packages feed

liquidhaskell 0.9.0.2.1 → 0.9.2.5.0

raw patch · 1151 files changed

+2258/−67904 lines, 1151 filesdep +liquidhaskell-bootdep −Cabaldep −Diffdep −aesondep ~basedep ~bytestringdep ~containersbuild-type:Customsetup-changed

Dependencies added: liquidhaskell-boot

Dependencies removed: Cabal, Diff, aeson, binary, cereal, cmdargs, data-default, data-fix, deepseq, directory, exceptions, extra, filepath, fingertree, free, ghc, ghc-boot, ghc-paths, githash, gitrev, hashable, hscolour, liquid-fixpoint, liquidhaskell, megaparsec, mtl, mustache, optics, optparse-applicative, pretty, process, recursion-schemes, shelly, split, syb, tasty, tasty-ant-xml, tasty-hunit, template-haskell, temporary, text, th-compat, time, transformers, unordered-containers, vector

Dependency ranges changed: base, bytestring, containers

This diff is very large; some files are shown as “too large to diff”. Download the raw patch for the complete diff.

Files

CHANGES.md view
@@ -1,7 +1,22 @@ # Changes -## NEXT 0.8.10.1+## NEXT 0.9.XX +## 0.9.2.5++- Introduce package liquidhaskell-boot and eliminate wrapper packages for boot libraries+- List all definitions used from the GHC API+- Allow LH to verify modules in parallel (remove withArgs call)+- Remove some calls to HashMap.toList which caused some non-determinisms in different machines+- Implement a Haskell script to plot performance without gnuplot++## 0.9.0.2++- **breaking change** Remove the implicit types mechanism and corresponding tests+- **breaking change** Remove the `decrease` keyword and mechanism in favor of the terminating expressions syntax (`/ [a,b]`)++## 0.8.10.1+ - Support for GHC 8.10.1 - LiquidHaskell is now available as a GHC Plugin @@ -38,22 +53,22 @@  ## 0.8.0.1 -- Support for GHC 8.0.2 +- Support for GHC 8.0.2  ## 0.7.0.1  - **DELETED** the gsDcons and generally carrying DataConP beyond Bare; this _may_ cause   problems with `target` as I removed the `dconEnv` field in `TargetState`. Is it live?-  To restore: have to apply the substitution syms/su in Bare.hs ALSO to gsDconsP (after +  To restore: have to apply the substitution syms/su in Bare.hs ALSO to gsDconsP (after   restoring the gsDconsP field to [(DataCon, DataConP)])  -- **breaking change** Remove the `Bool` vs. `Prop` distinction. This means that: +- **breaking change** Remove the `Bool` vs. `Prop` distinction. This means that: -    * signatures that use(d) `Prop` as a type, e.g. +    * signatures that use(d) `Prop` as a type, e.g.       `foo :: Int -> Prop` should just be `foo :: Int -> Bool`. -    * refinements that use(d) `Prop v` e.g. +    * refinements that use(d) `Prop v` e.g.       `isNull :: xs:[a] -> {v:Bool | Prop v <=> len xs > 0}`       should just be `isNull :: xs:[a] -> {v:Bool | v <=> len xs > 0}`. @@ -81,7 +96,7 @@  - Fixed a bug in the specification for `Data.Traversable.sequence` - Make interpreted mul and div the default, when `solver = z3`-- Use `--higherorder` to allow higher order binders into the fixpoint environment +- Use `--higherorder` to allow higher order binders into the fixpoint environment  ## 0.5.0.0 @@ -105,8 +120,8 @@  - Logical constraints: add extra subtyping constraints to signatures, e.g. -    {-@ -    (.) :: forall <p :: b -> c -> Prop, q :: a -> b -> Prop, r :: a -> c -> Prop>. +    {-@+    (.) :: forall <p :: b -> c -> Prop, q :: a -> b -> Prop, r :: a -> c -> Prop>.            {x::a, w::b<q x> |- c<p w> <: c<r x>}            (y:b -> c<p y>)         -> (z:a -> b<q z>)@@ -136,7 +151,7 @@ LiquidHaskell now *requires* ghc-7.8.3.  - Termination-LiquidHaskell will now attempt to prove all recursive functions terminating. It tries to prove that some parameter (or combination thereof) decreases at each recursive callsite. By default, this will be the first parameter with an associated size measure (see Size Measures), but can be overridden with the `Decreases` annotation or a termination expression (see Termination Expressions). +LiquidHaskell will now attempt to prove all recursive functions terminating. It tries to prove that some parameter (or combination thereof) decreases at each recursive callsite. By default, this will be the first parameter with an associated size measure (see Size Measures), but can be overridden with the `Decreases` annotation or a termination expression (see Termination Expressions).  If proving termination is too big of burden, it can be disabled on a per-module basis with the `--no-termination` flag, or on a per-function basis with the `Lazy` annotation. @@ -207,7 +222,7 @@ We have greatly improved our parser to require fewer parentheses! Yay!  - Emacs/Vim Support-LiquidHaskell now comes with syntax checkers for [flycheck](https://github.com/flycheck/flycheck) in Emacs and [syntastic](https://github.com/scrooloose/syntastic) in Vim. +LiquidHaskell now comes with syntax checkers for [flycheck](https://github.com/flycheck/flycheck) in Emacs and [syntastic](https://github.com/scrooloose/syntastic) in Vim.  - Incremental Checking LiquidHaskell has a new `--diffcheck` flag that will only check binders that have changed since the last run, which can drastically improve verification times.
README.md view
@@ -2,7 +2,6 @@   [![Hackage](https://img.shields.io/hackage/v/liquidhaskell.svg)](https://hackage.haskell.org/package/liquidhaskell) [![Hackage-Deps](https://img.shields.io/hackage-deps/v/liquidhaskell.svg)](http://packdeps.haskellers.com/feed?needle=liquidhaskell) [![Build Status](https://img.shields.io/circleci/project/ucsd-progsys/liquidhaskell/master.svg)](https://circleci.com/gh/ucsd-progsys/liquidhaskell)-[![Windows build status](https://ci.appveyor.com/api/projects/status/78y7uusjcgor5p16/branch/develop?svg=true)](https://ci.appveyor.com/project/varosi/liquidhaskell-nlhra/branch/develop)  This is the **development** site of the LiquidHaskell formal verification tool. @@ -21,12 +20,11 @@ * State as clearly as possible what is the problem you are facing; * Provide a small Haskell file producing the issue; * Write down the expected behaviour vs the actual behaviour;-* If possible, let us know if you have used the [plugin](install.md) or the [executable](legacy.md) and-  which _GHC version_ you are using.+* Please, let us know which liquidhaskell version you are using.  ## Your first Pull Request -We are thrilled to get PRs! Please follow these guidelines, as doing so will increase the chances of +We are thrilled to get PRs! Please follow these guidelines, as doing so will increase the chances of having your PR accepted:  * The main LH repo [lives here](https://github.com/ucsd-progsys/liquidhaskell)@@ -48,16 +46,16 @@  ## Fast (re)compilation -When working on the `liquidhaskell` library, usually all we want is to make changes and quickly recompile+When working on the `liquidhaskell-boot` library, usually all we want is to make changes and quickly recompile only the bare minimum, to try out new ideas. Using a fully-fledged GHC plugin doesn't help in this sense,-because packages like `liquid-base` or `liquid-ghc-prim` all have a direct dependency on `liquidhaskell`, and+because packages like `liquidhaskell` or `liquid-prelude` have a direct dependency on `liquidhaskell-boot`, and therefore every time the latter changes, an expensive rebuild of those packages is triggered, which might become tedious overtime. To mitigate this, we offer a faster, "dev-style" build mode which is based on the assumption that most changes to the `liquidhaskell` library do not alter the validity of-already-checked libraries, and therefore things like `liquid-base` and `liquid-ghc-prim` can be considered+already-checked libraries, and therefore things like `liquid-prelude` can be considered "static assets", avoiding the need for a recompilation. In other terms, we explicitly disable recompilation-of any of the `liquid-*` ancillary library in dev mode, so that rebuilds would also influence the -`liquidhaskell` library.+of any of the `liquid-*` ancillary library in dev mode, so that rebuilds only affect the+`liquidhaskell-boot` library.  ### Usage and recommended workflow @@ -65,13 +63,13 @@  * To begin with, perform a **full** build of **all** the libraries, by doing either `cabal v2-build` or `stack build`,   **without** specifying any extra environment variables from the command line. This is needed to ensure that-  we things like `liquid-base` and `liquid-ghc-prim` are compiled at least once, as we would need the+  things like `liquid-prelude` or `liquidhaskell` are compiled at least once, as we would need the   refinements they contain to correctly checks other downstream programs;  * At this point, the content of the `liquid-*` packages is considered "trusted" and "frozen", until you won't   force another full, _non-dev_ build; -* In order to quickly test changes to the `liquidhaskell` library without recompiling the `liquid-*` packages,+* In order to quickly test changes to the `liquidhaskell-boot` library without recompiling the `liquid-*` packages,   we need to start a build passing the `LIQUID_DEV_MODE` env var as part of the build command. Examples:  #### Stack@@ -99,7 +97,7 @@ permanently disable building the `liquid-*` packages, and this might silently mask breaking changes to the `liquidhaskell` library that would manifest only when compiling these other packages. -If you wish to force building all the libraries again, it's sufficient to issue the same builds commands +If you wish to force building all the libraries again, it's sufficient to issue the same builds commands without the `LIQUID_DEV_MODE`.  ## How To Run Regression Tests@@ -108,36 +106,29 @@ `README.md` in `tests/` or run `cabal run tests:test-driver -- --help` or `stack run test-driver -- --help` -_For a way of running the test suite for multiple GHC versions, consult the General Development FAQs. below_--There are particular scripts for running LH in the different modes, e.g. for different -compiler versions. These scripts are in:--    $ ./scripts/test--So you can run *all* the tests for say the ghc-8.10 version by+You can run *all* the tests by -    $ ./scripts/test/test_810_plugin.sh+    $ ./scripts/test/test_plugin.sh  You can run a bunch of particular test-groups instead by -    $ LIQUID_DEV_MODE=true ./scripts/test/test_810_plugin.sh <test-group-name1> <test-group-name2> ...+    $ LIQUID_DEV_MODE=true ./scripts/test/test_plugin.sh <test-group-name1> <test-group-name2> ... -and you can list all the possible test options with +and you can list all the possible test options with -    $ LIQUID_DEV_MODE=true ./scripts/test/test_810_plugin.sh --help+    $ LIQUID_DEV_MODE=true ./scripts/test/test_plugin.sh --help  or get a list of just the test groups, one per line, with -    $ LIQUID_DEV_MODE=true ./scripts/test/test_810_plugin.sh --show-all+    $ LIQUID_DEV_MODE=true ./scripts/test/test_plugin.sh --show-all -To pass in specific parameters and run a subset of the tests, you can invoke cabal directly with+To pass in specific parameters, you can invoke cabal directly with -    $ LIQUID_DEV_MODE=true cabal build tests:<test-group-name> --ghc-options=-fplugin-opt=LiquidHaskell:--no-termination MySpecificTest+    $ LIQUID_DEV_MODE=true cabal build tests:<test-group-name> --ghc-options=-fplugin-opt=LiquidHaskell:--no-termination  For example: -    $ LIQUID_DEV_MODE=true cabal build tests:unit-neg --ghc-options=--fplugin-opt=LiquidHaskell:--no-termination AbsApp+    $ LIQUID_DEV_MODE=true cabal build tests:unit-neg --ghc-options=-fplugin-opt=LiquidHaskell:--no-termination  Or your favorite number of threads, depending on cores etc. @@ -147,18 +138,16 @@  ### Parallelism in Tests -Most tests run in parallel, with a few module dependencies built sequentially in-advance. Benchmarks are run sequentially after all other tests have finished.-For details on adding tests, see note [Parallel_Tests] in `tests/test.hs`.+Tests run in parallel, unless the flag `--measure-timings` is specified to `test_plugin.sh`.  ## How to create performance comparison charts  When `liquidhaskell` tests run, we can collect timing information with -    $ ./scripts/test/test_810_plugin.sh --measure-timings+    $ ./scripts/test/test_plugin.sh --measure-timings -Measures will be collected in `.dump-timings` files. These can be converted to json-data with+Measures will be collected in `.dump-timings` files under `dist-newstyle` directory. These can be+converted to json data with  ```bash cabal v2-build ghc-timings@@ -173,18 +162,28 @@ ``` On each line, the report will contain the time taken by each test. -There is a script `scripts/plot-performance/chart_perf.sh` that can be-used to generate comparison charts in `svg` and `png` formats. It-requires [gnuplot](http://www.gnuplot.info/) to run. The following-command will produce two files `perf.svg` and `perf.png` in the-current directory.+Comparison charts in `svg` format can be generated by invoking +```+cabal v2-run plot-performance -- -b path_to_before_summary.csv -a path_to_after_summary.csv -s 50 -f "benchmark" -o outdir+```++This will generate three files `filtered.svg` (a subset of tests with a `benchmark` prefix, enabled by the `-f` option),+`top.svg` and `bot.svg` (top 50 speedups and slowdowns over the entire test set, both enabled by the `-s` option) under+the `outdir` directory. The `-f` and `-s` options can be used/omitted independently. If both are omitted, a single+`perf.svg` will be produced covering the full input test set. Additionally, their effects can be combined by providing+a third `-c` option (this will produce 2 files `filtered-top.svg` and `filtered-bot.svg` instead of 3).++There is also a legacy script `scripts/plot-performance/chart_perf.sh` that can be used to generate comparison charts+in both `svg` and `png` formats. It requires [gnuplot](http://www.gnuplot.info/) to run and assumes both files contain+the same test set. The following command will produce two files `perf.svg` and `perf.png` in the current directory.+     $ scripts/plot-performance/chart_perf.sh path_to_before_summary.csv path_to_after_summary.csv -The current formatting is optimized for comparing the outputs of running-the benchmarks alone.+The current formatting is optimized for comparing some subsets of the full test run, typically just the benchmarks alone.+If one wishes to save time or is not interested in top speedups/slowdowns, the benchmark subset can be obtained by running -    $ scripts/test/test_810_plugin.sh \+    $ scripts/test/test_plugin.sh \         benchmark-stitch-lh \         benchmark-bytestring \         benchmark-vector-algorithms \@@ -193,101 +192,14 @@         benchmark-icfp15-pos \         benchmark-icfp15-neg -## How to Profile--1. Build with profiling on--    ```-    $ stack build liquidhaskell --fast --profile-    ```--2. Run with profiling--    ```-    $ stack exec -- liquid range.hs +RTS -hc -p-    $ stack exec -- liquid range.hs +RTS -hy -p-    ```--    Followed by this which shows the stats file--    ```-    $ more liquid.prof-    ```--    or by this to see the graph--    ```-    $ hp2ps -e8in -c liquid.hp-    $ gv liquid.ps-    ```--    etc.--## How to Get Stack Traces On Exceptions--1. Build with profiling on--    ```-    $ stack build liquidhaskell --fast --profile-    ```--2. Run with backtraces--    ```-    $ liquid +RTS -xc -RTS foo.hs-    ```--    ```-    stack exec -- liquid List00.hs +RTS -p -xc -RTS-    ```--## Working With Submodules--To update the `liquid-fixpoint` submodule, run:--```-cd ./liquid-fixpoint-git fetch --all-git checkout <remote>/<branch>-cd ..-```--This will update `liquid-fixpoint` to the latest version on `<branch>` (usually `master`) -from `<remote>` (usually `origin`). After updating `liquid-fixpoint`, make sure to include this change in a-commit! Running:--```-git add ./liquid-fixpoint-```--will save the current commit hash of `liquid-fixpoint` in your next commit to the `liquidhaskell` repository.-For the best experience, **don't** make changes directly to the `./liquid-fixpoint` submodule, or else git-may get confused. Do any `liquid-fixpoint` development inside a separate clone/copy elsewhere. If something-goes wrong, run:--```-rm -r ./liquid-fixpoint-git submodule update --init-```--to blow away your copy of the `liquid-fixpoint` submodule and revert to the last saved commit hash.--Want to work fully offline? `git` lets you add a local directory as a remote. Run:--```-cd ./liquid-fixpoint-git remote add local /path/to/your/fixpoint/clone-cd ..-```+## Miscelaneous tasks -Then to update the submodule from your local clone, you can run:+* **Profiling** See the instructions in [scripts/profiling-driver/ProfilingDriver.hs](scripts/profiling-driver/ProfilingDriver.hs).+* **Getting stack traces on exceptions** See `-xc` flag in the [GHC user's guide][ghc-users-guide].+* **Working with submodules** See `man gitsubmodules` or the [git documentation site][git-documentation]. -```-cd ./liquid-fixpoint-git fetch local-git checkout local/<branch>-cd ..-```+[ghc-users-guide]: https://downloads.haskell.org/ghc/latest/docs/users_guide/+[git-documentation]: https://git-scm.com/doc  ## Releasing on Hackage @@ -356,27 +268,7 @@ The module [GHC.Plugin][] is the main entrypoint for all the plugin functionalities. Whenever possible, this module is reusing common functionalities from the [GHC.Interface][], which is the original module used to interface LH with the old executable. Generally speaking, the [GHC.Interface][] module is considered "legacy"-and it's rarely what one wants to modify. It will probably be removed once the old executable stops being-supported, with the functions now in use by the [GHC.Plugin][] being moved into the latter.--## The GhcMonadLike shim--Part of the tension in designing the plugin was trying to reuse as much code as possible from the original-[GHC.Interface][] shipped with LiquidHaskell. Unfortunately this was not possible from the get-go due to the-fact most of the functions provided by that module were requiring a [GhcMonad][] constraint or usually-living in the [Ghc monad][], which is also the only concrete type which derives an instance for [GhcMonad][].-While we could have run each and every function with `runGhc`, this was not very satisfactory due to the-fact running the `Ghc` monad is fairly expensive as it requires a bit of extra state in order to run it.--However, most of the functions used by the [Ghc.Interface][] didn't require anything specific from the-underlying [Ghc monad][] if not access to the [HscEnv][] and the ability to grab the [DynFlags][], as well-as doing `IO`. Therefore, the [GhcMonadLike][] shim was born with the intent of replicating some of the-functions used by the [GHC.Interface][] but crucially making those polymorphic in a generic [GhcMonadLike][]-for which we can give instances for `CoreM`, `TcM` etc. We can do this because we do not require the extra-`ExceptionMonad` constraint and we do not require to implement `setHscEnv`.--This allowed us to change ever so slightly the functions provided by the [GHC.Interface][], expose them and-reuse them in the [Plugin][] module.+and it's rarely what one wants to modify. It will probably be removed at some point.  ## Plugin architecture @@ -436,42 +328,18 @@ Typically the first thing you might want to do is to run a "clean" `cabal v2-build` or `stack build` using the latest compiler and "check the damage". If you are lucky, everything works out of the box, otherwise compilation might fail with an error, typically because some `ghc` API function has been removed/moved/renamed.-The way to fix it is to modify the [GHC.API][] shim module and perform any required change, likely by +The way to fix it is to modify the [GHC.API][] shim module and perform any required change, likely by conditionally compiling some code in a `CPP` block. For minor changes, it's usually enough to perform small changes, but for more tricky migrations it might be necessary to backport some GHC code, or create some-patter synonym to deal with changes in type constructors. You can see an example of this technique in-action by looking at the pattern synonym for [FunTy][].+patter synonym to deal with changes in type constructors.  ## Is there a way to run the testsuite for different versions of GHC? -Yes. The easiest way is to run one of the scripts inside the `scripts/test` directory. We provide scripts-to run the testsuite for a variety of GHC versions, mostly using `stack` but also with `cabal` (e.g.-`test_810_plugin.sh`). If run without arguments, the script will run the _full_ testsuite. If an argument-is given, only a particular pattern/test will be run. Running--```-./scripts/test/test_810_plugin.sh BST-```--will run all the tests which name matches "BST". In case the "fast recompilation" is desired, it's totally-possibly to pass `LIQUID_DEV_MODE` to the script, for example:--```-LIQUID_DEV_MODE=true ./scripts/test/test_810_plugin.sh-```--[GHC.API]: https://github.com/ucsd-progsys/liquidhaskell/blob/develop/src/Language/Haskell/Liquid/GHC/API.hs-[FunTy]: https://github.com/ucsd-progsys/liquidhaskell/blob/develop/src/Language/Haskell/Liquid/GHC/API.hs#L224+Currently, no. Only one version of GHC is supported and that is the one+that can be tested with `./scripts/test/test_plugin.sh`.  # GHC Plugin Development FAQs -## Is it possible that the behaviour of the old executable and the new / the plugin differ?--It might happen, yes, but the surface area is fairly small. Both modules work by producing a [TargetSrc][]-that is passed to the internal LH API, which is shared by _both_ modules. Therefore, any difference in -behaviour has to be researched in the code path that produces such [TargetSrc][]. For the [GHC.Plugin][] this-happens in the `makeTargetSrc`, whereas for the [GHC.Interface][] this happens inside the [makeGhcSrc][] function.- ## Why is the GHC.Interface using slightly different types than the GHC.Plugin module?  Mostly for backward-compatibility and for historical reasons. Types like [BareSpec][] used to be type alias@@ -481,24 +349,23 @@ **consider the GHC.Plugin as the single source of truth, and prefer whichever data structure the latter is using**. --[Plugin]:              https://github.com/ucsd-progsys/liquidhaskell/blob/9a2f8284c5fe5b18ed0410e842acd3329a629a6b/src/Language/Haskell/Liquid/GHC/Plugin.hs-[GHC.Plugin]:          https://github.com/ucsd-progsys/liquidhaskell/blob/9a2f8284c5fe5b18ed0410e842acd3329a629a6b/src/Language/Haskell/Liquid/GHC/Plugin.hs-[GHC.Interface]:       https://github.com/ucsd-progsys/liquidhaskell/blob/9a2f8284c5fe5b18ed0410e842acd3329a629a6b/src/Language/Haskell/Liquid/GHC/Interface.hs-[SpecFinder]:          https://github.com/ucsd-progsys/liquidhaskell/blob/9a2f8284c5fe5b18ed0410e842acd3329a629a6b/src/Language/Haskell/Liquid/GHC/Plugin/SpecFinder.hs-[BareSpec]:            https://github.com/ucsd-progsys/liquidhaskell/blob/9a2f8284c5fe5b18ed0410e842acd3329a629a6b/src/Language/Haskell/Liquid/Types/Specs.hs#L301-[LiftedSpec]:          https://github.com/ucsd-progsys/liquidhaskell/blob/9a2f8284c5fe5b18ed0410e842acd3329a629a6b/src/Language/Haskell/Liquid/Types/Specs.hs#L476-[TargetSrc]:           https://github.com/ucsd-progsys/liquidhaskell/blob/9a2f8284c5fe5b18ed0410e842acd3329a629a6b/src/Language/Haskell/Liquid/Types/Specs.hs#L160-[Ghc monad]:           https://hackage.haskell.org/package/ghc-8.10.1/docs/GHC.html#t:Ghc-[HscEnv]:              https://hackage.haskell.org/package/ghc-8.10.1/docs/GHC.html#t:HscEnv-[DynFlags]:            https://hackage.haskell.org/package/ghc-8.10.1/docs/GHC.html#t:DynFlags-[GhcMonad]:            https://hackage.haskell.org/package/ghc-8.10.1/docs/GHC.html#t:GhcMonad-[GhcMonadLike]:        https://github.com/ucsd-progsys/liquidhaskell/blob/9a2f8284c5fe5b18ed0410e842acd3329a629a6b/src/Language/Haskell/Liquid/GHC/GhcMonadLike.hs-[typechecking phase]:  https://github.com/ucsd-progsys/liquidhaskell/blob/9a2f8284c5fe5b18ed0410e842acd3329a629a6b/src/Language/Haskell/Liquid/GHC/Plugin.hs#L196-L224+[GHC.API]:             liquidhaskell-boot/src-ghc/Liquid/GHC/API.hs+[Plugin]:              liquidhaskell-boot/src/Language/Haskell/Liquid/GHC/Plugin.hs+[GHC.Plugin]:          liquidhaskell-boot/src/Language/Haskell/Liquid/GHC/Plugin.hs+[GHC.Interface]:       liquidhaskell-boot/src/Language/Haskell/Liquid/GHC/Interface.hs+[SpecFinder]:          liquidhaskell-boot/src/Language/Haskell/Liquid/GHC/Plugin/SpecFinder.hs+[BareSpec]:            liquidhaskell-boot/src/Language/Haskell/Liquid/Types/Specs.hs#L362+[LiftedSpec]:          liquidhaskell-boot/src/Language/Haskell/Liquid/Types/Specs.hs#L559+[TargetSrc]:           liquidhaskell-boot/src/Language/Haskell/Liquid/Types/Specs.hs#L158+[Ghc monad]:           https://hackage.haskell.org/package/ghc-9.2.5/docs/GHC.html#t:Ghc+[HscEnv]:              https://hackage.haskell.org/package/ghc-9.2.5/docs/GHC.html#t:HscEnv+[DynFlags]:            https://hackage.haskell.org/package/ghc-9.2.5/docs/GHC.html#t:DynFlags+[GhcMonad]:            https://hackage.haskell.org/package/ghc-9.2.5/docs/GHC.html#t:GhcMonad+[typechecking phase]:  liquidhaskell-boot/src/Language/Haskell/Liquid/GHC/Plugin.hs#L211-L226 [ghcide]:              https://github.com/haskell/ghcide-[findRelevantSpecs]:   https://github.com/ucsd-progsys/liquidhaskell/blob/9a2f8284c5fe5b18ed0410e842acd3329a629a6b/src/Language/Haskell/Liquid/GHC/Plugin/SpecFinder.hs#L61-[core binds]:          https://hackage.haskell.org/package/ghc-8.10.1/docs/CoreSyn.html#t:CoreBind-[configureGhcTargets]: https://github.com/ucsd-progsys/liquidhaskell/blob/9a2f8284c5fe5b18ed0410e842acd3329a629a6b/src/Language/Haskell/Liquid/GHC/Interface.hs#L268-[processTargetModule]: https://github.com/ucsd-progsys/liquidhaskell/blob/9a2f8284c5fe5b18ed0410e842acd3329a629a6b/src/Language/Haskell/Liquid/GHC/Interface.hs#L468-[processModule]:       https://github.com/ucsd-progsys/liquidhaskell/blob/9a2f8284c5fe5b18ed0410e842acd3329a629a6b/src/Language/Haskell/Liquid/GHC/Plugin.hs#L393+[findRelevantSpecs]:   liquidhaskell-boot/src/Language/Haskell/Liquid/GHC/Plugin/SpecFinder.hs#L65+[core binds]:          https://hackage.haskell.org/package/ghc-9.2.5/docs/CoreSyn.html#t:CoreBind+[configureGhcTargets]: liquidhaskell-boot/src/Language/Haskell/Liquid/GHC/Interface.hs#L254+[processTargetModule]: liquidhaskell-boot/src/Language/Haskell/Liquid/GHC/Interface.hs#L483+[processModule]:       liquidhaskell-boot/src/Language/Haskell/Liquid/GHC/Plugin.hs#L509
Setup.hs view
@@ -1,12 +1,6 @@-import Distribution.Simple--+module Main where -main = defaultMain+import Language.Haskell.Liquid.Cabal (liquidHaskellMain) --- --- --- main = defaultMainWithHooks fixpointHooks ---  --- fixpointHooks   = defaultUserHooks { postInst = cpFix }---    where ---      cpFix _ _ _ lbi = putStrLn $ "CPFIXSAYS: " ++ show lbi  +main :: IO ()+main = liquidHaskellMain
− devel/Paths_liquidhaskell.hs 
@@ -1,18 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Paths_liquidhaskell where--import Language.Haskell.TH-import System.Directory-import System.FilePath-import Data.Version (Version, makeVersion)--getDataFileName :: FilePath -> IO FilePath-getDataFileName fp = do-  let loc' = $(do { loc <- location; f <- runIO (canonicalizePath (loc_filename loc)); litE (stringL f); })-  let root = takeDirectory (takeDirectory loc')-  return (root </> fp)---- | dummy version (devel only)-version :: Version-version = makeVersion [0,0,0,0]
− exe/Liquid.hs 
@@ -1,6 +0,0 @@-import Language.Haskell.Liquid.Liquid (liquid)-import System.Environment             (getArgs)--- import GhcTest --main :: IO a-main = liquid =<< getArgs
− include/710/Data/Traversable.spec 
@@ -1,3 +0,0 @@-module spec Data.Traversable where--Data.Traversable.sequence :: Data.Traversable.Traversable t => forall m a. GHC.Base.Monad m => xs:t (m a) -> m ({v:t a | len v = len xs})
− include/Bot.hquals 
@@ -1,8 +0,0 @@-//BOT: Do not delete EVER!--qualif Bot(v:@(0))    : 0 = 1 -qualif Bot(v:obj)     : 0 = 1 -qualif Bot(v:a)       : 0 = 1 -qualif Bot(v:bool)    : 0 = 1 -qualif Bot(v:int)     : 0 = 1 -
− include/Control/Exception.spec 
@@ -1,5 +0,0 @@-module spec Control.Exception where--//  Useless as compiled into GHC primitive, which is ignored-assume assert :: {v:Bool | v } -> a -> a-
− include/Control/Parallel/Strategies.spec 
@@ -1,3 +0,0 @@-module spec Control.Parallel.Strategies where--assume withStrategy :: Control.Parallel.Strategies.Strategy a -> x:a -> {v:a | v == x}
− include/CoreToLogic.lg 
@@ -1,49 +0,0 @@-define Data.Set.Base.singleton x      = (Set_sng x)-define Data.Set.Base.union x y        = (Set_cup x y)-define Data.Set.Base.intersection x y = (Set_cap x y)-define Data.Set.Base.difference x y   = (Set_dif x y)-define Data.Set.Base.empty            = (Set_empty 0)-define Data.Set.Base.null x           = (Set_emp x)-define Data.Set.Base.member x xs      = (Set_mem x xs)-define Data.Set.Base.isSubsetOf x y   = (Set_sub x y)-define Data.Set.Base.fromList xs      = (listElts xs)--define Data.Set.Internal.singleton x      = (Set_sng x)-define Data.Set.Internal.union x y        = (Set_cup x y)-define Data.Set.Internal.intersection x y = (Set_cap x y)-define Data.Set.Internal.difference x y   = (Set_dif x y)-define Data.Set.Internal.empty            = (Set_empty 0)-define Data.Set.Internal.null x           = (Set_emp x)-define Data.Set.Internal.member x xs      = (Set_mem x xs)-define Data.Set.Internal.isSubsetOf x y   = (Set_sub x y)-define Data.Set.Internal.fromList xs      = (listElts xs)--define GHC.Real.fromIntegral x = (x)--define GHC.Types.True                 = (true)-define GHC.Real.div x y               = (x / y)-define GHC.Real.mod x y               = (x mod y)-define GHC.Classes.not x              = (~ x)-define GHC.Base.$ f x                 = (f x)--define Language.Haskell.Liquid.Bag.get k m   = (Map_select m k)-define Language.Haskell.Liquid.Bag.put k m   = (Map_store m k (1 + (Map_select m k)))-define Language.Haskell.Liquid.Bag.union m n = (Map_union  m n)-define Language.Haskell.Liquid.Bag.empty     = (Map_default 0)--define Data.Map.Base.insert k v m     = (Map_store m k v)-define Data.Map.Base.select k v       = (Map_select m k)--define Language.Haskell.Liquid.String.stringEmp = (stringEmp)-define Data.RString.RString.stringEmp = (stringEmp)-define String.stringEmp  = (stringEmp)-define Main.mempty       = (mempty)-define Language.Haskell.Liquid.ProofCombinators.cast x y = (y)-define Language.Haskell.Liquid.ProofCombinators.withProof x y = (x)-define ProofCombinators.cast x y = (y)-define Liquid.ProofCombinators.cast x y = (y)-define Control.Parallel.Strategies.withStrategy s x = (x)--define Language.Haskell.Liquid.Equational.eq x y = (y)--define GHC.CString.unpackCString# x = x
− include/Data/Bits.spec 
@@ -1,6 +0,0 @@-module spec Data.Bits where--//  TODO: cannot use this because `Bits` is not a `Num`-//  Data.Bits.shiftR :: (Data.Bits.Bits a) => x:a -> d:Nat -//                   -> {v:a | ((d=1) => (x <= 2*v + 1 && 2*v <= x)) }-
− include/Data/ByteString.spec 
@@ -1,375 +0,0 @@-module spec Data.ByteString where--import Data.String--measure bslen :: Data.ByteString.ByteString -> { n : Int | 0 <= n }--invariant { bs : Data.ByteString.ByteString  | 0 <= bslen bs }--invariant { bs : Data.ByteString.ByteString | bslen bs == stringlen bs }--empty :: { bs : Data.ByteString.ByteString | bslen bs == 0 }--singleton :: _ -> { bs : Data.ByteString.ByteString | bslen bs == 1 }--pack :: w8s : [_]-     -> { bs : Data.ByteString.ByteString | bslen bs == len w8s }--unpack :: bs : Data.ByteString.ByteString-       -> { w8s : [_] | len w8s == bslen bs }--cons :: _-     -> i : Data.ByteString.ByteString-     -> { o : Data.ByteString.ByteString | bslen o == bslen i + 1 }--snoc :: i : Data.ByteString.ByteString-     -> _-     -> { o : Data.ByteString.ByteString | bslen o == bslen i + 1 }--append :: l : Data.ByteString.ByteString-       -> r : Data.ByteString.ByteString-       -> { o : Data.ByteString.ByteString | bslen o == bslen l + bslen r }--head :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> _--unsnoc :: i:Data.ByteString.ByteString -       -> (Maybe ({ o : Data.ByteString.ByteString | bslen o == bslen i - 1 }, _))--last :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> _--tail :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> _--init -  :: {i:Data.ByteString.ByteString | 1 <= bslen i } -  -> {o:Data.ByteString.ByteString | bslen o == bslen i - 1 }--null -  :: bs : Data.ByteString.ByteString-  -> { b : GHC.Types.Bool | b <=> bslen bs == 0 }--length :: bs : Data.ByteString.ByteString -> { n : Int | bslen bs == n }--map -  :: (_ -> _)-  -> i : Data.ByteString.ByteString-  -> { o : Data.ByteString.ByteString | bslen o == bslen i }--reverse -  :: i : Data.ByteString.ByteString-  -> { o : Data.ByteString.ByteString | bslen o == bslen i }--intersperse -  :: _-  -> i : Data.ByteString.ByteString-  -> { o : Data.ByteString.ByteString | (bslen i == 0 <=> bslen o == 0) && (1 <= bslen i <=> bslen o == 2 * bslen i - 1) }--intercalate -  :: l : Data.ByteString.ByteString-  -> rs : [Data.ByteString.ByteString]-  -> { o : Data.ByteString.ByteString | len rs == 0 ==> bslen o == 0 }--transpose -  :: is : [Data.ByteString.ByteString]-  -> { os : [{ bs : Data.ByteString.ByteString | bslen bs <= len is }] | len is == 0 ==> len os == 0}--foldl1 -  :: (_ -> _ -> _)-  -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }-  -> _--foldl1' -  :: (_ -> _ -> _)-  -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }-  -> _--foldr1 -  :: (_ -> _ -> _)-  -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }-  -> _--foldr1' -  :: (_ -> _ -> _)-  -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }-  -> _--concat -  :: is : [Data.ByteString.ByteString] -  -> { o : Data.ByteString.ByteString | (len is == 0) ==> (bslen o == 0) }--concatMap -  :: (_ -> Data.ByteString.ByteString)-  -> i : Data.ByteString.ByteString-  -> { o : Data.ByteString.ByteString | bslen i == 0 ==> bslen o == 0 }--any -  :: (_ -> GHC.Types.Bool)-  -> bs : Data.ByteString.ByteString-  -> { b : GHC.Types.Bool | bslen bs == 0 ==> not b }--all -  :: (_ -> GHC.Types.Bool)-  -> bs : Data.ByteString.ByteString-  -> { b : GHC.Types.Bool | bslen bs == 0 ==> b }--maximum :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> _--minimum :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> _--scanl :: (_ -> _ -> _)-      -> _-      -> i : Data.ByteString.ByteString-      -> { o : Data.ByteString.ByteString | bslen o == bslen i }--scanl1 :: (_ -> _ -> _)-       -> i : { i : Data.ByteString.ByteString | 1 <= bslen i }-       -> { o : Data.ByteString.ByteString | bslen o == bslen i }--scanr-    :: (_ -> _ -> _)-    -> _-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o == bslen i }--scanr1-    :: (_ -> _ -> _)-    -> i : { i : Data.ByteString.ByteString | 1 <= bslen i }-    -> { o : Data.ByteString.ByteString | bslen o == bslen i }--mapAccumL-    :: (acc -> _ -> (acc, _))-    -> acc-    -> i : Data.ByteString.ByteString-    -> (acc, { o : Data.ByteString.ByteString | bslen o == bslen i })--mapAccumR-    :: (acc -> _ -> (acc, _))-    -> acc-    -> i : Data.ByteString.ByteString-    -> (acc, { o : Data.ByteString.ByteString | bslen o == bslen i })--replicate-    :: n : Int-    -> _-    -> { bs : Data.ByteString.ByteString | bslen bs == n }--unfoldrN-    :: n : Int-    -> (a -> Maybe (_, a))-    -> a-    -> ({ bs : Data.ByteString.ByteString | bslen bs <= n }, Maybe a)--take-    :: n : Int-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | (n <= 0 <=> bslen o == 0) &&-                                          ((0 <= n && n <= bslen i) <=> bslen o == n) &&-                                          (bslen i <= n <=> bslen o = bslen i) }--drop-    :: n : Int-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | (n <= 0 <=> bslen o == bslen i) &&-                                          ((0 <= n && n <= bslen i) <=> bslen o == bslen i - n) &&-                                          (bslen i <= n <=> bslen o == 0) }--splitAt-    :: n : Int-    -> i : Data.ByteString.ByteString-    -> ( { l : Data.ByteString.ByteString | (n <= 0 <=> bslen l == 0) &&-                                            ((0 <= n && n <= bslen i) <=> bslen l == n) &&-                                            (bslen i <= n <=> bslen l == bslen i) }-       , { r : Data.ByteString.ByteString | (n <= 0 <=> bslen r == bslen i) &&-                                            ((0 <= n && n <= bslen i) <=> bslen r == bslen i - n) &&-                                            (bslen i <= n <=> bslen r == 0) }-       )--takeWhile-    :: (_ -> GHC.Types.Bool)-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o <= bslen i }--dropWhile-    :: (_ -> GHC.Types.Bool)-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o <= bslen i }--span-    :: (_ -> GHC.Types.Bool)-    -> i : Data.ByteString.ByteString-    -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }-       , { r : Data.ByteString.ByteString | bslen r <= bslen i }-       )--spanEnd-    :: (_ -> GHC.Types.Bool)-    -> i : Data.ByteString.ByteString-    -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }-       , { r : Data.ByteString.ByteString | bslen r <= bslen i }-       )--break-    :: (_ -> GHC.Types.Bool)-    -> i : Data.ByteString.ByteString-    -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }-       , { r : Data.ByteString.ByteString | bslen r <= bslen i }-       )--breakEnd-    :: (_ -> GHC.Types.Bool)-    -> i : Data.ByteString.ByteString-    -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }-       , { r : Data.ByteString.ByteString | bslen r <= bslen i }-       )--group-    :: i : Data.ByteString.ByteString-    -> [{ o : Data.ByteString.ByteString | 1 <= bslen o && bslen o <= bslen i }]--groupBy-    :: (_ -> _ -> GHC.Types.Bool)-    -> i : Data.ByteString.ByteString-    -> [{ o : Data.ByteString.ByteString | 1 <= bslen o && bslen o <= bslen i }]--inits-    :: i : Data.ByteString.ByteString-    -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]--tails-    :: i : Data.ByteString.ByteString-    -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]--split-    :: _-    -> i : Data.ByteString.ByteString-    -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]--splitWith-    :: (_ -> GHC.Types.Bool)-    -> i : Data.ByteString.ByteString-    -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]--isPrefixOf-    :: l : Data.ByteString.ByteString-    -> r : Data.ByteString.ByteString-    -> { b : GHC.Types.Bool | bslen l >= bslen r ==> not b }--isSuffixOf-    :: l : Data.ByteString.ByteString-    -> r : Data.ByteString.ByteString-    -> { b : GHC.Types.Bool | bslen l > bslen r ==> not b }--isInfixOf-    :: l : Data.ByteString.ByteString-    -> r : Data.ByteString.ByteString-    -> { b : GHC.Types.Bool | bslen l > bslen r ==> not b }--breakSubstring-    :: il : Data.ByteString.ByteString-    -> ir : Data.ByteString.ByteString-    -> ( { ol : Data.ByteString.ByteString | bslen ol <= bslen ir && (bslen il > bslen ir ==> bslen ol == bslen ir)}-       , { or : Data.ByteString.ByteString | bslen or <= bslen ir && (bslen il > bslen ir ==> bslen or == 0) }-       )--elem-    :: _-    -> bs : Data.ByteString.ByteString-    -> { b : GHC.Types.Bool | bslen bs == 0 ==> not b }--notElem-    :: _-    -> bs : Data.ByteString.ByteString-    -> { b : GHC.Types.Bool | bslen bs == 0 ==> b }--find-    :: (_ -> GHC.Types.Bool)-    -> bs : Data.ByteString.ByteString-    -> (Maybe { w8 : _ | bslen bs /= 0 })--filter-    :: (_ -> GHC.Types.Bool)-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o <= bslen i }--partition-    :: (_ -> GHC.Types.Bool)-    -> i : Data.ByteString.ByteString-    -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }-       , { r : Data.ByteString.ByteString | bslen r <= bslen i }-       )--index :: bs : Data.ByteString.ByteString -> { n : Int | 0 <= n && n < bslen bs } -> _--elemIndex-    :: _-    -> bs : Data.ByteString.ByteString-    -> (Maybe { n : Int | 0 <= n && n < bslen bs })--elemIndices-    :: _-    -> bs : Data.ByteString.ByteString-    -> [{ n : Int | 0 <= n && n < bslen bs }]--elemIndexEnd-    :: _-    -> bs : Data.ByteString.ByteString-    -> (Maybe { n : Int | 0 <= n && n < bslen bs })--findIndex-    :: (_ -> GHC.Types.Bool)-    -> bs : Data.ByteString.ByteString-    -> (Maybe { n : Int | 0 <= n && n < bslen bs })--findIndices-    :: (_ -> GHC.Types.Bool)-    -> bs : Data.ByteString.ByteString-    -> [{ n : Int | 0 <= n && n < bslen bs }]--count-    :: _-    -> bs : Data.ByteString.ByteString-    -> { n : Int | 0 <= n && n < bslen bs }--zip-    :: l : Data.ByteString.ByteString-    -> r : Data.ByteString.ByteString-    -> { o : [(_, _)] | len o <= bslen l && len o <= bslen r }--zipWith-    :: (_ -> _ -> a)-    -> l : Data.ByteString.ByteString-    -> r : Data.ByteString.ByteString-    -> { o : [a] | len o <= bslen l && len o <= bslen r }--unzip-    :: i : [(_, _)]-    -> ( { l : Data.ByteString.ByteString | bslen l == len i }-       , { r : Data.ByteString.ByteString | bslen r == len i }-       )--sort-    :: i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o == bslen i }--copy-    :: i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o == bslen i }--hGet-    :: _-    -> n : { n : Int | 0 <= n }-    -> (IO { bs : Data.ByteString.ByteString | bslen bs == n || bslen bs == 0 })--hGetSome-    :: _-    -> n : { n : Int | 0 <= n }-    -> (IO { bs : Data.ByteString.ByteString | bslen bs <= n })--hGetNonBlocking-    :: _-    -> n : { n : Int | 0 <= n }-    -> (IO { bs : Data.ByteString.ByteString | bslen bs <= n })--uncons-    :: i : Data.ByteString.ByteString-    -> (Maybe (_, { o : Data.ByteString.ByteString | bslen o == bslen i - 1 }))-
− include/Data/ByteString/Char8.spec 
@@ -1,402 +0,0 @@-module spec Data.ByteString.Char8 where--import Data.ByteString --assume empty :: { bs : Data.ByteString.ByteString | bslen bs == 0 }--assume singleton-    :: Char -> { bs : Data.ByteString.ByteString | bslen bs == 1 }--assume pack-    :: w8s : [Char]-    -> { bs : Data.ByteString.ByteString | bslen bs == len w8s }--assume unpack-    :: bs : Data.ByteString.ByteString-    -> { w8s : [Char] | len w8s == bslen bs }--assume cons-    :: Char-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o == bslen i + 1 }--assume snoc-    :: i : Data.ByteString.ByteString-    -> Char-    -> { o : Data.ByteString.ByteString | bslen o == bslen i + 1 }--assume append-    :: l : Data.ByteString.ByteString-    -> r : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o == bslen l + bslen r }--head :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> Char--assume uncons-    :: i : Data.ByteString.ByteString-    -> Maybe (Char, { o : Data.ByteString.ByteString | bslen o == bslen i - 1 })--assume unsnoc-    :: i : Data.ByteString.ByteString-    -> Maybe ({ o : Data.ByteString.ByteString | bslen o == bslen i - 1 }, Char)--assume last :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> Char--assume tail :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> Char--assume init :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> Char--assume null-    :: bs : Data.ByteString.ByteString-    -> { b : GHC.Types.Bool | b <=> bslen bs == 0 }--assume length :: bs : Data.ByteString.ByteString -> { n : Int | bslen bs == n }--assume map-    :: (Char -> Char)-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o == bslen i }--assume reverse-    :: i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o == bslen i }--assume intersperse-    :: Char-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | (bslen i == 0 <=> bslen o == 0) && (1 <= bslen i <=> bslen o == 2 * bslen i - 1) }--assume intercalate-    :: l : Data.ByteString.ByteString-    -> rs : [Data.ByteString.ByteString]-    -> { o : Data.ByteString.ByteString | len rs == 0 ==> bslen o == 0 }--assume transpose-    :: is : [Data.ByteString.ByteString]-    -> { os : [{ bs : Data.ByteString.ByteString | bslen bs <= len is }] | len is == 0 ==> len os == 0}--foldl1-    :: (Char -> Char -> Char)-    -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }-    -> Char--foldl1'-    :: (Char -> Char -> Char)-    -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }-    -> Char--foldr1-    :: (Char -> Char -> Char)-    -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }-    -> Char--foldr1'-    :: (Char -> Char -> Char)-    -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }-    -> Char--assume concat-    :: is : [Data.ByteString.ByteString]-    -> { o : Data.ByteString.ByteString | len is == 0 ==> bslen o }--assume concatMap-    :: (Char -> Data.ByteString.ByteString)-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen i == 0 ==> bslen o == 0 }--assume any :: (Char -> GHC.Types.Bool)-    -> bs : Data.ByteString.ByteString-    -> { b : GHC.Types.Bool | bslen bs == 0 ==> not b }--assume all :: (Char -> GHC.Types.Bool)-    -> bs : Data.ByteString.ByteString-    -> { b : GHC.Types.Bool | bslen bs == 0 ==> b }--maximum-    :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> Char--minimum-    :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> Char--assume scanl-    :: (Char -> Char -> Char)-    -> Char-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o == bslen i }--assume scanl1-    :: (Char -> Char -> Char)-    -> i : { i : Data.ByteString.ByteString | 1 <= bslen i }-    -> { o : Data.ByteString.ByteString | bslen o == bslen i }--assume scanr-    :: (Char -> Char -> Char)-    -> Char-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o == bslen i }--assume scanr1-    :: (Char -> Char -> Char)-    -> i : { i : Data.ByteString.ByteString | 1 <= bslen i }-    -> { o : Data.ByteString.ByteString | bslen o == bslen i }--assume mapAccumL-    :: (acc -> Char -> (acc, Char))-    -> acc-    -> i : Data.ByteString.ByteString-    -> (acc, { o : Data.ByteString.ByteString | bslen o == bslen i })--assume mapAccumR-    :: (acc -> Char -> (acc, Char))-    -> acc-    -> i : Data.ByteString.ByteString-    -> (acc, { o : Data.ByteString.ByteString | bslen o == bslen i })--assume replicate-    :: n : Int-    -> Char-    -> { bs : Data.ByteString.ByteString | bslen bs == n }--assume unfoldrN-    :: n : Int-    -> (a -> Maybe (Char, a))-    -> a-    -> ({ bs : Data.ByteString.ByteString | bslen bs <= n }, Maybe a)--assume take-    :: n : Int-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | (n <= 0 <=> bslen o == 0) &&-                                          ((0 <= n && n <= bslen i) <=> bslen o == n) &&-                                          (bslen i <= n <=> bslen o = bslen i) }--assume drop-    :: n : Int-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | (n <= 0 <=> bslen o == bslen i) &&-                                          ((0 <= n && n <= bslen i) <=> bslen o == bslen i - n) &&-                                          (bslen i <= n <=> bslen o == 0) }--assume splitAt-    :: n : Int-    -> i : Data.ByteString.ByteString-    -> ( { l : Data.ByteString.ByteString | (n <= 0 <=> bslen l == 0) &&-                                            ((0 <= n && n <= bslen i) <=> bslen l == n) &&-                                            (bslen i <= n <=> bslen l == bslen i) }-       , { r : Data.ByteString.ByteString | (n <= 0 <=> bslen r == bslen i) &&-                                            ((0 <= n && n <= bslen i) <=> bslen r == bslen i - n) &&-                                            (bslen i <= n <=> bslen r == 0) }-       )--assume takeWhile-    :: (Char -> GHC.Types.Bool)-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o <= bslen i }--assume dropWhile-    :: (Char -> GHC.Types.Bool)-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o <= bslen i }--assume span-    :: (Char -> GHC.Types.Bool)-    -> i : Data.ByteString.ByteString-    -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }-       , { r : Data.ByteString.ByteString | bslen r <= bslen i }-       )--assume spanEnd-    :: (Char -> GHC.Types.Bool)-    -> i : Data.ByteString.ByteString-    -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }-       , { r : Data.ByteString.ByteString | bslen r <= bslen i }-       )--assume break-    :: (Char -> GHC.Types.Bool)-    -> i : Data.ByteString.ByteString-    -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }-       , { r : Data.ByteString.ByteString | bslen r <= bslen i }-       )--assume breakEnd-    :: (Char -> GHC.Types.Bool)-    -> i : Data.ByteString.ByteString-    -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }-       , { r : Data.ByteString.ByteString | bslen r <= bslen i }-       )--assume group-    :: i : Data.ByteString.ByteString-    -> [{ o : Data.ByteString.ByteString | 1 <= bslen o && bslen o <= bslen i }]--assume groupBy-    :: (Char -> Char -> GHC.Types.Bool)-    -> i : Data.ByteString.ByteString-    -> [{ o : Data.ByteString.ByteString | 1 <= bslen o && bslen o <= bslen i }]--assume inits-    :: i : Data.ByteString.ByteString-    -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]--assume tails-    :: i : Data.ByteString.ByteString-    -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]--assume split-    :: Char-    -> i : Data.ByteString.ByteString-    -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]--assume splitWith-    :: (Char -> GHC.Types.Bool)-    -> i : Data.ByteString.ByteString-    -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]--assume lines-    :: i : Data.ByteString.ByteString-    -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]--assume words-    :: i : Data.ByteString.ByteString-    -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]--assume unlines-    :: is : [Data.ByteString.ByteString]-    -> { o : Data.ByteString.ByteString | (len is == 0 <=> bslen o == 0) && bslen o >= len is }--assume unwords-    :: is : [Data.ByteString.ByteString]-    -> { o : Data.ByteString.ByteString | (len is == 0 ==> bslen o == 0) && (1 <= len is ==> bslen o >= len is - 1) }--assume isPrefixOf-    :: l : Data.ByteString.ByteString-    -> r : Data.ByteString.ByteString-    -> { b : GHC.Types.Bool | bslen l >= bslen r ==> not b }--assume isSuffixOf-    :: l : Data.ByteString.ByteString-    -> r : Data.ByteString.ByteString-    -> { b : GHC.Types.Bool | bslen l > bslen r ==> not b }--assume isInfixOf-    :: l : Data.ByteString.ByteString-    -> r : Data.ByteString.ByteString-    -> { b : GHC.Types.Bool | bslen l > bslen r ==> not b }--assume breakSubstring-    :: il : Data.ByteString.ByteString-    -> ir : Data.ByteString.ByteString-    -> ( { ol : Data.ByteString.ByteString | bslen ol <= bslen ir && (bslen il > bslen ir ==> bslen ol == bslen ir)}-       , { or : Data.ByteString.ByteString | bslen or <= bslen ir && (bslen il > bslen ir ==> bslen or == 0) }-       )--assume elem-    :: Char-    -> bs : Data.ByteString.ByteString-    -> { b : GHC.Types.Bool | bslen bs == 0 ==> not b }--assume notElem-    :: Char-    -> bs : Data.ByteString.ByteString-    -> { b : GHC.Types.Bool | bslen bs == 0 ==> b }--assume find-    :: (Char -> GHC.Types.Bool)-    -> bs : Data.ByteString.ByteString-    -> Maybe { w8 : Char | bslen bs /= 0 }--assume filter-    :: (Char -> GHC.Types.Bool)-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o <= bslen i }--index-    :: bs : Data.ByteString.ByteString-    -> { n : Int | 0 <= n && n < bslen bs }-    -> Char--assume elemIndex-    :: Char-    -> bs : Data.ByteString.ByteString-    -> Maybe { n : Int | 0 <= n && n < bslen bs }--assume elemIndices-    :: Char-    -> bs : Data.ByteString.ByteString-    -> [{ n : Int | 0 <= n && n < bslen bs }]--assume elemIndexEnd-    :: Char-    -> bs : Data.ByteString.ByteString-    -> Maybe { n : Int | 0 <= n && n < bslen bs }--assume findIndex-    :: (Char -> GHC.Types.Bool)-    -> bs : Data.ByteString.ByteString-    -> Maybe { n : Int | 0 <= n && n < bslen bs }--assume findIndices-    :: (Char -> GHC.Types.Bool)-    -> bs : Data.ByteString.ByteString-    -> [{ n : Int | 0 <= n && n < bslen bs }]--assume count-    :: Char-    -> bs : Data.ByteString.ByteString-    -> { n : Int | 0 <= n && n < bslen bs }--assume zip-    :: l : Data.ByteString.ByteString-    -> r : Data.ByteString.ByteString-    -> { o : [(Char, Char)] | len o <= bslen l && len o <= bslen r }--assume zipWith-    :: (Char -> Char -> a)-    -> l : Data.ByteString.ByteString-    -> r : Data.ByteString.ByteString-    -> { o : [a] | len o <= bslen l && len o <= bslen r }--assume unzip-    :: i : [(Char, Char)]-    -> ( { l : Data.ByteString.ByteString | bslen l == len i }-       , { r : Data.ByteString.ByteString | bslen r == len i }-       )--assume sort-    :: i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o == bslen i }--assume readInt-    :: i : Data.ByteString.ByteString-    -> Maybe { p : (Int, { o : Data.ByteString.ByteString | bslen o < bslen i}) | bslen i /= 0 }--assume readInteger-    :: i : Data.ByteString.ByteString-    -> Maybe { p : (Integer, { o : Data.ByteString.ByteString | bslen o < bslen i}) | bslen i /= 0 }--assume copy-    :: i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o == bslen i }--assume hGet-    :: System.IO.Handle-    -> n : { n : Int | 0 <= n }-    -> IO { bs : Data.ByteString.ByteString | bslen bs == n || bslen bs == 0 }--assume hGetSome-    :: System.IO.Handle-    -> n : { n : Int | 0 <= n }-    -> IO { bs : Data.ByteString.ByteString | bslen bs <= n }--assume hGetNonBlocking-    :: System.IO.Handle-    -> n : { n : Int | 0 <= n }-    -> IO { bs : Data.ByteString.ByteString | bslen bs <= n }--//  assume partition-    //  :: (Char -> GHC.Types.Bool)-    //  -> i : Data.ByteString.ByteString-    //  -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }-       //  , { r : Data.ByteString.ByteString | bslen r <= bslen i }-       //  )
− include/Data/ByteString/Lazy.spec 
@@ -1,338 +0,0 @@-module spec Data.ByteString.Lazy where--import Data.String-import Data.ByteString--measure bllen :: Data.ByteString.Lazy.ByteString -> { n : GHC.Int.Int64 | 0 <= n }--invariant { bs : Data.ByteString.Lazy.ByteString | 0 <= bllen bs }--invariant { bs : Data.ByteString.Lazy.ByteString | bllen bs == stringlen bs }--assume empty :: { bs : Data.ByteString.Lazy.ByteString | bllen bs == 0 }--assume singleton-    :: _ -> { bs : Data.ByteString.Lazy.ByteString | bllen bs == 1 }--assume pack-    :: w8s : [_]-    -> { bs : _ | bllen bs == len w8s }--assume unpack-    :: bs : Data.ByteString.Lazy.ByteString-    -> { w8s : [_] | len w8s == bllen bs }--assume fromStrict-    :: i : Data.ByteString.ByteString-    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bslen i }--assume toStrict-    :: i : Data.ByteString.Lazy.ByteString-    -> { o : Data.ByteString.ByteString | bslen o == bllen i }--assume fromChunks-    :: i : [Data.ByteString.ByteString]-    -> { o : Data.ByteString.Lazy.ByteString | len i == 0 <=> bllen o == 0 }--assume toChunks-    :: i : Data.ByteString.Lazy.ByteString-    -> { os : [{ o : Data.ByteString.ByteString | bslen o <= bllen i}] | len os == 0 <=> bllen i == 0 }--assume cons-    :: _-    -> i : Data.ByteString.Lazy.ByteString-    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i + 1 }--assume snoc-    :: i : Data.ByteString.Lazy.ByteString-    -> _-    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i + 1 }--assume append-    :: l : Data.ByteString.Lazy.ByteString-    -> r : Data.ByteString.Lazy.ByteString-    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen l + bllen r }--assume head-    :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }-    -> _--assume uncons-    :: i : Data.ByteString.Lazy.ByteString-    -> Maybe (_, { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i - 1 })--assume unsnoc-    :: i : Data.ByteString.Lazy.ByteString-    -> Maybe ({ o : Data.ByteString.Lazy.ByteString | bllen o == bllen i - 1 }, _)--assume last :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs } -> _--assume tail :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs } -> _--assume init :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs } -> _--assume null :: bs : Data.ByteString.Lazy.ByteString -> { b : GHC.Types.Bool | b <=> bllen bs == 0 }--assume length-    :: bs : Data.ByteString.Lazy.ByteString -> { n : GHC.Int.Int64 | bllen bs == n }--assume map-    :: (_ -> _)-    -> i : Data.ByteString.Lazy.ByteString-    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i }--assume reverse-    :: i : Data.ByteString.Lazy.ByteString-    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i }--assume intersperse-    :: _-    -> i : Data.ByteString.Lazy.ByteString-    -> { o : Data.ByteString.Lazy.ByteString | (bllen i == 0 <=> bllen o == 0) && (1 <= bllen i <=> bllen o == 2 * bllen i - 1) }--assume intercalate-    :: l : Data.ByteString.Lazy.ByteString-    -> rs : [Data.ByteString.Lazy.ByteString]-    -> { o : Data.ByteString.Lazy.ByteString | len rs == 0 ==> bllen o == 0 }--assume transpose-    :: is : [Data.ByteString.Lazy.ByteString]-    -> { os : [{ bs : Data.ByteString.Lazy.ByteString | bllen bs <= len is }] | len is == 0 ==> len os == 0}--assume foldl1-    :: (_ -> _ -> _)-    -> { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }-    -> _--assume foldl1'-    :: (_ -> _ -> _)-    -> { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }-    -> _--assume foldr1-    :: (_ -> _ -> _)-    -> { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }-    -> _--assume concat-    :: is : [Data.ByteString.Lazy.ByteString]-    -> { o : Data.ByteString.Lazy.ByteString | (len is == 0) ==> (bllen o == 0) }--assume concatMap-    :: (_ -> Data.ByteString.Lazy.ByteString)-    -> i : Data.ByteString.Lazy.ByteString-    -> { o : Data.ByteString.Lazy.ByteString | bllen i == 0 ==> bllen o == 0 }--assume any :: (_ -> GHC.Types.Bool)-    -> bs : Data.ByteString.Lazy.ByteString-    -> { b : GHC.Types.Bool | bllen bs == 0 ==> not b }--assume all :: (_ -> GHC.Types.Bool)-    -> bs : Data.ByteString.Lazy.ByteString-    -> { b : GHC.Types.Bool | bllen bs == 0 ==> b }--assume maximum :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs } -> _--assume minimum :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs } -> _--assume scanl-    :: (_ -> _ -> _)-    -> _-    -> i : Data.ByteString.Lazy.ByteString-    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i }--assume mapAccumL-    :: (acc -> _ -> (acc, _))-    -> acc-    -> i : Data.ByteString.Lazy.ByteString-    -> (acc, { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i })--assume mapAccumR-    :: (acc -> _ -> (acc, _))-    -> acc-    -> i : Data.ByteString.Lazy.ByteString-    -> (acc, { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i })--assume replicate-    :: n : GHC.Int.Int64-    -> _-    -> { bs : Data.ByteString.Lazy.ByteString | bllen bs == n }--assume take-    :: n : GHC.Int.Int64-    -> i : Data.ByteString.Lazy.ByteString-    -> { o : Data.ByteString.Lazy.ByteString | (n <= 0 ==> bllen o == 0) &&-                                               ((0 <= n && n <= bllen i) <=> bllen o == n) &&-                                               (bllen i <= n <=> bllen o = bllen i) }--assume drop-    :: n : GHC.Int.Int64-    -> i : Data.ByteString.Lazy.ByteString-    -> { o : Data.ByteString.Lazy.ByteString | (n <= 0 <=> bllen o == bllen i) &&-                                               ((0 <= n && n <= bllen i) <=> bllen o == bllen i - n) &&-                                               (bllen i <= n <=> bllen o == 0) }--assume splitAt-    :: n : GHC.Int.Int64-    -> i : Data.ByteString.Lazy.ByteString-    -> ( { l : Data.ByteString.Lazy.ByteString | (n <= 0 <=> bllen l == 0) &&-                                                 ((0 <= n && n <= bllen i) <=> bllen l == n) &&-                                                 (bllen i <= n <=> bllen l == bllen i) }-       , { r : Data.ByteString.Lazy.ByteString | (n <= 0 <=> bllen r == bllen i) &&-                                                 ((0 <= n && n <= bllen i) <=> bllen r == bllen i - n) &&-                                                 (bllen i <= n <=> bllen r == 0) }-       )--assume takeWhile-    :: (_ -> GHC.Types.Bool)-    -> i : Data.ByteString.Lazy.ByteString-    -> { o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }--assume dropWhile-    :: (_ -> GHC.Types.Bool)-    -> i : Data.ByteString.Lazy.ByteString-    -> { o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }--assume span-    :: (_ -> GHC.Types.Bool)-    -> i : Data.ByteString.Lazy.ByteString-    -> ( { l : Data.ByteString.Lazy.ByteString | bllen l <= bllen i }-       , { r : Data.ByteString.Lazy.ByteString | bllen r <= bllen i }-       )--assume break-    :: (_ -> GHC.Types.Bool)-    -> i : Data.ByteString.Lazy.ByteString-    -> ( { l : Data.ByteString.Lazy.ByteString | bllen l <= bllen i }-       , { r : Data.ByteString.Lazy.ByteString | bllen r <= bllen i }-       )--assume group-    :: i : Data.ByteString.Lazy.ByteString-    -> [{ o : Data.ByteString.Lazy.ByteString | 1 <= bllen o && bllen o <= bllen i }]--assume groupBy-    :: (_ -> _ -> GHC.Types.Bool)-    -> i : Data.ByteString.Lazy.ByteString-    -> [{ o : Data.ByteString.Lazy.ByteString | 1 <= bllen o && bllen o <= bllen i }]--assume inits-    :: i : Data.ByteString.Lazy.ByteString-    -> [{ o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }]--assume tails-    :: i : Data.ByteString.Lazy.ByteString-    -> [{ o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }]--assume split-    :: _-    -> i : Data.ByteString.Lazy.ByteString-    -> [{ o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }]--assume splitWith-    :: (_ -> GHC.Types.Bool)-    -> i : Data.ByteString.Lazy.ByteString-    -> [{ o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }]--assume isPrefixOf-    :: l : Data.ByteString.Lazy.ByteString-    -> r : Data.ByteString.Lazy.ByteString-    -> { b : GHC.Types.Bool | bllen l >= bllen r ==> not b }--assume isSuffixOf-    :: l : Data.ByteString.Lazy.ByteString-    -> r : Data.ByteString.Lazy.ByteString-    -> { b : GHC.Types.Bool | bllen l >= bllen r ==> not b }--assume elem-    :: _-    -> bs : Data.ByteString.Lazy.ByteString-    -> { b : GHC.Types.Bool | (bllen bs == 0) ==> not b }--assume notElem-    :: _-    -> bs : Data.ByteString.Lazy.ByteString-    -> { b : GHC.Types.Bool | (bllen bs == 0) ==> b }--assume find-    :: (_ -> GHC.Types.Bool)-    -> bs : Data.ByteString.Lazy.ByteString-    -> Maybe { w8 : _ | bllen bs /= 0 }--assume filter-    :: (_ -> GHC.Types.Bool)-    -> i : Data.ByteString.Lazy.ByteString-    -> { o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }--assume partition-    :: (_ -> GHC.Types.Bool)-    -> i : Data.ByteString.Lazy.ByteString-    -> ( { l : Data.ByteString.Lazy.ByteString | bllen l <= bllen i }-       , { r : Data.ByteString.Lazy.ByteString | bllen r <= bllen i }-       )--assume index-    :: bs : Data.ByteString.Lazy.ByteString-    -> { n : GHC.Int.Int64 | 0 <= n && n < bllen bs }-    -> _--assume elemIndex-    :: _-    -> bs : Data.ByteString.Lazy.ByteString-    -> Maybe { n : GHC.Int.Int64 | 0 <= n && n < bllen bs }--assume elemIndices-    :: _-    -> bs : Data.ByteString.Lazy.ByteString-    -> [{ n : GHC.Int.Int64 | 0 <= n && n < bllen bs }]--assume elemIndexEnd-    :: _-    -> bs : Data.ByteString.Lazy.ByteString-    -> Maybe { n : GHC.Int.Int64 | 0 <= n && n < bllen bs }--assume findIndex-    :: (_ -> GHC.Types.Bool)-    -> bs : Data.ByteString.Lazy.ByteString-    -> Maybe { n : GHC.Int.Int64 | 0 <= n && n < bllen bs }--assume findIndices-    :: (_ -> GHC.Types.Bool)-    -> bs : Data.ByteString.Lazy.ByteString-    -> [{ n : GHC.Int.Int64 | 0 <= n && n < bllen bs }]--assume count-    :: _-    -> bs : Data.ByteString.Lazy.ByteString-    -> { n : GHC.Int.Int64 | 0 <= n && n < bllen bs }--assume zip-    :: l : Data.ByteString.Lazy.ByteString-    -> r : Data.ByteString.Lazy.ByteString-    -> { o : [(_, _)] | len o <= bllen l && len o <= bllen r }--assume zipWith-    :: (_ -> _ -> a)-    -> l : Data.ByteString.Lazy.ByteString-    -> r : Data.ByteString.Lazy.ByteString-    -> { o : [a] | len o <= bllen l && len o <= bllen r }--assume unzip-    :: i : [(_, _)]-    -> ( { l : Data.ByteString.Lazy.ByteString | bllen l == len i }-       , { r : Data.ByteString.Lazy.ByteString | bllen r == len i }-       )--assume copy-    :: i : Data.ByteString.Lazy.ByteString-    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i }--assume hGet-    :: _-    -> n : { n : Int | 0 <= n }-    -> IO { bs : Data.ByteString.Lazy.ByteString | bllen bs == n || bllen bs == 0 }--assume hGetNonBlocking-    :: _-    -> n : { n : Int | 0 <= n }-    -> IO { bs : Data.ByteString.Lazy.ByteString | bllen bs <= n }
− include/Data/ByteString/Short.spec 
@@ -1,25 +0,0 @@-module spec Data.ByteString.Short where--import Data.String--measure sbslen :: Data.ByteString.Short.ShortByteString -> { n : Int | 0 <= n }--invariant { bs : Data.ByteString.Short.ShortByteString  | 0 <= sbslen bs }--invariant { bs : Data.ByteString.Short.ShortByteString | sbslen bs == stringlen bs }--toShort :: i : Data.ByteString.ByteString -> { o : Data.ByteString.Short.ShortByteString | sbslen o == bslen i }--fromShort :: o : Data.ByteString.Short.ShortByteString -> { i : Data.ByteString.ByteString | bslen i == sbslen o }--pack :: w8s : [Data.Word.Word8] -> { bs : Data.ByteString.Short.ShortByteString | sbslen bs == len w8s }--unpack :: bs : Data.ByteString.Short.ShortByteString -> { w8s : [Data.Word.Word8] | len w8s == sbslen bs }--empty :: { bs : Data.ByteString.Short.ShortByteString | sbslen bs == 0 }--null :: bs : Data.ByteString.Short.ShortByteString -> { b : GHC.Types.Bool | b <=> sbslen bs == 0 }--length :: bs : Data.ByteString.Short.ShortByteString -> { n : Int | sbslen bs == n }--index :: bs : Data.ByteString.Short.ShortByteString -> { n : Int | 0 <= n && n < sbslen bs } -> Data.Word.Word8
− include/Data/ByteString/Unsafe.spec 
@@ -1,29 +0,0 @@-module spec Data.ByteString.Unsafe where--unsafeHead-    :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> _ --unsafeTail-    :: bs : { v : Data.ByteString.ByteString | bslen v > 0 }-    -> { v : Data.ByteString.ByteString | bslen v = bslen bs - 1 }--unsafeInit-    :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> _ --unsafeLast-    :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> _ --unsafeIndex-    :: bs : Data.ByteString.ByteString-    -> { n : Int | 0 <= n && n < bslen bs }-    -> _ --unsafeTake-    :: n : { n : Int | 0 <= n }-    -> i : { i : Data.ByteString.ByteString | n <= bslen i }-    -> { o : Data.ByteString.ByteString | bslen o == n }--unsafeDrop-    :: n : { n : Int | 0 <= n }-    -> i : { i : Data.ByteString.ByteString | n <= bslen i }-    -> { o : Data.ByteString.ByteString | bslen o == bslen i - n }
− include/Data/Char.spec 
@@ -1,1 +0,0 @@-module spec Data.Chare where
− include/Data/Either.spec 
@@ -1,5 +0,0 @@-module spec Data.Either where--measure isLeft :: Data.Either.Either a b -> Bool-  isLeft (Left x)  = true-  isLeft (Right x) = false
− include/Data/Foldable.spec 
@@ -1,6 +0,0 @@-module spec Data.Foldable where--import GHC.Base--length :: Data.Foldable.Foldable f => forall a. xs:f a -> {v:Nat | v = len xs}-null :: v:_ -> {b:Bool | (b <=> len v = 0) && (not b <=> len v > 0)}
− include/Data/Int.spec 
@@ -1,8 +0,0 @@-module spec Data.Int where--embed Data.Int.Int8  as int-embed Data.Int.Int16 as int-embed Data.Int.Int32 as int-embed Data.Int.Int64 as int--//  type Nat64 = {v:Data.Int.Int64 | v >= 0}
− include/Data/Maybe.spec 
@@ -1,7 +0,0 @@-module spec Data.Maybe where--maybe :: v:b -> (a -> b) -> u:(Maybe a) -> {w:b | not (isJust u) => w == v}-isJust :: v:(Maybe a) -> {b:Bool | b == isJust v}-isNothing :: v:(Maybe a) -> {b:Bool | not (isJust v) == b}-fromJust :: {v:(Maybe a) | isJust v} -> a-fromMaybe :: v:a -> u:(Maybe a) -> {x:a | not (isJust u) => x == v}
− include/Data/OldList.spec 
@@ -1,11 +0,0 @@-module spec Data.OldList where--import GHC.Base-import GHC.List-import GHC.Types--assume groupBy :: (a -> a -> GHC.Types.Bool) -> [a] -> [{v:[a] | len(v) > 0}]--assume transpose :: [[a]] -> [{v:[a] | (len v) > 0}]--
− include/Data/Set.spec 
@@ -1,59 +0,0 @@-module spec Data.Set where--embed Data.Set.Internal.Set as Set_Set--//  -----------------------------------------------------------------------------------------------//  -- | Logical Set Operators: Interpreted "natively" by the SMT solver --------------------------//  -------------------------------------------------------------------------------------------------//  union-measure Set_cup  :: (Data.Set.Internal.Set a) -> (Data.Set.Internal.Set a) -> (Data.Set.Internal.Set a)--//  intersection-measure Set_cap  :: (Data.Set.Internal.Set a) -> (Data.Set.Internal.Set a) -> (Data.Set.Internal.Set a)--//  difference-measure Set_dif   :: (Data.Set.Internal.Set a) -> (Data.Set.Internal.Set a) -> (Data.Set.Internal.Set a)--//  singleton-measure Set_sng   :: a -> (Data.Set.Internal.Set a)--//  emptiness test-measure Set_emp   :: (Data.Set.Internal.Set a) -> GHC.Types.Bool--//  empty set-measure Set_empty :: forall a. GHC.Types.Int -> (Data.Set.Internal.Set a)--//  membership test-measure Set_mem  :: a -> (Data.Set.Internal.Set a) -> GHC.Types.Bool--//  inclusion test-measure Set_sub  :: (Data.Set.Internal.Set a) -> (Data.Set.Internal.Set a) -> GHC.Types.Bool--//  ----------------------------------------------------------------------------------------------//  -- | Refined Types for Data.Set Operations ---------------------------------------------------//  -----------------------------------------------------------------------------------------------isSubsetOf    :: (GHC.Classes.Ord a) => x:(Data.Set.Internal.Set a) -> y:(Data.Set.Internal.Set a) -> {v:GHC.Types.Bool | v <=> Set_sub x y}-member        :: (GHC.Classes.Ord a) => x:a -> xs:(Data.Set.Internal.Set a) -> {v:GHC.Types.Bool | v <=> Set_mem x xs}-null          :: xs:(Data.Set.Internal.Set a) -> {v:GHC.Types.Bool | v <=> Set_emp xs}--empty         :: {v:(Data.Set.Internal.Set a) | Set_emp v}-singleton     :: x:a -> {v:(Data.Set.Internal.Set a) | v = (Set_sng x)}-insert        :: (GHC.Classes.Ord a) => x:a -> xs:(Data.Set.Internal.Set a) -> {v:(Data.Set.Internal.Set a) | v = Set_cup xs (Set_sng x)}-delete        :: (GHC.Classes.Ord a) => x:a -> xs:(Data.Set.Internal.Set a) -> {v:(Data.Set.Internal.Set a) | v = Set_dif xs (Set_sng x)}--union         :: GHC.Classes.Ord a => xs:(Data.Set.Internal.Set a) -> ys:(Data.Set.Internal.Set a) -> {v:(Data.Set.Internal.Set a) | v = Set_cup xs ys}-intersection  :: GHC.Classes.Ord a => xs:(Data.Set.Internal.Set a) -> ys:(Data.Set.Internal.Set a) -> {v:(Data.Set.Internal.Set a) | v = Set_cap xs ys}-difference    :: GHC.Classes.Ord a => xs:(Data.Set.Internal.Set a) -> ys:(Data.Set.Internal.Set a) -> {v:(Data.Set.Internal.Set a) | v = Set_dif xs ys}--fromList :: GHC.Classes.Ord a => xs:[a] -> {v:Data.Set.Internal.Set a | v = listElts xs}--//  ----------------------------------------------------------------------------------------------//  -- | The set of elements in a list -----------------------------------------------------------//  -----------------------------------------------------------------------------------------------measure listElts :: [a] -> (Data.Set.Internal.Set a)-  listElts []     = {v | (Set_emp v)}-  listElts (x:xs) = {v | v = Set_cup (Set_sng x) (listElts xs) }
− include/Data/String.spec 
@@ -1,8 +0,0 @@-module spec Data.String where--measure stringlen :: a -> GHC.Types.Int--Data.String.fromString-    ::  forall a. Data.String.IsString a-    =>  i : [GHC.Types.Char]-    ->  { o : a | i ~~ o && len i == stringlen o }
− include/Data/Text.spec 
@@ -1,289 +0,0 @@-module spec Data.Text where--import Data.String--measure tlen :: Data.Text.Text -> { n : Int | 0 <= n }--invariant { t : Data.Text.Text  | 0 <= tlen t }--invariant { t : Data.Text.Text | tlen t == stringlen t }--empty :: { t : Data.Text.Text | tlen t == 0 }--singleton :: _ -> { t : Data.Text.Text | tlen t == 1 }--pack :: str : [_]-     -> { t : Data.Text.Text | tlen t == len str }--unpack :: t : Data.Text.Text-       -> { str : [_] | len str == tlen t }--cons :: _-     -> i : Data.Text.Text-     -> { o : Data.Text.Text | tlen o == tlen i + 1 }--snoc :: i : Data.Text.Text-     -> _-     -> { o : Data.Text.Text | tlen o == tlen i + 1 }--append :: l : Data.Text.Text-       -> r : Data.Text.Text-       -> { o : Data.Text.Text | tlen o == tlen l + tlen r }--head :: { t : Data.Text.Text | 1 <= tlen t } -> _--unsnoc :: i:Data.Text.Text-       -> (Maybe ({ o : Data.Text.Text | tlen o == tlen i - 1 }, _))--last :: { t : Data.Text.Text | 1 <= tlen t } -> _--tail :: { t : Data.Text.Text | 1 <= tlen t } -> _--init-  :: {i:Data.Text.Text | 1 <= tlen i }-  -> {o:Data.Text.Text | tlen o == tlen i - 1 }--null-  :: t : Data.Text.Text-  -> { b : GHC.Types.Bool | b <=> tlen t == 0 }--length :: t : Data.Text.Text -> { n : Int | tlen t == n }--map-  :: (_ -> _)-  -> i : Data.Text.Text-  -> { o : Data.Text.Text | tlen o == tlen i }--reverse-  :: i : Data.Text.Text-  -> { o : Data.Text.Text | tlen o == tlen i }--intersperse-  :: _-  -> i : Data.Text.Text-  -> { o : Data.Text.Text | (tlen i == 0 <=> tlen o == 0) && (1 <= tlen i <=> tlen o == 2 * tlen i - 1) }--intercalate-  :: l : Data.Text.Text-  -> rs : [Data.Text.Text]-  -> { o : Data.Text.Text | len rs == 0 ==> tlen o == 0 }--transpose-  :: is : [Data.Text.Text]-  -> { os : [{ t : Data.Text.Text | tlen t <= len is }] | len is == 0 ==> len os == 0}--foldl1-  :: (_ -> _ -> _)-  -> { t : Data.Text.Text | 1 <= tlen t }-  -> _--foldl1'-  :: (_ -> _ -> _)-  -> { t : Data.Text.Text | 1 <= tlen t }-  -> _--foldr1-  :: (_ -> _ -> _)-  -> { t : Data.Text.Text | 1 <= tlen t }-  -> _--concat-  :: is : [Data.Text.Text]-  -> { o : Data.Text.Text | (len is == 0) ==> (tlen o == 0) }--concatMap-  :: (_ -> Data.Text.Text)-  -> i : Data.Text.Text-  -> { o : Data.Text.Text | tlen i == 0 ==> tlen o == 0 }--any-  :: (_ -> GHC.Types.Bool)-  -> t : Data.Text.Text-  -> { b : GHC.Types.Bool | tlen t == 0 ==> not b }--all-  :: (_ -> GHC.Types.Bool)-  -> t : Data.Text.Text-  -> { b : GHC.Types.Bool | tlen t == 0 ==> b }--maximum :: { t : Data.Text.Text | 1 <= tlen t } -> _--minimum :: { t : Data.Text.Text | 1 <= tlen t } -> _--scanl :: (_ -> _ -> _)-      -> _-      -> i : Data.Text.Text-      -> { o : Data.Text.Text | tlen o == tlen i }--scanl1 :: (_ -> _ -> _)-       -> i : { i : Data.Text.Text | 1 <= tlen i }-       -> { o : Data.Text.Text | tlen o == tlen i }--scanr-    :: (_ -> _ -> _)-    -> _-    -> i : Data.Text.Text-    -> { o : Data.Text.Text | tlen o == tlen i }--scanr1-    :: (_ -> _ -> _)-    -> i : { i : Data.Text.Text | 1 <= tlen i }-    -> { o : Data.Text.Text | tlen o == tlen i }--mapAccumL-    :: (acc -> _ -> (acc, _))-    -> acc-    -> i : Data.Text.Text-    -> (acc, { o : Data.Text.Text | tlen o == tlen i })--mapAccumR-    :: (acc -> _ -> (acc, _))-    -> acc-    -> i : Data.Text.Text-    -> (acc, { o : Data.Text.Text | tlen o == tlen i })--replicate-    :: n : Int-    -> _-    -> { t : Data.Text.Text | tlen t == n }--unfoldrN-    :: n : Int-    -> (a -> Maybe (_, a))-    -> a-    -> { t : Data.Text.Text | tlen t <= n }--take-    :: n : Int-    -> i : Data.Text.Text-    -> { o : Data.Text.Text | (n <= 0 <=> tlen o == 0) &&-                                          ((0 <= n && n <= tlen i) <=> tlen o == n) &&-                                          (tlen i <= n <=> tlen o = tlen i) }--drop-    :: n : Int-    -> i : Data.Text.Text-    -> { o : Data.Text.Text | (n <= 0 <=> tlen o == tlen i) &&-                                          ((0 <= n && n <= tlen i) <=> tlen o == tlen i - n) &&-                                          (tlen i <= n <=> tlen o == 0) }--splitAt-    :: n : Int-    -> i : Data.Text.Text-    -> ( { l : Data.Text.Text | (n <= 0 <=> tlen l == 0) &&-                                            ((0 <= n && n <= tlen i) <=> tlen l == n) &&-                                            (tlen i <= n <=> tlen l == tlen i) }-       , { r : Data.Text.Text | (n <= 0 <=> tlen r == tlen i) &&-                                            ((0 <= n && n <= tlen i) <=> tlen r == tlen i - n) &&-                                            (tlen i <= n <=> tlen r == 0) }-       )--takeWhile-    :: (_ -> GHC.Types.Bool)-    -> i : Data.Text.Text-    -> { o : Data.Text.Text | tlen o <= tlen i }--dropWhile-    :: (_ -> GHC.Types.Bool)-    -> i : Data.Text.Text-    -> { o : Data.Text.Text | tlen o <= tlen i }--span-    :: (_ -> GHC.Types.Bool)-    -> i : Data.Text.Text-    -> ( { l : Data.Text.Text | tlen l <= tlen i }-       , { r : Data.Text.Text | tlen r <= tlen i }-       )--break-    :: (_ -> GHC.Types.Bool)-    -> i : Data.Text.Text-    -> ( { l : Data.Text.Text | tlen l <= tlen i }-       , { r : Data.Text.Text | tlen r <= tlen i }-       )--group-    :: i : Data.Text.Text-    -> [{ o : Data.Text.Text | 1 <= tlen o && tlen o <= tlen i }]--groupBy-    :: (_ -> _ -> GHC.Types.Bool)-    -> i : Data.Text.Text-    -> [{ o : Data.Text.Text | 1 <= tlen o && tlen o <= tlen i }]--inits-    :: i : Data.Text.Text-    -> [{ o : Data.Text.Text | tlen o <= tlen i }]--tails-    :: i : Data.Text.Text-    -> [{ o : Data.Text.Text | tlen o <= tlen i }]--split-    :: (_ -> GHC.Types.Bool)-    -> i : Data.Text.Text-    -> [{ o : Data.Text.Text | tlen o <= tlen i }]--isPrefixOf-    :: l : Data.Text.Text-    -> r : Data.Text.Text-    -> { b : GHC.Types.Bool | tlen l >= tlen r ==> not b }--isSuffixOf-    :: l : Data.Text.Text-    -> r : Data.Text.Text-    -> { b : GHC.Types.Bool | tlen l > tlen r ==> not b }--isInfixOf-    :: l : Data.Text.Text-    -> r : Data.Text.Text-    -> { b : GHC.Types.Bool | tlen l > tlen r ==> not b }--find-    :: (_ -> GHC.Types.Bool)-    -> t : Data.Text.Text-    -> (Maybe { char : _ | tlen t /= 0 })--filter-    :: (_ -> GHC.Types.Bool)-    -> i : Data.Text.Text-    -> { o : Data.Text.Text | tlen o <= tlen i }--partition-    :: (_ -> GHC.Types.Bool)-    -> i : Data.Text.Text-    -> ( { l : Data.Text.Text | tlen l <= tlen i }-       , { r : Data.Text.Text | tlen r <= tlen i }-       )--index :: t : Data.Text.Text -> { n : Int | 0 <= n && n < tlen t } -> _--findIndex-    :: (_ -> GHC.Types.Bool)-    -> t : Data.Text.Text-    -> (Maybe { n : Int | 0 <= n && n < tlen t })--count-    :: _-    -> t : Data.Text.Text-    -> { n : Int | 0 <= n && n < tlen t }--zip-    :: l : Data.Text.Text-    -> r : Data.Text.Text-    -> { o : [(_, _)] | len o <= tlen l && len o <= tlen r }--zipWith-    :: (_ -> _ -> Char)-    -> l : Data.Text.Text-    -> r : Data.Text.Text-    -> { o : Text | tlen o <= tlen l && tlen o <= tlen r }--copy-    :: i : Data.Text.Text-    -> { o : Data.Text.Text | tlen o == tlen i }--uncons-    :: i : Data.Text.Text-    -> (Maybe (_, { o : Data.Text.Text | tlen o == tlen i - 1 }))-
− include/Data/Text/Fusion.spec 
@@ -1,25 +0,0 @@-module spec Data.Text.Fusion where--import Data.Text.Fusion.Common--stream        :: t:Data.Text.Internal.Text-              -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) = (tlength t)}-reverseStream :: t:Data.Text.Internal.Text-              -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) = (tlength t)}-unstream      :: s:Data.Text.Fusion.Internal.Stream Char-              -> {v:Data.Text.Internal.Text | (tlength v) = (slen s)}--findIndex :: (GHC.Types.Char -> GHC.Types.Bool)-          -> s:Data.Text.Fusion.Internal.Stream Char-          -> (Data.Maybe.Maybe {v:Nat | v < (slen s)})--mapAccumL :: (a -> GHC.Types.Char -> (a,GHC.Types.Char))-          -> a-          -> s:Data.Text.Fusion.Internal.Stream Char-          -> (a, {v:Data.Text.Internal.Text | (tlength v) = (slen s)})---length  :: s:Data.Text.Fusion.Internal.Stream Char-        -> {v:GHC.Types.Int | v = (slen s)}-reverse :: s:Data.Text.Fusion.Internal.Stream Char-        -> {v:Data.Text.Internal.Text | (tlength v) = (slen s)}
− include/Data/Text/Fusion/Common.spec 
@@ -1,52 +0,0 @@-module spec Data.Text.Fusion.Common where--measure slen :: Data.Text.Fusion.Internal.Stream a-             -> GHC.Types.Int--cons :: GHC.Types.Char-     -> s:Data.Text.Fusion.Internal.Stream Char-     -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) = (1 + (slen s))}--snoc :: s:Data.Text.Fusion.Internal.Stream Char-     -> GHC.Types.Char-     -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) = (1 + (slen s))}--compareLengthI :: s:Data.Text.Fusion.Internal.Stream Char-               -> l:GHC.Types.Int-               -> {v:GHC.Types.Ordering | ((v = GHC.Types.EQ) <=> ((slen s) = l))}--isSingleton :: s:Data.Text.Fusion.Internal.Stream Char-            -> {v:GHC.Types.Bool | (v <=> ((slen s) = 1))}--singleton   :: GHC.Types.Char-            -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) = 1}--streamList   :: l:[a]-             -> {v:Data.Text.Fusion.Internal.Stream a | (slen v) = (len l)}--unstreamList :: s:Data.Text.Fusion.Internal.Stream a-             -> {v:[a] | (len v) = (slen s)}--map :: (GHC.Types.Char -> GHC.Types.Char)-    -> s:Data.Text.Fusion.Internal.Stream Char-    -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) = (slen s)}--filter :: (GHC.Types.Char -> GHC.Types.Bool)-       -> s:Data.Text.Fusion.Internal.Stream Char-       -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) <= (slen s)}--intersperse :: GHC.Types.Char-            -> s:Data.Text.Fusion.Internal.Stream Char-            -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) > (slen s)}--replicateCharI :: l:GHC.Types.Int-               -> GHC.Types.Char-               -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) = l}--toCaseFold :: s:Data.Text.Fusion.Internal.Stream Char-           -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) >= (slen s)}--toUpper    :: s:Data.Text.Fusion.Internal.Stream Char-           -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) >= (slen s)}-toLower    :: s:Data.Text.Fusion.Internal.Stream Char-           -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) >= (slen s)}
− include/Data/Text/Lazy/Fusion.spec 
@@ -1,8 +0,0 @@-module spec Data.Text.Lazy.Fusion where--stream :: t:Data.Text.Lazy.Internal.Text-       -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) = (ltlength t)}-unstream :: s:Data.Text.Fusion.Internal.Stream Char-         -> {v:Data.Text.Lazy.Internal.Text | (ltlength v) = (slen s)}-length :: s:Data.Text.Fusion.Internal.Stream Char-       -> {v:GHC.Int.Int64 | v = (slen s)}
− include/Data/Time.spec 
@@ -1,3 +0,0 @@-module spec Data.Time where--import Data.Time.Calendar
− include/Data/Tuple.spec 
@@ -1,4 +0,0 @@-module spec Data.Tuple where--fst :: {f:(x:(a,b) -> {v:a | v = (fst x)}) | f == fst }-snd :: {f:(x:(a,b) -> {v:b | v = (snd x)}) | f == snd }
− include/Data/Vector.hquals 
@@ -1,13 +0,0 @@-qualif VecEmpty(v: Data.Vector.Vector a)    : (vlen v)  =  0 -qualif VecEmpty(v: Data.Vector.Vector a)    : (vlen v)  >  0 -qualif VecEmpty(v: Data.Vector.Vector a)    : (vlen v)  >= 0 --qualif Vlen(v:int, x: Data.Vector.Vector a) : (v  =  vlen x)-qualif Vlen(v:int, x: Data.Vector.Vector a) : (v <=  vlen x) -qualif Vlen(v:int, x: Data.Vector.Vector a) : (v  <  vlen x) --qualif CmpVlen(v:Data.Vector.Vector a, x:Data.Vector.Vector b) : (vlen v <  vlen x) -qualif CmpVlen(v:Data.Vector.Vector a, x:Data.Vector.Vector b) : (vlen v <= vlen x) -qualif CmpVlen(v:Data.Vector.Vector a, x:Data.Vector.Vector b) : (vlen v >  vlen x) -qualif CmpVlen(v:Data.Vector.Vector a, x:Data.Vector.Vector b) : (vlen v >= vlen x) -qualif CmpVlen(v:Data.Vector.Vector a, x:Data.Vector.Vector b) : (vlen v =  vlen x)
− include/Data/Vector.spec 
@@ -1,26 +0,0 @@-module spec Data.Vector where--import GHC.Base--data variance Data.Vector.Vector covariant---measure vlen    :: forall a. (Data.Vector.Vector a) -> Int--invariant       {v: Data.Vector.Vector a | 0 <= vlen v } --!           :: forall a. x:(Data.Vector.Vector a) -> vec:{v:Nat | v < vlen x } -> a --unsafeIndex :: forall a. x:(Data.Vector.Vector a) -> vec:{v:Nat | v < vlen x } -> a --fromList  :: forall a. x:[a] -> {v: Data.Vector.Vector a  | vlen v = len x }--length    :: forall a. x:(Data.Vector.Vector a) -> {v : Nat | v = vlen x }--replicate :: n:Nat -> a -> {v:Data.Vector.Vector a | vlen v = n} --imap :: (Nat -> a -> b) -> x:(Data.Vector.Vector a) -> {y:Data.Vector.Vector b | vlen y = vlen x }--map :: (a -> b) -> x:(Data.Vector.Vector a) -> {y:Data.Vector.Vector b | vlen y = vlen x }--head :: forall a. {xs: Data.Vector.Vector a | vlen xs > 0} -> a
− include/Data/Word.spec 
@@ -1,10 +0,0 @@-module spec Data.Word where--embed Data.Word.Word   as int-embed Data.Word.Word8  as int-embed Data.Word.Word16 as int-embed Data.Word.Word32 as int-embed Data.Word.Word64 as int--invariant {v : Data.Word.Word32 | 0 <= v }-invariant {v : Data.Word.Word16 | 0 <= v }
− include/Data/Word8.spec 
@@ -1,5 +0,0 @@-module spec Data.Word8 where--import GHC.Word--invariant {v:GHC.Word.Word8 | 0 <= v }
− include/Foreign/C/String.spec 
@@ -1,11 +0,0 @@-module spec Foreign.C.String where--import Foreign.Ptr--type CStringLen    = ((GHC.Ptr.Ptr Foreign.C.Types.CChar), Nat)<{\p v -> (v <= (plen p))}>-type CStringLenN N = ((GHC.Ptr.Ptr Foreign.C.Types.CChar), {v:Nat | v = N})<{\p v -> (v <= (plen p))}>--//  measure cStringLen :: Foreign.C.String.CStringLen -> GHC.Types.Int--measure cStringLen :: ((GHC.Ptr.Ptr Foreign.C.Types.CChar), GHC.Types.Int) -> GHC.Types.Int -  cStringLen (c, n) = n
− include/Foreign/C/Types.spec 
@@ -1,7 +0,0 @@-module spec Foreign.C.Types where--import GHC.Word--embed Foreign.C.Types.CInt   as int-embed Foreign.C.Types.CSize  as int-embed Foreign.C.Types.CULong as int
− include/Foreign/ForeignPtr.spec 
@@ -1,16 +0,0 @@-module spec Foreign.ForeignPtr where--import GHC.ForeignPtr-import Foreign.Ptr--Foreign.ForeignPtr.withForeignPtr :: forall a b. fp:(GHC.ForeignPtr.ForeignPtr a) -  -> ((PtrN a (fplen fp)) -> GHC.Types.IO b) -  -> (GHC.Types.IO b)--GHC.ForeignPtr.newForeignPtr_     :: p:(GHC.Ptr.Ptr a) -> (GHC.Types.IO (ForeignPtrN a (plen p)))-Foreign.Concurrent.newForeignPtr  :: p:(PtrV a) -> GHC.Types.IO () -> (GHC.Types.IO (ForeignPtrN a (plen p)))-Foreign.ForeignPtr.newForeignPtr ::  _ -> p:(PtrV a) -> (GHC.Types.IO (ForeignPtrN a (plen p)))---//  this uses `sizeOf (undefined :: a)`, so the ForeignPtr does not necessarily have length `n`-//  Foreign.ForeignPtr.Imp.mallocForeignPtrArray :: (Foreign.Storable.Storable a) => n:Nat -> IO (ForeignPtrN a n)
− include/Foreign/Marshal/Alloc.spec 
@@ -1,3 +0,0 @@-module spec Foreign.Marshal.Alloc where--Foreign.Marshal.Alloc.allocaBytes :: n:Nat -> (PtrN a n -> IO b) -> IO b
− include/Foreign/Marshal/Array.spec 
@@ -1,3 +0,0 @@-module spec Foreign.Marshal.Array where--Foreign.Marshal.Array.allocaArray :: Foreign.Storable.Storable a => n:Int -> ((PtrN a n) -> IO b) -> IO b
− include/Foreign/Ptr.spec 
@@ -1,5 +0,0 @@-module spec Foreign.Ptr where--import GHC.Ptr--
− include/Foreign/Storable.spec 
@@ -1,30 +0,0 @@-module spec Foreign.Storable where--import Foreign.Ptr--//  DON'T do this, we can't import HS files from SPEC files-//  import Language.Haskell.Liquid.Foreign--predicate PValid P N         = ((0 <= N) && (N < (plen P)))   --Foreign.Storable.poke        :: (Foreign.Storable.Storable a)-                             => {v: (GHC.Ptr.Ptr a) | 0 < (plen v)}-                             -> a-                             -> (GHC.Types.IO ())--Foreign.Storable.peek        :: (Foreign.Storable.Storable a)-                             => p:{v: (GHC.Ptr.Ptr a) | 0 < (plen v)}-                             -> (GHC.Types.IO {v:a | v = (deref p)})--Foreign.Storable.peekByteOff :: (Foreign.Storable.Storable a)-                             => forall b. p:(GHC.Ptr.Ptr b)-                             -> {v:GHC.Types.Int | (PValid p v)}-                             -> (GHC.Types.IO a)--Foreign.Storable.pokeByteOff :: (Foreign.Storable.Storable a)-                             => forall b. p:(GHC.Ptr.Ptr b)-                             -> {v:GHC.Types.Int | (PValid p v)}-                             -> a-                             -> GHC.Types.IO ()--
− include/GHC/Base.hquals 
@@ -1,30 +0,0 @@-//qualif NonNull(v: [a])        : (? (nonnull([v])))-//qualif Null(v: [a])           : (~ (? (nonnull([v]))))-//qualif EqNull(v:Bool, ~A: [a]): (v <=> (? (nonnull([~A]))))--// qualif IsEmp(v:GHC.Types.Bool, ~A: [a]) : ((v) <=> len([~A]) [ > ;  = ] 0)-// qualif ListZ(v: [a])          : len([v]) [ = ; >= ; > ] 0 -// qualif CmpLen(v:[a], ~A:[b])  : len([v]) [= ; >=; >; <=; <] len([~A]) -// qualif EqLen(v:int, ~A: [a])  : v = len([~A]) -// qualif LenEq(v:[a], ~A: int)  : ~A = len([v]) -// qualif LenAcc(v:int, ~A:[a], ~B: int): v = len([~A]) + ~B-// qualif LenDiff(v:[a], ~A:int): len([v]) = (~A [ +; - ] 1)--qualif IsEmp(v:GHC.Types.Bool, xs: [a]) : (v <=> (len xs > 0))-qualif IsEmp(v:GHC.Types.Bool, xs: [a]) : (v <=> (len xs = 0))--qualif ListZ(v: [a])          : (len([v]) =  0) -qualif ListZ(v: [a])          : (len([v]) >= 0) -qualif ListZ(v: [a])          : (len([v]) >  0) --qualif CmpLen(v:[a], xs:[b])  : (len([v]) =  len([xs])) -qualif CmpLen(v:[a], xs:[b])  : (len([v]) >= len([xs])) -qualif CmpLen(v:[a], xs:[b])  : (len([v]) >  len([xs])) -qualif CmpLen(v:[a], xs:[b])  : (len([v]) <= len([xs])) -qualif CmpLen(v:[a], xs:[b])  : (len([v]) <  len([xs])) --qualif EqLen(v:int, xs: [a])  : (v = len([xs])) -qualif LenEq(v:[a], x: int)   : (x = len([v])) -qualif LenDiff(v:[a], x:int)  : (len([v]) = x + 1)-qualif LenDiff(v:[a], x:int)  : (len([v]) = x - 1)-qualif LenAcc(v:int, xs:[a], n: int): (v = len([xs]) + n)
− include/GHC/Base.spec 
@@ -1,79 +0,0 @@-module spec GHC.Base where--import GHC.CString-import GHC.Prim-import GHC.Classes-import GHC.Types--embed GHC.Types.Int      as int-embed GHC.Types.Bool     as bool--measure autolen :: forall a. a -> GHC.Types.Int-class measure len :: forall f a. f a -> GHC.Types.Int-instance measure len :: forall a. [a] -> GHC.Types.Int-  len []     = 0-  len (y:ys) = 1 + len ys--//  measure null :: [a] -> Bool-//  null []     = true -//  null (y:ys) = false--measure fst :: (a, b) -> a-  fst (a, b) = a--measure snd :: (a, b) -> b-  snd (a, b) = b--qualif Fst(__v:a, __y:b): (__v = (fst __y))-qualif Snd(__v:a, __y:b): (__v = (snd __y))--measure isJust :: Maybe a -> Bool-  isJust (Just x)  = true-  isJust (Nothing) = false--measure fromJust :: Maybe a -> a-  fromJust (Just x) = x---invariant {v: [a] | len v >= 0 }-map       :: (a -> b) -> xs:[a] -> {v: [b] | len v == len xs}-(++)      :: xs:[a] -> ys:[a] -> {v:[a] | len v == len xs + len ys}--($)       :: (a -> b) -> a -> b-id        :: x:a -> {v:a | v = x}--//  data variance Text.ParserCombinators.ReadPrec.ReadPrec contravariant--// qualif NonNull(v: [a])        : (? (nonnull v ))-// qualif Null(v: [a])           : (~ (? (nonnull v )))-// qualif EqNull(v:Bool, ~A: [a]): (v <=> (? (nonnull([~A]))))--//  qualif IsEmp(v:GHC.Types.Bool, ~A: [a]) : ((v) <=> len([~A]) [ > ;  = ] 0)-//  qualif ListZ(v: [a])          : len v  [ = ; >= ; > ] 0 -//  qualif CmpLen(v:[a], ~A:[b])  : len v  [= ; >=; >; <=; <] len([~A]) -//  qualif EqLen(v:int, ~A: [a])  : v = len([~A]) -//  qualif LenEq(v:[a], ~A: int)  : ~A = len v  -//  qualif LenAcc(v:int, ~A:[a], ~B: int): v = len([~A]) + ~B-//  qualif LenDiff(v:[a], ~A:int): len v  = (~A [ +; - ] 1)--qualif IsEmp(v:GHC.Types.Bool, xs: [a]) : (v <=> (len xs > 0))-qualif IsEmp(v:GHC.Types.Bool, xs: [a]) : (v <=> (len xs = 0))--qualif ListZ(v: [a])          : (len v =  0) -qualif ListZ(v: [a])          : (len v >= 0) -qualif ListZ(v: [a])          : (len v >  0) --qualif CmpLen(v:[a], xs:[b])  : (len v  =  len xs ) -qualif CmpLen(v:[a], xs:[b])  : (len v  >= len xs ) -qualif CmpLen(v:[a], xs:[b])  : (len v  >  len xs ) -qualif CmpLen(v:[a], xs:[b])  : (len v  <= len xs ) -qualif CmpLen(v:[a], xs:[b])  : (len v  <  len xs ) --qualif EqLen(v:int, xs: [a])  : (v = len xs ) -qualif LenEq(v:[a], x: int)   : (x = len v ) --qualif LenDiff(v:[a], x:int)  : (len v  = x + 1)-qualif LenDiff(v:[a], x:int)  : (len v  = x - 1)-qualif LenAcc(v:int, xs:[a], n: int): (v = len xs  + n)--
− include/GHC/CString.spec 
@@ -1,11 +0,0 @@-module spec GHC.CString where--import GHC.Prim--measure strLen :: GHC.Base.String -> GHC.Types.Int--embed GHC.Types.Char as Char--GHC.CString.unpackCString#-  :: x:GHC.Prim.Addr#-  -> {v:[Char] | v ~~ x && len v == strLen x}
− include/GHC/Classes.spec 
@@ -1,29 +0,0 @@-module spec GHC.Classes where--import GHC.Types--not     :: x:GHC.Types.Bool -> {v:GHC.Types.Bool | ((v) <=> ~(x))}-(&&)    :: x:GHC.Types.Bool -> y:GHC.Types.Bool-        -> {v:GHC.Types.Bool | ((v) <=> ((x) && (y)))}-(||)    :: x:GHC.Types.Bool -> y:GHC.Types.Bool-        -> {v:GHC.Types.Bool | ((v) <=> ((x) || (y)))}-(==)    :: (GHC.Classes.Eq  a) => x:a -> y:a-        -> {v:GHC.Types.Bool | ((v) <=> x = y)}-(/=)    :: (GHC.Classes.Eq  a) => x:a -> y:a-        -> {v:GHC.Types.Bool | ((v) <=> x != y)}-(>)     :: (GHC.Classes.Ord a) => x:a -> y:a-        -> {v:GHC.Types.Bool | ((v) <=> x > y)}-(>=)    :: (GHC.Classes.Ord a) => x:a -> y:a-        -> {v:GHC.Types.Bool | ((v) <=> x >= y)}-(<)     :: (GHC.Classes.Ord a) => x:a -> y:a-        -> {v:GHC.Types.Bool | ((v) <=> x < y)}-(<=)    :: (GHC.Classes.Ord a) => x:a -> y:a-        -> {v:GHC.Types.Bool | ((v) <=> x <= y)}--compare :: (GHC.Classes.Ord a) => x:a -> y:a-        -> {v:GHC.Types.Ordering | (((v = GHC.Types.EQ) <=> (x = y)) &&-                                    ((v = GHC.Types.LT) <=> (x < y)) &&-                                    ((v = GHC.Types.GT) <=> (x > y))) }--max :: (GHC.Classes.Ord a) => x:a -> y:a -> {v:a | v = (if x > y then x else y) }-min :: (GHC.Classes.Ord a) => x:a -> y:a -> {v:a | v = (if x < y then x else y) }
− include/GHC/Exts.spec 
@@ -1,10 +0,0 @@-module spec GHC.Exts where--//  embed GHC.Exts.Int#     as int-//  embed GHC.Exts.Word#    as int-//  embed GHC.Exts.Addr#    as Str-//  embed GHC.Exts.Double#  as real-//  embed GHC.Exts.Char#    as Char---
− include/GHC/ForeignPtr.spec 
@@ -1,9 +0,0 @@-module spec GHC.ForeignPtr where--measure fplen :: GHC.ForeignPtr.ForeignPtr a -> GHC.Types.Int--type ForeignPtrV a   = {v: GHC.ForeignPtr.ForeignPtr a | 0 <= fplen v}-type ForeignPtrN a N = {v: GHC.ForeignPtr.ForeignPtr a | 0 <= fplen v && fplen v == N }--mallocPlainForeignPtrBytes :: n:{v:GHC.Types.Int  | v >= 0 } -> (GHC.Types.IO (ForeignPtrN a n))-
− include/GHC/IO/Handle.spec 
@@ -1,10 +0,0 @@-module spec GHC.IO.Handle where--hGetBuf :: GHC.IO.Handle.Handle -> GHC.Ptr.Ptr a -> n:Nat-        -> (GHC.Types.IO {v:Nat | v <= n})--hGetBufNonBlocking :: GHC.IO.Handle.Handle -> GHC.Ptr.Ptr a -> n:Nat-                   -> (GHC.Types.IO {v:Nat | v <= n})--hFileSize :: GHC.IO.Handle.Handle-          -> (GHC.Types.IO {v:GHC.Integer.Type.Integer | v >= 0})
− include/GHC/Int.spec 
@@ -1,8 +0,0 @@-module spec GHC.Int where--embed GHC.Int.Int8  as int-embed GHC.Int.Int16 as int-embed GHC.Int.Int32 as int-embed GHC.Int.Int64 as int--type Nat64 = {v:GHC.Int.Int64 | v >= 0}
− include/GHC/List.spec 
@@ -1,60 +0,0 @@-module spec GHC.List where --head         :: xs:{v: [a] | len v > 0} -> {v:a | v = head xs}-tail         :: xs:{v: [a] | len v > 0} -> {v: [a] | len(v) = (len(xs) - 1) && v = tail xs}--last         :: xs:{v: [a] | len v > 0} -> a-init         :: xs:{v: [a] | len v > 0} -> {v: [a] | len(v) = len(xs) - 1}-null         :: xs:[a] -> {v: GHC.Types.Bool | ((v) <=> len(xs) = 0) }-length       :: xs:[a] -> {v: GHC.Types.Int | v = len(xs)}-filter       :: (a -> GHC.Types.Bool) -> xs:[a] -> {v: [a] | len(v) <= len(xs)}-scanl        :: (a -> b -> a) -> a -> xs:[b] -> {v: [a] | len(v) = 1 + len(xs) }-scanl1       :: (a -> a -> a) -> xs:{v: [a] | len(v) > 0} -> {v: [a] | len(v) = len(xs) }-foldr1       :: (a -> a -> a) -> xs:{v: [a] | len(v) > 0} -> a-scanr        :: (a -> b -> b) -> b -> xs:[a] -> {v: [b] | len(v) = 1 + len(xs) }-scanr1       :: (a -> a -> a) -> xs:{v: [a] | len(v) > 0} -> {v: [a] | len(v) = len(xs) }--lazy GHC.List.iterate-iterate :: (a -> a) -> a -> [a]--repeat :: a -> [a]-lazy GHC.List.repeat--replicate    :: n:Nat -> x:a -> {v: [{v:a | v = x}] | len(v) = n}--cycle        :: {v: [a] | len(v) > 0 } -> [a]-lazy cycle--takeWhile    :: (a -> GHC.Types.Bool) -> xs:[a] -> {v: [a] | len(v) <= len(xs)}-dropWhile    :: (a -> GHC.Types.Bool) -> xs:[a] -> {v: [a] | len(v) <= len(xs)}--take :: n:GHC.Types.Int-     -> xs:[a]-     -> {v:[a] | if n >= 0 then (len v = (if (len xs) < n then (len xs) else n)) else (len v = 0)}-drop :: n:GHC.Types.Int-     -> xs:[a]-     -> {v:[a] | (if (n >= 0) then (len(v) = (if (len(xs) < n) then 0 else len(xs) - n)) else ((len v) = (len xs)))}--splitAt :: n:_ -> x:[a] -> ({v:[a] | (if (n >= 0) then (if (len x) < n then (len v) = (len x) else (len v) = n) else ((len v) = 0))},[a])<{\x1 x2 -> (len x2) = (len x) - (len x1)}>-span    :: (a -> GHC.Types.Bool) -        -> xs:[a] -        -> ({v:[a]|((len v)<=(len xs))}, {v:[a]|((len v)<=(len xs))})--break :: (a -> GHC.Types.Bool) -> xs:[a] -> ([a],[a])<{\x y -> (len xs) = (len x) + (len y)}>--reverse      :: xs:[a] -> {v: [a] | len(v) = len(xs)}--include <len.hquals>--GHC.List.!!         :: xs:[a] -> {v: _ | ((0 <= v) && (v < len(xs)))} -> a---zip :: xs : [a] -> ys:[b]-            -> {v : [(a, b)] | ((((len v) <= (len xs)) && ((len v) <= (len ys)))-            && (((len xs) = (len ys)) => ((len v) = (len xs))) )}--zipWith :: (a -> b -> c) -        -> xs : [a] -> ys:[b] -        -> {v : [c] | (((len v) <= (len xs)) && ((len v) <= (len ys)))}--errorEmptyList :: {v: _ | false} -> a
− include/GHC/Num.spec 
@@ -1,9 +0,0 @@-module spec GHC.Num where--// embed GHC.Integer.Type.Integer as int --GHC.Num.fromInteger :: (GHC.Num.Num a) => x:_ -> {v:a | v = x }--GHC.Num.negate :: (GHC.Num.Num a)-               => x:a-               -> {v:a | v = -x}
− include/GHC/Prim.spec 
@@ -1,8 +0,0 @@-module spec GHC.Prim where --embed GHC.Prim.Int#     as int-embed GHC.Prim.Addr#    as Str-embed GHC.Prim.Char#    as Char-embed GHC.Prim.Double# as real-embed GHC.Prim.Float#  as real-embed GHC.Prim.Word#    as int
− include/GHC/Ptr.spec 
@@ -1,24 +0,0 @@-module spec GHC.Ptr where--measure pbase     :: GHC.Ptr.Ptr a -> GHC.Types.Int-measure plen      :: GHC.Ptr.Ptr a -> GHC.Types.Int-measure isNullPtr :: GHC.Ptr.Ptr a -> Bool --invariant {v:Foreign.Ptr.Ptr a | 0 <= plen  v }-invariant {v:Foreign.Ptr.Ptr a | 0 <= pbase v }--type PtrN a N = {v: PtrV a        | plen v == N }-type PtrV a   = {v: GHC.Ptr.Ptr a | 0 <= plen v }--GHC.Ptr.castPtr :: p:(PtrV a) -> (PtrN b (plen p))--GHC.Ptr.plusPtr :: base:(PtrV a)-                -> off:{v:GHC.Types.Int | v <= plen base }-                -> {v:(PtrV b) | pbase v = pbase base && plen v = plen base - off}--GHC.Ptr.minusPtr :: q:(PtrV a)-                 -> p:{v:(PtrV b) | pbase v == pbase q && plen v >= plen q}-                 -> {v:Nat | v == plen p - plen q}--measure deref     :: GHC.Ptr.Ptr a -> a-
− include/GHC/Read.spec 
@@ -1,5 +0,0 @@-module spec GHC.Read where--type ParsedString XS =  {v:_ | (if ((len XS) > 0) then ((len v) < (len XS)) else ((len v) = 0))}--GHC.Read.lex :: xs:_ -> [((ParsedString xs), (ParsedString xs))]
− include/GHC/Real.spec 
@@ -1,37 +0,0 @@-module spec GHC.Real where--(GHC.Real.^) :: (GHC.Num.Num a, GHC.Real.Integral b) => a:a -> n:b -> {v:a | v == 0 <=> a == 0 }--GHC.Real.fromIntegral    :: (GHC.Real.Integral a, GHC.Num.Num b) => x:a -> {v:b|v=x}--class (GHC.Num.Num a) => GHC.Real.Fractional a where-  (GHC.Real./)   :: x:a -> y:{v:a | v /= 0} -> {v:a | v == x / y}-  GHC.Real.recip :: a -> a-  GHC.Real.fromRational :: GHC.Real.Ratio Integer -> a--class (GHC.Real.Real a, GHC.Enum.Enum a) => GHC.Real.Integral a where-  GHC.Real.quot :: x:a -> y:{v:a | v /= 0} -> {v:a | (v = (x / y)) &&-                                                     ((x >= 0 && y >= 0) => v >= 0) &&-                                                     ((x >= 0 && y >= 1) => v <= x) }-  GHC.Real.rem :: x:a -> y:{v:a | v /= 0} -> {v:a | ((v >= 0) && (v < y))}-  GHC.Real.mod :: x:a -> y:{v:a | v /= 0} -> {v:a | v = x mod y && ((0 <= x && 0 < y) => (0 <= v && v < y))}--  GHC.Real.div :: x:a -> y:{v:a | v /= 0} -> {v:a | (v = (x / y)) &&-                                                    ((x >= 0 && y >= 0) => v >= 0) &&-                                                    ((x >= 0 && y >= 1) => v <= x) && -                                                    ((1 < y)            => v < x ) && -                                                    ((y >= 1)           => v <= x)  -                                                    }-  GHC.Real.quotRem :: x:a -> y:{v:a | v /= 0} -> ( {v:a | (v = (x / y)) &&-                                                          ((x >= 0 && y >= 0) => v >= 0) &&-                                                          ((x >= 0 && y >= 1) => v <= x)}-                                                 , {v:a | ((v >= 0) && (v < y))})-  GHC.Real.divMod :: x:a -> y:{v:a | v /= 0} -> ( {v:a | (v = (x / y)) &&-                                                         ((x >= 0 && y >= 0) => v >= 0) &&-                                                         ((x >= 0 && y >= 1) => v <= x) }-                                                , {v:a | v = x mod y && ((0 <= x && 0 < y) => (0 <= v && v < y))}-                                                )-  GHC.Real.toInteger :: x:a -> {v:GHC.Integer.Type.Integer | v = x}--//  fixpoint can't handle (x mod y), only (x mod c) so we need to be more clever here-//  mod :: x:a -> y:a -> {v:a | v = (x mod y) }
− include/GHC/Types.spec 
@@ -1,41 +0,0 @@-module spec GHC.Types where--embed GHC.Prim.Int#     as int-embed GHC.Prim.Addr#    as Str-embed GHC.Prim.Char#    as Char-embed GHC.Types.Double# as real-embed GHC.Types.Float# as real-embed GHC.Types.Word    as int --//  TODO: Drop prefix below-//  GHC.Types.EQ :: {v:GHC.Types.Ordering | v = (cmp v) }-//  GHC.Types.LT :: {v:GHC.Types.Ordering | v = (cmp v) }-//  GHC.Types.GT :: {v:GHC.Types.Ordering | v = (cmp v) }--//  measure cmp :: GHC.Types.Ordering -> GHC.Types.Ordering-//  cmp GHC.Types.EQ = { v | v = GHC.Types.EQ }-//  cmp GHC.Types.LT = { v | v = GHC.Types.LT }-//  cmp GHC.Types.GT = { v | v = GHC.Types.GT }---GHC.Types.True  :: {v:GHC.Types.Bool | v     }-GHC.Types.False :: {v:GHC.Types.Bool | (~ v) }--GHC.Types.isTrue#  :: n:_ -> {v:GHC.Types.Bool | (n = 1 <=> v)}--GHC.Types.W# :: w:_ -> {v:GHC.Types.Word | v == w }--assume GHC.Types.D# :: x:GHC.Prim.Double# -> {v: GHC.Types.Double | v = (x :: real) }-assume GHC.Types.F# :: x:GHC.Prim.Float# -> {v: GHC.Types.Float | v = (x :: real) }-assume GHC.Types.I# :: x:GHC.Prim.Int# -> {v: GHC.Types.Int | v = (x :: int) }-assume GHC.Types.C# :: x:GHC.Prim.Char# -> {v: GHC.Types.Char | v = (x :: Char) }--assume GHC.Prim.+#  :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v: GHC.Prim.Int# | v = x + y}-assume GHC.Prim.-#  :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v: GHC.Prim.Int# | v = x - y}-assume GHC.Prim.==# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v:GHC.Prim.Int# | v = 1 <=> x = y}-assume GHC.Prim.>=# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v:GHC.Prim.Int# | v = 1 <=> x >= y}-assume GHC.Prim.<=# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v:GHC.Prim.Int# | v = 1 <=> x <= y}-assume GHC.Prim.<#  :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v:GHC.Prim.Int# | v = 1 <=> x < y}-assume GHC.Prim.>#  :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v:GHC.Prim.Int# | v = 1 <=> x > y}--measure addrLen :: GHC.Prim.Addr# -> GHC.Types.Int
− include/GHC/Word.spec 
@@ -1,7 +0,0 @@-module spec GHC.Word where--embed GHC.Word.Word   as int-embed GHC.Word.Word8  as int-embed GHC.Word.Word16 as int-embed GHC.Word.Word32 as int-embed GHC.Word.Word64 as int
− include/KMeansHelper.hs 
@@ -1,78 +0,0 @@-module KMeansHelper where--import Prelude hiding (zipWith)-import Data.List (sort, span, minimumBy)-import Data.Function (on)-import Data.Ord (comparing)-import Language.Haskell.Liquid.Prelude (liquidAssert, liquidError)----- | Fixed-Length Lists--{-@ type List a N = {v : [a] | (len v) = N} @-}----- | N Dimensional Points--{-@ type Point N = List Double N @-}--{-@ type NonEmptyList a = {v : [a] | (len v) > 0} @-}---- | Clustering --{-@ type Clustering a  = [(NonEmptyList a)] @-}----------------------------------------------------------------------- | Grouping By a Predicate ----------------------------------------------------------------------------------------------------------{-@ groupBy       :: (a -> a -> Bool) -> [a] -> (Clustering a) @-}-groupBy _  []     =  []-groupBy eq (x:xs) =  (x:ys) : groupBy eq zs-  where (ys,zs)   = span (eq x) xs----------------------------------------------------------------------- | Partitioning By a Size -----------------------------------------------------------------------------------------------------------{-@ type PosInt = {v: Int | v > 0 } @-}--{-@ partition           :: size:PosInt -> xs:[a] -> (Clustering a) / [len xs] @-}--partition size []       = []-partition size ys@(_:_) = zs : partition size zs'-  where-    zs                  = take size ys-    zs'                 = drop size ys---------------------------------------------------------------------------- | Safe Zipping -------------------------------------------------------------------------------------------------------------------------------{-@ zipWith :: (a -> b -> c) -> xs:[a] -> (List b (len xs)) -> (List c (len xs)) @-}-zipWith f (a:as) (b:bs) = f a b : zipWith f as bs-zipWith _ [] []         = []---- Other cases only for exposition-zipWith _ (_:_) []      = liquidError "Dead Code"-zipWith _ [] (_:_)      = liquidError "Dead Code"---------------------------------------------------------------------------- | "Matrix" Transposition ---------------------------------------------------------------------------------------------------------------------{-@ type Matrix a Rows Cols  = (List (List a Cols) Rows) @-}--{-@ transpose                :: c:Int -> r:PosInt -> Matrix a r c -> Matrix a c r @-}--transpose                    :: Int -> Int -> [[a]] -> [[a]]-transpose 0 _ _              = []-transpose c r ((x:xs) : xss) = (x : map head xss) : transpose (c-1) r (xs : map tail xss)---- Or, with comprehensions--- transpose c r ((x:xs):xss) = (x : [ xs' | (x':_) <- xss ]) : transpose (c-1) r (xs : [xs' | (_ : xs') <- xss])---- Not needed, just for exposition-transpose c r ([] : _)       = liquidError "dead code"-transpose c r []             = liquidError "dead code"-
− include/Language/Haskell/Liquid/Bag.hs 
@@ -1,53 +0,0 @@-module Language.Haskell.Liquid.Bag where--import qualified Data.Map      as M--{-@ embed   Data.Map.Map as Map_t                                         @-}--{-@ measure Map_default :: Int -> Bag a                                   @-}-{-@ measure Map_union   :: Bag a -> Bag a -> Bag a                        @-}-{-@ measure Map_select  :: Data.Map.Map k v -> k -> v                     @-}-{-@ measure Map_store   :: Data.Map.Map k v -> k -> v -> Data.Map.Map k v @-}-{-@ measure bagSize     :: Bag k -> Int                                   @-}---- if I just write measure fromList the measure definition is not imported-{-@ measure fromList :: [k] -> Bag k-      fromList []     = Map_default 0-      fromList (x:xs) = Map_store (fromList xs) x (1 + (Map_select (fromList xs) x))-  @-}---type Bag a = M.Map a Int--{-@ assume empty :: {v:Bag k | v = Map_default 0} @-}-empty :: Bag k-empty = M.empty--{-@ assume bagSize :: b:Bag k -> {i:Nat | i == bagSize b} @-}-bagSize :: Bag k -> Int -bagSize b = sum (M.elems b) --{-@ fromList :: (Ord k) => xs:[k] -> {v:Bag k | v == fromList xs } @-} -fromList :: (Ord k) => [k] -> Bag k -fromList []     = empty-fromList (x:xs) = put x (fromList xs)--{-@ assume get :: (Ord k) => k:k -> b:Bag k -> {v:Nat | v = Map_select b k}  @-}-get :: (Ord k) => k -> Bag k -> Int-get k m = M.findWithDefault 0 k m--{-@ assume put :: (Ord k) => k:k -> b:Bag k -> {v:Bag k | v = Map_store b k (1 + (Map_select b k))} @-}-put :: (Ord k) => k -> Bag k -> Bag k-put k m = M.insert k (1 + get k m) m--{-@ assume union :: (Ord k) => m1:Bag k -> m2:Bag k -> {v:Bag k | v = Map_union m1 m2} @-}-union :: (Ord k) => Bag k -> Bag k -> Bag k-union m1 m2 = M.union m1 m2--{-@ thm_emp :: x:k -> xs:Bag k ->  { Language.Haskell.Liquid.Bag.empty /= put x xs }  @-}-thm_emp :: (Ord k) => k -> Bag k -> ()  -thm_emp x xs = const () (get x xs)--{-@ assume thm_size :: xs:[k] ->  { bagSize (fromList xs) == len xs }  @-}-thm_size :: (Ord k) => [k] -> ()  -thm_size _ = ()
− include/Language/Haskell/Liquid/Equational.hs 
@@ -1,55 +0,0 @@-module Language.Haskell.Liquid.Equational where ------------------------------------------------------------------------------------ | Proof is just unit----------------------------------------------------------------------------------type Proof = ()------------------------------------------------------------------------------------ | Casting expressions to Proof using the "postfix" `*** QED` ----------------------------------------------------------------------------------data QED = QED --infixl 2 ***-(***) :: a -> QED -> Proof-_ *** QED = () ------------------------------------------------------------------------------------ | Equational Reasoning operators --- | The `eq` operator is inlined in the logic, so can be used in reflected --- | functions while ignoring the equality steps. ----------------------------------------------------------------------------------infixl 3 ==., `eq` ---{-@ (==.) :: x:a -> y:{a | x == y} -> {v:a | v == y && v == x} @-}-(==.) :: a -> a -> a -_ ==. x = x -{-# INLINE (==.) #-} ---{-@ eq :: x:a -> y:{a | x == y} -> {v:a | v == y && v == x} @-}-eq :: a -> a -> a -_ `eq` x = x -{-# INLINE eq #-} ------------------------------------------------------------------------------------ | Explanations----------------------------------------------------------------------------------infixl 3 ?--{-@ (?) :: forall a b <pa :: a -> Bool>. a<pa> -> b -> a<pa> @-}-(?) :: a -> b -> a -x ? _ = x -{-# INLINE (?)   #-} ------------------------------------------------------------------------------------ | Using proofs as theorems ----------------------------------------------------------------------------------withTheorem :: a -> Proof -> a -withTheorem z _ = z
− include/Language/Haskell/Liquid/Foreign.hs 
@@ -1,64 +0,0 @@-{-# OPTIONS_GHC -fno-warn-unused-imports #-}-{-# LANGUAGE MagicHash #-}--{- OPTIONS_GHC -cpp #-}-{- OPTIONS_GHC -cpp -fglasgow-exts -}--module Language.Haskell.Liquid.Foreign where--import Foreign.C.Types          (CSize(..))-import Foreign.Ptr-import Foreign.ForeignPtr-import GHC.Base--import Data.Word (Word64) -- Necessary to bring in scope the evidence that Word64 = int---- TODO: shouldn't have to re-import these (tests/pos/imp0.hs)-{- import Foreign.C.Types    -}-{- import Foreign.Ptr        -}-{- import Foreign.ForeignPtr -}-{- import GHC.Base           -}-----------------------------------------------------------------------------------------------------{-# NOINLINE intCSize #-}-{-@ assume intCSize :: x:Int -> {v: CSize | v = x } @-}-intCSize :: Int -> CSize-intCSize = fromIntegral--{-# NOINLINE cSizeInt #-}-{-@ assume cSizeInt :: x:CSize -> {v: Int | v = x } @-}-cSizeInt :: CSize -> Int-cSizeInt = fromIntegral---{-@ assume mkPtr :: x:GHC.Prim.Addr# -> {v: (Ptr b) | ((plen v) = (addrLen x) && ((plen v) >= 0)) } @-}-mkPtr   :: Addr# -> Ptr b-mkPtr = undefined -- Ptr x---{-@ assume isNullPtr :: p:(Ptr a) -> {v:Bool | (v <=> (isNullPtr p)) } @-}-isNullPtr :: Ptr a -> Bool-isNullPtr p = (p == nullPtr)-{-# INLINE isNullPtr #-}--{-@ fpLen :: p:(ForeignPtr a) -> {v:Int | v = (fplen p) } @-}-fpLen :: ForeignPtr a -> Int-fpLen = undefined--{-@ pLen :: p:(Ptr a) -> {v:Int | v = (plen p) } @-}-pLen :: Ptr a -> Int-pLen = undefined--{-@ deref :: p:Ptr a -> {v:a | v = (deref p)} @-}-deref :: Ptr a -> a-deref = undefined--{-@ eqPtr :: p:PtrV a-          -> q:{v:PtrV a | (((pbase v) = (pbase p)) && ((plen v) <= (plen p)))}-          -> {v:Bool | (v <=> ((plen p) = (plen q)))}-  @-}-eqPtr :: Ptr a -> Ptr a -> Bool-eqPtr = undefined
− include/Language/Haskell/Liquid/List.hs 
@@ -1,7 +0,0 @@-module Language.Haskell.Liquid.List (transpose) where--{-@ lazy transpose @-}-transpose                  :: Int -> [[a]] -> [[a]]-transpose _ []             = []-transpose n ([]   : xss)   = transpose n xss-transpose n ((x:xs) : xss) = (x : [h | (h:_) <- xss]) : transpose (n - 1) (xs : [ t | (_:t) <- xss])
− include/Language/Haskell/Liquid/Prelude.hs 
@@ -1,142 +0,0 @@-{-# LANGUAGE MagicHash      #-}--module Language.Haskell.Liquid.Prelude where------------------------------------------------------------------------------------------------- Arithmetic --------------------------------------------------------------------------------------------------{-@ assume plus   :: x:{v:Int | true } -> y:{v:Int | true} -> {v:Int | v = x + y}  @-}-{-@ assume minus  :: x:{v:Int | true } -> y:{v:Int | true} -> {v:Int | v = x - y} @-}-{-@ assume times  :: x:Int -> y:Int -> Int                           @-}-{-@ assume eq     :: x:Int -> y:Int -> {v:Bool | ((v) <=> x = y)}  @-}-{-@ assume neq    :: x:Int -> y:Int -> {v:Bool | ((v) <=> x != y)} @-}-{-@ assume leq    :: x:Int -> y:Int -> {v:Bool | ((v) <=> x <= y)} @-}-{-@ assume geq    :: x:Int -> y:Int -> {v:Bool | ((v) <=> x >= y)} @-}-{-@ assume lt     :: x:Int -> y:Int -> {v:Bool | ((v) <=> x < y)}  @-}-{-@ assume gt     :: x:Int -> y:Int -> {v:Bool | ((v) <=> x > y)}  @-}--{-# NOINLINE plus #-}-plus :: Int -> Int -> Int-plus x y = x + y--{-# NOINLINE minus #-}-minus :: Int -> Int -> Int-minus x y = x - y--{-# NOINLINE times #-}-times :: Int -> Int -> Int-times x y = x * y------------------------------------------------------------------------------------------------- Comparisons -------------------------------------------------------------------------------------------------{-# NOINLINE eq #-}-eq :: Int -> Int -> Bool-eq x y = x == y--{-# NOINLINE neq #-}-neq :: Int -> Int -> Bool-neq x y = not (x == y)--{-# NOINLINE leq #-}-leq :: Int -> Int -> Bool-leq x y = x <= y--{-# NOINLINE geq #-}-geq :: Int -> Int -> Bool-geq x y = x >= y--{-# NOINLINE lt #-}-lt :: Int -> Int -> Bool-lt x y = x < y--{-# NOINLINE gt #-}-gt :: Int -> Int -> Bool-gt x y = x > y---------------------------------------------------------------------------------------------- Specifications --------------------------------------------------------------------------------------------------{-@ ignore liquidAssertB @-}-{-@ assume liquidAssertB :: x:{v:Bool | v} -> {v: Bool | v} @-}-{-# NOINLINE liquidAssertB #-}-liquidAssertB :: Bool -> Bool-liquidAssertB b = b--{-@ assume liquidAssert :: {v:Bool | v} -> a -> a  @-}-{-# NOINLINE liquidAssert #-}-liquidAssert :: Bool -> a -> a-liquidAssert _ x = x--{-@ ignore liquidAssume @-}-{-@ assume liquidAssume :: b:Bool -> a -> {v: a | b}  @-}-{-# NOINLINE liquidAssume #-}-liquidAssume :: Bool -> a -> a-liquidAssume b x = if b then x else error "liquidAssume fails"--{-@ ignore liquidAssumeB @-}-{-@ assume liquidAssumeB :: forall <p :: a -> Bool>. (a<p> -> {v:Bool| v}) -> a -> a<p> @-}-liquidAssumeB :: (a -> Bool) -> a -> a-liquidAssumeB p x | p x = x-                  | otherwise = error "liquidAssumeB fails"---{-@ ignore unsafeError @-}-{-# NOINLINE unsafeError #-}-unsafeError :: String -> a-unsafeError = error---{-@ liquidError :: {v:String | 0 = 1} -> a  @-}-{-# NOINLINE liquidError #-}-liquidError :: String -> a-liquidError = error--{-@ assume crash  :: forall a . x:{v:Bool | v} -> a @-}-{-# NOINLINE crash #-}-crash :: Bool -> a-crash = undefined--{-# NOINLINE force #-}-force :: Bool-force = True--{-# NOINLINE choose #-}-choose :: Int -> Int-choose = undefined--------------------------------------------------------------------------------- Modular Arithmetic Wrappers --------------------------------------------------------------------------------------------------- tedium because fixpoint doesn't want to deal with (x mod y) only (x mod c)-{-@ assume isEven :: x:Int -> {v:Bool | ((v) <=> ((x mod 2) = 0))} @-}-{-# NOINLINE isEven #-}-isEven   :: Int -> Bool-isEven x = x `mod` 2 == 0--{-@ assume isOdd :: x:Int -> {v:Bool | ((v) <=> ((x mod 2) = 1))} @-}-{-# NOINLINE isOdd #-}-isOdd   :: Int -> Bool-isOdd x = x `mod` 2 == 1---------------------------------------------------------------------------------------------------{-@ safeZipWith :: (a -> b -> c) -> xs : [a] -> ys:{v:[b] | len v = len xs} -                -> {v : [c] | len v = len xs } @-}-safeZipWith :: (a->b->c) -> [a]->[b]->[c]-safeZipWith f (a:as) (b:bs) = f a b : safeZipWith f as bs-safeZipWith _ []     []     = []-safeZipWith _ _ _ = error "safeZipWith: cannot happen!"--{-@ (==>) :: p:Bool -> q:Bool -> {v:Bool | v <=> (p =>  q)} @-}-infixr 8 ==>-(==>) :: Bool -> Bool -> Bool-False ==> False = True-False ==> True  = True-True  ==> True  = True-True  ==> False = False
− include/Language/Haskell/Liquid/Prelude.pred 
@@ -1,22 +0,0 @@-assume (>) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> Bool-assume (<) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> Bool-assume (>=) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> Bool-assume (<=) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> Bool-assume (==) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> Bool-assume (+) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> a^True-assume (*) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> a^True-assume (-) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> a^True-assume ($) :: forall a b. forAll q1:a q2:b. (a^q1 -> b^q2) -> a^q1 -> b^q2-assume (.) :: forall b c a. forAll q1:a q2:b q3:c. (b^q2 -> c^q3) -> (a^q1 -> b^q2) -> a^q1 -> c^q3-assume filter :: forall a. forAll p1:a. (a^p1 -> Bool) -> [a^p1]-> [a^p1]-assume snd :: forall a b. forAll p1:a p2:b. (a^p1, b^p2)-> b^p2-assume map :: forall a b. forAll q1:a q2:b. (a^q1 -> b^q2) -> [a^q1]-> [b^q2]-assume (++) :: forall a. forAll q:a. [a^q]-> [a^q]-> [a^q]-assume concat :: forall a. forAll q:a. [[a^q]]-> [a^q]-assume foldl :: forall a b. forAll q1:a q2:b. (a^q1 -> b^q2 -> a^q1) -> a^q1 -> [b^q2]-> a^q1-assume foldr :: forall a b. forAll q1:a q2:b. (a^q1 -> b^q2 -> b^q2) -> b^q2 -> [a^q1]-> b^q2-assume (,) :: forall a b. forAll q1:a q2:b. a^q1 -> b^q2 ->(a^q1, b^q2)-assume Prelude.error :: forall a. forAll q2:a. [Char]-> a^q2-assume Prelude.head :: forall a. forAll q:a. [a^q]-> a^q-assume Prelude.tail :: forall a. forAll q:a. [a^q]-> [a^q]-assume Prelude.enumFromTo :: forall a. forAll q:a. (Enum a^ True) => a^q -> a^q -> [a^q]
− include/Language/Haskell/Liquid/ProofCombinators.hs 
@@ -1,183 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE IncoherentInstances   #-}--module Language.Haskell.Liquid.ProofCombinators (--  -- ATTENTION! `Admit` and `(==!)` are UNSAFE: they should not belong the final proof term--  -- * Proof is just a () alias-  Proof-  , toProof --  -- * Proof constructors-  , trivial, unreachable, (***), QED(..)--  -- * Proof certificate constructors-  , (?)--  -- * These two operators check all intermediate equalities-  , (===) -- proof of equality is implicit eg. x === y-  , (=<=) -- proof of equality is implicit eg. x <= y-  , (=>=)  -- proof of equality is implicit eg. x =>= y --  -- * This operator does not check intermediate equalities-  , (==.) --  -- Uncheck operator used only for proof debugging-  , (==!) -- x ==! y always succeeds--  -- * Combining Proofs-  , (&&&)-  , withProof -  , impossible ---) where------------------------------------------------------------------------------------ | Proof is just a () alias -----------------------------------------------------------------------------------------------------------------------------------type Proof = ()--toProof :: a -> Proof-toProof _ = ()------------------------------------------------------------------------------------ | Proof Construction ------------------------------------------------------------------------------------------------------------------------------------------- | trivial is proof by SMT--trivial :: Proof-trivial =  ()---- {-@ unreachable :: {v : Proof | False } @-}-unreachable :: Proof-unreachable =  ()---- All proof terms are deleted at runtime.-{- RULE "proofs are irrelevant" forall (p :: Proof). p = () #-}---- | proof casting--- | `x *** QED`: x is a proof certificate* strong enough for SMT to prove your theorem--- | `x *** Admit`: x is an unfinished proof--infixl 3 ***-{-@ assume (***) :: a -> p:QED -> { if (isAdmit p) then false else true } @-}-(***) :: a -> QED -> Proof-_ *** _ = ()--data QED = Admit | QED--{-@ measure isAdmit :: QED -> Bool @-}-{-@ Admit :: {v:QED | isAdmit v } @-}------------------------------------------------------------------------------------- | * Checked Proof Certificates --------------------------------------------------------------------------------------------------------------------------------- Any (refined) carries proof certificates.--- For example 42 :: {v:Int | v == 42} is a certificate that--- the value 42 is equal to 42.--- But, this certificate will not really be used to proof any fancy theorems.---- Below we provide a number of equational operations--- that constuct proof certificates.---- | Implicit equality---- x === y returns the proof certificate that--- result value is equal to both x and y--- when y == x (as assumed by the operator's precondition)--infixl 3 ===-{-@ (===) :: x:a -> y:{a | y == x} -> {v:a | v == x && v == y} @-}-(===) :: a -> a -> a-_ === y  = y--infixl 3 =<=-{-@ (=<=) :: x:a -> y:{a | x <= y} -> {v:a | v == y} @-}-(=<=) :: a -> a -> a-_ =<= y  = y--infixl 3 =>=-{-@ (=>=) :: x:a -> y:{a | x >= y}  -> {v:a | v == y} @-}-(=>=) :: a -> a -> a-_ =>= y  = y------------------------------------------------------------------------------------ | `?` is basically Haskell's $ and is used for the right precedence--- | `?` lets you "add" some fact into a proof term----------------------------------------------------------------------------------infixl 3 ?--{-@ (?) :: forall a b <pa :: a -> Bool, pb :: b -> Bool>. a<pa> -> b<pb> -> a<pa> @-}-(?) :: a -> b -> a -x ? _ = x -{-# INLINE (?)   #-} ------------------------------------------------------------------------------------ | Assumed equality--- 	`x ==! y `---   returns the admitted proof certificate that result value is equals x and y----------------------------------------------------------------------------------infixl 3 ==!-{-@ assume (==!) :: x:a -> y:a -> {v:a | v == x && v == y} @-}-(==!) :: a -> a -> a-(==!) _ y = y----- | To summarize:------ 	- (==!) is *only* for proof debugging---	- (===) does not require explicit proof term--- 	- (?)   lets you insert "lemmas" as other `Proof` values------------------------------------------------------------------------------------ | * Unchecked Proof Certificates ------------------------------------------------------------------------------------------------------------------------------- | The above operators check each intermediate proof step.---   The operator `==.` below accepts an optional proof term---   argument, but does not check intermediate steps.---   TODO: What is it USEFUL FOR?--infixl 3 ==.--{-# DEPRECATED (==.) "Use (===) instead" #-}--{-# INLINE (==.) #-} -(==.) :: a -> a -> a -_ ==. x = x ------------------------------------------------------------------------------------ | * Combining Proof Certificates -----------------------------------------------------------------------------------------------------------------------------(&&&) :: Proof -> Proof -> Proof-x &&& _ = x---{-@ withProof :: x:a -> b -> {v:a | v = x} @-}-withProof :: a -> b -> a-withProof x _ = x--{-@ impossible :: {v:a | false} -> b @-}-impossible :: a -> b-impossible _ = undefined------------------------------------------------------------------------------------ | Convenient Syntax for Inductive Propositions ----------------------------------------------------------------------------------{-@ measure prop :: a -> b           @-}-{-@ type Prop E = {v:_ | prop v = E} @-}---
− include/Language/Haskell/Liquid/RTick.hs 
@@ -1,440 +0,0 @@------- Liquidate your assets: reasoning about resource usage in Liquid Haskell.--- Martin A.T. Handley, Niki Vazou, and Graham Hutton.-----{-@ LIQUID "--reflection" @-}--module Language.Haskell.Liquid.RTick-  (--  -- Tick datatype:-    Tick(..)-  -- Primitive resource operators:-  , fmap-  , pure-  , (<*>)-  , liftA2-  , return-  , (>>=)-  , (=<<)-  , eqBind-  , leqBind-  , geqBind-  , ap-  , liftM-  , liftM2-  -- Resource modifiers:-  , step-  , wait      -- step 1       . return-  , waitN     -- step (n > 0) . return-  , go        -- step (-1)    . return-  , goN       -- step (n < 0) . return-  , wmap      -- step 1       . fmap f-  , wmapN     -- step (n > 0) . fmap f-  , gmap      -- step (-1)    . fmap f-  , gmapN     -- step (n < 0) . fmap f-  , (</>)     -- step 1       . (f <*>)-  , (<//>)    -- step 2       . (f <*>)-  , (<\>)     -- step (-1)    . (f <*>)-  , (<\\>)    -- step (-2)    . (f <*>)-  , (>/=)     -- step 1       . (>>= f)-  , (=/<)     -- step 1       . (>>= f)-  , (>//=)    -- step 2       . (>>= f)-  , (=//<)    -- step 2       . (>>= f)-  , (>\=)     -- step (-1)    . (>>= f)-  , (=\<)     -- step (-1)    . (>>= f)-  , (>\\=)    -- step (-2)    . (>>= f)-  , (=\\<)    -- step (-2)    . (>>= f)-  -- Memoisation:-  , pay-  , zipWithM---  ) where--import Prelude hiding ( Functor(..), Applicative(..), Monad(..), (=<<) )--import qualified Control.Applicative as A-import qualified Control.Monad       as M-import qualified Data.Functor        as F------- The 'Tick' datatype and its corresponding resource modifiers.------ See 'ResourceModifiers.hs' for proofs that all resource modifiers--- can be defined using 'return', '(>>=) 'and 'step'.--------------------------------------------------------------------------------------- | 'Tick' datatype for recording resource usage:----------------------------------------------------------------------------------{-@ data Tick a = Tick { tcost :: Int, tval :: a } @-}-data Tick a = Tick { tcost :: Int, tval :: a }------------------------------------------------------------------------------------ | Primitive resource operators:----------------------------------------------------------------------------------instance F.Functor Tick where-  fmap = fmap--{-@ reflect fmap @-}-{-@ fmap :: f:(a -> b) -> t1:Tick a-    -> { t:Tick b | Tick (tcost t1) (f (tval t1)) == t }-@-}-fmap :: (a -> b) -> Tick a -> Tick b-fmap f (Tick m x) = Tick m (f x)--instance A.Applicative Tick where-  pure  = pure-  (<*>) = (<*>)--{-@ reflect pure @-}-{-@ pure :: x:a -> { t:Tick a | x == tval t && 0 == tcost t } @-}-pure :: a -> Tick a-pure x = Tick 0 x--{-@ reflect <*> @-}-{-@ (<*>) :: t1:Tick (a -> b) -> t2:Tick a-    -> { t:Tick b | (tval t1) (tval t2) == tval  t &&-                    tcost t1 + tcost t2 == tcost t }-@-}-infixl 4 <*>-(<*>) :: Tick (a -> b) -> Tick a -> Tick b-Tick m f <*> Tick n x = Tick (m + n) (f x)--{-@ reflect liftA2 @-}-{-@ liftA2 :: f:(a -> b -> c) -> t1:Tick a -> t2:Tick b-    -> { t:Tick c | f (tval t1) (tval t2) == tval  t &&-                      tcost t1 + tcost t2 == tcost t }-@-}-liftA2 :: (a -> b -> c) -> Tick a -> Tick b -> Tick c-liftA2 f (Tick m x) (Tick n y) = Tick (m + n) (f x y)--instance M.Monad Tick where-  return = return-  (>>=)  = (>>=)--{-@ reflect return @-}-{-@ return :: x:a -> { t:Tick a | x == tval t && 0 == tcost t } @-}-return :: a -> Tick a-return x = Tick 0 x--{-@ reflect >>= @-}-{-@ (>>=) :: t1:Tick a -> f:(a -> Tick b)-    -> { t:Tick b | tval (f (tval t1))  == tval  t &&-         tcost t1 + tcost (f (tval t1)) == tcost t }-@-}-infixl 4 >>=-(>>=) :: Tick a -> (a -> Tick b) -> Tick b-Tick m x >>= f = let Tick n y = f x in Tick (m + n) y--{-@ reflect =<< @-}-{-@ (=<<) :: f:(a -> Tick b) -> t1:Tick a-    -> { t:Tick b | tval (f (tval t1))  == tval  t &&-         tcost t1 + tcost (f (tval t1)) == tcost t }-@-}-infixl 4 =<<-(=<<) :: (a -> Tick b) -> Tick a -> Tick b-f =<< Tick m x = let Tick n y = f x in Tick (m + n) y--{-@ reflect ap @-}-{-@ ap :: t1:(Tick (a -> b)) -> t2:Tick a-    -> { t:Tick b | (tval t1) (tval t2) == tval  t &&-                    tcost t1 + tcost t2 == tcost t }-@-}-ap :: Tick (a -> b) -> Tick a -> Tick b-ap (Tick m f) (Tick n x) = Tick (m + n) (f x)--{-@ reflect liftM @-}-{-@ liftM :: f:(a -> b) -> t1:Tick a -> { t:Tick b | tcost t1 == tcost t } @-}-liftM :: (a -> b) -> Tick a -> Tick b-liftM f (Tick m x) = Tick m (f x)--{-@ reflect liftM2 @-}-{-@ liftM2 :: f:(a -> b -> c) -> t1:Tick a -> t2:Tick b-    -> { t:Tick c | f (tval t1) (tval t2) == tval  t &&-                      tcost t1 + tcost t2 == tcost t }-@-}-liftM2 :: (a -> b -> c) -> Tick a -> Tick b -> Tick c-liftM2 f (Tick m x) (Tick n y) = Tick (m + n) (f x y)-----------------------------------------------------------------------------------{-@ reflect eqBind @-}-{-@ eqBind :: n:Int -> t1:Tick a-    -> f:(a -> { tf:Tick b | n == tcost tf })-    -> { t:Tick b | tval (f (tval t1))  == tval  t &&-                           tcost t1 + n == tcost t }-@-}-eqBind :: Int -> Tick a -> (a -> Tick b) -> Tick b-eqBind _ (Tick m x) f = let Tick n y = f x in Tick (m + n) y--{-@ reflect leqBind @-}-{-@ leqBind :: n:Int -> t1:Tick a-    -> f:(a -> { tf:Tick b | n >= tcost tf })-    -> { t:Tick b | tcost t1 + n >= tcost t }-@-}-leqBind :: Int -> Tick a -> (a -> Tick b) -> Tick b-leqBind _ (Tick m x) f = let Tick n y = f x in Tick (m + n) y--{-@ reflect geqBind @-}-{-@ geqBind :: n:Int -> t1:Tick a-    -> f:(a -> { tf:Tick b | n <= tcost tf })-    -> { t2:Tick b | tcost t1 + n <= tcost t2 }-@-}-geqBind :: Int -> Tick a -> (a -> Tick b) -> Tick b-geqBind _ (Tick m x) f = let Tick n y = f x in Tick (m + n) y------------------------------------------------------------------------------------ | Resource modifiers:----------------------------------------------------------------------------------{-@ reflect step @-}-{-@ step :: m:Int -> t1:Tick a-    -> { t:Tick a | tval t1 == tval t && m + tcost t1 == tcost t }-@-}-step :: Int -> Tick a -> Tick a-step m (Tick n x) = Tick (m + n) x------- @wait := step 1 . return@.----{-@ reflect wait @-}-{-@ wait :: x:a -> { t:Tick a | x == tval t && 1 == tcost t } @-}-wait :: a -> Tick a-wait x = Tick 1 x------- @waitN (n > 0) := step n . return@.----{-@ reflect waitN @-}-{-@ waitN :: n:Nat -> x:a-    -> { t:Tick a | x == tval t && n == tcost t }-@-}-waitN :: Int -> a -> Tick a-waitN n x = Tick n x------- @go := step (-1) . return@.----{-@ reflect go @-}-{-@ go :: x:a -> { t:Tick a | x == tval t && (-1) == tcost t } @-}-go :: a -> Tick a-go x = Tick (-1) x------- @goN (n > 0) := step (-n) . return@.----{-@ reflect goN @-}-{-@ goN :: { n:Nat | n > 0 } -> x:a-    -> { t:Tick a | x == tval t && (-n) == tcost t }-@-}-goN :: Int -> a -> Tick a-goN n x = Tick (-n) x------- @wmap f := step 1 . fmap f@.----{-@ reflect wmap @-}-{-@ wmap :: f:(a -> b) -> t1:Tick a-    -> { t:Tick b | Tick (1 + tcost t1) (f (tval t1)) == t }-@-}-wmap :: (a -> b) -> Tick a -> Tick b-wmap f (Tick m x) = Tick (1 + m) (f x)------- @wmapN (n > 0) f := step n . fmap f@.----{-@ reflect wmapN @-}-{-@ wmapN :: { m:Nat | m > 0 } -> f:(a -> b) -> t1:Tick a-    -> { t:Tick b | Tick (m + tcost t1) (f (tval t1)) == t }-@-}-wmapN :: Int -> (a -> b) -> Tick a -> Tick b-wmapN m f (Tick n x) = Tick (m + n) (f x)------- @gmap f := step (-1) . fmap f@.----{-@ reflect gmap @-}-{-@ gmap :: f:(a -> b) -> t1:Tick a-    -> { t:Tick b | Tick (tcost t1 - 1) (f (tval t1)) == t }-@-}-gmap :: (a -> b) -> Tick a -> Tick b-gmap f (Tick m x) = Tick (m - 1) (f x)------- @gmapN (n > 0) f := step (-n) . fmap f@.----{-@ reflect gmapN @-}-{-@ gmapN :: { m:Nat | m > 0 } -> f:(a -> b) -> t1:Tick a-    -> { t:Tick b | Tick (tcost t1 - m) (f (tval t1)) == t }-@-}-gmapN :: Int -> (a -> b) -> Tick a -> Tick b-gmapN m f (Tick n x) = Tick (n - m) (f x)------- \"wapp\": @(f </>) := step 1 . (f <*>)@.----{-@ reflect </> @-}-{-@ (</>) :: t1:(Tick (a -> b)) -> t2:Tick a-    -> { t:Tick b | (tval t1) (tval t2) == tval  t &&-                1 + tcost t1 + tcost t2 == tcost t }-@-}-infixl 4 </>-(</>) :: Tick (a -> b) -> Tick a -> Tick b-Tick m f </> Tick n x = Tick (1 + m + n) (f x)------- \"wwapp\": @(f <//>) := step 2 . (f <*>)@.----{-@ reflect <//> @-}-{-@ (<//>) :: t1:(Tick (a -> b)) -> t2:Tick a-    -> { t:Tick b | (tval t1) (tval t2) == tval  t &&-                2 + tcost t1 + tcost t2 == tcost t }-@-}-infixl 4 <//>-(<//>) :: Tick (a -> b) -> Tick a -> Tick b-Tick m f <//> Tick n x = Tick (2 + m + n) (f x)------- \"gapp\": @(f <\>) := step (-1) . (f <*>)@.----{-@ reflect <\> @-}-{-@ (<\>) :: t1:(Tick (a -> b)) -> t2:Tick a-    -> { t:Tick b | (tval t1) (tval t2) == tval  t &&-                tcost t1 + tcost t2 - 1 == tcost t }-@-}-infixl 4 <\>-(<\>) :: Tick (a -> b) -> Tick a -> Tick b-Tick m f <\> Tick n x = Tick (m + n - 1) (f x)------- \"ggapp\": @(f <\\>) := step (-2) . (f <*>)@.----{-@ reflect <\\> @-}-{-@ (<\\>) :: t1:(Tick (a -> b)) -> t2:Tick a-    -> { t:Tick b | (tval t1) (tval t2) == tval  t &&-                tcost t1 + tcost t2 - 2 == tcost t }-@-}-infixl 4 <\\>-(<\\>) :: Tick (a -> b) -> Tick a -> Tick b-Tick m f <\\> Tick n x = Tick (m + n - 2) (f x)------- \"wbind\": @(>/= f) := step 1 . (>>= f)@.----{-@ reflect >/= @-}-{-@ (>/=) :: t1:Tick a -> f:(a -> Tick b)-    -> { t:Tick b | (tval (f (tval t1))      == tval  t) &&-         (1 + tcost t1 + tcost (f (tval t1))) == tcost t }-@-}-infixl 4 >/=-(>/=) :: Tick a -> (a -> Tick b) -> Tick b-Tick m x >/= f = let Tick n y = f x in Tick (1 + m + n) y------- \"wbind\": @(f =/<) := step 1 . (f =<<)@.----{-@ reflect =/< @-}-{-@ (=/<) :: f:(a -> Tick b) -> t1:Tick a-    -> { t:Tick b | tval (f (tval t1))      == tval  t &&-         1 + tcost t1 + tcost (f (tval t1)) == tcost t }-@-}-infixl 4 =/<-(=/<) :: (a -> Tick b) -> Tick a -> Tick b-f =/< Tick m x = let Tick n y = f x in Tick (1 + m + n) y------- \"wwbind\": @(>//= f) := step 2 . (>>= f)@.----{-@ reflect >//= @-}-{-@ (>//=) :: t1:Tick a -> f:(a -> Tick b)-    -> { t:Tick b | tval (f (tval t1))      == tval  t &&-         2 + tcost t1 + tcost (f (tval t1)) == tcost t }-@-}-infixl 4 >//=-(>//=) :: Tick a -> (a -> Tick b) -> Tick b-Tick m x >//= f = let Tick n y = f x in Tick (2 + m + n) y------- \"wwbind\": @(f =//<) := step 2 . (f =<<)@.----{-@ reflect =//< @-}-{-@ (=//<) :: f:(a -> Tick b) -> t1:Tick a-    -> { t:Tick b | tval (f (tval t1))      == tval  t &&-         2 + tcost t1 + tcost (f (tval t1)) == tcost t }-@-}-infixl 4 =//<-(=//<) :: (a -> Tick b) -> Tick a -> Tick b-f =//< Tick m x = let Tick n y = f x in Tick (2 + m + n) y------- \"gbind\": @(>\= f) := step (-1) . (>>= f)@.----{-@ reflect >\= @-}-{-@ (>\=) :: t1:Tick a -> f:(a -> Tick b)-    -> { t:Tick b | tval (f (tval t1))      == tval  t &&-         tcost t1 + tcost (f (tval t1)) - 1 == tcost t }-@-}-infixl 4 >\=-(>\=) :: Tick a -> (a -> Tick b) -> Tick b-Tick m x >\= f = let Tick n y = f x in Tick (m + n - 1) y------- \"gbind\": @(f =\<) := step (-1) . (f =<<)@.----{-@ reflect =\< @-}-{-@ (=\<) :: f:(a -> Tick b) -> t1:Tick a-    -> { t:Tick b | tval (f (tval t1))      == tval  t &&-         tcost t1 + tcost (f (tval t1)) - 1 == tcost t }-@-}-infixl 4 =\<-(=\<) :: (a -> Tick b) -> Tick a -> Tick b-f =\< Tick m x = let Tick n y = f x in Tick (m + n - 1) y------- \"ggbind\": @(>\= f) := step (-2) . (>>= f)@.----{-@ reflect >\\= @-}-{-@ (>\\=) :: t1:Tick a -> f:(a -> Tick b)-    -> { t:Tick b | tval (f (tval t1))      == tval  t &&-         tcost t1 + tcost (f (tval t1)) - 2 == tcost t }-@-}-infixl 4 >\\=-(>\\=) :: Tick a -> (a -> Tick b) -> Tick b-Tick m x >\\= f = let Tick n y = f x in Tick (m + n - 2) y------- \"ggbind\": @(f =\\<) := step (-2) . (f =<<)@.----{-@ reflect =\\< @-}-{-@ (=\\<) :: f:(a -> Tick b) -> t1:Tick a-    -> { t:Tick b | tval (f (tval t1))      == tval  t &&-         tcost t1 + tcost (f (tval t1)) - 2 == tcost t }-@-}-infixl 4 =\\<-(=\\<) :: (a -> Tick b) -> Tick a -> Tick b-f =\\< Tick m x = let Tick n y = f x in Tick (m + n - 2) y------------------------------------------------------------------------------------ | Memoisation:----------------------------------------------------------------------------------{-@ reflect pay @-}-{-@ pay :: m:Int-    -> { t1:Tick a | m <= tcost t1 }-    -> { t:Tick ({ t2 : Tick a | tcost t1 - m == tcost t2 }) | m == tcost t }-@-}-pay :: Int -> Tick a -> Tick (Tick a)-pay m (Tick n x) = Tick m (Tick (n - m) x)---{-@ reflect zipWithM @-}-{-@ zipWithM :: f:(a -> b -> Tick c) -> x:Tick a -> y:Tick b--> {t:Tick c | tcost t == tcost x + tcost y + tcost (f (tval x) (tval y))} @-}-zipWithM :: (a -> b -> Tick c) -> Tick a -> Tick b -> Tick c-zipWithM f (Tick c1 x1) (Tick c2 x2) = let Tick c x = f x1 x2 in Tick (c + c1 + c2) x
− include/Language/Haskell/Liquid/String.hs 
@@ -1,62 +0,0 @@--- Support for Strings for SMT --{-# LANGUAGE OverloadedStrings   #-}--module Language.Haskell.Liquid.String where--import qualified Data.ByteString as BS-import qualified Data.String     as ST--{-@ embed SMTString as Str @-}--data SMTString = S BS.ByteString -  deriving (Eq, Show)--{-@ invariant {s:SMTString | 0 <= stringLen s } @-}--{-@ measure stringEmp    :: SMTString @-}-{-@ measure stringLen    :: SMTString -> Int @-}-{-@ measure subString    :: SMTString -> Int -> Int -> SMTString @-}-{-@ measure concatString :: SMTString -> SMTString -> SMTString @-}-{-@ measure fromString   :: String -> SMTString @-}-{-@ measure takeString   :: Int -> SMTString -> SMTString @-}-{-@ measure dropString   :: Int -> SMTString -> SMTString @-}--------------------------------------{-@ assume concatString :: x:SMTString -> y:SMTString -                 -> {v:SMTString | v == concatString x y && stringLen v == stringLen x + stringLen y } @-}-concatString :: SMTString -> SMTString -> SMTString-concatString (S s1) (S s2) = S (s1 `BS.append` s2)--{-@ assume stringEmp :: {v:SMTString | v == stringEmp  && stringLen v == 0 } @-}-stringEmp :: SMTString-stringEmp = S (BS.empty)--stringLen :: SMTString -> Int  -{-@ assume stringLen :: x:SMTString -> {v:Nat | v == stringLen x} @-}-stringLen (S s) = BS.length s ---{-@ assume subString  :: s:SMTString -> offset:Int -> ln:Int -> {v:SMTString | v == subString s offset ln } @-}-subString :: SMTString -> Int -> Int -> SMTString -subString (S s) o l = S (BS.take l $ BS.drop o s) ---{-@ assume takeString :: i:Nat -> xs:{SMTString | i <= stringLen xs } -> {v:SMTString | stringLen v == i && v == takeString i xs } @-} -takeString :: Int -> SMTString -> SMTString-takeString i (S s) = S (BS.take i s)--{-@ assume dropString :: i:Nat -> xs:{SMTString | i <= stringLen xs } -> {v:SMTString | stringLen v == stringLen xs - i && v == dropString i xs } @-} -dropString :: Int -> SMTString -> SMTString-dropString i (S s) = S (BS.drop i s)---{-@ assume fromString :: i:String -> {o:SMTString | i == o && o == fromString i} @-}-fromString :: String -> SMTString-fromString = S . ST.fromString ---{-@ assume isNullString :: i:SMTString -> {b:Bool | b <=> stringLen i == 0 } @-} -isNullString :: SMTString -> Bool -isNullString (S s) = BS.length s == 0
− include/Language/Haskell/Liquid/Synthesize/Error.hs 
@@ -1,5 +0,0 @@-module Language.Haskell.Liquid.Synthesize.Error where --{-@ err :: { v: Int | false } -> a @-}-err :: Int -> a-err s = undefined
− include/NotReal.spec 
@@ -1,11 +0,0 @@-module spec Prelude where--import GHC.Num-assume GHC.Num.* :: (GHC.Num.Num a) => x:a -> y:a -                 -> {v:a | ((((((x = 0) || (y = 0)) => (v = 0))) -                         && (((x > 0) && (y > 0)) => ((v >= x) && (v >= y))))-                         && (((x > 1) && (y > 1)) => ((v > x) && (v > y))))-                    }---GHC.Real./       :: (GHC.Real.Fractional a) => x:a -> y:{v:a | v != 0.0} -> a
− include/PatErr.spec 
@@ -1,15 +0,0 @@-module spec Prelude where---measure totalityError :: a -> Bool---assume Control.Exception.Base.patError :: {v:GHC.Prim.Addr# | totalityError "Pattern match(es) are non-exhaustive"} -> a--assume Control.Exception.Base.recSelError :: {v:GHC.Prim.Addr# | totalityError "Use of partial record field selector"} -> a--assume Control.Exception.Base.nonExhaustiveGuardsError :: {v:GHC.Prim.Addr# | totalityError "Guards are non-exhaustive"} -> a--assume Control.Exception.Base.noMethodBindingError :: {v:GHC.Prim.Addr# | totalityError "Missing method(s) on instance declaration"} -> a--assume Control.Exception.Base.recConError :: {v:GHC.Prim.Addr# | totalityError "Missing field in record construction"} -> a
− include/Prelude.hquals 
@@ -1,44 +0,0 @@-//BOT: Do not delete EVER!--qualif Bot(v:@(0))    : (0 = 1)-qualif Bot(v:obj)     : (0 = 1)-qualif Bot(v:a)       : (0 = 1)-qualif Bot(v:bool)    : (0 = 1)-qualif Bot(v:int)     : (0 = 1)--qualif CmpZ(v:a)      : (v <  0)-qualif CmpZ(v:a)      : (v <= 0)-qualif CmpZ(v:a)      : (v >  0)-qualif CmpZ(v:a)      : (v >= 0)-qualif CmpZ(v:a)      : (v  = 0)-qualif CmpZ(v:a)      : (v != 0)--qualif Cmp(v:a, x:a)  : (v <  x)-qualif Cmp(v:a, x:a)  : (v <= x)-qualif Cmp(v:a, x:a)  : (v >  x)-qualif Cmp(v:a, x:a)  : (v >= x)-qualif Cmp(v:a, x:a)  : (v  = x)-qualif Cmp(v:a, x:a)  : (v != x)--// qualif CmpZ(v:a)        : v [ < ; <= ; > ; >= ; = ; != ] 0-// qualif Cmp(v:a,x:a)     : v [ < ; <= ; > ; >= ; = ; != ] x-// qualif Cmp(v:int,x:int) : v [ < ; <= ; > ; >= ; = ; != ] x---qualif One(v:int)     : v = 1-qualif True1(v:GHC.Types.Bool)   : (v)-qualif False1(v:GHC.Types.Bool)  : (~ v)--constant papp1 : func(1, [Pred @(0); @(0); bool])-qualif Papp(v:a,p:Pred a) : (papp1(p, v))--constant papp2 : func(4, [Pred @(0) @(1); @(2); @(3); bool])-qualif Papp2(v:a,x:b,p:Pred a b) : (papp2(p, v, x))--qualif Papp3(v:a,x:b, y:c, p:Pred a b c) : (papp3(p, v, x, y))-constant papp3 : func(6, [Pred @(0) @(1) @(2); @(3); @(4); @(5); bool])--// qualif Papp4(v:a,x:b, y:c, z:d, p:Pred a b c d) : papp4(p, v, x, y, z)-constant papp4 : func(8, [Pred @(0) @(1) @(2) @(6); @(3); @(4); @(5); @(7); bool])--constant runFun : func(2, [Arrow @(0) @(1); @(0); @(1)])
− include/Prelude.spec 
@@ -1,88 +0,0 @@-module spec Prelude where--import GHC.Base-import GHC.Int-import GHC.List-import GHC.Num-import GHC.Real-import GHC.Word--import Data.Foldable-import Data.Maybe-import Data.Tuple-import GHC.Exts-import GHC.Err ---//  GHC.Types.D# :: x:_ -> {v:_ | v = x}--GHC.Err.error :: {v:_ | false} -> a --assume GHC.Base.. :: forall <p :: b -> c -> Bool, q :: a -> b -> Bool, r :: a -> c -> Bool>. -                     {xcmp::a, wcmp::b<q xcmp> |- c<p wcmp> <: c<r xcmp>}-                     (ycmp:b -> c<p ycmp>)-                  -> (zcmp:a -> b<q zcmp>)-                  ->  xcmp:a -> c<r xcmp>-assume GHC.Integer.smallInteger :: x:GHC.Prim.Int# -> { v:GHC.Integer.Type | v = (x :: int) }--assume GHC.Num.+ :: (GHC.Num.Num a) => x:a -> y:a -> {v:a | v = x + y }-assume GHC.Num.- :: (GHC.Num.Num a) => x:a -> y:a -> {v:a | v = x - y }--embed GHC.Types.Double  as real-embed GHC.Types.Float   as real-embed Integer           as int--type GeInt N = {v: GHC.Types.Int | v >= N }-type LeInt N = {v: GHC.Types.Int | v <= N }-type Nat     = {v: GHC.Types.Int | v >= 0 }-type Even    = {v: GHC.Types.Int | (v mod 2) = 0 }-type Odd     = {v: GHC.Types.Int | (v mod 2) = 1 }-type BNat N  = {v: Nat           | v <= N }    -type TT      = {v: GHC.Types.Bool | v}-type FF      = {v: GHC.Types.Bool | not v}-type String  = [GHC.Types.Char]--predicate Max V X Y = if X > Y then V = X else V = Y-predicate Min V X Y = if X < Y then V = X else V = Y--type IncrListD a  = [a]<{\x y -> (x+D) <= y}>--// BOT: Do not delete EVER!--qualif Bot(v:@(0))    : (0 = 1)-qualif Bot(v:obj)     : (0 = 1)-qualif Bot(v:a)       : (0 = 1)-qualif Bot(v:bool)    : (0 = 1)-qualif Bot(v:int)     : (0 = 1)--qualif CmpZ(v:a)      : (v <  0)-qualif CmpZ(v:a)      : (v <= 0)-qualif CmpZ(v:a)      : (v >  0)-qualif CmpZ(v:a)      : (v >= 0)-qualif CmpZ(v:a)      : (v  = 0)-qualif CmpZ(v:a)      : (v != 0)--qualif Cmp(v:a, x:a)  : (v <  x)-qualif Cmp(v:a, x:a)  : (v <= x)-qualif Cmp(v:a, x:a)  : (v >  x)-qualif Cmp(v:a, x:a)  : (v >= x)-qualif Cmp(v:a, x:a)  : (v  = x)-qualif Cmp(v:a, x:a)  : (v != x)--qualif One(v:int)     : v = 1-qualif True1(v:GHC.Types.Bool)   : (v)-qualif False1(v:GHC.Types.Bool)  : (~ v)--//  REBARE constant papp1 : func(1, [Pred @(0); @(0); bool])-qualif Papp(v:a, p:Pred a) : (papp1 p v)--//  REBARE constant papp2 : func(4, [Pred @(0) @(1); @(2); @(3); bool])-qualif Papp2(v:a, x:b, p:Pred a b) : (papp2 p v x)--//  REBARE constant papp3 : func(6, [Pred @(0) @(1) @(2); @(3); @(4); @(5); bool])-qualif Papp3(v:a, x:b, y:c, p:Pred a b c) : (papp3 p v x y)--//  qualif Papp4(v:a,x:b, y:c, z:d, p:Pred a b c d) : papp4(p, v, x, y, z)-//  REBARE constant papp4 : func(8, [Pred @(0) @(1) @(2) @(6); @(3); @(4); @(5); @(7); bool])--//  REBARE constant runFun : func(2, [Arrow @(0) @(1); @(0); @(1)])
− include/Real.spec 
@@ -1,9 +0,0 @@-module spec Prelude where--import GHC.Num--assume GHC.Num.* :: (GHC.Num.Num a) => x:a -> y:a -> {v:a | v = x * y} ----//  GHC.Real./       :: forall a. (GHC.Real.Fractional a) => x:a -> y:{v:a | v != 0.0} -> {v: a | v = (x / y) }
− include/System/IO.spec 
@@ -1,3 +0,0 @@-module spec System.IO where--import GHC.IO.Handle
− include/len.hquals 
@@ -1,7 +0,0 @@--// Qualifiers about complex length relationships-// qualif LenSum(v:[a], ~A:[b], ~B:[c]): len([v]) = (len([~A]) [ +; - ] len([~B]))--qualif LenSum(v:[a], xs:[b], ys:[c]): len([v]) = (len([xs]) + len([ys]))-qualif LenSum(v:[a], xs:[b], ys:[c]): len([v]) = (len([xs]) - len([ys]))-
liquidhaskell.cabal view
@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               liquidhaskell-version:            0.9.0.2.1+version:            0.9.2.5.0 synopsis:           Liquid Types for Haskell description:        Liquid Types for Haskell. license:            BSD-3-Clause@@ -10,57 +10,11 @@ maintainer:         Ranjit Jhala <jhala@cs.ucsd.edu> category:           Language homepage:           https://github.com/ucsd-progsys/liquidhaskell-build-type:         Simple-tested-with:        GHC == 9.0.2+build-type:         Custom+tested-with:        GHC == 9.2.5 extra-source-files: CHANGES.md                     README.md-                    devel/Paths_liquidhaskell.hs-                    tests/pos/*.hs-                    tests/neg/*.hs-                    tests/import/lib/*.hs-                    tests/import/client/*.hs-                    tests/errors/*.hs-                    tests/pos/*.hquals-                    tests/ffi-include/foo.c-                    tests/ffi-include/foo.h --- The legacy executable requires a set of hardcoded specifications--- provided by the files in the 'include' directory. This--- directory is now deprecated and you should never edit it, unless you--- are specifically fixing a bug in the legacy executable.--- Remove these lines below once we stop supporting the legacy plugin.-data-files:         include/*.hquals-                    include/*.hs-                    include/*.spec-                    include/CoreToLogic.lg-                    include/Control/*.spec-                    include/Control/Parallel/*.spec-                    include/Data/*.hquals-                    include/Data/*.spec-                    include/Data/Text/*.spec-                    include/Data/Text/Fusion/*.spec-                    include/Data/Text/Lazy/*.spec-                    include/Data/ByteString/*.spec-                    include/Foreign/*.spec-                    include/Foreign/C/*.spec-                    include/Foreign/Marshal/*.spec-                    include/GHC/*.hquals-                    include/GHC/*.spec-                    include/GHC/IO/*.spec-                    include/Language/Haskell/Liquid/*.hs-                    include/Language/Haskell/Liquid/Synthesize/*.hs-                    include/Language/Haskell/Liquid/*.pred-                    include/System/*.spec-                    include/710/Data/*.spec-                    include/*.hs-                    include/Language/Haskell/Liquid/*.hs-                    include/Language/Haskell/Liquid/*.pred--                    syntax/liquid.css--                    -- Needed for the mirror-modules helper-                    mirror-modules/templates/MirrorModule.mustache- source-repository head   type:     git   location: https://github.com/ucsd-progsys/liquidhaskell/@@ -71,267 +25,64 @@   description: Enable more warnings and fail compilation when warnings occur.                Turn this flag on in CI. -flag include-  default:     False-  description: use in-tree include directory--flag deterministic-profiling-  default:     False-  description: Support building against GHC with <https://phabricator.haskell.org/D4388>-               backported--flag no-plugin-  default:     False-  manual:      True-  description: Use the legacy executable for testing.--flag mirror-modules-helper-  default:     False-  manual:      True-  description: Build the "mirror-modules" helper executable.+custom-setup+  setup-depends: Cabal<4, base<5, liquidhaskell-boot  library-  autogen-modules:    Paths_liquidhaskell-  exposed-modules:    Language.Haskell.Liquid.Cabal-                      Language.Haskell.Liquid.Bare-                      Language.Haskell.Liquid.Bare.Axiom-                      Language.Haskell.Liquid.Bare.Check-                      Language.Haskell.Liquid.Bare.Class-                      Language.Haskell.Liquid.Bare.DataType-                      Language.Haskell.Liquid.Bare.Expand-                      Language.Haskell.Liquid.Bare.Laws-                      Language.Haskell.Liquid.Bare.Measure-                      Language.Haskell.Liquid.Bare.Misc-                      Language.Haskell.Liquid.Bare.Plugged-                      Language.Haskell.Liquid.Bare.Resolve-                      Language.Haskell.Liquid.Bare.ToBare-                      Language.Haskell.Liquid.Bare.Types-                      Language.Haskell.Liquid.Bare.Slice-                      Language.Haskell.Liquid.Bare.Typeclass-                      Language.Haskell.Liquid.Bare.Elaborate-                      Language.Haskell.Liquid.Constraint.Constraint-                      Language.Haskell.Liquid.Constraint.Env-                      Language.Haskell.Liquid.Constraint.Fresh-                      Language.Haskell.Liquid.Constraint.Generate-                      Language.Haskell.Liquid.Constraint.Init-                      Language.Haskell.Liquid.Constraint.Monad-                      Language.Haskell.Liquid.Constraint.Qualifier-                      Language.Haskell.Liquid.Constraint.Split-                      Language.Haskell.Liquid.Constraint.ToFixpoint-                      Language.Haskell.Liquid.Constraint.Types-                      Language.Haskell.Liquid.Constraint.Relational-                      Liquid.GHC.API-                      Liquid.GHC.API.StableModule-                      Liquid.GHC.GhcMonadLike-                      Liquid.GHC.Interface-                      Liquid.GHC.Logging-                      Liquid.GHC.Misc-                      Liquid.GHC.Play-                      Liquid.GHC.Resugar-                      Liquid.GHC.SpanStack-                      Liquid.GHC.Types-                      Liquid.GHC.TypeRep-                      Language.Haskell.Liquid.GHC.Plugin-                      Language.Haskell.Liquid.GHC.Plugin.Tutorial-                      Language.Haskell.Liquid.Interactive.Handler-                      Language.Haskell.Liquid.Interactive.Types-                      Language.Haskell.Liquid.LawInstances-                      Language.Haskell.Liquid.Liquid-                      Language.Haskell.Liquid.Measure-                      Language.Haskell.Liquid.Misc-                      Language.Haskell.Liquid.Parse-                      Language.Haskell.Liquid.Synthesize.GHC-                      Language.Haskell.Liquid.Synthesize.Termination-                      Language.Haskell.Liquid.Synthesize.Monad-                      Language.Haskell.Liquid.Synthesize.Misc-                      Language.Haskell.Liquid.Synthesize.Generate-                      Language.Haskell.Liquid.Synthesize.Check-                      Language.Haskell.Liquid.Synthesize.Env-                      Language.Haskell.Liquid.Termination.Structural-                      Language.Haskell.Liquid.Transforms.ANF-                      Language.Haskell.Liquid.Transforms.CoreToLogic-                      Language.Haskell.Liquid.Transforms.Rec-                      Language.Haskell.Liquid.Transforms.RefSplit-                      Language.Haskell.Liquid.Transforms.Rewrite-                      Language.Haskell.Liquid.Transforms.Simplify-                      Language.Haskell.Liquid.Transforms.InlineAux-                      Language.Haskell.Liquid.Types-                      Language.Haskell.Liquid.Types.Bounds-                      Language.Haskell.Liquid.Types.Dictionaries-                      Language.Haskell.Liquid.Types.Equality-                      Language.Haskell.Liquid.Types.Errors-                      Language.Haskell.Liquid.Types.Fresh-                      Language.Haskell.Liquid.Types.Generics-                      Language.Haskell.Liquid.Types.Literals-                      Language.Haskell.Liquid.Types.Meet-                      Language.Haskell.Liquid.Types.Names-                      Language.Haskell.Liquid.Types.PredType-                      Language.Haskell.Liquid.Types.PrettyPrint-                      Language.Haskell.Liquid.Types.RefType-                      Language.Haskell.Liquid.Types.Specs-                      Language.Haskell.Liquid.Types.Types-                      Language.Haskell.Liquid.Types.Variance-                      Language.Haskell.Liquid.Types.Visitors-                      Language.Haskell.Liquid.Synthesize-                      Language.Haskell.Liquid.UX.ACSS-                      Language.Haskell.Liquid.UX.Annotate-                      Language.Haskell.Liquid.UX.CTags-                      Language.Haskell.Liquid.UX.CmdLine-                      Language.Haskell.Liquid.UX.Config-                      Language.Haskell.Liquid.UX.DiffCheck-                      Language.Haskell.Liquid.UX.Errors-                      Language.Haskell.Liquid.UX.QuasiQuoter-                      Language.Haskell.Liquid.UX.SimpleVersion-                      Language.Haskell.Liquid.UX.Tidy-                      Language.Haskell.Liquid.WiredIn-                      LiquidHaskell-                      Paths_liquidhaskell-  other-modules:      Language.Haskell.Liquid.GHC.Plugin.SpecFinder-                      Language.Haskell.Liquid.GHC.Plugin.Types-                      Language.Haskell.Liquid.GHC.Plugin.Util-  hs-source-dirs:     src src-ghc--  build-depends:      base                 >= 4.11.1.0 && < 5-                    , Diff                 >= 0.3 && < 0.5-                    , aeson-                    , binary-                    , bytestring           >= 0.10-                    , Cabal                < 3.5-                    , cereal-                    , cmdargs              >= 0.10-                    , containers           >= 0.5-                    , data-default         >= 0.5-                    , deepseq              >= 1.3-                    , directory            >= 1.2-                    , filepath             >= 1.3-                    , fingertree           >= 0.1-                    , exceptions           < 0.11-                    , ghc                  ^>= 9-                    , ghc-boot-                    , ghc-paths            >= 0.1-                    , ghc-prim-                    , gitrev-                    , hashable             >= 1.3 && < 1.4-                    , hscolour             >= 1.22-                    , liquid-fixpoint      >= 0.8.10.2.1 && < 0.9-                    , mtl                  >= 2.1-                    , optics               >= 0.2-                    , optparse-applicative < 0.17-                    , githash-                    , megaparsec           >= 8-                    , pretty               >= 1.1-                    , split-                    , syb                  >= 0.4.4-                    , template-haskell     >= 2.9-                    , th-compat            < 0.2-                    , temporary            >= 1.2-                    , text                 >= 1.2-                    , time                 >= 1.4-                    , transformers         >= 0.3-                    , unordered-containers >= 0.2.11-                    , vector               >= 0.10-                    , free-                    , recursion-schemes    < 5.3-                    , data-fix-                    , extra-  default-language:   Haskell98-  default-extensions: PatternGuards, RecordWildCards, DoAndIfThenElse-  ghc-options:        -W -fwarn-missing-signatures+  exposed-modules:    LiquidHaskell+                      GHC.Classes_LHAssumptions+                      GHC.CString_LHAssumptions+                      GHC.Types_LHAssumptions -  if flag(devel)-    ghc-options:      -Wall -Werror+                      Data.Bits_LHAssumptions+                      Data.Either_LHAssumptions+                      Data.Foldable_LHAssumptions+                      Data.Int_LHAssumptions+                      Data.Maybe_LHAssumptions+                      Data.String_LHAssumptions+                      Data.Tuple_LHAssumptions+                      Data.Word_LHAssumptions+                      Foreign.C.String_LHAssumptions+                      Foreign.C.Types_LHAssumptions+                      Foreign.Concurrent_LHAssumptions+                      Foreign.Marshal.Alloc_LHAssumptions+                      Foreign.ForeignPtr_LHAssumptions+                      Foreign.Ptr_LHAssumptions+                      Foreign.Storable_LHAssumptions+                      GHC.Base_LHAssumptions+                      GHC.Exts_LHAssumptions+                      GHC.Float_LHAssumptions+                      GHC.ForeignPtr_LHAssumptions+                      GHC.Int_LHAssumptions+                      GHC.IO.Handle_LHAssumptions+                      GHC.List_LHAssumptions+                      GHC.Num_LHAssumptions+                      GHC.Maybe_LHAssumptions+                      GHC.Ptr_LHAssumptions+                      GHC.Real_LHAssumptions+                      GHC.Word_LHAssumptions+                      Liquid.Prelude.Real_LHAssumptions+                      Liquid.Prelude.Totality_LHAssumptions+                      Prelude_LHAssumptions -  if flag(include)-    hs-source-dirs: devel+                      Data.ByteString_LHAssumptions+                      Data.ByteString.Char8_LHAssumptions+                      Data.ByteString.Lazy.Char8_LHAssumptions+                      Data.ByteString.Lazy_LHAssumptions+                      Data.ByteString.Short_LHAssumptions+                      Data.ByteString.Unsafe_LHAssumptions -  if flag(deterministic-profiling)-    cpp-options: -DDETERMINISTIC_PROFILING+                      Data.Set_LHAssumptions -  if flag(no-plugin)-    cpp-options: -DLIQUID_NO_PLUGIN+  hs-source-dirs:     src --- This is the (legacy) 'liquid' executable which uses the old GHC Interface.-executable liquid-  main-is:            exe/Liquid.hs-  build-depends:      base >= 4.9.1.0 && < 5, liquidhaskell+  build-depends:      base                 >= 4.11.1.0 && < 5,+                      liquidhaskell-boot   == 0.9.2.5.0,+                      bytestring == 0.11.3.1,+                      containers == 0.6.5.1,+                      ghc-prim   default-language:   Haskell98-  default-extensions: PatternGuards-  ghc-options:        -W -threaded--  if flag(devel)-    ghc-options:      -Wall -Wno-name-shadowing -Werror--test-suite liquidhaskell-parser-  type:             exitcode-stdio-1.0-  main-is:          Parser.hs-  other-modules:    Paths_liquidhaskell-  hs-source-dirs:   tests-  build-depends:    base            >= 4.8.1.0 && < 5-                  , directory       >= 1.2.5 && < 1.4-                  , filepath-                  , liquid-fixpoint >= 0.8.10.1-                  , liquidhaskell-                  , megaparsec-                  , syb-                  , tasty           >= 0.10-                  , tasty-ant-xml-                  , tasty-hunit     >= 0.9-  default-language: Haskell2010-  ghc-options:      -W--  if flag(devel)-    ghc-options:    -Wall -Wno-name-shadowing -Werror--test-suite synthesis-  type:             exitcode-stdio-1.0-  main-is:          Synthesis.hs-  other-modules:    Paths_liquidhaskell-  hs-source-dirs:   tests-  build-depends:    base            >= 4.8.1.0 && < 5-                  , liquid-fixpoint >= 0.8.10.1-                  , liquidhaskell-                  , tasty           >= 0.7-                  , tasty-hunit-                  , process-                  , filepath-                  , text-                  , directory-                  , ghc-                  , extra-  default-language: Haskell2010-  ghc-options:      -W--  if flag(devel)-    ghc-options:    -Wall -Wno-name-shadowing -Werror---- This executable can be used to generate modules for mirror-packages.-executable mirror-modules-  main-is:        Main.hs-  hs-source-dirs: mirror-modules--  other-modules: CLI-                 Paths_liquidhaskell--  if flag(mirror-modules-helper)-    build-depends: base >= 4.9.1.0 && < 5-                 , shelly < 1.10-                 , text < 1.3-                 , filepath < 1.5-                 , containers < 0.7-                 , mustache < 2.4-                 , optparse-applicative < 0.17-    buildable: True-  else-    buildable: False--  default-language:   Haskell2010-  default-extensions:-    OverloadedStrings-    RecordWildCards-    MultiWayIf-    LambdaCase-  ghc-options:        -W -threaded+  ghc-options:        -Wall -fplugin=LiquidHaskellBoot    if flag(devel)-    ghc-options:      -Wall -Wno-name-shadowing -Werror-+    ghc-options:      -Werror
− mirror-modules/CLI.hs 
@@ -1,59 +0,0 @@-module CLI (-    CLI (..)-  , Flag(..)-  , parseCLI-  ) where---import Options.Applicative-import qualified Data.Text as T----- Flags-data OverrideFiles---- The @Flag@ datatype.--newtype Flag ix = Flag { unFlag :: Bool }--data CLI = CLI {-    overrideFiles       :: Flag OverrideFiles-  , modulesList         :: FilePath-  -- ^ A path to a list of modules to create.-  , mirrorPackageName   :: T.Text-  , moduleHierarchyRoot :: FilePath-  -- ^ A path to the root of the module hierarchy for the package we would like to target.-  }--parseCLI :: Parser CLI-parseCLI = CLI <$> parseOverrideFiles-               <*> parseModulesList-               <*> parsePackageName-               <*> parseModuleRoot--parseOverrideFiles :: Parser (Flag OverrideFiles)-parseOverrideFiles =-  Flag <$> switch (  long "unsafe-override-files"-                  <> help "Overrides an Haskell module if already present in the folder."-                  )--parseModulesList :: Parser FilePath-parseModulesList =-  strOption (  short 'l'-            <> long "modules-list"-            <> help "The path to a file containing a newline-separated list of modules to mirror."-            )--parsePackageName :: Parser T.Text-parsePackageName = T.pack <$>-  strOption (  short 'p'-            <> long "mirror-package-name"-            <> help "The name of the mirror package we are targeting. (example: liquid-foo)"-            )--parseModuleRoot :: Parser FilePath-parseModuleRoot =-  strOption (  short 'i'-            <> long "target"-            <> help "The path to the root of the module hierarchy for the target package. (example: liquid-foo/src)"-            )
− mirror-modules/Main.hs 
@@ -1,90 +0,0 @@--module Main where--import           CLI-import           Options.Applicative--import           Control.Monad--import qualified Data.Text                               as T-import qualified Data.Set                                as S-import qualified Data.Map.Strict                         as M-import           Data.Set                                 ( Set )-import           Data.Function                            ( (&) )--import           System.FilePath-import           Shelly                                  as Sh hiding ((</>))--import           Text.Mustache                           (substitute, automaticCompile)--import Paths_liquidhaskell------- Utility functions-----findExistingModules :: CLI -> Sh (Set T.Text)-findExistingModules cli = do-  allFiles <- Sh.findWhen (\f -> pure $ takeExtension f == ".hs") (moduleHierarchyRoot cli)-  pure . S.fromList . map transform $ allFiles-  where-    -- Transform an input file by:-    -- * Stripping the path;-    -- * Replacing slashes with dots;-    -- * Remove the final \".hs"\ extension.-    transform :: FilePath -> T.Text-    transform f = f & dropExtension-                    & T.pack-                    & T.replace (T.pack $ moduleHierarchyRoot cli) mempty-                    & T.replace "/" "."-                    & T.replace "/" "."---- Extracts the name of the mirrored package by dropping the \"liquid-\" prefix.-mirroredPackage :: CLI -> T.Text-mirroredPackage = T.tail . snd . T.breakOn "-" . mirrorPackageName------- The main workhorse-----mirrorModules :: CLI -> IO ()-mirrorModules cli@CLI{..} = shelly $ silently $ do-  dataDir         <- liftIO getDataDir-  inputModules    <- S.fromList . map T.strip . T.words <$> readfile modulesList-  existingModules <- findExistingModules cli--  -- If the user decided to completely override existing files, simply return all the input modules.-  let notMirrored = if | unFlag overrideFiles -> inputModules-                       | otherwise            -> inputModules `S.difference` existingModules---  -- Use a template to automatically generate the module.-  let searchSpace = [dataDir </> "mirror-modules/templates"]-      templateName = "MirrorModule.mustache"--  compiled <- liftIO $ automaticCompile searchSpace templateName-  case compiled of-    Left err       -> errorExit (T.pack . show $ err)-    Right template -> do-      forM_ notMirrored $ \toMirror -> do-        let ctx = M.fromList [("packageName" :: String, mirroredPackage cli), ("moduleName", toMirror)]-        let newModule = substitute template ctx--        let pathToModule = moduleHierarchyRoot </> T.unpack (T.replace "." "/" toMirror) <> ".hs"-        parentFolder <- T.strip <$> run "dirname" [T.pack pathToModule]--        -- Create the parent folder, if necessary.-        mkdir_p (T.unpack parentFolder)--        -- Write the module.-        writefile pathToModule newModule--      echo $ "Mirrored " <> T.pack (show . length $ notMirrored) <> " modules."--main :: IO ()-main = mirrorModules =<< execParser opts-  where-    opts = info (parseCLI <**> helper)-      ( fullDesc-     <> progDesc "Create modules to be used in mirror packages."-     <> header "mirror-modules - Generate modules in mirror packages." )
− mirror-modules/templates/MirrorModule.mustache 
@@ -1,3 +0,0 @@-module {{ moduleName }} (module Exports) where--import "{{ packageName }}" {{ moduleName }} as Exports
− src-ghc/Liquid/GHC/API.hs 
@@ -1,179 +0,0 @@-{-| This module re-exports a bunch of the GHC API.--The intended use of this module is to shelter LiquidHaskell from changes to the GHC API, so this is the-/only/ module LiquidHaskell should import when trying to access any ghc-specific functionality.----}--{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE BangPatterns #-}--module Liquid.GHC.API (-    module Ghc-  , module StableModule-  , tyConRealArity-  , dataConExTyVars-  , fsToUnitId-  , moduleUnitId-  , thisPackage-  , renderWithStyle-  , mkUserStyle-  , pattern LitNumber-  , dataConSig-  , getDependenciesModuleNames-  , gcatch-  ) where--import           Liquid.GHC.API.StableModule      as StableModule-import           GHC                                               as Ghc hiding ( Warning-                                                                                 , SrcSpan(RealSrcSpan, UnhelpfulSpan)-                                                                                 , exprType-                                                                                 )--import Optics-import qualified Control.Monad.Catch as Ex--import Data.Foldable                  (asum)-import GHC.Builtin.Names              as Ghc-import GHC.Builtin.Types              as Ghc-import GHC.Builtin.Types.Prim         as Ghc-import GHC.Builtin.Utils              as Ghc-import GHC.Core                       as Ghc hiding (AnnExpr, AnnExpr' (..), AnnRec, AnnCase)-import GHC.Core.Class                 as Ghc-import GHC.Core.Coercion              as Ghc-import GHC.Core.Coercion.Axiom        as Ghc-import GHC.Core.ConLike               as Ghc-import GHC.Core.DataCon               as Ghc-import GHC.Core.FamInstEnv            as Ghc hiding (pprFamInst)-import GHC.Core.InstEnv               as Ghc-import GHC.Core.Lint                  as Ghc hiding (dumpIfSet)-import GHC.Core.Make                  as Ghc-import GHC.Core.Opt.Monad             as Ghc (CoreToDo(..))-import GHC.Core.Opt.WorkWrap.Utils    as Ghc-import GHC.Core.Predicate             as Ghc (getClassPredTys_maybe, getClassPredTys, isEvVarType, isEqPrimPred, isEqPred, isClassPred, isDictId, mkClassPred)-import GHC.Core.Subst                 as Ghc (deShadowBinds, emptySubst, extendCvSubst)-import GHC.Core.TyCo.Rep              as Ghc-import GHC.Core.TyCon                 as Ghc-import GHC.Core.Type                  as Ghc hiding (typeKind , isPredTy, extendCvSubst, linear)-import GHC.Core.Unify                 as Ghc-import GHC.Core.Utils                 as Ghc (exprType)-import GHC.Data.Bag                   as Ghc-import GHC.Data.FastString            as Ghc-import GHC.Data.Graph.Directed        as Ghc-import GHC.Data.Pair                  as Ghc-import GHC.Driver.Finder              as Ghc-import GHC.Driver.Main                as Ghc-import GHC.Driver.Phases              as Ghc (Phase(StopLn))-import GHC.Driver.Pipeline            as Ghc (compileFile)-import GHC.Driver.Session             as Ghc hiding (isHomeModule)-import GHC.Driver.Types               as Ghc-import GHC.Driver.Monad               as Ghc (withSession)-import GHC.HsToCore.Monad             as Ghc-import GHC.Iface.Syntax               as Ghc-import GHC.Plugins                    as Ghc ( deserializeWithData-                                             , fromSerialized-                                             , toSerialized-                                             , defaultPlugin-                                             , Plugin(..)-                                             , CommandLineOption-                                             , purePlugin-                                             , extendIdSubst-                                             , substExpr-                                             )-import GHC.Tc.Instance.Family         as Ghc-import GHC.Tc.Module                  as Ghc-import GHC.Tc.Types                   as Ghc-import GHC.Tc.Utils.Monad             as Ghc hiding (getGHCiMonad)-import GHC.Tc.Utils.TcType            as Ghc (tcSplitDFunTy, tcSplitMethodTy)-import GHC.Types.Annotations          as Ghc-import GHC.Types.Avail                as Ghc-import GHC.Types.Basic                as Ghc-import GHC.Types.CostCentre           as Ghc-import GHC.Types.Id                   as Ghc hiding (lazySetIdInfo, setIdExported, setIdNotExported)-import GHC.Types.Id.Info              as Ghc-import GHC.Types.Literal              as Ghc hiding (LitNumber)-import GHC.Types.Name                 as Ghc hiding (varName, isWiredIn)-import GHC.Types.Name.Reader          as Ghc-import GHC.Types.Name.Set             as Ghc-import GHC.Types.SrcLoc               as Ghc-import GHC.Types.Unique               as Ghc-import GHC.Types.Unique.DFM           as Ghc-import GHC.Types.Unique.FM            as Ghc-import GHC.Types.Unique.Set           as Ghc-import GHC.Types.Unique.Supply        as Ghc-import GHC.Types.Var                  as Ghc-import GHC.Types.Var.Env              as Ghc-import GHC.Types.Var.Set              as Ghc-import GHC.Unit.Module                as Ghc-import GHC.Utils.Error                as Ghc-import GHC.Utils.Outputable           as Ghc hiding ((<>), integer, renderWithStyle, mkUserStyle)-import GHC.Utils.Panic                as Ghc-import qualified GHC.Types.Literal    as Ghc-import qualified GHC.Utils.Outputable as Ghc-import GHC.Tc.Types.Origin            as Ghc (lexprCtOrigin)-import GHC.Rename.Expr                as Ghc (rnLExpr)-import GHC.Tc.Gen.Expr                as Ghc (tcInferSigma, tcInferRho)-import GHC.Tc.Gen.Bind                as Ghc (tcValBinds)-import GHC.Tc.Solver                  as Ghc-import GHC.Tc.Utils.Zonk              as Ghc-import GHC.Core.FVs                   as Ghc (exprFreeVarsList)-import GHC.Tc.Types.Evidence          as Ghc-import GHC.HsToCore.Expr              as Ghc-import GHC.Core.Opt.OccurAnal         as Ghc---- 'fsToUnitId' is gone in GHC 9, but we can bring code it in terms of 'fsToUnit' and 'toUnitId'.-fsToUnitId :: FastString -> UnitId-fsToUnitId = toUnitId . fsToUnit--moduleUnitId :: Module -> UnitId-moduleUnitId = toUnitId . moduleUnit--thisPackage :: DynFlags -> UnitId-thisPackage = toUnitId . homeUnit---- See NOTE [tyConRealArity].-tyConRealArity :: TyCon -> Int-tyConRealArity tc = go 0 (tyConKind tc)-  where-    go :: Int -> Kind -> Int-    go !acc k =-      case asum [fmap (view _3) (splitFunTy_maybe k), fmap snd (splitForAllTy_maybe k)] of-        Nothing -> acc-        Just ks -> go (acc + 1) ks--dataConExTyVars :: DataCon -> [TyVar]-dataConExTyVars = dataConExTyCoVars--getDependenciesModuleNames :: Dependencies -> [ModuleNameWithIsBoot]-getDependenciesModuleNames = dep_mods--renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String-renderWithStyle dynflags sdoc style = Ghc.renderWithStyle (Ghc.initSDocContext dynflags style) sdoc--mkUserStyle :: DynFlags -> PrintUnqualified -> Depth -> PprStyle-mkUserStyle _ = Ghc.mkUserStyle------- Literal------- In GHC 9 'LitNumber' doesn't have the extra 3rd argument, so we simply ignore it in the construction.--pattern LitNumber :: Ghc.LitNumType -> Integer -> Ghc.Type -> Ghc.Literal-pattern LitNumber numType integer ty <- ((intPrimTy,) -> (ty, Ghc.LitNumber numType integer))-  where-    LitNumber numType integer _ = Ghc.LitNumber numType integer---- This function is gone in GHC 9.-dataConSig :: DataCon -> ([TyCoVar], ThetaType, [Type], Type)-dataConSig dc-  = (dataConUnivAndExTyCoVars dc, dataConTheta dc, map irrelevantMult $ dataConOrigArgTys dc, dataConOrigResTy dc)--gcatch :: (Ex.MonadCatch m, Exception e) => m a -> (e -> m a) -> m a-gcatch = Ex.catch
− src-ghc/Liquid/GHC/API/StableModule.hs 
@@ -1,81 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--{-# OPTIONS_GHC -Wno-orphans #-}--module Liquid.GHC.API.StableModule (-    StableModule-  -- * Constructing a 'StableModule'-  , mkStableModule-  -- * Converting a 'StableModule' into a standard 'Module'-  , unStableModule-  -- * Utility functions-  , toStableModule-  , renderModule-  ) where--import qualified GHC-import qualified GHC.Unit.Types as GHC-import qualified GHC.Unit.Module as GHC-import           Data.Hashable-import           GHC.Generics            hiding (to, moduleName)-import           Data.Binary---- | A newtype wrapper around a 'Module' which:------ * Allows a 'Module' to be serialised (i.e. it has a 'Binary' instance)--- * It tries to use stable comparison and equality under the hood.----newtype StableModule =-  StableModule { unStableModule :: GHC.Module }-  deriving Generic---- | Converts a 'Module' into a 'StableModule'.-toStableModule :: GHC.Module -> StableModule-toStableModule = StableModule--moduleUnitId :: GHC.Module -> GHC.UnitId-moduleUnitId = GHC.toUnitId . GHC.moduleUnit--renderModule :: GHC.Module -> String-renderModule m =    "Module { unitId = " <> (GHC.unitIdString . moduleUnitId $ m)-                 <> ", name = " <> show (GHC.moduleName m)-                 <> " }"---- These two orphans originally lived inside module 'Language.Haskell.Liquid.Types.Types'.-instance Hashable GHC.ModuleName where-  hashWithSalt i = hashWithSalt i . show--instance Show GHC.ModuleName where-  show = GHC.moduleNameString--instance Hashable StableModule where-  hashWithSalt s (StableModule mdl) = hashWithSalt s (GHC.moduleStableString mdl)--instance Ord StableModule where-  (StableModule m1) `compare` (StableModule m2) = GHC.stableModuleCmp m1 m2--instance Eq StableModule where-  (StableModule m1) == (StableModule m2) = (m1 `GHC.stableModuleCmp` m2) == EQ--instance Show StableModule where-    show (StableModule mdl) = "Stable" ++ renderModule mdl--instance Binary StableModule where--    put (StableModule mdl) = do-      put (GHC.unitIdString . moduleUnitId $ mdl)-      put (GHC.moduleNameString . GHC.moduleName $ mdl)--    get = do-      uidStr <- get-      mkStableModule (GHC.stringToUnitId uidStr) . GHC.mkModuleName <$> get------- Compat shim layer------- | Creates a new 'StableModule' out of a 'ModuleName' and a 'UnitId'.-mkStableModule :: GHC.UnitId -> GHC.ModuleName -> StableModule-mkStableModule uid modName =-  let realUnit = GHC.RealUnit $ GHC.Definite uid-  in StableModule (GHC.Module realUnit modName)
− src-ghc/Liquid/GHC/GhcMonadLike.hs 
@@ -1,307 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}--- | This module introduces a \"lighter\" "GhcMonad" typeclass which doesn't require an instance of--- 'ExceptionMonad', and can therefore be used for both 'CoreM' and 'Ghc'.-----module Liquid.GHC.GhcMonadLike (-  -- * Types and type classes-    HasHscEnv-  , GhcMonadLike-  , ModuleInfo-  , TypecheckedModule(..)--  -- * Functions and typeclass methods--  , askHscEnv-  , getModuleGraph-  , getModSummary-  , lookupModSummary-  , lookupGlobalName-  , lookupName-  , modInfoLookupName-  , moduleInfoTc-  , parseModule-  , typecheckModule-  , desugarModule-  , findModule-  , lookupModule-  , isBootInterface-  , apiComments-  ) where--import Control.Monad.IO.Class-import Control.Exception (throwIO)--import Data.IORef (readIORef)--import qualified Liquid.GHC.API   as Ghc-import           Liquid.GHC.API   hiding ( ModuleInfo-                                                          , findModule-                                                          , desugarModule-                                                          , typecheckModule-                                                          , parseModule-                                                          , lookupName-                                                          , lookupGlobalName-                                                          , getModSummary-                                                          , getModuleGraph-                                                          , modInfoLookupName-                                                          , lookupModule-                                                          , TypecheckedModule-                                                          , tm_parsed_module-                                                          , tm_renamed_source-                                                          )--import GHC.Data.Maybe-import GHC.Driver.Make-import GHC.Utils.Exception (ExceptionMonad)-import qualified GHC.Core.Opt.Monad as CoreMonad-import qualified GHC.Data.EnumSet as EnumSet--import qualified Data.Map.Strict as M-import Optics--class HasHscEnv m where-  askHscEnv :: m HscEnv--instance HasHscEnv CoreMonad.CoreM where-  askHscEnv = CoreMonad.getHscEnv--instance HasHscEnv Ghc where-  askHscEnv = getSession--instance HasHscEnv (IfM lcl) where-  askHscEnv = getTopEnv--instance HasHscEnv TcM where-  askHscEnv = env_top <$> getEnv--instance HasHscEnv Hsc where-  askHscEnv = Hsc $ curry pure--instance (ExceptionMonad m, HasHscEnv m) => HasHscEnv (GhcT m) where-  askHscEnv = getSession---- | A typeclass which is /very/ similar to the existing 'GhcMonad', but it doesn't impose a--- 'ExceptionMonad' constraint.-class (Functor m, MonadIO m, HasHscEnv m, HasDynFlags m) => GhcMonadLike m--instance GhcMonadLike CoreMonad.CoreM-instance GhcMonadLike Ghc-instance GhcMonadLike (IfM lcl)-instance GhcMonadLike TcM-instance GhcMonadLike Hsc-instance (ExceptionMonad m, GhcMonadLike m) => GhcMonadLike (GhcT m)---- NOTE(adn) Taken from the GHC API, adapted to work for a 'GhcMonadLike' monad.-getModuleGraph :: GhcMonadLike m => m ModuleGraph-getModuleGraph = fmap hsc_mod_graph askHscEnv---- NOTE(adn) Taken from the GHC API, adapted to work for a 'GhcMonadLike' monad.-getModSummary :: GhcMonadLike m => ModuleName -> m ModSummary-getModSummary mdl = do-   mg <- fmap hsc_mod_graph askHscEnv-   let mods_by_name = [ ms | ms <- mgModSummaries mg-                      , ms_mod_name ms == mdl-                      , not (isBootInterface . isBootSummary $ ms) ]-   case mods_by_name of-     [] -> do dflags <- getDynFlags-              liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph")-     [ms] -> return ms-     multiple -> do dflags <- getDynFlags-                    liftIO $ throwIO $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple)----- Converts a 'IsBootInterface' into a 'Bool'.-isBootInterface :: IsBootInterface -> Bool-isBootInterface IsBoot  = True-isBootInterface NotBoot = False--lookupModSummary :: GhcMonadLike m => ModuleName -> m (Maybe ModSummary)-lookupModSummary mdl = do-   mg <- fmap hsc_mod_graph askHscEnv-   let mods_by_name = [ ms | ms <- mgModSummaries mg-                      , ms_mod_name ms == mdl-                      , not (isBootInterface . isBootSummary $ ms) ]-   case mods_by_name of-     [ms] -> pure (Just ms)-     _    -> pure Nothing---- NOTE(adn) Taken from the GHC API, adapted to work for a 'GhcMonadLike' monad.-lookupGlobalName :: GhcMonadLike m => Name -> m (Maybe TyThing)-lookupGlobalName name = do-  hsc_env <- askHscEnv-  liftIO $ lookupTypeHscEnv hsc_env name---- NOTE(adn) Taken from the GHC API, adapted to work for a 'GhcMonadLike' monad.-lookupName :: GhcMonadLike m => Name -> m (Maybe TyThing)-lookupName name = do-  hsc_env <- askHscEnv-  liftIO $ hscTcRcLookupName hsc_env name---- | Our own simplified version of 'ModuleInfo' to overcome the fact we cannot construct the \"original\"--- one as the constructor is not exported, and 'getHomeModuleInfo' and 'getPackageModuleInfo' are not--- exported either, so we had to backport them as well.-newtype ModuleInfo = ModuleInfo { minf_type_env :: UniqFM Name TyThing }--modInfoLookupName :: GhcMonadLike m-                  => ModuleInfo-                  -> Name-                  -> m (Maybe TyThing)-modInfoLookupName minf name = do-  hsc_env <- askHscEnv-  case lookupTypeEnv (minf_type_env minf) name of-    Just tyThing -> return (Just tyThing)-    Nothing      -> do-      eps   <- liftIO $ readIORef (hsc_EPS hsc_env)-      return $! lookupType (hsc_dflags hsc_env) (hsc_HPT hsc_env) (eps_PTE eps) name--moduleInfoTc :: GhcMonadLike m => ModSummary -> TcGblEnv -> m ModuleInfo-moduleInfoTc ms tcGblEnv = do-  hsc_env <- askHscEnv-  let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }-  details <- md_types <$> liftIO (makeSimpleDetails hsc_env_tmp tcGblEnv)-  pure ModuleInfo { minf_type_env = details }------- Parsing, typechecking and desugaring a module----parseModule :: GhcMonadLike m => ModSummary -> m ParsedModule-parseModule ms = do-  hsc_env <- askHscEnv-  let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }-  hpm <- liftIO $ hscParse hsc_env_tmp ms-  return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm)-                           (hpm_annotations hpm))---- | Our own simplified version of 'TypecheckedModule'.-data TypecheckedModule = TypecheckedModule { -    tm_parsed_module  :: ParsedModule-  , tm_renamed_source :: Maybe RenamedSource-  , tm_mod_summary    :: ModSummary-  , tm_gbl_env        :: TcGblEnv-  }--typecheckModule :: GhcMonadLike m => ParsedModule -> m TypecheckedModule-typecheckModule pmod = do-  -- Suppress all the warnings, so that they won't be printed (which would result in them being-  -- printed twice, one by GHC and once here).-  let ms = pm_mod_summary pmod-  hsc_env <- askHscEnv-  let dynFlags' = ms_hspp_opts ms-  let hsc_env_tmp = hsc_env { hsc_dflags = dynFlags' { warningFlags = EnumSet.empty } }-  (tc_gbl_env, rn_info)-        <- liftIO $ hscTypecheckRename hsc_env_tmp ms $-                       HsParsedModule { hpm_module = parsedSource pmod,-                                        hpm_src_files = pm_extra_src_files pmod,-                                        hpm_annotations = pm_annotations pmod }-  return TypecheckedModule {-      tm_parsed_module  = pmod-    , tm_renamed_source = rn_info-    , tm_mod_summary    = ms-    , tm_gbl_env        = tc_gbl_env-    }--{- | [NOTE:ghc810]-Something changed in the GHC bowels such that the 'hscTarget' that the 'ModSummary' was inheriting-was /not/ the one we were setting in 'configureDynFlags'. This is important, because if the 'hscTarget'-is not 'HscInterpreted' or 'HscNothing', the call to 'targetRetainsAllBindings' will yield 'False'. This-function is used internally by GHC to do dead-code-elimination and to mark functions as "exported" or not.-Therefore, the 'CoreBind's passed to LiquidHaskell would be different between GHC 8.6.5 and GHC 8.10.--}--class IsTypecheckedModule t where-  tmParsedModule :: Lens'  t ParsedModule-  tmModSummary   :: Lens'  t ModSummary-  tmGblEnv       :: Getter t TcGblEnv--instance IsTypecheckedModule TypecheckedModule where-  tmParsedModule = lens tm_parsed_module (\s x -> s { tm_parsed_module = x })-  tmModSummary   = lens tm_mod_summary   (\s x -> s { tm_mod_summary = x })-  tmGblEnv       = to tm_gbl_env--instance IsTypecheckedModule Ghc.TypecheckedModule where-  tmParsedModule = lens Ghc.tm_parsed_module (\s x -> s { Ghc.tm_parsed_module = x })-  tmModSummary   = lens (pm_mod_summary . Ghc.tm_parsed_module)-                        (\s x -> over tmParsedModule (\pm -> pm { Ghc.pm_mod_summary = x }) s )-  tmGblEnv       = to (fst . Ghc.tm_internals_)---- | Desugar a typechecked module.-desugarModule :: (GhcMonadLike m, IsTypecheckedModule t) => ModSummary -> t -> m ModGuts-desugarModule originalModSum typechecked = do-  -- See [NOTE:ghc810] on why we override the dynFlags here before calling 'desugarModule'.-  dynFlags          <- getDynFlags-  let modSum         = originalModSum { ms_hspp_opts = dynFlags }-  let parsedMod'     = (view tmParsedModule typechecked) { pm_mod_summary = modSum }-  let typechecked'   = set tmParsedModule parsedMod' typechecked--  hsc_env <- askHscEnv-  let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts (view tmModSummary typechecked') }-  liftIO $ hscDesugar hsc_env_tmp (view tmModSummary typechecked') (view tmGblEnv typechecked')---- | Takes a 'ModuleName' and possibly a 'UnitId', and consults the--- filesystem and package database to find the corresponding 'Module',--- using the algorithm that is used for an @import@ declaration.-findModule :: GhcMonadLike m => ModuleName -> Maybe FastString -> m Module-findModule mod_name maybe_pkg = do-  hsc_env <- askHscEnv-  let-    dflags   = hsc_dflags hsc_env-    this_pkg = thisPackage dflags-  ---  case maybe_pkg of-    Just pkg | fsToUnitId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do-      res <- findImportedModule hsc_env mod_name maybe_pkg-      case res of-        Found _ m -> return m-        err       -> throwOneError $ noModError dflags noSrcSpan mod_name err-    _otherwise -> do-      home <- lookupLoadedHomeModule mod_name-      case home of-        Just m  -> return m-        Nothing -> liftIO $ do-           res <- findImportedModule hsc_env mod_name maybe_pkg-           case res of-             Found loc m | moduleUnitId m /= this_pkg -> return m-                         | otherwise -> modNotLoadedError dflags m loc-             err -> throwOneError $ noModError dflags noSrcSpan mod_name err---lookupLoadedHomeModule :: GhcMonadLike m => ModuleName -> m (Maybe Module)-lookupLoadedHomeModule mod_name = do-  hsc_env <- askHscEnv-  case lookupHpt (hsc_HPT hsc_env) mod_name of-    Just mod_info      -> return (Just (mi_module (hm_iface mod_info)))-    _not_a_home_module -> return Nothing---modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a-modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $-   text "module is not loaded:" <+>-   quotes (ppr (moduleName m)) <+>-   parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))---lookupModule :: GhcMonadLike m => ModuleName -> Maybe FastString -> m Module-lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg)-lookupModule mod_name Nothing = do-  hsc_env <- askHscEnv-  home <- lookupLoadedHomeModule mod_name-  case home of-    Just m  -> return m-    Nothing -> liftIO $ do-      res <- findExposedPackageModule hsc_env mod_name Nothing-      case res of-        Found _ m -> return m-        err       -> throwOneError $ noModError (hsc_dflags hsc_env) noSrcSpan mod_name err---- Compatibility shim to extract the comments out of an 'ApiAnns', as modern GHCs now puts the--- comments (i.e. Haskell comments) in a different field ('apiAnnRogueComments').-apiComments :: ApiAnns -> [Ghc.Located AnnotationComment]-apiComments apiAnns =-  let comments = concat . M.elems . apiAnnComments $ apiAnns-  in-     map toRealSrc $ mappend comments (apiAnnRogueComments apiAnns)-  where-    toRealSrc (L x e) = L (RealSrcSpan x Nothing) e
− src-ghc/Liquid/GHC/Interface.hs 
@@ -1,1048 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction  #-}-{-# LANGUAGE LambdaCase                 #-}-{-# LANGUAGE TypeSynonymInstances       #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE TupleSections              #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE PartialTypeSignatures      #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE ViewPatterns               #-}--{-# OPTIONS_GHC -Wno-orphans #-}-{-# OPTIONS_GHC -Wwarn=deprecations #-}--module Liquid.GHC.Interface (--  -- * Determine the build-order for target files-   realTargets--  , getInterfaceDynFlags--  -- * Extract all information needed for verification-  , getTargetInfos-  , runLiquidGhc--  -- * Printer-  , pprintCBs--  -- * predicates-  -- , isExportedVar-  -- , exportedVars--  -- * Internal exports (provisional)-  , extractSpecComments-  , extractSpecQuotes'-  , makeLogicMap-  , classCons-  , derivedVars-  , importVars-  , makeGhcSrc-  , allImports-  , qualifiedImports-  , modSummaryHsFile-  , makeFamInstEnv-  , findAndParseSpecFiles-  , parseSpecFile-  , noTerm-  , clearSpec-  , checkFilePragmas-  , keepRawTokenStream-  , ignoreInline-  , lookupTyThings-  , availableTyCons-  , availableVars-  , updLiftedSpec-  , loadDependenciesOf-  ) where--import Prelude hiding (error)--import GHC.Paths (libdir)--import           Liquid.GHC.API as Ghc hiding ( text-                                                               , (<+>)-                                                               , panic-                                                               , vcat-                                                               , showPpr-                                                               , mkStableModule-                                                               , Target-                                                               , Located-                                                               )-import qualified Liquid.GHC.API as Ghc-import qualified Liquid.GHC.API as O-import GHC.LanguageExtensions--import Control.Exception-import Control.Monad--import Data.Bifunctor-import Data.Data-import Data.List hiding (intersperse)-import Data.Maybe--import Data.Generics.Aliases (mkT)-import Data.Generics.Schemes (everywhere)--import qualified Data.HashSet        as S-import qualified Data.HashMap.Strict as HM--import System.Console.CmdArgs.Verbosity hiding (Loud)-import System.Directory-import System.FilePath-import System.IO-import System.IO.Temp-import Text.Megaparsec.Error-import Text.PrettyPrint.HughesPJ        hiding (first, (<>))-import Language.Fixpoint.Types          hiding (err, panic, Error, Result, Expr)-import qualified Language.Fixpoint.Misc as Misc-import Language.Haskell.Liquid.Bare-import Liquid.GHC.Misc-import Liquid.GHC.Types (MGIModGuts(..), miModGuts)-import Liquid.GHC.Play-import qualified Liquid.GHC.GhcMonadLike as GhcMonadLike-import Liquid.GHC.GhcMonadLike (GhcMonadLike, isBootInterface, askHscEnv)-import Language.Haskell.Liquid.WiredIn (isDerivedInstance)-import qualified Language.Haskell.Liquid.Measure  as Ms-import qualified Language.Haskell.Liquid.Misc     as Misc-import Language.Haskell.Liquid.Parse-import Language.Haskell.Liquid.Transforms.ANF-import Language.Haskell.Liquid.Types hiding (Spec)--- import Language.Haskell.Liquid.Types.PrettyPrint--- import Language.Haskell.Liquid.Types.Visitors-import Language.Haskell.Liquid.UX.CmdLine-import Language.Haskell.Liquid.UX.QuasiQuoter-import Language.Haskell.Liquid.UX.Tidy-import Language.Fixpoint.Utils.Files--import Optics hiding (ix)--import qualified Debug.Trace as Debug------------------------------------------------------------------------------------{- | @realTargets mE cfg targets@ uses `Interface.configureGhcTargets` to-     return a list of files--       [i1, i2, ... ] ++ [f1, f2, ...]--     1. Where each file only (transitively imports) PRECEDIING ones;-     2. `f1..` are a permutation of the original `targets`;-     3. `i1..` either don't have "fresh" .bspec files.-- -}----------------------------------------------------------------------------------realTargets :: Maybe HscEnv -> Config -> [FilePath] -> IO [FilePath]-realTargets  mbEnv cfg tgtFs-  | noCheckImports cfg = return tgtFs-  | otherwise          = do-    incDir   <- Misc.getIncludeDir-    allFs    <- orderTargets mbEnv cfg tgtFs-    let srcFs = filter (not . Misc.isIncludeFile incDir) allFs-    realFs   <- filterM check srcFs-    dir      <- getCurrentDirectory-    return      (makeRelative dir <$> realFs)-  where-    check f    = not <$> skipTarget tgts f-    tgts       = S.fromList tgtFs--getInterfaceDynFlags :: Maybe HscEnv -> Config -> IO DynFlags-getInterfaceDynFlags mbEnv cfg = runLiquidGhc mbEnv cfg getSessionDynFlags--orderTargets :: Maybe HscEnv -> Config -> [FilePath] -> IO [FilePath]-orderTargets mbEnv cfg tgtFiles = runLiquidGhc mbEnv cfg $ do-  homeModules <- configureGhcTargets tgtFiles-  return         (modSummaryHsFile <$> mgModSummaries homeModules)---skipTarget :: S.HashSet FilePath -> FilePath -> IO Bool-skipTarget tgts f-  | S.member f tgts = return False          -- Always check target file-  | otherwise       = hasFreshBinSpec f     -- But skip an import with fresh .bspec--hasFreshBinSpec :: FilePath -> IO Bool-hasFreshBinSpec srcF = do-  let specF = extFileName BinSpec srcF-  srcMb    <- Misc.lastModified srcF-  specMb   <- Misc.lastModified specF-  case (srcMb, specMb) of-    (Just srcT, Just specT) -> return (srcT < specT)-    _                       -> return False--------------------------------------------------------------------------------------- | GHC Interface Pipeline ---------------------------------------------------------------------------------------------------------------------------------------getTargetInfos :: Maybe HscEnv -> Config -> [FilePath] -> IO ([TargetInfo], HscEnv)-getTargetInfos hscEnv cfg tgtFiles' = do-  tgtFiles <- mapM canonicalizePath tgtFiles'-  mapM_ checkFilePresent tgtFiles-  mapM_ createTempDirectoryIfMissing tgtFiles-  logicMap <- liftIO makeLogicMap-  runLiquidGhc hscEnv cfg (getTargetInfos' cfg logicMap tgtFiles)--checkFilePresent :: FilePath -> IO ()-checkFilePresent f = do-  b <- doesFileExist f-  unless b $ panic Nothing ("Cannot find file: " ++ f)--getTargetInfos' :: Config -> LogicMap -> [FilePath] -> Ghc ([TargetInfo], HscEnv)-getTargetInfos' cfg logicMap tgtFiles = do-  _           <- compileCFiles cfg-  homeModules <- configureGhcTargets tgtFiles-  depGraph    <- buildDepGraph homeModules-  ghcInfos    <- processModules cfg logicMap tgtFiles depGraph homeModules-  hscEnv      <- getSession-  return (ghcInfos, hscEnv)--createTempDirectoryIfMissing :: FilePath -> IO ()-createTempDirectoryIfMissing tgtFile = Misc.tryIgnore "create temp directory" $-  createDirectoryIfMissing False $ tempDirectory tgtFile------------------------------------------------------------------------------------- | GHC Configuration & Setup -----------------------------------------------------------------------------------------------------------------------------------runLiquidGhc :: Maybe HscEnv -> Config -> Ghc a -> IO a-runLiquidGhc hscEnv cfg act =-  withSystemTempDirectory "liquid" $ \tmp ->-    runGhc (Just libdir) $ do-      maybe (return ()) setSession hscEnv-      df <- configureDynFlags cfg tmp-      prettyPrintGhcErrors df act--updateIncludePaths :: DynFlags -> [FilePath] -> IncludeSpecs-updateIncludePaths df ps = addGlobalInclude (includePaths df) ps--configureDynFlags :: Config -> FilePath -> Ghc DynFlags-configureDynFlags cfg tmp = do-  df <- getSessionDynFlags-  (df',_,_) <- parseDynamicFlags df $ map noLoc $ ghcOptions cfg-  loud <- liftIO isLoud-  let df'' = df' { importPaths  = nub $ idirs cfg ++ importPaths df'-                 , libraryPaths = nub $ idirs cfg ++ libraryPaths df'-                 , includePaths = updateIncludePaths df' (idirs cfg) -- addGlobalInclude (includePaths df') (idirs cfg)-                 , packageFlags = ExposePackage ""-                                                (PackageArg "ghc-prim")-                                                (ModRenaming True [])-                                : packageFlags df'--                 , debugLevel   = 1               -- insert SourceNotes-                 -- , profAuto     = ProfAutoCalls-                 , ghcLink      = LinkInMemory-                 , hscTarget    = HscInterpreted-                 , ghcMode      = CompManager-                 -- prevent GHC from printing anything, unless in Loud mode-                 , log_action   = if loud-                                    then defaultLogAction-                                    else \_ _ _ _ _   -> return ()-                 -- redirect .hi/.o/etc files to temp directory-                 , objectDir    = Just tmp-                 , hiDir        = Just tmp-                 , stubDir      = Just tmp-                 } `gopt_set` Opt_ImplicitImportQualified-                   `gopt_set` Opt_PIC-                   `gopt_set` Opt_DeferTypedHoles-                   `xopt_set` MagicHash-                   `xopt_set` DeriveGeneric-                   `xopt_set` StandaloneDeriving-  _ <- setSessionDynFlags df''-  return df''--configureGhcTargets :: [FilePath] -> Ghc ModuleGraph-configureGhcTargets tgtFiles = do-  targets         <- mapM (`guessTarget` Nothing) tgtFiles-  _               <- setTargets targets-  moduleGraph     <- depanal [] False -- see [NOTE:DROP-BOOT-FILES]--  let homeModules  = filter (not . isBootInterface . isBootSummary) $-                     flattenSCCs $ topSortModuleGraph False moduleGraph Nothing-  let homeNames    = moduleName . ms_mod <$> homeModules-  _               <- setTargetModules homeNames-  liftIO $ whenLoud $ print ("Module Dependencies" :: String, homeNames)-  return $ mkModuleGraph homeModules--setTargetModules :: [ModuleName] -> Ghc ()-setTargetModules modNames = setTargets $ mkTarget <$> modNames-  where-    mkTarget modName = Ghc.Target (TargetModule modName) True Nothing--compileCFiles :: Config -> Ghc ()-compileCFiles cfg = do-  df  <- getSessionDynFlags-  _   <- setSessionDynFlags $-           df { includePaths = updateIncludePaths df (idirs cfg)-              , importPaths  = nub $ idirs cfg ++ importPaths df-              , libraryPaths = nub $ idirs cfg ++ libraryPaths df }-  hsc <- getSession-  os  <- mapM (\x -> liftIO $ compileFile hsc StopLn (x,Nothing)) (nub $ cFiles cfg)-  df'  <- getSessionDynFlags-  void $ setSessionDynFlags $ df' { ldInputs = nub $ map (FileOption "") os ++ ldInputs df' }--{- | [NOTE:DROP-BOOT-FILES] Drop hs-boot files from the graph.-      We do it manually rather than using the flag to topSortModuleGraph-      because otherwise the order of mutually recursive modules depends-      on the modulename, e.g. given--      Bar.hs --> Foo.hs --> Bar.hs-boot--      we'll get--      [Bar.hs, Foo.hs]--      which is backwards..- -}------------------------------------------------------------------------------------ Home Module Dependency Graph -----------------------------------------------------------------------------------------------------------------------------------type DepGraph = Graph DepGraphNode-type DepGraphNode = Node Module ()--reachableModules :: DepGraph -> Module -> [Module]-reachableModules depGraph mod' =-  node_key <$> tail (reachableG depGraph (DigraphNode () mod' []))--buildDepGraph :: ModuleGraph -> Ghc DepGraph-buildDepGraph homeModules =-  graphFromEdgedVerticesOrd <$> mapM mkDepGraphNode (mgModSummaries homeModules)--mkDepGraphNode :: ModSummary -> Ghc DepGraphNode-mkDepGraphNode modSummary =-  DigraphNode () (ms_mod modSummary) <$> (filterM isHomeModule =<< modSummaryImports modSummary)--isHomeModule :: GhcMonadLike m => Module -> m Bool-isHomeModule mod' = do-  homePkg <- thisPackage <$> getDynFlags-  return   $ moduleUnitId mod' == homePkg--modSummaryImports :: GhcMonadLike m => ModSummary -> m [Module]-modSummaryImports modSummary =-  mapM (importDeclModule (ms_mod modSummary))-       (ms_textual_imps modSummary)--importDeclModule :: GhcMonadLike m => Module -> (Maybe FastString,  Ghc.Located ModuleName) -> m Module-importDeclModule fromMod (mpkgQual, locModName) = do-  hscEnv <- askHscEnv-  let modName = unLoc locModName-  res <- liftIO $ findImportedModule hscEnv modName mpkgQual-  case res of-    Ghc.Found _ mod' -> return mod'-    _ -> do-      dflags <- getDynFlags-      liftIO $ throwGhcExceptionIO $ ProgramError $-        O.showPpr dflags (moduleName fromMod) ++ ": " ++-        O.showSDoc dflags (cannotFindModule dflags modName res)------------------------------------------------------------------------------------- | Extract Ids --------------------------------------------------------------------------------------------------------------------------------------------------classCons :: Maybe [ClsInst] -> [Id]-classCons Nothing   = []-classCons (Just cs) = concatMap (dataConImplicitIds . head . tyConDataCons . classTyCon . is_cls) cs--derivedVars :: Config -> MGIModGuts -> [Var]-derivedVars cfg mg  = concatMap (dFunIdVars cbs . is_dfun) derInsts-  where-    derInsts-      | checkDer    = insts-      | otherwise   = filter isDerivedInstance insts-    insts           = mgClsInstances mg-    checkDer        = checkDerived cfg-    cbs             = mgi_binds mg---mgClsInstances :: MGIModGuts -> [ClsInst]-mgClsInstances = fromMaybe [] . mgi_cls_inst--dFunIdVars :: CoreProgram -> DFunId -> [Id]-dFunIdVars cbs fd  = notracepp msg $ concatMap bindersOf cbs' ++ deps-  where-    msg            = "DERIVED-VARS-OF: " ++ showpp fd-    cbs'           = filter f cbs-    f (NonRec x _) = eqFd x-    f (Rec xes)    = any eqFd (fst <$> xes)-    eqFd x         = varName x == varName fd-    deps           = concatMap unfoldDep unfolds-    unfolds        = unfoldingInfo . idInfo <$> concatMap bindersOf cbs'--unfoldDep :: Unfolding -> [Id]-unfoldDep (DFunUnfolding _ _ e)       = concatMap exprDep e-unfoldDep CoreUnfolding {uf_tmpl = e} = exprDep e-unfoldDep _                           = []--exprDep :: CoreExpr -> [Id]-exprDep = freeVars S.empty--importVars :: CoreProgram -> [Id]-importVars = freeVars S.empty--_definedVars :: CoreProgram -> [Id]-_definedVars = concatMap defs-  where-    defs (NonRec x _) = [x]-    defs (Rec xes)    = map fst xes------------------------------------------------------------------------------------- | Per-Module Pipeline ------------------------------------------------------------------------------------------------------------------------------------------type SpecEnv = ModuleEnv (ModName, Ms.BareSpec)--processModules :: Config -> LogicMap -> [FilePath] -> DepGraph -> ModuleGraph -> Ghc [TargetInfo]-processModules cfg logicMap tgtFiles depGraph homeModules = do-  -- DO NOT DELETE: liftIO $ putStrLn $ "Process Modules: TargetFiles = " ++ show tgtFiles-  catMaybes . snd <$> Misc.mapAccumM go emptyModuleEnv (mgModSummaries homeModules)-  where-    go = processModule cfg logicMap (S.fromList tgtFiles) depGraph--processModule :: Config -> LogicMap -> S.HashSet FilePath -> DepGraph -> SpecEnv -> ModSummary-              -> Ghc (SpecEnv, Maybe TargetInfo)-processModule cfg logicMap tgtFiles depGraph specEnv modSummary = do-  let mod'             = ms_mod modSummary-  -- DO-NOT-DELETE _                <- liftIO $ whenLoud $ putStrLn $ "Process Module: " ++ showPpr (moduleName mod)-  file                <- liftIO $ canonicalizePath $ modSummaryHsFile modSummary-  let isTarget'        = file `S.member` tgtFiles-  _                   <- loadDependenciesOf $ moduleName mod'-  parsed              <- parseModule $ keepRawTokenStream modSummary-  let specComments     = extractSpecComments (pm_annotations parsed)-  typechecked         <- typecheckModule $ ignoreInline parsed-  let specQuotes       = extractSpecQuotes typechecked-  _                   <- loadModule' typechecked-  (modName, commSpec) <- either throw return $ hsSpecificationP (moduleName mod') specComments specQuotes--  liftedSpec          <- liftIO $ if isTarget' || null specComments then return Nothing else loadLiftedSpec cfg file-  let bareSpec         = updLiftedSpec commSpec liftedSpec-  _                   <- checkFilePragmas $ Ms.pragmas bareSpec-  let specEnv'         = extendModuleEnv specEnv mod' (modName, noTerm bareSpec)-  (specEnv', ) <$> if isTarget'-                     then Just <$> processTargetModule cfg logicMap depGraph specEnv file typechecked bareSpec-                     else return Nothing--updLiftedSpec :: Ms.BareSpec -> Maybe Ms.BareSpec -> Ms.BareSpec-updLiftedSpec s1 Nothing   = s1-updLiftedSpec s1 (Just s2) = clearSpec s1 `mappend` s2--clearSpec :: Ms.BareSpec -> Ms.BareSpec-clearSpec s = s { sigs = [], asmSigs = [], aliases = [], ealiases = [], qualifiers = [], dataDecls = [] }--keepRawTokenStream :: ModSummary -> ModSummary-keepRawTokenStream modSummary = modSummary-  { ms_hspp_opts = ms_hspp_opts modSummary `gopt_set` Opt_KeepRawTokenStream }--loadDependenciesOf :: GhcMonad m => ModuleName -> m ()-loadDependenciesOf modName = do-  loadResult <- load $ LoadDependenciesOf modName-  when (failed loadResult) $ liftIO $ throwGhcExceptionIO $ ProgramError $-   "Failed to load dependencies of module " ++ showPpr modName--loadModule' :: TypecheckedModule -> Ghc TypecheckedModule-loadModule' tm = loadModule tm'-  where-    pm   = tm_parsed_module tm-    ms   = pm_mod_summary pm-    df   = ms_hspp_opts ms-    df'  = df { hscTarget = HscNothing, ghcLink = NoLink }-    ms'  = ms { ms_hspp_opts = df' }-    pm'  = pm { pm_mod_summary = ms' }-    tm'  = tm { tm_parsed_module = pm' }-----      -- -- we should be able to setContext regardless of whether-      -- -- we use the ghc api. However, ghc will complain-      -- -- if the filename does not match the module name-      -- when (typeclass cfg) $ do-      --   Ghc.setContext [iimport |(modName, _) <- allSpecs legacyBareSpec,-      --                   let iimport = if isTarget modName-      --                                 then Ghc.IIModule (getModName modName)-      --                                 else Ghc.IIDecl (Ghc.simpleImportDecl (getModName modName))]-      --   void $ Ghc.execStmt-      --     "let {infixr 1 ==>; True ==> False = False; _ ==> _ = True}"-      --     Ghc.execOptions-      --   void $ Ghc.execStmt-      --     "let {infixr 1 <=>; True <=> False = False; _ <=> _ = True}"-      --     Ghc.execOptions-      --   void $ Ghc.execStmt-      --     "let {infix 4 ==; (==) :: a -> a -> Bool; _ == _ = undefined}"-      --     Ghc.execOptions-      --   void $ Ghc.execStmt-      --     "let {infix 4 /=; (/=) :: a -> a -> Bool; _ /= _ = undefined}"-      --     Ghc.execOptions-      --   void $ Ghc.execStmt-      --     "let {infixl 7 /; (/) :: Num a => a -> a -> a; _ / _ = undefined}"-      --     Ghc.execOptions-      --   void $ Ghc.execStmt-      --     "let {len :: [a] -> Int; len _ = undefined}"-      --     Ghc.execOptions-processTargetModule :: Config -> LogicMap -> DepGraph -> SpecEnv -> FilePath -> TypecheckedModule -> Ms.BareSpec-                    -> Ghc TargetInfo-processTargetModule cfg0 logicMap depGraph specEnv file typechecked bareSpec = do-  withPragmas cfg0 file (Ms.pragmas bareSpec) $ \cfg -> do-    let modSum    = pm_mod_summary (tm_parsed_module typechecked)-    ghcSrc       <- makeGhcSrc    cfg file     typechecked modSum-    dependencies <- makeDependencies cfg depGraph specEnv modSum bareSpec--    let targetSrc = view targetSrcIso ghcSrc-    dynFlags <- getDynFlags-  -- set up the interactive context-    when (typeclass cfg) $-      loadContext (view bareSpecIso bareSpec) dependencies targetSrc-    (msgs, specM) <- Ghc.withSession $ \hsc_env -> liftIO $ runTcInteractive hsc_env-      (makeTargetSpec cfg logicMap targetSrc (view bareSpecIso bareSpec) dependencies)-    case specM of-      Nothing -> panic Nothing  $ O.showSDoc dynFlags $ O.sep (Ghc.pprErrMsgBagWithLoc (snd msgs))-      Just spec ->-        case spec of-          Left diagnostics -> do-            mapM_ (liftIO . printWarning dynFlags) (allWarnings diagnostics)-            throw (allErrors diagnostics)-          Right (warns, targetSpec, liftedSpec) -> do-            mapM_ (liftIO . printWarning dynFlags) warns-            -- The call below is temporary, we should really load & save directly 'LiftedSpec's.-            _          <- liftIO $ saveLiftedSpec (_giTarget ghcSrc) (unsafeFromLiftedSpec liftedSpec)-            return      $ TargetInfo targetSrc targetSpec--  -- cfg          <- liftIO $ withPragmas cfg0 file (Ms.pragmas bareSpec)-  -- let modSum    = pm_mod_summary (tm_parsed_module typechecked)-  -- ghcSrc       <- makeGhcSrc    cfg file     typechecked modSum-  -- dependencies <- makeDependencies cfg depGraph specEnv modSum bareSpec--  -- let targetSrc = view targetSrcIso ghcSrc-  -- dynFlags <- getDynFlags-  -- -- set up the interactive context-  -- when (typeclass cfg) $-  --   loadContext (view bareSpecIso bareSpec) dependencies targetSrc-  -- (msgs, specM) <- Ghc.withSession $ \hsc_env -> liftIO $ runTcInteractive hsc_env-  --   (makeTargetSpec cfg logicMap targetSrc (view bareSpecIso bareSpec) dependencies)-  -- case specM of-  --   Nothing -> panic Nothing  $ O.showSDoc dynFlags $ O.sep (Ghc.pprErrMsgBagWithLoc (snd msgs))-  --   Just spec ->-  --     case spec of-  --       Left diagnostics -> do-  --         mapM_ (liftIO . printWarning dynFlags) (allWarnings diagnostics)-  --         throw (allErrors diagnostics)-  --       Right (warns, targetSpec, liftedSpec) -> do-  --         mapM_ (liftIO . printWarning dynFlags) warns--  --     -- makeTargetSpec cfg logicMap targetSrc (view bareSpecIso bareSpec) dependencies >>= \case-  --     --   Left  validationErrors -> Bare.checkThrow (Left validationErrors)-  --     --   Right (targetSpec, liftedSpec) -> do--  --     -- The call below is temporary, we should really load & save directly 'LiftedSpec's.-  --         _          <- liftIO $ saveLiftedSpec (_giTarget ghcSrc) (unsafeFromLiftedSpec liftedSpec)-  --         return      $ TargetInfo targetSrc targetSpec---loadContext :: BareSpec -> TargetDependencies -> TargetSrc -> Ghc ()-loadContext bareSpec dependencies targetSrc = do-  Ghc.setContext $ [Ghc.IIModule (getModName modName) |(modName, _) <- allSpecs legacyBareSpec,-                    isTarget modName]--  where-    toLegacyDep :: (StableModule, LiftedSpec) -> (ModName, Ms.BareSpec)-    toLegacyDep (sm, ls) = (ModName SrcImport (Ghc.moduleName . unStableModule $ sm), unsafeFromLiftedSpec ls)--    toLegacyTarget :: Ms.BareSpec -> (ModName, Ms.BareSpec)-    toLegacyTarget validatedSpec = (giTargetMod targetSrc, validatedSpec)--    legacyDependencies :: [(ModName, Ms.BareSpec)]-    legacyDependencies = map toLegacyDep . HM.toList . getDependencies $ dependencies--    allSpecs :: Ms.BareSpec -> [(ModName, Ms.BareSpec)]-    allSpecs validSpec = toLegacyTarget validSpec : legacyDependencies--    -- legacyBareSpec :: Spec LocBareType F.LocSymbol-    legacyBareSpec = review bareSpecIso bareSpec-------------------------------------------------------------------------------------------- | @makeGhcSrc@ builds all the source-related information needed for consgen------------------------------------------------------------------------------------------makeGhcSrc :: Config -> FilePath -> TypecheckedModule -> ModSummary -> Ghc GhcSrc-makeGhcSrc cfg file typechecked modSum = do-  modGuts'          <- GhcMonadLike.desugarModule modSum typechecked--  let modGuts        = makeMGIModGuts modGuts'-  hscEnv            <- getSession-  coreBinds         <- liftIO $ anormalize cfg hscEnv modGuts'-  _                 <- liftIO $ whenNormal $ Misc.donePhase Misc.Loud "A-Normalization"-  let dataCons       = concatMap (map dataConWorkId . tyConDataCons) (mgi_tcs modGuts)-  (fiTcs, fiDcs)    <- makeFamInstEnv <$> liftIO (getFamInstances hscEnv)-  things            <- lookupTyThings hscEnv modSum (fst $ tm_internals_ typechecked)--  availableTcs      <- availableTyCons hscEnv modSum (fst $ tm_internals_ typechecked) (mg_exports modGuts')--  let impVars        = importVars coreBinds ++ classCons (mgi_cls_inst modGuts)-  incDir            <- liftIO Misc.getIncludeDir--  --liftIO $ do-  --  print $ "_gsTcs   => " ++ show (nub $ (mgi_tcs      modGuts) ++ availableTcs)-  --  print $ "_gsFiTcs => " ++ show fiTcs-  --  print $ "_gsFiDcs => " ++ show fiDcs-  --  print $ "dataCons => " ++ show dataCons-  --  print $ "defVars  => " ++ show (dataCons ++ (letVars coreBinds))--  return $ Src-    { _giIncDir    = incDir-    , _giTarget    = file-    , _giTargetMod = ModName Target (moduleName (ms_mod modSum))-    , _giCbs       = coreBinds-    , _giImpVars   = impVars-    , _giDefVars   = dataCons ++ letVars coreBinds-    , _giUseVars   = readVars coreBinds-    , _giDerVars   = S.fromList (derivedVars cfg modGuts)-    , _gsExports   = mgi_exports  modGuts-    , _gsTcs       = nub $ mgi_tcs modGuts ++ availableTcs-    , _gsCls       = mgi_cls_inst modGuts-    , _gsFiTcs     = fiTcs-    , _gsFiDcs     = fiDcs-    , _gsPrimTcs   = Ghc.primTyCons-    , _gsQualImps  = qualifiedImports (maybe mempty (view _2) (tm_renamed_source typechecked))-    , _gsAllImps   = allImports       (maybe mempty (view _2) (tm_renamed_source typechecked))-    , _gsTyThings  = [ t | (_, Just t) <- things ]-    }--_impThings :: [Var] -> [TyThing] -> [TyThing]-_impThings vars  = filter ok-  where-    vs          = S.fromList vars-    ok (AnId x) = S.member x vs-    ok _        = True--allImports :: [LImportDecl GhcRn] -> S.HashSet Symbol-allImports = \case-  []-> Debug.trace "WARNING: Missing RenamedSource" mempty-  imps -> S.fromList (symbol . unLoc . ideclName . unLoc <$> imps)--qualifiedImports :: [LImportDecl GhcRn] -> QImports-qualifiedImports = \case-  []   -> Debug.trace "WARNING: Missing RenamedSource" (qImports mempty)-  imps -> qImports [ (qn, n) | i         <- imps-                                          , let decl   = unLoc i-                                          , let m      = unLoc (ideclName decl)-                                          , qm        <- maybeToList (unLoc <$> ideclAs decl)-                                          , let [n,qn] = symbol <$> [m, qm]-                                          ]--qImports :: [(Symbol, Symbol)] -> QImports-qImports qns  = QImports-  { qiNames   = Misc.group qns-  , qiModules = S.fromList (snd <$> qns)-  }--------------------------------------------------------------------------------------------- | @lookupTyThings@ grabs all the @Name@s and associated @TyThing@ known to GHC---   for this module; we will use this to create our name-resolution environment---   (see `Bare.Resolve`)-----------------------------------------------------------------------------------------lookupTyThings :: GhcMonadLike m => HscEnv -> ModSummary -> TcGblEnv -> m [(Name, Maybe TyThing)]-lookupTyThings hscEnv modSum tcGblEnv = forM names (lookupTyThing hscEnv modSum tcGblEnv)-  where-    names :: [Ghc.Name]-    names  = liftM2 (++)-             (fmap Ghc.gre_name . Ghc.globalRdrEnvElts . tcg_rdr_env)-             (fmap is_dfun_name . tcg_insts) tcGblEnv--- | Lookup a single 'Name' in the GHC environment, yielding back the 'Name' alongside the 'TyThing',--- if one is found.-lookupTyThing :: GhcMonadLike m => HscEnv -> ModSummary -> TcGblEnv -> Name -> m (Name, Maybe TyThing)-lookupTyThing hscEnv modSum tcGblEnv n = do-  mi  <- GhcMonadLike.moduleInfoTc modSum tcGblEnv-  tt1 <-          GhcMonadLike.lookupName      n-  tt2 <- liftIO $ Ghc.hscTcRcLookupName hscEnv n-  tt3 <-          GhcMonadLike.modInfoLookupName mi n-  tt4 <-          GhcMonadLike.lookupGlobalName n-  return (n, Misc.firstMaybes [tt1, tt2, tt3, tt4])--availableTyThings :: GhcMonadLike m => HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> m [TyThing]-availableTyThings hscEnv modSum tcGblEnv avails = fmap (catMaybes . mconcat) $ forM avails $ \a -> do-  results <- case a of-    Avail n        -> pure <$> lookupTyThing hscEnv modSum tcGblEnv n-    AvailTC n ns _ -> forM (n : ns) $ lookupTyThing hscEnv modSum tcGblEnv-  pure . map snd $ results---- | Returns all the available (i.e. exported) 'TyCon's (type constructors) for the input 'Module'.-availableTyCons :: GhcMonadLike m => HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> m [Ghc.TyCon]-availableTyCons hscEnv modSum tcGblEnv avails =-  fmap (\things -> [tyCon | (ATyCon tyCon) <- things]) (availableTyThings hscEnv modSum tcGblEnv avails)---- | Returns all the available (i.e. exported) 'Var's for the input 'Module'.-availableVars :: GhcMonadLike m => HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> m [Ghc.Var]-availableVars hscEnv modSum tcGblEnv avails =-  fmap (\things -> [var | (AnId var) <- things]) (availableTyThings hscEnv modSum tcGblEnv avails)---- lookupTyThings :: HscEnv -> TypecheckedModule -> MGIModGuts -> Ghc [(Name, Maybe TyThing)]--- lookupTyThings hscEnv tcm mg =---   forM (mgNames mg ++ instNames mg) $ \n -> do---     tt1 <-          lookupName                   n---     tt2 <- liftIO $ Ghc.hscTcRcLookupName hscEnv n---     tt3 <-          modInfoLookupName mi         n---     tt4 <-          lookupGlobalName             n---     return (n, Misc.firstMaybes [tt1, tt2, tt3, tt4])---     where---       mi = tm_checked_module_info tcm----- lookupName        :: GhcMonad m => Name -> m (Maybe TyThing)--- hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)--- modInfoLookupName :: GhcMonad m => ModuleInfo -> Name -> m (Maybe TyThing)--- lookupGlobalName  :: GhcMonad m => Name -> m (Maybe TyThing)--_dumpTypeEnv :: TypecheckedModule -> IO ()-_dumpTypeEnv tm = do-  print ("DUMP-TYPE-ENV" :: String)-  print (showpp <$> tcmTyThings tm)--tcmTyThings :: TypecheckedModule -> Maybe [Name]-tcmTyThings-  =-  -- typeEnvElts-  -- . tcg_type_env . fst-  -- . md_types . snd-  -- . tm_internals_-  modInfoTopLevelScope-  . tm_checked_module_info---_dumpRdrEnv :: HscEnv -> MGIModGuts -> IO ()-_dumpRdrEnv _hscEnv modGuts = do-  print ("DUMP-RDR-ENV" :: String)-  print (mgNames modGuts)-  -- print (hscNames hscEnv)-  -- print (mgDeps modGuts)-  where-    _mgDeps   = Ghc.dep_mods . mgi_deps-    _hscNames = fmap showPpr . Ghc.ic_tythings . Ghc.hsc_IC--mgNames :: MGIModGuts -> [Ghc.Name]-mgNames  = fmap Ghc.gre_name . Ghc.globalRdrEnvElts .  mgi_rdr_env-------------------------------------------------------------------------------------------- | @makeDependencies@ loads BareSpec for target and imported modules--- /IMPORTANT(adn)/: We \"cheat\" a bit by creating a 'Module' out the 'ModuleName' we--- parse from the spec, and convert the former into a 'StableModule' for the purpose--- of dependency tracking. This means, in practice, that all the \"wired-in-prelude\"--- specs will share the same `UnitId`, which for the sake of the executable is an--- acceptable compromise, as long as we don't create duplicates.-----------------------------------------------------------------------------------------makeDependencies :: Config -> DepGraph -> SpecEnv -> ModSummary -> Ms.BareSpec-                 -> Ghc TargetDependencies-makeDependencies cfg depGraph specEnv modSum _ = do-  let paths     = S.fromList $ idirs cfg ++ importPaths (ms_hspp_opts modSum)-  _            <- liftIO $ whenLoud $ putStrLn $ "paths = " ++ show paths-  let reachable = reachableModules depGraph (ms_mod modSum)-  specSpecs    <- findAndParseSpecFiles cfg paths modSum reachable-  let homeSpecs = cachedBareSpecs specEnv reachable--  -- NOTE:(adn) Unfortunately for the executable we might have 3 different 'Prelude' specs-  -- (one for the Prelude functions, one for the Real/NonReal and one for the PatErr, so we-  -- cannot really assume all the module names will be disjointed. As a result we have to-  -- hack our way around this by replacing the 'UnitId' with some unique enumeration, at-  -- least unique in this local scope.--  let combine' ix (mn, sp) = ((mn, ix), sp)-  let impSpecs  = map (bimap mkStableModule (view liftedSpecGetter)) (zipWith combine' [0..] (specSpecs ++ homeSpecs))--  return        $ TargetDependencies $ HM.fromList impSpecs-  where-    mkStableModule :: (ModName, Int) -> StableModule-    mkStableModule (modName, ix) =-      Ghc.mkStableModule (fakeUnitId (moduleUnitId targetModule) ix) (getModName modName)--    fakeUnitId :: UnitId -> Int -> UnitId-    fakeUnitId uid ix = stringToUnitId $ unitIdString uid ++ show ix--    targetModule :: Module-    targetModule = ms_mod modSum--modSummaryHsFile :: ModSummary -> FilePath-modSummaryHsFile modSummary =-  fromMaybe-    (panic Nothing $-      "modSummaryHsFile: missing .hs file for " ++-      showPpr (ms_mod modSummary))-    (ml_hs_file $ ms_location modSummary)--cachedBareSpecs :: SpecEnv -> [Module] -> [(ModName, Ms.BareSpec)]-cachedBareSpecs specEnv mods = lookupBareSpec <$> mods-  where-    lookupBareSpec m         = fromMaybe (err m) (lookupModuleEnv specEnv m)-    err m                    = impossible Nothing ("lookupBareSpec: missing module " ++ showPpr m)--checkFilePragmas :: GhcMonadLike m => [Located String] -> m ()-checkFilePragmas = Misc.applyNonNull (return ()) throw . mapMaybe err-  where-    err pragma-      | check (val pragma) = Just (ErrFilePragma $ fSrcSpan pragma :: Error)-      | otherwise          = Nothing-    check pragma           = any (`isPrefixOf` pragma) bad-    bad =-      [ "-i", "--idirs"-      , "-g", "--ghc-option"-      , "--c-files", "--cfiles"-      ]------------------------------------------------------------------------------------- | Family instance information----------------------------------------------------------------------------------makeFamInstEnv :: [FamInst] -> ([Ghc.TyCon], [(Symbol, DataCon)])-makeFamInstEnv famInsts =-  let fiTcs = [ tc            | FamInst { fi_flavor = DataFamilyInst tc } <- famInsts ]-      fiDcs = [ (symbol d, d) | tc <- fiTcs, d <- tyConDataCons tc ]-  in (fiTcs, fiDcs)--getFamInstances :: HscEnv -> IO [FamInst]-getFamInstances env = do-  (_, Just (pkg_fie, home_fie)) <- runTcInteractive env tcGetFamInstEnvs-  return $ famInstEnvElts home_fie ++ famInstEnvElts pkg_fie------------------------------------------------------------------------------------- | Extract Specifications from GHC -----------------------------------------------------------------------------------------------------------------------------extractSpecComments :: ApiAnns -> [(SourcePos, String)]-extractSpecComments = mapMaybe extractSpecComment . GhcMonadLike.apiComments---- | 'extractSpecComment' pulls out the specification part from a full comment---   string, i.e. if the string is of the form:---   1. '{-@ S @-}' then it returns the substring 'S',---   2. '{-@ ... -}' then it throws a malformed SPECIFICATION ERROR, and---   3. Otherwise it is just treated as a plain comment so we return Nothing.--extractSpecComment :: Ghc.Located AnnotationComment -> Maybe (SourcePos, String)-extractSpecComment (Ghc.L sp (AnnBlockComment txt))-  | isPrefixOf "{-@" txt && isSuffixOf "@-}" txt          -- valid   specification-  = Just (offsetPos, take (length txt - 6) $ drop 3 txt)-  | isPrefixOf "{-@" txt                                   -- invalid specification-  = uError $ ErrParseAnn sp "A valid specification must have a closing '@-}'."-  where-    offsetPos = case srcSpanSourcePos sp of-      SourcePos file line col -> safeSourcePos file (unPos line) (unPos col + 3)-extractSpecComment _ = Nothing--extractSpecQuotes :: TypecheckedModule -> [BPspec]-extractSpecQuotes =-  extractSpecQuotes' (ms_mod . pm_mod_summary . tm_parsed_module)-                     (tcg_anns . fst . tm_internals_)--extractSpecQuotes' :: (a -> Module) -> (a -> [Annotation]) -> a -> [BPspec]-extractSpecQuotes' thisModule getAnns a = mapMaybe extractSpecQuote anns-  where-    anns = map ann_value $-           filter (isOurModTarget . ann_target) $-           getAnns a--    isOurModTarget (ModuleTarget mod1) = mod1 == thisModule a-    isOurModTarget _ = False--extractSpecQuote :: AnnPayload -> Maybe BPspec-extractSpecQuote payload =-  case Ghc.fromSerialized Ghc.deserializeWithData payload of-    Nothing -> Nothing-    Just qt -> Just $ refreshSymbols $ liquidQuoteSpec qt--refreshSymbols :: Data a => a -> a-refreshSymbols = everywhere (mkT refreshSymbol)--refreshSymbol :: Symbol -> Symbol-refreshSymbol = symbol . symbolText------------------------------------------------------------------------------------- | Finding & Parsing Files ---------------------------------------------------------------------------------------------------------------------------------------- | Handle Spec Files -----------------------------------------------------------findAndParseSpecFiles :: GhcMonadLike m-                      => Config-                      -> S.HashSet FilePath-                      -> ModSummary-                      -> [Module]-                      -> m [(ModName, Ms.BareSpec)]-findAndParseSpecFiles cfg paths modSummary reachable = do-  modGraph <- GhcMonadLike.getModuleGraph-  impSumms <- mapM GhcMonadLike.getModSummary (moduleName <$> reachable)-  imps''   <- nub . concat <$> mapM modSummaryImports (modSummary : impSumms)-  imps'    <- filterM ((not <$>) . isHomeModule) imps''-  let imps  = m2s <$> imps'-  fs'      <- liftIO $ moduleFiles modGraph Spec paths imps-  -- liftIO  $ whenLoud  $ print ("moduleFiles-imps'': "  ++ show (m2s <$> imps''))-  -- liftIO  $ whenLoud  $ print ("moduleFiles-imps' : "  ++ show (m2s <$> imps'))-  -- liftIO  $ whenLoud  $ print ("moduleFiles-imps  : "  ++ show imps)-  -- liftIO  $ whenLoud  $ print ("moduleFiles-Paths : "  ++ show paths)-  -- liftIO  $ whenLoud  $ print ("moduleFiles-Specs : "  ++ show fs')-  patSpec  <- liftIO $ getPatSpec  modGraph paths $ totalityCheck cfg-  rlSpec   <- liftIO $ getRealSpec modGraph paths $ not (linear cfg)-  let fs    = patSpec ++ rlSpec ++ fs'-  liftIO $ transParseSpecs modGraph paths mempty mempty fs-  where-    m2s = moduleNameString . moduleName--getPatSpec :: ModuleGraph -> S.HashSet FilePath -> Bool -> IO [FilePath]-getPatSpec modGraph paths totalitycheck- | totalitycheck = moduleFiles modGraph Spec paths [patErrorName]- | otherwise     = return []- where-  patErrorName   = "PatErr"--getRealSpec :: ModuleGraph -> S.HashSet FilePath -> Bool -> IO [FilePath]-getRealSpec modGraph paths freal-  | freal     = moduleFiles modGraph Spec paths [realSpecName]-  | otherwise = moduleFiles modGraph Spec paths [notRealSpecName]-  where-    realSpecName    = "Real"-    notRealSpecName = "NotReal"--transParseSpecs :: ModuleGraph-                -> S.HashSet FilePath-                -> S.HashSet FilePath-                -> [(ModName, Ms.BareSpec)]-                -> [FilePath]-                -> IO [(ModName, Ms.BareSpec)]-transParseSpecs _ _ _ specs [] = return specs-transParseSpecs modGraph paths seenFiles specs newFiles = do-  -- liftIO $ print ("TRANS-PARSE-SPECS", seenFiles, newFiles)-  newSpecs      <- liftIO $ mapM parseSpecFile newFiles-  impFiles      <- moduleFiles modGraph Spec paths $ specsImports newSpecs-  let seenFiles' = seenFiles `S.union` S.fromList newFiles-  let specs'     = specs ++ map (second noTerm) newSpecs-  let newFiles'  = filter (not . (`S.member` seenFiles')) impFiles-  transParseSpecs modGraph paths seenFiles' specs' newFiles'-  where-    specsImports ss = nub $ concatMap (map symbolString . Ms.imports . snd) ss--noTerm :: Ms.BareSpec -> Ms.BareSpec-noTerm spec = spec { Ms.decr = mempty, Ms.lazy = mempty, Ms.termexprs = mempty }---- | Parse a spec file by path.------ On a parse error, we fail.------ TODO, Andres: It would be better to fail more systematically, but currently we--- seem to have an option between throwing an error which will be reported badly,--- or printing the error ourselves.----parseSpecFile :: FilePath -> IO (ModName, Ms.BareSpec)-parseSpecFile file = do-  contents <- Misc.sayReadFile file-  case specSpecificationP file contents of-    Left peb -> do-      hPutStrLn stderr (errorBundlePretty peb)-      panic Nothing "parsing spec file failed"-    Right x  -> pure x---- Find Hquals Files --------------------------------------------------------------- _moduleHquals :: MGIModGuts---              -> [FilePath]---              -> FilePath---              -> [String]---              -> [FilePath]---              -> Ghc [FilePath]--- _moduleHquals mgi paths target imps incs = do---   hqs   <- specIncludes Hquals paths incs---   hqs'  <- moduleFiles Hquals paths (mgi_namestring mgi : imps)---   hqs'' <- liftIO $ filterM doesFileExist [extFileName Hquals target]---   return $ Misc.sortNub $ hqs'' ++ hqs ++ hqs'---- Find Files for Modules --------------------------------------------------------moduleFiles :: ModuleGraph -> Ext -> S.HashSet FilePath -> [String] -> IO [FilePath]-moduleFiles modGraph ext paths names = catMaybes <$> mapM (moduleFile modGraph ext paths) names--moduleFile :: ModuleGraph -> Ext -> S.HashSet FilePath -> String -> IO (Maybe FilePath)-moduleFile modGraph ext (S.toList -> paths) name-  | ext `elem` [Hs, LHs] = do-    let graph = mgModSummaries modGraph-    case find (\m -> not (isBootInterface . isBootSummary $ m) &&-                     name == moduleNameString (ms_mod_name m)) graph of-      Nothing -> getFileInDirs (extModuleName name ext) paths-      Just ms -> return $ normalise <$> ml_hs_file (ms_location ms)-  | otherwise = getFileInDirs (extModuleName name ext) paths-------------------------------------------------------------------------------------- Assemble Information for Spec Extraction -----------------------------------------------------------------------------------------------------------------------makeMGIModGuts :: ModGuts -> MGIModGuts-makeMGIModGuts modGuts = miModGuts deriv modGuts-  where-    deriv   = Just $ instEnvElts $ mg_inst_env modGuts--makeLogicMap :: IO LogicMap-makeLogicMap = do-  lg    <- Misc.getCoreToLogicPath-  lspec <- Misc.sayReadFile lg-  case parseSymbolToLogic lg lspec of-    Left peb -> do-      hPutStrLn stderr (errorBundlePretty peb)-      panic Nothing "makeLogicMap failed"-    Right lm -> return (lm <> listLMap)--listLMap :: LogicMap -- TODO-REBARE: move to wiredIn-listLMap  = toLogicMap [ (dummyLoc nilName , []     , hNil)-                       , (dummyLoc consName, [x, xs], hCons (EVar <$> [x, xs])) ]-  where-    x     = "x"-    xs    = "xs"-    hNil  = mkEApp (dcSym Ghc.nilDataCon ) []-    hCons = mkEApp (dcSym Ghc.consDataCon)-    dcSym = dummyLoc . dropModuleUnique . symbol--------------------------------------------------------------------------------------- | Pretty Printing ----------------------------------------------------------------------------------------------------------------------------------------------instance PPrint TargetSpec where-  pprintTidy k spec = vcat-    [ "******* Target Variables ********************"-    , pprintTidy k $ gsTgtVars (gsVars spec)-    , "******* Type Signatures *********************"-    , pprintLongList k (gsTySigs (gsSig spec))-    , "******* Assumed Type Signatures *************"-    , pprintLongList k (gsAsmSigs (gsSig spec))-    , "******* DataCon Specifications (Measure) ****"-    , pprintLongList k (gsCtors (gsData spec))-    , "******* Measure Specifications **************"-    , pprintLongList k (gsMeas (gsData spec))       ]--instance PPrint TargetInfo where-  pprintTidy k info = vcat-    [ -- "*************** Imports *********************"-      -- , intersperse comma $ text <$> imports info-      -- , "*************** Includes ********************"-      -- , intersperse comma $ text <$> includes info-      "*************** Imported Variables **********"-    , pprDoc $ _giImpVars (review targetSrcIso $ giSrc info)-    , "*************** Defined Variables ***********"-    , pprDoc $ _giDefVars (review targetSrcIso $ giSrc info)-    , "*************** Specification ***************"-    , pprintTidy k $ giSpec info-    , "*************** Core Bindings ***************"-    , pprintCBs $ _giCbs (review targetSrcIso $ giSrc info) ]--pprintCBs :: [CoreBind] -> Doc-pprintCBs = pprDoc . tidyCBs-    -- To print verbosely-    --    = text . O.showSDocDebug unsafeGlobalDynFlags . O.ppr . tidyCBs--instance Show TargetInfo where-  show = showpp--instance PPrint TargetVars where-  pprintTidy _ AllVars   = text "All Variables"-  pprintTidy k (Only vs) = text "Only Variables: " <+> pprintTidy k vs----------------------------------------------------------------------------- Dealing with Errors ------------------------------------------------------------------------------------------------------------------------------instance Result SourceError where-  result e = Crash ((, Nothing) <$> sourceErrors "" e) "Invalid Source"
− src-ghc/Liquid/GHC/Logging.hs 
@@ -1,52 +0,0 @@-{- | This module exposes variations over the standard GHC's logging functions to work with the 'Doc'-     type from the \"pretty\" package. We would like LiquidHaskell to emit diagnostic messages using the very-     same GHC machinery, so that IDE-like programs (e.g. \"ghcid\", \"ghcide\" etc) would be able to-     correctly show errors and warnings to the users, in ther editors.--     Unfortunately, this is not possible to do out of the box because LiquidHaskell uses the 'Doc' type from-     the \"pretty\" package but GHC uses (for historical reasons) its own version. Due to the fact none of-     the constructors are exported, we simply cannot convert between the two types effortlessly, but we have-     to pay the price of a pretty-printing \"roundtrip\".--}--module Liquid.GHC.Logging (-    fromPJDoc-  , putWarnMsg-  , putErrMsg-  , mkLongErrAt-  ) where--import qualified Liquid.GHC.API as GHC-import qualified Text.PrettyPrint.HughesPJ as PJ---- Unfortunately we need the import below to bring in scope 'PPrint' instances.-import Language.Haskell.Liquid.Types.Errors ()--fromPJDoc :: PJ.Doc -> GHC.SDoc-fromPJDoc = GHC.text . PJ.render---- | Like the original 'putLogMsg', but internally converts the input 'Doc' (from the \"pretty\" library)--- into GHC's internal 'SDoc'.-putLogMsg :: GHC.DynFlags-          -> GHC.WarnReason-          -> GHC.Severity-          -> GHC.SrcSpan-          -> Maybe GHC.PprStyle-          -> PJ.Doc-          -> IO ()-putLogMsg dynFlags reason sev srcSpan _mbStyle =-  GHC.putLogMsg dynFlags reason sev srcSpan . GHC.text . PJ.render--defaultErrStyle :: GHC.DynFlags -> GHC.PprStyle-defaultErrStyle _dynFlags = GHC.defaultErrStyle--putWarnMsg :: GHC.DynFlags -> GHC.SrcSpan -> PJ.Doc -> IO ()-putWarnMsg dynFlags srcSpan doc =-  putLogMsg dynFlags GHC.NoReason GHC.SevWarning srcSpan (Just $ defaultErrStyle dynFlags) doc--putErrMsg :: GHC.DynFlags -> GHC.SrcSpan -> PJ.Doc -> IO ()-putErrMsg dynFlags srcSpan doc = putLogMsg dynFlags GHC.NoReason GHC.SevError srcSpan Nothing doc---- | Like GHC's 'mkLongErrAt', but it builds the final 'ErrMsg' out of two \"HughesPJ\"'s 'Doc's.-mkLongErrAt :: GHC.SrcSpan -> PJ.Doc -> PJ.Doc -> GHC.TcRn GHC.ErrMsg-mkLongErrAt srcSpan msg extra = GHC.mkLongErrAt srcSpan (fromPJDoc msg) (fromPJDoc extra)
− src-ghc/Liquid/GHC/Misc.hs 
@@ -1,1097 +0,0 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE TypeSynonymInstances      #-}-{-# LANGUAGE UndecidableInstances      #-}-{-# LANGUAGE ViewPatterns              #-}-{-# LANGUAGE PatternSynonyms           #-}--{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- TODO(#1918): Only needed for GHC <9.0.1.-{-# OPTIONS_GHC -Wno-orphans #-}---- | This module contains a wrappers and utility functions for--- accessing GHC module information. It should NEVER depend on--- ANY module inside the Language.Haskell.Liquid.* tree.--module Liquid.GHC.Misc where--import           Data.String-import qualified Data.List as L-import           Debug.Trace--import           Prelude                                    hiding (error)-import           Liquid.GHC.API            as Ghc hiding ( L-                                                                          , sourceName-                                                                          , showPpr-                                                                          , showSDocDump-                                                                          , panic-                                                                          , showSDoc-                                                                          )-import qualified Liquid.GHC.API            as Ghc (GenLocated (L), showSDoc, panic, showSDocDump)---import           Data.Char                                  (isLower, isSpace, isUpper)-import           Data.Maybe                                 (isJust, fromMaybe, fromJust, maybeToList)-import           Data.Hashable-import qualified Data.HashSet                               as S-import qualified Data.Map.Strict                            as OM-import           Control.Monad.State                        (evalState, get, modify)--import qualified Data.Text.Encoding.Error                   as TE-import qualified Data.Text.Encoding                         as T-import qualified Data.Text                                  as T-import           Control.Arrow                              (second)-import           Control.Monad                              ((>=>), foldM)-import qualified Text.PrettyPrint.HughesPJ                  as PJ-import           Language.Fixpoint.Types                    hiding (L, panic, Loc (..), SrcSpan, Constant, SESearch (..))-import qualified Language.Fixpoint.Types                    as F-import           Language.Fixpoint.Misc                     (safeHead, safeLast, errorstar) -- , safeLast, safeInit)-import           Language.Haskell.Liquid.Misc               (keyDiff)-import           Control.DeepSeq-import           Language.Haskell.Liquid.Types.Errors---isAnonBinder :: Ghc.TyConBinder -> Bool-isAnonBinder (Bndr _ (AnonTCB _)) = True-isAnonBinder (Bndr _ _)           = False--mkAlive :: Var -> Id-mkAlive x-  | isId x && isDeadOcc (idOccInfo x)-  = setIdInfo x (setOccInfo (idInfo x) noOccInfo)-  | otherwise-  = x-------------------------------------------------------------------------------------- | Encoding and Decoding Location ------------------------------------------------------------------------------------------------------------------------------srcSpanTick :: Module -> SrcSpan -> Tickish a-srcSpanTick m sp = ProfNote (AllCafsCC m sp) False True--tickSrcSpan ::  Outputable a => Tickish a -> SrcSpan-tickSrcSpan (ProfNote cc _ _) = cc_loc cc-tickSrcSpan (SourceNote ss _) = RealSrcSpan ss Nothing-tickSrcSpan _                 = noSrcSpan------------------------------------------------------------------------------------- | Generic Helpers for Accessing GHC Innards ---------------------------------------------------------------------------------------------------------------------- FIXME: reusing uniques like this is really dangerous-stringTyVar :: String -> TyVar-stringTyVar s = mkTyVar name liftedTypeKind-  where-    name      = mkInternalName (mkUnique 'x' 24)  occ noSrcSpan-    occ       = mkTyVarOcc s---- FIXME: reusing uniques like this is really dangerous-stringVar :: String -> Type -> Var-stringVar s t = mkLocalVar VanillaId name Many t vanillaIdInfo-   where-      name = mkInternalName (mkUnique 'x' 25) occ noSrcSpan-      occ  = mkVarOcc s---- FIXME: plugging in dummy type like this is really dangerous-maybeAuxVar :: Symbol -> Maybe Var-maybeAuxVar s-  | isMethod sym = Just sv-  | otherwise = Nothing-  where (_, uid) = splitModuleUnique s-        sym = dropModuleNames s-        sv = mkExportedLocalId VanillaId name anyTy-        -- 'x' is chosen for no particular reason..-        name = mkInternalName (mkUnique 'x' uid) occ noSrcSpan-        occ = mkVarOcc (T.unpack (symbolText sym))--stringTyCon :: Char -> Int -> String -> TyCon-stringTyCon = stringTyConWithKind anyTy---- FIXME: reusing uniques like this is really dangerous-stringTyConWithKind :: Kind -> Char -> Int -> String -> TyCon-stringTyConWithKind k c n s = Ghc.mkKindTyCon name [] k [] name-  where-    name          = mkInternalName (mkUnique c n) occ noSrcSpan-    occ           = mkTcOcc s--hasBaseTypeVar :: Var -> Bool-hasBaseTypeVar = isBaseType . varType---- same as Constraint isBase-isBaseType :: Type -> Bool-isBaseType (ForAllTy _ _)  = False-isBaseType (FunTy { ft_arg = t1, ft_res = t2}) = isBaseType t1 && isBaseType t2-isBaseType (TyVarTy _)     = True-isBaseType (TyConApp _ ts) = all isBaseType ts-isBaseType (AppTy t1 t2)   = isBaseType t1 && isBaseType t2-isBaseType _               = False--isTmpVar :: Var -> Bool-isTmpVar = isTmpSymbol . dropModuleNamesAndUnique . symbol--isTmpSymbol    :: Symbol -> Bool-isTmpSymbol x  = any (`isPrefixOfSym` x) [anfPrefix, tempPrefix, "ds_"]--validTyVar :: String -> Bool-validTyVar s@(c:_) = isLower c && not (any isSpace s)-validTyVar _       = False--tvId :: TyVar -> String-tvId α = {- traceShow ("tvId: α = " ++ show α) $ -} showPpr α ++ show (varUnique α)--tidyCBs :: [CoreBind] -> [CoreBind]-tidyCBs = map unTick--unTick :: CoreBind -> CoreBind-unTick (NonRec b e) = NonRec b (unTickExpr e)-unTick (Rec bs)     = Rec $ map (second unTickExpr) bs--unTickExpr :: CoreExpr -> CoreExpr-unTickExpr (App e a)          = App (unTickExpr e) (unTickExpr a)-unTickExpr (Lam b e)          = Lam b (unTickExpr e)-unTickExpr (Let b e)          = Let (unTick b) (unTickExpr e)-unTickExpr (Case e b t as)    = Case (unTickExpr e) b t (map unTickAlt as)-    where unTickAlt (a, b', e') = (a, b', unTickExpr e')-unTickExpr (Cast e c)         = Cast (unTickExpr e) c-unTickExpr (Tick _ e)         = unTickExpr e-unTickExpr x                  = x--isFractionalClass :: Class -> Bool-isFractionalClass clas = classKey clas `elem` fractionalClassKeys--isOrdClass :: Class -> Bool-isOrdClass clas = classKey clas == ordClassKey------------------------------------------------------------------------------------- | Pretty Printers ---------------------------------------------------------------------------------------------------------------------------------------------notracePpr :: Outputable a => String -> a -> a-notracePpr _ x = x--tracePpr :: Outputable a => String -> a -> a-tracePpr s x = trace ("\nTrace: [" ++ s ++ "] : " ++ showPpr x) x--pprShow :: Show a => a -> Ghc.SDoc-pprShow = text . show---toFixSDoc :: Fixpoint a => a -> PJ.Doc-toFixSDoc = PJ.text . PJ.render . toFix--sDocDoc :: Ghc.SDoc -> PJ.Doc-sDocDoc   = PJ.text . showSDoc--pprDoc :: Outputable a => a -> PJ.Doc-pprDoc    = sDocDoc . ppr---- Overriding Outputable functions because they now require DynFlags!-showPpr :: Outputable a => a -> String-showPpr       = showSDoc . ppr---- FIXME: somewhere we depend on this printing out all GHC entities with--- fully-qualified names...-showSDoc :: Ghc.SDoc -> String-showSDoc sdoc = Ghc.renderWithStyle unsafeGlobalDynFlags sdoc (Ghc.mkUserStyle unsafeGlobalDynFlags myQualify {- Ghc.alwaysQualify -} Ghc.AllTheWay)--myQualify :: Ghc.PrintUnqualified-myQualify = Ghc.neverQualify { Ghc.queryQualifyName = Ghc.alwaysQualifyNames }--- { Ghc.queryQualifyName = \_ _ -> Ghc.NameNotInScope1 }--showSDocDump :: Ghc.SDoc -> String-showSDocDump  = Ghc.showSDocDump unsafeGlobalDynFlags--instance Outputable a => Outputable (S.HashSet a) where-  ppr = ppr . S.toList--typeUniqueString :: Outputable a => a -> String-typeUniqueString = {- ("sort_" ++) . -} showSDocDump . ppr-------------------------------------------------------------------------------------- | Manipulating Source Spans ------------------------------------------------------------------------------------------------------------------------------------newtype Loc    = L (Int, Int) deriving (Eq, Ord, Show)--instance Hashable Loc where-  hashWithSalt i (L z) = hashWithSalt i z----instance (Uniquable a) => Hashable a where--instance Hashable SrcSpan where-  hashWithSalt i (UnhelpfulSpan reason) = case reason of-    UnhelpfulNoLocationInfo -> hashWithSalt i (uniq $ fsLit "UnhelpfulNoLocationInfo")-    UnhelpfulWiredIn        -> hashWithSalt i (uniq $ fsLit "UnhelpfulWiredIn")-    UnhelpfulInteractive    -> hashWithSalt i (uniq $ fsLit "UnhelpfulInteractive")-    UnhelpfulGenerated      -> hashWithSalt i (uniq $ fsLit "UnhelpfulGenerated")-    UnhelpfulOther fs       -> hashWithSalt i (uniq fs)-  hashWithSalt i (RealSrcSpan s _)      = hashWithSalt i (srcSpanStartLine s, srcSpanStartCol s, srcSpanEndCol s)--fSrcSpan :: (F.Loc a) => a -> SrcSpan-fSrcSpan = fSrcSpanSrcSpan . F.srcSpan--fSourcePos :: (F.Loc a) => a -> F.SourcePos-fSourcePos = F.sp_start . F.srcSpan--fSrcSpanSrcSpan :: F.SrcSpan -> SrcSpan-fSrcSpanSrcSpan (F.SS p p') = sourcePos2SrcSpan p p'--srcSpanFSrcSpan :: SrcSpan -> F.SrcSpan-srcSpanFSrcSpan sp = F.SS p p'-  where-    p              = srcSpanSourcePos sp-    p'             = srcSpanSourcePosE sp--sourcePos2SrcSpan :: SourcePos -> SourcePos -> SrcSpan-sourcePos2SrcSpan p p' = RealSrcSpan (realSrcSpan f (unPos l) (unPos c) (unPos l') (unPos c')) Nothing-  where-    (f, l,  c)         = F.sourcePosElts p-    (_, l', c')        = F.sourcePosElts p'--sourcePosSrcSpan   :: SourcePos -> SrcSpan-sourcePosSrcSpan p@(SourcePos file line col) = sourcePos2SrcSpan p (SourcePos file line (succPos col))--sourcePosSrcLoc    :: SourcePos -> SrcLoc-sourcePosSrcLoc (SourcePos file line col) = mkSrcLoc (fsLit file) (unPos line) (unPos col)--srcSpanSourcePos :: SrcSpan -> SourcePos-srcSpanSourcePos (UnhelpfulSpan _) = dummyPos "<no source information>"-srcSpanSourcePos (RealSrcSpan s _) = realSrcSpanSourcePos s--srcSpanSourcePosE :: SrcSpan -> SourcePos-srcSpanSourcePosE (UnhelpfulSpan _) = dummyPos "<no source information>"-srcSpanSourcePosE (RealSrcSpan s _) = realSrcSpanSourcePosE s--srcSpanFilename :: SrcSpan -> String-srcSpanFilename    = maybe "" unpackFS . srcSpanFileName_maybe--srcSpanStartLoc :: RealSrcSpan -> Loc-srcSpanStartLoc l  = L (srcSpanStartLine l, srcSpanStartCol l)--srcSpanEndLoc :: RealSrcSpan -> Loc-srcSpanEndLoc l    = L (srcSpanEndLine l, srcSpanEndCol l)---oneLine :: RealSrcSpan -> Bool-oneLine l          = srcSpanStartLine l == srcSpanEndLine l--lineCol :: RealSrcSpan -> (Int, Int)-lineCol l          = (srcSpanStartLine l, srcSpanStartCol l)--realSrcSpanSourcePos :: RealSrcSpan -> SourcePos-realSrcSpanSourcePos s = safeSourcePos file line col-  where-    file               = unpackFS $ srcSpanFile s-    line               = srcSpanStartLine       s-    col                = srcSpanStartCol        s---realSrcSpanSourcePosE :: RealSrcSpan -> SourcePos-realSrcSpanSourcePosE s = safeSourcePos file line col-  where-    file                = unpackFS $ srcSpanFile s-    line                = srcSpanEndLine       s-    col                 = srcSpanEndCol        s--getSourcePos :: NamedThing a => a -> SourcePos-getSourcePos = srcSpanSourcePos  . getSrcSpan--getSourcePosE :: NamedThing a => a -> SourcePos-getSourcePosE = srcSpanSourcePosE . getSrcSpan--locNamedThing :: NamedThing a => a -> F.Located a-locNamedThing x = F.Loc l lE x-  where-    l          = getSourcePos  x-    lE         = getSourcePosE x--instance F.Loc Var where-  srcSpan v = SS (getSourcePos v) (getSourcePosE v)--namedLocSymbol :: (F.Symbolic a, NamedThing a) => a -> F.Located F.Symbol-namedLocSymbol d = F.symbol <$> locNamedThing d--varLocInfo :: (Type -> a) -> Var -> F.Located a-varLocInfo f x = f . varType <$> locNamedThing x--namedPanic :: (NamedThing a) => a -> String -> b-namedPanic x msg = panic (Just (getSrcSpan x)) msg------------------------------------------------------------------------------------- | Manipulating CoreExpr ----------------------------------------------------------------------------------------------------------------------------------------collectArguments :: Int -> CoreExpr -> [Var]-collectArguments n e = if length xs > n then take n xs else xs-  where-    (vs', e')        = collectValBinders' $ snd $ collectTyBinders e-    vs               = fst $ collectBinders $ ignoreLetBinds e'-    xs               = vs' ++ vs--{--collectTyBinders :: CoreExpr -> ([Var], CoreExpr)-collectTyBinders expr-  = go [] expr-  where-    go tvs (Lam b e) | isTyVar b = go (b:tvs) e-    go tvs e                     = (reverse tvs, e)--}--collectValBinders' :: Ghc.Expr Var -> ([Var], Ghc.Expr Var)-collectValBinders' = go []-  where-    go tvs (Lam b e) | isTyVar b = go tvs     e-    go tvs (Lam b e) | isId    b = go (b:tvs) e-    go tvs (Tick _ e)            = go tvs e-    go tvs e                     = (reverse tvs, e)--ignoreLetBinds :: Ghc.Expr t -> Ghc.Expr t-ignoreLetBinds (Let (NonRec _ _) e')-  = ignoreLetBinds e'-ignoreLetBinds e-  = e------------------------------------------------------------------------------------- | Predicates on CoreExpr and DataCons --------------------------------------------------------------------------------------------------------------------------isExternalId :: Id -> Bool-isExternalId = isExternalName . getName--isTupleId :: Id -> Bool-isTupleId = maybe False Ghc.isTupleDataCon . idDataConM--idDataConM :: Id -> Maybe DataCon-idDataConM x = case idDetails x of-  DataConWorkId d -> Just d-  DataConWrapId d -> Just d-  _               -> Nothing--isDataConId :: Id -> Bool-isDataConId = isJust . idDataConM--getDataConVarUnique :: Var -> Unique-getDataConVarUnique v-  | isId v && isDataConId v = getUnique (idDataCon v)-  | otherwise               = getUnique v--isDictionaryExpression :: Ghc.Expr Id -> Maybe Id-isDictionaryExpression (Tick _ e) = isDictionaryExpression e-isDictionaryExpression (Var x)    | isDictionary x = Just x-isDictionaryExpression _          = Nothing--realTcArity :: TyCon -> Arity-realTcArity = tyConArity--{--  tracePpr ("realTcArity of " ++ showPpr c-     ++ "\n tyConKind = " ++ showPpr (tyConKind c)-     ++ "\n kindArity = " ++ show (kindArity (tyConKind c))-     ++ "\n kindArity' = " ++ show (kindArity' (tyConKind c)) -- this works for TypeAlias-     ) $ kindArity' (tyConKind c)--}--kindTCArity :: TyCon -> Arity-kindTCArity = go . tyConKind-  where-    go (FunTy { ft_res = res}) = 1 + go res-    go _               = 0---kindArity :: Kind -> Arity-kindArity (ForAllTy _ res)-  = 1 + kindArity res-kindArity _-  = 0--uniqueHash :: Uniquable a => Int -> a -> Int-uniqueHash i = hashWithSalt i . getKey . getUnique---- slightly modified version of DynamicLoading.lookupRdrNameInModule-lookupRdrName :: HscEnv -> ModuleName -> RdrName -> IO (Maybe Name)-lookupRdrName hsc_env mod_name rdr_name = do-    -- First find the package the module resides in by searching exposed packages and home modules-    found_module <- findImportedModule hsc_env mod_name Nothing-    case found_module of-        Found _ mod' -> do-            -- Find the exports of the module-            (_, mb_iface) <- getModuleInterface hsc_env mod'-            case mb_iface of-                Just iface -> do-                    -- Try and find the required name in the exports-                    let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name-                                                , is_qual = False, is_dloc = noSrcSpan }-                        provenance = Just $ ImpSpec decl_spec ImpAll-                        env = case mi_globals iface of-                                Nothing -> mkGlobalRdrEnv (gresFromAvails provenance (mi_exports iface))-                                Just e -> e-                    case lookupGRE_RdrName rdr_name env of-                        [gre] -> return (Just (gre_name gre))-                        []    -> return Nothing-                        _     -> Ghc.panic "lookupRdrNameInModule"-                Nothing -> throwCmdLineErrorS dflags $ Ghc.hsep [Ghc.ptext (sLit "Could not determine the exports of the module"), ppr mod_name]-        err' -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err'-  where dflags = hsc_dflags hsc_env-        throwCmdLineErrorS dflags' = throwCmdLineError . Ghc.showSDoc dflags'-        throwCmdLineError = throwGhcException . CmdLineError---- qualImportDecl :: ModuleName -> ImportDecl name--- qualImportDecl mn = (simpleImportDecl mn) { ideclQualified = True }--ignoreInline :: ParsedModule -> ParsedModule-ignoreInline x = x {pm_parsed_source = go <$> pm_parsed_source x}-  where-    go  y      = y {hsmodDecls = filter go' (hsmodDecls y) }-    go' :: LHsDecl GhcPs -> Bool-    go' z-      | SigD _ (InlineSig {}) <-  unLoc z = False-      | otherwise                         = True------------------------------------------------------------------------------------- | Symbol Conversions -------------------------------------------------------------------------------------------------------------------------------------------symbolTyConWithKind :: Kind -> Char -> Int -> Symbol -> TyCon-symbolTyConWithKind k x i n = stringTyConWithKind k x i (symbolString n)--symbolTyCon :: Char -> Int -> Symbol -> TyCon-symbolTyCon x i n = stringTyCon x i (symbolString n)--symbolTyVar :: Symbol -> TyVar-symbolTyVar = stringTyVar . symbolString--localVarSymbol ::  Var -> Symbol-localVarSymbol v-  | us `isSuffixOfSym` vs = vs-  | otherwise             = suffixSymbol vs us-  where-    us                    = symbol $ showPpr $ getDataConVarUnique v-    vs                    = exportedVarSymbol v--exportedVarSymbol :: Var -> Symbol-exportedVarSymbol x = notracepp msg . symbol . getName $ x-  where-    msg = "exportedVarSymbol: " ++ showPpr x--qualifiedNameSymbol :: Name -> Symbol-qualifiedNameSymbol n = symbol $ concatFS [modFS, occFS, uniqFS]-  where-  _msg   = showSDoc (ppr n) -- getOccString n-  modFS = case nameModule_maybe n of-            Nothing -> fsLit ""-            Just m  -> concatFS [moduleNameFS (moduleName m), fsLit "."]--  occFS = occNameFS (getOccName n)-  uniqFS-    | isSystemName n-    = concatFS [fsLit "_",  fsLit (showPpr (getUnique n))]-    | otherwise-    = fsLit ""--instance Symbolic FastString where-  symbol = symbol . fastStringText--fastStringText :: FastString -> T.Text-fastStringText = T.decodeUtf8With TE.lenientDecode . bytesFS--tyConTyVarsDef :: TyCon -> [TyVar]-tyConTyVarsDef c-  | noTyVars c = []-  | otherwise  = Ghc.tyConTyVars c-  --where-  --  none         = tracepp ("tyConTyVarsDef: " ++ show c) (noTyVars c)--noTyVars :: TyCon -> Bool-noTyVars c =  Ghc.isPrimTyCon c || isFunTyCon c || Ghc.isPromotedDataCon c------------------------------------------------------------------------------------- | Symbol Instances-----------------------------------------------------------------------------------instance Symbolic TyCon where-  symbol = symbol . getName--instance Symbolic Class where-  symbol = symbol . getName--instance Symbolic Name where-  symbol = symbol . qualifiedNameSymbol---- | [NOTE:REFLECT-IMPORTS] we **eschew** the `unique` suffix for exported vars,--- to make it possible to lookup names from symbols _across_ modules;--- anyways exported names are top-level and you shouldn't have local binders--- that shadow them. However, we **keep** the `unique` suffix for local variables,--- as otherwise there are spurious, but extremely problematic, name collisions--- in the fixpoint environment.--instance Symbolic Var where   -- TODO:reflect-datacons varSymbol-  symbol v-    | isExternalId v = exportedVarSymbol v-    | otherwise      = localVarSymbol    v---instance Hashable Var where-  hashWithSalt = uniqueHash--instance Hashable TyCon where-  hashWithSalt = uniqueHash--instance Hashable Class where-  hashWithSalt = uniqueHash--instance Hashable DataCon where-  hashWithSalt = uniqueHash--instance Fixpoint Var where-  toFix = pprDoc--instance Fixpoint Name where-  toFix = pprDoc--instance Fixpoint Type where-  toFix = pprDoc--instance Show Name where-  show = symbolString . symbol--instance Show Var where-  show = show . getName--instance Show Class where-  show = show . getName--instance Show TyCon where-  show = show . getName--instance NFData Class where-  rnf t = seq t ()--instance NFData TyCon where-  rnf t = seq t ()--instance NFData Type where-  rnf t = seq t ()--instance NFData Var where-  rnf t = seq t ()------------------------------------------------------------------------------------- | Manipulating Symbols -----------------------------------------------------------------------------------------------------------------------------------------takeModuleUnique :: Symbol -> Symbol-takeModuleUnique = mungeNames tailName sepUnique   "takeModuleUnique: "-  where-    tailName msg = symbol . safeLast msg--splitModuleUnique :: Symbol -> (Symbol, Int)-splitModuleUnique x = (dropModuleNamesAndUnique x, base62ToI (takeModuleUnique x))--base62ToI :: Symbol -> Int-base62ToI s =  fromMaybe (errorstar "base62ToI Out Of Range") $ go (F.symbolText s)-  where-    digitToI :: OM.Map Char Int-    digitToI = OM.fromList $ zip (['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z']) [0..]-    f acc (flip OM.lookup digitToI -> x) = (acc * 62 +) <$> x-    go = foldM f 0 . T.unpack---splitModuleName :: Symbol -> (Symbol, Symbol)-splitModuleName x = (takeModuleNames x, dropModuleNamesAndUnique x)--dropModuleNamesAndUnique :: Symbol -> Symbol-dropModuleNamesAndUnique = dropModuleUnique . dropModuleNames--dropModuleNames  :: Symbol -> Symbol-dropModuleNames = dropModuleNamesCorrect-{- -dropModuleNames = mungeNames lastName sepModNames "dropModuleNames: "- where-   lastName msg = symbol . safeLast msg--}--dropModuleNamesCorrect  :: Symbol -> Symbol-dropModuleNamesCorrect = F.symbol . go . F.symbolText-  where-    go s = case T.uncons s of-             Just (c,tl) -> if isUpper c  && T.any (== '.') tl-                              then go $ snd $ fromJust $ T.uncons $ T.dropWhile (/= '.') s-                              else s-             Nothing -> s--takeModuleNames  :: Symbol -> Symbol-takeModuleNames  = F.symbol . go [] . F.symbolText-  where-    go acc s = case T.uncons s of-                Just (c,tl) -> if isUpper c && T.any (== '.') tl-                                 then go (getModule' s:acc) $ snd $ fromJust $ T.uncons $ T.dropWhile (/= '.') s-                                 else T.intercalate "." (reverse acc)-                Nothing -> T.intercalate "." (reverse acc)-    getModule' = T.takeWhile (/= '.')--{- -takeModuleNamesOld  = mungeNames initName sepModNames "takeModuleNames: "-  where-    initName msg = symbol . T.intercalate "." . safeInit msg--}-dropModuleUnique :: Symbol -> Symbol-dropModuleUnique = mungeNames headName sepUnique   "dropModuleUnique: "-  where-    headName msg = symbol . safeHead msg--cmpSymbol :: Symbol -> Symbol -> Bool-cmpSymbol coreSym logicSym-  =  (dropModuleUnique coreSym == dropModuleNamesAndUnique logicSym)-  || (dropModuleUnique coreSym == dropModuleUnique         logicSym)--sepModNames :: T.Text-sepModNames = "."--sepUnique :: T.Text-sepUnique = "#"--mungeNames :: (String -> [T.Text] -> Symbol) -> T.Text -> String -> Symbol -> Symbol-mungeNames _ _ _ ""  = ""-mungeNames f d msg s'@(symbolText -> s)-  | s' == tupConName = tupConName-  | otherwise        = f (msg ++ T.unpack s) $ T.splitOn d $ stripParens s--qualifySymbol :: Symbol -> Symbol -> Symbol-qualifySymbol (symbolText -> m) x'@(symbolText -> x)-  | isQualified x  = x'-  | isParened x    = symbol (wrapParens (m `mappend` "." `mappend` stripParens x))-  | otherwise      = symbol (m `mappend` "." `mappend` x)--isQualifiedSym :: Symbol -> Bool-isQualifiedSym (symbolText -> x) = isQualified x--isQualified :: T.Text -> Bool-isQualified y = "." `T.isInfixOf` y--wrapParens :: (IsString a, Monoid a) => a -> a-wrapParens x  = "(" `mappend` x `mappend` ")"--isParened :: T.Text -> Bool-isParened xs  = xs /= stripParens xs--isDictionary :: Symbolic a => a -> Bool-isDictionary = isPrefixOfSym "$f" . dropModuleNames . symbol--isMethod :: Symbolic a => a -> Bool-isMethod = isPrefixOfSym "$c" . dropModuleNames . symbol--isInternal :: Symbolic a => a -> Bool-isInternal   = isPrefixOfSym "$"  . dropModuleNames . symbol--isWorker :: Symbolic a => a -> Bool-isWorker s = notracepp ("isWorkerSym: s = " ++ ss) $ "$W" `L.isInfixOf` ss-  where-    ss     = symbolString (symbol s)--isSCSel :: Symbolic a => a -> Bool-isSCSel  = isPrefixOfSym "$p" . dropModuleNames . symbol--stripParens :: T.Text -> T.Text-stripParens t = fromMaybe t (strip t)-  where-    strip = T.stripPrefix "(" >=> T.stripSuffix ")"--stripParensSym :: Symbol -> Symbol-stripParensSym (symbolText -> t) = symbol (stripParens t)--desugarModule :: TypecheckedModule -> Ghc DesugaredModule-desugarModule tcm = do-  let ms = pm_mod_summary $ tm_parsed_module tcm-  -- let ms = modSummary tcm-  let (tcg, _) = tm_internals_ tcm-  hsc_env <- getSession-  let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }-  guts <- liftIO $ hscDesugar{- WithLoc -} hsc_env_tmp ms tcg-  return DesugaredModule { dm_typechecked_module = tcm, dm_core_module = guts }------------------------------------------------------------------------------------- | GHC Compatibility Layer --------------------------------------------------------------------------------------------------------------------------------------gHC_VERSION :: String-gHC_VERSION = show (__GLASGOW_HASKELL__ :: Int)--symbolFastString :: Symbol -> FastString-symbolFastString = mkFastStringByteString . T.encodeUtf8 . symbolText--lintCoreBindings :: [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc)-lintCoreBindings = Ghc.lintCoreBindings (defaultDynFlags undefined (undefined ("LlvmTargets" :: String))) CoreDoNothing--synTyConRhs_maybe :: TyCon -> Maybe Type-synTyConRhs_maybe = Ghc.synTyConRhs_maybe--tcRnLookupRdrName :: HscEnv -> Ghc.Located RdrName -> IO (Messages, Maybe [Name])-tcRnLookupRdrName = Ghc.tcRnLookupRdrName--showCBs :: Bool -> [CoreBind] -> String-showCBs untidy-  | untidy    = Ghc.showSDocDebug unsafeGlobalDynFlags . ppr . tidyCBs-  | otherwise = showPpr---ignoreCoreBinds :: S.HashSet Var -> [CoreBind] -> [CoreBind]-ignoreCoreBinds vs cbs-  | S.null vs         = cbs-  | otherwise         = concatMap go cbs-  where-    go :: CoreBind -> [CoreBind]-    go b@(NonRec x _)-      | S.member x vs = []-      | otherwise     = [b]-    go (Rec xes)      = [Rec (filter ((`notElem` vs) . fst) xes)]---findVarDef :: Symbol -> [CoreBind] -> Maybe (Var, CoreExpr)-findVarDef sym cbs = case xCbs of-                     (NonRec v def   : _ ) -> Just (v, def)-                     (Rec [(v, def)] : _ ) -> Just (v, def)-                     _                     -> Nothing-  where-    xCbs            = [ cb | cb <- concatMap unRec cbs, sym `elem` coreBindSymbols cb ]-    unRec (Rec xes) = [NonRec x es | (x,es) <- xes]-    unRec nonRec    = [nonRec]---findVarDefMethod :: Symbol -> [CoreBind] -> Maybe (Var, CoreExpr)-findVarDefMethod sym cbs =-  case rcbs  of-                     (NonRec v def   : _ ) -> Just (v, def)-                     (Rec [(v, def)] : _ ) -> Just (v, def)-                     _                     -> Nothing-  where-    rcbs | isMethod sym = mCbs-         | isDictionary (dropModuleNames sym) = dCbs-         | otherwise  = xCbs-    xCbs            = [ cb | cb <- concatMap unRec cbs, sym `elem` coreBindSymbols cb-                           ]-    mCbs            = [ cb | cb <- concatMap unRec cbs, sym `elem` methodSymbols cb]-    dCbs            = [ cb | cb <- concatMap unRec cbs, sym `elem` dictionarySymbols cb]-    unRec (Rec xes) = [NonRec x es | (x,es) <- xes]-    unRec nonRec    = [nonRec]--dictionarySymbols :: CoreBind -> [Symbol]-dictionarySymbols = filter isDictionary . map (dropModuleNames . symbol) . binders---methodSymbols :: CoreBind -> [Symbol]-methodSymbols = filter isMethod . map (dropModuleNames . symbol) . binders----coreBindSymbols :: CoreBind -> [Symbol]-coreBindSymbols = map (dropModuleNames . simplesymbol) . binders--simplesymbol :: (NamedThing t) => t -> Symbol-simplesymbol = symbol . getName--binders :: Bind a -> [a]-binders (NonRec z _) = [z]-binders (Rec xes)    = fst <$> xes--expandVarType :: Var -> Type-expandVarType = expandTypeSynonyms . varType------------------------------------------------------------------------------------- | The following functions test if a `CoreExpr` or `CoreVar` can be---   embedded in logic. With type-class support, we can no longer erase---   such expressions arbitrarily.----------------------------------------------------------------------------------isEmbeddedDictExpr :: CoreExpr -> Bool-isEmbeddedDictExpr = isEmbeddedDictType . exprType--isEmbeddedDictVar :: Var -> Bool-isEmbeddedDictVar v = F.notracepp msg . isEmbeddedDictType . varType $ v-  where-    msg     =  "isGoodCaseBind v = " ++ show v--isEmbeddedDictType :: Type -> Bool-isEmbeddedDictType = anyF [isOrdPred, isNumericPred, isEqPred, isPrelEqPred]---- unlike isNumCls, isFracCls, these two don't check if the argument's--- superclass is Ord or Num. I believe this is the more predictable behavior--isPrelEqPred :: Type -> Bool-isPrelEqPred ty = case tyConAppTyCon_maybe ty of-  Just tyCon -> isPrelEqTyCon tyCon-  _          -> False---isPrelEqTyCon :: TyCon -> Bool-isPrelEqTyCon tc = tc `hasKey` eqClassKey--isOrdPred :: Type -> Bool-isOrdPred ty = case tyConAppTyCon_maybe ty of-  Just tyCon -> tyCon `hasKey` ordClassKey-  _          -> False---- Not just Num, but Fractional, Integral as well-isNumericPred :: Type -> Bool-isNumericPred ty = case tyConAppTyCon_maybe ty of-  Just tyCon -> getUnique tyCon `elem` numericClassKeys-  _          -> False--------------------------------------------------------------------------------------- | The following functions test if a `CoreExpr` or `CoreVar` are just types---   in disguise, e.g. have `PredType` (in the GHC sense of the word), and so---   shouldn't appear in refinements.----------------------------------------------------------------------------------isPredExpr :: CoreExpr -> Bool-isPredExpr = isPredType . Ghc.exprType--isPredVar :: Var -> Bool-isPredVar v = F.notracepp msg . isPredType . varType $ v-  where-    msg     =  "isGoodCaseBind v = " ++ show v--isPredType :: Type -> Bool-isPredType = anyF [ isClassPred, isEqPred, isEqPrimPred ]--anyF :: [a -> Bool] -> a -> Bool-anyF ps x = or [ p x | p <- ps ]----- | 'defaultDataCons t ds' returns the list of '(dc, types)' pairs,---   corresponding to the _missing_ cases, i.e. _other_ than those in 'ds',---   that are being handled by DEFAULT.-defaultDataCons :: Type -> [AltCon] -> Maybe [(DataCon, [TyVar], [Type])]-defaultDataCons (TyConApp tc argτs) ds = do-  allDs     <- Ghc.tyConDataCons_maybe tc-  let seenDs = [d | DataAlt d <- ds ]-  let defDs  = keyDiff showPpr allDs seenDs-  return [ (d, Ghc.dataConExTyVars d, map irrelevantMult $ Ghc.dataConInstArgTys d argτs) | d <- defDs ]--defaultDataCons _ _ =-  Nothing----isEvVar :: Id -> Bool-isEvVar x = isPredVar x || isTyVar x || isCoVar x-------------------------------------------------------------------------------------- | Elaboration------------------------------------------------------------------------------------- FIXME: the handling of exceptions seems to be broken---- partially stolen from GHC'sa exprType---- elaborateHsExprInst---   :: GhcMonad m => LHsExpr GhcPs -> m (Messages, Maybe CoreExpr)--- elaborateHsExprInst expr = elaborateHsExpr TM_Inst expr----- elaborateHsExpr---   :: GhcMonad m => TcRnExprMode -> LHsExpr GhcPs -> m (Messages, Maybe CoreExpr)--- elaborateHsExpr mode expr =---   withSession $ \hsc_env -> liftIO $ hscElabHsExpr hsc_env mode expr---- hscElabHsExpr :: HscEnv -> TcRnExprMode -> LHsExpr GhcPs -> IO (Messages, Maybe CoreExpr)--- hscElabHsExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do---   hsc_env <- Ghc.getHscEnv---   liftIO $ elabRnExpr hsc_env mode expr--elabRnExpr-  :: TcRnExprMode -> LHsExpr GhcPs -> TcRn CoreExpr-elabRnExpr mode rdr_expr = do-    (rn_expr, _fvs) <- rnLExpr rdr_expr-    failIfErrsM--        -- Now typecheck the expression, and generalise its type-        -- it might have a rank-2 type (e.g. :t runST)-    uniq <- newUnique ;-    let fresh_it  = itName uniq (getLoc rdr_expr) -    ((tclvl, (tc_expr, res_ty)), lie)-          <- captureTopConstraints $-             pushTcLevelM          $-             tc_infer rn_expr--    -- Generalise-    (_qtvs, _dicts, evbs, residual, _)-         <- simplifyInfer tclvl infer_mode-                          []    {- No sig vars -}-                          [(fresh_it, res_ty)]-                          lie--    -- Ignore the dictionary bindings-    evbs' <- perhaps_disable_default_warnings $-         simplifyInteractive residual-    full_expr <- zonkTopLExpr (mkHsDictLet (EvBinds evbs') (mkHsDictLet evbs tc_expr))-    initDsTc $ dsLExpr full_expr-  where-    tc_infer expr' | inst      = tcInferRho expr'-                   | otherwise = tcInferSigma expr'-                  -- tcInferSigma: see Note [Implementing :type]--    -- See Note [TcRnExprMode]-    (inst, infer_mode, perhaps_disable_default_warnings) = case mode of-      TM_Inst    -> (True,  NoRestrictions, id)-      TM_NoInst  -> (False, NoRestrictions, id)-      TM_Default -> (True,  EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults)--newtype HashableType = HashableType {getHType :: Type}--instance Eq HashableType where-  x == y = eqType (getHType x) (getHType y)--instance Ord HashableType where-  compare x y = nonDetCmpType (getHType x) (getHType y)--instance Outputable HashableType where-  ppr = ppr . getHType-------------------------------------------------------------------------------------- | Superclass coherence-----------------------------------------------------------------------------------canonSelectorChains :: PredType -> OM.Map HashableType [Id]-canonSelectorChains t = foldr (OM.unionWith const) mempty (zs : xs)- where-  (cls, ts) = Ghc.getClassPredTys t-  scIdTys   = classSCSelIds cls-  ys        = fmap (\d -> (d, piResultTys (idType d) (ts ++ [t]))) scIdTys-  zs        = OM.fromList $ fmap (\(x, y) -> (HashableType y, [x])) ys-  xs        = fmap (\(d, t') -> fmap (d :) (canonSelectorChains t')) ys--buildCoherenceOblig :: Class -> [[([Id], [Id])]]-buildCoherenceOblig cls = evalState (mapM f xs) OM.empty- where-  (ts, _, selIds, _) = classBigSig cls-  tts                = mkTyVarTy <$> ts-  t                  = mkClassPred cls tts-  ys = fmap (\d -> (d, piResultTys (idType d) (tts ++ [t]))) selIds-  xs                 = fmap (\(d, t') -> fmap (d:) (canonSelectorChains t')) ys-  f tid = do-    ctid' <- get-    modify (flip (OM.unionWith const) tid)-    pure . OM.elems $ OM.intersectionWith (,) ctid' (fmap tail tid)----- to be zipped onto the super class selectors-coherenceObligToRef :: (F.Symbolic s) => s -> [Id] -> [Id] -> F.Reft-coherenceObligToRef d = coherenceObligToRefE (F.eVar $ F.symbol d)--coherenceObligToRefE :: F.Expr -> [Id] -> [Id] -> F.Reft-coherenceObligToRefE e rps0 rps1 = F.Reft (F.vv_, F.PAtom F.Eq lhs rhs)-  where lhs = L.foldr EApp e ps0-        rhs = L.foldr EApp (F.eVar F.vv_) ps1-        ps0 = F.eVar . F.symbol <$> L.reverse rps0-        ps1 = F.eVar . F.symbol <$> L.reverse rps1--data TcWiredIn = TcWiredIn {-    tcWiredInName :: Name-  , tcWiredInFixity :: Maybe (Int, FixityDirection)-  , tcWiredInType :: LHsType GhcRn-  }---- | Run a computation in GHC's typechecking monad with wired in values locally bound in the typechecking environment.-withWiredIn :: TcM a -> TcM a-withWiredIn m = discardConstraints $ do-  -- undef <- lookupUndef-  wiredIns <- mkWiredIns-  -- snd <$> tcValBinds Ghc.NotTopLevel (binds undef wiredIns) (sigs wiredIns) m-  snd <$> tcValBinds Ghc.NotTopLevel [] (sigs wiredIns) m-- where-  -- lookupUndef = do-  --   lookupOrig gHC_ERR (Ghc.mkVarOcc "undefined")-  --   -- tcLookupGlobal undefName--  -- binds :: Name -> [TcWiredIn] -> [(Ghc.RecFlag, LHsBinds GhcRn)]-  -- binds undef wiredIns = map (\w -> -  --     let ext = Ghc.unitNameSet undef in -- $ varName $ tyThingId undef in-  --     let co_fn = idHsWrapper in-  --     let matches = -  --           let ctxt = LambdaExpr in-  --           let grhss = GRHSs Ghc.noExtField [Ghc.L locSpan (GRHS Ghc.noExtField [] (Ghc.L locSpan (HsVar Ghc.noExtField (Ghc.L locSpan undef))))] (Ghc.L locSpan emptyLocalBinds) in-  --           MG Ghc.noExtField (Ghc.L locSpan [Ghc.L locSpan (Match Ghc.noExtField ctxt [] grhss)]) Ghc.Generated -  --     in-  --     let b = FunBind ext (Ghc.L locSpan $ tcWiredInName w) matches co_fn [] in-  --     (Ghc.NonRecursive, unitBag (Ghc.L locSpan b))-  --   ) wiredIns--  sigsExt ext wiredIns = concatMap (\w ->-      let inf = maybeToList $ (\(fPrec, fDir) -> Ghc.L locSpan $ FixSig Ghc.noExtField $ FixitySig Ghc.noExtField [Ghc.L locSpan (tcWiredInName w)] $ Ghc.Fixity Ghc.NoSourceText fPrec fDir) <$> tcWiredInFixity w in-      let t =-            let ext' = [] in-            [Ghc.L locSpan $ TypeSig Ghc.noExtField [Ghc.L locSpan (tcWiredInName w)] $ HsWC ext' $ HsIB ext $ tcWiredInType w]-      in-      inf <> t-    ) wiredIns--  sigs = sigsExt cppExt--  cppExt = []--  locSpan = UnhelpfulSpan (UnhelpfulOther "Liquid.GHC.Misc: WiredIn")--  mkHsFunTy :: LHsType GhcRn -> LHsType GhcRn -> LHsType GhcRn-  mkHsFunTy a b = nlHsFunTy a b--  mkWiredIns = sequence [impl, dimpl, eq, len]--  toName s = do-    u <- getUniqueM-    return $ Ghc.mkInternalName u (Ghc.mkVarOcc s) locSpan--  toLoc = Ghc.L locSpan-  nameToTy = Ghc.L locSpan . HsTyVar Ghc.noExtField Ghc.NotPromoted--  boolTy' :: LHsType GhcRn-  boolTy' = nameToTy $ toLoc boolTyConName-    -- boolName <- lookupOrig (Module (stringToUnitId "Data.Bool") (mkModuleName "Data.Bool")) (Ghc.mkVarOcc "Bool")-    -- return $ Ghc.L locSpan $ HsTyVar Ghc.noExtField Ghc.NotPromoted $ Ghc.L locSpan boolName-  intTy' = nameToTy $ toLoc intTyConName-  listTy lt = toLoc $ HsAppTy Ghc.noExtField (nameToTy $ toLoc listTyConName) lt--  -- infixr 1 ==> :: Bool -> Bool -> Bool-  impl = do-    n <- toName "==>"-    let ty = mkHsFunTy boolTy' (mkHsFunTy boolTy' boolTy')-    return $ TcWiredIn n (Just (1, Ghc.InfixR)) ty--  -- infixr 1 <=> :: Bool -> Bool -> Bool-  dimpl = do-    n <- toName "<=>"-    let ty = mkHsFunTy boolTy' (mkHsFunTy boolTy' boolTy')-    return $ TcWiredIn n (Just (1, Ghc.InfixR)) ty--  -- infix 4 == :: forall a . a -> a -> Bool-  eq = do-    n <- toName "=="-    aName <- Ghc.L locSpan <$> toName "a"-    let aTy = nameToTy aName-    let ty = noLoc $ HsForAllTy Ghc.noExtField-             (mkHsForAllInvisTele [Ghc.L locSpan $ UserTyVar Ghc.noExtField SpecifiedSpec aName]) $ mkHsFunTy aTy (mkHsFunTy aTy boolTy')-    return $ TcWiredIn n (Just (4, Ghc.InfixN)) ty--  -- TODO: This is defined as a measure in liquid-base GHC.Base. We probably want to insert all measures to the environment.-  -- len :: forall a. [a] -> Int-  len = do-    n <- toName "len"-    aName <- Ghc.L locSpan <$> toName "a"-    let aTy = nameToTy aName-    let ty =-          noLoc $ HsForAllTy Ghc.noExtField-               (mkHsForAllInvisTele [Ghc.L locSpan $ UserTyVar Ghc.noExtField SpecifiedSpec aName]) $ mkHsFunTy (listTy aTy) intTy'-    return $ TcWiredIn n Nothing ty--prependGHCRealQual :: FastString -> RdrName-prependGHCRealQual = varQual_RDR gHC_REAL--isFromGHCReal :: NamedThing a => a -> Bool-isFromGHCReal x = Ghc.nameModule (Ghc.getName x) == gHC_REAL
− src-ghc/Liquid/GHC/Play.hs 
@@ -1,259 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE FlexibleInstances         #-}--{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- TODO(#1918): Only needed for GHC <9.0.1.--module Liquid.GHC.Play where--import Prelude hiding (error)--import           Control.Arrow       ((***))-import qualified Data.HashMap.Strict as M-import qualified Data.List           as L-import qualified Data.Maybe          as Mb--import Liquid.GHC.API as Ghc hiding (substTysWith, panic,showPpr)-import Liquid.GHC.Misc ()-import Language.Haskell.Liquid.Types.Errors-import Language.Haskell.Liquid.Types.Variance------------------------------------------------------------------------------------ | Positivity Checker ------------------------------------------------------------------------------------------------------------------------------------------- If the type constructor T is in the input list and its data constructors Di, Dj--- use T in non strictly positive positions, --- then (T,(Di, Dj)) will appear in the result list.  --getNonPositivesTyCon :: [TyCon] -> [(TyCon, [DataCon])]-getNonPositivesTyCon tcs = Mb.mapMaybe go (M.toList $ makeOccurrences tcs)-  where-    go (tc,dcocs) = case filter (\(_,occ) -> elem tc (negOcc occ)) dcocs of-                      [] -> Nothing-                      xs -> Just (tc, fst <$> xs)----- OccurrenceMap maps type constructors to their TyConOccurrence. --- for each of their data constructor. For example, for the below data definition--- data T a = P (T a) | N (T a -> Int) | Both (T a -> T a) | None --- the entry below should get generated---  OccurrenceMap --- = T |-> [(P, [---          (P,    TyConOcc [T] [])---          (N,    TyConOcc [Int] [T])---          (Both, TyConOcc [T] [T])---          (None, TyConOcc [] [])---         ])] --- For positivity check, ultimately we only care about self occurences, --- but we keep track of all the TyCons for the mutually inductive data types. --- We separate the occurences per data constructor only to provide better error messages. -type OccurrenceMap = M.HashMap TyCon [(DataCon, TyConOccurrence)]--data TyConOccurrence-    = TyConOcc { posOcc :: [TyCon] -- TyCons that occur in positive positions-               , negOcc :: [TyCon] -- TyCons that occur in negative positions-               }-  deriving Eq--instance Monoid TyConOccurrence where-  mempty = TyConOcc mempty mempty-instance Semigroup TyConOccurrence where-  TyConOcc p1 n1 <> TyConOcc p2 n2 = TyConOcc (L.nub (p1 <> p2)) (L.nub (n1 <> n2))-instance Outputable TyConOccurrence where-  ppr (TyConOcc pos neg) = text "pos" <+> ppr pos <+>  text "neg" <+> ppr neg---instance Outputable OccurrenceMap where-  ppr m = ppr (M.toList m)---makeOccurrences :: [TyCon] -> OccurrenceMap-makeOccurrences tycons-  = let m0 = M.fromList [(tc, map (\dc -> (dc, makeOccurrence tcInfo (dctypes dc))) (tyConDataCons tc))-                        | tc <- tycons']-    -- fixpoint to find occurrences of mutually recursive data definitons-    in fix (\m -> foldl merge m tycons') m0-  where-    fix f x = let x' = f x in if x == x' then x else fix f x'-    tcInfo = M.fromList $ zip tycons' (makeTyConVariance <$> tycons')-    merge m tc = M.update (mergeList m) tc m-    mergeList m xs = Just [(dc, mergeApp m am) | (dc,am) <- xs]-    mergeApp m (TyConOcc pos neg) =-        let TyConOcc pospos posneg = mconcat (findOccurrence m <$> pos)-            TyConOcc negpos negneg = mconcat (findOccurrence m <$> neg)-        -- Keep positive, flip negative -        in TyConOcc (L.nub (pos <> pospos <> negneg)) (L.nub (neg <> negpos <> posneg))---    tycontypes tc = concatMap dctypes $ tyConDataCons tc-    dctypes    dc = irrelevantMult <$> dataConOrigArgTys dc--    -- Construct the map for all TyCons that appear in the definitions -    tycons' = L.nub (concatMap tcs (concatMap tycontypes tycons) ++ tycons)--    tcs (TyConApp tc' ts) = tc': concatMap tcs ts-    tcs (AppTy t1 t2)     = tcs t1 ++ tcs t2-    tcs (ForAllTy _ t)    = tcs t-    tcs (FunTy _ _ t1 t2) = tcs t1 ++ tcs t2-    tcs (TyVarTy _ )      = []-    tcs (LitTy _)         = []-    tcs (CastTy _ _)      = []-    tcs (CoercionTy _)    = []--makeOccurrence :: M.HashMap TyCon VarianceInfo -> [Type] -> TyConOccurrence-makeOccurrence tcInfo = foldl (go Covariant) mempty-  where-    go :: Variance -> TyConOccurrence -> Type -> TyConOccurrence-    go p m (TyConApp tc ts)  = addOccurrence p tc-                             $ foldl (\m' (t, v) -> go (v <> p) m' t) m-                                (zip ts (M.lookupDefault (repeat Bivariant) tc tcInfo))-    go _ m (TyVarTy _ )      = m-    go _ m (AppTy t1 t2)     = go Bivariant (go Bivariant m t1) t2-    go p m (ForAllTy _ t)    = go p m t-    go p m (FunTy _ _ t1 t2) = go p (go (flipVariance p) m t1) t2-    go _ m (LitTy _)         = m-    go _ m (CastTy _ _)      = m-    go _ m (CoercionTy _)    = m--    addOccurrence p tc (TyConOcc pos neg)-      = case p of-         Covariant     -> TyConOcc (L.nub (tc:pos)) neg-         Contravariant -> TyConOcc pos (L.nub (tc:neg))-         Bivariant     -> TyConOcc (L.nub (tc:pos)) (L.nub (tc:neg))-         Invariant     -> TyConOcc pos neg--findOccurrence :: OccurrenceMap -> TyCon -> TyConOccurrence-findOccurrence m tc = mconcat (snd <$> M.lookupDefault mempty tc m)-----isRecursivenewTyCon :: TyCon -> Bool-isRecursivenewTyCon c-  | not (isNewTyCon c)-  = False-isRecursivenewTyCon c-  = go t-  where-    t = snd $ newTyConRhs c-    go (AppTy t1 t2)      = go t1 || go t2-    go (TyConApp c' ts)   = c == c' || any go ts-    go (ForAllTy _ t1)    = go t1-    go (FunTy _ _ t1 t2)  = go t1 || go t2-    go (CastTy t1 _)      = go t1-    go _                  = False---isHoleVar :: Var -> Bool-isHoleVar x = L.isPrefixOf "_" (show x)--dataConImplicitIds :: DataCon -> [Id]-dataConImplicitIds dc = [ x | AnId x <- dataConImplicitTyThings dc]--class Subable a where-  sub   :: M.HashMap CoreBndr CoreExpr -> a -> a-  subTy :: M.HashMap TyVar Type -> a -> a--instance Subable CoreExpr where-  sub s (Var v)        = M.lookupDefault (Var v) v s-  sub _ (Lit l)        = Lit l-  sub s (App e1 e2)    = App (sub s e1) (sub s e2)-  sub s (Lam b e)      = Lam b (sub s e)-  sub s (Let b e)      = Let (sub s b) (sub s e)-  sub s (Case e b t a) = Case (sub s e) (sub s b) t (map (sub s) a)-  sub s (Cast e c)     = Cast (sub s e) c-  sub s (Tick t e)     = Tick t (sub s e)-  sub _ (Type t)       = Type t-  sub _ (Coercion c)   = Coercion c--  subTy s (Var v)      = Var (subTy s v)-  subTy _ (Lit l)      = Lit l-  subTy s (App e1 e2)  = App (subTy s e1) (subTy s e2)-  subTy s (Lam b e)    | isTyVar b = Lam v' (subTy s e)-   where v' = case M.lookup b s of-               Just (TyVarTy v) -> v-               _                -> b--  subTy s (Lam b e)      = Lam (subTy s b) (subTy s e)-  subTy s (Let b e)      = Let (subTy s b) (subTy s e)-  subTy s (Case e b t a) = Case (subTy s e) (subTy s b) (subTy s t) (map (subTy s) a)-  subTy s (Cast e c)     = Cast (subTy s e) (subTy s c)-  subTy s (Tick t e)     = Tick t (subTy s e)-  subTy s (Type t)       = Type (subTy s t)-  subTy s (Coercion c)   = Coercion (subTy s c)--instance Subable Coercion where-  sub _ c                = c-  subTy _ _              = panic Nothing "subTy Coercion"--instance Subable (Alt Var) where- sub s (a, b, e)   = (a, map (sub s) b,   sub s e)- subTy s (a, b, e) = (a, map (subTy s) b, subTy s e)--instance Subable Var where- sub s v   | M.member v s = subVar $ s M.! v-           | otherwise    = v- subTy s v = setVarType v (subTy s (varType v))--subVar :: Expr t -> Id-subVar (Var x) = x-subVar  _      = panic Nothing "sub Var"--instance Subable (Bind Var) where- sub s (NonRec x e)   = NonRec (sub s x) (sub s e)- sub s (Rec xes)      = Rec ((sub s *** sub s) <$> xes)-- subTy s (NonRec x e) = NonRec (subTy s x) (subTy s e)- subTy s (Rec xes)    = Rec ((subTy s  *** subTy s) <$> xes)--instance Subable Type where- sub _ e   = e- subTy     = substTysWith--substTysWith :: M.HashMap Var Type -> Type -> Type-substTysWith s tv@(TyVarTy v)      = M.lookupDefault tv v s-substTysWith s (FunTy aaf m t1 t2) = FunTy aaf m (substTysWith s t1) (substTysWith s t2)-substTysWith s (ForAllTy v t)      = ForAllTy v (substTysWith (M.delete (binderVar v) s) t)-substTysWith s (TyConApp c ts)     = TyConApp c (map (substTysWith s) ts)-substTysWith s (AppTy t1 t2)       = AppTy (substTysWith s t1) (substTysWith s t2)-substTysWith _ (LitTy t)           = LitTy t-substTysWith s (CastTy t c)        = CastTy (substTysWith s t) c-substTysWith _ (CoercionTy c)      = CoercionTy c--substExpr :: M.HashMap Var Var -> CoreExpr -> CoreExpr-substExpr s = go-  where-    subsVar v                = M.lookupDefault v v s-    go (Var v)               = Var $ subsVar v-    go (Lit l)               = Lit l-    go (App e1 e2)           = App (go e1) (go e2)-    go (Lam x e)             = Lam (subsVar x) (go e)-    go (Let (NonRec x ex) e) = Let (NonRec (subsVar x) (go ex)) (go e)-    go (Let (Rec xes) e)     = Let (Rec [(subsVar x', go e') | (x',e') <- xes]) (go e)-    go (Case e b t alts)     = Case (go e) (subsVar b) t [(c, subsVar <$> xs, go e') | (c, xs, e') <- alts]-    go (Cast e c)            = Cast (go e) c-    go (Tick t e)            = Tick t (go e)-    go (Type t)              = Type t-    go (Coercion c)          = Coercion c--mapType :: (Type -> Type) -> Type -> Type-mapType f = go-  where-    go t@(TyVarTy _)        = f t-    go (AppTy t1 t2)        = f $ AppTy (go t1) (go t2)-    go (TyConApp c ts)      = f $ TyConApp c (go <$> ts)-    go (FunTy aaf m t1 t2)  = f $ FunTy aaf m (go t1) (go t2)-    go (ForAllTy v t)       = f $ ForAllTy v (go t)-    go t@(LitTy _)          = f t-    go (CastTy t c)         = CastTy (go t) c-    go (CoercionTy c)       = f $ CoercionTy c---stringClassArg :: Type -> Maybe Type-stringClassArg t | isFunTy t-  = Nothing-stringClassArg t-  = case (tyConAppTyCon_maybe t, tyConAppArgs_maybe t) of-      (Just c, Just [t']) | isStringClassName == tyConName c-           -> Just t'-      _    -> Nothing
− src-ghc/Liquid/GHC/Resugar.hs 
@@ -1,162 +0,0 @@-{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE UndecidableInstances      #-}---- | This module contains functions for "resugaring" low-level GHC `CoreExpr`---   into high-level patterns, that can receive special case handling in---   different phases (e.g. ANF, Constraint Generation, etc.)--module Liquid.GHC.Resugar (-  -- * High-level Source Patterns-    Pattern (..)--  -- * Lift a CoreExpr into a Pattern-  , lift--  -- * Lower a pattern back into a CoreExpr-  , lower-  ) where--import qualified Data.List as L-import           Liquid.GHC.API  as Ghc hiding (PatBind)-import qualified Liquid.GHC.Misc as GM-import qualified Language.Fixpoint.Types          as F -import qualified Text.PrettyPrint.HughesPJ        as PJ --- import           Debug.Trace------------------------------------------------------------------------------------- | Data type for high-level patterns ----------------------------------------------------------------------------------------------------------------------------data Pattern-  = PatBind-      { patE1  :: !CoreExpr-      , patX   :: !Var-      , patE2  :: !CoreExpr-      , patM   :: !Type-      , patDct :: !CoreExpr-      , patTyA :: !Type-      , patTyB :: !Type-      , patFF  :: !Var-      }                      -- ^ e1 >>= \x -> e2--  | PatReturn                -- return @ m @ t @ $dT @ e-     { patE    :: !CoreExpr  -- ^ e-     , patM    :: !Type      -- ^ m-     , patDct  :: !CoreExpr  -- ^ $dT-     , patTy   :: !Type      -- ^ t-     , patRet  :: !Var       -- ^ "return"-     }--  | PatProject               -- (case xe as x of C [x1,...,xn] -> xi) : ty-    { patXE    :: !Var       -- ^ xe-    , patX     :: !Var       -- ^ x-    , patTy    :: !Type      -- ^ ty-    , patCtor  :: !DataCon   -- ^ C-    , patBinds :: ![Var]     -- ^ [x1,...,xn]-    , patIdx   :: !Int       -- ^ i :: NatLT {len patBinds}-    }--  | PatSelfBind              -- let x = e in x-    { patX     :: !Var       -- ^ x-    , patE     :: !CoreExpr  -- ^ e-    }--  | PatSelfRecBind           -- letrec x = e in x-    { patX     :: !Var       -- ^ x-    , patE     :: !CoreExpr  -- ^ e-    }--instance F.PPrint Pattern where -  pprintTidy  = ppPat--ppPat :: F.Tidy -> Pattern -> PJ.Doc -ppPat k (PatReturn e m d t rv) = -  "PatReturn: " -  PJ.$+$ -  F.pprintKVs k-    [ ("rv" :: PJ.Doc, GM.pprDoc rv) -    , ("e " :: PJ.Doc, GM.pprDoc e) -    , ("m " :: PJ.Doc, GM.pprDoc m) -    , ("$d" :: PJ.Doc, GM.pprDoc d) -    , ("t " :: PJ.Doc, GM.pprDoc t) -    ] -ppPat _ _  = "TODO: PATTERN" -    --_mbId :: CoreExpr -> Maybe Var-_mbId (Var x)    = Just x-_mbId (Tick _ e) = _mbId e-_mbId _          = Nothing------------------------------------------------------------------------------------- | Lift expressions into High-level patterns -------------------------------------------------------------------------------------------------------------------lift :: CoreExpr -> Maybe Pattern----------------------------------------------------------------------------------lift e = exprArgs e (collectArgs e)--exprArgs :: CoreExpr -> (CoreExpr, [CoreExpr]) -> Maybe Pattern-exprArgs _e (Var op, [Type m, d, Type a, Type b, e1, Lam x e2])-  | op `is` Ghc.bindMName-  = Just (PatBind e1 x e2 m d a b op)--exprArgs (Case (Var xe) x t [(DataAlt c, ys, Var y)]) _-  | Just i <- y `L.elemIndex` ys-  = Just (PatProject xe x t c ys i)---{- TEMPORARILY DISABLED: TODO-REBARE; in reality it hasn't been working AT ALL -   since at least the GHC 8.2.1 port (?) because the TICKs get in the way -   of recognizing the pattern? Anyways, messes up --     tests/pattern/pos/Return00.hs  --   because we treat _all_ types of the form `m a` as "invariant" in the parameter `a`.-   Looks like the above tests only pass in earlier LH versions because this pattern -   was NOT getting tickled!--exprArgs _e (Var op, [Type m, d, Type t, e])-  | op `is` PN.returnMName-  = Just (PatReturn e m d t op)--}--{- TEMPORARILY DISBLED--exprArgs (Let (NonRec x e) e') _-  | Just y <- _mbId e', x == y-  = Just (PatSelfBind x e)--exprArgs (Let (Rec [(x, e)]) e') _-  | Just y <- _mbId e', x == y-  = Just (PatSelfRecBind x e)---}-exprArgs _ _-  = Nothing--is :: Var -> Name -> Bool-is v n = n == getName v------------------------------------------------------------------------------------- | Lower patterns back into expressions ------------------------------------------------------------------------------------------------------------------------lower :: Pattern -> CoreExpr----------------------------------------------------------------------------------lower (PatBind e1 x e2 m d a b op)-  = Ghc.mkCoreApps (Var op) [Type m, d, Type a, Type b, e1, Lam x e2]--lower (PatReturn e m d t op)-  = Ghc.mkCoreApps (Var op) [Type m, d, Type t, e]--lower (PatProject xe x t c ys i)-  = Case (Var xe) x t [(DataAlt c, ys, Var yi)] where yi = ys !! i--lower (PatSelfBind x e)-  = Let (NonRec x e) (Var x)--lower (PatSelfRecBind x e)-  = Let (Rec [(x, e)]) (Var x)
− src-ghc/Liquid/GHC/SpanStack.hs 
@@ -1,80 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module Liquid.GHC.SpanStack-   ( -- * Stack of positions-     Span (..)-   , SpanStack--     -- * Creating Stacks-   , empty, push--     -- * Using Stacks-   , srcSpan--     -- * Creating general spans-   , showSpan-   ) where--import           Prelude                   hiding (error)-import           Data.Maybe                       (listToMaybe, fromMaybe)-import           Liquid.GHC.Misc (tickSrcSpan, showPpr)-import qualified Liquid.GHC.API  as Ghc-import           Liquid.GHC.API  ( SrcSpan-                                                  , fsLit-                                                  , getSrcSpan-                                                  , isGoodSrcSpan-                                                  , mkGeneralSrcSpan-                                                  )---- | Opaque type for a stack of spans-newtype SpanStack = SpanStack { unStack :: [(Span, SrcSpan)] }-----------------------------------------------------------------------------------empty :: SpanStack----------------------------------------------------------------------------------empty = SpanStack []-----------------------------------------------------------------------------------push :: Span -> SpanStack -> SpanStack----------------------------------------------------------------------------------push !s stk -- @(SpanStack stk)-  | Just sp <- spanSrcSpan s = SpanStack ((s, sp) : unStack stk)-  | otherwise                = stk---- | A single span-data Span-  = Var  !Ghc.Var               -- ^ binder for whom we are generating constraint-  | Tick !(Ghc.Tickish Ghc.Var) -- ^ nearest known Source Span-  | Span SrcSpan--instance Show Span where-  show (Var x)   = show x-  show (Tick tt) = showPpr tt-  show (Span s)  = show s -----------------------------------------------------------------------------------srcSpan :: SpanStack -> SrcSpan----------------------------------------------------------------------------------srcSpan s  = fromMaybe noSpan (mbSrcSpan s)-  where-    noSpan = showSpan "Yikes! No source information"--mbSrcSpan :: SpanStack -> Maybe SrcSpan-mbSrcSpan = fmap snd . listToMaybe  . unStack--spanSrcSpan :: Span -> Maybe SrcSpan-spanSrcSpan      = maybeSpan Nothing . go-  where-    go (Var x)   = getSrcSpan x-    go (Tick tt) = tickSrcSpan tt-    go (Span s)  = s --maybeSpan :: Maybe SrcSpan -> SrcSpan -> Maybe SrcSpan-maybeSpan d sp-  | isGoodSrcSpan sp = Just sp-  | otherwise        = d-----------------------------------------------------------------------------------showSpan :: (Show a) => a -> SrcSpan----------------------------------------------------------------------------------showSpan = mkGeneralSrcSpan . fsLit . show
− src-ghc/Liquid/GHC/TypeRep.hs 
@@ -1,164 +0,0 @@-{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE UndecidableInstances      #-}-{-# LANGUAGE StandaloneDeriving        #-}--{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- TODO(#1918): Only needed for GHC <9.0.1.-{-# OPTIONS_GHC -Wno-orphans #-}--module Liquid.GHC.TypeRep (-  mkTyArg, --  showTy-  ) where--import           Liquid.GHC.Misc (showPpr)-import           Liquid.GHC.API as Ghc hiding (mkTyArg, showPpr, panic)-import           Language.Fixpoint.Types (symbol)---- e368f3265b80aeb337fbac3f6a70ee54ab14edfd--mkTyArg :: TyVar -> TyVarBinder-mkTyArg v = Bndr v Required--instance Eq Type where-  t1 == t2 = eqType' t1 t2--eqType' :: Type -> Type -> Bool -eqType' (LitTy l1) (LitTy l2) -  = l1 == l2  -eqType' (CoercionTy c1) (CoercionTy c2) -  = c1 == c2  -eqType'(CastTy t1 c1) (CastTy t2 c2) -  = eqType' t1 t2 && c1 == c2 -eqType' (FunTy a1 m1 t11 t12) (FunTy a2 m2 t21 t22)-  = a1 == a2 && m1 == m2 && eqType' t11 t21 && eqType' t12 t22  -eqType' (ForAllTy (Bndr v1 _) t1) (ForAllTy (Bndr v2 _) t2) -  = eqType' t1 (subst v2 (TyVarTy v1) t2) -eqType' (TyVarTy v1) (TyVarTy v2) -  = v1 == v2 -eqType' (AppTy t11 t12) (AppTy t21 t22) -  = eqType' t11 t21 && eqType' t12 t22  -eqType' (TyConApp c1 ts1) (TyConApp c2 ts2) -  = c1 == c2 && and (zipWith eqType' ts1 ts2) -eqType' _ _ -  = False ---deriving instance (Eq tyvar, Eq argf) => Eq (VarBndr tyvar argf)--instance Eq Coercion where-  _ == _ = True ---showTy :: Type -> String -showTy (TyConApp c ts) = "(RApp   " ++ showPpr c ++ " " ++ sep' ", " (showTy <$> ts) ++ ")"-showTy (AppTy t1 t2)   = "(TAppTy " ++ (showTy t1 ++ " " ++ showTy t2) ++ ")" -showTy (TyVarTy v)   = "(RVar " ++ show (symbol v)  ++ ")" -showTy (ForAllTy (Bndr v _) t)  = "ForAllTy " ++ show (symbol v) ++ ". (" ++  showTy t ++ ")"-showTy (FunTy af _m1 t1 t2) = "FunTy " ++ showPpr af ++ " " ++ showTy t1 ++ ". (" ++  showTy t2 ++ ")"-showTy (CastTy _ _)    = "CastTy"-showTy (CoercionTy _)  = "CoercionTy"-showTy (LitTy _)       = "LitTy"--sep' :: String -> [String] -> String-sep' _ [x] = x-sep' _ []  = []-sep' s (x:xs) = x ++ s ++ sep' s xs -------------------------------------------------------------------------------------- | GHC Type Substitutions -------------------------------------------------------------------------------------------------------------------------------------class SubstTy a where-  subst :: TyVar -> Type -> a -> a-  subst _ _ = id  --instance SubstTy Type where-  subst = substType--substType :: TyVar -> Type -> Type -> Type-substType x tx (TyConApp c ts) -  = TyConApp c (subst x tx <$> ts)-substType x tx (AppTy t1 t2)   -  = AppTy (subst x tx t1) (subst x tx t2) -substType x tx (TyVarTy y)   -  | symbol x == symbol y-  = tx -  | otherwise-  = TyVarTy y -substType x tx (FunTy aaf m t1 t2)-  = FunTy aaf m (subst x tx t1) (subst x tx t2)-substType x tx f@(ForAllTy b@(Bndr y _) t)  -  | symbol x == symbol y -  = f-  | otherwise -  = ForAllTy b (subst x tx t)-substType x tx (CastTy t c)    -  = CastTy (subst x tx t) (subst x tx c)-substType x tx (CoercionTy c)  -  = CoercionTy $ subst x tx c -substType _ _  (LitTy l)-  = LitTy l  ---instance SubstTy Coercion where-  subst = substCoercion--substCoercion :: TyVar -> Type -> Coercion -> Coercion-substCoercion x tx (TyConAppCo r c cs)-  = TyConAppCo (subst x tx r) c (subst x tx <$> cs)-substCoercion x tx (AppCo c1 c2)-  = AppCo (subst x tx c1) (subst x tx c2)-substCoercion x tx (FunCo r cN c1 c2)-  = FunCo r cN (subst x tx c1) (subst x tx c2) -- TODO(adinapoli) Is this the correct substitution?-substCoercion x tx (ForAllCo y c1 c2)-  | symbol x == symbol y -  = ForAllCo y c1 c2-  | otherwise -  = ForAllCo y (subst x tx c1) (subst x tx c2)-substCoercion _ _ (CoVarCo y)-  = CoVarCo y -substCoercion x tx (AxiomInstCo co bi cs)-  = AxiomInstCo (subst x tx co) bi (subst x tx <$> cs)  -substCoercion x tx (UnivCo y r t1 t2)-  = UnivCo (subst x tx y) (subst x tx r) (subst x tx t1) (subst x tx t2)-substCoercion x tx (SymCo c)-  = SymCo (subst x tx c)-substCoercion x tx (TransCo c1 c2)-  = TransCo (subst x tx c1) (subst x tx c2)-substCoercion x tx (AxiomRuleCo ca cs)-  = AxiomRuleCo (subst x tx ca)  (subst x tx <$> cs)  -substCoercion x tx (NthCo r i c)-  = NthCo r i (subst x tx c)-substCoercion x tx (LRCo i c)-  = LRCo i (subst x tx c)-substCoercion x tx (InstCo c1 c2)-  = InstCo (subst x tx c1) (subst x tx c2)-substCoercion x tx (KindCo c)-  = KindCo (subst x tx c)-substCoercion x tx (SubCo c)-  = SubCo (subst x tx c)--instance SubstTy Role where-instance SubstTy (CoAxiom Branched) where--instance SubstTy UnivCoProvenance where-  subst x tx (PhantomProv c)-    = PhantomProv $ subst x tx c -  subst x tx (ProofIrrelProv c)-    = ProofIrrelProv $ subst x tx c -  subst _ _ ch -    = ch --instance SubstTy CoAxiomRule where-  subst x tx (CoAxiomRule n rs r ps) -    = CoAxiomRule n (subst x tx <$> rs) (subst x tx r) (\eq -> subst x tx (ps (subst x tx eq)))--instance (SubstTy a, Functor m) => SubstTy (m a) where-  subst x tx xs = subst x tx <$> xs
− src-ghc/Liquid/GHC/Types.hs 
@@ -1,79 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Liquid.GHC.Types where--import           Data.HashSet (HashSet, fromList)-import           Data.Hashable-import           GHC.Generics hiding (moduleName)-import           Liquid.GHC.API---- | A 'StableName' is virtually isomorphic to a GHC's 'Name' but crucially we don't use--- the 'Eq' instance defined on a 'Name' because it's 'Unique'-based. In particular, GHC--- doesn't guarantee that if we load an interface multiple times we would get the same 'Unique' for the--- same 'Name', and this is a problem when we rely on 'Name's to be the same when we call 'isExportedVar',--- which used to use a 'NameSet' derived from the '[AvailInfo]'. As the name implies, a 'NameSet' uses a--- 'Name's 'Unique' for duplicate detection and indexing, and this would lead to 'Var's being resolved to--- a 'Name' which is basically the same, but it has a /different/ 'Unique', and that would cause the lookup--- inside the 'NameSet' to fail.-newtype StableName =-  MkStableName { unStableName :: Name }-  deriving Generic--instance Show StableName where-  show (MkStableName n) = nameStableString n--instance Hashable StableName where-  hashWithSalt s (MkStableName n) = hashWithSalt s (nameStableString n)--instance Eq StableName where-  (MkStableName n1) == (MkStableName n2) = -- n1 `stableNameCmp` n2 == EQ-    let sameOccName = occNameString (nameOccName n1) == occNameString (nameOccName n2)-        sameModule  = nameModule  n1 == nameModule  n2-        sameSrcLoc  = nameSrcLoc  n1 == nameSrcLoc  n2-        sameSrcSpan = nameSrcSpan n1 == nameSrcSpan n2-    in sameOccName && sameModule && sameSrcLoc  && sameSrcSpan---- | Creates a new 'StableName' out of a 'Name'.-mkStableName :: Name -> StableName-mkStableName = MkStableName---- | Converts a list of 'AvailInfo' into a \"StableNameSet\", similarly to what 'availsToNameSet' would do.-availsToStableNameSet :: [AvailInfo] -> HashSet StableName-availsToStableNameSet avails = foldr add mempty avails-      where add av acc = acc <> fromList (map mkStableName (availNames av))------------------------------------------------------------------------------------- | Datatype For Holding GHC ModGuts ----------------------------------------------------------------------------------------------------------------------------data MGIModGuts = MI-  { mgi_binds     :: !CoreProgram-  , mgi_module    :: !Module-  , mgi_deps      :: !Dependencies-  , mgi_dir_imps  :: ![ModuleName]-  , mgi_rdr_env   :: !GlobalRdrEnv-  , mgi_tcs       :: ![TyCon]-  , mgi_fam_insts :: ![FamInst]-  , mgi_exports   :: !(HashSet StableName)-  , mgi_cls_inst  :: !(Maybe [ClsInst])-  }--miModGuts :: Maybe [ClsInst] -> ModGuts -> MGIModGuts-miModGuts cls mg  = MI-  { mgi_binds     = mg_binds mg-  , mgi_module    = mg_module mg-  , mgi_deps      = mg_deps mg-  , mgi_dir_imps  = mgDirImps mg-  , mgi_rdr_env   = mg_rdr_env mg-  , mgi_tcs       = mg_tcs mg-  , mgi_fam_insts = mg_fam_insts mg-  , mgi_exports   = availsToStableNameSet $ mg_exports mg-  , mgi_cls_inst  = cls-  }--nameSetToStableNameSet :: NameSet -> HashSet StableName-nameSetToStableNameSet = fromList . map mkStableName . nameSetElemsStable--mgDirImps :: ModGuts -> [ModuleName]-mgDirImps = map gwib_mod . getDependenciesModuleNames . mg_deps--mgiNamestring :: MGIModGuts -> String-mgiNamestring = moduleNameString . moduleName . mgi_module
+ src/Data/Bits_LHAssumptions.hs view
@@ -0,0 +1,7 @@+module Data.Bits_LHAssumptions where++{-@+//  TODO: cannot use this because `Bits` is not a `Num`+//  Data.Bits.shiftR :: (Data.Bits.Bits a) => x:a -> d:Nat +//                   -> {v:a | ((d=1) => (x <= 2*v + 1 && 2*v <= x)) }+@-}
+ src/Data/ByteString/Char8_LHAssumptions.hs view
@@ -0,0 +1,285 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+module Data.ByteString.Char8_LHAssumptions where++import Data.ByteString_LHAssumptions()+import Data.ByteString+import Data.ByteString.Char8++{-@++assume Data.ByteString.Char8.singleton+    :: GHC.Types.Char -> { bs : Data.ByteString.ByteString | bslen bs == 1 }++assume Data.ByteString.Char8.pack+    :: w8s : [GHC.Types.Char]+    -> { bs : Data.ByteString.ByteString | bslen bs == len w8s }++assume Data.ByteString.Char8.unpack+    :: bs : Data.ByteString.ByteString+    -> { w8s : [GHC.Types.Char] | len w8s == bslen bs }++assume Data.ByteString.Char8.cons+    :: GHC.Types.Char+    -> i : Data.ByteString.ByteString+    -> { o : Data.ByteString.ByteString | bslen o == bslen i + 1 }++assume Data.ByteString.Char8.snoc+    :: i : Data.ByteString.ByteString+    -> GHC.Types.Char+    -> { o : Data.ByteString.ByteString | bslen o == bslen i + 1 }++assume Data.ByteString.Char8.head :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> GHC.Types.Char++assume Data.ByteString.Char8.uncons+    :: i : Data.ByteString.ByteString+    -> Maybe (GHC.Types.Char, { o : Data.ByteString.ByteString | bslen o == bslen i - 1 })++assume Data.ByteString.Char8.unsnoc+    :: i : Data.ByteString.ByteString+    -> Maybe ({ o : Data.ByteString.ByteString | bslen o == bslen i - 1 }, GHC.Types.Char)++assume Data.ByteString.Char8.last :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> GHC.Types.Char++assume Data.ByteString.Char8.map+    :: (GHC.Types.Char -> GHC.Types.Char)+    -> i : Data.ByteString.ByteString+    -> { o : Data.ByteString.ByteString | bslen o == bslen i }++assume Data.ByteString.Char8.intersperse+    :: GHC.Types.Char+    -> i : Data.ByteString.ByteString+    -> { o : Data.ByteString.ByteString | (bslen i == 0 <=> bslen o == 0) && (1 <= bslen i <=> bslen o == 2 * bslen i - 1) }++assume Data.ByteString.Char8.foldl1+    :: (GHC.Types.Char -> GHC.Types.Char -> GHC.Types.Char)+    -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }+    -> Char++assume Data.ByteString.Char8.foldl1'+    :: (GHC.Types.Char -> GHC.Types.Char -> GHC.Types.Char)+    -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }+    -> GHC.Types.Char++assume Data.ByteString.Char8.foldr1+    :: (GHC.Types.Char -> GHC.Types.Char -> GHC.Types.Char)+    -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }+    -> Char++assume Data.ByteString.Char8.foldr1'+    :: (GHC.Types.Char -> GHC.Types.Char -> GHC.Types.Char)+    -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }+    -> GHC.Types.Char++assume Data.ByteString.Char8.concatMap+    :: (GHC.Types.Char -> Data.ByteString.ByteString)+    -> i : Data.ByteString.ByteString+    -> { o : Data.ByteString.ByteString | bslen i == 0 ==> bslen o == 0 }++assume Data.ByteString.Char8.any :: (GHC.Types.Char -> GHC.Types.Bool)+    -> bs : Data.ByteString.ByteString+    -> { b : GHC.Types.Bool | bslen bs == 0 ==> not b }++assume Data.ByteString.Char8.all :: (GHC.Types.Char -> GHC.Types.Bool)+    -> bs : Data.ByteString.ByteString+    -> { b : GHC.Types.Bool | bslen bs == 0 ==> b }++assume Data.ByteString.Char8.maximum+    :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> GHC.Types.Char++assume Data.ByteString.Char8.minimum+    :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> GHC.Types.Char++assume Data.ByteString.Char8.scanl+    :: (GHC.Types.Char -> GHC.Types.Char -> GHC.Types.Char)+    -> GHC.Types.Char+    -> i : Data.ByteString.ByteString+    -> { o : Data.ByteString.ByteString | bslen o == bslen i }++assume Data.ByteString.Char8.scanl1+    :: (GHC.Types.Char -> GHC.Types.Char -> GHC.Types.Char)+    -> i : { i : Data.ByteString.ByteString | 1 <= bslen i }+    -> { o : Data.ByteString.ByteString | bslen o == bslen i }++assume Data.ByteString.Char8.scanr+    :: (GHC.Types.Char -> GHC.Types.Char -> GHC.Types.Char)+    -> GHC.Types.Char+    -> i : Data.ByteString.ByteString+    -> { o : Data.ByteString.ByteString | bslen o == bslen i }++assume Data.ByteString.Char8.scanr1+    :: (GHC.Types.Char -> GHC.Types.Char -> GHC.Types.Char)+    -> i : { i : Data.ByteString.ByteString | 1 <= bslen i }+    -> { o : Data.ByteString.ByteString | bslen o == bslen i }++assume Data.ByteString.Char8.mapAccumL+    :: (acc -> GHC.Types.Char -> (acc, GHC.Types.Char))+    -> acc+    -> i : Data.ByteString.ByteString+    -> (acc, { o : Data.ByteString.ByteString | bslen o == bslen i })++assume Data.ByteString.Char8.mapAccumR+    :: (acc -> GHC.Types.Char -> (acc, GHC.Types.Char))+    -> acc+    -> i : Data.ByteString.ByteString+    -> (acc, { o : Data.ByteString.ByteString | bslen o == bslen i })++assume Data.ByteString.Char8.replicate+    :: n : Int+    -> GHC.Types.Char+    -> { bs : Data.ByteString.ByteString | bslen bs == n }++assume Data.ByteString.Char8.unfoldrN+    :: n : Int+    -> (a -> Maybe (GHC.Types.Char, a))+    -> a+    -> ({ bs : Data.ByteString.ByteString | bslen bs <= n }, Maybe a)++assume Data.ByteString.Char8.takeWhile+    :: (GHC.Types.Char -> GHC.Types.Bool)+    -> i : Data.ByteString.ByteString+    -> { o : Data.ByteString.ByteString | bslen o <= bslen i }++assume Data.ByteString.Char8.dropWhile+    :: (GHC.Types.Char -> GHC.Types.Bool)+    -> i : Data.ByteString.ByteString+    -> { o : Data.ByteString.ByteString | bslen o <= bslen i }++assume Data.ByteString.Char8.span+    :: (GHC.Types.Char -> GHC.Types.Bool)+    -> i : Data.ByteString.ByteString+    -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }+       , { r : Data.ByteString.ByteString | bslen r <= bslen i }+       )++assume Data.ByteString.Char8.spanEnd+    :: (GHC.Types.Char -> GHC.Types.Bool)+    -> i : Data.ByteString.ByteString+    -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }+       , { r : Data.ByteString.ByteString | bslen r <= bslen i }+       )++assume Data.ByteString.Char8.break+    :: (GHC.Types.Char -> GHC.Types.Bool)+    -> i : Data.ByteString.ByteString+    -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }+       , { r : Data.ByteString.ByteString | bslen r <= bslen i }+       )++assume Data.ByteString.Char8.breakEnd+    :: (GHC.Types.Char -> GHC.Types.Bool)+    -> i : Data.ByteString.ByteString+    -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }+       , { r : Data.ByteString.ByteString | bslen r <= bslen i }+       )++assume Data.ByteString.Char8.groupBy+    :: (GHC.Types.Char -> GHC.Types.Char -> GHC.Types.Bool)+    -> i : Data.ByteString.ByteString+    -> [{ o : Data.ByteString.ByteString | 1 <= bslen o && bslen o <= bslen i }]++assume Data.ByteString.Char8.split+    :: GHC.Types.Char+    -> i : Data.ByteString.ByteString+    -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]++assume Data.ByteString.Char8.splitWith+    :: (GHC.Types.Char -> GHC.Types.Bool)+    -> i : Data.ByteString.ByteString+    -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]++assume Data.ByteString.Char8.lines+    :: i : Data.ByteString.ByteString+    -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]++assume Data.ByteString.Char8.words+    :: i : Data.ByteString.ByteString+    -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]++assume Data.ByteString.Char8.unlines+    :: is : [Data.ByteString.ByteString]+    -> { o : Data.ByteString.ByteString | (len is == 0 <=> bslen o == 0) && bslen o >= len is }++assume Data.ByteString.Char8.unwords+    :: is : [Data.ByteString.ByteString]+    -> { o : Data.ByteString.ByteString | (len is == 0 ==> bslen o == 0) && (1 <= len is ==> bslen o >= len is - 1) }++assume Data.ByteString.Char8.elem+    :: GHC.Types.Char+    -> bs : Data.ByteString.ByteString+    -> { b : GHC.Types.Bool | bslen bs == 0 ==> not b }++assume Data.ByteString.Char8.notElem+    :: GHC.Types.Char+    -> bs : Data.ByteString.ByteString+    -> { b : GHC.Types.Bool | bslen bs == 0 ==> b }++assume Data.ByteString.Char8.find+    :: (GHC.Types.Char -> GHC.Types.Bool)+    -> bs : Data.ByteString.ByteString+    -> Maybe { w8 : GHC.Types.Char | bslen bs /= 0 }++assume Data.ByteString.Char8.filter+    :: (GHC.Types.Char -> GHC.Types.Bool)+    -> i : Data.ByteString.ByteString+    -> { o : Data.ByteString.ByteString | bslen o <= bslen i }++assume Data.ByteString.Char8.index+    :: bs : Data.ByteString.ByteString+    -> { n : Int | 0 <= n && n < bslen bs }+    -> GHC.Types.Char++assume Data.ByteString.Char8.elemIndex+    :: GHC.Types.Char+    -> bs : Data.ByteString.ByteString+    -> Maybe { n : Int | 0 <= n && n < bslen bs }++assume Data.ByteString.Char8.elemIndices+    :: GHC.Types.Char+    -> bs : Data.ByteString.ByteString+    -> [{ n : Int | 0 <= n && n < bslen bs }]++assume Data.ByteString.Char8.elemIndexEnd+    :: GHC.Types.Char+    -> bs : Data.ByteString.ByteString+    -> Maybe { n : Int | 0 <= n && n < bslen bs }++assume Data.ByteString.Char8.findIndex+    :: (GHC.Types.Char -> GHC.Types.Bool)+    -> bs : Data.ByteString.ByteString+    -> Maybe { n : Int | 0 <= n && n < bslen bs }++assume Data.ByteString.Char8.findIndices+    :: (GHC.Types.Char -> GHC.Types.Bool)+    -> bs : Data.ByteString.ByteString+    -> [{ n : Int | 0 <= n && n < bslen bs }]++assume Data.ByteString.Char8.count+    :: GHC.Types.Char+    -> bs : Data.ByteString.ByteString+    -> { n : Int | 0 <= n && n < bslen bs }++assume Data.ByteString.Char8.zip+    :: l : Data.ByteString.ByteString+    -> r : Data.ByteString.ByteString+    -> { o : [(GHC.Types.Char, GHC.Types.Char)] | len o <= bslen l && len o <= bslen r }++assume Data.ByteString.Char8.zipWith+    :: (GHC.Types.Char -> GHC.Types.Char -> a)+    -> l : Data.ByteString.ByteString+    -> r : Data.ByteString.ByteString+    -> { o : [a] | len o <= bslen l && len o <= bslen r }++assume Data.ByteString.Char8.unzip+    :: i : [(GHC.Types.Char, GHC.Types.Char)]+    -> ( { l : Data.ByteString.ByteString | bslen l == len i }+       , { r : Data.ByteString.ByteString | bslen r == len i }+       )++assume Data.ByteString.Char8.readInt+    :: i : Data.ByteString.ByteString+    -> Maybe { p : (Int, { o : Data.ByteString.ByteString | bslen o < bslen i}) | bslen i /= 0 }++assume Data.ByteString.Char8.readInteger+    :: i : Data.ByteString.ByteString+    -> Maybe { p : (Integer, { o : Data.ByteString.ByteString | bslen o < bslen i}) | bslen i /= 0 }+@-}
+ src/Data/ByteString/Lazy/Char8_LHAssumptions.hs view
@@ -0,0 +1,255 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+module Data.ByteString.Lazy.Char8_LHAssumptions where++import Data.ByteString.Lazy hiding (hGetNonBlocking, scanl)+import Data.ByteString.Lazy.Char8+import Data.ByteString.Lazy_LHAssumptions()++{-@+assume Data.ByteString.Lazy.Char8.last :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs } -> GHC.Types.Char++assume Data.ByteString.Lazy.Char8.singleton+    :: GHC.Types.Char -> { bs : Data.ByteString.Lazy.ByteString | bllen bs == 1 }++assume Data.ByteString.Lazy.Char8.pack+    :: w8s : [GHC.Types.Char]+    -> { bs : Data.ByteString.Lazy.ByteString | bllen bs == len w8s }++assume Data.ByteString.Lazy.Char8.unpack+    :: bs : Data.ByteString.Lazy.ByteString+    -> { w8s : [GHC.Types.Char] | len w8s == bllen bs }++assume Data.ByteString.Lazy.Char8.cons+    :: GHC.Types.Char+    -> i : Data.ByteString.Lazy.ByteString+    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i + 1 }++assume Data.ByteString.Lazy.Char8.snoc+    :: i : Data.ByteString.Lazy.ByteString+    -> GHC.Types.Char+    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i + 1 }++assume Data.ByteString.Lazy.Char8.head+    :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }+    -> GHC.Types.Char++assume Data.ByteString.Lazy.Char8.uncons+    :: i : Data.ByteString.Lazy.ByteString+    -> Maybe (GHC.Types.Char, { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i - 1 })++assume Data.ByteString.Lazy.Char8.unsnoc+    :: i : Data.ByteString.Lazy.ByteString+    -> Maybe ({ o : Data.ByteString.Lazy.ByteString | bllen o == bllen i - 1 }, GHC.Types.Char)++assume Data.ByteString.Lazy.Char8.map+    :: (GHC.Types.Char -> GHC.Types.Char)+    -> i : Data.ByteString.Lazy.ByteString+    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i }++assume Data.ByteString.Lazy.Char8.intersperse+    :: GHC.Types.Char+    -> i : Data.ByteString.Lazy.ByteString+    -> { o : Data.ByteString.Lazy.ByteString | (bllen i == 0 <=> bllen o == 0) && (1 <= bllen i <=> bllen o == 2 * bllen i - 1) }++assume Data.ByteString.Lazy.Char8.foldl1+    :: (GHC.Types.Char -> GHC.Types.Char -> GHC.Types.Char)+    -> { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }+    -> GHC.Types.Char++assume Data.ByteString.Lazy.Char8.foldl1'+    :: (GHC.Types.Char -> GHC.Types.Char -> GHC.Types.Char)+    -> { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }+    -> GHC.Types.Char++assume Data.ByteString.Lazy.Char8.foldr1+    :: (GHC.Types.Char -> GHC.Types.Char -> GHC.Types.Char)+    -> { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }+    -> GHC.Types.Char++assume Data.ByteString.Lazy.Char8.concatMap+    :: (GHC.Types.Char -> Data.ByteString.Lazy.ByteString)+    -> i : Data.ByteString.Lazy.ByteString+    -> { o : Data.ByteString.Lazy.ByteString | bllen i == 0 ==> bllen o == 0 }++assume Data.ByteString.Lazy.Char8.any :: (GHC.Types.Char -> GHC.Types.Bool)+    -> bs : Data.ByteString.Lazy.ByteString+    -> { b : GHC.Types.Bool | bllen bs == 0 ==> not b }++assume Data.ByteString.Lazy.Char8.all :: (GHC.Types.Char -> GHC.Types.Bool)+    -> bs : Data.ByteString.Lazy.ByteString+    -> { b : GHC.Types.Bool | bllen bs == 0 ==> b }++assume Data.ByteString.Lazy.Char8.maximum :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs } -> GHC.Types.Char++assume Data.ByteString.Lazy.Char8.minimum :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs } -> GHC.Types.Char++assume Data.ByteString.Lazy.Char8.scanl+    :: (GHC.Types.Char -> GHC.Types.Char -> GHC.Types.Char)+    -> GHC.Types.Char+    -> i : Data.ByteString.Lazy.ByteString+    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i }++assume Data.ByteString.Lazy.Char8.scanl1+    :: (GHC.Types.Char -> GHC.Types.Char -> GHC.Types.Char)+    -> i : { i : Data.ByteString.Lazy.ByteString | 1 <= bllen i }+    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i }++assume Data.ByteString.Lazy.Char8.scanr+    :: (GHC.Types.Char -> GHC.Types.Char -> GHC.Types.Char)+    -> GHC.Types.Char+    -> i : Data.ByteString.Lazy.ByteString+    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i }++assume Data.ByteString.Lazy.Char8.scanr1+    :: (GHC.Types.Char -> GHC.Types.Char -> GHC.Types.Char)+    -> i : { i : Data.ByteString.Lazy.ByteString | 1 <= bllen i }+    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i }++assume Data.ByteString.Lazy.Char8.mapAccumL+    :: (acc -> GHC.Types.Char -> (acc, GHC.Types.Char))+    -> acc+    -> i : Data.ByteString.Lazy.ByteString+    -> (acc, { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i })++assume Data.ByteString.Lazy.Char8.mapAccumR+    :: (acc -> GHC.Types.Char -> (acc, GHC.Types.Char))+    -> acc+    -> i : Data.ByteString.Lazy.ByteString+    -> (acc, { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i })++assume Data.ByteString.Lazy.Char8.replicate+    :: n : Int64+    -> GHC.Types.Char+    -> { bs : Data.ByteString.Lazy.ByteString | bllen bs == n }++assume Data.ByteString.Lazy.Char8.takeWhile+    :: (GHC.Types.Char -> GHC.Types.Bool)+    -> i : Data.ByteString.Lazy.ByteString+    -> { o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }++assume Data.ByteString.Lazy.Char8.dropWhile+    :: (GHC.Types.Char -> GHC.Types.Bool)+    -> i : Data.ByteString.Lazy.ByteString+    -> { o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }++assume Data.ByteString.Lazy.Char8.span+    :: (GHC.Types.Char -> GHC.Types.Bool)+    -> i : Data.ByteString.Lazy.ByteString+    -> ( { l : Data.ByteString.Lazy.ByteString | bllen l <= bllen i }+       , { r : Data.ByteString.Lazy.ByteString | bllen r <= bllen i }+       )++assume Data.ByteString.Lazy.Char8.break+    :: (GHC.Types.Char -> GHC.Types.Bool)+    -> i : Data.ByteString.Lazy.ByteString+    -> ( { l : Data.ByteString.Lazy.ByteString | bllen l <= bllen i }+       , { r : Data.ByteString.Lazy.ByteString | bllen r <= bllen i }+       )++assume Data.ByteString.Lazy.Char8.groupBy+    :: (GHC.Types.Char -> GHC.Types.Char -> GHC.Types.Bool)+    -> i : Data.ByteString.Lazy.ByteString+    -> [{ o : Data.ByteString.Lazy.ByteString | 1 <= bllen o && bllen o <= bllen i }]++assume Data.ByteString.Lazy.Char8.split+    :: GHC.Types.Char+    -> i : Data.ByteString.Lazy.ByteString+    -> [{ o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }]++assume Data.ByteString.Lazy.Char8.splitWith+    :: (GHC.Types.Char -> GHC.Types.Bool)+    -> i : Data.ByteString.Lazy.ByteString+    -> [{ o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }]++assume Data.ByteString.Lazy.Char8.lines+    :: i : Data.ByteString.Lazy.ByteString+    -> [{ o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }]++assume Data.ByteString.Lazy.Char8.words+    :: i : Data.ByteString.Lazy.ByteString+    -> [{ o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }]++assume Data.ByteString.Lazy.Char8.unlines+    :: is : [Data.ByteString.Lazy.ByteString]+    -> { o : Data.ByteString.Lazy.ByteString | (len is == 0 <=> bllen o == 0) && bllen o >= len is }++assume Data.ByteString.Lazy.Char8.unwords+    :: is : [Data.ByteString.Lazy.ByteString]+    -> { o : Data.ByteString.Lazy.ByteString | (len is == 0 ==> bllen o == 0) && (1 <= len is ==> bllen o >= len is - 1) }++assume Data.ByteString.Lazy.Char8.elem+    :: GHC.Types.Char+    -> bs : Data.ByteString.Lazy.ByteString+    -> { b : GHC.Types.Bool | bllen bs == 0 ==> not b }++assume Data.ByteString.Lazy.Char8.notElem+    :: GHC.Types.Char+    -> bs : Data.ByteString.Lazy.ByteString+    -> { b : GHC.Types.Bool | bllen bs == 0 ==> b }++assume Data.ByteString.Lazy.Char8.find+    :: (GHC.Types.Char -> GHC.Types.Bool)+    -> bs : Data.ByteString.Lazy.ByteString+    -> Maybe { w8 : GHC.Types.Char | bllen bs /= 0 }++assume Data.ByteString.Lazy.Char8.filter+    :: (GHC.Types.Char -> GHC.Types.Bool)+    -> i : Data.ByteString.Lazy.ByteString+    -> { o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }++assume Data.ByteString.Lazy.Char8.index+    :: bs : Data.ByteString.Lazy.ByteString+    -> { n : Int64 | 0 <= n && n < bllen bs }+    -> GHC.Types.Char++assume Data.ByteString.Lazy.Char8.elemIndex+    :: GHC.Types.Char+    -> bs : Data.ByteString.Lazy.ByteString+    -> Maybe { n : Int64 | 0 <= n && n < bllen bs }++assume Data.ByteString.Lazy.Char8.elemIndices+    :: GHC.Types.Char+    -> bs : Data.ByteString.Lazy.ByteString+    -> [{ n : Int64 | 0 <= n && n < bllen bs }]++assume Data.ByteString.Lazy.Char8.findIndex+    :: (GHC.Types.Char -> GHC.Types.Bool)+    -> bs : Data.ByteString.Lazy.ByteString+    -> Maybe { n : Int64 | 0 <= n && n < bllen bs }++assume Data.ByteString.Lazy.Char8.findIndices+    :: (GHC.Types.Char -> GHC.Types.Bool)+    -> bs : Data.ByteString.Lazy.ByteString+    -> [{ n : Int64 | 0 <= n && n < bllen bs }]++assume Data.ByteString.Lazy.Char8.count+    :: GHC.Types.Char+    -> bs : Data.ByteString.Lazy.ByteString+    -> { n : Int64 | 0 <= n && n < bllen bs }++assume Data.ByteString.Lazy.Char8.zip+    :: l : Data.ByteString.Lazy.ByteString+    -> r : Data.ByteString.Lazy.ByteString+    -> { o : [(GHC.Types.Char, GHC.Types.Char)] | len o <= bllen l && len o <= bllen r }++assume Data.ByteString.Lazy.Char8.zipWith+    :: (GHC.Types.Char -> GHC.Types.Char -> a)+    -> l : Data.ByteString.Lazy.ByteString+    -> r : Data.ByteString.Lazy.ByteString+    -> { o : [a] | len o <= bllen l && len o <= bllen r }++assume Data.ByteString.Lazy.Char8.unzip+    :: i : [(GHC.Types.Char, GHC.Types.Char)]+    -> ( { l : Data.ByteString.Lazy.ByteString | bllen l == len i }+       , { r : Data.ByteString.Lazy.ByteString | bllen r == len i }+       )++assume Data.ByteString.Lazy.Char8.readInt+    :: i : Data.ByteString.Lazy.ByteString+    -> Maybe { p : (Int, { o : Data.ByteString.Lazy.ByteString | bllen o < bllen i}) | bllen i /= 0 }++assume Data.ByteString.Lazy.Char8.readInteger+    :: i : Data.ByteString.Lazy.ByteString+    -> Maybe { p : (Integer, { o : Data.ByteString.Lazy.ByteString | bllen o < bllen i}) | bllen i /= 0 }++@-}
+ src/Data/ByteString/Lazy_LHAssumptions.hs view
@@ -0,0 +1,344 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+module Data.ByteString.Lazy_LHAssumptions where++import Data.ByteString+import Data.ByteString_LHAssumptions()+import Data.ByteString.Lazy+import Data.String_LHAssumptions()+import GHC.Int_LHAssumptions()++{-@+measure bllen :: Data.ByteString.Lazy.ByteString -> { n : GHC.Int.Int64 | 0 <= n }++invariant { bs : Data.ByteString.Lazy.ByteString | 0 <= bllen bs }++invariant { bs : Data.ByteString.Lazy.ByteString | bllen bs == stringlen bs }++assume Data.ByteString.Lazy.empty :: { bs : Data.ByteString.Lazy.ByteString | bllen bs == 0 }++assume Data.ByteString.Lazy.singleton+    :: _ -> { bs : Data.ByteString.Lazy.ByteString | bllen bs == 1 }++assume Data.ByteString.Lazy.pack+    :: w8s : [_]+    -> { bs : _ | bllen bs == len w8s }++assume Data.ByteString.Lazy.unpack+    :: bs : Data.ByteString.Lazy.ByteString+    -> { w8s : [_] | len w8s == bllen bs }++assume Data.ByteString.Lazy.Internal.fromStrict+    :: i : Data.ByteString.ByteString+    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bslen i }++assume Data.ByteString.Lazy.Internal.toStrict+    :: i : Data.ByteString.Lazy.ByteString+    -> { o : Data.ByteString.ByteString | bslen o == bllen i }++assume Data.ByteString.Lazy.fromChunks+    :: i : [Data.ByteString.ByteString]+    -> { o : Data.ByteString.Lazy.ByteString | len i == 0 <=> bllen o == 0 }++assume Data.ByteString.Lazy.toChunks+    :: i : Data.ByteString.Lazy.ByteString+    -> { os : [{ o : Data.ByteString.ByteString | bslen o <= bllen i}] | len os == 0 <=> bllen i == 0 }++assume Data.ByteString.Lazy.cons+    :: _+    -> i : Data.ByteString.Lazy.ByteString+    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i + 1 }++assume Data.ByteString.Lazy.snoc+    :: i : Data.ByteString.Lazy.ByteString+    -> _+    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i + 1 }++assume Data.ByteString.Lazy.append+    :: l : Data.ByteString.Lazy.ByteString+    -> r : Data.ByteString.Lazy.ByteString+    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen l + bllen r }++assume Data.ByteString.Lazy.head+    :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }+    -> _++assume Data.ByteString.Lazy.uncons+    :: i : Data.ByteString.Lazy.ByteString+    -> Maybe (_, { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i - 1 })++assume Data.ByteString.Lazy.unsnoc+    :: i : Data.ByteString.Lazy.ByteString+    -> Maybe ({ o : Data.ByteString.Lazy.ByteString | bllen o == bllen i - 1 }, _)++assume Data.ByteString.Lazy.last :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs } -> _++assume Data.ByteString.Lazy.tail :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs } -> _++assume Data.ByteString.Lazy.init :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs } -> _++assume Data.ByteString.Lazy.null :: bs : Data.ByteString.Lazy.ByteString -> { b : GHC.Types.Bool | b <=> bllen bs == 0 }++assume Data.ByteString.Lazy.length+    :: bs : Data.ByteString.Lazy.ByteString -> { n : GHC.Int.Int64 | bllen bs == n }++assume Data.ByteString.Lazy.map+    :: (_ -> _)+    -> i : Data.ByteString.Lazy.ByteString+    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i }++assume Data.ByteString.Lazy.reverse+    :: i : Data.ByteString.Lazy.ByteString+    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i }++assume Data.ByteString.Lazy.intersperse+    :: _+    -> i : Data.ByteString.Lazy.ByteString+    -> { o : Data.ByteString.Lazy.ByteString | (bllen i == 0 <=> bllen o == 0) && (1 <= bllen i <=> bllen o == 2 * bllen i - 1) }++assume Data.ByteString.Lazy.intercalate+    :: l : Data.ByteString.Lazy.ByteString+    -> rs : [Data.ByteString.Lazy.ByteString]+    -> { o : Data.ByteString.Lazy.ByteString | len rs == 0 ==> bllen o == 0 }++assume Data.ByteString.Lazy.transpose+    :: is : [Data.ByteString.Lazy.ByteString]+    -> { os : [{ bs : Data.ByteString.Lazy.ByteString | bllen bs <= len is }] | len is == 0 ==> len os == 0}++assume Data.ByteString.Lazy.foldl1+    :: (_ -> _ -> _)+    -> { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }+    -> _++assume Data.ByteString.Lazy.foldl1'+    :: (_ -> _ -> _)+    -> { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }+    -> _++assume Data.ByteString.Lazy.foldr1+    :: (_ -> _ -> _)+    -> { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }+    -> _++assume Data.ByteString.Lazy.concat+    :: is : [Data.ByteString.Lazy.ByteString]+    -> { o : Data.ByteString.Lazy.ByteString | (len is == 0) ==> (bllen o == 0) }++assume Data.ByteString.Lazy.concatMap+    :: (_ -> Data.ByteString.Lazy.ByteString)+    -> i : Data.ByteString.Lazy.ByteString+    -> { o : Data.ByteString.Lazy.ByteString | bllen i == 0 ==> bllen o == 0 }++assume Data.ByteString.Lazy.any :: (_ -> GHC.Types.Bool)+    -> bs : Data.ByteString.Lazy.ByteString+    -> { b : GHC.Types.Bool | bllen bs == 0 ==> not b }++assume Data.ByteString.Lazy.all :: (_ -> GHC.Types.Bool)+    -> bs : Data.ByteString.Lazy.ByteString+    -> { b : GHC.Types.Bool | bllen bs == 0 ==> b }++assume Data.ByteString.Lazy.maximum :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs } -> _++assume Data.ByteString.Lazy.minimum :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs } -> _++assume Data.ByteString.Lazy.scanl+    :: (_ -> _ -> _)+    -> _+    -> i : Data.ByteString.Lazy.ByteString+    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i }++assume Data.ByteString.Lazy.mapAccumL+    :: (acc -> _ -> (acc, _))+    -> acc+    -> i : Data.ByteString.Lazy.ByteString+    -> (acc, { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i })++assume Data.ByteString.Lazy.mapAccumR+    :: (acc -> _ -> (acc, _))+    -> acc+    -> i : Data.ByteString.Lazy.ByteString+    -> (acc, { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i })++assume Data.ByteString.Lazy.replicate+    :: n : GHC.Int.Int64+    -> _+    -> { bs : Data.ByteString.Lazy.ByteString | bllen bs == n }++assume Data.ByteString.Lazy.take+    :: n : GHC.Int.Int64+    -> i : Data.ByteString.Lazy.ByteString+    -> { o : Data.ByteString.Lazy.ByteString | (n <= 0 ==> bllen o == 0) &&+                                               ((0 <= n && n <= bllen i) <=> bllen o == n) &&+                                               (bllen i <= n <=> bllen o = bllen i) }++assume Data.ByteString.Lazy.drop+    :: n : GHC.Int.Int64+    -> i : Data.ByteString.Lazy.ByteString+    -> { o : Data.ByteString.Lazy.ByteString | (n <= 0 <=> bllen o == bllen i) &&+                                               ((0 <= n && n <= bllen i) <=> bllen o == bllen i - n) &&+                                               (bllen i <= n <=> bllen o == 0) }++assume Data.ByteString.Lazy.splitAt+    :: n : GHC.Int.Int64+    -> i : Data.ByteString.Lazy.ByteString+    -> ( { l : Data.ByteString.Lazy.ByteString | (n <= 0 <=> bllen l == 0) &&+                                                 ((0 <= n && n <= bllen i) <=> bllen l == n) &&+                                                 (bllen i <= n <=> bllen l == bllen i) }+       , { r : Data.ByteString.Lazy.ByteString | (n <= 0 <=> bllen r == bllen i) &&+                                                 ((0 <= n && n <= bllen i) <=> bllen r == bllen i - n) &&+                                                 (bllen i <= n <=> bllen r == 0) }+       )++assume Data.ByteString.Lazy.takeWhile+    :: (_ -> GHC.Types.Bool)+    -> i : Data.ByteString.Lazy.ByteString+    -> { o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }++assume Data.ByteString.Lazy.dropWhile+    :: (_ -> GHC.Types.Bool)+    -> i : Data.ByteString.Lazy.ByteString+    -> { o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }++assume Data.ByteString.Lazy.span+    :: (_ -> GHC.Types.Bool)+    -> i : Data.ByteString.Lazy.ByteString+    -> ( { l : Data.ByteString.Lazy.ByteString | bllen l <= bllen i }+       , { r : Data.ByteString.Lazy.ByteString | bllen r <= bllen i }+       )++assume Data.ByteString.Lazy.break+    :: (_ -> GHC.Types.Bool)+    -> i : Data.ByteString.Lazy.ByteString+    -> ( { l : Data.ByteString.Lazy.ByteString | bllen l <= bllen i }+       , { r : Data.ByteString.Lazy.ByteString | bllen r <= bllen i }+       )++assume Data.ByteString.Lazy.group+    :: i : Data.ByteString.Lazy.ByteString+    -> [{ o : Data.ByteString.Lazy.ByteString | 1 <= bllen o && bllen o <= bllen i }]++assume Data.ByteString.Lazy.groupBy+    :: (_ -> _ -> GHC.Types.Bool)+    -> i : Data.ByteString.Lazy.ByteString+    -> [{ o : Data.ByteString.Lazy.ByteString | 1 <= bllen o && bllen o <= bllen i }]++assume Data.ByteString.Lazy.inits+    :: i : Data.ByteString.Lazy.ByteString+    -> [{ o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }]++assume Data.ByteString.Lazy.tails+    :: i : Data.ByteString.Lazy.ByteString+    -> [{ o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }]++assume Data.ByteString.Lazy.split+    :: _+    -> i : Data.ByteString.Lazy.ByteString+    -> [{ o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }]++assume Data.ByteString.Lazy.splitWith+    :: (_ -> GHC.Types.Bool)+    -> i : Data.ByteString.Lazy.ByteString+    -> [{ o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }]++assume Data.ByteString.Lazy.isPrefixOf+    :: l : Data.ByteString.Lazy.ByteString+    -> r : Data.ByteString.Lazy.ByteString+    -> { b : GHC.Types.Bool | bllen l >= bllen r ==> not b }++assume Data.ByteString.Lazy.isSuffixOf+    :: l : Data.ByteString.Lazy.ByteString+    -> r : Data.ByteString.Lazy.ByteString+    -> { b : GHC.Types.Bool | bllen l >= bllen r ==> not b }++assume Data.ByteString.Lazy.elem+    :: _+    -> bs : Data.ByteString.Lazy.ByteString+    -> { b : GHC.Types.Bool | (bllen bs == 0) ==> not b }++assume Data.ByteString.Lazy.notElem+    :: _+    -> bs : Data.ByteString.Lazy.ByteString+    -> { b : GHC.Types.Bool | (bllen bs == 0) ==> b }++assume Data.ByteString.Lazy.find+    :: (_ -> GHC.Types.Bool)+    -> bs : Data.ByteString.Lazy.ByteString+    -> Maybe { w8 : _ | bllen bs /= 0 }++assume Data.ByteString.Lazy.filter+    :: (_ -> GHC.Types.Bool)+    -> i : Data.ByteString.Lazy.ByteString+    -> { o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }++assume Data.ByteString.Lazy.partition+    :: (_ -> GHC.Types.Bool)+    -> i : Data.ByteString.Lazy.ByteString+    -> ( { l : Data.ByteString.Lazy.ByteString | bllen l <= bllen i }+       , { r : Data.ByteString.Lazy.ByteString | bllen r <= bllen i }+       )++assume Data.ByteString.Lazy.index+    :: bs : Data.ByteString.Lazy.ByteString+    -> { n : GHC.Int.Int64 | 0 <= n && n < bllen bs }+    -> _++assume Data.ByteString.Lazy.elemIndex+    :: _+    -> bs : Data.ByteString.Lazy.ByteString+    -> Maybe { n : GHC.Int.Int64 | 0 <= n && n < bllen bs }++assume Data.ByteString.Lazy.elemIndices+    :: _+    -> bs : Data.ByteString.Lazy.ByteString+    -> [{ n : GHC.Int.Int64 | 0 <= n && n < bllen bs }]++assume Data.ByteString.Lazy.elemIndexEnd+    :: _+    -> bs : Data.ByteString.Lazy.ByteString+    -> Maybe { n : GHC.Int.Int64 | 0 <= n && n < bllen bs }++assume Data.ByteString.Lazy.findIndex+    :: (_ -> GHC.Types.Bool)+    -> bs : Data.ByteString.Lazy.ByteString+    -> Maybe { n : GHC.Int.Int64 | 0 <= n && n < bllen bs }++assume Data.ByteString.Lazy.findIndices+    :: (_ -> GHC.Types.Bool)+    -> bs : Data.ByteString.Lazy.ByteString+    -> [{ n : GHC.Int.Int64 | 0 <= n && n < bllen bs }]++assume Data.ByteString.Lazy.count+    :: _+    -> bs : Data.ByteString.Lazy.ByteString+    -> { n : GHC.Int.Int64 | 0 <= n && n < bllen bs }++assume Data.ByteString.Lazy.zip+    :: l : Data.ByteString.Lazy.ByteString+    -> r : Data.ByteString.Lazy.ByteString+    -> { o : [(_, _)] | len o <= bllen l && len o <= bllen r }++assume Data.ByteString.Lazy.zipWith+    :: (_ -> _ -> a)+    -> l : Data.ByteString.Lazy.ByteString+    -> r : Data.ByteString.Lazy.ByteString+    -> { o : [a] | len o <= bllen l && len o <= bllen r }++assume Data.ByteString.Lazy.unzip+    :: i : [(_, _)]+    -> ( { l : Data.ByteString.Lazy.ByteString | bllen l == len i }+       , { r : Data.ByteString.Lazy.ByteString | bllen r == len i }+       )++assume Data.ByteString.Lazy.copy+    :: i : Data.ByteString.Lazy.ByteString+    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i }++assume Data.ByteString.Lazy.hGet+    :: _+    -> n : { n : Int | 0 <= n }+    -> IO { bs : Data.ByteString.Lazy.ByteString | bllen bs == n || bllen bs == 0 }++assume Data.ByteString.Lazy.hGetNonBlocking+    :: _+    -> n : { n : Int | 0 <= n }+    -> IO { bs : Data.ByteString.Lazy.ByteString | bllen bs <= n }+@-}
+ src/Data/ByteString/Short_LHAssumptions.hs view
@@ -0,0 +1,31 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+module Data.ByteString.Short_LHAssumptions where++import Data.ByteString+import Data.ByteString_LHAssumptions()+import Data.ByteString.Short+import Data.String_LHAssumptions()++{-@+measure sbslen :: Data.ByteString.Short.ShortByteString -> { n : Int | 0 <= n }++invariant { bs : Data.ByteString.Short.ShortByteString  | 0 <= sbslen bs }++invariant { bs : Data.ByteString.Short.ShortByteString | sbslen bs == stringlen bs }++assume Data.ByteString.Short.Internal.toShort :: i : Data.ByteString.ByteString -> { o : Data.ByteString.Short.ShortByteString | sbslen o == bslen i }++assume Data.ByteString.Short.Internal.fromShort :: o : Data.ByteString.Short.ShortByteString -> { i : Data.ByteString.ByteString | bslen i == sbslen o }++assume Data.ByteString.Short.Internal.pack :: w8s : [Word8] -> { bs : Data.ByteString.Short.ShortByteString | sbslen bs == len w8s }++assume Data.ByteString.Short.Internal.unpack :: bs : Data.ByteString.Short.ShortByteString -> { w8s : [Word8] | len w8s == sbslen bs }++assume Data.ByteString.Short.Internal.empty :: { bs : Data.ByteString.Short.ShortByteString | sbslen bs == 0 }++assume Data.ByteString.Short.Internal.null :: bs : Data.ByteString.Short.ShortByteString -> { b : GHC.Types.Bool | b <=> sbslen bs == 0 }++assume Data.ByteString.Short.Internal.length :: bs : Data.ByteString.Short.ShortByteString -> { n : Int | sbslen bs == n }++assume Data.ByteString.Short.Internal.index :: bs : Data.ByteString.Short.ShortByteString -> { n : Int | 0 <= n && n < sbslen bs } -> Word8+@-}
+ src/Data/ByteString/Unsafe_LHAssumptions.hs view
@@ -0,0 +1,36 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+module Data.ByteString.Unsafe_LHAssumptions where++import Data.ByteString.Unsafe+import Data.ByteString_LHAssumptions()+import GHC.Types_LHAssumptions()++{-@+assume Data.ByteString.Unsafe.unsafeHead+    :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> _++assume Data.ByteString.Unsafe.unsafeTail+    :: bs : { v : Data.ByteString.ByteString | bslen v > 0 }+    -> { v : Data.ByteString.ByteString | bslen v = bslen bs - 1 }++assume Data.ByteString.Unsafe.unsafeInit+    :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> _++assume Data.ByteString.Unsafe.unsafeLast+    :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> _++assume Data.ByteString.Unsafe.unsafeIndex+    :: bs : Data.ByteString.ByteString+    -> { n : Int | 0 <= n && n < bslen bs }+    -> _++assume Data.ByteString.Unsafe.unsafeTake+    :: n : { n : Int | 0 <= n }+    -> i : { i : Data.ByteString.ByteString | n <= bslen i }+    -> { o : Data.ByteString.ByteString | bslen o == n }++assume Data.ByteString.Unsafe.unsafeDrop+    :: n : { n : Int | 0 <= n }+    -> i : { i : Data.ByteString.ByteString | n <= bslen i }+    -> { o : Data.ByteString.ByteString | bslen o == bslen i - n }+@-}
+ src/Data/ByteString_LHAssumptions.hs view
@@ -0,0 +1,379 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+module Data.ByteString_LHAssumptions where++import Data.ByteString+import Data.String_LHAssumptions()+import GHC.Word++{-@+measure bslen :: Data.ByteString.ByteString -> { n : Int | 0 <= n }++invariant { bs : Data.ByteString.ByteString  | 0 <= bslen bs }++invariant { bs : Data.ByteString.ByteString | bslen bs == stringlen bs }++assume Data.ByteString.Internal.empty :: { bs : Data.ByteString.ByteString | bslen bs == 0 }++assume Data.ByteString.singleton :: _ -> { bs : Data.ByteString.ByteString | bslen bs == 1 }++assume Data.ByteString.pack :: w8s : [_]+     -> { bs : Data.ByteString.ByteString | bslen bs == len w8s }++assume Data.ByteString.unpack :: bs : Data.ByteString.ByteString+       -> { w8s : [_] | len w8s == bslen bs }++assume Data.ByteString.cons :: _+     -> i : Data.ByteString.ByteString+     -> { o : Data.ByteString.ByteString | bslen o == bslen i + 1 }++assume Data.ByteString.snoc :: i : Data.ByteString.ByteString+     -> _+     -> { o : Data.ByteString.ByteString | bslen o == bslen i + 1 }++assume Data.ByteString.append :: l : Data.ByteString.ByteString+       -> r : Data.ByteString.ByteString+       -> { o : Data.ByteString.ByteString | bslen o == bslen l + bslen r }++assume Data.ByteString.head :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> _++assume Data.ByteString.unsnoc :: i:Data.ByteString.ByteString+       -> (Maybe ({ o : Data.ByteString.ByteString | bslen o == bslen i - 1 }, _))++assume Data.ByteString.last :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> _++assume Data.ByteString.tail :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> _++assume Data.ByteString.init+  :: {i:Data.ByteString.ByteString | 1 <= bslen i }+  -> {o:Data.ByteString.ByteString | bslen o == bslen i - 1 }++assume Data.ByteString.null+  :: bs : Data.ByteString.ByteString+  -> { b : GHC.Types.Bool | b <=> bslen bs == 0 }++assume Data.ByteString.length :: bs : Data.ByteString.ByteString -> { n : Int | bslen bs == n }++assume Data.ByteString.map+  :: (_ -> _)+  -> i : Data.ByteString.ByteString+  -> { o : Data.ByteString.ByteString | bslen o == bslen i }++assume Data.ByteString.reverse+  :: i : Data.ByteString.ByteString+  -> { o : Data.ByteString.ByteString | bslen o == bslen i }++assume Data.ByteString.intersperse+  :: _+  -> i : Data.ByteString.ByteString+  -> { o : Data.ByteString.ByteString | (bslen i == 0 <=> bslen o == 0) && (1 <= bslen i <=> bslen o == 2 * bslen i - 1) }++assume Data.ByteString.intercalate+  :: l : Data.ByteString.ByteString+  -> rs : [Data.ByteString.ByteString]+  -> { o : Data.ByteString.ByteString | len rs == 0 ==> bslen o == 0 }++assume Data.ByteString.transpose+  :: is : [Data.ByteString.ByteString]+  -> { os : [{ bs : Data.ByteString.ByteString | bslen bs <= len is }] | len is == 0 ==> len os == 0}++assume Data.ByteString.foldl1+  :: (_ -> _ -> _)+  -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }+  -> _++assume Data.ByteString.foldl1'+  :: (_ -> _ -> _)+  -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }+  -> _++assume Data.ByteString.foldr1+  :: (_ -> _ -> _)+  -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }+  -> _++assume Data.ByteString.foldr1'+  :: (_ -> _ -> _)+  -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }+  -> _++assume Data.ByteString.concat+  :: is : [Data.ByteString.ByteString]+  -> { o : Data.ByteString.ByteString | (len is == 0) ==> (bslen o == 0) }++assume Data.ByteString.concatMap+  :: (_ -> Data.ByteString.ByteString)+  -> i : Data.ByteString.ByteString+  -> { o : Data.ByteString.ByteString | bslen i == 0 ==> bslen o == 0 }++assume Data.ByteString.any+  :: (_ -> GHC.Types.Bool)+  -> bs : Data.ByteString.ByteString+  -> { b : GHC.Types.Bool | bslen bs == 0 ==> not b }++assume Data.ByteString.all+  :: (_ -> GHC.Types.Bool)+  -> bs : Data.ByteString.ByteString+  -> { b : GHC.Types.Bool | bslen bs == 0 ==> b }++assume Data.ByteString.maximum :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> _++assume Data.ByteString.minimum :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> _++assume Data.ByteString.scanl :: (_ -> _ -> _)+      -> _+      -> i : Data.ByteString.ByteString+      -> { o : Data.ByteString.ByteString | bslen o == bslen i }++assume Data.ByteString.scanl1 :: (_ -> _ -> _)+       -> i : { i : Data.ByteString.ByteString | 1 <= bslen i }+       -> { o : Data.ByteString.ByteString | bslen o == bslen i }++assume Data.ByteString.scanr+    :: (_ -> _ -> _)+    -> _+    -> i : Data.ByteString.ByteString+    -> { o : Data.ByteString.ByteString | bslen o == bslen i }++assume Data.ByteString.scanr1+    :: (_ -> _ -> _)+    -> i : { i : Data.ByteString.ByteString | 1 <= bslen i }+    -> { o : Data.ByteString.ByteString | bslen o == bslen i }++assume Data.ByteString.mapAccumL+    :: (acc -> _ -> (acc, _))+    -> acc+    -> i : Data.ByteString.ByteString+    -> (acc, { o : Data.ByteString.ByteString | bslen o == bslen i })++assume Data.ByteString.mapAccumR+    :: (acc -> _ -> (acc, _))+    -> acc+    -> i : Data.ByteString.ByteString+    -> (acc, { o : Data.ByteString.ByteString | bslen o == bslen i })++assume Data.ByteString.replicate+    :: n : Int+    -> _+    -> { bs : Data.ByteString.ByteString | bslen bs == n }++assume Data.ByteString.unfoldrN+    :: n : Int+    -> (a -> Maybe (_, a))+    -> a+    -> ({ bs : Data.ByteString.ByteString | bslen bs <= n }, Maybe a)++assume Data.ByteString.take+    :: n : Int+    -> i : Data.ByteString.ByteString+    -> { o : Data.ByteString.ByteString | (n <= 0 <=> bslen o == 0) &&+                                          ((0 <= n && n <= bslen i) <=> bslen o == n) &&+                                          (bslen i <= n <=> bslen o = bslen i) }++assume Data.ByteString.drop+    :: n : Int+    -> i : Data.ByteString.ByteString+    -> { o : Data.ByteString.ByteString | (n <= 0 <=> bslen o == bslen i) &&+                                          ((0 <= n && n <= bslen i) <=> bslen o == bslen i - n) &&+                                          (bslen i <= n <=> bslen o == 0) }++assume Data.ByteString.splitAt+    :: n : Int+    -> i : Data.ByteString.ByteString+    -> ( { l : Data.ByteString.ByteString | (n <= 0 <=> bslen l == 0) &&+                                            ((0 <= n && n <= bslen i) <=> bslen l == n) &&+                                            (bslen i <= n <=> bslen l == bslen i) }+       , { r : Data.ByteString.ByteString | (n <= 0 <=> bslen r == bslen i) &&+                                            ((0 <= n && n <= bslen i) <=> bslen r == bslen i - n) &&+                                            (bslen i <= n <=> bslen r == 0) }+       )++assume Data.ByteString.takeWhile+    :: (_ -> GHC.Types.Bool)+    -> i : Data.ByteString.ByteString+    -> { o : Data.ByteString.ByteString | bslen o <= bslen i }++assume Data.ByteString.dropWhile+    :: (_ -> GHC.Types.Bool)+    -> i : Data.ByteString.ByteString+    -> { o : Data.ByteString.ByteString | bslen o <= bslen i }++assume Data.ByteString.span+    :: (_ -> GHC.Types.Bool)+    -> i : Data.ByteString.ByteString+    -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }+       , { r : Data.ByteString.ByteString | bslen r <= bslen i }+       )++assume Data.ByteString.spanEnd+    :: (_ -> GHC.Types.Bool)+    -> i : Data.ByteString.ByteString+    -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }+       , { r : Data.ByteString.ByteString | bslen r <= bslen i }+       )++assume Data.ByteString.break+    :: (_ -> GHC.Types.Bool)+    -> i : Data.ByteString.ByteString+    -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }+       , { r : Data.ByteString.ByteString | bslen r <= bslen i }+       )++assume Data.ByteString.breakEnd+    :: (_ -> GHC.Types.Bool)+    -> i : Data.ByteString.ByteString+    -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }+       , { r : Data.ByteString.ByteString | bslen r <= bslen i }+       )++assume Data.ByteString.group+    :: i : Data.ByteString.ByteString+    -> [{ o : Data.ByteString.ByteString | 1 <= bslen o && bslen o <= bslen i }]++assume Data.ByteString.groupBy+    :: (_ -> _ -> GHC.Types.Bool)+    -> i : Data.ByteString.ByteString+    -> [{ o : Data.ByteString.ByteString | 1 <= bslen o && bslen o <= bslen i }]++assume Data.ByteString.inits+    :: i : Data.ByteString.ByteString+    -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]++assume Data.ByteString.tails+    :: i : Data.ByteString.ByteString+    -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]++assume Data.ByteString.split+    :: _+    -> i : Data.ByteString.ByteString+    -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]++assume Data.ByteString.splitWith+    :: (_ -> GHC.Types.Bool)+    -> i : Data.ByteString.ByteString+    -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]++assume Data.ByteString.isPrefixOf+    :: l : Data.ByteString.ByteString+    -> r : Data.ByteString.ByteString+    -> { b : GHC.Types.Bool | bslen l >= bslen r ==> not b }++assume Data.ByteString.isSuffixOf+    :: l : Data.ByteString.ByteString+    -> r : Data.ByteString.ByteString+    -> { b : GHC.Types.Bool | bslen l > bslen r ==> not b }++assume Data.ByteString.isInfixOf+    :: l : Data.ByteString.ByteString+    -> r : Data.ByteString.ByteString+    -> { b : GHC.Types.Bool | bslen l > bslen r ==> not b }++assume Data.ByteString.breakSubstring+    :: il : Data.ByteString.ByteString+    -> ir : Data.ByteString.ByteString+    -> ( { ol : Data.ByteString.ByteString | bslen ol <= bslen ir && (bslen il > bslen ir ==> bslen ol == bslen ir)}+       , { or : Data.ByteString.ByteString | bslen or <= bslen ir && (bslen il > bslen ir ==> bslen or == 0) }+       )++assume Data.ByteString.elem+    :: _+    -> bs : Data.ByteString.ByteString+    -> { b : GHC.Types.Bool | bslen bs == 0 ==> not b }++assume Data.ByteString.notElem+    :: _+    -> bs : Data.ByteString.ByteString+    -> { b : GHC.Types.Bool | bslen bs == 0 ==> b }++assume Data.ByteString.find+    :: (_ -> GHC.Types.Bool)+    -> bs : Data.ByteString.ByteString+    -> (Maybe { w8 : _ | bslen bs /= 0 })++assume Data.ByteString.filter+    :: (_ -> GHC.Types.Bool)+    -> i : Data.ByteString.ByteString+    -> { o : Data.ByteString.ByteString | bslen o <= bslen i }++assume Data.ByteString.partition+    :: (Word8 -> GHC.Types.Bool)+    -> i : Data.ByteString.ByteString+    -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }+       , { r : Data.ByteString.ByteString | bslen r <= bslen i }+       )++assume Data.ByteString.index :: bs : Data.ByteString.ByteString -> { n : Int | 0 <= n && n < bslen bs } -> _++assume Data.ByteString.elemIndex+    :: _+    -> bs : Data.ByteString.ByteString+    -> (Maybe { n : Int | 0 <= n && n < bslen bs })++assume Data.ByteString.elemIndices+    :: _+    -> bs : Data.ByteString.ByteString+    -> [{ n : Int | 0 <= n && n < bslen bs }]++assume Data.ByteString.elemIndexEnd+    :: _+    -> bs : Data.ByteString.ByteString+    -> (Maybe { n : Int | 0 <= n && n < bslen bs })++assume Data.ByteString.findIndex+    :: (_ -> GHC.Types.Bool)+    -> bs : Data.ByteString.ByteString+    -> (Maybe { n : Int | 0 <= n && n < bslen bs })++assume Data.ByteString.findIndices+    :: (_ -> GHC.Types.Bool)+    -> bs : Data.ByteString.ByteString+    -> [{ n : Int | 0 <= n && n < bslen bs }]++assume Data.ByteString.count+    :: _+    -> bs : Data.ByteString.ByteString+    -> { n : Int | 0 <= n && n < bslen bs }++assume Data.ByteString.zip+    :: l : Data.ByteString.ByteString+    -> r : Data.ByteString.ByteString+    -> { o : [(_, _)] | len o <= bslen l && len o <= bslen r }++assume Data.ByteString.zipWith+    :: (_ -> _ -> a)+    -> l : Data.ByteString.ByteString+    -> r : Data.ByteString.ByteString+    -> { o : [a] | len o <= bslen l && len o <= bslen r }++assume Data.ByteString.unzip+    :: i : [(_, _)]+    -> ( { l : Data.ByteString.ByteString | bslen l == len i }+       , { r : Data.ByteString.ByteString | bslen r == len i }+       )++assume Data.ByteString.sort+    :: i : Data.ByteString.ByteString+    -> { o : Data.ByteString.ByteString | bslen o == bslen i }++assume Data.ByteString.copy+    :: i : Data.ByteString.ByteString+    -> { o : Data.ByteString.ByteString | bslen o == bslen i }++assume Data.ByteString.hGet+    :: _+    -> n : { n : Int | 0 <= n }+    -> (IO { bs : Data.ByteString.ByteString | bslen bs == n || bslen bs == 0 })++assume Data.ByteString.hGetSome+    :: _+    -> n : { n : Int | 0 <= n }+    -> (IO { bs : Data.ByteString.ByteString | bslen bs <= n })++assume Data.ByteString.hGetNonBlocking+    :: _+    -> n : { n : Int | 0 <= n }+    -> (IO { bs : Data.ByteString.ByteString | bslen bs <= n })++assume Data.ByteString.uncons+    :: i : Data.ByteString.ByteString+    -> (Maybe (_, { o : Data.ByteString.ByteString | bslen o == bslen i - 1 }))+@-}
+ src/Data/Either_LHAssumptions.hs view
@@ -0,0 +1,9 @@+module Data.Either_LHAssumptions where++import GHC.Types_LHAssumptions()++{-@+measure isLeft :: Data.Either.Either a b -> Bool+  isLeft (Left x)  = true+  isLeft (Right x) = false+@-}
+ src/Data/Foldable_LHAssumptions.hs view
@@ -0,0 +1,8 @@+module Data.Foldable_LHAssumptions where++import GHC.Types_LHAssumptions()++{-@+assume Data.Foldable.length :: Data.Foldable.Foldable f => forall a. xs:f a -> {v:Nat | v = len xs}+assume Data.Foldable.null   :: Data.Foldable.Foldable f => forall a. v:(f a) -> {b:Bool | (b <=> len v = 0) && (not b <=> len v > 0)}+@-}
+ src/Data/Int_LHAssumptions.hs view
@@ -0,0 +1,9 @@+module Data.Int_LHAssumptions where++{-@+embed Data.Int.Int8  as int+embed Data.Int.Int16 as int+embed Data.Int.Int32 as int+embed Data.Int.Int64 as int++@-}
+ src/Data/Maybe_LHAssumptions.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+module Data.Maybe_LHAssumptions where++import GHC.Types_LHAssumptions()+import Data.Maybe++{-@+assume Data.Maybe.maybe :: v:b -> (a -> b) -> u:(GHC.Maybe.Maybe a) -> {w:b | not (isJust u) => w == v}+assume Data.Maybe.isNothing :: v:(GHC.Maybe.Maybe a) -> {b:Bool | not (isJust v) == b}+assume Data.Maybe.fromMaybe :: v:a -> u:(GHC.Maybe.Maybe a) -> {x:a | not (isJust u) => x == v}++assume Data.Maybe.isJust :: v:(GHC.Maybe.Maybe a) -> {b:Bool | b == isJust v}+measure isJust :: GHC.Maybe.Maybe a -> Bool+  isJust (GHC.Maybe.Just x)  = true+  isJust (GHC.Maybe.Nothing) = false++assume Data.Maybe.fromJust :: {v:(GHC.Maybe.Maybe a) | isJust v} -> a+measure fromJust :: GHC.Maybe.Maybe a -> a+  fromJust (GHC.Maybe.Just x) = x+@-}
+ src/Data/Set_LHAssumptions.hs view
@@ -0,0 +1,68 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+module Data.Set_LHAssumptions where++import Data.Set+import GHC.Types_LHAssumptions()++{-@++embed Data.Set.Internal.Set as Set_Set++//  ----------------------------------------------------------------------------------------------+//  -- | Logical Set Operators: Interpreted "natively" by the SMT solver -------------------------+//  ----------------------------------------------------------------------------------------------+++//  union+measure Set_cup  :: (Data.Set.Internal.Set a) -> (Data.Set.Internal.Set a) -> (Data.Set.Internal.Set a)++//  intersection+measure Set_cap  :: (Data.Set.Internal.Set a) -> (Data.Set.Internal.Set a) -> (Data.Set.Internal.Set a)++//  difference+measure Set_dif   :: (Data.Set.Internal.Set a) -> (Data.Set.Internal.Set a) -> (Data.Set.Internal.Set a)++//  singleton+measure Set_sng   :: a -> (Data.Set.Internal.Set a)++//  emptiness test+measure Set_emp   :: (Data.Set.Internal.Set a) -> GHC.Types.Bool++//  empty set+measure Set_empty :: forall a. GHC.Types.Int -> (Data.Set.Internal.Set a)++//  membership test+measure Set_mem  :: a -> (Data.Set.Internal.Set a) -> GHC.Types.Bool++//  inclusion test+measure Set_sub  :: (Data.Set.Internal.Set a) -> (Data.Set.Internal.Set a) -> GHC.Types.Bool++//  ---------------------------------------------------------------------------------------------+//  -- | Refined Types for Data.Set Operations --------------------------------------------------+//  ---------------------------------------------------------------------------------------------++assume Data.Set.Internal.isSubsetOf    :: (GHC.Classes.Ord a) => x:(Data.Set.Internal.Set a) -> y:(Data.Set.Internal.Set a) -> {v:GHC.Types.Bool | v <=> Set_sub x y}+assume Data.Set.Internal.member        :: (GHC.Classes.Ord a) => x:a -> xs:(Data.Set.Internal.Set a) -> {v:GHC.Types.Bool | v <=> Set_mem x xs}+assume Data.Set.Internal.null          :: (GHC.Classes.Ord a) => xs:(Data.Set.Internal.Set a) -> {v:GHC.Types.Bool | v <=> Set_emp xs}++assume Data.Set.Internal.empty         :: {v:(Data.Set.Internal.Set a) | Set_emp v}+assume Data.Set.Internal.singleton     :: x:a -> {v:(Data.Set.Internal.Set a) | v = (Set_sng x)}+assume Data.Set.Internal.insert        :: (GHC.Classes.Ord a) => x:a -> xs:(Data.Set.Internal.Set a) -> {v:(Data.Set.Internal.Set a) | v = Set_cup xs (Set_sng x)}+assume Data.Set.Internal.delete        :: (GHC.Classes.Ord a) => x:a -> xs:(Data.Set.Internal.Set a) -> {v:(Data.Set.Internal.Set a) | v = Set_dif xs (Set_sng x)}++assume Data.Set.Internal.union         :: GHC.Classes.Ord a => xs:(Data.Set.Internal.Set a) -> ys:(Data.Set.Internal.Set a) -> {v:(Data.Set.Internal.Set a) | v = Set_cup xs ys}+assume Data.Set.Internal.intersection  :: GHC.Classes.Ord a => xs:(Data.Set.Internal.Set a) -> ys:(Data.Set.Internal.Set a) -> {v:(Data.Set.Internal.Set a) | v = Set_cap xs ys}+assume Data.Set.Internal.difference    :: GHC.Classes.Ord a => xs:(Data.Set.Internal.Set a) -> ys:(Data.Set.Internal.Set a) -> {v:(Data.Set.Internal.Set a) | v = Set_dif xs ys}++assume Data.Set.Internal.fromList :: GHC.Classes.Ord a => xs:[a] -> {v:Data.Set.Internal.Set a | v = listElts xs}+assume Data.Set.Internal.toList   :: GHC.Classes.Ord a => s:Data.Set.Internal.Set a -> {xs:[a] | s = listElts xs}++//  ---------------------------------------------------------------------------------------------+//  -- | The set of elements in a list ----------------------------------------------------------+//  ---------------------------------------------------------------------------------------------++measure listElts :: [a] -> (Data.Set.Internal.Set a)+  listElts []     = {v | (Set_emp v)}+  listElts (x:xs) = {v | v = Set_cup (Set_sng x) (listElts xs) }++@-}
+ src/Data/String_LHAssumptions.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+module Data.String_LHAssumptions where++import Data.String+import GHC.Types_LHAssumptions()++{-@+measure stringlen :: a -> GHC.Types.Int++assume Data.String.fromString+    ::  forall a. Data.String.IsString a+    =>  i : [GHC.Types.Char]+    ->  { o : a | i ~~ o && len i == stringlen o }+@-}
+ src/Data/Tuple_LHAssumptions.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+module Data.Tuple_LHAssumptions where++import Data.Tuple++{-@+assume Data.Tuple.fst :: {f:(x:(a,b) -> {v:a | v = (fst x)}) | f == fst }+assume Data.Tuple.snd :: {f:(x:(a,b) -> {v:b | v = (snd x)}) | f == snd }++measure fst :: (a, b) -> a+  fst (a, b) = a++measure snd :: (a, b) -> b+  snd (a, b) = b++qualif Fst(__v:a, __y:b): (__v = (fst __y))+qualif Snd(__v:a, __y:b): (__v = (snd __y))+@-}
+ src/Data/Word_LHAssumptions.hs view
@@ -0,0 +1,12 @@+module Data.Word_LHAssumptions where++{-@+embed GHC.Word.Word   as int+embed GHC.Word.Word8  as int+embed GHC.Word.Word16 as int+embed GHC.Word.Word32 as int+embed GHC.Word.Word64 as int++invariant {v : GHC.Word.Word32 | 0 <= v }+invariant {v : GHC.Word.Word16 | 0 <= v }+@-}
+ src/Foreign/C/String_LHAssumptions.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+module Foreign.C.String_LHAssumptions where++import Foreign.C.Types+import Foreign.Ptr_LHAssumptions()+import GHC.Ptr+import GHC.Types_LHAssumptions()++{-@+type CStringLen    = ((GHC.Ptr.Ptr Foreign.C.Types.CChar), Nat)<{\p v -> (v <= (plen p))}>+type CStringLenN N = ((GHC.Ptr.Ptr Foreign.C.Types.CChar), {v:Nat | v = N})<{\p v -> (v <= (plen p))}>++// measure cStringLen :: Foreign.C.String.CStringLen -> GHC.Types.Int+measure cStringLen :: ((GHC.Ptr.Ptr Foreign.C.Types.CChar), GHC.Types.Int) -> GHC.Types.Int++// measure cStringLen :: ((GHC.Ptr.Ptr Foreign.C.Types.CChar), GHC.Types.Int) -> GHC.Types.Int +// cStringLen (c, n) = n+@-}
+ src/Foreign/C/Types_LHAssumptions.hs view
@@ -0,0 +1,11 @@+module Foreign.C.Types_LHAssumptions where++import GHC.Int_LHAssumptions()++{-@++embed Foreign.C.Types.CInt   as int+embed Foreign.C.Types.CSize  as int+embed Foreign.C.Types.CULong as int++@-}
+ src/Foreign/Concurrent_LHAssumptions.hs view
@@ -0,0 +1,9 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+module Foreign.Concurrent_LHAssumptions where++import Foreign.Concurrent+import GHC.ForeignPtr_LHAssumptions()++{-@+assume Foreign.Concurrent.newForeignPtr  :: p:(PtrV a) -> GHC.Types.IO () -> (GHC.Types.IO (ForeignPtrN a (plen p)))+@-}
+ src/Foreign/ForeignPtr_LHAssumptions.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+module Foreign.ForeignPtr_LHAssumptions where++import Foreign.Concurrent_LHAssumptions()+import Foreign.ForeignPtr+import GHC.ForeignPtr_LHAssumptions()++{-@++assume GHC.ForeignPtr.withForeignPtr :: forall a b. fp:(GHC.ForeignPtr.ForeignPtr a)+  -> ((PtrN a (fplen fp)) -> GHC.Types.IO b)+  -> (GHC.Types.IO b)++assume Foreign.ForeignPtr.Imp.newForeignPtr ::  _ -> p:(PtrV a) -> (GHC.Types.IO (ForeignPtrN a (plen p)))+++//  this uses `sizeOf (undefined :: a)`, so the ForeignPtr does not necessarily have length `n`+//  Foreign.ForeignPtr.Imp.mallocForeignPtrArray :: (Foreign.Storable.Storable a) => n:Nat -> IO (ForeignPtrN a n)+@-}
+ src/Foreign/Marshal/Alloc_LHAssumptions.hs view
@@ -0,0 +1,10 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+module Foreign.Marshal.Alloc_LHAssumptions where++import GHC.Types_LHAssumptions()+import GHC.Ptr_LHAssumptions()+import Foreign.Marshal.Alloc++{-@+assume Foreign.Marshal.Alloc.allocaBytes :: n:Nat -> (PtrN a n -> IO b) -> IO b+@-}
+ src/Foreign/Ptr_LHAssumptions.hs view
@@ -0,0 +1,9 @@+module Foreign.Ptr_LHAssumptions where+++{-@++invariant {v:Foreign.Ptr.Ptr a | 0 <= plen  v }+invariant {v:Foreign.Ptr.Ptr a | 0 <= pbase v }++@-}
+ src/Foreign/Storable_LHAssumptions.hs view
@@ -0,0 +1,29 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+module Foreign.Storable_LHAssumptions where++import GHC.Ptr_LHAssumptions()+import Foreign.Storable++{-@+predicate PValid P N         = ((0 <= N) && (N < (plen P)))++assume Foreign.Storable.poke        :: (Foreign.Storable.Storable a)+                             => {v: (GHC.Ptr.Ptr a) | 0 < (plen v)}+                             -> a+                             -> (GHC.Types.IO ())++assume Foreign.Storable.peek        :: (Foreign.Storable.Storable a)+                             => p:{v: (GHC.Ptr.Ptr a) | 0 < (plen v)}+                             -> (GHC.Types.IO {v:a | v = (deref p)})++assume Foreign.Storable.peekByteOff :: (Foreign.Storable.Storable a)+                             => forall b. p:(GHC.Ptr.Ptr b)+                             -> {v:GHC.Types.Int | (PValid p v)}+                             -> (GHC.Types.IO a)++assume Foreign.Storable.pokeByteOff :: (Foreign.Storable.Storable a)+                             => forall b. p:(GHC.Ptr.Ptr b)+                             -> {v:GHC.Types.Int | (PValid p v)}+                             -> a+                             -> GHC.Types.IO ()+@-}
+ src/GHC/Base_LHAssumptions.hs view
@@ -0,0 +1,54 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+module GHC.Base_LHAssumptions where++import GHC.CString_LHAssumptions()+import GHC.Exts_LHAssumptions()+import GHC.Types_LHAssumptions()+import GHC.Base+import Data.Tuple_LHAssumptions()++{-@++assume GHC.Base.. :: forall <p :: b -> c -> Bool, q :: a -> b -> Bool, r :: a -> c -> Bool>.+                   {xcmp::a, wcmp::b<q xcmp> |- c<p wcmp> <: c<r xcmp>}+                   (ycmp:b -> c<p ycmp>)+                -> (zcmp:a -> b<q zcmp>)+                ->  xcmp:a -> c<r xcmp>++measure autolen :: forall a. a -> GHC.Types.Int++//  Useless as compiled into GHC primitive, which is ignored+assume GHC.Base.assert :: {v:Bool | v } -> a -> a++instance measure len :: forall a. [a] -> GHC.Types.Int+  len []     = 0+  len (y:ys) = 1 + len ys++invariant {v: [a] | len v >= 0 }+assume GHC.Base.map       :: (a -> b) -> xs:[a] -> {v: [b] | len v == len xs}+assume GHC.Base.++        :: xs:[a] -> ys:[a] -> {v:[a] | len v == len xs + len ys}++assume (GHC.Base.$)       :: (a -> b) -> a -> b+assume GHC.Base.id        :: x:a -> {v:a | v = x}++qualif IsEmp(v:GHC.Types.Bool, xs: [a]) : (v <=> (len xs > 0))+qualif IsEmp(v:GHC.Types.Bool, xs: [a]) : (v <=> (len xs = 0))++qualif ListZ(v: [a])          : (len v =  0)+qualif ListZ(v: [a])          : (len v >= 0)+qualif ListZ(v: [a])          : (len v >  0)++qualif CmpLen(v:[a], xs:[b])  : (len v  =  len xs )+qualif CmpLen(v:[a], xs:[b])  : (len v  >= len xs )+qualif CmpLen(v:[a], xs:[b])  : (len v  >  len xs )+qualif CmpLen(v:[a], xs:[b])  : (len v  <= len xs )+qualif CmpLen(v:[a], xs:[b])  : (len v  <  len xs )++qualif EqLen(v:int, xs: [a])  : (v = len xs )+qualif LenEq(v:[a], x: int)   : (x = len v )++qualif LenDiff(v:[a], x:int)  : (len v  = x + 1)+qualif LenDiff(v:[a], x:int)  : (len v  = x - 1)+qualif LenAcc(v:int, xs:[a], n: int): (v = len xs  + n)++@-}
+ src/GHC/CString_LHAssumptions.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE MagicHash #-}+{-# OPTIONS_GHC -Wno-missing-signatures #-}+module GHC.CString_LHAssumptions() where++import GHC.CString+import GHC.Types_LHAssumptions()++_f = unpackCString#++{-@+measure strLen :: Addr# -> GHC.Types.Int++assume GHC.CString.unpackCString#+  :: x:GHC.Prim.Addr#+  -> {v:[GHC.Types.Char] | v ~~ x && len v == strLen x}+@-}
+ src/GHC/Classes_LHAssumptions.hs view
@@ -0,0 +1,35 @@+module GHC.Classes_LHAssumptions where++import GHC.Classes()+import GHC.Types()+import GHC.Types_LHAssumptions()++{-@++assume GHC.Classes.not :: x:GHC.Types.Bool -> {v:GHC.Types.Bool | ((v) <=> ~(x))}+assume (GHC.Classes.&&)    :: x:GHC.Types.Bool -> y:GHC.Types.Bool+        -> {v:GHC.Types.Bool | ((v) <=> ((x) && (y)))}+assume (GHC.Classes.||)    :: x:GHC.Types.Bool -> y:GHC.Types.Bool+        -> {v:GHC.Types.Bool | ((v) <=> ((x) || (y)))}+assume (GHC.Classes.==)    :: (GHC.Classes.Eq  a) => x:a -> y:a+        -> {v:GHC.Types.Bool | ((v) <=> x = y)}+assume (GHC.Classes./=)    :: (GHC.Classes.Eq  a) => x:a -> y:a+        -> {v:GHC.Types.Bool | ((v) <=> x != y)}+assume (GHC.Classes.>)     :: (GHC.Classes.Ord a) => x:a -> y:a+        -> {v:GHC.Types.Bool | ((v) <=> x > y)}+assume (GHC.Classes.>=)    :: (GHC.Classes.Ord a) => x:a -> y:a+        -> {v:GHC.Types.Bool | ((v) <=> x >= y)}+assume (GHC.Classes.<)     :: (GHC.Classes.Ord a) => x:a -> y:a+        -> {v:GHC.Types.Bool | ((v) <=> x < y)}+assume (GHC.Classes.<=)    :: (GHC.Classes.Ord a) => x:a -> y:a+        -> {v:GHC.Types.Bool | ((v) <=> x <= y)}++assume GHC.Classes.compare :: (GHC.Classes.Ord a) => x:a -> y:a+        -> {v:GHC.Types.Ordering | (((v = GHC.Types.EQ) <=> (x = y)) &&+                                    ((v = GHC.Types.LT) <=> (x < y)) &&+                                    ((v = GHC.Types.GT) <=> (x > y))) }++assume GHC.Classes.max :: (GHC.Classes.Ord a) => x:a -> y:a -> {v:a | v = (if x > y then x else y) }+assume GHC.Classes.min :: (GHC.Classes.Ord a) => x:a -> y:a -> {v:a | v = (if x < y then x else y) }++@-}
+ src/GHC/Exts_LHAssumptions.hs view
@@ -0,0 +1,17 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+module GHC.Exts_LHAssumptions where++import GHC.Base+import GHC.Types_LHAssumptions()++{-@++assume GHC.Prim.+#  :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v: GHC.Prim.Int# | v = x + y}+assume GHC.Prim.-#  :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v: GHC.Prim.Int# | v = x - y}+assume GHC.Prim.==# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v:GHC.Prim.Int# | v = 1 <=> x = y}+assume GHC.Prim.>=# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v:GHC.Prim.Int# | v = 1 <=> x >= y}+assume GHC.Prim.<=# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v:GHC.Prim.Int# | v = 1 <=> x <= y}+assume GHC.Prim.<#  :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v:GHC.Prim.Int# | v = 1 <=> x < y}+assume GHC.Prim.>#  :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v:GHC.Prim.Int# | v = 1 <=> x > y}++@-}
+ src/GHC/Float_LHAssumptions.hs view
@@ -0,0 +1,27 @@+module GHC.Float_LHAssumptions(Floating(..)) where++{-@+class (GHC.Real.Fractional a) => GHC.Float.Floating a where+  GHC.Float.pi       :: a+  GHC.Float.exp      :: a -> {y:a | y > 0}+  GHC.Float.log      :: {x:a | x > 0} -> a+  GHC.Float.sqrt     :: {x:a | x >= 0} -> {y:a | y >= 0}+  (GHC.Float.**)     :: x:a -> {y:a | x = 0 => y >= 0} -> a+  GHC.Float.logBase  :: {b:a | b > 0 && b /= 1} -> {x:a | x > 0} -> a+  GHC.Float.sin      :: a -> {y:a | -1 <= y && y <= 1}+  GHC.Float.cos      :: a -> {y:a | -1 <= y && y <= 1}+  GHC.Float.tan      :: a -> a+  GHC.Float.asin     :: {x:a | -1 <= x && x <= 1} -> a+  GHC.Float.acos     :: {x:a | -1 <= x && x <= 1} -> a+  GHC.Float.atan     :: a -> a+  GHC.Float.sinh     :: a -> a+  GHC.Float.cosh     :: a -> {y:a | y >= 1}+  GHC.Float.tanh     :: a -> {y:a | -1 < y && y < 1}+  GHC.Float.asinh    :: a -> a+  GHC.Float.acosh    :: {y:a | y >= 1} -> a+  GHC.Float.atanh    :: {y:a | -1 < y && y < 1} -> a+  GHC.Float.log1p    :: a -> a+  GHC.Float.expm1    :: a -> a+  GHC.Float.log1pexp :: a -> a+  GHC.Float.log1mexp :: a -> a+@-}
+ src/GHC/ForeignPtr_LHAssumptions.hs view
@@ -0,0 +1,15 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+module GHC.ForeignPtr_LHAssumptions where++import GHC.ForeignPtr+import GHC.Ptr_LHAssumptions()++{-@+measure fplen :: GHC.ForeignPtr.ForeignPtr a -> GHC.Types.Int++type ForeignPtrV a   = {v: GHC.ForeignPtr.ForeignPtr a | 0 <= fplen v}+type ForeignPtrN a N = {v: GHC.ForeignPtr.ForeignPtr a | 0 <= fplen v && fplen v == N }++assume GHC.ForeignPtr.newForeignPtr_     :: p:(GHC.Ptr.Ptr a) -> (GHC.Types.IO (ForeignPtrN a (plen p)))+assume GHC.ForeignPtr.mallocPlainForeignPtrBytes :: n:{v:GHC.Types.Int  | v >= 0 } -> (GHC.Types.IO (ForeignPtrN a n))+@-}
+ src/GHC/IO/Handle_LHAssumptions.hs view
@@ -0,0 +1,16 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+module GHC.IO.Handle_LHAssumptions where++import GHC.IO.Handle+import GHC.Types_LHAssumptions()++{-@+assume GHC.IO.Handle.Text.hGetBuf :: GHC.IO.Handle.Handle -> GHC.Ptr.Ptr a -> n:Nat+        -> (GHC.Types.IO {v:Nat | v <= n})++assume GHC.IO.Handle.Text.hGetBufNonBlocking :: GHC.IO.Handle.Handle -> GHC.Ptr.Ptr a -> n:Nat+                   -> (GHC.Types.IO {v:Nat | v <= n})++assume GHC.IO.Handle.hFileSize :: GHC.IO.Handle.Handle+          -> (GHC.Types.IO {v:Integer | v >= 0})+@-}
+ src/GHC/Int_LHAssumptions.hs view
@@ -0,0 +1,13 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+module GHC.Int_LHAssumptions where++import GHC.Int++{-@+embed GHC.Int.Int8  as int+embed GHC.Int.Int16 as int+embed GHC.Int.Int32 as int+embed GHC.Int.Int64 as int++type Nat64 = {v:GHC.Int.Int64 | v >= 0}+@-}
+ src/GHC/List_LHAssumptions.hs view
@@ -0,0 +1,69 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+module GHC.List_LHAssumptions where++import GHC.List+import GHC.Types_LHAssumptions()++{-@++assume GHC.List.head         :: xs:{v: [a] | len v > 0} -> {v:a | v = head xs}+assume GHC.List.tail         :: xs:{v: [a] | len v > 0} -> {v: [a] | len(v) = (len(xs) - 1) && v = tail xs}++assume GHC.List.last         :: xs:{v: [a] | len v > 0} -> a+assume GHC.List.init         :: xs:{v: [a] | len v > 0} -> {v: [a] | len(v) = len(xs) - 1}+assume GHC.List.null         :: xs:[a] -> {v: GHC.Types.Bool | ((v) <=> len(xs) = 0) }+assume GHC.List.length       :: xs:[a] -> {v: GHC.Types.Int | v = len(xs)}+assume GHC.List.filter       :: (a -> GHC.Types.Bool) -> xs:[a] -> {v: [a] | len(v) <= len(xs)}+assume GHC.List.scanl        :: (a -> b -> a) -> a -> xs:[b] -> {v: [a] | len(v) = 1 + len(xs) }+assume GHC.List.scanl1       :: (a -> a -> a) -> xs:{v: [a] | len(v) > 0} -> {v: [a] | len(v) = len(xs) }+assume GHC.List.foldr1       :: (a -> a -> a) -> xs:{v: [a] | len(v) > 0} -> a+assume GHC.List.scanr        :: (a -> b -> b) -> b -> xs:[a] -> {v: [b] | len(v) = 1 + len(xs) }+assume GHC.List.scanr1       :: (a -> a -> a) -> xs:{v: [a] | len(v) > 0} -> {v: [a] | len(v) = len(xs) }++lazy GHC.List.iterate+assume GHC.List.iterate :: (a -> a) -> a -> [a]++assume GHC.List.repeat :: a -> [a]+lazy GHC.List.repeat++assume GHC.List.replicate    :: n:Nat -> x:a -> {v: [{v:a | v = x}] | len(v) = n}++assume GHC.List.cycle        :: {v: [a] | len(v) > 0 } -> [a]+lazy GHC.List.cycle++assume GHC.List.takeWhile    :: (a -> GHC.Types.Bool) -> xs:[a] -> {v: [a] | len(v) <= len(xs)}+assume GHC.List.dropWhile    :: (a -> GHC.Types.Bool) -> xs:[a] -> {v: [a] | len(v) <= len(xs)}++assume GHC.List.take :: n:GHC.Types.Int+     -> xs:[a]+     -> {v:[a] | if n >= 0 then (len v = (if (len xs) < n then (len xs) else n)) else (len v = 0)}+assume GHC.List.drop :: n:GHC.Types.Int+     -> xs:[a]+     -> {v:[a] | (if (n >= 0) then (len(v) = (if (len(xs) < n) then 0 else len(xs) - n)) else ((len v) = (len xs)))}++assume GHC.List.splitAt :: n:_ -> x:[a] -> ({v:[a] | (if (n >= 0) then (if (len x) < n then (len v) = (len x) else (len v) = n) else ((len v) = 0))},[a])<{\x1 x2 -> (len x2) = (len x) - (len x1)}>+assume GHC.List.span    :: (a -> GHC.Types.Bool)+        -> xs:[a]+        -> ({v:[a]|((len v)<=(len xs))}, {v:[a]|((len v)<=(len xs))})++assume GHC.List.break :: (a -> GHC.Types.Bool) -> xs:[a] -> ([a],[a])<{\x y -> (len xs) = (len x) + (len y)}>++assume GHC.List.reverse      :: xs:[a] -> {v: [a] | len(v) = len(xs)}++//  Copy-pasted from len.hquals+qualif LenSum(v:[a], xs:[b], ys:[c]): len([v]) = (len([xs]) + len([ys]))+qualif LenSum(v:[a], xs:[b], ys:[c]): len([v]) = (len([xs]) - len([ys]))++assume GHC.List.!!         :: xs:[a] -> {v: _ | ((0 <= v) && (v < len(xs)))} -> a+++assume GHC.List.zip :: xs : [a] -> ys:[b]+            -> {v : [(a, b)] | ((((len v) <= (len xs)) && ((len v) <= (len ys)))+            && (((len xs) = (len ys)) => ((len v) = (len xs))) )}++assume GHC.List.zipWith :: (a -> b -> c)+        -> xs : [a] -> ys:[b]+        -> {v : [c] | (((len v) <= (len xs)) && ((len v) <= (len ys)))}++assume GHC.List.errorEmptyList :: {v: _ | false} -> a+@-}
+ src/GHC/Maybe_LHAssumptions.hs view
@@ -0,0 +1,5 @@+module GHC.Maybe_LHAssumptions where++{-@+data Maybe a = Nothing | Just a+@-}
+ src/GHC/Num_LHAssumptions.hs view
@@ -0,0 +1,17 @@+module GHC.Num_LHAssumptions where++{-@+embed GHC.Integer.Type.Integer as int+embed GHC.Num.Integer as int++assume GHC.Num.fromInteger :: (GHC.Num.Num a) => x:Integer -> {v:a | v = x }++assume GHC.Num.negate :: (GHC.Num.Num a)+               => x:a+               -> {v:a | v = -x}++assume GHC.Num.abs :: (GHC.Num.Num a) => x:a -> {y:a | (x >= 0 ==> y = x) && (x < 0 ==> y = -x) }++assume GHC.Num.+ :: (GHC.Num.Num a) => x:a -> y:a -> {v:a | v = x + y }+assume GHC.Num.- :: (GHC.Num.Num a) => x:a -> y:a -> {v:a | v = x - y }+@-}
+ src/GHC/Ptr_LHAssumptions.hs view
@@ -0,0 +1,26 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+module GHC.Ptr_LHAssumptions where++import GHC.Ptr+import GHC.Types_LHAssumptions()++{-@+measure pbase     :: GHC.Ptr.Ptr a -> GHC.Types.Int+measure plen      :: GHC.Ptr.Ptr a -> GHC.Types.Int+measure isNullPtr :: GHC.Ptr.Ptr a -> Bool ++type PtrN a N = {v: PtrV a        | plen v == N }+type PtrV a   = {v: GHC.Ptr.Ptr a | 0 <= plen v }++assume GHC.Ptr.castPtr :: p:(PtrV a) -> (PtrN b (plen p))++assume GHC.Ptr.plusPtr :: base:(PtrV a)+                -> off:{v:GHC.Types.Int | v <= plen base }+                -> {v:(PtrV b) | pbase v = pbase base && plen v = plen base - off}++assume GHC.Ptr.minusPtr :: q:(PtrV a)+                 -> p:{v:(PtrV b) | pbase v == pbase q && plen v >= plen q}+                 -> {v:Nat | v == plen p - plen q}++measure deref     :: GHC.Ptr.Ptr a -> a+@-}
+ src/GHC/Real_LHAssumptions.hs view
@@ -0,0 +1,42 @@+-- Reexports are necessary for LH to expose specs of type classes+module GHC.Real_LHAssumptions(Integral(..), Fractional(..)) where++import GHC.Types_LHAssumptions()++{-@+assume (GHC.Real.^) :: (GHC.Num.Num a, GHC.Real.Integral b) => x:a -> y:{n:b | n >= 0} -> {z:a | (y == 0 => z == 1) && ((x == 0 && y /= 0) <=> z == 0)}++assume GHC.Real.fromIntegral    :: (GHC.Real.Integral a, GHC.Num.Num b) => x:a -> {v:b|v=x}++class (GHC.Num.Num a) => GHC.Real.Fractional a where+  (GHC.Real./)   :: x:a -> y:{v:a | v /= 0} -> {v:a | v == x / y}+  GHC.Real.recip :: a -> a+  GHC.Real.fromRational :: GHC.Real.Ratio Integer -> a++class (GHC.Real.Real a, GHC.Enum.Enum a) => GHC.Real.Integral a where+  GHC.Real.quot :: x:a -> y:{v:a | v /= 0} -> {v:a | (v = (x / y)) &&+                                                     ((x >= 0 && y >= 0) => v >= 0) &&+                                                     ((x >= 0 && y >= 1) => v <= x) }+  GHC.Real.rem :: x:a -> y:{v:a | v /= 0} -> {v:a | ((v >= 0) && (v < y))}+  GHC.Real.mod :: x:a -> y:{v:a | v /= 0} -> {v:a | v = x mod y && ((0 <= x && 0 < y) => (0 <= v && v < y))}++  GHC.Real.div :: x:a -> y:{v:a | v /= 0} -> {v:a | (v = (x / y)) &&+                                                    ((x >= 0 && y >= 0) => v >= 0) &&+                                                    ((x >= 0 && y >= 1) => v <= x) && +                                                    ((1 < y)            => v < x ) && +                                                    ((y >= 1)           => v <= x)  +                                                    }+  GHC.Real.quotRem :: x:a -> y:{v:a | v /= 0} -> ( {v:a | (v = (x / y)) &&+                                                          ((x >= 0 && y >= 0) => v >= 0) &&+                                                          ((x >= 0 && y >= 1) => v <= x)}+                                                 , {v:a | ((v >= 0) && (v < y))})+  GHC.Real.divMod :: x:a -> y:{v:a | v /= 0} -> ( {v:a | (v = (x / y)) &&+                                                         ((x >= 0 && y >= 0) => v >= 0) &&+                                                         ((x >= 0 && y >= 1) => v <= x) }+                                                , {v:a | v = x mod y && ((0 <= x && 0 < y) => (0 <= v && v < y))}+                                                )+  GHC.Real.toInteger :: x:a -> {v:Integer | v = x}++//  fixpoint can't handle (x mod y), only (x mod c) so we need to be more clever here+//  mod :: x:a -> y:a -> {v:a | v = (x mod y) }+@-}
+ src/GHC/Types_LHAssumptions.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE MagicHash #-}+{-# OPTIONS_GHC -Wno-missing-signatures #-}+module GHC.Types_LHAssumptions() where++import GHC.Types++-- This definition is needed to make the listed data constructors+-- visible to LH+_f = (D#, F#, W#)++{-@+//  Boxed types+embed GHC.Types.Double  as real+embed GHC.Prim.Double#  as real+embed GHC.Types.Float   as real+embed GHC.Prim.Float#   as real+embed GHC.Types.Word    as int+embed GHC.Prim.Word#    as int+embed GHC.Types.Int     as int+embed GHC.Prim.Int#     as int+embed GHC.Types.Bool    as bool+embed GHC.Types.Char    as Char+embed GHC.Prim.Char#    as Char+embed GHC.Prim.Addr#    as Str++embed GHC.Integer.Type.Integer as int+embed GHC.Num.Integer as int++assume GHC.Types.True  :: {v:GHC.Types.Bool | v     }+assume GHC.Types.False :: {v:GHC.Types.Bool | (~ v) }+assume GHC.Types.isTrue#  :: n:_ -> {v:GHC.Types.Bool | (n = 1 <=> v)}++assume GHC.Types.D# :: x:GHC.Prim.Double# -> {v: GHC.Types.Double | v = (x :: real) }+assume GHC.Types.F# :: x:GHC.Prim.Float# -> {v: GHC.Types.Float | v = (x :: real) }+assume GHC.Types.I# :: x:GHC.Prim.Int# -> {v: GHC.Types.Int | v = (x :: int) }+assume GHC.Types.C# :: x:GHC.Prim.Char# -> {v: GHC.Types.Char | v = (x :: Char) }+assume GHC.Types.W# :: w:_ -> {v:GHC.Types.Word | v == w }++measure addrLen :: GHC.Prim.Addr# -> GHC.Types.Int++type GeInt N = {v: GHC.Types.Int | v >= N }+type LeInt N = {v: GHC.Types.Int | v <= N }+type Nat     = {v: GHC.Types.Int | v >= 0 }+type Even    = {v: GHC.Types.Int | (v mod 2) = 0 }+type Odd     = {v: GHC.Types.Int | (v mod 2) = 1 }+type BNat N  = {v: Nat           | v <= N }+type TT      = {v: GHC.Types.Bool | v}+type FF      = {v: GHC.Types.Bool | not v}+type String  = [GHC.Types.Char]++class measure len :: forall f a. f a -> GHC.Types.Int+@-}
+ src/GHC/Word_LHAssumptions.hs view
@@ -0,0 +1,9 @@+module GHC.Word_LHAssumptions where++{-@+embed GHC.Word.Word   as int+embed GHC.Word.Word8  as int+embed GHC.Word.Word16 as int+embed GHC.Word.Word32 as int+embed GHC.Word.Word64 as int+@-}
− src/Language/Haskell/Liquid/Bare.hs 
@@ -1,1308 +0,0 @@-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE PartialTypeSignatures     #-}-{-# LANGUAGE OverloadedStrings         #-}---- | This module contains the functions that convert /from/ descriptions of---   symbols, names and types (over freshly parsed /bare/ Strings),---   /to/ representations connected to GHC 'Var's, 'Name's, and 'Type's.---   The actual /representations/ of bare and real (refinement) types are all---   in 'RefType' -- they are different instances of 'RType'.--module Language.Haskell.Liquid.Bare (-  -- * Creating a TargetSpec-  -- $creatingTargetSpecs-    makeTargetSpec--  -- * Loading and Saving lifted specs from/to disk-  , loadLiftedSpec-  , saveLiftedSpec-  ) where--import           Prelude                                    hiding (error)-import           Optics-import           Control.Monad                              (forM)-import           Control.Applicative                        ((<|>))-import qualified Control.Exception                          as Ex-import qualified Data.Binary                                as B-import qualified Data.Maybe                                 as Mb-import qualified Data.List                                  as L-import qualified Data.HashMap.Strict                        as M-import qualified Data.HashSet                               as S-import           Text.PrettyPrint.HughesPJ                  hiding (first, (<>)) -- (text, (<+>))-import           System.FilePath                            (dropExtension)-import           System.Directory                           (doesFileExist)-import           System.Console.CmdArgs.Verbosity           (whenLoud)-import           Language.Fixpoint.Utils.Files              as Files-import           Language.Fixpoint.Misc                     as Misc-import           Language.Fixpoint.Types                    hiding (dcFields, DataDecl, Error, panic)-import qualified Language.Fixpoint.Types                    as F-import qualified Language.Haskell.Liquid.Misc               as Misc -- (nubHashOn)-import qualified Liquid.GHC.Misc           as GM-import qualified Liquid.GHC.API            as Ghc-import           Liquid.GHC.Types          (StableName)-import           Language.Haskell.Liquid.Types-import           Language.Haskell.Liquid.WiredIn-import qualified Language.Haskell.Liquid.Measure            as Ms-import qualified Language.Haskell.Liquid.Bare.Types         as Bare-import qualified Language.Haskell.Liquid.Bare.Resolve       as Bare-import qualified Language.Haskell.Liquid.Bare.DataType      as Bare-import           Language.Haskell.Liquid.Bare.Elaborate-import qualified Language.Haskell.Liquid.Bare.Expand        as Bare-import qualified Language.Haskell.Liquid.Bare.Measure       as Bare-import qualified Language.Haskell.Liquid.Bare.Plugged       as Bare-import qualified Language.Haskell.Liquid.Bare.Axiom         as Bare-import qualified Language.Haskell.Liquid.Bare.ToBare        as Bare-import qualified Language.Haskell.Liquid.Bare.Class         as Bare-import qualified Language.Haskell.Liquid.Bare.Check         as Bare-import qualified Language.Haskell.Liquid.Bare.Laws          as Bare-import qualified Language.Haskell.Liquid.Bare.Typeclass     as Bare-import qualified Language.Haskell.Liquid.Transforms.CoreToLogic as CoreToLogic-import           Control.Arrow                    (second)-import Data.Hashable (Hashable)-import qualified Language.Haskell.Liquid.Bare.Slice as Dg------------------------------------------------------------------------------------- | De/Serializing Spec files-----------------------------------------------------------------------------------loadLiftedSpec :: Config -> FilePath -> IO (Maybe Ms.BareSpec)-loadLiftedSpec cfg srcF-  | noLiftedImport cfg = putStrLn "No LIFTED Import" >> return Nothing-  | otherwise          = do-      let specF = extFileName BinSpec srcF-      ex  <- doesFileExist specF-      whenLoud $ putStrLn $ "Loading Binary Lifted Spec: " ++ specF ++ " " ++ "for source-file: " ++ show srcF ++ " " ++ show ex-      lSp <- if ex-               then Just <$> B.decodeFile specF-               else {- warnMissingLiftedSpec srcF specF >> -} return Nothing-      Ex.evaluate lSp---- warnMissingLiftedSpec :: FilePath -> FilePath -> IO () --- warnMissingLiftedSpec srcF specF = do ---   incDir <- Misc.getIncludeDir ---   unless (Misc.isIncludeFile incDir srcF)---     $ Ex.throw (errMissingSpec srcF specF) --saveLiftedSpec :: FilePath -> Ms.BareSpec -> IO ()-saveLiftedSpec srcF lspec = do-  ensurePath specF-  B.encodeFile specF lspec-  -- print (errorP "DIE" "HERE" :: String) -  where-    specF = extFileName BinSpec srcF--{- $creatingTargetSpecs--/Liquid Haskell/ operates on 'TargetSpec's, so this module provides a single function called-'makeTargetSpec' to produce a 'TargetSpec', alongside the 'LiftedSpec'. The former will be used by-functions like 'liquid' or 'liquidOne' to verify our program is correct, the latter will be serialised-to disk so that we can retrieve it later without having to re-check the relevant Haskell file.--}---- | 'makeTargetSpec' constructs the 'TargetSpec' and then validates it. Upon success, the 'TargetSpec'--- and the 'LiftedSpec' are returned. We perform error checking in \"two phases\": during the first phase,--- we check for errors and warnings in the input 'BareSpec' and the dependencies. During this phase we ideally--- want to short-circuit in case the validation failure is found in one of the dependencies (to avoid--- printing potentially endless failures).--- The second phase involves creating the 'TargetSpec', and returning either the full list of diagnostics--- (errors and warnings) in case things went wrong, or the final 'TargetSpec' and 'LiftedSpec' together--- with a list of 'Warning's, which shouldn't abort the compilation (modulo explicit request from the user,--- to treat warnings and errors).-makeTargetSpec :: Config-               -> LogicMap-               -> TargetSrc-               -> BareSpec-               -> TargetDependencies-               -> Ghc.TcRn (Either Diagnostics ([Warning], TargetSpec, LiftedSpec))-makeTargetSpec cfg lmap targetSrc bareSpec dependencies = do-  let targDiagnostics     = Bare.checkTargetSrc cfg targetSrc-  let depsDiagnostics     = mapM (uncurry Bare.checkBareSpec) legacyDependencies-  let bareSpecDiagnostics = Bare.checkBareSpec (giTargetMod targetSrc) legacyBareSpec-  case targDiagnostics >> depsDiagnostics >> bareSpecDiagnostics of-   Left d | noErrors d -> secondPhase (allWarnings d)-   Left d              -> return $ Left d-   Right ()            -> secondPhase mempty-  where-    secondPhase :: [Warning] -> Ghc.TcRn (Either Diagnostics ([Warning], TargetSpec, LiftedSpec))-    secondPhase phaseOneWarns = do--      -- we should be able to setContext regardless of whether-      -- we use the ghc api. However, ghc will complain-      -- if the filename does not match the module name-      -- when (typeclass cfg) $ do-      --   Ghc.setContext [iimport |(modName, _) <- allSpecs legacyBareSpec,-      --                   let iimport = if isTarget modName-      --                                 then Ghc.IIModule (getModName modName)-      --                                 else Ghc.IIDecl (Ghc.simpleImportDecl (getModName modName))]-      --   void $ Ghc.execStmt-      --     "let {infixr 1 ==>; True ==> False = False; _ ==> _ = True}"-      --     Ghc.execOptions-      --   void $ Ghc.execStmt-      --     "let {infixr 1 <=>; True <=> False = False; _ <=> _ = True}"-      --     Ghc.execOptions-      --   void $ Ghc.execStmt-      --     "let {infix 4 ==; (==) :: a -> a -> Bool; _ == _ = undefined}"-      --     Ghc.execOptions-      --   void $ Ghc.execStmt-      --     "let {infix 4 /=; (/=) :: a -> a -> Bool; _ /= _ = undefined}"-      --     Ghc.execOptions-      --   void $ Ghc.execStmt-      --     "let {infixl 7 /; (/) :: Num a => a -> a -> a; _ / _ = undefined}"-      --     Ghc.execOptions        -      --   void $ Ghc.execStmt-      --     "let {len :: [a] -> Int; len _ = undefined}"-      --     Ghc.execOptions        --      diagOrSpec <- makeGhcSpec cfg (review targetSrcIso targetSrc) lmap (allSpecs legacyBareSpec)-      return $ do-        (warns, ghcSpec) <- diagOrSpec-        let (targetSpec, liftedSpec) = view targetSpecGetter ghcSpec-        pure (phaseOneWarns <> warns, targetSpec, liftedSpec)--    toLegacyDep :: (Ghc.StableModule, LiftedSpec) -> (ModName, Ms.BareSpec)-    toLegacyDep (sm, ls) = (ModName SrcImport (Ghc.moduleName . Ghc.unStableModule $ sm), unsafeFromLiftedSpec ls)--    toLegacyTarget :: Ms.BareSpec -> (ModName, Ms.BareSpec)-    toLegacyTarget validatedSpec = (giTargetMod targetSrc, validatedSpec)--    legacyDependencies :: [(ModName, Ms.BareSpec)]-    legacyDependencies = map toLegacyDep . M.toList . getDependencies $ dependencies--    allSpecs :: Ms.BareSpec -> [(ModName, Ms.BareSpec)]-    allSpecs validSpec = toLegacyTarget validSpec : legacyDependencies--    legacyBareSpec :: Spec LocBareType F.LocSymbol-    legacyBareSpec = review bareSpecIso bareSpec------------------------------------------------------------------------------------------ | @makeGhcSpec@ invokes @makeGhcSpec0@ to construct the @GhcSpec@ and then---   validates it using @checkGhcSpec@.---------------------------------------------------------------------------------------makeGhcSpec :: Config-            -> GhcSrc-            -> LogicMap-            -> [(ModName, Ms.BareSpec)]-            -> Ghc.TcRn (Either Diagnostics ([Warning], GhcSpec))---------------------------------------------------------------------------------------makeGhcSpec cfg src lmap validatedSpecs = do-  (dg0, sp) <- makeGhcSpec0 cfg src lmap validatedSpecs-  let diagnostics = Bare.checkTargetSpec (map snd validatedSpecs)-                                         (view targetSrcIso src)-                                         (ghcSpecEnv sp)-                                         (_giCbs src)-                                         (fst . view targetSpecGetter $ sp)-  pure $ if not (noErrors dg0) then Left dg0 else-           case diagnostics of-             Left dg1-               | noErrors dg1 -> pure (allWarnings dg1, sp)-               | otherwise    -> Left dg1-             Right ()         -> pure (mempty, sp)---ghcSpecEnv :: GhcSpec -> SEnv SortedReft-ghcSpecEnv sp = F.notracepp "RENV" $ fromListSEnv binds-  where-    emb       = gsTcEmbeds (_gsName sp)-    binds     = F.notracepp "binds" $ concat-                 [ [(x,        rSort t) | (x, Loc _ _ t)  <- gsMeas     (_gsData sp)]-                 , [(symbol v, rSort t) | (v, Loc _ _ t)  <- gsCtors    (_gsData sp)]-                 , [(symbol v, vSort v) | v               <- gsReflects (_gsRefl sp)]-                 , [(x,        vSort v) | (x, v)          <- gsFreeSyms (_gsName sp), Ghc.isConLikeId v ]-                 , [(x, RR s mempty)    | (x, s)          <- wiredSortedSyms       ]-                 , [(x, RR s mempty)    | (x, s)          <- _gsImps sp       ]-                 ]-    vSort     = rSort . classRFInfoType (typeclass $ getConfig sp) .-                (ofType :: Ghc.Type -> SpecType) . Ghc.varType-    rSort     = rTypeSortedReft    emb------------------------------------------------------------------------------------------- | @makeGhcSpec0@ slurps up all the relevant information needed to generate ---   constraints for a target module and packages them into a @GhcSpec@ ---   See [NOTE] LIFTING-STAGES to see why we split into lSpec0, lSpec1, etc.---   essentially, to get to the `BareRTEnv` as soon as possible, as thats what---   lets us use aliases inside data-constructor definitions.---------------------------------------------------------------------------------------makeGhcSpec0 :: Config -> GhcSrc ->  LogicMap -> [(ModName, Ms.BareSpec)] ->-                Ghc.TcRn (Diagnostics, GhcSpec)-makeGhcSpec0 cfg src lmap mspecsNoCls = do-  -- build up environments-  tycEnv <- makeTycEnv1 name env (tycEnv0, datacons) coreToLg simplifier-  let tyi      = Bare.tcTyConMap   tycEnv-  let sigEnv   = makeSigEnv  embs tyi (_gsExports src) rtEnv-  let lSpec1   = lSpec0 <> makeLiftedSpec1 cfg src tycEnv lmap mySpec1-  let mySpec   = mySpec2 <> lSpec1-  let specs    = M.insert name mySpec iSpecs2-  let myRTE    = myRTEnv       src env sigEnv rtEnv-  let (dg5, measEnv) = withDiagnostics $ makeMeasEnv      env tycEnv sigEnv       specs-  let (dg4, sig) = withDiagnostics $ makeSpecSig cfg name specs env sigEnv   tycEnv measEnv (_giCbs src)-  elaboratedSig <--    if allowTC then Bare.makeClassAuxTypes (elaborateSpecType coreToLg simplifier) datacons instMethods-                              >>= elaborateSig sig-               else pure sig-  let qual     = makeSpecQual cfg env tycEnv measEnv rtEnv specs-  let sData    = makeSpecData  src env sigEnv measEnv elaboratedSig specs-  let (dg1, spcVars) = withDiagnostics $ makeSpecVars cfg src mySpec env measEnv-  let (dg2, spcTerm) = withDiagnostics $ makeSpecTerm cfg     mySpec env       name-  let (dg3, refl)    = withDiagnostics $ makeSpecRefl cfg src measEnv specs env name elaboratedSig tycEnv-  let laws     = makeSpecLaws env sigEnv (gsTySigs elaboratedSig ++ gsAsmSigs elaboratedSig) measEnv specs-  let finalLiftedSpec = makeLiftedSpec name src env refl sData elaboratedSig qual myRTE lSpec1-  let diags    = mconcat [dg0, dg1, dg2, dg3, dg4, dg5]--  pure (diags, SP-    { _gsConfig = cfg-    , _gsImps   = makeImports mspecs-    , _gsSig    = addReflSigs env name rtEnv refl elaboratedSig-    , _gsRefl   = refl-    , _gsLaws   = laws-    , _gsData   = sData-    , _gsQual   = qual-    , _gsName   = makeSpecName env     tycEnv measEnv   name-    , _gsVars   = spcVars-    , _gsTerm   = spcTerm--    , _gsLSpec  = finalLiftedSpec-                { impSigs   = makeImports mspecs-                , expSigs   = [ (F.symbol v, F.sr_sort $ Bare.varSortedReft embs v) | v <- gsReflects refl ]-                , dataDecls = Bare.dataDeclSize mySpec $ dataDecls mySpec-                , measures  = Ms.measures mySpec-                  -- We want to export measures in a 'LiftedSpec', especially if they are-                  -- required to check termination of some 'liftedSigs' we export. Due to the fact-                  -- that 'lSpec1' doesn't contain the measures that we compute via 'makeHaskellMeasures',-                  -- we take them from 'mySpec', which has those.-                , asmSigs = Ms.asmSigs finalLiftedSpec ++ Ms.asmSigs mySpec-                  -- Export all the assumptions (not just the ones created out of reflection) in-                  -- a 'LiftedSpec'.-                , imeasures = Ms.imeasures finalLiftedSpec ++ Ms.imeasures mySpec-                  -- Preserve user-defined 'imeasures'.-                , dvariance = Ms.dvariance finalLiftedSpec ++ Ms.dvariance mySpec-                  -- Preserve user-defined 'dvariance'.-                , rinstance = Ms.rinstance finalLiftedSpec ++ Ms.rinstance mySpec-                  -- Preserve rinstances.-                }-    })-  where-    -- typeclass elaboration--    coreToLg ce =-      case CoreToLogic.runToLogic-             embs-             lmap-             dm-             (\x -> todo Nothing ("coreToLogic not working " ++ x))-             (CoreToLogic.coreToLogic allowTC ce) of-        Left msg -> panic Nothing (F.showpp msg)-        Right e -> e-    elaborateSig si auxsig = do-      tySigs <--        forM (gsTySigs si) $ \(x, t) ->-          if GM.isFromGHCReal x then-            pure (x, t)-          else do t' <- traverse (elaborateSpecType coreToLg simplifier) t-                  pure (x, t')-      -- things like len breaks the code-      -- asmsigs should be elaborated only if they are from the current module-      -- asmSigs <- forM (gsAsmSigs si) $ \(x, t) -> do-      --   t' <- traverse (elaborateSpecType (pure ()) coreToLg) t-      --   pure (x, fst <$> t')-      pure-        si-          { gsTySigs = F.notracepp ("asmSigs" ++ F.showpp (gsAsmSigs si)) tySigs ++ auxsig  }--    simplifier :: Ghc.CoreExpr -> Ghc.TcRn Ghc.CoreExpr-    simplifier = pure -- no simplification-    allowTC  = typeclass cfg-    mySpec2  = Bare.qualifyExpand env name rtEnv l [] mySpec1    where l = F.dummyPos "expand-mySpec2"-    iSpecs2  = Bare.qualifyExpand env name rtEnv l [] iSpecs0    where l = F.dummyPos "expand-iSpecs2"-    rtEnv    = Bare.makeRTEnv env name mySpec1 iSpecs0 lmap-    mspecs   = if allowTC then M.toList $ M.insert name mySpec0 iSpecs0 else mspecsNoCls-    (mySpec0, instMethods)  = if allowTC-                              then Bare.compileClasses src env (name, mySpec0NoCls) (M.toList iSpecs0)-                              else (mySpec0NoCls, [])-    mySpec1  = mySpec0 <> lSpec0-    lSpec0   = makeLiftedSpec0 cfg src embs lmap mySpec0-    embs     = makeEmbeds          src env ((name, mySpec0) : M.toList iSpecs0)-    dm       = Bare.tcDataConMap tycEnv0-    (dg0, datacons, tycEnv0) = makeTycEnv0   cfg name env embs mySpec2 iSpecs2-    -- extract name and specs-    env      = Bare.makeEnv cfg src lmap mspecsNoCls-    (mySpec0NoCls, iSpecs0) = splitSpecs name src mspecsNoCls-    -- check barespecs -    name     = F.notracepp ("ALL-SPECS" ++ zzz) $ _giTargetMod  src-    zzz      = F.showpp (fst <$> mspecs)--splitSpecs :: ModName -> GhcSrc -> [(ModName, Ms.BareSpec)] -> (Ms.BareSpec, Bare.ModSpecs)-splitSpecs name src specs = (mySpec, iSpecm)-  where-    iSpecm             = fmap mconcat . Misc.group $ iSpecs-    iSpecs             = Dg.sliceSpecs src mySpec iSpecs'-    mySpec             = mconcat (snd <$> mySpecs)-    (mySpecs, iSpecs') = L.partition ((name ==) . fst) specs---makeImports :: [(ModName, Ms.BareSpec)] -> [(F.Symbol, F.Sort)]-makeImports specs = concatMap (expSigs . snd) specs'-  where specs' = filter (isSrcImport . fst) specs---makeEmbeds :: GhcSrc -> Bare.Env -> [(ModName, Ms.BareSpec)] -> F.TCEmb Ghc.TyCon-makeEmbeds src env-  = Bare.addClassEmbeds (_gsCls src) (_gsFiTcs src)-  . mconcat-  . map (makeTyConEmbeds env)--makeTyConEmbeds :: Bare.Env -> (ModName, Ms.BareSpec) -> F.TCEmb Ghc.TyCon-makeTyConEmbeds env (name, spec)-  = F.tceFromList [ (tc, t) | (c,t) <- F.tceToList (Ms.embeds spec), tc <- symTc c ]-    where-      symTc = Mb.maybeToList . Bare.maybeResolveSym env name "embed-tycon"------------------------------------------------------------------------------------- | [NOTE]: REFLECT-IMPORTS------ 1. MAKE the full LiftedSpec, which will eventually, contain:---      makeHaskell{Inlines, Measures, Axioms, Bounds}--- 2. SAVE the LiftedSpec, which will be reloaded--- ---   This step creates the aliases and inlines etc. It must be done BEFORE---   we compute the `SpecType` for (all, including the reflected binders),---   as we need the inlines and aliases to properly `expand` the SpecTypes.----------------------------------------------------------------------------------makeLiftedSpec1 :: Config -> GhcSrc -> Bare.TycEnv -> LogicMap -> Ms.BareSpec-                -> Ms.BareSpec-makeLiftedSpec1 config src tycEnv lmap mySpec = mempty-  { Ms.measures  = Bare.makeHaskellMeasures (typeclass config) src tycEnv lmap mySpec }------------------------------------------------------------------------------------- | [NOTE]: LIFTING-STAGES --- --- We split the lifting up into stage:--- 0. Where we only lift inlines,--- 1. Where we lift reflects, measures, and normalized tySigs--- --- This is because we need the inlines to build the @BareRTEnv@ which then--- does the alias @expand@ business, that in turn, lets us build the DataConP,--- i.e. the refined datatypes and their associate selectors, projectors etc,--- that are needed for subsequent stages of the lifting.----------------------------------------------------------------------------------makeLiftedSpec0 :: Config -> GhcSrc -> F.TCEmb Ghc.TyCon -> LogicMap -> Ms.BareSpec-                -> Ms.BareSpec-makeLiftedSpec0 cfg src embs lmap mySpec = mempty-  { Ms.ealiases  = lmapEAlias . snd <$> Bare.makeHaskellInlines (typeclass cfg) src embs lmap mySpec-  , Ms.reflects  = Ms.reflects mySpec-  , Ms.dataDecls = Bare.makeHaskellDataDecls cfg name mySpec tcs-  , Ms.embeds    = Ms.embeds mySpec-  -- We do want 'embeds' to survive and to be present into the final 'LiftedSpec'. The-  -- caveat is to decide which format is more appropriate. We obviously cannot store-  -- them as a 'TCEmb TyCon' as serialising a 'TyCon' would be fairly exponsive. This-  -- needs more thinking.-  , Ms.cmeasures = Ms.cmeasures mySpec-  -- We do want 'cmeasures' to survive and to be present into the final 'LiftedSpec'. The-  -- caveat is to decide which format is more appropriate. This needs more thinking.-  }-  where-    tcs          = uniqNub (_gsTcs src ++ refTcs)-    refTcs       = reflectedTyCons cfg embs cbs  mySpec-    cbs          = _giCbs       src-    name         = _giTargetMod src--uniqNub :: (Ghc.Uniquable a) => [a] -> [a]-uniqNub xs = M.elems $ M.fromList [ (index x, x) | x <- xs ]-  where-    index  = Ghc.getKey . Ghc.getUnique---- | 'reflectedTyCons' returns the list of `[TyCon]` that must be reflected but---   which are defined *outside* the current module e.g. in Base or somewhere---   that we don't have access to the code.--reflectedTyCons :: Config -> TCEmb Ghc.TyCon -> [Ghc.CoreBind] -> Ms.BareSpec -> [Ghc.TyCon]-reflectedTyCons cfg embs cbs spec-  | exactDCFlag cfg = filter (not . isEmbedded embs)-                    $ concatMap varTyCons-                    $ reflectedVars spec cbs ++ measureVars spec cbs-  | otherwise       = []---- | We cannot reflect embedded tycons (e.g. Bool) as that gives you a sort---   conflict: e.g. what is the type of is-True? does it take a GHC.Types.Bool---   or its embedding, a bool?-isEmbedded :: TCEmb Ghc.TyCon -> Ghc.TyCon -> Bool-isEmbedded embs c = F.tceMember c embs--varTyCons :: Ghc.Var -> [Ghc.TyCon]-varTyCons = specTypeCons . ofType . Ghc.varType--specTypeCons           :: SpecType -> [Ghc.TyCon]-specTypeCons         = foldRType tc []-  where-    tc acc t@RApp {} = rtc_tc (rt_tycon t) : acc-    tc acc _         = acc--reflectedVars :: Ms.BareSpec -> [Ghc.CoreBind] -> [Ghc.Var]-reflectedVars spec cbs = fst <$> xDefs-  where-    xDefs              = Mb.mapMaybe (`GM.findVarDef` cbs) reflSyms-    reflSyms           = val <$> S.toList (Ms.reflects spec)--measureVars :: Ms.BareSpec -> [Ghc.CoreBind] -> [Ghc.Var]-measureVars spec cbs = fst <$> xDefs-  where-    xDefs              = Mb.mapMaybe (`GM.findVarDef` cbs) measureSyms-    measureSyms        = val <$> S.toList (Ms.hmeas spec)---------------------------------------------------------------------------------------------makeSpecVars :: Config -> GhcSrc -> Ms.BareSpec -> Bare.Env -> Bare.MeasEnv-             -> Bare.Lookup GhcSpecVars--------------------------------------------------------------------------------------------makeSpecVars cfg src mySpec env measEnv = do-  tgtVars     <-   mapM (resolveStringVar  env name)              (checks     cfg)-  igVars      <-  sMapM (Bare.lookupGhcVar env name "gs-ignores") (Ms.ignores mySpec)-  lVars       <-  sMapM (Bare.lookupGhcVar env name "gs-lvars"  ) (Ms.lvars   mySpec)-  return (SpVar tgtVars igVars lVars cMethods)-  where-    name       = _giTargetMod src-    cMethods   = snd3 <$> Bare.meMethods measEnv--sMapM :: (Monad m, Eq b, Hashable b) => (a -> m b) -> S.HashSet a -> m (S.HashSet b)-sMapM f xSet = do- ys <- mapM f (S.toList xSet)- return (S.fromList ys)--sForM :: (Monad m, Eq b, Hashable b) =>S.HashSet a -> (a -> m b) -> m (S.HashSet b)-sForM xs f = sMapM f xs--qualifySymbolic :: (F.Symbolic a) => ModName -> a -> F.Symbol-qualifySymbolic name s = GM.qualifySymbol (F.symbol name) (F.symbol s)--resolveStringVar :: Bare.Env -> ModName -> String -> Bare.Lookup Ghc.Var-resolveStringVar env name s = Bare.lookupGhcVar env name "resolve-string-var" lx-  where-    lx                      = dummyLoc (qualifySymbolic name s)-----------------------------------------------------------------------------------------------makeSpecQual :: Config -> Bare.Env -> Bare.TycEnv -> Bare.MeasEnv -> BareRTEnv -> Bare.ModSpecs-             -> GhcSpecQual--------------------------------------------------------------------------------------------makeSpecQual _cfg env tycEnv measEnv _rtEnv specs = SpQual-  { gsQualifiers = filter okQual quals-  , gsRTAliases  = [] -- makeSpecRTAliases env rtEnv -- TODO-REBARE-  }-  where-    quals        = concatMap (makeQualifiers env tycEnv) (M.toList specs)-    -- mSyms        = F.tracepp "MSYMS" $ M.fromList (Bare.meSyms measEnv ++ Bare.meClassSyms measEnv)-    okQual q     = F.notracepp ("okQual: " ++ F.showpp q)-                   $ all (`S.member` mSyms) (F.syms q)-    mSyms        = F.notracepp "MSYMS" . S.fromList-                   $  (fst <$> wiredSortedSyms)-                   ++ (fst <$> Bare.meSyms measEnv)-                   ++ (fst <$> Bare.meClassSyms measEnv)--makeQualifiers :: Bare.Env -> Bare.TycEnv -> (ModName, Ms.Spec ty bndr) -> [F.Qualifier]-makeQualifiers env tycEnv (modn, spec)-  = fmap        (Bare.qualifyTopDummy env        modn)-  . Mb.mapMaybe (resolveQParams       env tycEnv modn)-  $ Ms.qualifiers spec----- | @resolveQualParams@ converts the sorts of parameters from, e.g. ---     'Int' ===> 'GHC.Types.Int' or ---     'Ptr' ===> 'GHC.Ptr.Ptr'  ---   It would not be required if _all_ qualifiers are scraped from ---   function specs, but we're keeping it around for backwards compatibility.--resolveQParams :: Bare.Env -> Bare.TycEnv -> ModName -> F.Qualifier -> Maybe F.Qualifier-resolveQParams env tycEnv name q = do-     qps   <- mapM goQP (F.qParams q)-     return $ q { F.qParams = qps }-  where-    goQP qp          = do { s <- go (F.qpSort qp) ; return qp { F.qpSort = s } }-    go               :: F.Sort -> Maybe F.Sort-    go (FAbs i s)    = FAbs i <$> go s-    go (FFunc s1 s2) = FFunc  <$> go s1 <*> go s2-    go (FApp  s1 s2) = FApp   <$> go s1 <*> go s2-    go (FTC c)       = qualifyFTycon env tycEnv name c-    go s             = Just s--qualifyFTycon :: Bare.Env -> Bare.TycEnv -> ModName -> F.FTycon -> Maybe F.Sort-qualifyFTycon env tycEnv name c-  | isPrimFTC           = Just (FTC c)-  | otherwise           = tyConSort embs . F.atLoc tcs <$> ty-  where-    ty                  = Bare.maybeResolveSym env name "qualify-FTycon" tcs-    isPrimFTC           = F.val tcs `elem` F.prims-    tcs                 = F.fTyconSymbol c-    embs                = Bare.tcEmbs tycEnv--tyConSort :: F.TCEmb Ghc.TyCon -> F.Located Ghc.TyCon -> F.Sort-tyConSort embs lc = Mb.maybe s0 fst (F.tceLookup c embs)-  where-    c             = F.val lc-    s0            = tyConSortRaw lc--tyConSortRaw :: F.Located Ghc.TyCon -> F.Sort-tyConSortRaw = FTC . F.symbolFTycon . fmap F.symbol---------------------------------------------------------------------------------------------makeSpecTerm :: Config -> Ms.BareSpec -> Bare.Env -> ModName ->-                Bare.Lookup GhcSpecTerm--------------------------------------------------------------------------------------------makeSpecTerm cfg mySpec env name = do-  sizes  <- if structuralTerm cfg then pure mempty else makeSize env name mySpec-  lazies <- makeLazy     env name mySpec-  autos  <- makeAutoSize env name mySpec-  decr   <- makeDecrs env name mySpec-  gfail  <- makeFail env name mySpec-  return  $ SpTerm-    { gsLazy       = S.insert dictionaryVar (lazies `mappend` sizes)-    , gsFail       = gfail-    , gsStTerm     = sizes-    , gsAutosize   = autos-    , gsDecr       = decr-    , gsNonStTerm  = mempty-    }---- formerly, makeHints-makeDecrs :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup [(Ghc.Var, [Int])]-makeDecrs env name mySpec =-  forM (Ms.decr mySpec) $ \(lx, z) -> do-    v <- Bare.lookupGhcVar env name "decreasing" lx-    return (v, z)--makeRelation :: Bare.Env -> ModName -> Bare.SigEnv ->-  [(LocSymbol, LocSymbol, LocBareType, LocBareType, RelExpr, RelExpr)] -> Bare.Lookup [(Ghc.Var, Ghc.Var, LocSpecType, LocSpecType, RelExpr, RelExpr)]-makeRelation env name sigEnv = mapM go- where-  go (x, y, tx, ty, a, e) = do-    vx <- Bare.lookupGhcVar env name "Var" x-    vy <- Bare.lookupGhcVar env name "Var" y-    return  -        ( vx-        , vy-        , Bare.cookSpecType env sigEnv name (Bare.HsTV vx) tx-        , Bare.cookSpecType env sigEnv name (Bare.HsTV vy) ty-        , a-        , e-        )---makeLazy :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup (S.HashSet Ghc.Var)-makeLazy env name spec =-  sMapM (Bare.lookupGhcVar env name "Var") (Ms.lazy spec)--makeFail :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup (S.HashSet (Located Ghc.Var))-makeFail env name spec =-  sForM (Ms.fails spec) $ \x -> do-    vx <- Bare.lookupGhcVar env name "Var" x-    return x { val = vx }--makeRewrite :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup (S.HashSet (Located Ghc.Var))-makeRewrite env name spec =-  sForM (Ms.rewrites spec) $ \x -> do-    vx <-  Bare.lookupGhcVar env name "Var" x-    return x { val = vx }--makeRewriteWith :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup (M.HashMap Ghc.Var [Ghc.Var])-makeRewriteWith env name spec = M.fromList <$> makeRewriteWith' env name spec--makeRewriteWith' :: Bare.Env -> ModName -> Spec ty bndr -> Bare.Lookup [(Ghc.Var, [Ghc.Var])]-makeRewriteWith' env name spec =-  forM (M.toList $ Ms.rewriteWith spec) $ \(x, xs) -> do-    xv  <- Bare.lookupGhcVar env name "Var1" x-    xvs <- mapM (Bare.lookupGhcVar env name "Var2") xs-    return (xv, xvs)--makeAutoSize :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup (S.HashSet Ghc.TyCon)-makeAutoSize env name-  = fmap S.fromList-  . mapM (Bare.lookupGhcTyCon env name "TyCon")-  . S.toList-  . Ms.autosize--makeSize :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup (S.HashSet Ghc.Var)-makeSize env name-  = fmap S.fromList-  . mapM (Bare.lookupGhcVar env name "Var")-  . Mb.mapMaybe getSizeFuns-  . Ms.dataDecls--getSizeFuns :: DataDecl -> Maybe LocSymbol-getSizeFuns decl-  | Just x       <- tycSFun decl-  , SymSizeFun f <- x-  = Just f-  | otherwise-  = Nothing----------------------------------------------------------------------------------------------makeSpecLaws :: Bare.Env -> Bare.SigEnv -> [(Ghc.Var,LocSpecType)] -> Bare.MeasEnv -> Bare.ModSpecs-             -> GhcSpecLaws--------------------------------------------------------------------------------------------makeSpecLaws env sigEnv sigs menv specs = SpLaws-  { gsLawDefs = second (map (\(_,x,y) -> (x,y))) <$> Bare.meCLaws menv-  , gsLawInst = Bare.makeInstanceLaws env sigEnv sigs specs-  }---------------------------------------------------------------------------------------------makeSpecRefl :: Config -> GhcSrc -> Bare.MeasEnv -> Bare.ModSpecs -> Bare.Env -> ModName -> GhcSpecSig -> Bare.TycEnv-             -> Bare.Lookup GhcSpecRefl--------------------------------------------------------------------------------------------makeSpecRefl cfg src menv specs env name sig tycEnv = do-  autoInst <- makeAutoInst env name mySpec-  rwr      <- makeRewrite env name mySpec-  rwrWith  <- makeRewriteWith env name mySpec-  wRefls   <- Bare.wiredReflects cfg env name sig-  xtes     <- Bare.makeHaskellAxioms cfg src env tycEnv name lmap sig mySpec-  let myAxioms =-        [ Bare.qualifyTop-            env-            name-            (F.loc lt)-            e {eqName = s, eqRec = S.member s (exprSymbolsSet (eqBody e))}-        | (x, lt, e) <- xtes-        , let s = symbol x-        ]-  let sigVars  = F.notracepp "SIGVARS" $ (fst3 <$> xtes)            -- reflects-                                      ++ (fst  <$> gsAsmSigs sig)   -- assumes-                                      ++ (fst  <$> gsRefSigs sig)-  return SpRefl-    { gsLogicMap   = lmap-    , gsAutoInst   = autoInst-    , gsImpAxioms  = concatMap (Ms.axeqs . snd) (M.toList specs)-    , gsMyAxioms   = F.notracepp "gsMyAxioms" myAxioms-    , gsReflects   = F.notracepp "gsReflects" (lawMethods ++ filter (isReflectVar rflSyms) sigVars ++ wRefls)-    , gsHAxioms    = F.notracepp "gsHAxioms" xtes-    , gsWiredReft  = wRefls-    , gsRewrites   = rwr-    , gsRewritesWith = rwrWith-    }-  where-    lawMethods   = F.notracepp "Law Methods" $ concatMap Ghc.classMethods (fst <$> Bare.meCLaws menv)-    mySpec       = M.lookupDefault mempty name specs-    rflSyms      = S.fromList (getReflects specs)-    lmap         = Bare.reLMap env--isReflectVar :: S.HashSet F.Symbol -> Ghc.Var -> Bool-isReflectVar reflSyms v = S.member vx reflSyms-  where-    vx                  = GM.dropModuleNames (symbol v)--getReflects :: Bare.ModSpecs -> [Symbol]-getReflects  = fmap val . S.toList . S.unions . fmap (names . snd) . M.toList-  where-    names  z = S.unions [ Ms.reflects z, Ms.inlines z, Ms.hmeas z ]----------------------------------------------------------------------------------------------- | @updateReflSpecSig@ uses the information about reflected functions to update the ---   "assumed" signatures. --------------------------------------------------------------------------------------------addReflSigs :: Bare.Env -> ModName -> BareRTEnv -> GhcSpecRefl -> GhcSpecSig -> GhcSpecSig--------------------------------------------------------------------------------------------addReflSigs env name rtEnv refl sig =-  sig { gsRefSigs = F.notracepp ("gsRefSigs for " ++ F.showpp name) $ map expandReflectedSignature reflSigs-      , gsAsmSigs = F.notracepp ("gsAsmSigs for " ++ F.showpp name) (wreflSigs ++ filter notReflected (gsAsmSigs sig))-      }-  where--    -- See T1738. We need to expand and qualify any reflected signature /here/, after any-    -- relevant binder has been detected and \"promoted\". The problem stems from the fact that any input-    -- 'BareSpec' will have a 'reflects' list of binders to reflect under the form of an opaque 'Var', that-    -- qualifyExpand can't touch when we do a first pass in 'makeGhcSpec0'. However, once we reflected all-    -- the functions, we are left with a pair (Var, LocSpecType). The latter /needs/ to be qualified and-    -- expanded again, for example in case it has expression aliases derived from 'inlines'.-    expandReflectedSignature :: (Ghc.Var, LocSpecType) -> (Ghc.Var, LocSpecType)-    expandReflectedSignature = fmap (Bare.qualifyExpand env name rtEnv (F.dummyPos "expand-refSigs") [])--    (wreflSigs, reflSigs)   = L.partition ((`elem` gsWiredReft refl) . fst)-                                 [ (x, t) | (x, t, _) <- gsHAxioms refl ]-    reflected       = fst <$> (wreflSigs ++ reflSigs)-    notReflected xt = fst xt `notElem` reflected--makeAutoInst :: Bare.Env -> ModName -> Ms.BareSpec ->-                Bare.Lookup (M.HashMap Ghc.Var (Maybe Int))-makeAutoInst env name spec = M.fromList <$> kvs-  where-    kvs = forM (M.toList (Ms.autois spec)) $ \(k, val) -> do-            vk <- Bare.lookupGhcVar env name "Var" k-            return (vk, val)--------------------------------------------------------------------------------------------makeSpecSig :: Config -> ModName -> Bare.ModSpecs -> Bare.Env -> Bare.SigEnv -> Bare.TycEnv -> Bare.MeasEnv -> [Ghc.CoreBind]-            -> Bare.Lookup GhcSpecSig------------------------------------------------------------------------------------------makeSpecSig cfg name specs env sigEnv tycEnv measEnv cbs = do-  mySigs     <- makeTySigs  env sigEnv name mySpec-  aSigs      <- F.notracepp ("makeSpecSig aSigs " ++ F.showpp name) $ makeAsmSigs env sigEnv name specs-  let asmSigs =  Bare.tcSelVars tycEnv-              ++ aSigs-              ++ [ (x,t) | (_, x, t) <- concatMap snd (Bare.meCLaws measEnv) ]-  let tySigs  = strengthenSigs . concat $-                  [ [(v, (0, t)) | (v, t,_) <- mySigs                         ]   -- NOTE: these weights are to priortize -                  , [(v, (1, t)) | (v, t  ) <- makeMthSigs measEnv            ]   -- user defined sigs OVER auto-generated -                  , [(v, (2, t)) | (v, t  ) <- makeInlSigs env rtEnv allSpecs ]   -- during the strengthening, i.e. to KEEP -                  , [(v, (3, t)) | (v, t  ) <- makeMsrSigs env rtEnv allSpecs ]   -- the binders used in USER-defined sigs -                  ]                                                               -- as they appear in termination metrics-  newTys     <-  makeNewTypes env sigEnv allSpecs-  relation   <-  makeRelation env name sigEnv (Ms.relational mySpec)-  asmRel     <-  makeRelation env name sigEnv (Ms.asmRel mySpec)-  return SpSig-    { gsTySigs   = tySigs-    , gsAsmSigs  = asmSigs-    , gsRefSigs  = []-    , gsDicts    = dicts-    -- , gsMethods  = if noclasscheck cfg then [] else Bare.makeMethodTypes dicts (Bare.meClasses  measEnv) cbs -    , gsMethods  = if noclasscheck cfg then [] else Bare.makeMethodTypes (typeclass cfg) dicts (Bare.meClasses  measEnv) cbs-    , gsInSigs   = mempty-    , gsNewTypes = newTys-    , gsTexprs   = [ (v, t, es) | (v, t, Just es) <- mySigs ]-    , gsRelation = relation-    , gsAsmRel   = asmRel-  }-  where-    dicts      = Bare.makeSpecDictionaries env sigEnv specs-    mySpec     = M.lookupDefault mempty name specs-    allSpecs   = M.toList specs-    rtEnv      = Bare.sigRTEnv sigEnv-    -- hmeas      = makeHMeas    env allSpecs --strengthenSigs :: [(Ghc.Var, (Int, LocSpecType))] ->[(Ghc.Var, LocSpecType)]-strengthenSigs sigs = go <$> Misc.groupList sigs-  where-    go (v, ixs)     = (v,) $ L.foldl1' (flip meetLoc) (F.notracepp ("STRENGTHEN-SIGS: " ++ F.showpp v) (prio ixs))-    prio            = fmap snd . Misc.sortOn fst-    meetLoc         :: LocSpecType -> LocSpecType -> LocSpecType-    meetLoc t1 t2   = t1 {val = val t1 `F.meet` val t2}--makeMthSigs :: Bare.MeasEnv -> [(Ghc.Var, LocSpecType)]-makeMthSigs measEnv = [ (v, t) | (_, v, t) <- Bare.meMethods measEnv ]--makeInlSigs :: Bare.Env -> BareRTEnv -> [(ModName, Ms.BareSpec)] -> [(Ghc.Var, LocSpecType)]-makeInlSigs env rtEnv-  = makeLiftedSigs rtEnv (CoreToLogic.inlineSpecType (typeclass (getConfig env)))-  . makeFromSet "hinlines" Ms.inlines env--makeMsrSigs :: Bare.Env -> BareRTEnv -> [(ModName, Ms.BareSpec)] -> [(Ghc.Var, LocSpecType)]-makeMsrSigs env rtEnv-  = makeLiftedSigs rtEnv (CoreToLogic.inlineSpecType (typeclass (getConfig env)))-  . makeFromSet "hmeas" Ms.hmeas env--makeLiftedSigs :: BareRTEnv -> (Ghc.Var -> SpecType) -> [Ghc.Var] -> [(Ghc.Var, LocSpecType)]-makeLiftedSigs rtEnv f xs-  = [(x, lt) | x <- xs-             , let lx = GM.locNamedThing x-             , let lt = expand $ lx {val = f x}-    ]-  where-    expand   = Bare.specExpandType rtEnv--makeFromSet :: String -> (Ms.BareSpec -> S.HashSet LocSymbol) -> Bare.Env -> [(ModName, Ms.BareSpec)]-            -> [Ghc.Var]-makeFromSet msg f env specs = concat [ mk n xs | (n, s) <- specs, let xs = S.toList (f s)]-  where-    mk name                 = Mb.mapMaybe (Bare.maybeResolveSym env name msg)--makeTySigs :: Bare.Env -> Bare.SigEnv -> ModName -> Ms.BareSpec-           -> Bare.Lookup [(Ghc.Var, LocSpecType, Maybe [Located F.Expr])]-makeTySigs env sigEnv name spec = do-  bareSigs   <- bareTySigs env name                spec-  expSigs    <- makeTExpr  env name bareSigs rtEnv spec-  let rawSigs = Bare.resolveLocalBinds env expSigs-  return [ (x, cook x bt, z) | (x, bt, z) <- rawSigs ]-  where-    rtEnv     = Bare.sigRTEnv sigEnv-    cook x bt = Bare.cookSpecType env sigEnv name (Bare.HsTV x) bt--bareTySigs :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup [(Ghc.Var, LocBareType)]-bareTySigs env name spec = checkDuplicateSigs <$> vts-  where-    vts = forM ( Ms.sigs spec ++ Ms.localSigs spec ) $ \ (x, t) -> do-            v <- F.notracepp "LOOKUP-GHC-VAR" $ Bare.lookupGhcVar env name "rawTySigs" x-            return (v, t)---- checkDuplicateSigs :: [(Ghc.Var, LocSpecType)] -> [(Ghc.Var, LocSpecType)] -checkDuplicateSigs :: (Symbolic x) => [(x, F.Located t)] -> [(x, F.Located t)]-checkDuplicateSigs xts = case Misc.uniqueByKey symXs  of-  Left (k, ls) -> uError (errDupSpecs (pprint k) (GM.sourcePosSrcSpan <$> ls))-  Right _      -> xts-  where-    symXs = [ (F.symbol x, F.loc t) | (x, t) <- xts ]---makeAsmSigs :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.ModSpecs -> Bare.Lookup [(Ghc.Var, LocSpecType)]-makeAsmSigs env sigEnv myName specs = do-  raSigs <- rawAsmSigs env myName specs-  return [ (x, t) | (name, x, bt) <- raSigs, let t = Bare.cookSpecType env sigEnv name (Bare.LqTV x) bt ]--rawAsmSigs :: Bare.Env -> ModName -> Bare.ModSpecs -> Bare.Lookup [(ModName, Ghc.Var, LocBareType)]-rawAsmSigs env myName specs = do-  aSigs <- allAsmSigs env myName specs-  return [ (m, v, t) | (v, sigs) <- aSigs, let (m, t) = myAsmSig v sigs ]--myAsmSig :: Ghc.Var -> [(Bool, ModName, LocBareType)] -> (ModName, LocBareType)-myAsmSig v sigs = Mb.fromMaybe errImp (Misc.firstMaybes [mbHome, mbImp])-  where-    mbHome      = takeUnique mkErr                  sigsHome-    mbImp       = takeUnique mkErr (Misc.firstGroup sigsImp) -- see [NOTE:Prioritize-Home-Spec] -    sigsHome    = [(m, t)      | (True,  m, t) <- sigs ]-    sigsImp     = F.notracepp ("SIGS-IMP: " ++ F.showpp v)-                  [(d, (m, t)) | (False, m, t) <- sigs, let d = nameDistance vName m]-    mkErr ts    = ErrDupSpecs (Ghc.getSrcSpan v) (F.pprint v) (GM.sourcePosSrcSpan . F.loc . snd <$> ts) :: UserError-    errImp      = impossible Nothing "myAsmSig: cannot happen as sigs is non-null"-    vName       = GM.takeModuleNames (F.symbol v)--makeTExpr :: Bare.Env -> ModName -> [(Ghc.Var, LocBareType)] -> BareRTEnv -> Ms.BareSpec-          -> Bare.Lookup [(Ghc.Var, LocBareType, Maybe [Located F.Expr])]-makeTExpr env name tySigs rtEnv spec = do-  vExprs       <- M.fromList <$> makeVarTExprs env name spec-  let vSigExprs = Misc.hashMapMapWithKey (\v t -> (t, M.lookup v vExprs)) vSigs-  return [ (v, t, qual t <$> es) | (v, (t, es)) <- M.toList vSigExprs ]-  where-    qual t es   = qualifyTermExpr env name rtEnv t <$> es-    vSigs       = M.fromList tySigs--qualifyTermExpr :: Bare.Env -> ModName -> BareRTEnv -> LocBareType -> Located F.Expr-                -> Located F.Expr-qualifyTermExpr env name rtEnv t le-        = F.atLoc le (Bare.qualifyExpand env name rtEnv l bs e)-  where-    l   = F.loc le-    e   = F.val le-    bs  = ty_binds . toRTypeRep . val $ t--makeVarTExprs :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup [(Ghc.Var, [Located F.Expr])]-makeVarTExprs env name spec =-  forM (Ms.termexprs spec) $ \(x, es) -> do-    vx <- Bare.lookupGhcVar env name "Var" x-    return (vx, es)--------------------------------------------------------------------------------------------- [NOTE:Prioritize-Home-Spec] Prioritize spec for THING defined in --- `Foo.Bar.Baz.Quux.x` over any other specification, IF GHC's --- fully qualified name for THING is `Foo.Bar.Baz.Quux.x`. ------ For example, see tests/names/neg/T1078.hs for example, --- which assumes a spec for `head` defined in both --- ---   (1) Data/ByteString.spec---   (2) Data/ByteString/Char8.spec --- --- We end up resolving the `head` in (1) to the @Var@ `Data.ByteString.Char8.head` --- even though there is no exact match, just to account for re-exports of "internal"--- modules and such (see `Resolve.matchMod`). However, we should pick the closer name--- if its available.------------------------------------------------------------------------------------------nameDistance :: F.Symbol -> ModName -> Int-nameDistance vName tName-  | vName == F.symbol tName = 0-  | otherwise               = 1---takeUnique :: Ex.Exception e => ([a] -> e) -> [a] -> Maybe a-takeUnique _ []  = Nothing-takeUnique _ [x] = Just x-takeUnique f xs  = Ex.throw (f xs)--allAsmSigs :: Bare.Env -> ModName -> Bare.ModSpecs ->-              Bare.Lookup [(Ghc.Var, [(Bool, ModName, LocBareType)])]-allAsmSigs env myName specs = do-  let aSigs = [ (name, must, x, t) | (name, spec) <- M.toList specs-                                   , (must, x, t) <- getAsmSigs myName name spec ]-  vSigs    <- forM aSigs $ \(name, must, x, t) -> do-                vMb <- resolveAsmVar env name must x-                return (vMb, (must, name, t))-  return    $ Misc.groupList [ (v, z) | (Just v, z) <- vSigs ]--resolveAsmVar :: Bare.Env -> ModName -> Bool -> LocSymbol -> Bare.Lookup (Maybe Ghc.Var)-resolveAsmVar env name True  lx = Just  <$> Bare.lookupGhcVar env name "resolveAsmVar-True"  lx-resolveAsmVar env name False lx = return $  Bare.maybeResolveSym     env name "resolveAsmVar-False" lx  <|> GM.maybeAuxVar (F.val lx)---getAsmSigs :: ModName -> ModName -> Ms.BareSpec -> [(Bool, LocSymbol, LocBareType)]-getAsmSigs myName name spec-  | myName == name = [ (True,  x,  t) | (x, t) <- Ms.asmSigs spec ] -- MUST    resolve, or error-  | otherwise      = [ (False, x', t) | (x, t) <- Ms.asmSigs spec-                                                  ++ Ms.sigs spec-                                      , let x' = qSym x           ]  -- MAY-NOT resolve-  where-    qSym           = fmap (GM.qualifySymbol ns)-    ns             = F.symbol name---- TODO-REBARE: grepClassAssumes-_grepClassAssumes :: [RInstance t] -> [(Located F.Symbol, t)]-_grepClassAssumes  = concatMap go-  where-    go    xts              = Mb.mapMaybe goOne (risigs xts)-    goOne (x, RIAssumed t) = Just (fmap (F.symbol . (".$c" ++ ) . F.symbolString) x, t)-    goOne (_, RISig _)     = Nothing--makeSigEnv :: F.TCEmb Ghc.TyCon -> Bare.TyConMap -> S.HashSet StableName -> BareRTEnv -> Bare.SigEnv-makeSigEnv embs tyi exports rtEnv = Bare.SigEnv-  { sigEmbs     = embs-  , sigTyRTyMap = tyi-  , sigExports  = exports-  , sigRTEnv    = rtEnv-  }--makeNewTypes :: Bare.Env -> Bare.SigEnv -> [(ModName, Ms.BareSpec)] ->-                Bare.Lookup [(Ghc.TyCon, LocSpecType)]-makeNewTypes env sigEnv specs = do-  fmap concat $-    forM nameDecls $ uncurry (makeNewType env sigEnv)-  where-    nameDecls = [(name, d) | (name, spec) <- specs, d <- Ms.newtyDecls spec]--makeNewType :: Bare.Env -> Bare.SigEnv -> ModName -> DataDecl ->-               Bare.Lookup [(Ghc.TyCon, LocSpecType)]-makeNewType env sigEnv name d = do-  tcMb <- Bare.lookupGhcDnTyCon env name "makeNewType" tcName-  case tcMb of-    Just tc -> return [(tc, lst)]-    _       -> return []-  where-    tcName                    = tycName d-    lst                       = Bare.cookSpecType env sigEnv name Bare.GenTV bt-    bt                        = getTy tcName (tycSrcPos d) (Mb.fromMaybe [] (tycDCons d))-    getTy _ l [c]-      | [(_, t)] <- dcFields c = Loc l l t-    getTy n l _                = Ex.throw (mkErr n l)-    mkErr n l                  = ErrOther (GM.sourcePosSrcSpan l) ("Bad new type declaration:" <+> F.pprint n) :: UserError---------------------------------------------------------------------------------------------makeSpecData :: GhcSrc -> Bare.Env -> Bare.SigEnv -> Bare.MeasEnv -> GhcSpecSig -> Bare.ModSpecs-             -> GhcSpecData--------------------------------------------------------------------------------------------makeSpecData src env sigEnv measEnv sig specs = SpData-  { gsCtors      = F.notracepp "GS-CTORS"-                   [ (x, if allowTC then t else tt)-                       | (x, t) <- Bare.meDataCons measEnv-                       , let tt  = Bare.plugHoles (typeclass $ getConfig env) sigEnv name (Bare.LqTV x) t-                   ]-  , gsMeas       = [ (F.symbol x, uRType <$> t) | (x, t) <- measVars ]-  , gsMeasures   = Bare.qualifyTopDummy env name <$> (ms1 ++ ms2)-  , gsInvariants = Misc.nubHashOn (F.loc . snd) invs-  , gsIaliases   = concatMap (makeIAliases env sigEnv) (M.toList specs)-  , gsUnsorted   = usI ++ concatMap msUnSorted (concatMap measures specs)-  }-  where-    allowTC      = typeclass (getConfig env)-    measVars     = Bare.meSyms      measEnv -- ms'-                ++ Bare.meClassSyms measEnv -- cms' -                ++ Bare.varMeasures env-    measuresSp   = Bare.meMeasureSpec measEnv-    ms1          = M.elems (Ms.measMap measuresSp)-    ms2          = Ms.imeas   measuresSp-    mySpec       = M.lookupDefault mempty name specs-    name         = _giTargetMod      src-    (minvs,usI)  = makeMeasureInvariants env name sig mySpec-    invs         = minvs ++ concatMap (makeInvariants env sigEnv) (M.toList specs)--makeIAliases :: Bare.Env -> Bare.SigEnv -> (ModName, Ms.BareSpec) -> [(LocSpecType, LocSpecType)]-makeIAliases env sigEnv (name, spec)-  = [ z | Right z <- mkIA <$> Ms.ialiases spec ]-  where-    -- mkIA :: (LocBareType, LocBareType) -> Either _ (LocSpecType, LocSpecType)-    mkIA (t1, t2) = (,) <$> mkI' t1 <*> mkI' t2-    mkI'          = Bare.cookSpecTypeE env sigEnv name Bare.GenTV--makeInvariants :: Bare.Env -> Bare.SigEnv -> (ModName, Ms.BareSpec) -> [(Maybe Ghc.Var, Located SpecType)]-makeInvariants env sigEnv (name, spec) =-  [ (Nothing, t)-    | (_, bt) <- Ms.invariants spec-    , Bare.knownGhcType env name bt-    , let t = Bare.cookSpecType env sigEnv name Bare.GenTV bt-  ] ++-  concat [ (Nothing,) . makeSizeInv l <$>  ts-    | (bts, l) <- Ms.dsize spec-    , all (Bare.knownGhcType env name) bts-    , let ts = Bare.cookSpecType env sigEnv name Bare.GenTV <$> bts-  ]--makeSizeInv :: F.LocSymbol -> Located SpecType -> Located SpecType-makeSizeInv s lst = lst{val = go (val lst)}-  where go (RApp c ts rs r) = RApp c ts rs (r `meet` nat)-        go (RAllT a t r)    = RAllT a (go t) r-        go t = t-        nat  = MkUReft (Reft (vv_, PAtom Le (ECon $ I 0) (EApp (EVar $ val s) (eVar vv_))))-                       mempty--makeMeasureInvariants :: Bare.Env -> ModName -> GhcSpecSig -> Ms.BareSpec-                      -> ([(Maybe Ghc.Var, LocSpecType)], [UnSortedExpr])-makeMeasureInvariants env name sig mySpec-  = mapSnd Mb.catMaybes $-    unzip (measureTypeToInv env name <$> [(x, (y, ty)) | x <- xs, (y, ty) <- sigs-                                         , isSymbolOfVar (val x) y ])-  where-    sigs = gsTySigs sig-    xs   = S.toList (Ms.hmeas  mySpec)--isSymbolOfVar :: Symbol -> Ghc.Var -> Bool-isSymbolOfVar x v = x == symbol' v-  where-    symbol' :: Ghc.Var -> Symbol-    symbol' = GM.dropModuleNames . symbol . Ghc.getName--measureTypeToInv :: Bare.Env -> ModName -> (LocSymbol, (Ghc.Var, LocSpecType)) -> ((Maybe Ghc.Var, LocSpecType), Maybe UnSortedExpr)-measureTypeToInv env name (x, (v, t))-  = notracepp "measureTypeToInv" ((Just v, t {val = Bare.qualifyTop env name (F.loc x) mtype}), usorted)-  where-    trep = toRTypeRep (val t)-    rts  = ty_args  trep-    args = ty_binds trep-    res  = ty_res   trep-    z    = last args-    tz   = last rts-    usorted = if isSimpleADT tz then Nothing else mapFst (:[]) <$> mkReft (dummyLoc $ F.symbol v) z tz res-    mtype-      | null rts-      = uError $ ErrHMeas (GM.sourcePosSrcSpan $ loc t) (pprint x) "Measure has no arguments!"-      | otherwise-      = mkInvariant x z tz res-    isSimpleADT (RApp _ ts _ _) = all isRVar ts-    isSimpleADT _               = False--mkInvariant :: LocSymbol -> Symbol -> SpecType -> SpecType -> SpecType-mkInvariant x z t tr = strengthen (top <$> t) (MkUReft reft' mempty)-      where-        reft' = Mb.maybe mempty Reft mreft-        mreft = mkReft x z t tr---mkReft :: LocSymbol -> Symbol -> SpecType -> SpecType -> Maybe (Symbol, Expr)-mkReft x z _t tr-  | Just q <- stripRTypeBase tr-  = let Reft (v, p) = toReft q-        su          = mkSubst [(v, mkEApp x [EVar v]), (z,EVar v)]-        -- p'          = pAnd $ filter (\e -> z `notElem` syms e) $ conjuncts p-    in  Just (v, subst su p)-mkReft _ _ _ _-  = Nothing----- REBARE: formerly, makeGhcSpec3---------------------------------------------------------------------------------------------makeSpecName :: Bare.Env -> Bare.TycEnv -> Bare.MeasEnv -> ModName -> GhcSpecNames---------------------------------------------------------------------------------------------makeSpecName env tycEnv measEnv name = SpNames-  { gsFreeSyms = Bare.reSyms env-  , gsDconsP   = [ F.atLoc dc (dcpCon dc) | dc <- datacons ++ cls ]-  , gsTconsP   = Bare.qualifyTopDummy env name <$> tycons-  -- , gsLits = mempty                                              -- TODO-REBARE, redundant with gsMeas-  , gsTcEmbeds = Bare.tcEmbs     tycEnv-  , gsADTs     = Bare.tcAdts     tycEnv-  , gsTyconEnv = Bare.tcTyConMap tycEnv-  }-  where-    datacons, cls :: [DataConP]-    datacons   = Bare.tcDataCons tycEnv-    cls        = F.notracepp "meClasses" $ Bare.meClasses measEnv-    tycons     = Bare.tcTyCons   tycEnv----- REBARE: formerly, makeGhcCHOP1--- split into two to break circular dependency. we need dataconmap for core2logic---------------------------------------------------------------------------------------------makeTycEnv0 :: Config -> ModName -> Bare.Env -> TCEmb Ghc.TyCon -> Ms.BareSpec -> Bare.ModSpecs-           -> (Diagnostics,  [Located DataConP], Bare.TycEnv)---------------------------------------------------------------------------------------------makeTycEnv0 cfg myName env embs mySpec iSpecs = (diag0 <> diag1, datacons, Bare.TycEnv-  { tcTyCons      = tycons-  , tcDataCons    = mempty -- val <$> datacons -  , tcSelMeasures = dcSelectors-  , tcSelVars     = mempty -- recSelectors            -  , tcTyConMap    = tyi-  , tcAdts        = adts-  , tcDataConMap  = dm-  , tcEmbs        = embs-  , tcName        = myName-  })-  where-    (tcDds, dcs)   = conTys-    (diag0, conTys) = withDiagnostics $ Bare.makeConTypes myName env specs-    specs         = (myName, mySpec) : M.toList iSpecs-    tcs           = Misc.snd3 <$> tcDds-    tyi           = Bare.qualifyTopDummy env myName (makeTyConInfo embs fiTcs tycons)-    -- tycons        = F.tracepp "TYCONS" $ Misc.replaceWith tcpCon tcs wiredTyCons-    -- datacons      =  Bare.makePluggedDataCons embs tyi (Misc.replaceWith (dcpCon . val) (F.tracepp "DATACONS" $ concat dcs) wiredDataCons)-    tycons        = tcs ++ knownWiredTyCons env myName-    datacons      = Bare.makePluggedDataCon (typeclass cfg) embs tyi <$> (concat dcs ++ knownWiredDataCons env myName)-    tds           = [(name, tcpCon tcp, dd) | (name, tcp, Just dd) <- tcDds]-    (diag1, adts) = Bare.makeDataDecls cfg embs myName tds       datacons-    dm            = Bare.dataConMap adts-    dcSelectors   = concatMap (Bare.makeMeasureSelectors cfg dm) (if reflection cfg then charDataCon:datacons else datacons)-    fiTcs         = _gsFiTcs (Bare.reSrc env)----makeTycEnv1 ::-     ModName-  -> Bare.Env-  -> (Bare.TycEnv, [Located DataConP])-  -> (Ghc.CoreExpr -> F.Expr)-  -> (Ghc.CoreExpr -> Ghc.TcRn Ghc.CoreExpr)-  -> Ghc.TcRn Bare.TycEnv-makeTycEnv1 myName env (tycEnv, datacons) coreToLg simplifier = do-  -- fst for selector generation, snd for dataconsig generation-  lclassdcs <- forM classdcs $ traverse (Bare.elaborateClassDcp coreToLg simplifier)-  let recSelectors = Bare.makeRecordSelectorSigs env myName (dcs ++ (fmap . fmap) snd lclassdcs)-  pure $-    tycEnv {Bare.tcSelVars = recSelectors, Bare.tcDataCons = F.val <$> ((fmap . fmap) fst lclassdcs ++ dcs )}-  where-    (classdcs, dcs) =-      L.partition-        (Ghc.isClassTyCon . Ghc.dataConTyCon . dcpCon . F.val) datacons---knownWiredDataCons :: Bare.Env -> ModName -> [Located DataConP]-knownWiredDataCons env name = filter isKnown wiredDataCons-  where-    isKnown                 = Bare.knownGhcDataCon env name . GM.namedLocSymbol . dcpCon . val--knownWiredTyCons :: Bare.Env -> ModName -> [TyConP]-knownWiredTyCons env name = filter isKnown wiredTyCons-  where-    isKnown               = Bare.knownGhcTyCon env name . GM.namedLocSymbol . tcpCon----- REBARE: formerly, makeGhcCHOP2---------------------------------------------------------------------------------------------makeMeasEnv :: Bare.Env -> Bare.TycEnv -> Bare.SigEnv -> Bare.ModSpecs ->-               Bare.Lookup Bare.MeasEnv---------------------------------------------------------------------------------------------makeMeasEnv env tycEnv sigEnv specs = do-  laws        <- Bare.makeCLaws env sigEnv name specs-  (cls, mts)  <- Bare.makeClasses        env sigEnv name specs-  let dms      = Bare.makeDefaultMethods env mts-  measures0   <- mapM (Bare.makeMeasureSpec env sigEnv name) (M.toList specs)-  let measures = mconcat (Ms.mkMSpec' dcSelectors : measures0)-  let (cs, ms) = Bare.makeMeasureSpec'  (typeclass $ getConfig env)   measures-  let cms      = Bare.makeClassMeasureSpec measures-  let cms'     = [ (x, Loc l l' $ cSort t)  | (Loc l l' x, t) <- cms ]-  let ms'      = [ (F.val lx, F.atLoc lx t) | (lx, t) <- ms-                                            , Mb.isNothing (lookup (val lx) cms') ]-  let cs'      = [ (v, txRefs v t) | (v, t) <- Bare.meetDataConSpec (typeclass (getConfig env)) embs cs (datacons ++ cls)]-  return Bare.MeasEnv-    { meMeasureSpec = measures-    , meClassSyms   = cms'-    , meSyms        = ms'-    , meDataCons    = cs'-    , meClasses     = cls-    , meMethods     = mts ++ dms-    , meCLaws       = laws-    }-  where-    txRefs v t    = Bare.txRefSort tyi embs (t <$ GM.locNamedThing v)-    tyi           = Bare.tcTyConMap    tycEnv-    dcSelectors   = Bare.tcSelMeasures tycEnv-    datacons      = Bare.tcDataCons    tycEnv-    embs          = Bare.tcEmbs        tycEnv-    name          = Bare.tcName        tycEnv---------------------------------------------------------------------------------------------- | @makeLiftedSpec@ is used to generate the BareSpec object that should be serialized ---   so that downstream files that import this target can access the lifted definitions, ---   e.g. for measures, reflected functions etc.-------------------------------------------------------------------------------------------makeLiftedSpec :: ModName -> GhcSrc -> Bare.Env-               -> GhcSpecRefl -> GhcSpecData -> GhcSpecSig -> GhcSpecQual -> BareRTEnv-               -> Ms.BareSpec -> Ms.BareSpec-------------------------------------------------------------------------------------------makeLiftedSpec name src _env refl sData sig qual myRTE lSpec0 = lSpec0-  { Ms.asmSigs    = F.notracepp   ("makeLiftedSpec : ASSUMED-SIGS " ++ F.showpp name ) (xbs ++ myDCs)-  , Ms.reflSigs   = F.notracepp "REFL-SIGS"         xbs-  , Ms.sigs       = F.notracepp   ("makeLiftedSpec : LIFTED-SIGS " ++ F.showpp name )  $ mkSigs (gsTySigs sig)-  , Ms.invariants = [ (varLocSym <$> x, Bare.specToBare <$> t)-                       | (x, t) <- gsInvariants sData-                       , isLocInFile srcF t-                    ]-  , Ms.axeqs      = gsMyAxioms refl-  , Ms.aliases    = F.notracepp "MY-ALIASES" $ M.elems . typeAliases $ myRTE-  , Ms.ealiases   = M.elems . exprAliases $ myRTE-  , Ms.qualifiers = filter (isLocInFile srcF) (gsQualifiers qual)-  }-  where-    myDCs         = [(x,t) | (x,t) <- mkSigs (gsCtors sData)-                           , F.symbol name == fst (GM.splitModuleName $ val x)]-    mkSigs xts    = [ toBare (x, t) | (x, t) <- xts-                    ,  S.member x sigVars && isExportedVar (view targetSrcIso src) x-                    ]-    toBare (x, t) = (varLocSym x, Bare.specToBare <$> t)-    xbs           = toBare <$> reflTySigs-    sigVars       = S.difference defVars reflVars-    defVars       = S.fromList (_giDefVars src)-    reflTySigs    = [(x, t) | (x,t,_) <- gsHAxioms refl, x `notElem` gsWiredReft refl]-    reflVars      = S.fromList (fst <$> reflTySigs)-    -- myAliases fld = M.elems . fld $ myRTE -    srcF          = _giTarget src---- | Returns 'True' if the input determines a location within the input file. Due to the fact we might have--- Haskell sources which have \"companion\" specs defined alongside them, we also need to account for this--- case, by stripping out the extensions and check that the LHS is a Haskell source and the RHS a spec file.-isLocInFile :: (F.Loc a) => FilePath -> a ->  Bool-isLocInFile f lx = f == lifted || isCompanion-  where-    lifted :: FilePath-    lifted = locFile lx--    isCompanion :: Bool-    isCompanion =-      (==) (dropExtension f) (dropExtension lifted)-       &&  isExtFile Hs f-       &&  isExtFile Files.Spec lifted--locFile :: (F.Loc a) => a -> FilePath-locFile = Misc.fst3 . F.sourcePosElts . F.sp_start . F.srcSpan--varLocSym :: Ghc.Var -> LocSymbol-varLocSym v = F.symbol <$> GM.locNamedThing v---- makeSpecRTAliases :: Bare.Env -> BareRTEnv -> [Located SpecRTAlias]--- makeSpecRTAliases _env _rtEnv = [] -- TODO-REBARE -------------------------------------------------------------------------------------- | @myRTEnv@ slices out the part of RTEnv that was generated by aliases defined ---   in the _target_ file, "cooks" the aliases (by conversion to SpecType), and ---   then saves them back as BareType.----------------------------------------------------------------------------------myRTEnv :: GhcSrc -> Bare.Env -> Bare.SigEnv -> BareRTEnv -> BareRTEnv-myRTEnv src env sigEnv rtEnv = mkRTE tAs' eAs-  where-    tAs'                     = normalizeBareAlias env sigEnv name <$> tAs-    tAs                      = myAliases typeAliases-    eAs                      = myAliases exprAliases-    myAliases fld            = filter (isLocInFile srcF) . M.elems . fld $ rtEnv-    srcF                     = _giTarget    src-    name                     = _giTargetMod src--mkRTE :: [Located (RTAlias x a)] -> [Located (RTAlias F.Symbol F.Expr)] -> RTEnv x a-mkRTE tAs eAs   = RTE-  { typeAliases = M.fromList [ (aName a, a) | a <- tAs ]-  , exprAliases = M.fromList [ (aName a, a) | a <- eAs ]-  }-  where aName   = rtName . F.val--normalizeBareAlias :: Bare.Env -> Bare.SigEnv -> ModName -> Located BareRTAlias-                   -> Located BareRTAlias-normalizeBareAlias env sigEnv name lx = fixRTA <$> lx-  where-    fixRTA  :: BareRTAlias -> BareRTAlias-    fixRTA  = mapRTAVars fixArg . fmap fixBody--    fixArg  :: Symbol -> Symbol-    fixArg  = F.symbol . GM.symbolTyVar--    fixBody :: BareType -> BareType-    fixBody = Bare.specToBare-            . F.val-            . Bare.cookSpecType env sigEnv name Bare.RawTV-            . F.atLoc lx---withDiagnostics :: (Monoid a) => Bare.Lookup a -> (Diagnostics, a)-withDiagnostics (Left es) = (mkDiagnostics [] es, mempty)-withDiagnostics (Right v) = (emptyDiagnostics, v)
− src/Language/Haskell/Liquid/Bare/Axiom.hs 
@@ -1,264 +0,0 @@-{-# LANGUAGE OverloadedStrings    #-}-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE FlexibleInstances    #-}---- | This module contains the code that DOES reflection; i.e. converts Haskell---   definitions into refinements.--module Language.Haskell.Liquid.Bare.Axiom ( makeHaskellAxioms, wiredReflects ) where--import Prelude hiding (error)-import Prelude hiding (mapM)-import qualified Control.Exception         as Ex---- import           Control.Monad.Except      hiding (forM, mapM)--- import           Control.Monad.State       hiding (forM, mapM)-import qualified Text.PrettyPrint.HughesPJ as PJ -- (text)-import qualified Data.HashSet              as S-import qualified Data.Maybe                as Mb-import Control.Monad.Trans.State.Lazy (runState, get, put)--import           Language.Fixpoint.Misc-import qualified Language.Haskell.Liquid.Measure as Ms-import qualified Language.Fixpoint.Types as F-import qualified Liquid.GHC.API as Ghc-import qualified Liquid.GHC.Misc as GM-import           Language.Haskell.Liquid.Types.RefType-import           Language.Haskell.Liquid.Transforms.CoreToLogic-import           Liquid.GHC.Misc-import           Language.Haskell.Liquid.Types--import           Language.Haskell.Liquid.Bare.Resolve as Bare-import           Language.Haskell.Liquid.Bare.Types   as Bare--------------------------------------------------------------------------------------------------makeHaskellAxioms :: Config -> GhcSrc -> Bare.Env -> Bare.TycEnv -> ModName -> LogicMap -> GhcSpecSig -> Ms.BareSpec-                  -> Bare.Lookup [(Ghc.Var, LocSpecType, F.Equation)]-------------------------------------------------------------------------------------------------makeHaskellAxioms cfg src env tycEnv name lmap spSig spec = do-  wiDefs     <- wiredDefs cfg env name spSig-  let refDefs = getReflectDefs src spSig spec-  return (makeAxiom env tycEnv name lmap <$> (wiDefs ++ refDefs))--getReflectDefs :: GhcSrc -> GhcSpecSig -> Ms.BareSpec-               -> [(LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr)]-getReflectDefs src sig spec = findVarDefType cbs sigs <$> xs-  where-    sigs                    = gsTySigs sig-    xs                      = S.toList (Ms.reflects spec)-    cbs                     = _giCbs src--findVarDefType :: [Ghc.CoreBind] -> [(Ghc.Var, LocSpecType)] -> LocSymbol-               -> (LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr)-findVarDefType cbs sigs x = case findVarDefMethod (val x) cbs of-  -- YL: probably ok even without checking typeclass flag since user cannot-  -- manually reflect internal names-  Just (v, e) -> if GM.isExternalId v || isMethod (F.symbol x) || isDictionary (F.symbol x)-                   then (x, val <$> lookup v sigs, v, e)-                   else Ex.throw $ mkError x ("Lifted functions must be exported; please export " ++ show v)-  Nothing     -> Ex.throw $ mkError x "Cannot lift haskell function"-----------------------------------------------------------------------------------makeAxiom :: Bare.Env -> Bare.TycEnv -> ModName -> LogicMap-          -> (LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr)-          -> (Ghc.Var, LocSpecType, F.Equation)----------------------------------------------------------------------------------makeAxiom env tycEnv name lmap (x, mbT, v, def)-            = (v, t, e)-  where-    t       = Bare.qualifyTop env name (F.loc t0) t0-    (t0, e) = makeAssumeType allowTC embs lmap dm x mbT v def-    embs    = Bare.tcEmbs       tycEnv-    dm      = Bare.tcDataConMap tycEnv-    allowTC = typeclass (getConfig env)--mkError :: LocSymbol -> String -> Error-mkError x str = ErrHMeas (sourcePosSrcSpan $ loc x) (pprint $ val x) (PJ.text str)--makeAssumeType-  :: Bool -- ^ typeclass enabled-  -> F.TCEmb Ghc.TyCon -> LogicMap -> DataConMap -> LocSymbol -> Maybe SpecType-  -> Ghc.Var -> Ghc.CoreExpr-  -> (LocSpecType, F.Equation)-makeAssumeType allowTC tce lmap dm sym mbT v def-  = (sym {val = aty at `strengthenRes` F.subst su ref},  F.mkEquation (val sym) xts (F.subst su le) out)-  where-    rt    = fromRTypeRep .-            (\trep@RTypeRep{..} ->-                trep{ty_info = fmap (\rinfo -> rinfo{permitTC = Just allowTC}) ty_info}) .-            toRTypeRep $ Mb.fromMaybe (ofType τ) mbT-    τ     = Ghc.varType v-    at    = axiomType allowTC sym rt-    out   = rTypeSort tce $ ares at-    xArgs = F.EVar . fst <$> aargs at-    _msg  = unwords [showpp sym, showpp mbT]-    le    = case runToLogicWithBoolBinds bbs tce lmap dm mkErr (coreToLogic allowTC def') of-              Right e -> e-              Left  e -> panic Nothing (show e)-    ref        = F.Reft (F.vv_, F.PAtom F.Eq (F.EVar F.vv_) le)-    mkErr s    = ErrHMeas (sourcePosSrcSpan $ loc sym) (pprint $ val sym) (PJ.text s)-    bbs        = filter isBoolBind xs-    (xs, def') = GM.notracePpr "grabBody" $ grabBody allowTC (Ghc.expandTypeSynonyms τ) $ normalize allowTC def-    su         = F.mkSubst  $ zip (F.symbol     <$> xs) xArgs-                           ++ zip (simplesymbol <$> xs) xArgs-    xts        = [(F.symbol x, rTypeSortExp tce t) | (x, t) <- aargs at]--rTypeSortExp :: F.TCEmb Ghc.TyCon -> SpecType -> F.Sort-rTypeSortExp tce = typeSort tce . Ghc.expandTypeSynonyms . toType False--grabBody :: Bool -- ^ typeclass enabled-         -> Ghc.Type -> Ghc.CoreExpr -> ([Ghc.Var], Ghc.CoreExpr)-grabBody allowTC (Ghc.ForAllTy _ ty) e-  = grabBody allowTC ty e-grabBody allowTC@False Ghc.FunTy{ Ghc.ft_arg = tx, Ghc.ft_res = t} e | Ghc.isClassPred tx-  = grabBody allowTC t e-grabBody allowTC@True Ghc.FunTy{ Ghc.ft_arg = tx, Ghc.ft_res = t} e | isEmbeddedDictType tx-  = grabBody allowTC t e-grabBody allowTC torig@Ghc.FunTy {} (Ghc.Let (Ghc.NonRec x e) body)-  = grabBody allowTC torig (subst (x,e) body)-grabBody allowTC Ghc.FunTy{ Ghc.ft_res = t} (Ghc.Lam x e)-  = (x:xs, e') where (xs, e') = grabBody allowTC t e-grabBody allowTC t (Ghc.Tick _ e)-  = grabBody allowTC t e-grabBody allowTC ty@Ghc.FunTy{} e-  = (txs++xs, e')-   where (ts,tr)  = splitFun ty-         (xs, e') = grabBody allowTC tr (foldl Ghc.App e (Ghc.Var <$> txs))-         txs      = [ stringVar ("ls" ++ show i) t |  (t,i) <- zip ts [(1::Int)..]]-grabBody _ _ e-  = ([], e)--splitFun :: Ghc.Type -> ([Ghc.Type], Ghc.Type)-splitFun = go []-  where go acc Ghc.FunTy{ Ghc.ft_arg = tx, Ghc.ft_res = t} = go (tx:acc) t-        go acc t                                           = (reverse acc, t)---isBoolBind :: Ghc.Var -> Bool-isBoolBind v = isBool (ty_res $ toRTypeRep ((ofType $ Ghc.varType v) :: RRType ()))--strengthenRes :: SpecType -> F.Reft -> SpecType-strengthenRes st rf = go st-  where-    go (RAllT a t r)   = RAllT a (go t) r-    go (RAllP p t)     = RAllP p $ go t-    go (RFun x i tx t r) = RFun x i tx (go t) r-    go t               =  t `strengthen` F.ofReft rf--class Subable a where-  subst :: (Ghc.Var, Ghc.CoreExpr) -> a -> a--instance Subable Ghc.Var where-  subst (x, ex) z-    | x == z, Ghc.Var y <- ex = y-    | otherwise           = z--instance Subable Ghc.CoreExpr where-  subst (x, ex) (Ghc.Var y)-    | x == y    = ex-    | otherwise = Ghc.Var y-  subst su (Ghc.App f e)-    = Ghc.App (subst su f) (subst su e)-  subst su (Ghc.Lam x e)-    = Ghc.Lam x (subst su e)-  subst su (Ghc.Case e x t alts)-    = Ghc.Case (subst su e) x t (subst su <$> alts)-  subst su (Ghc.Let (Ghc.Rec xes) e)-    = Ghc.Let (Ghc.Rec (mapSnd (subst su) <$> xes)) (subst su e)-  subst su (Ghc.Let (Ghc.NonRec x ex) e)-    = Ghc.Let (Ghc.NonRec x (subst su ex)) (subst su e)-  subst su (Ghc.Cast e t)-    = Ghc.Cast (subst su e) t-  subst su (Ghc.Tick t e)-    = Ghc.Tick t (subst su e)-  subst _ e-    = e--instance Subable Ghc.CoreAlt where-  subst su (c, xs, e) = (c, xs, subst su e)--data AxiomType = AT { aty :: SpecType, aargs :: [(F.Symbol, SpecType)], ares :: SpecType }---- | Specification for Haskell function-axiomType :: Bool -> LocSymbol -> SpecType -> AxiomType-axiomType allowTC s st = AT to (reverse xts) res-  where-    (to, (_,xts, Just res)) = runState (go st) (1,[], Nothing)-    go (RAllT a t r) = RAllT a <$> go t <*> return r-    go (RAllP p t) = RAllP p <$> go t-    go (RFun x i tx t r) | isErasable tx = (\t' -> RFun x i tx t' r) <$> go t-    go (RFun x ii tx t r) = do-      (i,bs,mres) <- get-      let x' = unDummy x i-      put (i+1, (x', tx):bs,mres)-      t' <- go t-      return $ RFun x' ii tx t' r-    go t = do-      (i,bs,_) <- get-      let ys = reverse $ map fst bs-      let t' = strengthen t (singletonApp s ys)-      put (i, bs, Just t')-      return t'-    isErasable = if allowTC then isEmbeddedClass else isClassType-unDummy :: F.Symbol -> Int -> F.Symbol-unDummy x i-  | x /= F.dummySymbol = x-  | otherwise          = F.symbol ("lq" ++ show i)--singletonApp :: F.Symbolic a => LocSymbol -> [a] -> UReft F.Reft-singletonApp s ys = MkUReft r mempty-  where-    r             = F.exprReft (F.mkEApp s (F.eVar <$> ys))------------------------------------------------------------------------------------- | Hardcode imported reflected functions ----------------------------------------------------------------------------------------------------------------------wiredReflects :: Config -> Bare.Env -> ModName -> GhcSpecSig ->-                 Bare.Lookup [Ghc.Var]-wiredReflects cfg env name sigs = do-  vs <- wiredDefs cfg env name sigs-  return [v | (_, _, v, _) <- vs]--wiredDefs :: Config -> Bare.Env -> ModName -> GhcSpecSig-          -> Bare.Lookup [(LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr)]-wiredDefs cfg env name spSig-  | reflection cfg = do-    let x = F.dummyLoc functionComposisionSymbol-    v    <- Bare.lookupGhcVar env name "wiredAxioms" x-    return [ (x, F.val <$> lookup v (gsTySigs spSig), v, makeCompositionExpression v) ]-  | otherwise =-    return []------------------------------------------------------------------------------------ | Expression Definitions of Prelude Functions --------------------------------- | NV: Currently Just Hacking Composition       ----------------------------------------------------------------------------------------------------------------makeCompositionExpression :: Ghc.Id -> Ghc.CoreExpr-makeCompositionExpression gid-  =  go $ Ghc.varType $ F.notracepp ( -- tracing to find  the body of . from the inline spec, -                                      -- replace F.notrace with F.trace to print -      "\nv = " ++ GM.showPpr gid ++-      "\n realIdUnfolding = " ++ GM.showPpr (Ghc.realIdUnfolding gid) ++-      "\n maybeUnfoldingTemplate . realIdUnfolding = " ++ GM.showPpr (Ghc.maybeUnfoldingTemplate $ Ghc.realIdUnfolding gid ) ++-      "\n inl_src . inlinePragInfo . Ghc.idInfo = "    ++ GM.showPpr (Ghc.inl_src $ Ghc.inlinePragInfo $ Ghc.idInfo gid) ++-      "\n inl_inline . inlinePragInfo . Ghc.idInfo = " ++ GM.showPpr (Ghc.inl_inline $ Ghc.inlinePragInfo $ Ghc.idInfo gid) ++-      "\n inl_sat . inlinePragInfo . Ghc.idInfo = "    ++ GM.showPpr (Ghc.inl_sat $ Ghc.inlinePragInfo $ Ghc.idInfo gid) ++-      "\n inl_act . inlinePragInfo . Ghc.idInfo = "    ++ GM.showPpr (Ghc.inl_act $ Ghc.inlinePragInfo $ Ghc.idInfo gid) ++-      "\n inl_rule . inlinePragInfo . Ghc.idInfo = "   ++ GM.showPpr (Ghc.inl_rule $ Ghc.inlinePragInfo $ Ghc.idInfo gid) ++-      "\n inl_rule rule = " ++ GM.showPpr (Ghc.inl_rule $ Ghc.inlinePragInfo $ Ghc.idInfo gid) ++-      "\n inline spec = " ++ GM.showPpr (Ghc.inl_inline $ Ghc.inlinePragInfo $ Ghc.idInfo gid)-     ) gid-   where-    go (Ghc.ForAllTy a (Ghc.ForAllTy b (Ghc.ForAllTy c Ghc.FunTy{ Ghc.ft_arg = tf, Ghc.ft_res = Ghc.FunTy { Ghc.ft_arg = tg, Ghc.ft_res = tx}})))-      = let f = stringVar "f" tf-            g = stringVar "g" tg-            x = stringVar "x" tx-        in Ghc.Lam (Ghc.binderVar a) $-           Ghc.Lam (Ghc.binderVar b) $-           Ghc.Lam (Ghc.binderVar c) $-           Ghc.Lam f $ Ghc.Lam g $ Ghc.Lam x $ Ghc.App (Ghc.Var f) (Ghc.App (Ghc.Var g) (Ghc.Var x))-    go _ = error "Axioms.go"
− src/Language/Haskell/Liquid/Bare/Check.hs 
@@ -1,763 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE TupleSections       #-}-{-# LANGUAGE RecordWildCards     #-}-{-# LANGUAGE OverloadedStrings   #-}--module Language.Haskell.Liquid.Bare.Check-  ( checkTargetSpec-  , checkBareSpec-  , checkTargetSrc-  ) where---import           Language.Haskell.Liquid.Constraint.ToFixpoint--import           Liquid.GHC.API                   as Ghc hiding ( Located-                                                                                 , text-                                                                                 , (<+>)-                                                                                 , panic-                                                                                 , ($+$)-                                                                                 , empty-                                                                                 )-import           Control.Applicative                       ((<|>))-import           Control.Arrow                             ((&&&))-import           Data.Maybe-import           Data.Function                             (on)-import           Text.PrettyPrint.HughesPJ                 hiding ((<>))-import qualified Data.List                                 as L-import qualified Data.HashMap.Strict                       as M-import qualified Data.HashSet                              as S-import           Data.Hashable-import qualified Language.Fixpoint.Misc                    as Misc-import           Language.Fixpoint.SortCheck               (checkSorted, checkSortedReftFull, checkSortFull)-import qualified Language.Fixpoint.Types                   as F-import qualified Liquid.GHC.Misc          as GM-import           Liquid.GHC.Play          (getNonPositivesTyCon)-import           Language.Haskell.Liquid.Misc              (condNull, thd5)-import           Language.Haskell.Liquid.Types-import           Language.Haskell.Liquid.WiredIn-import           Language.Haskell.Liquid.LawInstances      (checkLawInstances)--import qualified Language.Haskell.Liquid.Measure           as Ms-import qualified Language.Haskell.Liquid.Bare.Types        as Bare-import qualified Language.Haskell.Liquid.Bare.Resolve      as Bare---------------------------------------------------------------------------------------------------- | Checking TargetSrc ------------------------------------------------------------------------------------------------------------------------------------------------------------------------checkTargetSrc :: Config -> TargetSrc -> Either Diagnostics ()-checkTargetSrc cfg spec-  |  nopositivity cfg-  || nopositives == emptyDiagnostics-  = Right ()-  | otherwise-  = Left nopositives-  where nopositives = checkPositives (gsTcs spec)---checkPositives :: [TyCon] -> Diagnostics-checkPositives tys = mkDiagnostics [] $ mkNonPosError (getNonPositivesTyCon tys)--mkNonPosError :: [(TyCon, [DataCon])]  -> [Error]-mkNonPosError tcs = [ ErrPosTyCon (getSrcSpan tc) (pprint tc) (pprint dc <+> ":" <+> pprint (dataConRepType dc))-                    | (tc, dc:_) <- tcs]--------------------------------------------------------------------------------------------------- | Checking BareSpec ------------------------------------------------------------------------------------------------------------------------------------------------------------------------checkBareSpec :: ModName -> Ms.BareSpec -> Either Diagnostics ()-checkBareSpec _ sp-  | allChecks == emptyDiagnostics = Right ()-  | otherwise = Left allChecks-  where-    allChecks = mconcat [ checkUnique   "measure"    measures-                        , checkUnique   "field"      fields-                        , checkDisjoints             [ inlines-                                                     , hmeasures-                                                     , S.fromList measures-                                                     , reflects-                                                     , S.fromList fields-                                                     ]-                        ]-    inlines   = Ms.inlines    sp-    hmeasures = Ms.hmeas      sp-    reflects  = Ms.reflects   sp-    measures  = msName    <$> Ms.measures sp-    fields    = concatMap dataDeclFields (Ms.dataDecls sp)--dataDeclFields :: DataDecl -> [F.LocSymbol]-dataDeclFields = filter (not . GM.isTmpSymbol . F.val)-               . Misc.hashNubWith val-               . concatMap dataCtorFields-               . fromMaybe []-               . tycDCons--dataCtorFields :: DataCtor -> [F.LocSymbol]-dataCtorFields c-  | isGadt c  = []-  | otherwise = F.atLoc c <$> [ f | (f,_) <- dcFields c ]--isGadt :: DataCtor -> Bool-isGadt = isJust . dcResult--checkUnique :: String -> [F.LocSymbol] -> Diagnostics-checkUnique _ = mkDiagnostics mempty . checkUnique' F.val GM.fSrcSpan--checkUnique' :: (PPrint a, Eq a, Hashable a)-             => (t -> a) -> (t -> Ghc.SrcSpan) -> [t] -> [Error]-checkUnique' nameF locF ts = [ErrDupSpecs l (pprint n) ls | (n, ls@(l:_)) <- dups]-  where-    dups                   = [ z      | z@(_, _:_:_) <- Misc.groupList nts       ]-    nts                    = [ (n, l) | t <- ts, let n = nameF t, let l = locF t ]--checkDisjoints :: [S.HashSet F.LocSymbol] -> Diagnostics-checkDisjoints []     = emptyDiagnostics-checkDisjoints [_]    = emptyDiagnostics-checkDisjoints (s:ss) = checkDisjoint s (S.unions ss) <> checkDisjoints ss--checkDisjoint :: S.HashSet F.LocSymbol -> S.HashSet F.LocSymbol -> Diagnostics-checkDisjoint s1 s2 = checkUnique "disjoint" (S.toList s1 ++ S.toList s2)--------------------------------------------------------------------------------------------------- | Checking TargetSpec-------------------------------------------------------------------------------------------------checkTargetSpec :: [Ms.BareSpec]-                -> TargetSrc-                -> F.SEnv F.SortedReft-                -> [CoreBind]-                -> TargetSpec-                -> Either Diagnostics ()-checkTargetSpec specs src env cbs tsp-  | diagnostics == emptyDiagnostics = Right ()-  | otherwise                       = Left diagnostics-  where-    diagnostics      :: Diagnostics-    diagnostics      =  foldMap (checkBind allowHO bsc "measure"      emb tcEnv env) (gsMeas       (gsData tsp))-                     <> condNull noPrune-                        (foldMap (checkBind allowHO bsc "constructor"  emb tcEnv env) (txCtors $ gsCtors      (gsData tsp)))-                     <> foldMap (checkBind allowHO bsc "assume"       emb tcEnv env) (gsAsmSigs    (gsSig tsp))-                     <> foldMap (checkBind allowHO bsc "reflect"      emb tcEnv env . (\sig@(_,s) -> F.notracepp (show (ty_info (toRTypeRep (F.val s)))) sig)) (gsRefSigs (gsSig tsp))-                     <> checkTySigs allowHO bsc cbs            emb tcEnv env                (gsSig tsp)-                     -- ++ mapMaybe (checkTerminationExpr             emb       env) (gsTexprs     (gsSig  sp))-                     <> foldMap (checkBind allowHO bsc "class method" emb tcEnv env) (clsSigs      (gsSig tsp))-                     <> foldMap (checkInv allowHO bsc emb tcEnv env)                 (gsInvariants (gsData tsp))-                     <> checkIAl allowHO bsc emb tcEnv env                            (gsIaliases   (gsData tsp))-                     <> checkMeasures emb env ms-                     <> checkClassMeasures                                        (gsMeasures (gsData tsp))-                     <> checkClassMethods (gsCls src) (gsCMethods (gsVars tsp)) (gsTySigs     (gsSig tsp))-                     -- <> foldMap checkMismatch sigs-                     <> foldMap checkMismatch (L.filter (\(v,_) -> not (GM.isSCSel v || GM.isMethod v)) sigs)-                     <> checkDuplicate                                            (gsTySigs     (gsSig tsp))-                     -- TODO-REBARE ++ checkQualifiers env                                       (gsQualifiers (gsQual sp))-                     <> checkDuplicate                                            (gsAsmSigs    (gsSig tsp))-                     <> checkDupIntersect                                         (gsTySigs (gsSig tsp)) (gsAsmSigs (gsSig tsp))-                     <> checkRTAliases "Type Alias" env            tAliases-                     <> checkRTAliases "Pred Alias" env            eAliases-                     -- ++ _checkDuplicateFieldNames                   (gsDconsP sp)-                     -- NV TODO: allow instances of refined classes to be refined-                     -- but make sure that all the specs are checked.-                     -- ++ checkRefinedClasses                        rClasses rInsts-                     <> checkSizeFun emb env                                      (gsTconsP (gsName tsp))-                     <> checkPlugged (catMaybes [ fmap (F.dropSym 2 $ GM.simplesymbol x,) (getMethodType t) | (x, t) <- gsMethods (gsSig tsp) ])-                     <> checkLawInstances (gsLaws tsp)-                     <> checkRewrites tsp--    _rClasses         = concatMap Ms.classes specs-    _rInsts           = concatMap Ms.rinstance specs-    tAliases          = concat [Ms.aliases sp  | sp <- specs]-    eAliases          = concat [Ms.ealiases sp | sp <- specs]-    emb              = gsTcEmbeds (gsName tsp)-    tcEnv            = gsTyconEnv (gsName tsp)-    ms               = gsMeasures (gsData tsp)-    clsSigs sp       = [ (v, t) | (v, t) <- gsTySigs sp, isJust (isClassOpId_maybe v) ]-    sigs             = gsTySigs (gsSig tsp) ++ gsAsmSigs (gsSig tsp) ++ gsCtors (gsData tsp)-    -- allowTC          = typeclass (getConfig sp)-    allowHO          = higherOrderFlag tsp-    bsc              = bscope (getConfig tsp)-    noPrune          = not (pruneFlag tsp)-    txCtors ts       = [(v, fmap (fmap (fmap (F.filterUnMatched temps))) t) | (v, t) <- ts]-    temps            = F.makeTemplates $ gsUnsorted $ gsData tsp-    -- env'             = L.foldl' (\e (x, s) -> insertSEnv x (RR s mempty) e) env wiredSortedSyms------checkPlugged :: PPrint v => [(v, LocSpecType)] -> Diagnostics-checkPlugged xs = mkDiagnostics mempty (map mkErr (filter (hasHoleTy . val . snd) xs))-  where-    mkErr (x,t) = ErrBadData (GM.sourcePosSrcSpan $ loc t) (pprint x) msg-    msg        = "Cannot resolve type hole `_`. Use explicit type instead."------------------------------------------------------------------------------------checkTySigs :: Bool-            -> BScope-            -> [CoreBind]-            -> F.TCEmb TyCon-            -> Bare.TyConMap-            -> F.SEnv F.SortedReft-            -> GhcSpecSig-            -> Diagnostics----------------------------------------------------------------------------------checkTySigs allowHO bsc cbs emb tcEnv senv sig-                   = mconcat (map (check senv) topTs)-                   -- = concatMap (check env) topTs-                   -- (mapMaybe   (checkT env) [ (x, t)     | (x, (t, _)) <- topTs])-                   -- ++ (mapMaybe   (checkE env) [ (x, t, es) | (x, (t, Just es)) <- topTs]) -                  <> coreVisitor checkVisitor senv emptyDiagnostics cbs-                   -- ++ coreVisitor checkVisitor env [] cbs -  where-    check env      = checkSigTExpr allowHO bsc emb tcEnv env-    locTm          = M.fromList locTs-    (locTs, topTs) = Bare.partitionLocalBinds vtes-    vtes           = [ (x, (t, es)) | (x, t) <- gsTySigs sig, let es = M.lookup x vExprs]-    vExprs         = M.fromList  [ (x, es) | (x, _, es) <- gsTexprs sig ]--    checkVisitor  :: CoreVisitor (F.SEnv F.SortedReft) Diagnostics-    checkVisitor   = CoreVisitor-                       { envF  = \env v     -> F.insertSEnv (F.symbol v) (vSort v) env-                       , bindF = \env acc v -> errs env v <> acc-                       , exprF = \_   acc _ -> acc-                       }-    vSort            = Bare.varSortedReft emb-    errs env v       = case M.lookup v locTm of-                         Nothing -> emptyDiagnostics-                         Just t  -> check env (v, t)--checkSigTExpr :: Bool -> BScope -> F.TCEmb TyCon -> Bare.TyConMap -> F.SEnv F.SortedReft-              -> (Var, (LocSpecType, Maybe [Located F.Expr]))-              -> Diagnostics-checkSigTExpr allowHO bsc emb tcEnv env (x, (t, es))-           = mbErr1 <> mbErr2-   where-    mbErr1 = checkBind allowHO bsc empty emb tcEnv env (x, t)-    mbErr2 = maybe emptyDiagnostics (checkTerminationExpr emb env . (x, t,)) es-    -- mbErr2 = checkTerminationExpr emb env . (x, t,) =<< es --_checkQualifiers :: F.SEnv F.SortedReft -> [F.Qualifier] -> [Error]-_checkQualifiers = mapMaybe . checkQualifier--checkQualifier       :: F.SEnv F.SortedReft -> F.Qualifier -> Maybe Error-checkQualifier env q =  mkE <$> checkSortFull (F.srcSpan q) γ F.boolSort  (F.qBody q)-  where-    γ                = L.foldl' (\e (x, s) -> F.insertSEnv x (F.RR s mempty) e) env (F.qualBinds q ++ wiredSortedSyms)-    mkE              = ErrBadQual (GM.fSrcSpan q) (pprint $ F.qName q)---- | Used for termination checking. If we have no \"len\" defined /yet/ (for example we are checking--- 'GHC.Prim') then we want to skip this check.-checkSizeFun :: F.TCEmb TyCon -> F.SEnv F.SortedReft -> [TyConP] -> Diagnostics-checkSizeFun emb env tys = mkDiagnostics mempty (map mkError (mapMaybe go tys))-  where-    mkError ((f, tcp), msg)  = ErrTyCon (GM.sourcePosSrcSpan $ tcpLoc tcp)-                                 (text "Size function" <+> pprint (f x)-                                                       <+> text "should have type int, but it was "-                                                       <+> pprint (tcpCon tcp)-                                                       <+> text "."-                                                       $+$   msg)-                                 (pprint (tcpCon tcp))-    go tcp = case tcpSizeFun tcp of-               Nothing                   -> Nothing-               Just f | isWiredInLenFn f -> Nothing -- Skip the check.-               Just f                    -> checkWFSize (szFun f) tcp--    checkWFSize f tcp = ((f, tcp),) <$> checkSortFull (F.srcSpan tcp) (F.insertSEnv x (mkTySort (tcpCon tcp)) env) F.intSort (f x)-    x                 = "x" :: F.Symbol-    mkTySort tc       = rTypeSortedReft emb (ofType $ TyConApp tc (TyVarTy <$> tyConTyVars tc) :: RRType ())--    isWiredInLenFn :: SizeFun -> Bool-    isWiredInLenFn IdSizeFun           = False-    isWiredInLenFn (SymSizeFun locSym) = isWiredIn locSym--_checkRefinedClasses :: [RClass LocBareType] -> [RInstance LocBareType] -> [Error]-_checkRefinedClasses definitions instances-  = mkError <$> duplicates-  where-    duplicates-      = mapMaybe (checkCls . rcName) definitions-    checkCls cls-      = case findConflicts cls of-          []        -> Nothing-          conflicts -> Just (cls, conflicts)-    findConflicts cls-      = filter ((== cls) . riclass) instances-    mkError (cls, conflicts)-      = ErrRClass (GM.sourcePosSrcSpan $ loc $ btc_tc cls)-                  (pprint cls) (ofConflict <$> conflicts)-    ofConflict-      = GM.sourcePosSrcSpan . loc . btc_tc . riclass &&& pprint . ritype--_checkDuplicateFieldNames :: [(DataCon, DataConP)]  -> [Error]-_checkDuplicateFieldNames = mapMaybe go-  where-    go (d, dts)          = checkNoDups (dcpLoc dts) d (fst <$> dcpTyArgs dts)-    checkNoDups l d xs   = mkErr l d <$> _firstDuplicate xs--    mkErr l d x = ErrBadData (GM.sourcePosSrcSpan l)-                             (pprint d)-                             (text "Multiple declarations of record selector" <+> pprintSymbol x)--_firstDuplicate :: Ord a => [a] -> Maybe a-_firstDuplicate = go . L.sort-  where-    go (y:x:xs) | x == y    = Just x-                | otherwise = go (x:xs)-    go _                    = Nothing--checkInv :: Bool-         -> BScope-         -> F.TCEmb TyCon-         -> Bare.TyConMap-         -> F.SEnv F.SortedReft-         -> (Maybe Var, LocSpecType)-         -> Diagnostics-checkInv allowHO bsc emb tcEnv env (_, t) = checkTy allowHO bsc err emb tcEnv env t-  where-    err              = ErrInvt (GM.sourcePosSrcSpan $ loc t) (val t)--checkIAl :: Bool-         -> BScope-         -> F.TCEmb TyCon-         -> Bare.TyConMap-         -> F.SEnv F.SortedReft-         -> [(LocSpecType, LocSpecType)]-         -> Diagnostics-checkIAl allowHO bsc emb tcEnv env = mconcat . map (checkIAlOne allowHO bsc emb tcEnv env)--checkIAlOne :: Bool-            -> BScope-            -> F.TCEmb TyCon-            -> Bare.TyConMap-            -> F.SEnv F.SortedReft-            -> (LocSpecType, LocSpecType)-            -> Diagnostics-checkIAlOne allowHO bsc emb tcEnv env (t1, t2) = mconcat $ checkEq : (tcheck <$> [t1, t2])-  where-    tcheck t = checkTy allowHO bsc (err t) emb tcEnv env t-    err    t = ErrIAl (GM.sourcePosSrcSpan $ loc t) (val t)-    t1'      :: RSort-    t1'      = toRSort $ val t1-    t2'      :: RSort-    t2'      = toRSort $ val t2-    checkEq  = if t1' == t2' then emptyDiagnostics else mkDiagnostics mempty [errmis]-    errmis   = ErrIAlMis (GM.sourcePosSrcSpan $ loc t1) (val t1) (val t2) emsg-    emsg     = pprint t1 <+> text "does not match with" <+> pprint t2----- FIXME: Should _ be removed if it isn't used?-checkRTAliases :: String -> t -> [Located (RTAlias s a)] -> Diagnostics-checkRTAliases msg _ as = err1s-  where-    err1s               = checkDuplicateRTAlias msg as--checkBind :: (PPrint v)-          => Bool-          -> BScope-          -> Doc-          -> F.TCEmb TyCon-          -> Bare.TyConMap-          -> F.SEnv F.SortedReft-          -> (v, LocSpecType)-          -> Diagnostics-checkBind allowHO bsc s emb tcEnv env (v, t) = checkTy allowHO bsc msg emb tcEnv env t-  where-    msg                      = ErrTySpec (GM.fSrcSpan t) (Just s) (pprint v) (val t)---checkTerminationExpr :: (Eq v, PPrint v)-                     => F.TCEmb TyCon-                     -> F.SEnv F.SortedReft-                     -> (v, LocSpecType, [F.Located F.Expr])-                     -> Diagnostics-checkTerminationExpr emb env (v, Loc l _ st, les)-            = mkErr "ill-sorted" (go les) <> mkErr "non-numeric" (go' les)-  where-    -- es      = val <$> les-    mkErr :: Doc -> Maybe (F.Expr, Doc) -> Diagnostics-    mkErr _ Nothing = emptyDiagnostics-    mkErr k (Just expr') =-      mkDiagnostics mempty [(\ (e, d) -> ErrTermSpec (GM.sourcePosSrcSpan l) (pprint v) k e st d) expr']-    -- mkErr   = uncurry (\ e d -> ErrTermSpec (GM.sourcePosSrcSpan l) (pprint v) (text "ill-sorted" ) e t d)-    -- mkErr'  = uncurry (\ e d -> ErrTermSpec (GM.sourcePosSrcSpan l) (pprint v) (text "non-numeric") e t d)--    go :: [F.Located F.Expr] -> Maybe (F.Expr, Doc)-    go      = L.foldl' (\err e -> err <|> (val e,) <$> checkSorted (F.srcSpan e) env' (val e))     Nothing--    go' :: [F.Located F.Expr] -> Maybe (F.Expr, Doc)-    go'     = L.foldl' (\err e -> err <|> (val e,) <$> checkSorted (F.srcSpan e) env' (cmpZero e)) Nothing--    env'    = F.sr_sort <$> L.foldl' (\e (x,s) -> F.insertSEnv x s e) env xts-    xts     = concatMap mkClss $ zip (ty_binds trep) (ty_args trep)-    trep    = toRTypeRep st--    mkClss (_, RApp c ts _ _) | isClass c = classBinds emb (rRCls c ts)-    mkClss (x, t)                         = [(x, rSort t)]--    rSort   = rTypeSortedReft emb-    cmpZero e = F.PAtom F.Le (F.expr (0 :: Int)) (val e)--checkTy :: Bool-        -> BScope-        -> (Doc -> Error)-        -> F.TCEmb TyCon-        -> Bare.TyConMap-        -> F.SEnv F.SortedReft-        -> LocSpecType-        -> Diagnostics-checkTy allowHO bsc mkE emb tcEnv env t =-  case checkRType allowHO bsc emb env (Bare.txRefSort tcEnv emb t) of-    Nothing -> emptyDiagnostics-    Just d  -> mkDiagnostics mempty [mkE d]-  where-    _msg =  "CHECKTY: " ++ showpp (val t)--checkDupIntersect     :: [(Var, LocSpecType)] -> [(Var, LocSpecType)] -> Diagnostics-checkDupIntersect xts asmSigs =-  mkDiagnostics (map mkWrn {- trace msg -} dups) mempty-  where-    mkWrn (x, t)   = mkWarning (GM.sourcePosSrcSpan $ loc t) (pprWrn x)-    dups           = L.intersectBy ((==) `on` fst) asmSigs xts-    pprWrn v       = text $ "Assume Overwrites Specifications for " ++ show v-    -- msg              = "CHECKDUPINTERSECT:" ++ msg1 ++ msg2-    -- msg1             = "\nCheckd-SIGS:\n" ++ showpp (M.fromList xts)-    -- msg2             = "\nAssume-SIGS:\n" ++ showpp (M.fromList asmSigs)---checkDuplicate :: [(Var, LocSpecType)] -> Diagnostics-checkDuplicate = mkDiagnostics mempty . checkUnique' fst (GM.fSrcSpan . snd)--checkClassMethods :: Maybe [ClsInst] -> [Var] ->  [(Var, LocSpecType)] -> Diagnostics-checkClassMethods Nothing      _   _   = emptyDiagnostics-checkClassMethods (Just clsis) cms xts =-  mkDiagnostics mempty [ErrMClass (GM.sourcePosSrcSpan $ loc t) (pprint x)| (x,t) <- dups ]-  where-    dups = F.notracepp "DPS" $ filter ((`elem` ms) . fst) xts'-    ms   = F.notracepp "MS"  $ concatMap (classMethods . is_cls) clsis-    xts' = F.notracepp "XTS" $ filter (not . (`elem` cls) . fst) xts-    cls  = F.notracepp "CLS" cms--checkDuplicateRTAlias :: String -> [Located (RTAlias s a)] -> Diagnostics-checkDuplicateRTAlias s tas = mkDiagnostics mempty (map mkErr dups)-  where-    mkErr xs@(x:_)          = ErrDupAlias (GM.fSrcSpan x)-                                          (text s)-                                          (pprint . rtName . val $ x)-                                          (GM.fSrcSpan <$> xs)-    mkErr []                = panic Nothing "mkError: called on empty list"-    dups                    = [z | z@(_:_:_) <- L.groupBy ((==) `on` (rtName . val)) tas]---checkMismatch        :: (Var, LocSpecType) -> Diagnostics-checkMismatch (x, t) = if ok then emptyDiagnostics else mkDiagnostics mempty [err]-  where-    ok               = tyCompat x (val t')-    err              = errTypeMismatch x t'-    t'               = dropImplicits <$> t--tyCompat :: Var -> RType RTyCon RTyVar r -> Bool-tyCompat x t         = lqT == hsT-  where-    lqT :: RSort     = toRSort t-    hsT :: RSort     = ofType (varType x)-    _msg             = "TY-COMPAT: " ++ GM.showPpr x ++ ": hs = " ++ F.showpp hsT ++ " :lq = " ++ F.showpp lqT--errTypeMismatch     :: Var -> Located SpecType -> Error-errTypeMismatch x t = ErrMismatch lqSp (pprint x) (text "Checked")  d1 d2 Nothing hsSp-  where-    d1              = pprint $ varType x-    d2              = pprint $ toType False $ val t-    lqSp            = GM.fSrcSpan t-    hsSp            = getSrcSpan x----------------------------------------------------------------------------------------------------- | @checkRType@ determines if a type is malformed in a given environment -----------------------------------------------------------------------------------------------------------------------checkRType :: Bool -> BScope -> F.TCEmb TyCon -> F.SEnv F.SortedReft -> LocSpecType -> Maybe Doc--------------------------------------------------------------------------------------------------checkRType allowHO bsc emb senv lt-  =   checkAppTys st-  <|> checkAbstractRefs st-  <|> efoldReft farg bsc cb (tyToBind emb) (rTypeSortedReft emb) f insertPEnv senv Nothing st-  where-    -- isErasable         = if allowTC then isEmbeddedDict else isClass-    st                 = val lt-    cb c ts            = classBinds emb (rRCls c ts)-    farg _ t           = allowHO || isBase t  -- NOTE: this check should be the same as the one in addCGEnv-    f env me r err     = err <|> checkReft (F.srcSpan lt) env emb me r-    insertPEnv p γ     = insertsSEnv γ (Misc.mapSnd (rTypeSortedReft emb) <$> pbinds p)-    pbinds p           = (pname p, pvarRType p :: RSort) : [(x, tx) | (tx, x, _) <- pargs p]--tyToBind :: F.TCEmb TyCon -> RTVar RTyVar RSort  -> [(F.Symbol, F.SortedReft)]-tyToBind emb = go . ty_var_info-  where-    go RTVInfo{..} = [(rtv_name, rTypeSortedReft emb rtv_kind)]-    go RTVNoInfo{} = []--checkAppTys :: RType RTyCon t t1 -> Maybe Doc-checkAppTys = go-  where-    go (RAllT _ t _)    = go t-    go (RAllP _ t)      = go t-    go (RApp rtc ts _ _)-      = checkTcArity rtc (length ts) <|>-        L.foldl' (\merr t -> merr <|> go t) Nothing ts-    go (RImpF _ _ t1 t2 _)= go t1 <|> go t2-    go (RFun _ _ t1 t2 _) = go t1 <|> go t2-    go (RVar _ _)       = Nothing-    go (RAllE _ t1 t2)  = go t1 <|> go t2-    go (REx _ t1 t2)    = go t1 <|> go t2-    go (RAppTy t1 t2 _) = go t1 <|> go t2-    go (RRTy _ _ _ t)   = go t-    go (RExprArg _)     = Just $ text "Logical expressions cannot appear inside a Haskell type"-    go (RHole _)        = Nothing--checkTcArity :: RTyCon -> Arity -> Maybe Doc-checkTcArity RTyCon{ rtc_tc = tc } givenArity-  | expectedArity < givenArity-    = Just $ text "Type constructor" <+> pprint tc-        <+> text "expects a maximum" <+> pprint expectedArity-        <+> text "arguments but was given" <+> pprint givenArity-        <+> text "arguments"-  | otherwise-    = Nothing-  where-    expectedArity = tyConRealArity tc---checkAbstractRefs-  :: (PPrint t, F.Reftable t, SubsTy RTyVar RSort t, F.Reftable (RTProp RTyCon RTyVar (UReft t))) =>-     RType RTyCon RTyVar (UReft t) -> Maybe Doc-checkAbstractRefs rt = go rt-  where-    penv = mkPEnv rt--    go t@(RAllT _ t1 r)   = check (toRSort t :: RSort) r <|>  go t1-    go (RAllP _ t)        = go t-    go t@(RApp c ts rs r) = check (toRSort t :: RSort) r <|>  efold go ts <|> go' c rs-    go t@(RImpF _ _ t1 t2 r)= check (toRSort t :: RSort) r <|> go t1 <|> go t2-    go t@(RFun _ _ t1 t2 r) = check (toRSort t :: RSort) r <|> go t1 <|> go t2-    go t@(RVar _ r)       = check (toRSort t :: RSort) r-    go (RAllE _ t1 t2)    = go t1 <|> go t2-    go (REx _ t1 t2)      = go t1 <|> go t2-    go t@(RAppTy t1 t2 r) = check (toRSort t :: RSort) r <|> go t1 <|> go t2-    go (RRTy xts _ _ t)   = efold go (snd <$> xts) <|> go t-    go (RExprArg _)       = Nothing-    go (RHole _)          = Nothing--    go' c rs = L.foldl' (\acc (x, y) -> acc <|> checkOne' x y) Nothing (zip rs (rTyConPVs c))--    checkOne' (RProp xs (RHole _)) p-      | or [s1 /= s2 | ((_, s1), (s2, _, _)) <- zip xs (pargs p)]-      = Just $ text "Wrong Arguments in" <+> pprint p-      | length xs /= length (pargs p)-      = Just $ text "Wrong Number of Arguments in" <+> pprint p-      | otherwise-      = Nothing-    checkOne' (RProp xs t) p-      | pvType p /= toRSort t-      = Just $ text "Unexpected Sort in" <+> pprint p-      | or [s1 /= s2 | ((_, s1), (s2, _, _)) <- zip xs (pargs p)]-      = Just $ text "Wrong Arguments in" <+> pprint p-      | length xs /= length (pargs p)-      = Just $ text "Wrong Number of Arguments in" <+> pprint p-      | otherwise-      = go t---    efold f = L.foldl' (\acc x -> acc <|> f x) Nothing--    check s (MkUReft _ (Pr ps)) = L.foldl' (\acc pp -> acc <|> checkOne s pp) Nothing ps--    checkOne s p | pvType' p /= s-                 = Just $ text "Incorrect Sort:\n\t"-                       <+> text "Abstract refinement with type"-                       <+> pprint (pvType' p)-                       <+> text "is applied to"-                       <+> pprint s-                       <+> text "\n\t In" <+> pprint p-                 | otherwise-                 = Nothing--    mkPEnv (RAllT _ t _) = mkPEnv t-    mkPEnv (RAllP p t)   = p:mkPEnv t-    mkPEnv _             = []-    pvType' p          = Misc.safeHead (showpp p ++ " not in env of " ++ showpp rt) [pvType q | q <- penv, pname p == pname q]---checkReft                    :: (PPrint r, F.Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, F.Reftable (RTProp RTyCon RTyVar (UReft r)))-                             => F.SrcSpan -> F.SEnv F.SortedReft -> F.TCEmb TyCon -> Maybe (RRType (UReft r)) -> UReft r -> Maybe Doc-checkReft _ _   _   Nothing _   = Nothing -- TODO:RPropP/Ref case, not sure how to check these yet.-checkReft sp env emb (Just t) _ = (\z -> dr $+$ z) <$> checkSortedReftFull sp env r-  where-    r                           = rTypeSortedReft emb t-    dr                          = text "Sort Error in Refinement:" <+> pprint r---- DONT DELETE the below till we've added pred-checking as well--- checkReft env emb (Just t) _ = checkSortedReft env xs (rTypeSortedReft emb t)---    where xs                  = fromMaybe [] $ params <$> stripRTypeBase t---- checkSig env (x, t)---   = case filter (not . (`S.member` env)) (freeSymbols t) of---       [] -> TrueNGUAGE ScopedTypeVariables #-}---       ys -> errorstar (msg ys)---     where---       msg ys = printf "Unkown free symbols: %s in specification for %s \n%s\n" (showpp ys) (showpp x) (showpp t)-------------------------------------------------------------------------------------------------------- | @checkMeasures@ determines if a measure definition is wellformed ----------------------------------------------------------------------------------------------------------------------------------checkMeasures :: F.TCEmb TyCon -> F.SEnv F.SortedReft -> [Measure SpecType DataCon] -> Diagnostics-----------------------------------------------------------------------------------------------------checkMeasures emb env = foldMap (checkMeasure emb env)--checkMeasure :: F.TCEmb TyCon -> F.SEnv F.SortedReft -> Measure SpecType DataCon -> Diagnostics-checkMeasure emb γ (M name@(Loc src _ n) sort body _ _)-  = mkDiagnostics mempty [ txerror e | Just e <- checkMBody γ emb name sort <$> body ]-  where-    txerror = ErrMeas (GM.sourcePosSrcSpan src) (pprint n)--checkMBody :: (PPrint r, F.Reftable r,SubsTy RTyVar RSort r, F.Reftable (RTProp RTyCon RTyVar r))-           => F.SEnv F.SortedReft-           -> F.TCEmb TyCon-           -> t-           -> SpecType-           -> Def (RRType r) DataCon-           -> Maybe Doc-checkMBody senv emb _ sort (Def m c _ bs body) = checkMBody' emb sort γ' sp body-  where-    sp    = F.srcSpan m-    γ'    = L.foldl' (\γ (x, t) -> F.insertSEnv x t γ) senv xts-    xts   = zip (fst <$> bs) $ rTypeSortedReft emb . subsTyVarsMeet su  <$>-            filter keep (ty_args trep)-    keep | allowTC = not . isEmbeddedClass-         | otherwise = not . isClassType-    -- YL: extract permitTC information from sort-    allowTC = or $ fmap (fromMaybe False . permitTC) (ty_info $ toRTypeRep sort)-    trep  = toRTypeRep ct-    su    = checkMBodyUnify (ty_res trep) (last txs)-    txs   = thd5 $ bkArrowDeep sort-    ct    = ofType $ dataConWrapperType c :: SpecType--checkMBodyUnify-  :: RType t t2 t1 -> RType c tv r -> [(t2,RType c tv (),RType c tv r)]-checkMBodyUnify = go-  where-    go (RVar tv _) t      = [(tv, toRSort t, t)]-    go t@RApp{} t'@RApp{} = concat $ zipWith go (rt_args t) (rt_args t')-    go _ _                = []--checkMBody' :: (PPrint r, F.Reftable r,SubsTy RTyVar RSort r, F.Reftable (RTProp RTyCon RTyVar r))-            => F.TCEmb TyCon-            -> RType RTyCon RTyVar r-            -> F.SEnv F.SortedReft-            -> F.SrcSpan-            -> Body-            -> Maybe Doc-checkMBody' emb sort γ sp body = case body of-    E e   -> checkSortFull sp γ (rTypeSort emb sort') e-    P p   -> checkSortFull sp γ F.boolSort  p-    R s p -> checkSortFull sp (F.insertSEnv s sty γ) F.boolSort p-  where-    sty   = rTypeSortedReft emb sort'-    sort' = dropNArgs 1 sort--dropNArgs :: Int -> RType RTyCon RTyVar r -> RType RTyCon RTyVar r-dropNArgs i t = fromRTypeRep $ trep {ty_binds = xs, ty_info = is, ty_args = ts, ty_refts = rs}-  where-    xs   = drop i $ ty_binds trep-    ts   = drop i $ ty_args  trep-    rs   = drop i $ ty_refts trep-    is   = drop i $ ty_info trep-    trep = toRTypeRep t---getRewriteErrors :: (Var, Located SpecType) -> [TError t]-getRewriteErrors (rw, t)-  | null $ refinementEQs t-  = [ErrRewrite (GM.fSrcSpan t) $ text $-                "Unable to use "-                ++ show rw-                ++ " as a rewrite because it does not prove an equality, or the equality it proves is trivial." ]-  | otherwise-  = refErrs ++-      [ ErrRewrite (GM.fSrcSpan t) $-        text $ "Could not generate any rewrites from equality. Likely causes: "-        ++ "\n - There are free (uninstantiatable) variables on both sides of the "-        ++ "equality\n - The rewrite would diverge"-      | cannotInstantiate]-    where-        refErrs = map getInnerRefErr (filter (hasInnerRefinement . fst) (zip tyArgs syms))-        allowedRWs = [ (lhs, rhs) | (lhs , rhs) <- refinementEQs t-                 , canRewrite (S.fromList syms) lhs rhs ||-                   canRewrite (S.fromList syms) rhs lhs-                 ]-        cannotInstantiate = null allowedRWs-        tyArgs = ty_args  tRep-        syms   = ty_binds tRep-        tRep   = toRTypeRep $ val t-        getInnerRefErr (_, sym) =-          ErrRewrite (GM.fSrcSpan t) $ text $-          "Unable to use "-          ++ show rw-          ++ " as a rewrite. Functions whose parameters have inner refinements cannot be used as rewrites, but parameter "-          ++ show sym-          ++ " contains an inner refinement."---isRefined :: F.Reftable r => RType c tv r -> Bool-isRefined ty-  | Just r <- stripRTypeBase ty = not $ F.isTauto r-  | otherwise = False--hasInnerRefinement :: F.Reftable r => RType c tv r -> Bool-hasInnerRefinement (RFun _ _ rIn rOut _) =-  isRefined rIn || isRefined rOut-hasInnerRefinement (RImpF _ _ rIn rOut _) =-  isRefined rIn || isRefined rOut-hasInnerRefinement (RAllT _ ty  _) =-  isRefined ty-hasInnerRefinement (RAllP _ ty) =-  isRefined ty-hasInnerRefinement (RApp _ args _ _) =-  any isRefined args-hasInnerRefinement (RAllE _ allarg ty) =-  isRefined allarg || isRefined ty-hasInnerRefinement (REx _ allarg ty) =-  isRefined allarg || isRefined ty-hasInnerRefinement (RAppTy arg res _) =-  isRefined arg || isRefined res-hasInnerRefinement (RRTy env _ _ ty) =-  isRefined ty || any (isRefined . snd) env-hasInnerRefinement _ = False--checkRewrites :: TargetSpec -> Diagnostics-checkRewrites targetSpec = mkDiagnostics mempty (concatMap getRewriteErrors rwSigs)-  where-    rwSigs = filter ((`S.member` rws) . fst) sigs-    refl   = gsRefl targetSpec-    sig    = gsSig targetSpec-    sigs   = gsTySigs sig ++ gsAsmSigs sig-    rws    = S.union (S.map val $ gsRewrites refl)-                   (S.fromList $ concat $ M.elems (gsRewritesWith refl))---checkClassMeasures :: [Measure SpecType DataCon] -> Diagnostics-checkClassMeasures measures = mkDiagnostics mempty (mapMaybe checkOne byTyCon)-  where-  byName = L.groupBy ((==) `on` (val . msName)) measures--  byTyCon = concatMap (L.groupBy ((==) `on` (dataConTyCon . ctor . head . msEqns)))-                      byName--  checkOne []     = impossible Nothing "checkClassMeasures.checkOne on empty measure group"-  checkOne [_]    = Nothing-  checkOne (m:ms) = Just (ErrDupIMeas (GM.fSrcSpan (msName m))-                                      (pprint (val (msName m)))-                                      (pprint ((dataConTyCon . ctor . head . msEqns) m))-                                      (GM.fSrcSpan <$> (m:ms)))---
− src/Language/Haskell/Liquid/Bare/Class.hs 
@@ -1,278 +0,0 @@-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ParallelListComp  #-}-{-# LANGUAGE TupleSections     #-}--module Language.Haskell.Liquid.Bare.Class-  ( makeClasses-  , makeCLaws-  , makeSpecDictionaries-  , makeDefaultMethods-  , makeMethodTypes-  )-  where--import           Data.Bifunctor-import qualified Data.Maybe                                 as Mb-import qualified Data.List                                  as L-import qualified Data.HashMap.Strict                        as M--import qualified Language.Fixpoint.Misc                     as Misc-import qualified Language.Fixpoint.Types                    as F-import qualified Language.Fixpoint.Types.Visitor            as F--import           Language.Haskell.Liquid.Types.Dictionaries-import qualified Liquid.GHC.Misc           as GM-import qualified Liquid.GHC.API            as Ghc-import           Language.Haskell.Liquid.Misc-import           Language.Haskell.Liquid.Types.RefType-import           Language.Haskell.Liquid.Types              hiding (freeTyVars)--import qualified Language.Haskell.Liquid.Measure            as Ms-import           Language.Haskell.Liquid.Bare.Types         as Bare-import           Language.Haskell.Liquid.Bare.Resolve       as Bare-import           Language.Haskell.Liquid.Bare.Expand        as Bare-import           Language.Haskell.Liquid.Bare.Misc         as Bare--import           Text.PrettyPrint.HughesPJ (text)-import qualified Control.Exception                 as Ex-import Control.Monad (forM)------------------------------------------------------------------------------------makeMethodTypes :: Bool -> DEnv Ghc.Var LocSpecType -> [DataConP] -> [Ghc.CoreBind] -> [(Ghc.Var, MethodType LocSpecType)]---------------------------------------------------------------------------------makeMethodTypes allowTC (DEnv hm) cls cbs-  = [(x, MT (addCC allowTC x . fromRISig <$> methodType d x hm) (addCC allowTC x <$> classType (splitDictionary e) x)) | (d,e) <- ds, x <- grepMethods e]-    where-      grepMethods = filter GM.isMethod . freeVars mempty-      ds = filter (GM.isDictionary . fst) (concatMap unRec cbs)-      unRec (Ghc.Rec xes) = xes-      unRec (Ghc.NonRec x e) = [(x,e)]--      classType Nothing _ = Nothing-      classType (Just (d, ts, _)) x =-        case filter ((==d) . Ghc.dataConWorkId . dcpCon) cls of-          (di:_) -> (dcpLoc di `F.atLoc`) . subst (zip (dcpFreeTyVars di) ts) <$> L.lookup (mkSymbol x) (dcpTyArgs di)-          _      -> Nothing--      methodType d x m = ihastype (M.lookup d m) x--      ihastype Nothing _    = Nothing-      ihastype (Just xts) x = M.lookup (mkSymbol x) xts--      mkSymbol x = F.dropSym 2 $ GM.simplesymbol x--      subst [] t = t-      subst ((a,ta):su) t = subsTyVarMeet' (a,ofType ta) (subst su t)--addCC :: Bool -> Ghc.Var -> LocSpecType -> LocSpecType-addCC allowTC var zz@(Loc l l' st0)-  = Loc l l'-  . addForall hst-  . mkArrow [] ps' [] []-  . makeCls cs'-  . mapExprReft (\_ -> F.applyCoSub coSub)-  . subts su-  $ st-  where-    hst           = ofType (Ghc.expandTypeSynonyms t0) :: SpecType-    t0            = Ghc.varType var-    tyvsmap       = case Bare.runMapTyVars allowTC t0 st err of-                          Left e  -> Ex.throw e-                          Right s -> Bare.vmap s-    su            = [(y, rTyVar x)           | (x, y) <- tyvsmap]-    su'           = [(y, RVar (rTyVar x) ()) | (x, y) <- tyvsmap] :: [(RTyVar, RSort)]-    coSub         = M.fromList [(F.symbol y, F.FObj (F.symbol x)) | (y, x) <- su]-    ps'           = fmap (subts su') <$> ps-    cs'           = [(F.dummySymbol, RApp c ts [] mempty) | (c, ts) <- cs ]-    (_,_,cs,_)    = bkUnivClass (F.notracepp "hs-spec" $ ofType (Ghc.expandTypeSynonyms t0) :: SpecType)-    (_,ps,_ ,st)  = bkUnivClass (F.notracepp "lq-spec" st0)--    makeCls c t  = foldr (uncurry rFun) t c-    err hsT lqT   = ErrMismatch (GM.fSrcSpan zz) (pprint var)-      (text "makeMethodTypes")-      (pprint $ Ghc.expandTypeSynonyms t0)-      (pprint $ toRSort st0)-      (Just (hsT, lqT))-      (Ghc.getSrcSpan var)--    addForall (RAllT v t r) tt@(RAllT v' _ _)-      | v == v'-      = tt-      | otherwise-      = RAllT (updateRTVar v) (addForall t tt) r-    addForall (RAllT v t r) t'-      = RAllT (updateRTVar v) (addForall t t') r-    addForall (RAllP _ t) t'-      = addForall t t'-    addForall _ (RAllP p t')-      = RAllP (fmap (subts su') p) t'-    addForall (RFun _ _ t1 t2 _) (RFun x i t1' t2' r)-      = RFun x i (addForall t1 t1') (addForall t2 t2') r-    addForall _ t-      = t---splitDictionary :: Ghc.CoreExpr -> Maybe (Ghc.Var, [Ghc.Type], [Ghc.Var])-splitDictionary = go [] []-  where-    go ts xs (Ghc.App e (Ghc.Tick _ a)) = go ts xs (Ghc.App e a)-    go ts xs (Ghc.App e (Ghc.Type t))   = go (t:ts) xs e-    go ts xs (Ghc.App e (Ghc.Var x))    = go ts (x:xs) e-    go ts xs (Ghc.Tick _ t) = go ts xs t-    go ts xs (Ghc.Var x) = Just (x, reverse ts, reverse xs)-    go _ _ _ = Nothing-----------------------------------------------------------------------------------makeCLaws :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.ModSpecs-          -> Bare.Lookup [(Ghc.Class, [(ModName, Ghc.Var, LocSpecType)])]---------------------------------------------------------------------------------makeCLaws env sigEnv myName specs = do-  zMbs <- forM classTcs $ \(name, clss, tc) -> do-            clsMb <- mkClass env sigEnv myName name clss tc-            case clsMb of-              Nothing ->-                return Nothing-              Just cls -> do-                gcls <- Mb.maybe (err tc) Right (Ghc.tyConClass_maybe tc)-                return $ Just (gcls, snd cls)-  return (Mb.catMaybes zMbs)-  where-    err tc   = error ("Not a type class: " ++ F.showpp tc)-    classTc  = Bare.maybeResolveSym env myName "makeClass" . btc_tc . rcName-    classTcs = [ (name, cls, tc) | (name, spec) <- M.toList specs-                                 , cls          <- Ms.claws spec-                                 , tc           <- Mb.maybeToList (classTc cls)-               ]----------------------------------------------------------------------------------makeClasses :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.ModSpecs-            -> Bare.Lookup ([DataConP], [(ModName, Ghc.Var, LocSpecType)])---------------------------------------------------------------------------------makeClasses env sigEnv myName specs = do-  mbZs <- forM classTcs $ \(name, cls, tc) ->-            mkClass env sigEnv myName name cls tc-  return . second mconcat . unzip . Mb.catMaybes $ mbZs-  where-    classTcs = [ (name, cls, tc) | (name, spec) <- M.toList specs-                                 , cls          <- Ms.classes spec-                                 , tc           <- Mb.maybeToList (classTc cls) ]-    classTc = Bare.maybeResolveSym env myName "makeClass" . btc_tc . rcName--mkClass :: Bare.Env -> Bare.SigEnv -> ModName -> ModName -> RClass LocBareType -> Ghc.TyCon-        -> Bare.Lookup (Maybe (DataConP, [(ModName, Ghc.Var, LocSpecType)]))-mkClass env sigEnv _myName name (RClass cc ss as ms)-  = Bare.failMaybe env name-  . mkClassE env sigEnv _myName name (RClass cc ss as ms)--mkClassE :: Bare.Env -> Bare.SigEnv -> ModName -> ModName -> RClass LocBareType -> Ghc.TyCon-         -> Bare.Lookup (DataConP, [(ModName, Ghc.Var, LocSpecType)])-mkClassE env sigEnv _myName name (RClass cc ss as ms) tc = do-    ss'    <- mapM (mkConstr   env sigEnv name) ss-    meths  <- mapM (makeMethod env sigEnv name) ms'-    let vts = [ (m, v, t) | (m, kv, t) <- meths, v <- Mb.maybeToList (plugSrc kv) ]-    let sts = [(val s, unClass $ val t) | (s, _) <- ms | (_, _, t) <- meths]-    let dcp = DataConP l dc αs [] (val <$> ss') (reverse sts) rt False (F.symbol name) l'-    return  $ F.notracepp msg (dcp, vts)-  where-    c      = btc_tc cc-    l      = loc  c-    l'     = locE c-    msg    = "MKCLASS: " ++ F.showpp (cc, as, αs)-    (dc:_) = Ghc.tyConDataCons tc-    αs     = bareRTyVar <$> as-    as'    = [rVar $ GM.symbolTyVar $ F.symbol a | a <- as ]-    ms'    = [ (s, rFun "" (RApp cc (flip RVar mempty <$> as) [] mempty) <$> t) | (s, t) <- ms]-    rt     = rCls tc as'--mkConstr :: Bare.Env -> Bare.SigEnv -> ModName -> LocBareType -> Bare.Lookup LocSpecType-mkConstr env sigEnv name = fmap (fmap dropUniv) . Bare.cookSpecTypeE env sigEnv name Bare.GenTV-  where-    dropUniv t           = t' where (_, _, t') = bkUniv t--   --FIXME: cleanup this code-unClass :: SpecType -> SpecType-unClass = snd . bkClass . thrd3 . bkUniv--makeMethod :: Bare.Env -> Bare.SigEnv -> ModName -> (LocSymbol, LocBareType)-           -> Bare.Lookup (ModName, PlugTV Ghc.Var, LocSpecType)-makeMethod env sigEnv name (lx, bt) = (name, mbV,) <$> Bare.cookSpecTypeE env sigEnv name mbV bt-  where-    mbV = maybe Bare.GenTV Bare.LqTV (Bare.maybeResolveSym env name "makeMethod" lx)----------------------------------------------------------------------------------makeSpecDictionaries :: Bare.Env -> Bare.SigEnv -> ModSpecs -> DEnv Ghc.Var LocSpecType---------------------------------------------------------------------------------makeSpecDictionaries env sigEnv specs-  = dfromList-  . concatMap (makeSpecDictionary env sigEnv)-  $ M.toList specs--makeSpecDictionary :: Bare.Env -> Bare.SigEnv -> (ModName, Ms.BareSpec)-                   -> [(Ghc.Var, M.HashMap F.Symbol (RISig LocSpecType))]-makeSpecDictionary env sigEnv (name, spec)-  = Mb.catMaybes-  . resolveDictionaries env name-  . fmap (makeSpecDictionaryOne env sigEnv name)-  . Ms.rinstance-  $ spec--makeSpecDictionaryOne :: Bare.Env -> Bare.SigEnv -> ModName-                      -> RInstance LocBareType-                      -> (F.Symbol, M.HashMap F.Symbol (RISig LocSpecType))-makeSpecDictionaryOne env sigEnv name (RI bt lbt xts)-         = makeDictionary $ F.notracepp "RI" $ RI bt ts [(x, mkLSpecIType t) | (x, t) <- xts ]-  where-    ts      = mkTy' <$> lbt-    rts     = concatMap (univs . val) ts-    univs t = (\(RTVar tv _, _) -> tv) <$> as where (as, _, _) = bkUniv t--    mkTy' :: LocBareType -> LocSpecType-    mkTy' = Bare.cookSpecType env sigEnv name Bare.GenTV-    mkTy :: LocBareType -> LocSpecType-    mkTy = fmap (mapUnis tidy) . Bare.cookSpecType env sigEnv name-               Bare.GenTV -- (Bare.HsTV (Bare.lookupGhcVar env name "rawDictionaries" x))-    mapUnis f t = mkUnivs (f as) ps t0 where (as, ps, t0) = bkUniv t--    tidy vs = l ++ r-      where (l,r) = L.partition (\(RTVar tv _,_) -> tv `elem` rts) vs--    mkLSpecIType :: RISig LocBareType -> RISig LocSpecType-    mkLSpecIType t = fmap mkTy t--resolveDictionaries :: Bare.Env -> ModName -> [(F.Symbol, M.HashMap F.Symbol (RISig LocSpecType))]-                    -> [Maybe (Ghc.Var, M.HashMap F.Symbol (RISig LocSpecType))]-resolveDictionaries env name = fmap lookupVar-                             . concatMap addInstIndex-                             . Misc.groupList-  where-    lookupVar (x, inst)      = (, inst) <$> Bare.maybeResolveSym env name "resolveDict" (F.dummyLoc x)---- formerly, addIndex--- GHC internal postfixed same name dictionaries with ints-addInstIndex            :: (F.Symbol, [a]) -> [(F.Symbol, a)]-addInstIndex (x, ks) = go (0::Int) (reverse ks)-  where-    go _ []          = []-    go _ [i]         = [(x, i)]-    go j (i:is)      = (F.symbol (F.symbolString x ++ show j),i) : go (j+1) is-------------------------------------------------------------------------------------makeDefaultMethods :: Bare.Env -> [(ModName, Ghc.Var, LocSpecType)]-                   -> [(ModName, Ghc.Var, LocSpecType)]------------------------------------------------------------------------------------makeDefaultMethods env mts = [ (mname, dm, t)-                                 | (mname, m, t) <- mts-                                 , dm            <- lookupDefaultVar env mname m ]--lookupDefaultVar :: Bare.Env -> ModName -> Ghc.Var -> [Ghc.Var]-lookupDefaultVar env name v = Mb.maybeToList-                            . Bare.maybeResolveSym env name "default-method"-                            $ dmSym-  where-    dmSym                   = F.atLoc v (GM.qualifySymbol mSym dnSym)-    dnSym                   = F.mappendSym "$dm" nSym-    (mSym, nSym)            = GM.splitModuleName (F.symbol v)
− src/Language/Haskell/Liquid/Bare/DataType.hs 
@@ -1,812 +0,0 @@-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections     #-}--module Language.Haskell.Liquid.Bare.DataType-  ( dataConMap--  -- * Names for accessing Data Constuctors -  , makeDataConChecker-  , makeDataConSelector-  , addClassEmbeds--  -- * Constructors-  , makeDataDecls-  , makeConTypes-  , makeRecordSelectorSigs-  , meetDataConSpec-  -- , makeTyConEmbeds--  , dataDeclSize-  ) where--import           Prelude                                hiding (error)--import qualified Control.Exception                      as Ex-import           Control.Monad.Reader-import qualified Data.List                              as L-import qualified Data.HashMap.Strict                    as M-import qualified Data.HashSet                           as S-import qualified Data.Maybe                             as Mb--import qualified Language.Fixpoint.Types                as F-import qualified Liquid.GHC.Misc       as GM-import qualified Liquid.GHC.API        as Ghc-import           Language.Haskell.Liquid.Types.PredType (dataConPSpecType)-import qualified Language.Haskell.Liquid.Types.RefType  as RT-import           Language.Haskell.Liquid.Types.Types-import           Language.Haskell.Liquid.Types.Meet-import qualified Language.Fixpoint.Misc                 as Misc-import qualified Language.Haskell.Liquid.Misc           as Misc-import           Language.Haskell.Liquid.Types.Variance-import           Language.Haskell.Liquid.WiredIn-import           Language.Haskell.Liquid.Types.Names (selfSymbol)--import qualified Language.Haskell.Liquid.Measure        as Ms--import qualified Language.Haskell.Liquid.Bare.Types     as Bare-import qualified Language.Haskell.Liquid.Bare.Resolve   as Bare-import           Text.Printf                     (printf)-import Text.PrettyPrint ((<+>))------------------------------------------------------------------------------------- | 'DataConMap' stores the names of those ctor-fields that have been declared---   as SMT ADTs so we don't make up new names for them.----------------------------------------------------------------------------------dataConMap :: [F.DataDecl] -> Bare.DataConMap-dataConMap ds = M.fromList $ do-  d     <- ds-  c     <- F.ddCtors d-  let fs = F.symbol <$> F.dcFields c-  zip ((F.symbol c,) <$> [1..]) fs-------------------------------------------------------------------------------------- | 'makeDataConChecker d' creates the measure for `is$d` which tests whether---   a given value was created by 'd'. e.g. is$Nil or is$Cons.----------------------------------------------------------------------------------makeDataConChecker :: Ghc.DataCon -> F.Symbol----------------------------------------------------------------------------------makeDataConChecker = F.testSymbol . F.symbol------------------------------------------------------------------------------------- | 'makeDataConSelector d' creates the selector `select$d$i`---   which projects the i-th field of a constructed value.---   e.g. `select$Cons$1` and `select$Cons$2` are respectively---   equivalent to `head` and `tail`.----------------------------------------------------------------------------------makeDataConSelector :: Maybe Bare.DataConMap -> Ghc.DataCon -> Int -> F.Symbol-makeDataConSelector dmMb d i = M.lookupDefault def (F.symbol d, i) dm-  where-    dm                       = Mb.fromMaybe M.empty dmMb-    def                      = makeDataConSelector' d i---makeDataConSelector' :: Ghc.DataCon -> Int -> F.Symbol-makeDataConSelector' d i-  = symbolMeasure "$select" (dcSymbol d) (Just i)--dcSymbol :: Ghc.DataCon -> F.Symbol-dcSymbol = {- simpleSymbolVar -} F.symbol . Ghc.dataConWorkId--symbolMeasure :: String -> F.Symbol -> Maybe Int -> F.Symbol-symbolMeasure f d iMb = foldr1 F.suffixSymbol (dcPrefix : F.symbol f : d : rest)-  where-    rest          = maybe [] (Misc.single . F.symbol . show) iMb-------------------------------------------------------------------------------------- | makeClassEmbeds: sort-embeddings for numeric, and family-instance tycons----------------------------------------------------------------------------------addClassEmbeds :: Maybe [Ghc.ClsInst] -> [Ghc.TyCon] -> F.TCEmb Ghc.TyCon-               -> F.TCEmb Ghc.TyCon-addClassEmbeds instenv fiTcs = makeFamInstEmbeds fiTcs . makeNumEmbeds instenv------------------------------------------------------------------------------------- | makeFamInstEmbeds : embed family instance tycons, see [NOTE:FamInstEmbeds]------------------------------------------------------------------------------------     Query.R$58$EntityFieldBlobdog---   with the actual family instance  types that have numeric instances as int [Check!]----------------------------------------------------------------------------------makeFamInstEmbeds :: [Ghc.TyCon] -> F.TCEmb Ghc.TyCon -> F.TCEmb Ghc.TyCon-makeFamInstEmbeds cs0 embeds = L.foldl' embed embeds famInstSorts-  where-    famInstSorts          = F.notracepp "famInstTcs"-                            [ (c, RT.typeSort embeds ty)-                                | c   <- cs-                                , ty  <- Mb.maybeToList (RT.famInstTyConType c) ]-    embed embs (c, t)     = F.tceInsert c t F.NoArgs embs-    cs                    = F.notracepp "famInstTcs-all" cs0--{- -famInstTyConType :: Ghc.TyCon -> Maybe Ghc.Type-famInstTyConType c = case Ghc.tyConFamInst_maybe c of-    Just (c', ts) -> F.tracepp ("famInstTyConType: " ++ F.showpp (c, Ghc.tyConArity c, ts)) -                     $ Just (famInstType (Ghc.tyConArity c) c' ts)-    Nothing       -> Nothing--famInstType :: Int -> Ghc.TyCon -> [Ghc.Type] -> Ghc.Type-famInstType n c ts = Ghc.mkTyConApp c (take (length ts - n) ts)--}--{- | [NOTE:FamInstEmbeds] GHC represents family instances in two ways: --     (1) As an applied type, -     (2) As a special tycon.-     -     For example, consider `tests/pos/ExactGADT4.hs`:--        class PersistEntity record where-          data EntityField record :: * -> *--        data Blob = B { xVal :: Int, yVal :: Int }--        instance PersistEntity Blob where-           data EntityField Blob dog where-             BlobXVal :: EntityField Blob Int-             BlobYVal :: EntityField Blob Int--     here, the type of the constructor `BlobXVal` can be represented as:--     (1) EntityField Blob Int,--     or--     (2) R$58$EntityFieldBlobdog Int--     PROBLEM: For various reasons, GHC will use _both_ representations interchangeably,-     which messes up our sort-checker.--     SOLUTION: To address the above, we create an "embedding"--        R$58$EntityFieldBlobdog :-> EntityField Blob--     So that all occurrences of the (2) are treated as (1) by the sort checker.-- -}------------------------------------------------------------------------------------- | makeNumEmbeds: embed types that have numeric instances as int [Check!]----------------------------------------------------------------------------------makeNumEmbeds :: Maybe [Ghc.ClsInst] -> F.TCEmb Ghc.TyCon -> F.TCEmb Ghc.TyCon-makeNumEmbeds Nothing x   = x-makeNumEmbeds (Just is) x = L.foldl' makeNumericInfoOne x is--makeNumericInfoOne :: F.TCEmb Ghc.TyCon -> Ghc.ClsInst -> F.TCEmb Ghc.TyCon-makeNumericInfoOne m is-  | isFracCls cls, Just tc <- instanceTyCon is-  = F.tceInsertWith (flip mappendSortFTC) tc (ftc tc True True) F.NoArgs m-  | isNumCls  cls, Just tc <- instanceTyCon is-  = F.tceInsertWith (flip mappendSortFTC) tc (ftc tc True False) F.NoArgs m-  | otherwise-  = m-  where-    cls         = Ghc.classTyCon (Ghc.is_cls is)-    ftc c f1 f2 = F.FTC (F.symbolNumInfoFTyCon (dummyLoc $ RT.tyConName c) f1 f2)--mappendSortFTC :: F.Sort -> F.Sort -> F.Sort-mappendSortFTC (F.FTC x) (F.FTC y) = F.FTC (F.mappendFTC x y)-mappendSortFTC s         (F.FTC _) = s-mappendSortFTC (F.FTC _) s         = s-mappendSortFTC s1        s2        = panic Nothing ("mappendSortFTC: s1 = " ++ showpp s1 ++ " s2 = " ++ showpp s2)--instanceTyCon :: Ghc.ClsInst -> Maybe Ghc.TyCon-instanceTyCon = go . Ghc.is_tys-  where-    go [Ghc.TyConApp c _] = Just c-    go _                  = Nothing------------------------------------------------------------------------------------- | Create Fixpoint DataDecl from LH DataDecls --------------------------------------------------------------------------------------------------------------------- | A 'DataPropDecl' is associated with a (`TyCon` and) `DataDecl`, and defines the---   sort of relation that is established by terms of the given `TyCon`.---   A 'DataPropDecl' say, 'pd' is associated with a 'dd' of type 'DataDecl' when---   'pd' is the `SpecType` version of the `BareType` given by `tycPropTy dd`.--type DataPropDecl = (DataDecl, Maybe SpecType)--makeDataDecls :: Config -> F.TCEmb Ghc.TyCon -> ModName-              -> [(ModName, Ghc.TyCon, DataPropDecl)]-              -> [Located DataConP]-              -> (Diagnostics, [F.DataDecl])-makeDataDecls cfg tce name tds ds-  | makeDecls        = (mkDiagnostics warns [], okDecs)-  | otherwise        = (mempty, [])-  where-    makeDecls        = exactDCFlag cfg && not (noADT cfg)-    warns            = (mkWarnDecl . fst . fst . snd <$> badTcs) ++ (mkWarnDecl <$> badDecs)-    tds'             = resolveTyCons name tds-    tcDds            = filter ((/= Ghc.listTyCon) . fst)-                     $ groupDataCons tds' ds-    (okTcs, badTcs)  = L.partition isVanillaTc tcDds-    decs             = [ makeFDataDecls tce tc dd ctors | (tc, (dd, ctors)) <- okTcs]-    (okDecs,badDecs) = checkRegularData decs--isVanillaTc :: (a, (b, [(Ghc.DataCon, c)])) -> Bool-isVanillaTc (_, (_, ctors)) = all (Ghc.isVanillaDataCon . fst) ctors--checkRegularData :: [F.DataDecl] -> ([F.DataDecl], [F.DataDecl])-checkRegularData ds = (oks, badDs)-  where-    badDs           = F.checkRegular ds-    badSyms         = {- F.notracepp "BAD-Data" . -} S.fromList . fmap F.symbol $ badDs-    oks             = [ d |  d <- ds, not (S.member (F.symbol d) badSyms) ]--mkWarnDecl :: (F.Loc a, F.Symbolic a) => a -> Warning-mkWarnDecl d = mkWarning (GM.fSrcSpan d) ("Non-regular data declaration" <+> pprint (F.symbol d))----- [NOTE:Orphan-TyCons]--{- | 'resolveTyCons' will prune duplicate 'TyCon' definitions, as follows:--      Let the "home" of a 'TyCon' be the module where it is defined.-      There are three kinds of 'DataDecl' definitions:--      1. A  "home"-definition is one that belongs to its home module,-      2. An "orphan"-definition is one that belongs to some non-home module.--      A 'DataUser' definition MUST be a "home" definition-          - otherwise you can avoid importing the definition-            and hence, unsafely pass its invariants!--      So, 'resolveTyConDecls' implements the following protocol:--      (a) If there is a "Home" definition,-          then use it, and IGNORE others.--      (b) If there are ONLY "orphan" definitions,-          then pick the one from module being analyzed.--      We COULD relax to allow for exactly one orphan `DataUser` definition-      which is the one that should be selected, but that seems like a-      slippery slope, as you can avoid importing the definition-      and hence, unsafely pass its invariants! (Feature not bug?)---}-resolveTyCons :: ModName -> [(ModName, Ghc.TyCon, DataPropDecl)]-              -> [(Ghc.TyCon, (ModName, DataPropDecl))]-resolveTyCons mn mtds = [(tc, (m, d)) | (tc, mds) <- M.toList tcDecls-                                      , (m, d)    <- Mb.maybeToList $ resolveDecls mn tc mds ]-  where-    tcDecls          = Misc.group [ (tc, (m, d)) | (m, tc, d) <- mtds ]---- | See [NOTE:Orphan-TyCons], the below function tells us which of (possibly many)---   DataDecls to use.-resolveDecls :: ModName -> Ghc.TyCon -> Misc.ListNE (ModName, DataPropDecl)-             -> Maybe (ModName, DataPropDecl)-resolveDecls mName tc mds  = F.notracepp msg $ Misc.firstMaybes $ (`L.find` mds) <$> [ isHomeDef , isMyDef]-  where-    msg                    = "resolveDecls" ++ F.showpp (mName, tc)-    isMyDef                = (mName ==)             . fst-    isHomeDef              = (tcHome ==) . F.symbol . fst-    tcHome                 = GM.takeModuleNames (F.symbol tc)--groupDataCons :: [(Ghc.TyCon, (ModName, DataPropDecl))]-              -> [Located DataConP]-              -> [(Ghc.TyCon, (DataPropDecl, [(Ghc.DataCon, DataConP)]))]-groupDataCons tds ds = [ (tc, (d, dds')) | (tc, ((m, d), dds)) <- tcDataCons-                                         , let dds' = filter (isResolvedDataConP m . snd) dds-                       ]-  where-    tcDataCons       = M.toList $ M.intersectionWith (,) declM ctorM-    declM            = M.fromList tds-    ctorM            = Misc.group [(Ghc.dataConTyCon d, (d, dcp)) | Loc _ _ dcp <- ds, let d = dcpCon dcp]--isResolvedDataConP :: ModName -> DataConP -> Bool-isResolvedDataConP m dp = F.symbol m == dcpModule dp--makeFDataDecls :: F.TCEmb Ghc.TyCon -> Ghc.TyCon -> DataPropDecl -> [(Ghc.DataCon, DataConP)]-               -> F.DataDecl-makeFDataDecls tce tc dd ctors = makeDataDecl tce tc (fst dd) ctors--makeDataDecl :: F.TCEmb Ghc.TyCon -> Ghc.TyCon -> DataDecl -> [(Ghc.DataCon, DataConP)]-             -> F.DataDecl-makeDataDecl tce tc dd ctors-  = F.DDecl-      { F.ddTyCon = ftc-      , F.ddVars  = length                $  GM.tyConTyVarsDef tc-      , F.ddCtors = makeDataCtor tce ftc <$> ctors-      }-  where-    ftc = F.symbolFTycon (tyConLocSymbol tc dd)--tyConLocSymbol :: Ghc.TyCon -> DataDecl -> LocSymbol-tyConLocSymbol tc dd = F.atLoc (tycName dd) (F.symbol tc)---- [NOTE:ADT] We need to POST-PROCESS the 'Sort' so that:--- 1. The poly tyvars are replaced with debruijn---    versions e.g. 'List a_a1m' becomes 'List @(1)'--- 2. The "self" type is replaced with just itself---    (i.e. without any type applications.)--makeDataCtor :: F.TCEmb Ghc.TyCon -> F.FTycon -> (Ghc.DataCon, DataConP) -> F.DataCtor-makeDataCtor tce c (d, dp) = F.DCtor-  { F.dcName    = GM.namedLocSymbol d-  , F.dcFields  = makeDataFields tce c as xts-  }-  where-    as          = dcpFreeTyVars dp-    xts         = [ (fld x, t) | (x, t) <- reverse (dcpTyArgs dp) ]-    fld         = F.atLoc dp . fieldName d dp--fieldName :: Ghc.DataCon -> DataConP -> F.Symbol -> F.Symbol-fieldName d dp x-  | dcpIsGadt dp = F.suffixSymbol (F.symbol d) x-  | otherwise    = x--makeDataFields :: F.TCEmb Ghc.TyCon -> F.FTycon -> [RTyVar] -> [(F.LocSymbol, SpecType)]-               -> [F.DataField]-makeDataFields tce _c as xts = [ F.DField x (fSort t) | (x, t) <- xts]-  where-    su    = zip (F.symbol <$> as) [0..]-    fSort = F.substVars su . F.mapFVar (+ length as) . RT.rTypeSort tce--{- -muSort :: F.FTycon -> Int -> F.Sort -> F.Sort-muSort c n  = V.mapSort tx-  where-    ct      = F.fTyconSort c-    me      = F.fTyconSelfSort c n-    tx t    = if t == me then ct else t--}-----------------------------------------------------------------------------------meetDataConSpec :: Bool -> F.TCEmb Ghc.TyCon -> [(Ghc.Var, SpecType)] -> [DataConP]-                -> [(Ghc.Var, SpecType)]----------------------------------------------------------------------------------meetDataConSpec allowTC emb xts dcs  = M.toList $ snd <$> L.foldl' upd dcm0 xts-  where-    dcm0                     = M.fromListWith meetM (dataConSpec' allowTC dcs)-    upd dcm (x, t)           = M.insert x (Ghc.getSrcSpan x, tx') dcm-                                where-                                  tx' = maybe t (meetX x t) (M.lookup x dcm)-    meetM (l,t) (_,t')       = (l, t `F.meet` t')-    meetX x t (sp', t')      = F.notracepp (_msg x t t') $ meetVarTypes emb (pprint x) (Ghc.getSrcSpan x, t) (sp', t')-    _msg x t t'              = "MEET-VAR-TYPES: " ++ showpp (x, t, t')--dataConSpec' :: Bool -> [DataConP] -> [(Ghc.Var, (Ghc.SrcSpan, SpecType))]-dataConSpec' allowTC = concatMap tx-  where-    tx dcp   =  [ (x, res) | (x, t0) <- dataConPSpecType allowTC dcp-                          , let t    = RT.expandProductType x t0-                          , let res  = (GM.fSrcSpan dcp, t)-                ]------------------------------------------------------------------------------------ | Bare Predicate: DataCon Definitions -------------------------------------------------------------------------------------------------------------------------makeConTypes :: ModName -> Bare.Env -> [(ModName, Ms.BareSpec)]-             -> Bare.Lookup ([(ModName, TyConP, Maybe DataPropDecl)], [[Located DataConP]])-makeConTypes myName env specs =-  Misc.concatUnzip <$> mapM (makeConTypes' myName env) specs---makeConTypes' :: ModName -> Bare.Env -> (ModName, Ms.BareSpec)-             -> Bare.Lookup ([(ModName, TyConP, Maybe DataPropDecl)], [[Located DataConP]])-makeConTypes' _myName env (name, spec) = do-  dcs'   <- canonizeDecls env name dcs-  let dcs'' = dataDeclSize spec dcs'-  let gvs = groupVariances dcs'' vdcs-  zong <- catLookups . map (uncurry (ofBDataDecl env name)) $ gvs-  return (unzip zong)-  where-    dcs  = Ms.dataDecls spec-    vdcs = Ms.dvariance spec---type DSizeMap = M.HashMap F.Symbol (F.Symbol, [F.Symbol])-normalizeDSize :: [([LocBareType], F.LocSymbol)] -> DSizeMap-normalizeDSize ds = M.fromList (concatMap go ds)-  where go (ts,x) = let xs = Mb.mapMaybe (getTc . val) ts-                    in [(tc, (val x, xs)) | tc <- xs]-        getTc (RAllT _ t _)  = getTc t-        getTc (RApp c _ _ _) = Just (val $ btc_tc c)-        getTc _ = Nothing--dataDeclSize :: Ms.BareSpec -> [DataDecl] -> [DataDecl]-dataDeclSize spec dcs = makeSize smap <$> dcs-  where smap = normalizeDSize $ Ms.dsize spec---makeSize :: DSizeMap -> DataDecl -> DataDecl-makeSize smap d-  | Just p <- M.lookup (F.symbol $ tycName d) smap-  = d {tycDCons = fmap (fmap (makeSizeCtor p)) (tycDCons d) }-  | otherwise-   = d--makeSizeCtor :: (F.Symbol, [F.Symbol]) -> DataCtor -> DataCtor-makeSizeCtor (s,xs) d = d {dcFields = Misc.mapSnd (mapBot go) <$> dcFields d}-  where-    go (RApp c ts rs r) | F.symbol c `elem` xs-                        = RApp c ts rs (r `F.meet` rsz)-    go t                = t-    rsz  = MkUReft (F.Reft (F.vv_, F.PAtom F.Lt-                                      (F.EApp (F.EVar s) (F.EVar F.vv_))-                                      (F.EApp (F.EVar s) (F.EVar selfSymbol))-                                      ))-                   mempty---catLookups :: [Bare.Lookup a] -> Bare.Lookup [a]-catLookups = sequence . Mb.mapMaybe skipResolve--skipResolve  :: Bare.Lookup a -> Maybe (Bare.Lookup a)-skipResolve (Left es) = left' (filter (not . isErrResolve) es)-skipResolve (Right v) = Just (Right v)--isErrResolve :: TError t -> Bool-isErrResolve ErrResolve {} = True-isErrResolve _             =  False--left' :: [e] -> Maybe (Either [e] a)-left' [] = Nothing-left' es = Just (Left es)----- | 'canonizeDecls ds' returns a subset of 'ds' with duplicates, e.g. arising---   due to automatic lifting (via 'makeHaskellDataDecls'). We require that the---   lifted versions appear LATER in the input list, and always use those---   instead of the unlifted versions.--canonizeDecls :: Bare.Env -> ModName -> [DataDecl] -> Bare.Lookup [DataDecl]-canonizeDecls env name dataDecls = do-  kds <- forM dataDecls $ \d -> do-           k <- dataDeclKey env name d-           return (fmap (, d) k)-  case Misc.uniqueByKey' selectDD (Mb.catMaybes kds) of-    Left  decls  -> Left [err decls]-    Right decls  -> return decls-            -- [ (k, d) | d <- ds, k <- rights [dataDeclKey env name d] ] -  -- case Misc.uniqueByKey' selectDD kds of-    -- Left  decls  -> err    decls-    -- Right decls  -> decls-  where-    -- kds          = F.tracepp "canonizeDecls" [ (k, d) | d <- ds, k <- rights [dataDeclKey env name d] ] -    err ds@(d:_) = {- uError $ -} errDupSpecs (pprint (tycName d)) (GM.fSrcSpan <$> ds)-    err _        = impossible Nothing "canonizeDecls"--dataDeclKey :: Bare.Env -> ModName -> DataDecl -> Bare.Lookup (Maybe F.Symbol)-dataDeclKey env name d = do-  tcMb  <- Bare.lookupGhcDnTyCon env name "canonizeDecls" (tycName d)-  case tcMb of-    Nothing ->-      return Nothing-    Just tc -> do-      _ <- checkDataCtors env name tc d (tycDCons d)-      return $ Just (F.symbol tc)---- | Perform sanity check on the data constructors of a LH datatype declaration.------ In the special situation where the LH datatype declaration is only used to--- attach a termination measure, we pass 'Nothing', and our check always succeeds.------ Otherwise, we check that the constructors match the constructors for the--- Haskell datatype. This replaces an older check that only verified that any--- constructor we list in a datatype is indeed a constructor of that corresponding--- Haskell datatype.------ We also check that constructors do not have duplicate fields.----checkDataCtors :: Bare.Env -> ModName -> Ghc.TyCon -> DataDecl -> Maybe [DataCtor] -> Bare.Lookup [DataCtor]-checkDataCtors _env _name _c _dd Nothing     = return []-checkDataCtors  env  name  c  dd (Just cons) = do-  -- The GHC data constructors (these are qualified)-  let dcs :: S.HashSet F.Symbol-      dcs = S.fromList . fmap F.symbol . Ghc.tyConDataCons $ c--  -- The data constructors in the spec (which we have to qualify for them to match the GHC data constructors)-  mbDcs <- mapM (Bare.failMaybe env name . Bare.lookupGhcDataCon env name "checkDataCtors" . dcName) cons-  let rdcs = S.fromList . fmap F.symbol . Mb.catMaybes $ mbDcs-  if dcs == rdcs-    then mapM checkDataCtorDupField cons-    else Left [errDataConMismatch (dataNameSymbol (tycName dd)) dcs rdcs]---- | Checks whether the given data constructor has duplicate fields.----checkDataCtorDupField :: DataCtor -> Bare.Lookup DataCtor-checkDataCtorDupField d-  | x : _ <- dups = Left [err sym x]-  | otherwise     = return d-    where-      sym         = dcName   d-      xts         = dcFields d-      dups        = [ x | (x, ts) <- Misc.groupList xts, 2 <= length ts ]-      err lc x    = ErrDupField (GM.sourcePosSrcSpan $ loc lc) (pprint $ val lc) (pprint x)--selectDD :: (a, [DataDecl]) -> Either [DataDecl] DataDecl-selectDD (_,[d]) = Right d-selectDD (_, ds) = case [ d | d <- ds, tycKind d == DataReflected ] of-                     [d] -> Right d-                     _   -> Left  ds--groupVariances :: [DataDecl]-               -> [(LocSymbol, [Variance])]-               -> [(Maybe DataDecl, Maybe (LocSymbol, [Variance]))]-groupVariances dcs vdcs     =  merge (L.sort dcs) (L.sortBy (\x y -> compare (fst x) (fst y)) vdcs)-  where-    merge (d:ds) (v:vs)-      | F.symbol d == sym v = (Just d, Just v)  : merge ds vs-      | F.symbol d <  sym v = (Just d, Nothing) : merge ds (v:vs)-      | otherwise           = (Nothing, Just v) : merge (d:ds) vs-    merge []     vs         = (Nothing,) . Just <$> vs-    merge ds     []         = (,Nothing) . Just <$> ds-    sym                     = val . fst----- | 'checkDataDecl' checks that the supplied DataDecl is indeed a refinement---   of the GHC TyCon. We just check that the right tyvars are supplied---   as errors in the names and types of the constructors will be caught---   elsewhere. [e.g. tests/errors/BadDataDecl.hs]--checkDataDecl :: Ghc.TyCon -> DataDecl -> Bool-checkDataDecl c d = F.notracepp _msg (isGADT || cN == dN || null (tycDCons d))-  where-    _msg          = printf "checkDataDecl: D = %s, c = %s, cN = %d, dN = %d" (show d) (show c) cN dN-    cN            = length (GM.tyConTyVarsDef c)-    dN            = length (tycTyVars         d)-    isGADT        = Ghc.isGadtSyntaxTyCon c--getDnTyCon :: Bare.Env -> ModName -> DataName -> Bare.Lookup Ghc.TyCon-getDnTyCon env name dn = do-  tcMb <- Bare.lookupGhcDnTyCon env name "ofBDataDecl-1" dn-  case tcMb of-    Just tc -> return tc-    Nothing -> Left [ ErrBadData (GM.fSrcSpan dn) (pprint dn) "Unknown Type Constructor" ]-  --  ugh              = impossible Nothing "getDnTyCon"----- FIXME: ES: why the maybes?-ofBDataDecl :: Bare.Env -> ModName -> Maybe DataDecl -> Maybe (LocSymbol, [Variance])-            -> Bare.Lookup ( (ModName, TyConP, Maybe DataPropDecl), [Located DataConP] )-ofBDataDecl env name (Just dd@(DataDecl tc as ps cts pos sfun pt _)) maybe_invariance_info = do-  let Loc lc lc' _ = dataNameSymbol tc-  let πs           = Bare.ofBPVar env name pos <$> ps-  let αs           = RTV . GM.symbolTyVar <$> as-  let n            = length αs-  let initmap      = zip (RT.uPVar <$> πs) [0..]-  tc'             <- getDnTyCon env name tc-  cts'            <- mapM (ofBDataCtor env name lc lc' tc' αs ps πs) (Mb.fromMaybe [] cts)-  unless (checkDataDecl tc' dd) (Left [err])-  let pd           = Bare.ofBareType env name lc (Just []) <$> F.tracepp "ofBDataDecl-prop" pt-  let tys          = [t | dcp <- cts', (_, t) <- dcpTyArgs dcp]-  let varInfo      = L.nub $  concatMap (getPsSig initmap True) tys-  let defPs        = varSignToVariance varInfo <$> [0 .. (length πs - 1)]-  let (tvi, pvi)   = case maybe_invariance_info of-                       Nothing     -> ([], defPs)-                       Just (_,is) -> let is_n = drop n is in-                                      (take n is, if null is_n then defPs else is_n)-  let tcp          = TyConP lc tc' αs πs tvi pvi sfun-  return ((name, tcp, Just (dd { tycDCons = cts }, pd)), Loc lc lc' <$> cts')-  where-    err            = ErrBadData (GM.fSrcSpan tc) (pprint tc) "Mismatch in number of type variables"--ofBDataDecl env name Nothing (Just (tc, is)) =-  case Bare.lookupGhcTyCon env name "ofBDataDecl-2" tc of-    Left e    -> Left e-    Right tc' -> Right ((name, TyConP srcpos tc' [] [] tcov tcontr Nothing, Nothing), [])-  where-    (tcov, tcontr) = (is, [])-    srcpos         = F.dummyPos "LH.DataType.Variance"--ofBDataDecl _ _ Nothing Nothing-  = panic Nothing "Bare.DataType.ofBDataDecl called on invalid inputs"---- TODO:EFFECTS:ofBDataCon-ofBDataCtor :: Bare.Env-            -> ModName-            -> F.SourcePos-            -> F.SourcePos-            -> Ghc.TyCon-            -> [RTyVar]-            -> [PVar BSort]-            -> [PVar RSort]-            -> DataCtor-            -> Bare.Lookup DataConP-ofBDataCtor env name l l' tc αs ps πs dc = do-  c' <- Bare.lookupGhcDataCon env name "ofBDataCtor" (dcName dc)-  return (ofBDataCtorTc env name l l' tc αs ps πs dc c')--ofBDataCtorTc :: Bare.Env -> ModName -> F.SourcePos -> F.SourcePos ->-                 Ghc.TyCon -> [RTyVar] -> [PVar BSort] -> [PVar RSort] -> DataCtor -> Ghc.DataCon ->-                 DataConP-ofBDataCtorTc env name l l' tc αs ps πs _ctor@(DataCtor _c as _ xts res) c' =-  DataConP-    { dcpLoc        = l-    , dcpCon        = c'-    , dcpFreeTyVars = RT.symbolRTyVar <$> as-    , dcpFreePred   = πs-    , dcpTyConstrs  = cs-    , dcpTyArgs     = zts-    , dcpTyRes      = ot-    , dcpIsGadt     = isGadt-    , dcpModule     = F.symbol name-    , dcpLocE       = l'-    }-  where-    ts'           = Bare.ofBareType env name l (Just ps) <$> ts-    res'          = Bare.ofBareType env name l (Just ps) <$> res-    t0'           = dataConResultTy c' αs t0 res'-    _cfg          = getConfig env-    (yts, ot)     = qualifyDataCtor (not isGadt) name dLoc (zip xs ts', t0')-    zts           = zipWith (normalizeField c') [1..] (reverse yts)-    usedTvs       = S.fromList (ty_var_value <$> concatMap RT.freeTyVars (t0':ts'))-    cs            = [ p | p <- RT.ofType <$> Ghc.dataConTheta c', keepPredType usedTvs p ]-    (xs, ts)      = unzip xts-    t0            = case RT.famInstTyConType tc of-                      Nothing -> RT.gApp tc αs πs-                      Just ty -> RT.ofType ty-    isGadt        = Mb.isJust res-    dLoc          = F.Loc l l' ()--errDataConMismatch :: LocSymbol -> S.HashSet F.Symbol -> S.HashSet F.Symbol -> Error-errDataConMismatch d dcs rdcs = ErrDataConMismatch sp v (ppTicks <$> S.toList dcs) (ppTicks <$> S.toList rdcs)-  where-    v                 = pprint (val d)-    sp                = GM.sourcePosSrcSpan (loc d)--varSignToVariance :: Eq a => [(a, Bool)] -> a -> Variance-varSignToVariance varsigns i = case filter (\p -> fst p == i) varsigns of-                                []       -> Invariant-                                [(_, b)] -> if b then Covariant else Contravariant-                                _        -> Bivariant--getPsSig :: [(UsedPVar, a)] -> Bool -> SpecType -> [(a, Bool)]-getPsSig m pos (RAllT _ t r)-  = addps m pos r ++  getPsSig m pos t-getPsSig m pos (RApp _ ts rs r)-  = addps m pos r ++ concatMap (getPsSig m pos) ts-    ++ concatMap (getPsSigPs m pos) rs-getPsSig m pos (RVar _ r)-  = addps m pos r-getPsSig m pos (RAppTy t1 t2 r)-  = addps m pos r ++ getPsSig m pos t1 ++ getPsSig m pos t2-getPsSig m pos (RFun _ _ t1 t2 r)-  = addps m pos r ++ getPsSig m pos t2 ++ getPsSig m (not pos) t1-getPsSig m pos (RHole r)-  = addps m pos r-getPsSig _ _ z-  = panic Nothing $ "getPsSig" ++ show z--getPsSigPs :: [(UsedPVar, a)] -> Bool -> SpecProp -> [(a, Bool)]-getPsSigPs m pos (RProp _ (RHole r)) = addps m pos r-getPsSigPs m pos (RProp _ t) = getPsSig m pos t--addps :: [(UsedPVar, a)] -> b -> UReft t -> [(a, b)]-addps m pos (MkUReft _ ps) = (, pos) . f  <$> pvars ps-  where-    f = Mb.fromMaybe (panic Nothing "Bare.addPs: notfound") . (`L.lookup` m) . RT.uPVar--keepPredType :: S.HashSet RTyVar -> SpecType -> Bool-keepPredType tvs p-  | Just (tv, _) <- eqSubst p = S.member tv tvs-  | otherwise                 = True----- | This computes the result of a `DataCon` application.---   For 'isVanillaDataCon' we can just use the `TyCon`---   applied to the relevant tyvars.-dataConResultTy :: Ghc.DataCon-                -> [RTyVar]         -- ^ DataConP ty-vars-                -> SpecType         -- ^ vanilla result type-                -> Maybe SpecType   -- ^ user-provided result type-                -> SpecType-dataConResultTy c _ _ (Just t) = F.notracepp ("dataConResultTy-3 : vanilla = " ++ show (Ghc.isVanillaDataCon c) ++ " : ") t-dataConResultTy c _ t _-  | Ghc.isVanillaDataCon c     = F.notracepp ("dataConResultTy-1 : " ++ F.showpp c) t-  | otherwise                  = F.notracepp ("dataConResultTy-2 : " ++ F.showpp c) $ RT.ofType ct-  where-    (_,_,_,_,_,ct)             = Ghc.dataConFullSig c--eqSubst :: SpecType -> Maybe (RTyVar, SpecType)-eqSubst (RApp c [_, _, RVar a _, t] _ _)-  | rtc_tc c == Ghc.eqPrimTyCon = Just (a, t)-eqSubst _                       = Nothing--normalizeField :: Ghc.DataCon -> Int -> (F.Symbol, a) -> (F.Symbol, a)-normalizeField c i (x, t)-  | isTmp x   = (xi, t)-  | otherwise = (x , t)-  where-    isTmp     = F.isPrefixOfSym F.tempPrefix-    xi        = makeDataConSelector Nothing c i---- | `qualifyDataCtor` qualfies the field names for each `DataCtor` to---   ensure things work properly when exported.-type CtorType = ([(F.Symbol, SpecType)], SpecType)--qualifyDataCtor :: Bool -> ModName -> F.Located a -> CtorType -> CtorType-qualifyDataCtor qualFlag name l ct@(xts, st)- | qualFlag  = (xts', t')- | otherwise = ct- where-   t'        = F.subst su <$> st-   xts'      = [ (qx, F.subst su t)       | (qx, t, _) <- fields ]-   su        = F.mkSubst [ (x, F.eVar qx) | (qx, _, Just x) <- fields ]-   fields    = [ (qx, t, mbX) | (x, t) <- xts, let (mbX, qx) = qualifyField name (F.atLoc l x) ]--qualifyField :: ModName -> LocSymbol -> (Maybe F.Symbol, F.Symbol)-qualifyField name lx- | needsQual = (Just x, F.notracepp msg $ qualifyModName name x)- | otherwise = (Nothing, x)- where-   msg       = "QUALIFY-NAME: " ++ show x ++ " in module " ++ show (F.symbol name)-   x         = val lx-   needsQual = not (isWiredIn lx)--checkRecordSelectorSigs :: [(Ghc.Var, LocSpecType)] -> [(Ghc.Var, LocSpecType)]-checkRecordSelectorSigs vts = [ (v, take1 v lspecTys) | (v, lspecTys) <- Misc.groupList vts ]-  where-    take1 v lsts            = case Misc.nubHashOn (showpp . val) lsts of-                                [t]    -> t-                                (t:ts) -> Ex.throw (ErrDupSpecs (GM.fSrcSpan t) (pprint v) (GM.fSrcSpan <$> ts) :: Error)-                                _      -> impossible Nothing "checkRecordSelectorSigs"---strengthenClassSel :: Ghc.Var -> LocSpecType -> LocSpecType-strengthenClassSel v lt = lt { val = st }- where-  st = runReader (go (F.val lt)) (1, [])-  s = GM.namedLocSymbol v-  extend :: F.Symbol -> (Int, [F.Symbol]) -> (Int, [F.Symbol])-  extend x (i, xs) = (i + 1, x : xs)-  go :: SpecType -> Reader (Int, [F.Symbol]) SpecType-  go (RAllT a t r) = RAllT a <$> go t <*> pure r-  go (RAllP p t  ) = RAllP p <$> go t-  go (RFun x i tx t r) | isEmbeddedClass tx =-    RFun x i tx <$> go t <*> pure r-  go (RFun x i tx t r) = do-    x' <- unDummy x <$> reader fst-    r' <- singletonApp s <$> (L.reverse <$> reader snd)-    RFun x' i tx <$> local (extend x') (go t) <*> pure (F.meet r r')-  go t = RT.strengthen t . singletonApp s . L.reverse <$> reader snd--singletonApp :: F.Symbolic a => F.LocSymbol -> [a] -> UReft F.Reft-singletonApp s ys = MkUReft r mempty-  where r = F.exprReft (F.mkEApp s (F.eVar <$> ys))---unDummy :: F.Symbol -> Int -> F.Symbol-unDummy x i | x /= F.dummySymbol = x-            | otherwise          = F.symbol ("_cls_lq" ++ show i)--makeRecordSelectorSigs :: Bare.Env -> ModName -> [Located DataConP] -> [(Ghc.Var, LocSpecType)]-makeRecordSelectorSigs env name = checkRecordSelectorSigs . concatMap makeOne-  where-  makeOne (Loc l l' dcp)-    | Just cls <- maybe_cls-    = let cfs = Ghc.classAllSelIds cls in-        fmap ((,) <$> fst <*> uncurry strengthenClassSel)-          [(v, Loc l l' t)| (v,t) <- zip cfs (reverse $ fmap snd args)]-    | null fls                    --    no field labels-    || any (isFunTy . snd) args && not (higherOrderFlag env)   -- OR function-valued fields-    || dcpIsGadt dcp              -- OR GADT style datcon-    = []-    | otherwise-    = [ (v, t) | (Just v, t) <- zip fs ts ]-    where-      maybe_cls = Ghc.tyConClass_maybe (Ghc.dataConTyCon dc)-      dc  = dcpCon dcp-      fls = Ghc.dataConFieldLabels dc-      fs  = Bare.lookupGhcNamedVar env name . Ghc.flSelector <$> fls-      ts :: [ LocSpecType ]-      ts = [ Loc l l' (mkArrow (zip (makeRTVar <$> dcpFreeTyVars dcp) (repeat mempty)) []-                                 [] [(z, classRFInfo True, res, mempty)]-                                 (dropPreds (F.subst su t `RT.strengthen` mt)))-             | (x, t) <- reverse args -- NOTE: the reverse here is correct-             , let vv = rTypeValueVar t-               -- the measure singleton refinement, eg `v = getBar foo`-             , let mt = RT.uReft (vv, F.PAtom F.Eq (F.EVar vv) (F.EApp (F.EVar x) (F.EVar z)))-             ]--      su   = F.mkSubst [ (x, F.EApp (F.EVar x) (F.EVar z)) | x <- fst <$> args ]-      args = dcpTyArgs dcp-      z    = "lq$recSel"-      res  = dropPreds (dcpTyRes dcp)--      -- FIXME: this is clearly imprecise, but the preds in the DataConP seem-      -- to be malformed. If we leave them in, tests/pos/kmp.hs fails with-      -- a malformed predicate application. Niki, help!!-      dropPreds = fmap (\(MkUReft r _ps) -> MkUReft r mempty)
− src/Language/Haskell/Liquid/Bare/Elaborate.hs 
@@ -1,757 +0,0 @@-{-# LANGUAGE ViewPatterns              #-}-{-# LANGUAGE ExplicitForAll            #-}-{-# LANGUAGE TypeFamilies              #-}-{-# LANGUAGE DeriveFunctor             #-}-{-# LANGUAGE TypeApplications          #-}-{-# LANGUAGE LambdaCase                #-}-{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE CPP                       #-}--{-# OPTIONS_GHC -Wno-orphans #-}--{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- TODO(#1913): Fix import of Data.Functor.Foldable.Fix-{-# OPTIONS_GHC -Wno-unused-top-binds #-} -- TODO(#1914): Is RTypeF even used?---- | This module uses GHC API to elaborate the resolves expressions---- TODO: Genearlize to BareType and replace the existing resolution mechanisms--module Language.Haskell.Liquid.Bare.Elaborate-  ( fixExprToHsExpr-  , elaborateSpecType-  -- , buildSimplifier-  )-where--import qualified Language.Fixpoint.Types       as F--- import           Control.Arrow-import           Liquid.GHC.API hiding (panic, varName)-import qualified Liquid.GHC.Misc-                                               as GM-import           Language.Haskell.Liquid.Types.Types-import           Language.Haskell.Liquid.Types.RefType-                                                ( ofType )-import qualified Data.List                     as L-import qualified Data.HashMap.Strict           as M-import qualified Data.HashSet                  as S-import           Control.Monad.Free-#if MIN_VERSION_recursion_schemes(5,2,0)-import           Data.Fix                      hiding (hylo)-import           Data.Functor.Foldable         hiding (Fix)-#else-import           Data.Functor.Foldable-#endif--import           Data.Char                      ( isUpper )-import           GHC.Types.Name.Occurrence-import qualified Liquid.GHC.API as Ghc-                                                (noExtField)-import           Data.Default                   ( def )-import qualified Data.Maybe                    as Mb---- TODO: make elaboration monadic so typeclass names are unified to something--- that is generated in advance. This can greatly simplify the implementation--- of elaboration---- the substitution code is meant to inline dictionary functions--- but does not seem to work--- lookupIdSubstAll :: O.SDoc -> M.HashMap Id CoreExpr -> Id -> CoreExpr--- lookupIdSubstAll doc env v | Just e <- M.lookup v env = e---                            | otherwise                = Var v---         -- Vital! See Note [Extending the Subst]---   -- | otherwise = WARN( True, text "CoreSubst.lookupIdSubst" <+> doc <+> ppr v---   --                           $$ ppr in_scope)---- substExprAll :: O.SDoc -> M.HashMap Id CoreExpr -> CoreExpr -> CoreExpr--- substExprAll doc subst orig_expr = subst_expr_all doc subst orig_expr----- subst_expr_all :: O.SDoc -> M.HashMap Id CoreExpr -> CoreExpr -> CoreExpr--- subst_expr_all doc subst expr = go expr---  where---   go (Var v) = lookupIdSubstAll (doc O.$$ O.text "subst_expr_all") subst v---   go (Type     ty      ) = Type ty---   go (Coercion co      ) = Coercion co---   go (Lit      lit     ) = Lit lit---   go (App  fun     arg ) = App (go fun) (go arg)---   go (Tick tickish e   ) = Tick tickish (go e)---   go (Cast e       co  ) = Cast (go e) co---      -- Do not optimise even identity coercions---      -- Reason: substitution applies to the LHS of RULES, and---      --         if you "optimise" an identity coercion, you may---      --         lose a binder. We optimise the LHS of rules at---      --         construction time----   go (Lam  bndr    body) = Lam bndr (subst_expr_all doc subst body)----   go (Let  bind    body) = Let (mapBnd go bind) (subst_expr_all doc subst body)----   go (Case scrut bndr ty alts) =---     Case (go scrut) bndr ty (map (go_alt subst) alts)----   go_alt subst (con, bndrs, rhs) = (con, bndrs, subst_expr_all doc subst rhs)----- mapBnd :: (Expr b -> Expr b) -> Bind b -> Bind b--- mapBnd f (NonRec b e) = NonRec b (f e)--- mapBnd f (Rec bs    ) = Rec (map (second f) bs)---- -- substLet :: CoreExpr -> CoreExpr--- -- substLet (Lam b body) = Lam b (substLet body)--- -- substLet (Let b body)--- --   | NonRec x e <- b = substLet--- --     (substExprAll O.empty (extendIdSubst emptySubst x e) body)--- --   | otherwise = Let b (substLet body)--- -- substLet e = e----- buildDictSubst :: CoreProgram -> M.HashMap Id CoreExpr--- buildDictSubst = cata f---  where---   f Nil = M.empty---   f (Cons b s) | NonRec x e <- b, isDFunId x -- || isDictonaryId x---                                              = M.insert x e s---                | otherwise                   = s---- buildSimplifier :: CoreProgram -> CoreExpr -> TcRn CoreExpr--- buildSimplifier cbs e = pure e-- do- --  df <- getDynFlags- --  liftIO $ simplifyExpr (df `gopt_set` Opt_SuppressUnfoldings) e'- -- where- --  -- fvs = fmap (\x -> (x, getUnique x, isLocalId x))  (freeVars mempty e)- --  dictSubst = buildDictSubst cbs- --  e'        = substExprAll O.empty dictSubst e----- | Base functor of RType-data RTypeF c tv r f-  = RVarF {-      rtf_var    :: !tv-    , rtf_reft   :: !r-    }--  | RFunF  {-      rtf_bind   :: !F.Symbol-    , rtf_rinfo  :: !RFInfo-    , rtf_in     :: !f-    , rtf_out    :: !f-    , rtf_reft   :: !r-    }--  | RImpFF  {-      rtf_bind   :: !F.Symbol-    , rtd_rinfo  :: !RFInfo-    , rtf_in     :: !f-    , rtf_out    :: !f-    , rtf_reft   :: !r-    }--  | RAllTF {-      rtf_tvbind :: !(RTVU c tv) -- RTVar tv (RType c tv ()))-    , rtf_ty     :: !f-    , rtf_ref    :: !r-    }--  -- | "forall x y <z :: Nat, w :: Int> . TYPE"-  --               ^^^^^^^^^^^^^^^^^^^ (rtf_pvbind)-  | RAllPF {-      rtf_pvbind :: !(PVU c tv)  -- ar (RType c tv ()))-    , rtf_ty     :: !f-    }--  -- | For example, in [a]<{\h -> v > h}>, we apply (via `RApp`)-  --   * the `RProp`  denoted by `{\h -> v > h}` to-  --   * the `RTyCon` denoted by `[]`.-  | RAppF  {-      rtf_tycon  :: !c-    , rtf_args   :: ![f]-    , rtf_pargs  :: ![RTPropF c tv f]-    , rtf_reft   :: !r-    }--  | RAllEF {-      rtf_bind   :: !F.Symbol-    , rtf_allarg :: !f-    , rtf_ty     :: !f-    }--  | RExF {-      rtf_bind   :: !F.Symbol-    , rtf_exarg  :: !f-    , rtf_ty     :: !f-    }--  | RExprArgF (F.Located F.Expr)--  | RAppTyF{-      rtf_arg   :: !f-    , rtf_res   :: !f-    , rtf_reft  :: !r-    }--  | RRTyF  {-      rtf_env   :: ![(F.Symbol, f)]-    , rtf_ref   :: !r-    , rtf_obl   :: !Oblig-    , rtf_ty    :: !f-    }--  | RHoleF r-  deriving (Functor)---- It's probably ok to treat (RType c tv ()) as a leaf..-type RTPropF c tv f = Ref (RType c tv ()) f----- | SpecType with Holes.---   It provides us a context to construct the ghc queries.---   I don't think we can reuse RHole since it is not intended---   for this use case--type SpecTypeF = RTypeF RTyCon RTyVar RReft-type PartialSpecType = Free SpecTypeF ()--type instance Base (RType c tv r) = RTypeF c tv r--instance Recursive (RType c tv r) where-  project (RVar var reft           ) = RVarF var reft-  project (RFun  bind i tin tout reft) = RFunF bind i tin tout reft-  project (RImpF bind i tin tout reft) = RImpFF bind i tin tout reft-  project (RAllT tvbind ty ref     ) = RAllTF tvbind ty ref-  project (RAllP pvbind ty         ) = RAllPF pvbind ty-  project (RApp c args pargs reft  ) = RAppF c args pargs reft-  project (RAllE bind allarg ty    ) = RAllEF bind allarg ty-  project (REx   bind exarg  ty    ) = RExF bind exarg ty-  project (RExprArg e              ) = RExprArgF e-  project (RAppTy arg res reft     ) = RAppTyF arg res reft-  project (RRTy env ref obl ty     ) = RRTyF env ref obl ty-  project (RHole r                 ) = RHoleF r--instance Corecursive (RType c tv r) where-  embed (RVarF var reft           ) = RVar var reft-  embed (RFunF  bind i tin tout reft) = RFun bind  i tin tout reft-  embed (RImpFF bind i tin tout reft) = RImpF bind i tin tout reft-  embed (RAllTF tvbind ty ref     ) = RAllT tvbind ty ref-  embed (RAllPF pvbind ty         ) = RAllP pvbind ty-  embed (RAppF c args pargs reft  ) = RApp c args pargs reft-  embed (RAllEF bind allarg ty    ) = RAllE bind allarg ty-  embed (RExF   bind exarg  ty    ) = REx bind exarg ty-  embed (RExprArgF e              ) = RExprArg e-  embed (RAppTyF arg res reft     ) = RAppTy arg res reft-  embed (RRTyF env ref obl ty     ) = RRTy env ref obl ty-  embed (RHoleF r                 ) = RHole r----- specTypeToLHsType :: SpecType -> LHsType GhcPs--- specTypeToLHsType = typeToLHsType . toType---- -- Given types like x:a -> y:a -> _, this function returns x:a -> y:a -> Bool--- -- Free monad takes care of substitution---- A one-way function. Kind of like injecting something into Maybe-specTypeToPartial :: forall a . SpecType -> SpecTypeF (Free SpecTypeF a)-specTypeToPartial = hylo (fmap wrap) project---- probably should return spectype instead..-plugType :: SpecType -> PartialSpecType -> SpecType-plugType t = refix . f- where-  f = hylo Fix $ \case-    Pure _   -> specTypeToPartial t-    Free res -> res---- build the expression we send to ghc for elaboration--- YL: tweak this function to see if ghc accepts explicit dictionary binders--- returning both expressions and binders since ghc adds unique id to the expressions---- | returns (lambda binders, forall binders)-collectSpecTypeBinders :: SpecType -> ([F.Symbol], [F.Symbol])-collectSpecTypeBinders = para $ \case-  RFunF bind _ (tin, _) (_, (bs, abs')) _ | isClassType tin -> (bs, abs')-                                       | otherwise       -> (bind : bs, abs')-  RImpFF bind _ (tin, _) (_, (bs, abs')) _ | isClassType tin -> (bs, abs')-                                        | otherwise       -> (bind : bs, abs')-  RAllEF b _ (_, (bs, abs'))  -> (b : bs, abs')-  RAllTF (RTVar (RTV ab) _) (_, (bs, abs')) _ -> (bs, F.symbol ab : abs')-  RExF b _ (_, (bs, abs'))    -> (b : bs, abs')-  RAppTyF _ (_, (bs, abs')) _ -> (bs, abs')-  RRTyF _ _ _ (_, (bs, abs')) -> (bs, abs')-  _                          -> ([], [])---- really should be fused with collectBinders. However, we need the binders--- to correctly convert fixpoint expressions to ghc expressions because of--- namespace related issues (whether the symbol denotes a varName or a datacon)-buildHsExpr :: LHsExpr GhcPs -> SpecType -> LHsExpr GhcPs-buildHsExpr result = para $ \case-  RFunF bind _ (tin, _) (_, res) _-    | isClassType tin -> res-    | otherwise       -> mkHsLam [nlVarPat (varSymbolToRdrName bind)] res-  RImpFF bind _ (tin, _) (_, res) _-    | isClassType tin -> res-    | otherwise       -> mkHsLam [nlVarPat (varSymbolToRdrName bind)] res-  RAllEF  _ _        (_, res) -> res-  RAllTF  _ (_, res) _        -> res-  RExF    _ _        (_, res) -> res-  RAppTyF _ (_, res) _        -> res-  RRTyF _ _ _ (_, res)        -> res-  _                           -> result----canonicalizeDictBinder-  :: F.Subable a => [F.Symbol] -> (a, [F.Symbol]) -> (a, [F.Symbol])-canonicalizeDictBinder [] (e', bs') = (e', bs')-canonicalizeDictBinder bs (e', [] ) = (e', bs)-canonicalizeDictBinder bs (e', bs') = (renameDictBinder bs bs' e', bs)- where-  renameDictBinder :: (F.Subable a) => [F.Symbol] -> [F.Symbol] -> a -> a-  renameDictBinder []          _  = id-  renameDictBinder _           [] = id-  renameDictBinder canonicalDs ds = F.substa $ \x -> M.lookupDefault x x tbl-    where tbl = F.notracepp "TBL" $ M.fromList (zip ds canonicalDs)--elaborateSpecType-  :: (CoreExpr -> F.Expr)-  -> (CoreExpr -> TcRn CoreExpr)-  -> SpecType-  -> TcRn SpecType-elaborateSpecType coreToLogic simplifier t = GM.withWiredIn $ do-  (t', xs) <- elaborateSpecType' (pure ()) coreToLogic simplifier t-  case xs of-    _ : _ -> panic-      Nothing-      "elaborateSpecType: invariant broken. substitution list for dictionary is not completely consumed"-    _ -> pure t'--elaborateSpecType'-  :: PartialSpecType-  -> (CoreExpr -> F.Expr) -- core to logic-  -> (CoreExpr -> TcRn CoreExpr)-  -> SpecType-  -> TcRn (SpecType, [F.Symbol]) -- binders for dictionaries-                   -- should have returned Maybe [F.Symbol]-elaborateSpecType' partialTp coreToLogic simplify t =-  case F.notracepp "elaborateSpecType'" t of-    RVar (RTV tv) (MkUReft reft@(F.Reft (vv, _oldE)) p) -> do-      elaborateReft-        (reft, t)-        (pure (t, []))-        (\bs' ee -> pure (RVar (RTV tv) (MkUReft (F.Reft (vv, ee)) p), bs'))-        -- YL : Fix-    RFun bind i tin tout ureft@(MkUReft reft@(F.Reft (vv, _oldE)) p) -> do-      -- the reft is never actually used by the child-      -- maybe i should enforce this information at the type level-      let partialFunTp =-            Free (RFunF bind i (wrap $ specTypeToPartial tin) (pure ()) ureft) :: PartialSpecType-          partialTp' = partialTp >> partialFunTp :: PartialSpecType-      (eTin , bs ) <- elaborateSpecType' partialTp coreToLogic simplify tin-      (eTout, bs') <- elaborateSpecType' partialTp' coreToLogic simplify tout-      let buildRFunContTrivial-            | isClassType tin, dictBinder : bs0' <- bs' = do-              let (eToutRenamed, canonicalBinders) =-                    canonicalizeDictBinder bs (eTout, bs0')-              pure-                ( F.notracepp "RFunTrivial0"-                  $ RFun dictBinder i eTin eToutRenamed ureft-                , canonicalBinders-                )-            | otherwise = do-              let (eToutRenamed, canonicalBinders) =-                    canonicalizeDictBinder bs (eTout, bs')-              pure-                ( F.notracepp "RFunTrivial1" $ RFun bind i eTin eToutRenamed ureft-                , canonicalBinders-                )-          buildRFunCont bs'' ee-            | isClassType tin, dictBinder : bs0' <- bs' = do-              let (eToutRenamed, canonicalBinders) =-                    canonicalizeDictBinder bs (eTout, bs0')-                  (eeRenamed, canonicalBinders') =-                    canonicalizeDictBinder canonicalBinders (ee, bs'')-              pure-                ( RFun dictBinder i-                       eTin-                       eToutRenamed-                       (MkUReft (F.Reft (vv, eeRenamed)) p)-                , canonicalBinders'-                )-            | otherwise = do-              let (eToutRenamed, canonicalBinders) =-                    canonicalizeDictBinder bs (eTout, bs')-                  (eeRenamed, canonicalBinders') =-                    canonicalizeDictBinder canonicalBinders (ee, bs'')-              pure-                ( RFun bind i-                       eTin-                       eToutRenamed-                       (MkUReft (F.Reft (vv, eeRenamed)) p)-                , canonicalBinders'-                )-      elaborateReft (reft, t) buildRFunContTrivial buildRFunCont--        -- (\bs' ee | isClassType tin -> do-        --    let eeRenamed = renameDictBinder canonicalBinders bs' ee-        --    pure (RFun bind eTin eToutRenamed (MkUReft (F.Reft (vv, eeRenamed)) p), bs')-        -- )-    -- YL: implicit dictionary param doesn't seem possible..-    RImpF bind i tin tout ureft@(MkUReft reft@(F.Reft (vv, _oldE)) p) -> do-      let partialFunTp =-            Free (RImpFF bind i (wrap $ specTypeToPartial tin) (pure ()) ureft) :: PartialSpecType-          partialTp' = partialTp >> partialFunTp :: PartialSpecType-      (eTin , bs ) <- elaborateSpecType' partialTp' coreToLogic simplify tin-      (eTout, bs') <- elaborateSpecType' partialTp' coreToLogic simplify tout-      let (eToutRenamed, canonicalBinders) =-            canonicalizeDictBinder bs (eTout, bs')--      -- eTin and eTout might have different dictionary names-      -- need to do a substitution to make the reference to dictionaries consistent-      -- if isClassType eTin-      elaborateReft-        (reft, t)-        (pure (RImpF bind i eTin eToutRenamed ureft, canonicalBinders))-        (\bs'' ee -> do-          let (eeRenamed, canonicalBinders') =-                canonicalizeDictBinder canonicalBinders (ee, bs'')-          pure-            ( RImpF bind i eTin eTout (MkUReft (F.Reft (vv, eeRenamed)) p)-            , canonicalBinders'-            )-        )-    -- support for RankNTypes/ref-    RAllT (RTVar tv ty) tout ureft@(MkUReft ref@(F.Reft (vv, _oldE)) p) -> do-      (eTout, bs) <- elaborateSpecType'-        (partialTp >> Free (RAllTF (RTVar tv ty) (pure ()) ureft))-        coreToLogic-        simplify-        tout-      elaborateReft-        (ref, RVar tv mempty)-        (pure (RAllT (RTVar tv ty) eTout ureft, bs))-        (\bs' ee ->-          let (eeRenamed, canonicalBinders) =-                canonicalizeDictBinder bs (ee, bs')-          in  pure-                ( RAllT (RTVar tv ty) eTout (MkUReft (F.Reft (vv, eeRenamed)) p)-                , canonicalBinders-                )-        )-      -- pure (RAllT (RTVar tv ty) eTout ref, bts')-    -- todo: might as well print an error message?-    RAllP pvbind tout -> do-      (eTout, bts') <- elaborateSpecType'-        (partialTp >> Free (RAllPF pvbind (pure ())))-        coreToLogic-        simplify-        tout-      pure (RAllP pvbind eTout, bts')-    -- pargs not handled for now-    -- RApp tycon args pargs reft-    RApp tycon args pargs ureft@(MkUReft reft@(F.Reft (vv, _)) p)-      | isClass tycon -> pure (t, [])-      | otherwise -> do-        args' <- mapM-          (fmap fst . elaborateSpecType' partialTp coreToLogic simplify)-          args-        elaborateReft-          (reft, t)-          (pure (RApp tycon args' pargs ureft, []))-          (\bs' ee ->-            pure (RApp tycon args' pargs (MkUReft (F.Reft (vv, ee)) p), bs')-          )-    RAppTy arg res ureft@(MkUReft reft@(F.Reft (vv, _)) p) -> do-      (eArg, bs ) <- elaborateSpecType' partialTp coreToLogic simplify arg-      (eRes, bs') <- elaborateSpecType' partialTp coreToLogic simplify res-      let (eResRenamed, canonicalBinders) =-            canonicalizeDictBinder bs (eRes, bs')-      elaborateReft-        (reft, t)-        (pure (RAppTy eArg eResRenamed ureft, canonicalBinders))-        (\bs'' ee ->-          let (eeRenamed, canonicalBinders') =-                canonicalizeDictBinder canonicalBinders (ee, bs'')-          in  pure-                ( RAppTy eArg eResRenamed (MkUReft (F.Reft (vv, eeRenamed)) p)-                , canonicalBinders'-                )-        )-    -- todo: Existential support-    RAllE bind allarg ty -> do-      (eAllarg, bs ) <- elaborateSpecType' partialTp coreToLogic simplify allarg-      (eTy    , bs') <- elaborateSpecType' partialTp coreToLogic simplify ty-      let (eTyRenamed, canonicalBinders) = canonicalizeDictBinder bs (eTy, bs')-      pure (RAllE bind eAllarg eTyRenamed, canonicalBinders)-    REx bind allarg ty -> do-      (eAllarg, bs ) <- elaborateSpecType' partialTp coreToLogic simplify allarg-      (eTy    , bs') <- elaborateSpecType' partialTp coreToLogic simplify ty-      let (eTyRenamed, canonicalBinders) = canonicalizeDictBinder bs (eTy, bs')-      pure (REx bind eAllarg eTyRenamed, canonicalBinders)-    -- YL: might need to filter RExprArg out and replace RHole with ghc wildcard-    -- in the future-    RExprArg _ -> impossible Nothing "RExprArg should not appear here"-    RHole    _ -> impossible Nothing "RHole should not appear here"-    RRTy{}     -> todo Nothing ("Not sure how to elaborate RRTy" ++ F.showpp t)- where-  boolType = RApp (RTyCon boolTyCon [] def) [] [] mempty :: SpecType-  elaborateReft-    :: (F.PPrint a)-    => (F.Reft, SpecType)-    -> TcRn a-    -> ([F.Symbol] -> F.Expr -> TcRn a)-    -> TcRn a-  elaborateReft (reft@(F.Reft (vv, e)), vvTy) trivial nonTrivialCont =-    if isTrivial' reft-      then trivial-      else do-        let-          querySpecType =-            plugType (rFun' (classRFInfo True) vv vvTy boolType) partialTp :: SpecType--          (origBinders, origTyBinders) = F.notracepp "collectSpecTypeBinders"-            $ collectSpecTypeBinders querySpecType----          hsExpr =-            buildHsExpr (fixExprToHsExpr (S.fromList origBinders) e)-                        querySpecType :: LHsExpr GhcPs-          exprWithTySigs = noLoc $ ExprWithTySig-            Ghc.noExtField-            hsExpr-            (mkLHsSigWcType (specTypeToLHsType querySpecType))-        eeWithLamsCore <- GM.elabRnExpr TM_Inst exprWithTySigs-        eeWithLamsCore' <- simplify eeWithLamsCore-        let-          (_, tyBinders) =-            collectSpecTypeBinders-              . ofType-              . exprType-              $ eeWithLamsCore'-          substTy' = zip tyBinders origTyBinders-          eeWithLams =-            coreToLogic (GM.notracePpr "eeWithLamsCore" eeWithLamsCore')-          (bs', ee) = F.notracepp "grabLams" $ grabLams ([], eeWithLams)-          (dictbs, nondictbs) =-            L.partition (F.isPrefixOfSym "$d") bs'-      -- invariant: length nondictbs == length origBinders-          subst = if length nondictbs == length origBinders-            then F.notracepp "SUBST" $ zip (L.reverse nondictbs) origBinders-            else panic-              Nothing-              "Oops, Ghc gave back more/less binders than I expected"-        ret <- nonTrivialCont-          dictbs-          ( renameBinderCoerc (\x -> Mb.fromMaybe x (L.lookup x substTy'))-          . F.substa (\x -> Mb.fromMaybe x (L.lookup x subst))-          $ F.notracepp-              (  "elaborated: subst "-              ++ F.showpp substTy'-              ++ "  "-              ++ F.showpp-                   (ofType $ exprType eeWithLamsCore' :: SpecType)-              )-              ee-          )  -- (GM.dropModuleUnique <$> bs')-        pure (F.notracepp "result" ret)-                           -- (F.substa )-  isTrivial' :: F.Reft -> Bool-  isTrivial' (F.Reft (_, F.PTrue)) = True-  isTrivial' _                     = False--  grabLams :: ([F.Symbol], F.Expr) -> ([F.Symbol], F.Expr)-  grabLams (bs, F.ELam (b, _) e) = grabLams (b : bs, e)-  grabLams bse                   = bse-  -- dropBinderUnique :: [F.Symbol] -> F.Expr -> F.Expr-  -- dropBinderUnique binders = F.notracepp "ElaboratedExpr"-  --   . F.substa (\x -> if L.elem x binders then GM.dropModuleUnique x else x)--renameBinderCoerc :: (F.Symbol -> F.Symbol) -> F.Expr -> F.Expr-renameBinderCoerc f = rename- where-  renameSort = renameBinderSort f-  rename e'@(F.ESym _          ) = e'-  rename e'@(F.ECon _          ) = e'-  rename e'@(F.EVar _          ) = e'-  rename (   F.EApp e0 e1      ) = F.EApp (rename e0) (rename e1)-  rename (   F.ENeg e0         ) = F.ENeg (rename e0)-  rename (   F.EBin bop e0 e1  ) = F.EBin bop (rename e0) (rename e1)-  rename (   F.EIte e0  e1 e2  ) = F.EIte (rename e0) (rename e1) (rename e2)-  rename (   F.ECst e' t       ) = F.ECst (rename e') (renameSort t)-  -- rename (F.ELam (x, t) e') = F.ELam (x, renameSort t) (rename e')-  rename (   F.PAnd es         ) = F.PAnd (rename <$> es)-  rename (   F.POr  es         ) = F.POr (rename <$> es)-  rename (   F.PNot e'         ) = F.PNot (rename e')-  rename (   F.PImp e0 e1      ) = F.PImp (rename e0) (rename e1)-  rename (   F.PIff e0 e1      ) = F.PIff (rename e0) (rename e1)-  rename (   F.PAtom brel e0 e1) = F.PAtom brel (rename e0) (rename e1)-  rename (F.ECoerc _ _ e') = rename e'--  rename e = panic-    Nothing-    ("renameBinderCoerc: Not sure how to handle the expression " ++ F.showpp e)----renameBinderSort :: (F.Symbol -> F.Symbol) -> F.Sort -> F.Sort-renameBinderSort f = rename- where-  rename F.FInt             = F.FInt-  rename F.FReal            = F.FReal-  rename F.FNum             = F.FNum-  rename F.FFrac            = F.FFrac-  rename (   F.FObj s     ) = F.FObj (f s)-  rename t'@(F.FVar _     ) = t'-  rename (   F.FFunc t0 t1) = F.FFunc (rename t0) (rename t1)-  rename (   F.FAbs  x  t') = F.FAbs x (rename t')-  rename t'@(F.FTC _      ) = t'-  rename (   F.FApp t0 t1 ) = F.FApp (rename t0) (rename t1)---mkHsTyConApp ::  IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p)-mkHsTyConApp tyconId tyargs = nlHsTyConApp Prefix tyconId (map HsValArg tyargs)---- | Embed fixpoint expressions into parsed haskell expressions.---   It allows us to bypass the GHC parser and use arbitrary symbols---   for identifiers (compared to using the string API)-fixExprToHsExpr :: S.HashSet F.Symbol -> F.Expr -> LHsExpr GhcPs-fixExprToHsExpr _ (F.ECon c) = constantToHsExpr c-fixExprToHsExpr env (F.EVar x)-  | x == "GHC.Types.[]" =  GM.notracePpr "Empty" $ nlHsVar (mkVarUnqual (mkFastString "[]"))-  | x == "GHC.Types.:" = GM.notracePpr "Cons" $ nlHsVar (mkVarUnqual (mkFastString ":"))-  | otherwise = GM.notracePpr "Var" $ nlHsVar (symbolToRdrName env x)-fixExprToHsExpr env (F.EApp e0 e1) =-  mkHsApp (fixExprToHsExpr env e0) (fixExprToHsExpr env e1)-fixExprToHsExpr env (F.ENeg e) =-  mkHsApp (nlHsVar (nameRdrName negateName)) (fixExprToHsExpr env e)--fixExprToHsExpr env (F.EBin bop e0 e1) = mkHsApp-  (mkHsApp (bopToHsExpr bop) (fixExprToHsExpr env e0))-  (fixExprToHsExpr env e1)-fixExprToHsExpr env (F.EIte p e0 e1) = nlHsIf (fixExprToHsExpr env p)-                                              (fixExprToHsExpr env e0)-                                              (fixExprToHsExpr env e1)---- FIXME: convert sort to HsType--- This is currently not doable because how do we know if FInt corresponds to--- Int or Integer?-fixExprToHsExpr env (F.ECst e0 _    ) = fixExprToHsExpr env e0--- fixExprToHsExpr env (F.PAnd []      ) = nlHsVar true_RDR-fixExprToHsExpr _ (F.PAnd []      ) = nlHsVar true_RDR-fixExprToHsExpr env (F.PAnd (e : es)) = L.foldr f (fixExprToHsExpr env e) es- where-  f x acc = mkHsApp (mkHsApp (nlHsVar and_RDR) (fixExprToHsExpr env x)) acc---- This would work in the latest commit--- fixExprToHsExpr env (F.PAnd es  ) = mkHsApp---   (nlHsVar (varQual_RDR dATA_FOLDABLE (fsLit "and")))---   (nlList $ fixExprToHsExpr env <$> es)-fixExprToHsExpr env (F.POr es) = mkHsApp-  (nlHsVar (varQual_RDR dATA_FOLDABLE (fsLit "or")))-  (nlList $ fixExprToHsExpr env <$> es)-fixExprToHsExpr env (F.PIff e0 e1) = mkHsApp-  (mkHsApp (nlHsVar (mkVarUnqual (mkFastString "<=>"))) (fixExprToHsExpr env e0)-  )-  (fixExprToHsExpr env e1)-fixExprToHsExpr env (F.PNot e) =-  mkHsApp (nlHsVar not_RDR) (fixExprToHsExpr env e)-fixExprToHsExpr env (F.PAtom brel e0 e1) = mkHsApp-  (mkHsApp (brelToHsExpr brel) (fixExprToHsExpr env e0))-  (fixExprToHsExpr env e1)-fixExprToHsExpr env (F.PImp e0 e1) = mkHsApp-  (mkHsApp (nlHsVar (mkVarUnqual (mkFastString "==>"))) (fixExprToHsExpr env e0)-  )-  (fixExprToHsExpr env e1)--fixExprToHsExpr _ e =-  todo Nothing ("toGhcExpr: Don't know how to handle " ++ show e)--constantToHsExpr :: F.Constant -> LHsExpr GhcPs--- constantToHsExpr (F.I c) = noLoc (HsLit NoExt (HsInt NoExt (mkIntegralLit c)))-constantToHsExpr (F.I i) =-  noLoc (HsOverLit Ghc.noExtField (mkHsIntegral (mkIntegralLit i)))-constantToHsExpr (F.R d) =-  noLoc (HsOverLit Ghc.noExtField (mkHsFractional (mkFractionalLit d)))-constantToHsExpr _ =-  todo Nothing "constantToHsExpr: Not sure how to handle constructor L"---- This probably won't work because of the qualifiers-bopToHsExpr :: F.Bop -> LHsExpr GhcPs-bopToHsExpr bop = noLoc (HsVar Ghc.noExtField (noLoc (f bop)))- where-  f F.Plus   = plus_RDR-  f F.Minus  = minus_RDR-  f F.Times  = times_RDR-  f F.Div    = mkVarUnqual (fsLit "/")-  f F.Mod    = GM.prependGHCRealQual (fsLit "mod")-  f F.RTimes = times_RDR-  f F.RDiv   = GM.prependGHCRealQual (fsLit "/")--brelToHsExpr :: F.Brel -> LHsExpr GhcPs-brelToHsExpr brel = noLoc (HsVar Ghc.noExtField (noLoc (f brel)))- where-  f F.Eq = mkVarUnqual (mkFastString "==")-  f F.Gt = gt_RDR-  f F.Lt = lt_RDR-  f F.Ge = ge_RDR-  f F.Le = le_RDR-  f F.Ne = mkVarUnqual (mkFastString "/=")-  f _    = impossible Nothing "brelToExpr: Unsupported operation"--symbolToRdrNameNs :: NameSpace -> F.Symbol -> RdrName-symbolToRdrNameNs ns x-  | F.isNonSymbol modName = mkUnqual ns (mkFastString (F.symbolString s))-  | otherwise = mkQual-    ns-    (mkFastString (F.symbolString modName), mkFastString (F.symbolString s))-  where (modName, s) = GM.splitModuleName x---varSymbolToRdrName :: F.Symbol -> RdrName-varSymbolToRdrName = symbolToRdrNameNs varName----- don't use this function...-symbolToRdrName :: S.HashSet F.Symbol -> F.Symbol -> RdrName-symbolToRdrName env x-  | F.isNonSymbol modName = mkUnqual ns (mkFastString (F.symbolString s))-  | otherwise = mkQual-    ns-    (mkFastString (F.symbolString modName), mkFastString (F.symbolString s))- where-  (modName, s) = GM.splitModuleName x-  ns | not (S.member x env), Just (c, _) <- F.unconsSym s, isUpper c = dataName-     | otherwise = varName---specTypeToLHsType :: SpecType -> LHsType GhcPs--- surprised that the type application is necessary-specTypeToLHsType =-  flip (ghylo (distPara @SpecType) distAna) (fmap pure . project) $ \case-    RVarF (RTV tv) _ -> nlHsTyVar-      -- (GM.notracePpr ("varRdr" ++ F.showpp (F.symbol tv)) $ getRdrName tv)-      (symbolToRdrNameNs tvName (F.symbol tv))-    RFunF _ _ (tin, tin') (_, tout) _-      | isClassType tin -> noLoc $ HsQualTy Ghc.noExtField (noLoc [tin']) tout-      | otherwise       -> nlHsFunTy tin' tout-    RImpFF _ _ (_, tin) (_, tout) _              -> nlHsFunTy tin tout-    RAllTF (ty_var_value -> (RTV tv)) (_, t) _ -> noLoc $ HsForAllTy-      Ghc.noExtField-      (mkHsForAllInvisTele [noLoc $ UserTyVar Ghc.noExtField SpecifiedSpec (noLoc $ symbolToRdrNameNs tvName (F.symbol tv))])-      t-    RAllPF _ (_, ty)                    -> ty-    RAppF RTyCon { rtc_tc = tc } ts _ _ -> mkHsTyConApp-      (getRdrName tc)-      [ hst | (t, hst) <- ts, notExprArg t ]-     where-      notExprArg (RExprArg _) = False-      notExprArg _            = True-    RAllEF _ (_, tin) (_, tout) -> nlHsFunTy tin tout-    RExF   _ (_, tin) (_, tout) -> nlHsFunTy tin tout-    -- impossible-    RAppTyF _ (RExprArg _, _) _ ->-      impossible Nothing "RExprArg should not appear here"-    RAppTyF (_, t) (_, t') _ -> nlHsAppTy t t'-    -- YL: todo..-    RRTyF _ _ _ (_, t)       -> t-    RHoleF _                 -> noLoc $ HsWildCardTy Ghc.noExtField-    RExprArgF _ ->-      todo Nothing "Oops, specTypeToLHsType doesn't know how to handle RExprArg"
− src/Language/Haskell/Liquid/Bare/Expand.hs 
@@ -1,843 +0,0 @@--- | This module has the code for applying refinement (and) type aliases ---   and the pipeline for "cooking" a @BareType@ into a @SpecType@. ---   TODO: _only_ export `makeRTEnv`, `cookSpecType` and maybe `qualifyExpand`...--{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE OverloadedStrings     #-}--module Language.Haskell.Liquid.Bare.Expand-  ( -- * Create alias expansion environment-    makeRTEnv--    -- * Expand and Qualify -  , qualifyExpand--    -- * Converting BareType to SpecType-  , cookSpecType-  , cookSpecTypeE-  , specExpandType--    -- * Re-exported for data-constructors-  , plugHoles-  ) where--import Prelude hiding (error)-import Data.Graph hiding (Graph)-import Data.Maybe--import           Control.Monad.State-import           Data.Functor ((<&>))-import qualified Control.Exception         as Ex-import qualified Data.HashMap.Strict       as M-import qualified Data.Char                 as Char-import qualified Data.List                 as L-import qualified Text.Printf               as Printf-import qualified Text.PrettyPrint.HughesPJ as PJ--import qualified Language.Fixpoint.Types               as F--- import qualified Language.Fixpoint.Types.Visitor       as F -import qualified Language.Fixpoint.Misc                as Misc-import           Language.Fixpoint.Types (Expr(..)) -- , Symbol, symbol) -import qualified Liquid.GHC.Misc      as GM-import qualified Liquid.GHC.API       as Ghc-import qualified Language.Haskell.Liquid.Types.RefType as RT-import           Language.Haskell.Liquid.Types         hiding (fresh)-import qualified Language.Haskell.Liquid.Misc          as Misc-import qualified Language.Haskell.Liquid.Measure       as Ms-import qualified Language.Haskell.Liquid.Bare.Resolve  as Bare-import qualified Language.Haskell.Liquid.Bare.Types    as Bare-import qualified Language.Haskell.Liquid.Bare.Plugged  as Bare------------------------------------------------------------------------------------- | `makeRTEnv` initializes the env needed to `expand` refinements and types,---   that is, the below needs to be called *before* we use `Expand.expand`----------------------------------------------------------------------------------makeRTEnv :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.ModSpecs -> LogicMap-          -> BareRTEnv----------------------------------------------------------------------------------makeRTEnv env modName mySpec iSpecs lmap-          = renameRTArgs $ makeRTAliases tAs $ makeREAliases eAs-  where-    tAs   = [ t                   | (_, s)  <- specs, t <- Ms.aliases  s ]-    eAs   = [ specREAlias env m e | (m, s)  <- specs, e <- Ms.ealiases s ]-         ++ if typeclass (getConfig env) then []-                                              -- lmap expansion happens during elaboration-                                              -- this clearly breaks things if a signature-                                              -- contains lmap functions but never gets-                                              -- elaborated-              else [ specREAlias env modName e | (_, xl) <- M.toList (lmSymDefs lmap)-                                  , let e    = lmapEAlias xl             ]-    specs = (modName, mySpec) : M.toList iSpecs---- | We apply @renameRTArgs@ *after* expanding each alias-definition, to ---   ensure that the substitutions work properly (i.e. don't miss expressions ---   hidden inside @RExprArg@ or as strange type parameters. -renameRTArgs :: BareRTEnv -> BareRTEnv-renameRTArgs rte = RTE-  { typeAliases = M.map (fmap (renameTys . renameVV . renameRTVArgs)) (typeAliases rte)-  , exprAliases = M.map (fmap                         renameRTVArgs) (exprAliases rte)-  }--makeREAliases :: [Located (RTAlias F.Symbol F.Expr)] -> BareRTEnv-makeREAliases = graphExpand buildExprEdges f mempty-  where-    f rtEnv xt = setREAlias rtEnv (expandLoc rtEnv xt)----- | @renameTys@ ensures that @RTAlias@ type parameters have distinct names ---   to avoid variable capture e.g. as in T1556.hs-renameTys :: RTAlias F.Symbol BareType -> RTAlias F.Symbol BareType-renameTys rt = rt { rtTArgs = ys, rtBody = sbts (rtBody rt) (zip xs ys) }-  where-    xs    = rtTArgs rt-    ys    = (`F.suffixSymbol` rtName rt) <$> xs-    sbts  = foldl (flip subt)---renameVV :: RTAlias F.Symbol BareType -> RTAlias F.Symbol BareType-renameVV rt = rt { rtBody = RT.shiftVV (rtBody rt) (F.vv (Just 0)) }---- | @renameRTVArgs@ ensures that @RTAlias@ value parameters have distinct names ---   to avoid variable capture e.g. as in tests-names-pos-Capture01.hs-renameRTVArgs :: (F.PPrint a, F.Subable a) => RTAlias x a -> RTAlias x a-renameRTVArgs rt = rt { rtVArgs = newArgs-                      , rtBody  = F.notracepp msg $ F.subst su (rtBody rt)-                      }-  where-    msg          = "renameRTVArgs: " ++ F.showpp su-    su           = F.mkSubst (zip oldArgs (F.eVar <$> newArgs))-    newArgs      = zipWith rtArg (rtVArgs rt) [(0::Int)..]-    oldArgs      = rtVArgs rt-    rtArg x i    = F.suffixSymbol x (F.intSymbol "rta" i)--makeRTAliases :: [Located (RTAlias F.Symbol BareType)] -> BareRTEnv -> BareRTEnv-makeRTAliases lxts rte = graphExpand buildTypeEdges f rte lxts-  where-    f rtEnv xt         = setRTAlias rtEnv (expandLoc rtEnv xt)--specREAlias :: Bare.Env -> ModName -> Located (RTAlias F.Symbol F.Expr) -> Located (RTAlias F.Symbol F.Expr)-specREAlias env m la = F.atLoc la $ a { rtBody = Bare.qualify env m (loc la) (rtVArgs a) (rtBody a) }-  where-    a     = val la------------------------------------------------------------------------------------------------------------------graphExpand :: (PPrint t)-            => (AliasTable x t -> t -> [F.Symbol])         -- ^ dependencies-            -> (thing -> Located (RTAlias x t) -> thing) -- ^ update-            -> thing                                     -- ^ initial-            -> [Located (RTAlias x t)]                   -- ^ vertices-            -> thing                                     -- ^ final -graphExpand buildEdges expBody env lxts-           = L.foldl' expBody env (genExpandOrder table' graph)-  where-    -- xts    = val <$> lxts-    table  = buildAliasTable lxts-    graph  = buildAliasGraph (buildEdges table) lxts-    table' = checkCyclicAliases table graph--setRTAlias :: RTEnv x t -> Located (RTAlias x t) -> RTEnv x t-setRTAlias env a = env { typeAliases =  M.insert n a (typeAliases env) }-  where-    n            = rtName (val a)--setREAlias :: RTEnv x t -> Located (RTAlias F.Symbol F.Expr) -> RTEnv x t-setREAlias env a = env { exprAliases = M.insert n a (exprAliases env) }-  where-    n            = rtName (val a)-------------------------------------------------------------------------------------type AliasTable x t = M.HashMap F.Symbol (Located (RTAlias x t))--buildAliasTable :: [Located (RTAlias x t)] -> AliasTable x t-buildAliasTable = M.fromList . map (\rta -> (rtName (val rta), rta))--fromAliasSymbol :: AliasTable x t -> F.Symbol -> Located (RTAlias x t)-fromAliasSymbol table sym-  = fromMaybe err (M.lookup sym table)-  where-    err = panic Nothing ("fromAliasSymbol: Dangling alias symbol: " ++ show sym)--type Graph t = [Node t]-type Node  t = (t, t, [t])--buildAliasGraph :: (PPrint t) => (t -> [F.Symbol]) -> [Located (RTAlias x t)]-                -> Graph F.Symbol-buildAliasGraph buildEdges = map (buildAliasNode buildEdges)--buildAliasNode :: (PPrint t) => (t -> [F.Symbol]) -> Located (RTAlias x t)-               -> Node F.Symbol-buildAliasNode f la = (rtName a, rtName a, f (rtBody a))-  where-    a               = val la--checkCyclicAliases :: AliasTable x t -> Graph F.Symbol -> AliasTable x t-checkCyclicAliases table graph-  = case mapMaybe go (stronglyConnComp graph) of-      []   -> table-      sccs -> Ex.throw (cycleAliasErr table <$> sccs)-    where-      go (CyclicSCC vs) = Just vs-      go (AcyclicSCC _) = Nothing--cycleAliasErr :: AliasTable x t -> [F.Symbol] -> Error-cycleAliasErr _ []          = panic Nothing "checkCyclicAliases: No type aliases in reported cycle"-cycleAliasErr t symList@(rta:_) = ErrAliasCycle { pos    = fst (locate rta)-                                                , acycle = map locate symList }-  where-    locate sym = ( GM.fSrcSpan $ fromAliasSymbol t sym-                 , pprint sym )---genExpandOrder :: AliasTable x t -> Graph F.Symbol -> [Located (RTAlias x t)]-genExpandOrder table graph-  = map (fromAliasSymbol table) symOrder-  where-    (digraph, lookupVertex, _)-      = graphFromEdges graph-    symOrder-      = map (Misc.fst3 . lookupVertex) $ reverse $ topSort digraph------------------------------------------------------------------------------------ordNub :: Ord a => [a] -> [a]-ordNub = map head . L.group . L.sort--buildTypeEdges :: (F.Symbolic c) => AliasTable x t -> RType c tv r -> [F.Symbol]-buildTypeEdges table = ordNub . go-  where-    -- go :: t -> [Symbol]-    go (RApp c ts rs _) = go_alias (F.symbol c) ++ concatMap go ts ++ concatMap go (mapMaybe go_ref rs)-    go (RImpF _ _ t1 t2 _) = go t1 ++ go t2-    go (RFun _ _ t1 t2 _) = go t1 ++ go t2-    go (RAppTy t1 t2 _) = go t1 ++ go t2-    go (RAllE _ t1 t2)  = go t1 ++ go t2-    go (REx _ t1 t2)    = go t1 ++ go t2-    go (RAllT _ t _)    = go t-    go (RAllP _ t)      = go t-    go (RVar _ _)       = []-    go (RExprArg _)     = []-    go (RHole _)        = []-    go (RRTy env _ _ t) = concatMap (go . snd) env ++ go t-    go_alias c          = [c | M.member c table]-    go_ref (RProp _ (RHole _)) = Nothing-    go_ref (RProp  _ t) = Just t--buildExprEdges :: M.HashMap F.Symbol a -> F.Expr -> [F.Symbol]-buildExprEdges table  = ordNub . go-  where-    go :: F.Expr -> [F.Symbol]-    go (EApp e1 e2)   = go e1 ++ go e2-    go (ENeg e)       = go e-    go (EBin _ e1 e2) = go e1 ++ go e2-    go (EIte _ e1 e2) = go e1 ++ go e2-    go (ECst e _)     = go e-    go (ESym _)       = []-    go (ECon _)       = []-    go (EVar v)       = go_alias v-    go (PAnd ps)       = concatMap go ps-    go (POr ps)        = concatMap go ps-    go (PNot p)        = go p-    go (PImp p q)      = go p ++ go q-    go (PIff p q)      = go p ++ go q-    go (PAll _ p)      = go p-    go (ELam _ e)      = go e-    go (ECoerc _ _ e)  = go e-    go (PAtom _ e1 e2) = go e1 ++ go e2-    go (ETApp e _)     = go e-    go (ETAbs e _)     = go e-    go (PKVar _ _)     = []-    go (PExist _ e)    = go e-    go (PGrad _ _ _ e) = go e-    go_alias f         = [f | M.member f table ]---------------------------------------------------------------------------------------- | Using the `BareRTEnv` to do alias-expansion ------------------------------------------------------------------------------------class Expand a where-  expand :: BareRTEnv -> F.SourcePos -> a -> a--------------------------------------------------------------------------------------- | @qualifyExpand@ first qualifies names so that we can successfully resolve them during expansion.------ When expanding, it's important we pass around a 'BareRTEnv' where the type aliases have been qualified as well.--- This is subtle, see for example T1761. In that test, we had a type alias \"OneTyAlias a = {v:a | oneFunPred v}\" where--- \"oneFunPred\" was marked inline. However, inlining couldn't happen because the 'BareRTEnv' had an--- entry for \"T1761.oneFunPred\", so the relevant expansion of \"oneFunPred\" couldn't happen. This was--- because the type alias entry inside 'BareRTEnv' mentioned the tuple (\"OneTyAlias\", \"{v:a | oneFunPred v}\") but--- the 'snd' element needed to be qualified as well, before trying to expand anything.------------------------------------------------------------------------------------qualifyExpand :: (PPrint a, Expand a, Bare.Qualify a)-              => Bare.Env -> ModName -> BareRTEnv -> F.SourcePos -> [F.Symbol] -> a -> a------------------------------------------------------------------------------------qualifyExpand env name rtEnv l bs-  = expand qualifiedRTEnv l . Bare.qualify env name l bs-  where-    qualifiedRTEnv :: BareRTEnv-    qualifiedRTEnv = rtEnv { typeAliases = M.map (Bare.qualify env name l bs) (typeAliases rtEnv) }-------------------------------------------------------------------------------------expandLoc :: (Expand a) => BareRTEnv -> Located a -> Located a-expandLoc rtEnv lx = expand rtEnv (F.loc lx) <$> lx--instance Expand Expr where-  expand = expandExpr--instance Expand F.Reft where-  expand rtEnv l (F.Reft (v, ra)) = F.Reft (v, expand rtEnv l ra)--instance Expand RReft where-  expand rtEnv l = fmap (expand rtEnv l)--expandReft :: (Expand r) => BareRTEnv -> F.SourcePos -> RType c tv r -> RType c tv r-expandReft rtEnv l = fmap (expand rtEnv l)--- expandReft rtEnv l = emapReft (expand rtEnv l)----- | @expand@ on a SpecType simply expands the refinements, ---   i.e. *does not* apply the type aliases, but just the ---   1. predicate aliases, ---   2. inlines,---   3. stuff from @LogicMap@--instance Expand SpecType where-  expand = expandReft---- | @expand@ on a BareType actually applies the type- and expression- aliases.-instance Expand BareType where-  expand rtEnv l-    = expandReft     rtEnv l -- apply expression aliases-    . expandBareType rtEnv l -- apply type       aliases--instance Expand (RTAlias F.Symbol Expr) where-  expand rtEnv l x = x { rtBody = expand rtEnv l (rtBody x) }--instance Expand BareRTAlias where-  expand rtEnv l x = x { rtBody = expand rtEnv l (rtBody x) }--instance Expand Body where-  expand rtEnv l (P   p) = P   (expand rtEnv l p)-  expand rtEnv l (E   e) = E   (expand rtEnv l e)-  expand rtEnv l (R x p) = R x (expand rtEnv l p)--instance Expand DataCtor where-  expand rtEnv l c = c-    { dcTheta  = expand rtEnv l (dcTheta c)-    , dcFields = [(x, expand rtEnv l t) | (x, t) <- dcFields c ]-    , dcResult = expand rtEnv l (dcResult c)-    }--instance Expand DataDecl where-  expand rtEnv l d = d-    { tycDCons  = expand rtEnv l (tycDCons  d)-    , tycPropTy = expand rtEnv l (tycPropTy d)-    }--instance Expand BareMeasure where-  expand rtEnv l m = m-    { msSort = expand rtEnv l (msSort m)-    , msEqns = expand rtEnv l (msEqns m)-    }--instance Expand BareDef where-  expand rtEnv l d = d-    { dsort = expand rtEnv l (dsort d)-    , binds = [ (x, expand rtEnv l t) | (x, t) <- binds d]-    , body  = expand rtEnv l (body  d)-    }--instance Expand Ms.BareSpec where-  expand = expandBareSpec--instance Expand a => Expand (F.Located a) where-  expand rtEnv _ = expandLoc rtEnv--instance Expand a => Expand (F.LocSymbol, a) where-  expand rtEnv l (x, y) = (x, expand rtEnv l y)--instance Expand a => Expand (Maybe a) where-  expand rtEnv l = fmap (expand rtEnv l)--instance Expand a => Expand [a] where-  expand rtEnv l = fmap (expand rtEnv l)--instance Expand a => Expand (M.HashMap k a) where-  expand rtEnv l = fmap (expand rtEnv l)---- | Expands a 'BareSpec'.-expandBareSpec :: BareRTEnv -> F.SourcePos -> Ms.BareSpec -> Ms.BareSpec-expandBareSpec rtEnv l sp = sp-  { measures   = expand rtEnv l (measures   sp)-  , asmSigs    = expand rtEnv l (asmSigs    sp)-  , sigs       = expand rtEnv l (sigs       sp)-  , localSigs  = expand rtEnv l (localSigs  sp)-  , reflSigs   = expand rtEnv l (reflSigs   sp)-  , ialiases   = [ (f x, f y) | (x, y) <- ialiases sp ]-  , dataDecls  = expand rtEnv l (dataDecls  sp)-  , newtyDecls = expand rtEnv l (newtyDecls sp)-  }-  where f      = expand rtEnv l--expandBareType :: BareRTEnv -> F.SourcePos -> BareType -> BareType-expandBareType rtEnv _ = go-  where-    go (RApp c ts rs r)  = case lookupRTEnv c rtEnv of-                             Just rta -> expandRTAliasApp (GM.fSourcePos c) rta (go <$> ts) r-                             Nothing  -> RApp c (go <$> ts) (goRef <$> rs) r-    go (RAppTy t1 t2 r)  = RAppTy (go t1) (go t2) r-    go (RImpF x i t1 t2 r) = RImpF x i (go t1) (go t2) r-    go (RFun  x i t1 t2 r) = RFun  x i (go t1) (go t2) r-    go (RAllT a t r)     = RAllT a (go t) r-    go (RAllP a t)       = RAllP a (go t)-    go (RAllE x t1 t2)   = RAllE x (go t1) (go t2)-    go (REx x t1 t2)     = REx   x (go t1) (go t2)-    go (RRTy e r o t)    = RRTy  e r o     (go t)-    go t@RHole{}         = t-    go t@RVar{}          = t-    go t@RExprArg{}      = t-    goRef (RProp ss t)   = RProp ss (go t)--lookupRTEnv :: BTyCon -> BareRTEnv -> Maybe (Located BareRTAlias)-lookupRTEnv c rtEnv = M.lookup (F.symbol c) (typeAliases rtEnv)--expandRTAliasApp :: F.SourcePos -> Located BareRTAlias -> [BareType] -> RReft -> BareType-expandRTAliasApp l (Loc la _ rta) args r = case isOK of-  Just e     -> Ex.throw e-  Nothing    -> F.subst esu . (`RT.strengthen` r) . RT.subsTyVarsMeet tsu $ rtBody rta-  where-    tsu       = zipWith (\α t -> (α, toRSort t, t)) αs ts-    esu       = F.mkSubst $ zip (F.symbol <$> εs) es-    es        = exprArg l msg <$> es0-    (ts, es0) = splitAt nαs args-    (αs, εs)  = (BTV <$> rtTArgs rta, rtVArgs rta)-    targs     = takeWhile (not . isRExprArg) args-    eargs     = dropWhile (not . isRExprArg) args--    -- ERROR Checking Code-    msg       = "EXPAND-RTALIAS-APP: " ++ F.showpp (rtName rta)-    nαs       = length αs-    nεs       = length εs-    nargs     = length args-    ntargs    = length targs-    neargs    = length eargs-    err       = errRTAliasApp l la rta-    isOK :: Maybe Error-    isOK-      | nargs /= ntargs + neargs-      = err $ PJ.hsep ["Expects", pprint nαs, "type arguments and then", pprint nεs, "expression arguments, but is given", pprint nargs]-      | nargs /= nαs + nεs-      = err $ PJ.hsep ["Expects", pprint nαs, "type arguments and"     , pprint nεs, "expression arguments, but is given", pprint nargs]-      | nαs /= ntargs, not (null eargs)-      = err $ PJ.hsep ["Expects", pprint nαs, "type arguments before expression arguments"]-      | otherwise-      = Nothing--isRExprArg :: RType c tv r -> Bool-isRExprArg (RExprArg _) = True-isRExprArg _            = False--errRTAliasApp :: F.SourcePos -> F.SourcePos -> BareRTAlias -> PJ.Doc -> Maybe Error-errRTAliasApp l la rta = Just . ErrAliasApp  sp name sp'-  where-    name            = pprint              (rtName rta)-    sp              = GM.sourcePosSrcSpan l-    sp'             = GM.sourcePosSrcSpan la--------------------------------------------------------------------------------------- | exprArg converts a tyVar to an exprVar because parser cannot tell---   this function allows us to treating (parsed) "types" as "value"---   arguments, e.g. type Matrix a Row Col = List (List a Row) Col---   Note that during parsing, we don't necessarily know whether a---   string is a type or a value expression. E.g. in tests/pos/T1189.hs,---   the string `Prop (Ev (plus n n))` where `Prop` is the alias:---     {-@ type Prop E = {v:_ | prop v = E} @-}---   the parser will chomp in `Ev (plus n n)` as a `BareType` and so---   `exprArg` converts that `BareType` into an `Expr`.----------------------------------------------------------------------------------exprArg :: F.SourcePos -> String -> BareType -> Expr-exprArg l msg = F.notracepp ("exprArg: " ++ msg) . go-  where-    go :: BareType -> Expr-    go (RExprArg e)     = val e-    go (RVar x _)       = EVar (F.symbol x)-    go (RApp x [] [] _) = EVar (F.symbol x)-    go (RApp f ts [] _) = F.mkEApp (F.symbol <$> btc_tc f) (go <$> ts)-    go (RAppTy t1 t2 _) = F.EApp (go t1) (go t2)-    go z                = panic sp $ Printf.printf "Unexpected expression parameter: %s in %s" (show z) msg-    sp                  = Just (GM.sourcePosSrcSpan l)---------------------------------------------------------------------------------------------- | @cookSpecType@ is the central place where a @BareType@ gets processed, ---   in multiple steps, into a @SpecType@. See [NOTE:Cooking-SpecType] for ---   details of each of the individual steps.------------------------------------------------------------------------------------------cookSpecType :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.PlugTV Ghc.Var -> LocBareType-             -> LocSpecType-cookSpecType env sigEnv name x bt-         = either Ex.throw id (cookSpecTypeE env sigEnv name x bt)-  where-    _msg = "cookSpecType: " ++ GM.showPpr (z, Ghc.varType <$> z)-    z    = Bare.plugSrc x---------------------------------------------------------------------------------------------cookSpecTypeE :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.PlugTV Ghc.Var -> LocBareType-              -> Bare.Lookup LocSpecType-------------------------------------------------------------------------------------------cookSpecTypeE env sigEnv name@(ModName _ _) x bt-  = fmap f . bareSpecType env name $ bareExpandType rtEnv bt-  where-    f = (if doplug || not allowTC then plugHoles allowTC sigEnv name x else id)-        . fmap (addTyConInfo embs tyi)-        . Bare.txRefSort tyi embs-        . fmap txExpToBind -- What does this function DO-        . (specExpandType rtEnv . fmap (generalizeWith x))-        . (if doplug || not allowTC then maybePlug allowTC sigEnv name x else id)-        -- we do not qualify/resolve Expr/Pred when typeclass is enabled-        -- since ghci will not be able to recognize fully qualified names-        -- instead, we leave qualification to ghc elaboration-        . Bare.qualifyTop env name l--    allowTC = typeclass (getConfig env)-    -- modT   = mname `S.member` wiredInMods-    doplug-      | Bare.LqTV v <- x-      , GM.isMethod v || GM.isSCSel v-      , not (isTarget name)-      = False-      | otherwise-      = True-    _msg i = "cook-" ++ show i ++ " : " ++ F.showpp x-    rtEnv  = Bare.sigRTEnv    sigEnv-    embs   = Bare.sigEmbs     sigEnv-    tyi    = Bare.sigTyRTyMap sigEnv-    l      = F.loc bt---- | We don't want to generalize type variables that maybe bound in the ---   outer scope, e.g. see tests/basic/pos/LocalPlug00.hs --generalizeWith :: Bare.PlugTV Ghc.Var -> SpecType -> SpecType-generalizeWith (Bare.HsTV v) t = generalizeVar v t-generalizeWith  Bare.RawTV   t = t-generalizeWith _             t = RT.generalize t--generalizeVar :: Ghc.Var -> SpecType -> SpecType-generalizeVar v t = mkUnivs (zip as (repeat mempty)) [] t-  where-    as            = filter isGen (freeTyVars t)-    (vas,_)       = Ghc.splitForAllTys (GM.expandVarType v)-    isGen (RTVar (RTV a) _) = a `elem` vas---- splitForAllTys :: Type -> ([TyVar], Type)--- --- generalize :: (Eq tv) => RType c tv r -> RType c tv r--- generalize t = mkUnivs (freeTyVars t) [] [] t ---bareExpandType :: BareRTEnv -> LocBareType -> LocBareType-bareExpandType = expandLoc--specExpandType :: BareRTEnv -> LocSpecType -> LocSpecType-specExpandType = expandLoc--bareSpecType :: Bare.Env -> ModName -> LocBareType -> Bare.Lookup LocSpecType-bareSpecType env name bt = case Bare.ofBareTypeE env name (F.loc bt) Nothing (val bt) of-  Left e  -> Left e-  Right t -> Right (F.atLoc bt t)--maybePlug :: Bool -> Bare.SigEnv -> ModName -> Bare.PlugTV Ghc.Var -> LocSpecType -> LocSpecType-maybePlug allowTC sigEnv name kx = case Bare.plugSrc kx of-                             Nothing -> id-                             Just _  -> plugHoles allowTC sigEnv name kx--plugHoles :: Bool -> Bare.SigEnv -> ModName -> Bare.PlugTV Ghc.Var -> LocSpecType -> LocSpecType-plugHoles allowTC sigEnv name = Bare.makePluggedSig allowTC name embs tyi exports-  where-    embs              = Bare.sigEmbs     sigEnv-    tyi               = Bare.sigTyRTyMap sigEnv-    exports           = Bare.sigExports  sigEnv--{- [NOTE:Cooking-SpecType] -    A @SpecType@ is _raw_ when it is obtained directly from a @BareType@, i.e. -    just by replacing all the @BTyCon@ with @RTyCon@. Before it can be used -    for constraint generation, we need to _cook_ it via the following transforms:--    A @SigEnv@ should contain _all_ the information needed to do the below steps.--    - expand               : resolving all type/refinement etc. aliases -    - ofType               : convert BareType -> SpecType-    - plugged              : filling in any remaining "holes"-    - txRefSort            : filling in the abstract-refinement predicates etc. (YUCK) -    - resolve              : renaming / qualifying symbols?-    - expand (again)       : as the "resolve" step can rename variables to trigger more aliases (e.g. member -> Data.Set.Internal.Member -> Set_mem)-    - generalize           : (universally) quantify free type variables -    - strengthen-measures  : ?-    - strengthen-inline(?) : ? ---}---------------------------------------------------------------------------------------------------- | From BareOLD.Expand ---------------------------------------------------------------------------------------------------{- TODO-REBARE -instance Expand ty => Expand (Def ty ctor) where-  expand z (Def f xts c t bxts b) =-    Def f <$> expand z xts-          <*> pure c-          <*> expand z t-          <*> expand z bxts-          <*> expand z b--instance Expand ty => Expand (Measure ty ctor) where-  expand z (M n t ds k) =-    M n <$> expand z t <*> expand z ds <*> pure k--instance Expand DataConP where-  expand z d = do-    tyRes'    <- expand z (tyRes     d)-    tyConsts' <- expand z (tyConstrs d)-    tyArgs'   <- expand z (tyArgs    d)-    return d { tyRes =  tyRes', tyConstrs = tyConsts', tyArgs = tyArgs' }--}------------------------------------------------------------------------------------- | @expandExpr@ applies the aliases and inlines in @BareRTEnv@ to its argument ---   @Expr@. It must first @resolve@ the symbols in the refinement to see if ---   they correspond to alias definitions. However, we ensure that we do not ---   resolve bound variables (e.g. those bound in output refinements by input ---   parameters), and we use the @bs@ parameter to pass in the bound symbols.----------------------------------------------------------------------------------expandExpr :: BareRTEnv -> F.SourcePos -> Expr -> Expr-expandExpr rtEnv l      = go-  where-    go e@(EApp _ _)     = expandEApp rtEnv l (F.splitEApp e)-    go (EVar x)         = expandSym  rtEnv l x-    go (ENeg e)         = ENeg       (go e)-    go (ECst e s)       = ECst       (go e) s-    go (PAnd ps)        = PAnd       (go <$> ps)-    go (POr ps)         = POr        (go <$> ps)-    go (PNot p)         = PNot       (go p)-    go (PAll xs p)      = PAll xs    (go p)-    go (PExist xs p)    = PExist xs  (go p)-    go (ELam xt e)      = ELam xt    (go e)-    go (ECoerc a t e)   = ECoerc a t (go e)-    go (ETApp e s)      = ETApp      (go e) s-    go (ETAbs e s)      = ETAbs      (go e) s-    go (EBin op e1 e2)  = EBin op    (go e1) (go e2)-    go (PImp    e1 e2)  = PImp       (go e1) (go e2)-    go (PIff    e1 e2)  = PIff       (go e1) (go e2)-    go (PAtom b e1 e2)  = PAtom b    (go e1) (go e2)-    go (EIte  p e1 e2)  = EIte (go p)(go e1) (go e2)-    go (PGrad k su i e) = PGrad k su i (go e)-    go e@(PKVar _ _)    = e-    go e@(ESym _)       = e-    go e@(ECon _)       = e--expandSym :: BareRTEnv -> F.SourcePos -> F.Symbol -> Expr-expandSym rtEnv l s' = expandEApp rtEnv l (EVar s', [])---- REBARE :: expandSym' :: Symbol -> BareM Symbol--- REBARE :: expandSym' s = do-  -- REBARE :: axs <- gets axSyms-  -- REBARE :: let s' = dropModuleNamesAndUnique s-  -- REBARE :: return $ if M.member s' axs then s' else s--expandEApp :: BareRTEnv -> F.SourcePos -> (Expr, [Expr]) -> Expr-expandEApp rtEnv l (EVar f, es) = case mBody of-    Just re -> expandApp l   re       es'-    Nothing -> F.eApps       (EVar f) es'-  where-    eAs     = exprAliases rtEnv-    mBody   = Misc.firstMaybes [M.lookup f eAs, M.lookup (GM.dropModuleUnique f) eAs]-    es'     = expandExpr rtEnv l <$> es-    _f0     = GM.dropModuleNamesAndUnique f--expandEApp _ _ (f, es) = F.eApps f es------------------------------------------------------------------------------------- | Expand Alias Application ------------------------------------------------------------------------------------------------------------------------------------expandApp :: F.Subable ty => F.SourcePos -> Located (RTAlias F.Symbol ty) -> [Expr] -> ty-expandApp l lre es-  | Just su <- args = F.subst su (rtBody re)-  | otherwise       = Ex.throw err-  where-    re              = F.val lre-    args            = F.mkSubst <$> Misc.zipMaybe (rtVArgs re) es-    err             :: UserError-    err             = ErrAliasApp sp alias sp' msg-    sp              = GM.sourcePosSrcSpan l-    alias           = pprint           (rtName re)-    sp'             = GM.fSrcSpan lre -- sourcePosSrcSpan (rtPos re)-    msg             =  "expects" PJ.<+> pprint (length $ rtVArgs re)-                   PJ.<+> "arguments but it is given"-                   PJ.<+> pprint (length es)------------------------------------------------------------------------------------- | Replace Predicate Arguments With Existentials -------------------------------------------------------------------------------------------------------------txExpToBind   :: SpecType -> SpecType---------------------------------------------------------------------------------txExpToBind t = evalState (expToBindT t) (ExSt 0 M.empty πs)-  where-    πs        = M.fromList [(pname p, p) | p <- ty_preds $ toRTypeRep t ]--data ExSt = ExSt { fresh :: Int-                 , emap  :: M.HashMap F.Symbol (RSort, F.Expr)-                 , pmap  :: M.HashMap F.Symbol RPVar-                 }---- | TODO: Niki please write more documentation for this, maybe an example?---   I can't really tell whats going on... (RJ)--expToBindT :: SpecType -> State ExSt SpecType-expToBindT (RVar v r)-  = expToBindRef r >>= addExists . RVar v-expToBindT (RFun x i t1 t2 r)-  = do t1' <- expToBindT t1-       t2' <- expToBindT t2-       expToBindRef r >>= addExists . RFun x i t1' t2'-expToBindT (RAllT a t r)-  = do t' <- expToBindT t-       expToBindRef r >>= addExists . RAllT a t'-expToBindT (RAllP p t)-  = fmap (RAllP p) (expToBindT t)-expToBindT (RApp c ts rs r)-  = do ts' <- mapM expToBindT ts-       rs' <- mapM expToBindReft rs-       expToBindRef r >>= addExists . RApp c ts' rs'-expToBindT (RAppTy t1 t2 r)-  = do t1' <- expToBindT t1-       t2' <- expToBindT t2-       expToBindRef r >>= addExists . RAppTy t1' t2'-expToBindT (RRTy xts r o t)-  = do xts' <- zip xs <$> mapM expToBindT ts-       r'   <- expToBindRef r-       t'   <- expToBindT t-       return $ RRTy xts' r' o t'-  where-     (xs, ts) = unzip xts-expToBindT t-  = return t--expToBindReft              :: SpecProp -> State ExSt SpecProp-expToBindReft (RProp s (RHole r)) = rPropP s <$> expToBindRef r-expToBindReft (RProp s t)  = RProp s  <$> expToBindT t---getBinds :: State ExSt (M.HashMap F.Symbol (RSort, F.Expr))-getBinds-  = do bds <- gets emap-       modify $ \st -> st{emap = M.empty}-       return bds--addExists :: SpecType -> State ExSt SpecType-addExists t = fmap (M.foldlWithKey' addExist t) getBinds--addExist :: SpecType -> F.Symbol -> (RSort, F.Expr) -> SpecType-addExist t x (tx, e) = REx x t' t-  where-    t'               = ofRSort tx `strengthen` uTop r-    r                = F.exprReft e--expToBindRef :: UReft r -> State ExSt (UReft r)-expToBindRef (MkUReft r (Pr p))-  = mapM expToBind p <&> (MkUReft r . Pr)--expToBind :: UsedPVar -> State ExSt UsedPVar-expToBind p = do-  res <- gets (M.lookup (pname p) . pmap)-  case res of-    Nothing ->-      panic Nothing ("expToBind: " ++ show p)-    Just π  -> do-      let pargs0 = zip (pargs p) (Misc.fst3 <$> pargs π)-      pargs' <- mapM expToBindParg pargs0-      return $ p { pargs = pargs' }--expToBindParg :: (((), F.Symbol, F.Expr), RSort) -> State ExSt ((), F.Symbol, F.Expr)-expToBindParg ((t, s, e), s') = fmap ((,,) t s) (expToBindExpr e s')--expToBindExpr :: F.Expr ->  RSort -> State ExSt F.Expr-expToBindExpr e@(EVar s) _-  | Char.isLower $ F.headSym $ F.symbol s-  = return e-expToBindExpr e t-  = do s <- freshSymbol-       modify $ \st -> st{emap = M.insert s (t, e) (emap st)}-       return $ EVar s--freshSymbol :: State ExSt F.Symbol-freshSymbol-  = do n <- gets fresh-       modify $ \s -> s {fresh = n+1}-       return $ F.symbol $ "ex#" ++ show n----- wiredInMods :: S.HashSet Ghc.ModuleName--- wiredInMods = S.fromList $ Ghc.mkModuleName <$>---   ["Language.Haskell.Liquid.String",---   "Language.Haskell.Liquid.Prelude",---   "Language.Haskell.Liquid.Foreign",---   "Language.Haskell.Liquid.Bag",---   "Prelude",---   "System.IO",---   "Data.Word",---   "Data.Time.Calendar",---   "Data.Set",---   "Data.Either",---   "Data.ByteString.Unsafe",---   "Data.ByteString.Lazy",---   "Data.ByteString.Short",---   "Data.Foldable",---   "Data.OldList",---   "Data.Text",---   "Data.Tuple",---   "Data.Bits",---   "Data.Chare",---   "Data.String",---   "Data.Vector",---   "Data.Time",---   "Data.Int",---   "Data.Text.Fusion",---   "Data.Map",---   "Data.Text.Fusion.Common",---   "KMeansHelper",---   "Data.Text.Lazy.Fusion",---   "Control.Exception",---   "Control.Parallel.Strategies",---   "Data.Traversable",---   "GHC.Read",---   "Data.ByteString",---   "GHC.Classes",---   "GHC.Ptr",---   "GHC.Word",---   "Language.Haskell.Liquid.Equational",---   "GHC.Types",---   "GHC.Num",---   "GHC.CString",---   "GHC.IO.Handle",---   "GHC.Prim",---   "GHC.Int",---   "GHC.Base",---   "Foreign.Ptr",---   "GHC.ForeignPtr",---   "GHC.List",---   "Foreign.C.String",---   "GHC.Exts",---   "Foreign.Marshal.Alloc",---   "Foreign.Marshal.Array",---   "Foreign.C.Types",---   "GHC.Real",---   "Foreign.Storable",---   "Foreign.ForeignPtr"]
− src/Language/Haskell/Liquid/Bare/Laws.hs 
@@ -1,54 +0,0 @@-module Language.Haskell.Liquid.Bare.Laws ( makeInstanceLaws ) where--import qualified Data.Maybe                                 as Mb-import qualified Data.List                                  as L-import qualified Data.HashMap.Strict                        as M-import           Control.Monad ((<=<))--import qualified Language.Haskell.Liquid.Measure            as Ms-import qualified Language.Fixpoint.Types                    as F-import qualified Liquid.GHC.Misc           as GM-import           Language.Haskell.Liquid.Bare.Types         as Bare-import           Language.Haskell.Liquid.Bare.Resolve       as Bare-import           Language.Haskell.Liquid.Bare.Expand        as Bare-import           Language.Haskell.Liquid.Types-import           Liquid.GHC.API----makeInstanceLaws :: Bare.Env -> Bare.SigEnv -> [(Var,LocSpecType)]-                -> Bare.ModSpecs -> [LawInstance]-makeInstanceLaws env sigEnv sigs specs-  = [makeInstanceLaw env sigEnv sigs name rilaw-              | (name, spec) <- M.toList specs-              , rilaw <- Ms.ilaws spec ]---makeInstanceLaw :: Bare.Env -> Bare.SigEnv -> [(Var,LocSpecType)] -> ModName-                -> RILaws LocBareType -> LawInstance-makeInstanceLaw env sigEnv sigs name rilaw = LawInstance-  { lilName   = Mb.fromMaybe errmsg tc-  , liSupers  = mkTy <$> rilSupers rilaw-  , lilTyArgs = mkTy <$> rilTyArgs rilaw-  , lilEqus   = [(mkVar l, mkTypedVar r) | (l,r)<- rilEqus rilaw ]-  , lilPos    = GM.sourcePosSrcSpan $ loc $ rilPos rilaw-  }-  where-    tc    :: Maybe Class-    tc     = classTc (rilName rilaw)-    errmsg = error ("Not a type class: " ++ F.showpp tc)--    classTc = tyConClass_maybe <=< (Bare.maybeResolveSym env name "makeClass" . btc_tc)--    mkTy :: LocBareType -> LocSpecType-    mkTy = Bare.cookSpecType env sigEnv name Bare.GenTV-    mkVar :: LocSymbol -> VarOrLocSymbol-    mkVar x = case Bare.maybeResolveSym env name "makeInstanceLaw" x of-                Just v -> Left v-                _      -> Right x--    mkTypedVar :: LocSymbol -> (VarOrLocSymbol, Maybe LocSpecType)-    mkTypedVar l = case mkVar l of-                     Left x -> (Left x, Just $ Mb.fromMaybe (dummyLoc $ ofType $ varType x) (L.lookup x sigs))-                     Right x -> (Right x, Nothing)-
− src/Language/Haskell/Liquid/Bare/Measure.hs 
@@ -1,502 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RecordWildCards  #-}-{-# LANGUAGE TupleSections    #-}---- | This module contains (most of) the code needed to lift Haskell entitites,---   . code- (CoreBind), and data- (Tycon) definitions into the spec level.--module Language.Haskell.Liquid.Bare.Measure-  ( makeHaskellMeasures-  , makeHaskellInlines-  , makeHaskellDataDecls-  , makeMeasureSelectors-  , makeMeasureSpec-  , makeMeasureSpec'-  , varMeasures-  , makeClassMeasureSpec-  -- , makeHaskellBounds-  ) where--import Data.Default-import qualified Control.Exception as Ex-import Prelude hiding (mapM, error)-import Data.Bifunctor-import qualified Data.Maybe as Mb-import Text.PrettyPrint.HughesPJ (text)--- import Text.Printf     (printf)--import qualified Data.HashMap.Strict as M-import qualified Data.HashSet        as S--import           Language.Fixpoint.SortCheck (isFirstOrder)-import qualified Language.Fixpoint.Types as F-import           Language.Haskell.Liquid.Transforms.CoreToLogic-import qualified Language.Fixpoint.Misc                as Misc-import qualified Language.Haskell.Liquid.Misc          as Misc-import           Language.Haskell.Liquid.Misc             ((.||.))-import qualified Liquid.GHC.API       as Ghc-import qualified Liquid.GHC.Misc      as GM-import qualified Language.Haskell.Liquid.Types.RefType as RT-import           Language.Haskell.Liquid.Types--- import           Language.Haskell.Liquid.Types.Bounds-import qualified Language.Haskell.Liquid.Measure       as Ms--import qualified Language.Haskell.Liquid.Bare.Types    as Bare-import qualified Language.Haskell.Liquid.Bare.Resolve  as Bare-import qualified Language.Haskell.Liquid.Bare.Expand   as Bare-import qualified Language.Haskell.Liquid.Bare.DataType as Bare-import qualified Language.Haskell.Liquid.Bare.ToBare   as Bare-import Control.Monad (mapM)-----------------------------------------------------------------------------------makeHaskellMeasures :: Bool -> GhcSrc -> Bare.TycEnv -> LogicMap -> Ms.BareSpec-                    -> [Measure (Located BareType) LocSymbol]----------------------------------------------------------------------------------makeHaskellMeasures allowTC src tycEnv lmap spec-          = Bare.measureToBare <$> ms-  where-    ms    = makeMeasureDefinition allowTC tycEnv lmap cbs <$> mSyms-    cbs   = nonRecCoreBinds   (_giCbs src)-    mSyms = S.toList (Ms.hmeas spec)--makeMeasureDefinition :: Bool -> Bare.TycEnv -> LogicMap -> [Ghc.CoreBind] -> LocSymbol-                      -> Measure LocSpecType Ghc.DataCon-makeMeasureDefinition allowTC tycEnv lmap cbs x =-  case GM.findVarDef (val x) cbs of-    Nothing        -> Ex.throw $ errHMeas x "Cannot extract measure from haskell function"-    Just (v, cexp) -> Ms.mkM vx vinfo mdef MsLifted (makeUnSorted allowTC (Ghc.varType v) mdef)-                     where-                       vx           = F.atLoc x (F.symbol v)-                       mdef         = coreToDef' allowTC tycEnv lmap vx v cexp-                       vinfo        = GM.varLocInfo (logicType allowTC) v--makeUnSorted :: Bool -> Ghc.Type -> [Def LocSpecType Ghc.DataCon] -> UnSortedExprs-makeUnSorted allowTC ty defs-  | isMeasureType ta-  = mempty-  | otherwise-  = map defToUnSortedExpr defs-  where-    ta = go $ Ghc.expandTypeSynonyms ty--    go (Ghc.ForAllTy _ t) = go t-    go Ghc.FunTy{ Ghc.ft_arg = p, Ghc.ft_res = t} | isErasable p = go t-    go Ghc.FunTy{ Ghc.ft_arg = t } = t-    go t                  = t -- this should never happen!--    isMeasureType (Ghc.TyConApp _ ts) = all Ghc.isTyVarTy ts-    isMeasureType _                   = False--    defToUnSortedExpr defn = (xx:(fst <$> binds defn),-                             Ms.bodyPred (F.mkEApp (measure defn) [F.expr xx]) (body defn))--    xx = F.vv $ Just 10000-    isErasable = if allowTC then GM.isEmbeddedDictType else Ghc.isClassPred--coreToDef' :: Bool -> Bare.TycEnv -> LogicMap -> LocSymbol -> Ghc.Var -> Ghc.CoreExpr-           -> [Def LocSpecType Ghc.DataCon]-coreToDef' allowTC tycEnv lmap vx v defn =-  case runToLogic embs lmap dm (errHMeas vx) (coreToDef allowTC vx v defn) of-    Right l -> l-    Left e  -> Ex.throw e-  where-    embs    = Bare.tcEmbs       tycEnv-    dm      = Bare.tcDataConMap tycEnv--errHMeas :: LocSymbol -> String -> Error-errHMeas x str = ErrHMeas (GM.sourcePosSrcSpan $ loc x) (pprint $ val x) (text str)-----------------------------------------------------------------------------------makeHaskellInlines :: Bool -> GhcSrc -> F.TCEmb Ghc.TyCon -> LogicMap -> Ms.BareSpec-                   -> [(LocSymbol, LMap)]----------------------------------------------------------------------------------makeHaskellInlines allowTC src embs lmap spec-         = makeMeasureInline allowTC embs lmap cbs <$> inls-  where-    cbs  = nonRecCoreBinds (_giCbs src)-    inls = S.toList        (Ms.inlines spec)--makeMeasureInline :: Bool -> F.TCEmb Ghc.TyCon -> LogicMap -> [Ghc.CoreBind] -> LocSymbol-                  -> (LocSymbol, LMap)-makeMeasureInline allowTC embs lmap cbs x =-  case GM.findVarDef (val x) cbs of-    Nothing        -> Ex.throw $ errHMeas x "Cannot inline haskell function"-    Just (v, defn) -> (vx, coreToFun' allowTC embs Nothing lmap vx v defn ok)-                     where-                       vx         = F.atLoc x (F.symbol v)-                       ok (xs, e) = LMap vx (F.symbol <$> xs) (either id id e)---- | @coreToFun'@ takes a @Maybe DataConMap@: we need a proper map when lifting ---   measures and reflects (which have case-of, and hence, need the projection symbols),---   but NOT when lifting inlines (which do not have case-of). ---   For details, see [NOTE:Lifting-Stages] --coreToFun' :: Bool -> F.TCEmb Ghc.TyCon -> Maybe Bare.DataConMap -> LogicMap -> LocSymbol -> Ghc.Var -> Ghc.CoreExpr-           -> (([Ghc.Var], Either F.Expr F.Expr) -> a) -> a-coreToFun' allowTC embs dmMb lmap x v defn ok = either Ex.throw ok act-  where-    act  = runToLogic embs lmap dm err xFun-    xFun = coreToFun allowTC x v defn-    err  = errHMeas x-    dm   = Mb.fromMaybe mempty dmMb---nonRecCoreBinds :: [Ghc.CoreBind] -> [Ghc.CoreBind]-nonRecCoreBinds            = concatMap go-  where-    go cb@(Ghc.NonRec _ _) = [cb]-    go    (Ghc.Rec xes)    = [Ghc.NonRec x e | (x, e) <- xes]----------------------------------------------------------------------------------makeHaskellDataDecls :: Config -> ModName -> Ms.BareSpec -> [Ghc.TyCon]-                     -> [DataDecl]----------------------------------------------------------------------------------makeHaskellDataDecls cfg name spec tcs-  | exactDCFlag cfg = Bare.dataDeclSize spec-                    . Mb.mapMaybe tyConDataDecl-                    -- . F.tracepp "makeHaskellDataDecls-3"-                    . zipMap   (hasDataDecl name spec . fst)-                    -- . F.tracepp "makeHaskellDataDecls-2"-                    . liftableTyCons-                    -- . F.tracepp "makeHaskellDataDecls-1"-                    . filter isReflectableTyCon-                    $ tcs-  | otherwise       = []---isReflectableTyCon :: Ghc.TyCon -> Bool-isReflectableTyCon  = Ghc.isFamInstTyCon .||. Ghc.isVanillaAlgTyCon--liftableTyCons :: [Ghc.TyCon] -> [(Ghc.TyCon, DataName)]-liftableTyCons-  = F.notracepp "LiftableTCs 3"-  . zipMapMaybe (tyConDataName True)-  . F.notracepp "LiftableTCs 2"-  . filter   (not . Ghc.isBoxedTupleTyCon)-  . F.notracepp "LiftableTCs 1"-  -- . (`sortDiff` wiredInTyCons)-  -- . F.tracepp "LiftableTCs 0"--zipMap :: (a -> b) -> [a] -> [(a, b)]-zipMap f xs = zip xs (map f xs)--zipMapMaybe :: (a -> Maybe b) -> [a] -> [(a, b)]-zipMapMaybe f = Mb.mapMaybe (\x -> (x, ) <$> f x)--hasDataDecl :: ModName -> Ms.BareSpec -> Ghc.TyCon -> HasDataDecl-hasDataDecl modName spec-                 = \tc -> F.notracepp (msg tc) $ M.lookupDefault defn (tcName tc) decls-  where-    msg tc       = "hasDataDecl " ++ show (tcName tc)-    defn         = NoDecl Nothing-    tcName       = fmap (qualifiedDataName modName) . tyConDataName True-    dcName       =       qualifiedDataName modName  . tycName-    decls        = M.fromList [ (Just dn, hasDecl d)-                                | d     <- Ms.dataDecls spec-                                , let dn = dcName d]--qualifiedDataName :: ModName -> DataName -> DataName-qualifiedDataName modName (DnName lx) = DnName (qualifyModName modName <$> lx)-qualifiedDataName modName (DnCon  lx) = DnCon  (qualifyModName modName <$> lx)--{-tyConDataDecl :: {tc:TyCon | isAlgTyCon tc} -> Maybe DataDecl @-}-tyConDataDecl :: ((Ghc.TyCon, DataName), HasDataDecl) -> Maybe DataDecl-tyConDataDecl (_, HasDecl)-  = Nothing-tyConDataDecl ((tc, dn), NoDecl szF)-  = Just $ DataDecl-      { tycName   = dn-      , tycTyVars = F.symbol <$> GM.tyConTyVarsDef tc-      , tycPVars  = []-      , tycDCons  = Just (decls tc)-      , tycSrcPos = GM.getSourcePos tc-      , tycSFun   = szF-      , tycPropTy = Nothing-      , tycKind   = DataReflected-      }-      where decls = map dataConDecl . Ghc.tyConDataCons--tyConDataName :: Bool -> Ghc.TyCon -> Maybe DataName-tyConDataName full tc-  | vanillaTc  = Just (DnName (post . F.symbol <$> GM.locNamedThing tc))-  | d:_ <- dcs = Just (DnCon  (post . F.symbol <$> GM.locNamedThing d ))-  | otherwise  = Nothing-  where-    post       = if full then id else GM.dropModuleNamesAndUnique-    vanillaTc  = Ghc.isVanillaAlgTyCon tc-    dcs        = Misc.sortOn F.symbol (Ghc.tyConDataCons tc)--dataConDecl :: Ghc.DataCon -> DataCtor-dataConDecl d     = {- F.notracepp msg $ -} DataCtor dx (F.symbol <$> as) [] xts outT-  where-    isGadt        = not (Ghc.isVanillaDataCon d)-    -- msg           = printf "dataConDecl (gadt = %s)" (show isGadt)-    xts           = [(Bare.makeDataConSelector Nothing d i, RT.bareOfType t) | (i, t) <- its ]-    dx            = F.symbol <$> GM.locNamedThing d-    its           = zip [1..] ts-    (as,_ps,ts,ty)  = Ghc.dataConSig d-    outT          = Just (RT.bareOfType ty :: BareType)-    _outT :: Maybe BareType-    _outT-      | isGadt    = Just (RT.bareOfType ty)-      | otherwise = Nothing----------------------------------------------------------------------------------------- | 'makeMeasureSelectors' converts the 'DataCon's and creates the measures for---   the selectors and checkers that then enable reflection.-----------------------------------------------------------------------------------makeMeasureSelectors :: Config -> Bare.DataConMap -> Located DataConP -> [Measure SpecType Ghc.DataCon]-makeMeasureSelectors cfg dm (Loc l l' c)-  = Misc.condNull (exactDCFlag cfg) (checker : Mb.mapMaybe go' fields) --  internal measures, needed for reflection- ++ Misc.condNull autofields (Mb.mapMaybe go fields) --  user-visible measures.-  where-    dc         = dcpCon    c-    isGadt     = dcpIsGadt c-    xts        = dcpTyArgs c-    autofields = not isGadt-    go ((x, t), i)-      -- do not make selectors for functional fields-      | isFunTy t && not (higherOrderFlag cfg)-      = Nothing-      | otherwise-      = Just $ makeMeasureSelector (Loc l l' x) (projT i) dc n i--    go' ((_,t), i)-      -- do not make selectors for functional fields-      | isFunTy t && not (higherOrderFlag cfg)-      = Nothing-      | otherwise-      = Just $ makeMeasureSelector (Loc l l' (Bare.makeDataConSelector (Just dm) dc i)) (projT i) dc n i--    fields   = zip (reverse xts) [1..]-    n        = length xts-    checker  = makeMeasureChecker (Loc l l' (Bare.makeDataConChecker dc)) checkT dc n-    projT i  = dataConSel permitTC dc n (Proj i)-    checkT   = dataConSel permitTC dc n Check-    permitTC = typeclass cfg--dataConSel :: Bool -> Ghc.DataCon -> Int -> DataConSel -> SpecType-dataConSel permitTC dc n Check    = mkArrow (zip as (repeat mempty)) [] [] [xt] bareBool-  where-    (as, _, xt)          = {- traceShow ("dataConSel: " ++ show dc) $ -} bkDataCon permitTC dc n--dataConSel permitTC dc n (Proj i) = mkArrow (zip as (repeat mempty)) [] [] [xt] (mempty <$> ti)-  where-    ti                   = Mb.fromMaybe err $ Misc.getNth (i-1) ts-    (as, ts, xt)         = {- F.tracepp ("bkDatacon dc = " ++ F.showpp (dc, n)) $ -} bkDataCon permitTC dc n-    err                  = panic Nothing $ "DataCon " ++ show dc ++ "does not have " ++ show i ++ " fields"---- bkDataCon :: DataCon -> Int -> ([RTVar RTyVar RSort], [SpecType], (Symbol, SpecType, RReft))-bkDataCon :: (F.Reftable (RTProp RTyCon RTyVar r), PPrint r, F.Reftable r) => Bool -> Ghc.DataCon -> Int -> ([RTVar RTyVar RSort], [RRType r], (F.Symbol, RFInfo, RRType r, r))-bkDataCon permitTC dcn nFlds  = (as, ts, (F.dummySymbol, classRFInfo permitTC, t, mempty))-  where-    ts                = RT.ofType <$> Misc.takeLast nFlds (map Ghc.irrelevantMult _ts)-    t                 = -- Misc.traceShow ("bkDataConResult" ++ GM.showPpr (dc, _t, _t0)) $-                          RT.ofType  $ Ghc.mkTyConApp tc tArgs'-    as                = makeRTVar . RT.rTyVar <$> (αs ++ αs')-    ((αs,αs',_,_,_ts,_t), _t0) = hammer dcn-    tArgs'            = take (nArgs - nVars) tArgs ++ (Ghc.mkTyVarTy <$> αs)-    nVars             = length αs-    nArgs             = length tArgs-    (tc, tArgs)       = Mb.fromMaybe err (Ghc.splitTyConApp_maybe _t)-    err               = GM.namedPanic dcn ("Cannot split result type of DataCon " ++ show dcn)-    hammer dc         = (Ghc.dataConFullSig dc, Ghc.varType . Ghc.dataConWorkId $ dc)--data DataConSel = Check | Proj Int--bareBool :: SpecType-bareBool = RApp (RTyCon Ghc.boolTyCon [] def) [] [] mempty---{- | NOTE:Use DataconWorkId--      dcWorkId :: forall a1 ... aN. (a1 ~ X1 ...) => T1 -> ... -> Tn -> T-      checkT   :: forall as. T -> Bool-      projT t  :: forall as. T -> t---}--makeMeasureSelector :: (Show a1) => LocSymbol -> SpecType -> Ghc.DataCon -> Int -> a1 -> Measure SpecType Ghc.DataCon-makeMeasureSelector x s dc n i = M { msName = x, msSort = s, msEqns = [eqn], msKind = MsSelector, msUnSorted = mempty}-  where-    eqn                        = Def x dc Nothing args (E (F.EVar $ mkx i))-    args                       = (, Nothing) . mkx <$> [1 .. n]-    mkx j                      = F.symbol ("xx" ++ show j)--makeMeasureChecker :: LocSymbol -> SpecType -> Ghc.DataCon -> Int -> Measure SpecType Ghc.DataCon-makeMeasureChecker x s0 dc n = M { msName = x, msSort = s, msEqns = eqn : (eqns <$> filter (/= dc) dcs), msKind = MsChecker, msUnSorted = mempty }-  where-    s       = F.notracepp ("makeMeasureChecker: " ++ show x) s0-    eqn     = Def x dc Nothing ((, Nothing) . mkx <$> [1 .. n])       (P F.PTrue)-    eqns d  = Def x d  Nothing ((, Nothing) . mkx <$> [1 .. nArgs d]) (P F.PFalse)-    nArgs d = length (Ghc.dataConOrigArgTys d)-    mkx j   = F.symbol ("xx" ++ show j)-    dcs     = Ghc.tyConDataCons (Ghc.dataConTyCon dc)--------------------------------------------------------------------------------------------------makeMeasureSpec' :: Bool -> MSpec SpecType Ghc.DataCon -> ([(Ghc.Var, SpecType)], [(LocSymbol, RRType F.Reft)])------------------------------------------------------------------------------------------------makeMeasureSpec' allowTC mspec0 = (ctorTys, measTys)-  where-    ctorTys             = Misc.mapSnd RT.uRType <$> ctorTys0-    (ctorTys0, measTys) = Ms.dataConTypes allowTC mspec-    mspec               = first (mapReft ur_reft) mspec0-------------------------------------------------------------------------------------------------makeMeasureSpec :: Bare.Env -> Bare.SigEnv -> ModName -> (ModName, Ms.BareSpec) ->-                   Bare.Lookup (Ms.MSpec SpecType Ghc.DataCon)------------------------------------------------------------------------------------------------makeMeasureSpec env sigEnv myName (name, spec)-  = mkMeasureDCon env               name-  . mkMeasureSort env               name-  . first val-  . bareMSpec     env sigEnv myName name-  $ spec--bareMSpec :: Bare.Env -> Bare.SigEnv -> ModName -> ModName -> Ms.BareSpec -> Ms.MSpec LocBareType LocSymbol-bareMSpec env sigEnv myName name spec = Ms.mkMSpec ms cms ims-  where-    cms        = F.notracepp "CMS" $ filter inScope1 $             Ms.cmeasures spec-    ms         = F.notracepp "UMS" $ filter inScope2 $ expMeas <$> Ms.measures  spec-    ims        = F.notracepp "IMS" $ filter inScope2 $ expMeas <$> Ms.imeasures spec-    expMeas    = expandMeasure env name  rtEnv-    rtEnv      = Bare.sigRTEnv          sigEnv-    force      = name == myName-    inScope1 z = F.notracepp ("inScope1: " ++ F.showpp (msName z)) (force ||  okSort z)-    inScope2 z = F.notracepp ("inScope2: " ++ F.showpp (msName z)) (force || (okSort z && okCtors z))-    okSort     = Bare.knownGhcType env name . msSort-    okCtors    = all (Bare.knownGhcDataCon env name . ctor) . msEqns--mkMeasureDCon :: Bare.Env -> ModName -> Ms.MSpec t LocSymbol -> Bare.Lookup (Ms.MSpec t Ghc.DataCon)-mkMeasureDCon env name m = do-  let ns = measureCtors m-  dcs   <- mapM (Bare.lookupGhcDataCon env name "measure-datacon") ns-  return $ mkMeasureDCon_ m (zip (val <$> ns) dcs)---- mkMeasureDCon env name m = mkMeasureDCon_ m [ (val n, symDC n) | n <- measureCtors m ]---   where ---     symDC                = Bare.lookupGhcDataCon env name "measure-datacon"--mkMeasureDCon_ :: Ms.MSpec t LocSymbol -> [(F.Symbol, Ghc.DataCon)] -> Ms.MSpec t Ghc.DataCon-mkMeasureDCon_ m ndcs = m' {Ms.ctorMap = cm'}-  where-    m'                = fmap (tx.val) m-    cm'               = Misc.hashMapMapKeys (F.symbol . tx) $ Ms.ctorMap m'-    tx                = Misc.mlookup (M.fromList ndcs)--measureCtors ::  Ms.MSpec t LocSymbol -> [LocSymbol]-measureCtors = Misc.sortNub . fmap ctor . concat . M.elems . Ms.ctorMap--mkMeasureSort :: Bare.Env -> ModName -> Ms.MSpec BareType LocSymbol-              -> Ms.MSpec SpecType LocSymbol-mkMeasureSort env name (Ms.MSpec c mm cm im) =-  Ms.MSpec (map txDef <$> c) (tx <$> mm) (tx <$> cm) (tx <$> im)-    where-      ofMeaSort :: F.SourcePos -> BareType -> SpecType-      ofMeaSort l = Bare.ofBareType env name l Nothing--      tx :: Measure BareType ctor -> Measure SpecType ctor-      tx (M n s eqs k u) = M n (ofMeaSort l s) (txDef <$> eqs) k u where l = GM.fSourcePos n--      txDef :: Def BareType ctor -> Def SpecType ctor-      txDef d = first (ofMeaSort l) d                              where l = GM.fSourcePos (measure d)--------------------------------------------------------------------------------------- | Expand Measures ----------------------------------------------------------------------------------------------------------------------------------------------- type BareMeasure = Measure LocBareType LocSymbol--expandMeasure :: Bare.Env -> ModName -> BareRTEnv -> BareMeasure -> BareMeasure-expandMeasure env name rtEnv m = m-  { msSort = RT.generalize                   <$> msSort m-  , msEqns = expandMeasureDef env name rtEnv <$> msEqns m-  }--expandMeasureDef :: Bare.Env -> ModName -> BareRTEnv -> Def t LocSymbol -> Def t LocSymbol-expandMeasureDef env name rtEnv d = d-  { body  = F.notracepp msg $ Bare.qualifyExpand env name rtEnv l bs (body d) }-  where-    l     = loc (measure d)-    bs    = fst <$> binds d-    msg   = "QUALIFY-EXPAND-BODY" ++ F.showpp (bs, body d)---------------------------------------------------------------------------------varMeasures :: (Monoid r) => Bare.Env -> [(F.Symbol, Located (RRType r))]--------------------------------------------------------------------------------varMeasures env =-  [ (F.symbol v, varSpecType v)-      | v <- knownVars env-      , GM.isDataConId v-      , isSimpleType (Ghc.varType v) ]--knownVars :: Bare.Env -> [Ghc.Var]-knownVars env = [ v | (_, xThings)   <- M.toList (Bare._reTyThings env)-                    , (_,Ghc.AnId v) <- xThings-                ]--varSpecType :: (Monoid r) => Ghc.Var -> Located (RRType r)-varSpecType = fmap (RT.ofType . Ghc.varType) . GM.locNamedThing--isSimpleType :: Ghc.Type -> Bool-isSimpleType = isFirstOrder . RT.typeSort mempty--makeClassMeasureSpec :: MSpec (RType c tv (UReft r2)) t-                     -> [(LocSymbol, CMeasure (RType c tv r2))]-makeClassMeasureSpec Ms.MSpec{..} = tx <$> M.elems cmeasMap-  where-    tx (M n s _ _ _) = (n, CM n (mapReft ur_reft s))---{- -expandMeasureBody :: Bare.Env -> ModName -> BareRTEnv -> SourcePos -> Body -> Body-expandMeasureBody env name rtEnv l (P   p) = P   (Bare.expandQualify env name rtEnv l p) -expandMeasureBody env name rtEnv l (R x p) = R x (Bare.expandQualify env name rtEnv l p) -expandMeasureBody env name rtEnv l (E   e) = E   (Bare.expandQualify env name rtEnv l e) ---makeHaskellBounds :: F.TCEmb TyCon -> CoreProgram -> S.HashSet (Var, LocSymbol) -> BareM RBEnv  -- TODO-REBARE-makeHaskellBounds embs cbs xs = do-  lmap <- gets logicEnv-  M.fromList <$> mapM (makeHaskellBound embs lmap cbs) (S.toList xs)--makeHaskellBound :: F.TCEmb TyCon-                 -> LogicMap-                 -> [Bind Var]-                 -> (Var, Located Symbol)-                 -> BareM (LocSymbol, RBound)-makeHaskellBound embs lmap  cbs (v, x) =-  case filter ((v  `elem`) . GM.binders) cbs of-    (NonRec v def:_)   -> toBound v x <$> coreToFun' embs lmap x v def return-    (Rec [(v, def)]:_) -> toBound v x <$> coreToFun' embs lmap x v def return-    _                  -> throwError $ errHMeas x "Cannot make bound of haskell function"----toBound :: Var -> LocSymbol -> ([Var], Either F.Expr F.Expr) -> (LocSymbol, RBound)-toBound v x (vs, Left p) = (x', Bound x' fvs ps xs p)-  where-    x'         = capitalizeBound x-    (ps', xs') = L.partition (hasBoolResult . varType) vs-    (ps , xs)  = (txp <$> ps', txx <$> xs')-    txp v      = (dummyLoc $ simpleSymbolVar v, RT.ofType $ varType v)-    txx v      = (dummyLoc $ symbol v,          RT.ofType $ varType v)-    fvs        = (((`RVar` mempty) . RTV) <$> fst (splitForAllTys $ varType v)) :: [RSort]--toBound v x (vs, Right e) = toBound v x (vs, Left e)--capitalizeBound :: Located Symbol -> Located Symbol-capitalizeBound = fmap (symbol . toUpperHead . symbolString)-  where-    toUpperHead []     = []-    toUpperHead (x:xs) = toUpper x:xs---}-
− src/Language/Haskell/Liquid/Bare/Misc.hs 
@@ -1,213 +0,0 @@-{-# LANGUAGE FlexibleContexts         #-}---module Language.Haskell.Liquid.Bare.Misc-  ( joinVar-  , mkVarExpr-  , vmap-  , runMapTyVars-  , matchKindArgs-  , symbolRTyVar-  , simpleSymbolVar-  , hasBoolResult-  , isKind-  ) where--import           Prelude                               hiding (error)--import           Liquid.GHC.API       as Ghc  hiding (Located, showPpr)--import           Control.Monad.Except                  (MonadError, throwError)-import           Control.Monad.State-import qualified Data.Maybe                            as Mb --(fromMaybe, isNothing)--import qualified Text.PrettyPrint.HughesPJ             as PJ-import qualified Data.List                             as L-import qualified Language.Fixpoint.Types as F-import           Liquid.GHC.Misc-import           Language.Haskell.Liquid.Types.RefType-import           Language.Haskell.Liquid.Types.Types---- import           Language.Haskell.Liquid.Bare.Env---- import           Language.Haskell.Liquid.WiredIn       (dcPrefix)----- TODO: This is where unsorted stuff is for now. Find proper places for what follows.--{- --- WTF does this function do?-makeSymbols :: (Id -> Bool) -> [Id] -> [F.Symbol] -> BareM [(F.Symbol, Var)]-makeSymbols f vs xs-  = do svs <- M.toList <$> gets varEnv-       return $ L.nub ([ (x,v') | (x,v) <- svs, x `elem` xs, let (v',_,_) = joinVar vs (v,x,x)]-                   ++  [ (F.symbol v, v) | v <- vs, f v, isDataConId v, hasBasicArgs $ varType v ])-    where-      -- arguments should be basic so that autogenerated singleton types are well formed-      hasBasicArgs (ForAllTy _ t) = hasBasicArgs t-      hasBasicArgs (FunTy _ tx t)   = isBaseTy tx && hasBasicArgs t-      hasBasicArgs _              = True---}--{- -HEAD-freeSymbols :: (F.Reftable r, F.Reftable r1, F.Reftable r2, TyConable c, TyConable c1, TyConable c2)-            => [F.Symbol]-            -> [(a1, Located (RType c2 tv2 r2))]-            -> [(a, Located (RType c1 tv1 r1))]-            -> [Located (RType c tv r)]-            -> [LocSymbol]-freeSymbols xs' xts yts ivs =  [ lx | lx <- Misc.sortNub $ zs ++ zs' ++ zs'' , not (M.member (val lx) knownM) ]-  where-    knownM                  = M.fromList [ (x, ()) | x <- xs' ]-    zs                      = concatMap freeSyms (snd <$> xts)-    zs'                     = concatMap freeSyms (snd <$> yts)-    zs''                    = concatMap freeSyms ivs------------------------------------------------------------------------------------freeSyms :: (F.Reftable r, TyConable c) => Located (RType c tv r) -> [LocSymbol]---------------------------------------------------------------------------------freeSyms ty    = [ F.atLoc ty x | x <- tySyms ]-  where-    tySyms     = Misc.sortNub $ concat $ efoldReft (\_ _ -> True) False (\_ _ -> []) (const []) (const ()) f (const id) F.emptySEnv [] (val ty)-    f γ _ r xs = let F.Reft (v, _) = F.toReft r in-                 [ x | x <- F.syms r, x /= v, not (x `F.memberSEnv` γ)] : xs----- ABOVE IS THE T1773 STUFF---- BELOW IS THE develop-classes STUFF ---- freeSymbols :: (F.Reftable r, F.Reftable r1, F.Reftable r2, TyConable c, TyConable c1, TyConable c2)---             => [F.Symbol]---             -> [(a1, Located (RType c2 tv2 r2))]---             -> [(a, Located (RType c1 tv1 r1))]---             -> [(Located (RType c tv r))]---             -> [LocSymbol]--- freeSymbols xs' xts yts ivs =  [ lx | lx <- Misc.sortNub $ zs ++ zs' ++ zs'' , not (M.member (val lx) knownM) ]---   where---     knownM                  = M.fromList [ (x, ()) | x <- xs' ]---     zs                      = concatMap freeSyms (snd <$> xts)---     zs'                     = concatMap freeSyms (snd <$> yts)---     zs''                    = concatMap freeSyms ivs------ freeSyms :: (F.Reftable r, TyConable c) => Located (RType c tv r) -> [LocSymbol]--- freeSyms ty    = [ F.atLoc ty x | x <- tySyms ]---   where---     tySyms     = Misc.sortNub $ concat $ efoldReft (\_ _ -> True) False (\_ _ -> []) (\_ -> []) (const ()) f (const id) F.emptySEnv [] (val ty)---     f γ _ r xs = let F.Reft (v, _) = F.toReft r in---                  [ x | x <- F.syms r, x /= v, not (x `F.memberSEnv` γ)] : xs---}----------------------------------------------------------------------------------- Renaming Type Variables in Haskell Signatures ---------------------------------------------------------------------------------------------------------------runMapTyVars :: Bool -> Type -> SpecType -> (PJ.Doc -> PJ.Doc -> Error) -> Either Error MapTyVarST-runMapTyVars allowTC τ t err = execStateT (mapTyVars allowTC τ t) (MTVST [] err)--data MapTyVarST = MTVST-  { vmap   :: [(Var, RTyVar)]-  , errmsg :: PJ.Doc -> PJ.Doc -> Error-  }--mapTyVars :: Bool -> Type -> SpecType -> StateT MapTyVarST (Either Error) ()-mapTyVars allowTC t (RImpF _ _ _ t' _)-   = mapTyVars allowTC t t'-mapTyVars allowTC (FunTy { ft_arg = τ, ft_res = τ'}) t-  | isErasable τ-  = mapTyVars allowTC τ' t-  where isErasable = if allowTC then isEmbeddedDictType else isClassPred-mapTyVars allowTC (FunTy { ft_arg = τ, ft_res = τ'}) (RFun _ _ t t' _)-   = mapTyVars allowTC τ t >> mapTyVars allowTC τ' t'-mapTyVars allowTC τ (RAllT _ t _)-  = mapTyVars allowTC τ t-mapTyVars allowTC (TyConApp _ τs) (RApp _ ts _ _)-   = zipWithM_ (mapTyVars allowTC) τs (matchKindArgs' τs ts)-mapTyVars _ (TyVarTy α) (RVar a _)-   = do s  <- get-        s' <- mapTyRVar α a s-        put s'-mapTyVars allowTC τ (RAllP _ t)-  = mapTyVars allowTC τ t-mapTyVars allowTC τ (RAllE _ _ t)-  = mapTyVars allowTC τ t-mapTyVars allowTC τ (RRTy _ _ _ t)-  = mapTyVars allowTC τ t-mapTyVars allowTC τ (REx _ _ t)-  = mapTyVars allowTC τ t-mapTyVars _ _ (RExprArg _)-  = return ()-mapTyVars allowTC (AppTy τ τ') (RAppTy t t' _)-  = do  mapTyVars allowTC τ t-        mapTyVars allowTC τ' t'-mapTyVars _ _ (RHole _)-  = return ()-mapTyVars _ k _ | isKind k-  = return ()-mapTyVars allowTC (ForAllTy _ τ) t-  = mapTyVars allowTC τ t-mapTyVars _ hsT lqT-  = do err <- gets errmsg-       throwError (err (F.pprint hsT) (F.pprint lqT))--isKind :: Kind -> Bool-isKind = classifiesTypeWithValues -- TODO:GHC-863 isStarKind k --  typeKind k---mapTyRVar :: MonadError Error m-          => Var -> RTyVar -> MapTyVarST -> m MapTyVarST-mapTyRVar α a s@(MTVST αas err)-  = case lookup α αas of-      Just a' | a == a'   -> return s-              | otherwise -> throwError (err (F.pprint a) (F.pprint a'))-      Nothing             -> return $ MTVST ((α,a):αas) err--matchKindArgs' :: [Type] -> [SpecType] -> [SpecType]-matchKindArgs' ts1' = reverse . go (reverse ts1') . reverse-  where-    go (_:ts1) (t2:ts2) = t2:go ts1 ts2-    go ts      []       | all isKind ts-                        = (ofType <$> ts) :: [SpecType]-    go _       ts       = ts---matchKindArgs :: [SpecType] -> [SpecType] -> [SpecType]-matchKindArgs ts1' = reverse . go (reverse ts1') . reverse-  where-    go (_:ts1) (t2:ts2) = t2:go ts1 ts2-    go ts      []       = ts-    go _       ts       = ts--mkVarExpr :: Id -> F.Expr-mkVarExpr v-  | isFunVar v = F.mkEApp (varFunSymbol v) []-  | otherwise  = F.eVar v -- EVar (symbol v)--varFunSymbol :: Id -> Located F.Symbol-varFunSymbol = dummyLoc . F.symbol . idDataCon--isFunVar :: Id -> Bool-isFunVar v   = isDataConId v && not (null αs) && Mb.isNothing tf-  where-    (αs, t)  = splitForAllTys $ varType v-    tf       = splitFunTy_maybe t---- the Vars we lookup in GHC don't always have the same tyvars as the Vars--- we're given, so return the original var when possible.--- see tests/pos/ResolvePred.hs for an example-joinVar :: [Var] -> (Var, s, t) -> (Var, s, t)-joinVar vs (v,s,t) = case L.find ((== showPpr v) . showPpr) vs of-                       Just v' -> (v',s,t)-                       Nothing -> (v,s,t)--simpleSymbolVar :: Var -> F.Symbol-simpleSymbolVar  = dropModuleNames . F.symbol . showPpr . getName--hasBoolResult :: Type -> Bool-hasBoolResult (ForAllTy _ t) = hasBoolResult t-hasBoolResult (FunTy { ft_res = t} )    | eqType boolTy t = True-hasBoolResult (FunTy { ft_res = t} )    = hasBoolResult t-hasBoolResult _              = False
− src/Language/Haskell/Liquid/Bare/Plugged.hs 
@@ -1,307 +0,0 @@-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE PartialTypeSignatures #-}--module Language.Haskell.Liquid.Bare.Plugged-  ( makePluggedSig-  , makePluggedDataCon-  ) where--import Prelude hiding (error)-import Data.Generics.Aliases (mkT)-import Data.Generics.Schemes (everywhere)--import           Text.PrettyPrint.HughesPJ-import qualified Control.Exception                 as Ex-import qualified Data.HashMap.Strict               as M-import qualified Data.HashSet                      as S-import qualified Data.Maybe                        as Mb-import qualified Data.List                         as L-import qualified Language.Fixpoint.Types           as F-import qualified Language.Fixpoint.Types.Visitor   as F-import qualified Liquid.GHC.Misc  as GM-import qualified Liquid.GHC.API   as Ghc-import           Liquid.GHC.Types (StableName, mkStableName)-import           Language.Haskell.Liquid.Types.RefType ()-import           Language.Haskell.Liquid.Types-import qualified Language.Haskell.Liquid.Misc       as Misc-import qualified Language.Haskell.Liquid.Bare.Types as Bare-import qualified Language.Haskell.Liquid.Bare.Misc  as Bare-------------------------------------------------------------------------------------------- [NOTE: Plug-Holes-TyVars] We have _two_ versions of `plugHoles:--- * `HsTyVars` ensures that the returned signature uses the GHC type variables;---   We need this as these tyvars can appear in the SOURCE (as type annotations, or---   as the types of lambdas) and renaming them will cause problems; --- * `LqTyVars` ensures that the returned signatuer uses the LIQUID type variables; ---   We need this e.g. for class specifications where we cannot change the tyvars ---   used inside method signatures as that messes up the type for the data-constructor ---   for the dictionary (as we need to use the same tyvars as are "bound" in the class ---   definition).--- In short, use `HsTyVars` when we also have to analyze the binder's SOURCE; and --- otherwise, use `LqTyVars`.----------------------------------------------------------------------------------------------------------------------------------------------------------------------------- | NOTE: Be *very* careful with the use functions from RType -> GHC.Type,---   e.g. toType, in this module as they cannot handle LH type holes. Since---   this module is responsible for plugging the holes we obviously cannot---   assume, as in e.g. L.H.L.Constraint.* that they do not appear.----------------------------------------------------------------------------------makePluggedSig :: Bool -> ModName -> F.TCEmb Ghc.TyCon -> TyConMap -> S.HashSet StableName-               -> Bare.PlugTV Ghc.Var -> LocSpecType-               -> LocSpecType--makePluggedSig allowTC name embs tyi exports kx t-  | Just x <- kxv = mkPlug x-  | otherwise     = t-  where-    kxv           = Bare.plugSrc kx-    mkPlug x      = plugHoles allowTC kx embs tyi  r τ t-      where-        τ         = Ghc.expandTypeSynonyms (Ghc.varType x)-        r         = maybeTrue x name exports-    -- x = case kx of { Bare.HsTV x -> x ; Bare.LqTV x -> x }----- makePluggedDataCon = makePluggedDataCon_old --- plugHoles          = plugHolesOld --- makePluggedDataCon = makePluggedDataCon_new ---- plugHoles _         = plugHolesOld--plugHoles :: (Ghc.NamedThing a, PPrint a, Show a)-          => Bool-          -> Bare.PlugTV a-          -> F.TCEmb Ghc.TyCon-          -> Bare.TyConMap-          -> (SpecType -> RReft -> RReft)-          -> Ghc.Type-          -> LocSpecType-          -> LocSpecType-plugHoles allowTC (Bare.HsTV x) a b = plugHolesOld allowTC a b x-plugHoles allowTC (Bare.LqTV x) a b = plugHolesNew allowTC a b x-plugHoles _ _                   _ _ = \_ _ t -> t---makePluggedDataCon :: Bool -> F.TCEmb Ghc.TyCon -> Bare.TyConMap -> Located DataConP -> Located DataConP-makePluggedDataCon allowTC embs tyi ldcp-  | mismatchFlds      = Ex.throw (err "fields") -- (err $  "fields:" <+> F.pprint (length dts) <+> " vs " <+> F.pprint ( dcArgs))-  | mismatchTyVars    = Ex.throw (err "type variables")-  | otherwise         = F.atLoc ldcp $ F.notracepp "makePluggedDataCon" $ dcp-                          { dcpFreeTyVars = dcVars-                          , dcpTyArgs     = reverse tArgs-                          , dcpTyRes      = tRes-                          }-  where-    (tArgs, tRes)     = plugMany allowTC  embs tyi ldcp (das, dts, dt) (dcVars, dcArgs, dcpTyRes dcp)-    (das, _, dts, dt) = {- F.notracepp ("makePluggedDC: " ++ F.showpp dc) $ -} Ghc.dataConSig dc-    dcArgs            = reverse $ filter (not . (if allowTC then isEmbeddedClass else isClassType) . snd) (dcpTyArgs dcp)-    dcVars            = if isGADT-                          then padGADVars $ L.nub (dcpFreeTyVars dcp ++ concatMap (map ty_var_value . freeTyVars) (dcpTyRes dcp:(snd <$> dcArgs)))-                          else dcpFreeTyVars dcp-    dc                = dcpCon        dcp-    dcp               = val           ldcp--    isGADT            = Ghc.isGadtSyntaxTyCon $ Ghc.dataConTyCon dc--    -- hack to match LH and GHC GADT vars, since it is unclear how ghc generates free vars -    padGADVars vs = (RTV <$> take (length das - length vs) das) ++ vs--    mismatchFlds      = length dts /= length dcArgs-    mismatchTyVars    = length das /= length dcVars-    err things        = ErrBadData (GM.fSrcSpan dcp) (pprint dc) ("GHC and Liquid specifications have different numbers of" <+> things) :: UserError----- | @plugMany@ is used to "simultaneously" plug several different types, ---   e.g. as arise in the fields of a data constructor. To do so we create ---   a single "function type" that is then passed into @plugHoles@. ---   We also pass in the type parameters as dummy arguments, because, e.g. ---   we want @plugMany@ on the two types---  ---      forall a. a -> a -> Bool ---      forall b. _ -> _ -> _ --- ---   to return something like --- ---      forall b. b -> b -> Bool--- ---   and not, forall b. a -> a -> Bool.--plugMany :: Bool -> F.TCEmb Ghc.TyCon -> Bare.TyConMap-         -> Located DataConP-         -> ([Ghc.Var], [Ghc.Type],             Ghc.Type)   -- ^ hs type -         -> ([RTyVar] , [(F.Symbol, SpecType)], SpecType)   -- ^ lq type -         -> ([(F.Symbol, SpecType)], SpecType)              -- ^ plugged lq type-plugMany allowTC embs tyi ldcp (hsAs, hsArgs, hsRes) (lqAs, lqArgs, lqRes)-                     = F.notracepp msg (drop nTyVars (zip xs ts), t)-  where-    (_,(xs,_,ts,_), t) = bkArrow (val pT)-    pT               = plugHoles allowTC (Bare.LqTV dcName) embs tyi (const killHoles) hsT (F.atLoc ldcp lqT)-    hsT              = foldr (Ghc.mkFunTy Ghc.VisArg Ghc.Many) hsRes hsArgs'-    lqT              = foldr (uncurry (rFun' (classRFInfo allowTC))) lqRes lqArgs'-    hsArgs'          = [ Ghc.mkTyVarTy a               | a <- hsAs] ++ hsArgs-    lqArgs'          = [(F.dummySymbol, RVar a mempty) | a <- lqAs] ++ lqArgs-    nTyVars          = length hsAs -- == length lqAs-    dcName           = Ghc.dataConName . dcpCon . val $ ldcp-    msg              = "plugMany: " ++ F.showpp (dcName, hsT, lqT)--plugHolesOld, plugHolesNew-  :: (Ghc.NamedThing a, PPrint a, Show a)-  => Bool-  -> F.TCEmb Ghc.TyCon-  -> Bare.TyConMap-  -> a-  -> (SpecType -> RReft -> RReft)-  -> Ghc.Type-  -> LocSpecType-  -> LocSpecType---- NOTE: this use of toType is safe as rt' is derived from t.-plugHolesOld allowTC tce tyi xx f t0 zz@(Loc l l' st0)-    = Loc l l'-    . mkArrow (zip (updateRTVar <$> αs') rs) ps' [] []-    . makeCls cs'-    . goPlug tce tyi err f (subts su rt)-    . mapExprReft (\_ -> F.applyCoSub coSub)-    . subts su-    $ st-  where-    tyvsmap      = case Bare.runMapTyVars allowTC (toType False rt) st err of-                          Left e  -> Ex.throw e-                          Right s -> Bare.vmap s-    su           = [(y, rTyVar x)           | (x, y) <- tyvsmap]-    su'          = [(y, RVar (rTyVar x) ()) | (x, y) <- tyvsmap] :: [(RTyVar, RSort)]-    coSub        = M.fromList [(F.symbol y, F.FObj (F.symbol x)) | (y, x) <- su]-    ps'          = fmap (subts su') <$> ps-    cs'          = [(F.dummySymbol, RApp c ts [] mempty) | (c, ts) <- cs2 ]-    (αs', rs)    = unzip αs-    (αs,_,cs2,rt) = bkUnivClass (F.notracepp "hs-spec" $ ofType (Ghc.expandTypeSynonyms t0) :: SpecType)-    (_,ps,_ ,st) = bkUnivClass (F.notracepp "lq-spec" st0)--    makeCls cs t = foldr (uncurry (rFun' (classRFInfo allowTC))) t cs-    err hsT lqT  = ErrMismatch (GM.fSrcSpan zz) (pprint xx)-                          (text "Plugged Init types old")-                          (pprint $ Ghc.expandTypeSynonyms t0)-                          (pprint $ toRSort st0)-                          (Just (hsT, lqT))-                          (Ghc.getSrcSpan xx)----plugHolesNew allowTC@False tce tyi xx f t0 zz@(Loc l l' st0)-    = Loc l l'-    . mkArrow (zip (updateRTVar <$> as'') rs) ps [] []-    . makeCls cs'-    . goPlug tce tyi err f rt'-    $ st-  where-    rt'          = tx rt-    as''         = subRTVar su <$> as'-    (as',rs)     = unzip as-    cs'          = [ (F.dummySymbol, ct) | (c, t) <- tyCons, let ct = tx (RApp c t [] mempty) ]-    tx           = subts su-    su           = case Bare.runMapTyVars allowTC (toType False rt) st err of-                          Left e  -> Ex.throw e-                          Right s -> [ (rTyVar x, y) | (x, y) <- Bare.vmap s]-    (as,_,tyCons,rt) = bkUnivClass (ofType (Ghc.expandTypeSynonyms t0) :: SpecType)-    (_,ps,_ ,st) = bkUnivClass st0--    makeCls cs t = foldr (uncurry (rFun' (classRFInfo allowTC))) t cs-    err hsT lqT  = ErrMismatch (GM.fSrcSpan zz) (pprint xx)-                          (text "Plugged Init types new")-                          (pprint $ Ghc.expandTypeSynonyms t0)-                          (pprint $ toRSort st0)-                          (Just (hsT, lqT))-                          (Ghc.getSrcSpan xx)---plugHolesNew allowTC@True tce tyi a f t0 zz@(Loc l l' st0)-    = Loc l l'-    . mkArrow (zip (updateRTVar <$> as'') rs) ps [] (if length cs > length cs' then cs else cs')-    -- . makeCls cs' -    . goPlug tce tyi err f rt'-    $ st-  where-    rt'          = tx rt-    as''         = subRTVar su <$> as'-    (as',rs)     = unzip as-    -- cs'          = [ (F.dummySymbol, ct) | (c, t) <- cs, let ct = tx (RApp c t [] mempty) ]-    tx           = subts su-    su           = case Bare.runMapTyVars allowTC (toType False rt) st err of-                          Left e  -> Ex.throw e-                          Right s -> [ (rTyVar x, y) | (x, y) <- Bare.vmap s]-    (as,_,cs0,rt) = bkUnivClass' (ofType (Ghc.expandTypeSynonyms t0) :: SpecType)-    (_,ps,cs0' ,st) = bkUnivClass' st0-    cs  = [ (x, classRFInfo allowTC, t, r) | (x,t,r)<-cs0]-    cs' = [ (x, classRFInfo allowTC, t, r) | (x,t,r)<-cs0']--    err hsT lqT  = ErrMismatch (GM.fSrcSpan zz) (pprint a)-                          (text "Plugged Init types new")-                          (pprint $ Ghc.expandTypeSynonyms t0)-                          (pprint $ toRSort st0)-                          (Just (hsT, lqT))-                          (Ghc.getSrcSpan a)--subRTVar :: [(RTyVar, RTyVar)] -> SpecRTVar -> SpecRTVar-subRTVar su a@(RTVar v i) = Mb.maybe a (`RTVar` i) (lookup v su)--goPlug :: F.TCEmb Ghc.TyCon -> Bare.TyConMap -> (Doc -> Doc -> Error) -> (SpecType -> RReft -> RReft) -> SpecType -> SpecType-       -> SpecType-goPlug tce tyi err f = go-  where-    go st (RHole r) = (addHoles t') { rt_reft = f st r }-      where-        t'         = everywhere (mkT $ addRefs tce tyi) st-        addHoles   = everywhere (mkT addHole)-        -- NOTE: make sure we only add holes to RVar and RApp (NOT RFun)-        addHole :: SpecType -> SpecType-        addHole t@(RVar v _)       = RVar v (f t (uReft ("v", hole)))-        addHole t@(RApp c ts ps _) = RApp c ts ps (f t (uReft ("v", hole)))-        addHole t                  = t--    go (RVar _ _)       v@(RVar _ _)       = v-    go t'               (RImpF x ii i o r)   = RImpF x ii i  (go t' o)             r-    go (RFun _ _ i o _) (RFun x ii i' o' r)  = RFun x  ii   (go i i')   (go o o') r-    go (RAllT _ t _)    (RAllT a t' r)     = RAllT a    (go t t') r-    go (RAllT a t r)    t'                 = RAllT a    (go t t') r-    go t                (RAllP p t')       = RAllP p    (go t t')-    go t                (RAllE b a t')     = RAllE b a  (go t t')-    go t                (REx b x t')       = REx b x    (go t t')-    go t                (RRTy e r o t')    = RRTy e r o (go t t')-    go (RAppTy t1 t2 _) (RAppTy t1' t2' r) = RAppTy     (go t1 t1') (go t2 t2') r-    -- zipWithDefM: if ts and ts' have different length then the liquid and haskell types are different.-    -- keep different types for now, as a pretty error message will be created at Bare.Check-    go (RApp _ ts _ _)  (RApp c ts' p r)-      | length ts == length ts'            = RApp c     (Misc.zipWithDef go ts $ Bare.matchKindArgs ts ts') p r-    go hsT lqT                             = Ex.throw (err (F.pprint hsT) (F.pprint lqT))--    -- otherwise                          = Ex.throw err -    -- If we reach the default case, there's probably an error, but we defer-    -- throwing it as checkGhcSpec does a much better job of reporting the-    -- problem to the user.-    -- go st               _                 = st--addRefs :: F.TCEmb Ghc.TyCon -> TyConMap -> SpecType -> SpecType-addRefs tce tyi (RApp c ts _ r) = RApp c' ts ps r-  where-    RApp c' _ ps _ = addTyConInfo tce tyi (RApp c ts [] r)-addRefs _ _ t  = t--maybeTrue :: Ghc.NamedThing a => a -> ModName -> S.HashSet StableName -> SpecType -> RReft -> RReft-maybeTrue x target exports t r-  | not (isFunTy t) && (Ghc.isInternalName name || inTarget && notExported)-  = r-  | otherwise-  = killHoles r-  where-    inTarget    = Ghc.moduleName (Ghc.nameModule name) == getModName target-    name        = Ghc.getName x-    notExported = not (mkStableName (Ghc.getName x) `S.member` exports)---- killHoles r@(U (Reft (v, rs)) _ _) = r { ur_reft = Reft (v, filter (not . isHole) rs) }--killHoles :: RReft -> RReft-killHoles ur = ur { ur_reft = tx $ ur_reft ur }-  where-    tx r = {- traceFix ("killholes: r = " ++ showFix r) $ -} F.mapPredReft dropHoles r-    dropHoles    = F.pAnd . filter (not . isHole) . F.conjuncts
− src/Language/Haskell/Liquid/Bare/Resolve.hs 
@@ -1,1073 +0,0 @@--- | This module has the code that uses the GHC definitions to:---   1. MAKE a name-resolution environment,---   2. USE the environment to translate plain symbols into Var, TyCon, etc. --{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE LambdaCase            #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE TupleSections         #-}--module Language.Haskell.Liquid.Bare.Resolve-  ( -- * Creating the Environment-    makeEnv--    -- * Resolving symbols -  , ResolveSym (..)-  , Qualify (..)-  , Lookup-  , qualifyTop, qualifyTopDummy--  -- * Looking up names-  , maybeResolveSym-  , lookupGhcDataCon-  , lookupGhcDnTyCon-  , lookupGhcTyCon-  , lookupGhcVar-  , lookupGhcNamedVar--  -- * Checking if names exist-  , knownGhcVar-  , knownGhcTyCon-  , knownGhcDataCon-  , knownGhcType--  -- * Misc -  , srcVars-  , coSubRReft--  -- * Conversions from Bare-  , ofBareTypeE-  , ofBareType-  , ofBPVar--  -- * Post-processing types-  , txRefSort-  , errResolve--  -- * Fixing local variables-  , resolveLocalBinds-  , partitionLocalBinds-  ) where--import qualified Control.Exception                 as Ex-import qualified Data.List                         as L-import qualified Data.HashSet                      as S-import qualified Data.Maybe                        as Mb-import qualified Data.HashMap.Strict               as M-import qualified Data.Text                         as T-import qualified Text.PrettyPrint.HughesPJ         as PJ--import qualified Language.Fixpoint.Utils.Files         as F-import qualified Language.Fixpoint.Types               as F-import qualified Language.Fixpoint.Types.Visitor       as F-import qualified Language.Fixpoint.Misc                as Misc-import qualified Liquid.GHC.API       as Ghc-import qualified Liquid.GHC.Misc      as GM-import qualified Language.Haskell.Liquid.Misc          as Misc-import qualified Language.Haskell.Liquid.Types.RefType as RT-import qualified Language.Haskell.Liquid.Types.Errors  as Errors-import           Language.Haskell.Liquid.Types.Types-import           Language.Haskell.Liquid.Measure       (BareSpec)-import           Language.Haskell.Liquid.Types.Specs   hiding (BareSpec)-import           Language.Haskell.Liquid.Types.Visitors-import           Language.Haskell.Liquid.Bare.Types-import           Language.Haskell.Liquid.Bare.Misc-import           Language.Haskell.Liquid.WiredIn--myTracepp :: (F.PPrint a) => String -> a -> a-myTracepp = F.notracepp---- type Lookup a = Misc.Validate [Error] a-type Lookup a = Either [Error] a------------------------------------------------------------------------------------ | Creating an environment ---------------------------------------------------------------------------------makeEnv :: Config -> GhcSrc -> LogicMap -> [(ModName, BareSpec)] -> Env-makeEnv cfg src lmap specs = RE-  { reLMap      = lmap-  , reSyms      = syms-  , _reSubst    = makeVarSubst   src-  , _reTyThings = makeTyThingMap src-  , reQualImps  = _gsQualImps     src-  , reAllImps   = _gsAllImps      src-  , reLocalVars = makeLocalVars  src-  , reSrc       = src-  , reGlobSyms  = S.fromList     globalSyms-  , reCfg       = cfg-  }-  where-    globalSyms  = concatMap getGlobalSyms specs-    syms        = [ (F.symbol v, v) | v <- vars ]-    vars        = srcVars src--getGlobalSyms :: (ModName, BareSpec) -> [F.Symbol]-getGlobalSyms (_, spec)-  = filter (not . GM.isQualifiedSym)-       $ (mbName <$> measures  spec)-      ++ (mbName <$> cmeasures spec)-      ++ (mbName <$> imeasures spec)-  where-    mbName = F.val . msName--makeLocalVars :: GhcSrc -> LocalVars-makeLocalVars = localVarMap . localBinds . _giCbs---- TODO: rewrite using CoreVisitor-localBinds :: [Ghc.CoreBind] -> [Ghc.Var]-localBinds                    = concatMap (bgo S.empty)-  where-    add  x g                  = maybe g (`S.insert` g) (localKey x)-    adds b g                  = foldr add g (Ghc.bindersOf b)-    take' x g                 = maybe [] (\k -> [x | not (S.member k g)]) (localKey x)-    pgo g (x, e)              = take' x g ++ go (add x g) e-    bgo g (Ghc.NonRec x e)    = pgo g (x, e)-    bgo g (Ghc.Rec xes)       = concatMap (pgo g) xes-    go  g (Ghc.App e a)       = concatMap (go  g) [e, a]-    go  g (Ghc.Lam _ e)       = go g e-    go  g (Ghc.Let b e)       = bgo g b ++ go (adds b g) e-    go  g (Ghc.Tick _ e)      = go g e-    go  g (Ghc.Cast e _)      = go g e-    go  g (Ghc.Case e _ _ cs) = go g e ++ concatMap (go g . Misc.thd3) cs-    go  _ (Ghc.Var _)         = []-    go  _ _                   = []--localVarMap :: [Ghc.Var] -> LocalVars-localVarMap vs =-  Misc.group [ (x, (i, v)) | v <- vs-                           , let i = F.unPos (F.srcLine v)-                           , x <- Mb.maybeToList (localKey v)-             ]--localKey   :: Ghc.Var -> Maybe F.Symbol-localKey v-  | isLocal m = Just x-  | otherwise = Nothing-  where-    (m, x)    = splitModuleNameExact . GM.dropModuleUnique . F.symbol $ v--makeVarSubst :: GhcSrc -> F.Subst-makeVarSubst src = F.mkSubst unqualSyms-  where-    unqualSyms   = [ (x, mkVarExpr v)-                       | (x, mxs) <- M.toList (makeSymMap src)-                       , not (isWiredInName x)-                       , v <- Mb.maybeToList (okUnqualified me mxs)-                   ]-    me           = F.symbol (_giTargetMod src)---- | @okUnqualified mod mxs@ takes @mxs@ which is a list of modulenames-var ---   pairs all of which have the same unqualified symbol representation. ---   The function returns @Just v@ if ---   1. that list is a singleton i.e. there is a UNIQUE unqualified version, OR---   2. there is a version whose module equals @me@.--okUnqualified :: F.Symbol -> [(F.Symbol, a)] -> Maybe a-okUnqualified _ [(_, x)] = Just x-okUnqualified me mxs     = go mxs-  where-    go []                = Nothing-    go ((m,x) : rest)-      | me == m          = Just x-      | otherwise        = go rest---makeSymMap :: GhcSrc -> M.HashMap F.Symbol [(F.Symbol, Ghc.Var)]-makeSymMap src = Misc.group [ (sym, (m, x))-                                | x           <- srcVars src-                                , let (m, sym) = qualifiedSymbol x ]--makeTyThingMap :: GhcSrc -> TyThingMap-makeTyThingMap src =-  Misc.group [ (x, (m, t))  | t         <- srcThings src-                            , tSym      <- Mb.maybeToList (tyThingSymbol t)-                            , let (m, x) = qualifiedSymbol tSym-                            , not (isLocal m)-             ]--tyThingSymbol :: Ghc.TyThing -> Maybe F.Symbol-tyThingSymbol (Ghc.AnId     x) = Just (F.symbol x)-tyThingSymbol (Ghc.ATyCon   c) = Just (F.symbol c)-tyThingSymbol (Ghc.AConLike d) = conLikeSymbol d-tyThingSymbol _tt              = Nothing -- panic Nothing ("TODO: tyThingSymbol" ++ showPpr tt)---conLikeSymbol :: Ghc.ConLike -> Maybe F.Symbol-conLikeSymbol (Ghc.RealDataCon d) = Just (F.symbol d)-conLikeSymbol _z                   = Nothing -- panic Nothing ("TODO: conLikeSymbol -- " ++ showPpr z)-----isLocal :: F.Symbol -> Bool-isLocal = isEmptySymbol--qualifiedSymbol :: (F.Symbolic a) => a -> (F.Symbol, F.Symbol)-qualifiedSymbol = splitModuleNameExact . F.symbol--isEmptySymbol :: F.Symbol -> Bool-isEmptySymbol x = F.lengthSym x == 0--srcThings :: GhcSrc -> [Ghc.TyThing]-srcThings src = myTracepp "SRCTHINGS"-              $ Misc.hashNubWith F.showpp (_gsTyThings src ++ mySrcThings src)--mySrcThings :: GhcSrc -> [Ghc.TyThing]-mySrcThings src = [ Ghc.AnId   x | x <- vars ]-               ++ [ Ghc.ATyCon c | c <- tcs  ]-               ++ [ aDataCon   d | d <- dcs  ]-  where-    vars        = Misc.sortNub $ dataConVars dcs ++ srcVars  src-    dcs         = Misc.sortNub $ concatMap Ghc.tyConDataCons tcs-    tcs         = Misc.sortNub $ srcTyCons src-    aDataCon    = Ghc.AConLike . Ghc.RealDataCon--srcTyCons :: GhcSrc -> [Ghc.TyCon]-srcTyCons src = concat-  [ _gsTcs     src-  , _gsFiTcs   src-  , _gsPrimTcs src-  , srcVarTcs src-  ]--srcVarTcs :: GhcSrc -> [Ghc.TyCon]-srcVarTcs = varTyCons . srcVars--varTyCons :: [Ghc.Var] -> [Ghc.TyCon]-varTyCons = concatMap (typeTyCons . Ghc.dropForAlls . Ghc.varType)--typeTyCons :: Ghc.Type -> [Ghc.TyCon]-typeTyCons t = tops t ++ inners t-  where-    tops     = Mb.maybeToList . Ghc.tyConAppTyCon_maybe-    inners   = concatMap typeTyCons . snd . Ghc.splitAppTys---- | We prioritize the @Ghc.Var@ in @srcVars@ because @_giDefVars@ and @gsTyThings@ ---   have _different_ values for the same binder, with different types where the ---   type params are alpha-renamed. However, for absref, we need _the same_ ---   type parameters as used by GHC as those are used inside the lambdas and---   other bindings in the code. See also [NOTE: Plug-Holes-TyVars] and ---      tests-absref-pos-Papp00.hs --srcVars :: GhcSrc -> [Ghc.Var]-srcVars src = filter Ghc.isId .  fmap Misc.thd3 . Misc.fstByRank $ concat-  [ key "SRC-VAR-DEF" 0 <$> _giDefVars src-  , key "SRC-VAR-DER" 1 <$> S.toList (_giDerVars src)-  , key "SRC-VAR-IMP" 2 <$> _giImpVars src-  , key "SRC-VAR-USE" 3 <$> _giUseVars src-  , key "SRC-VAR-THN" 4 <$> [ x | Ghc.AnId x <- _gsTyThings src ]-  ]-  where-    key :: String -> Int -> Ghc.Var -> (Int, F.Symbol, Ghc.Var)-    key _ i x  = (i, F.symbol x, {- dump s -} x)-    _dump msg x = fst . myTracepp msg $ (x, RT.ofType (Ghc.expandTypeSynonyms (Ghc.varType x)) :: SpecType)--dataConVars :: [Ghc.DataCon] -> [Ghc.Var]-dataConVars dcs = (Ghc.dataConWorkId <$> dcs) ++ (Ghc.dataConWrapId <$> dcs)------------------------------------------------------------------------------------ | Qualify various names ---------------------------------------------------------------------------------qualifyTop :: (Qualify a) => Env -> ModName -> F.SourcePos -> a -> a-qualifyTop env name l = qualify env name l []--qualifyTopDummy :: (Qualify a) => Env -> ModName -> a -> a-qualifyTopDummy env name = qualifyTop env name dummySourcePos--dummySourcePos :: F.SourcePos-dummySourcePos = F.loc (F.dummyLoc ())--class Qualify a where-  qualify :: Env -> ModName -> F.SourcePos -> [F.Symbol] -> a -> a--instance Qualify TyConMap where-  qualify env name l bs tyi = tyi-    { tcmTyRTy = tx <$> tcmTyRTy tyi-    , tcmFIRTy = tx <$> tcmFIRTy tyi-    }-    where-      tx :: (Qualify a) => a -> a-      tx = qualify env name l bs--instance Qualify TyConP where-  qualify env name _ bs tcp = tcp { tcpSizeFun = qualify env name (tcpLoc tcp) bs <$> tcpSizeFun tcp }--instance Qualify SizeFun where-  qualify env name _ bs (SymSizeFun lx) = SymSizeFun (qualify env name (F.loc lx) bs lx)-  qualify _   _    _ _  sf              = sf--instance Qualify F.Equation where-  qualify _env _name _l _bs x = x -- TODO-REBARE --- REBARE: qualifyAxiomEq :: Bare.Env -> Var -> Subst -> AxiomEq -> AxiomEq--- REBARE: qualifyAxiomEq v su eq = subst su eq { eqName = symbol v}--instance Qualify F.Symbol where-  qualify env name l bs x = qualifySymbol env name l bs x--qualifySymbol :: Env -> ModName -> F.SourcePos -> [F.Symbol] -> F.Symbol -> F.Symbol-qualifySymbol env name l bs x-  | isSpl     = x-  | otherwise = case resolveLocSym env name "Symbol" (F.Loc l l x) of-                  Left _ -> x-                  Right v -> v-  where-    isSpl     = isSplSymbol env bs x--isSplSymbol :: Env -> [F.Symbol] -> F.Symbol -> Bool-isSplSymbol env bs x-  =  isWiredInName x-  || elem x bs-  || S.member x (reGlobSyms env)--instance (Qualify a) => Qualify (Located a) where-  qualify env name l bs = fmap (qualify env name l bs)--instance (Qualify a) => Qualify [a] where-  qualify env name l bs = fmap (qualify env name l bs)--instance (Qualify a) => Qualify (Maybe a) where-  qualify env name l bs = fmap (qualify env name l bs)--instance Qualify Body where-  qualify env name l bs (P   p) = P   (qualify env name l bs p)-  qualify env name l bs (E   e) = E   (qualify env name l bs e)-  qualify env name l bs (R x p) = R x (qualify env name l bs p)--instance Qualify TyConInfo where-  qualify env name l bs tci = tci { sizeFunction = qualify env name l bs <$> sizeFunction tci }--instance Qualify RTyCon where-  qualify env name l bs rtc = rtc { rtc_info = qualify env name l bs (rtc_info rtc) }--instance Qualify (Measure SpecType Ghc.DataCon) where-  qualify env name _ bs m = m -- FIXME substEnv env name bs $ -    { msName = qualify env name l bs     lname-    , msEqns = qualify env name l bs <$> msEqns m-    }-    where-      l      = F.loc  lname-      lname  = msName m---instance Qualify (Def ty ctor) where-  qualify env name l bs d = d-    { body  = qualify env name l (bs ++ bs') (body d) }-    where-      bs'   = fst <$> binds d--instance Qualify BareMeasure where-  qualify env name l bs m = m-    { msEqns = qualify env name l bs (msEqns m)-    }--instance Qualify DataCtor where-  qualify env name l bs c = c-    { dcTheta  = qualify env name l bs (dcTheta  c)-    , dcFields = qualify env name l bs (dcFields c)-    , dcResult = qualify env name l bs (dcResult c)-    }--instance Qualify DataDecl where-  qualify env name l bs d = d-    { tycDCons  = qualify env name l bs (tycDCons  d)-    , tycPropTy = qualify env name l bs (tycPropTy d)-    }--instance Qualify ModSpecs where-  qualify env name l bs = Misc.hashMapMapWithKey (\_ -> qualify env name l bs)--instance Qualify b => Qualify (a, b) where-  qualify env name l bs (x, y) = (x, qualify env name l bs y)--instance Qualify BareSpec where-  qualify = qualifyBareSpec--qualifyBareSpec :: Env -> ModName -> F.SourcePos -> [F.Symbol] -> BareSpec -> BareSpec-qualifyBareSpec env name l bs sp = sp-  { measures   = qualify env name l bs (measures   sp)-  , asmSigs    = qualify env name l bs (asmSigs    sp)-  , sigs       = qualify env name l bs (sigs       sp)-  , localSigs  = qualify env name l bs (localSigs  sp)-  , reflSigs   = qualify env name l bs (reflSigs   sp)-  , dataDecls  = qualify env name l bs (dataDecls  sp)-  , newtyDecls = qualify env name l bs (newtyDecls sp)-  , ialiases   = [ (f x, f y) | (x, y) <- ialiases sp ]-  }-  where f      = qualify env name l bs--instance Qualify a => Qualify (RTAlias F.Symbol a) where-  qualify env name l bs rtAlias-   = rtAlias { rtName  = qualify env name l bs (rtName rtAlias)-             , rtTArgs = qualify env name l bs (rtTArgs rtAlias)-             , rtVArgs = qualify env name l bs (rtVArgs rtAlias)-             , rtBody  = qualify env name l bs (rtBody rtAlias)-             }--instance Qualify F.Expr where-  qualify = substEnv--instance Qualify RReft where-  qualify = substEnv--instance Qualify F.Qualifier where-  qualify env name _ bs q = q { F.qBody = qualify env name (F.qPos q) bs' (F.qBody q) }-    where-      bs'                 = bs ++ (F.qpSym <$> F.qParams q)--substEnv :: (F.Subable a) => Env -> ModName -> F.SourcePos -> [F.Symbol] -> a -> a-substEnv env name l bs = F.substa (qualifySymbol env name l bs)--instance Qualify SpecType where-  qualify x1 x2 x3 x4 x5 = emapReft (substFreeEnv x1 x2 x3) x4 x5--instance Qualify BareType where-  qualify x1 x2 x3 x4 x5 = emapReft (substFreeEnv x1 x2 x3) x4 x5--substFreeEnv :: (F.Subable a) => Env -> ModName -> F.SourcePos -> [F.Symbol] -> a -> a-substFreeEnv env name l bs = F.substf (F.EVar . qualifySymbol env name l bs)----------------------------------------------------------------------------------lookupGhcNamedVar :: (Ghc.NamedThing a, F.Symbolic a) => Env -> ModName -> a -> Maybe Ghc.Var---------------------------------------------------------------------------------lookupGhcNamedVar env name z = maybeResolveSym  env name "Var" lx-  where-    lx                       = GM.namedLocSymbol z--lookupGhcVar :: Env -> ModName -> String -> LocSymbol -> Lookup Ghc.Var-lookupGhcVar env name kind lx = case resolveLocSym env name kind lx of-    Right v -> Mb.maybe (Right v) Right (lookupLocalVar env lx [v])-    Left  e -> Mb.maybe (Left  e) Right (lookupLocalVar env lx [])--  -- where-    -- err e   = Misc.errorP "error-lookupGhcVar" (F.showpp (e, F.loc lx, lx))-  --  err     = Ex.throw---- | @lookupLocalVar@ takes as input the list of "global" (top-level) vars ---   that also match the name @lx@; we then pick the "closest" definition. ---   See tests/names/LocalSpec.hs for a motivating example. --lookupLocalVar :: Env -> LocSymbol -> [Ghc.Var] -> Maybe Ghc.Var-lookupLocalVar env lx gvs = Misc.findNearest lxn kvs-  where-    _msg                  = "LOOKUP-LOCAL: " ++ F.showpp (F.val lx, lxn, kvs)-    kvs                   = gs ++ M.lookupDefault [] x (reLocalVars env)-    gs                    = [(F.unPos (F.srcLine v), v) | v <- gvs]-    lxn                   = F.unPos (F.srcLine lx)-    (_, x)                = unQualifySymbol (F.val lx)--lookupGhcDataCon :: Env -> ModName -> String -> LocSymbol -> Lookup Ghc.DataCon-lookupGhcDataCon = resolveLocSym -- strictResolveSym --lookupGhcTyCon :: Env -> ModName -> String -> LocSymbol -> Lookup Ghc.TyCon-lookupGhcTyCon env name k lx = myTracepp ("LOOKUP-TYCON: " ++ F.showpp (val lx))-                               $ {- strictResolveSym -} resolveLocSym env name k lx--lookupGhcDnTyCon :: Env -> ModName -> String -> DataName -> Lookup (Maybe Ghc.TyCon)--- lookupGhcDnTyCon = lookupGhcDnTyConE-lookupGhcDnTyCon env name msg = failMaybe env name . lookupGhcDnTyConE env name msg--lookupGhcDnTyConE :: Env -> ModName -> String -> DataName -> Lookup Ghc.TyCon-lookupGhcDnTyConE env name msg (DnCon  s)-  = lookupGhcDnCon env name msg s-lookupGhcDnTyConE env name msg (DnName s)-  = case resolveLocSym env name msg s of-      Right r -> Right r-      Left  e -> case lookupGhcDnCon  env name msg s of-                   Right r -> Right r-                   Left  _ -> Left  e---lookupGhcDnCon :: Env -> ModName -> String -> LocSymbol -> Lookup Ghc.TyCon-lookupGhcDnCon env name msg = fmap Ghc.dataConTyCon . resolveLocSym env name msg------------------------------------------------------------------------------------ | Checking existence of names ---------------------------------------------------------------------------------knownGhcType :: Env ->  ModName -> LocBareType -> Bool-knownGhcType env name (F.Loc l _ t) =-  case ofBareTypeE env name l Nothing t of-    Left e  -> myTracepp ("knownType: " ++ F.showpp (t, e)) False-    Right _ -> True----_rTypeTyCons :: (Ord c) => RType c tv r -> [c]-_rTypeTyCons        = Misc.sortNub . foldRType f []-  where-    f acc t@RApp {} = rt_tycon t : acc-    f acc _         = acc---- Aargh. Silly that each of these is the SAME code, only difference is the type.--knownGhcVar :: Env -> ModName -> LocSymbol -> Bool-knownGhcVar env name lx = Mb.isJust v-  where-    v :: Maybe Ghc.Var -- This annotation is crucial-    v = myTracepp ("knownGhcVar " ++ F.showpp lx)-      $ maybeResolveSym env name "known-var" lx--knownGhcTyCon :: Env -> ModName -> LocSymbol -> Bool-knownGhcTyCon env name lx = myTracepp  msg $ Mb.isJust v-  where-    msg = "knownGhcTyCon: "  ++ F.showpp lx-    v :: Maybe Ghc.TyCon -- This annotation is crucial-    v = maybeResolveSym env name "known-tycon" lx--knownGhcDataCon :: Env -> ModName -> LocSymbol -> Bool-knownGhcDataCon env name lx = Mb.isJust v-  where-    v :: Maybe Ghc.DataCon -- This annotation is crucial-    v = myTracepp ("knownGhcDataCon" ++ F.showpp lx)-      $ maybeResolveSym env name "known-datacon" lx------------------------------------------------------------------------------------ | Using the environment ---------------------------------------------------------------------------------class ResolveSym a where-  resolveLocSym :: Env -> ModName -> String -> LocSymbol -> Lookup a--instance ResolveSym Ghc.Var where-  resolveLocSym = resolveWith "variable" $ \case-                    Ghc.AnId x -> Just x-                    _          -> Nothing--instance ResolveSym Ghc.TyCon where-  resolveLocSym = resolveWith "type constructor" $ \case-                    Ghc.ATyCon x -> Just x-                    _            -> Nothing--instance ResolveSym Ghc.DataCon where-  resolveLocSym = resolveWith "data constructor" $ \case-                    Ghc.AConLike (Ghc.RealDataCon x) -> Just x-                    _                                -> Nothing---{- Note [ResolveSym for Symbol]--In case we need to resolve (aka qualify) a 'Symbol', we need to do some extra work. Generally speaking,-all these 'ResolveSym' instances perform a lookup into a 'Map' keyed by the 'Symbol' in-order to find a 'TyThing'. More specifically such map is known as the 'TyThingMap':--type TyThingMap = M.HashMap F.Symbol [(F.Symbol, Ghc.TyThing)]--This means, in practice, that we might have more than one result indexed by a given 'Symbol', and we need-to make a choice. The function 'rankedThings' does this. By default, we try to extract only /identifiers/-(i.e. a GHC's 'Id') out of an input 'TyThing', but in the case of test \"T1688\", something different happened.-By tracing calls to 'rankedThings' (called by 'resolveLocSym') there were cases where we had something like-this as our input TyThingMap:--[- 1 : T1688Lib : Data constructor T1688Lib.Lambda,- 1 : T1688Lib : Identifier T1688Lib.Lambda-]--Here name resolution worked because 'resolveLocSym' used the 'ResolveSym' instance defined for 'GHC.Var' that-looks only for 'Id's (contained inside 'Identifier's, and we had one). In some other cases, though,-'resolveLocSym' got called with only this:--[1 : T1688Lib : Data constructor T1688Lib.Lambda]--This would /not/ yield a match, despite the fact a \"Data constructor\" in principle /does/ contain an 'Id'-(it can be extracted out of a 'RealDataCon' by calling 'dataConWorkId'). In the case of test T1688, such-failed lookup caused the 'Symbol' to /not/ qualify, which in turn caused the symbols inside the type synonym:--ProofOf( Step (App (Lambda x e) v) e)--To not qualify. Finally, by the time 'expand' was called, the 'ProofOf' type alias would be replaced with-the correct refinement, but the unqualified 'Symbol's would now cause a test failure when refining the client-module.--It's not clear to me (Alfredo) why 'resolveLocSym' is called multiple times within the same module with-different inputs, but it definitely makes sense to allow for the special case here, at least for 'Symbol's.--Probably finding the /root cause/ would entail partially rewriting the name resoultion engine.---}---instance ResolveSym F.Symbol where-  resolveLocSym env name _ lx =-    -- If we can't resolve the input 'Symbol' from an 'Id', try again-    -- by grabbing the 'Id' of an 'AConLike', if any.-    -- See Note [ResolveSym for Symbol].-    let resolved =  resolveLocSym env name "Var" lx-                 <> resolveWith "variable" lookupVarInsideRealDataCon env name "Var" lx-    in case resolved of-      Left _               -> Right (val lx)-      Right (v :: Ghc.Var) -> Right (F.symbol v)-    where-      lookupVarInsideRealDataCon :: Ghc.TyThing -> Maybe Ghc.Var-      lookupVarInsideRealDataCon = \case-        Ghc.AConLike (Ghc.RealDataCon x) -> Just (Ghc.dataConWorkId x)-        _                                -> Nothing----resolveWith :: (PPrint a) => PJ.Doc -> (Ghc.TyThing -> Maybe a) -> Env -> ModName -> String -> LocSymbol-            -> Lookup a-resolveWith kind f env name str lx =-  -- case Mb.mapMaybe f things of -  case rankedThings f things of-    []  -> Left [errResolve kind str lx]-    [x] -> Right x-    xs  -> Left [ErrDupNames sp (pprint (F.val lx)) (pprint <$> xs)]-  where-    _xSym   = F.val lx-    sp      = GM.fSrcSpanSrcSpan (F.srcSpan lx)-    things  = myTracepp msg $ lookupTyThing env name lx-    msg     = "resolveWith: " ++ str ++ " " ++ F.showpp (val lx)---rankedThings :: (Misc.EqHash k) => (a -> Maybe b) -> [(k, a)] -> [b]-rankedThings f ias = case Misc.sortOn fst (Misc.groupList ibs) of-                       (_,ts):_ -> ts-                       []       -> []-  where-    ibs            = Mb.mapMaybe (\(k, x) -> (k,) <$> f x) ias------------------------------------------------------------------------------------ | @lookupTyThing@ is the central place where we lookup the @Env@ to find ---   any @Ghc.TyThing@ that match that name. The code is a bit hairy as we---   have various heuristics to approximiate how GHC resolves names. e.g. ---   see tests-names-pos-*.hs, esp. vector04.hs where we need the name `Vector` ---   to resolve to `Data.Vector.Vector` and not `Data.Vector.Generic.Base.Vector`... ---------------------------------------------------------------------------------lookupTyThing :: Env -> ModName -> LocSymbol -> [((Int, F.Symbol), Ghc.TyThing)]---------------------------------------------------------------------------------lookupTyThing env mdname lsym = [ (k, t) | (k, ts) <- ordMatches, t <- ts]--  where-    ordMatches             = Misc.sortOn fst (Misc.groupList matches)-    matches                = myTracepp ("matches-" ++ msg)-                             [ ((k, m), t) | (m, t) <- lookupThings env x-                                           , k      <- myTracepp msg $ mm nameSym m mds ]-    msg                    = "lookupTyThing: " ++ F.showpp (lsym, x, mds)-    (x, mds)               = symbolModules env (F.val lsym)-    nameSym                = F.symbol mdname-    allowExt               = allowExtResolution env lsym-    mm name m mods         = myTracepp ("matchMod: " ++ F.showpp (lsym, name, m, mods, allowExt)) $-                               matchMod env name m allowExt mods---- | [NOTE:External-Resolution] @allowExtResolution@ determines whether a @LocSymbol@ ---   can be resolved by a @TyThing@ that is _outside_ the module corresponding to @LocSymbol@. ---   We need to allow this, e.g. to resolve names like @Data.Set.Set@ with @Data.Set.Internal.Set@, ---   but should do so ONLY when the LocSymbol comes from a "hand-written" .spec file or ---   something from the LH prelude. Other names, e.g. from "machine-generated" .bspec files ---   should already be FULLY-qualified to to their actual definition (e.g. Data.Set.Internal.Set) ---   and so we should DISALLOW external-resolution in such cases.--allowExtResolution :: Env -> LocSymbol -> Bool-allowExtResolution env lx = case fileMb of-  Nothing   -> True-  Just f    -> myTracepp ("allowExt: " ++ show (f, tgtFile))-                 $ f == tgtFile || Misc.isIncludeFile incDir f || F.isExtFile F.Spec f-  where-    tgtFile = _giTarget (reSrc env)-    incDir  = _giIncDir (reSrc env)-    fileMb  = Errors.srcSpanFileMb (GM.fSrcSpan lx)--lookupThings :: Env -> F.Symbol -> [(F.Symbol, Ghc.TyThing)]-lookupThings env x = myTracepp ("lookupThings: " ++ F.showpp x)-                   $ Misc.fromFirstMaybes [] (get <$> [x, GM.stripParensSym x])-  where-    get z          = M.lookup z (_reTyThings env)--matchMod :: Env -> F.Symbol -> F.Symbol -> Bool -> Maybe [F.Symbol] -> [Int]-matchMod env tgtName defName allowExt = go-  where-    go Nothing               -- Score UNQUALIFIED names -     | defName == tgtName = [0]                       -- prioritize names defined in *this* module -     | otherwise          = [matchImp env defName 1]  -- prioritize directly imported modules over -                                                      -- names coming from elsewhere, with a --    go (Just ms)             -- Score QUALIFIED names-     |  isEmptySymbol defName-     && ms == [tgtName]   = [0]                       -- local variable, see tests-names-pos-local00.hs-     | ms == [defName]    = [1]-     | allowExt && isExt  = [matchImp env defName 2]  -- to allow matching re-exported names e.g. Data.Set.union for Data.Set.Internal.union-     | otherwise          = []-     where-       isExt              = any (`isParentModuleOf` defName) ms---- | Returns 'True' if the 'Symbol' given as a first argument represents a parent module for the second.------ >>> L.symbolic "Data.Text" `isParentModuleOf` L.symbolic "Data.Text.Internal"--- True------ Invariants:------ * The empty 'Symbol' is always considered the module prefix of the second,---   in compliance with 'isPrefixOfSym' (AND: why?)--- * If the parent \"hierarchy\" is smaller than the children's one, this is clearly not a parent module.-isParentModuleOf :: F.Symbol -> F.Symbol -> Bool-isParentModuleOf parentModule childModule-  | isEmptySymbol parentModule = True-  | otherwise                  =-    length parentHierarchy <= length childHierarchy && all (uncurry (==)) (zip parentHierarchy childHierarchy)-  where-    parentHierarchy :: [T.Text]-    parentHierarchy = T.splitOn "." . F.symbolText $ parentModule--    childHierarchy :: [T.Text]-    childHierarchy = T.splitOn "." . F.symbolText $ childModule---symbolModules :: Env -> F.Symbol -> (F.Symbol, Maybe [F.Symbol])-symbolModules env s = (x, glerb <$> modMb)-  where-    (modMb, x)      = unQualifySymbol s-    glerb m         = M.lookupDefault [m] m qImps-    qImps           = qiNames (reQualImps env)---- | @matchImp@ lets us prioritize @TyThing@ defined in directly imported modules over ---   those defined elsewhere. Specifically, in decreasing order of priority we have ---   TyThings that we:---   * DIRECTLY     imported WITHOUT qualification ---   * TRANSITIVELY imported (e.g. were re-exported by SOME imported module)---   * QUALIFIED    imported (so qualify the symbol to get this result!) --matchImp :: Env -> F.Symbol -> Int -> Int-matchImp env defName i-  | isUnqualImport = i-  | isQualImport   = i + 2-  | otherwise      = i + 1-  where-    isUnqualImport = S.member defName (reAllImps env) && not isQualImport-    isQualImport   = S.member defName (qiModules (reQualImps env))----- | `unQualifySymbol name sym` splits `sym` into a pair `(mod, rest)` where ---   `mod` is the name of the module, derived from `sym` if qualified.-unQualifySymbol :: F.Symbol -> (Maybe F.Symbol, F.Symbol)-unQualifySymbol sym-  | GM.isQualifiedSym sym = Misc.mapFst Just (splitModuleNameExact sym)-  | otherwise             = (Nothing, sym)--splitModuleNameExact :: F.Symbol -> (F.Symbol, F.Symbol)-splitModuleNameExact x' = myTracepp ("splitModuleNameExact for " ++ F.showpp x)-                          (GM.takeModuleNames x, GM.dropModuleNames x)-  where-    x = GM.stripParensSym x'--errResolve :: PJ.Doc -> String -> LocSymbol -> Error-errResolve k msg lx = ErrResolve (GM.fSrcSpan lx) k (F.pprint (F.val lx)) (PJ.text msg)---- -- | @strictResolve@ wraps the plain @resolve@ to throw an error --- --   if the name being searched for is unknown.--- strictResolveSym :: (ResolveSym a) => Env -> ModName -> String -> LocSymbol -> a --- strictResolveSym env name kind x = case resolveLocSym env name kind x of ---   Left  err -> Misc.errorP "error-strictResolveSym" (F.showpp err)---   Right val -> val ---- | @maybeResolve@ wraps the plain @resolve@ to return @Nothing@ ---   if the name being searched for is unknown.-maybeResolveSym :: (ResolveSym a) => Env -> ModName -> String -> LocSymbol -> Maybe a-maybeResolveSym env name kind x = case resolveLocSym env name kind x of-  Left  _   -> Nothing-  Right val -> Just val------------------------------------------------------------------------------------ | @ofBareType@ and @ofBareTypeE@ should be the _only_ @SpecType@ constructors---------------------------------------------------------------------------------ofBareType :: Env -> ModName -> F.SourcePos -> Maybe [PVar BSort] -> BareType -> SpecType-ofBareType env name l ps t = either fail' id (ofBareTypeE env name l ps t)-  where-    fail'                  = Ex.throw-    -- fail                   = Misc.errorP "error-ofBareType" . F.showpp --ofBareTypeE :: Env -> ModName -> F.SourcePos -> Maybe [PVar BSort] -> BareType -> Lookup SpecType-ofBareTypeE env name l ps t = ofBRType env name (resolveReft env name l ps t) l t--resolveReft :: Env -> ModName -> F.SourcePos -> Maybe [PVar BSort] -> BareType -> [F.Symbol] -> RReft -> RReft-resolveReft env name l ps t bs-        = qualify env name l bs-        . txParam l RT.subvUReft (RT.uPVar <$> πs) t-        . fixReftTyVars t       -- same as fixCoercions -  where-    πs  = Mb.fromMaybe tπs ps-    tπs = ty_preds (toRTypeRep t)--fixReftTyVars :: BareType -> RReft -> RReft-fixReftTyVars bt  = coSubRReft coSub-  where-    coSub         = M.fromList [ (F.symbol a, F.FObj (specTvSymbol a)) | a <- tvs ]-    tvs           = RT.allTyVars bt-    specTvSymbol  = F.symbol . RT.bareRTyVar--coSubRReft :: F.CoSub -> RReft -> RReft-coSubRReft su r = r { ur_reft = coSubReft su (ur_reft r) }--coSubReft :: F.CoSub -> F.Reft -> F.Reft-coSubReft su (F.Reft (x, e)) = F.Reft (x, F.applyCoSub su e)---ofBSort :: Env -> ModName -> F.SourcePos -> BSort -> RSort-ofBSort env name l t = either (Misc.errorP "error-ofBSort" . F.showpp) id (ofBSortE env name l t)--ofBSortE :: Env -> ModName -> F.SourcePos -> BSort -> Lookup RSort-ofBSortE env name l t = ofBRType env name (const id) l t--ofBPVar :: Env -> ModName -> F.SourcePos -> BPVar -> RPVar-ofBPVar env name l = fmap (ofBSort env name l)-----------------------------------------------------------------------------------txParam :: F.SourcePos -> ((UsedPVar -> UsedPVar) -> t) -> [UsedPVar] -> RType c tv r -> t-txParam l f πs t = f (txPvar l (predMap πs t))--txPvar :: F.SourcePos -> M.HashMap F.Symbol UsedPVar -> UsedPVar -> UsedPVar-txPvar l m π = π { pargs = args' }-  where-    args' | not (null (pargs π)) = zipWith (\(_,x ,_) (t,_,y) -> (t, x, y)) (pargs π') (pargs π)-          | otherwise            = pargs π'-    π'    = Mb.fromMaybe err $ M.lookup (pname π) m-    err   = uError $ ErrUnbPred sp (pprint π)-    sp    = GM.sourcePosSrcSpan l--predMap :: [UsedPVar] -> RType c tv r -> M.HashMap F.Symbol UsedPVar-predMap πs t = M.fromList [(pname π, π) | π <- πs ++ rtypePredBinds t]--rtypePredBinds :: RType c tv r -> [UsedPVar]-rtypePredBinds = map RT.uPVar . ty_preds . toRTypeRep-------------------------------------------------------------------------------------type Expandable r = ( PPrint r-                    , F.Reftable r-                    , SubsTy RTyVar (RType RTyCon RTyVar ()) r-                    , F.Reftable (RTProp RTyCon RTyVar r))--ofBRType :: (Expandable r) => Env -> ModName -> ([F.Symbol] -> r -> r) -> F.SourcePos -> BRType r-         -> Lookup (RRType r)-ofBRType env name f l = go []-  where-    goReft bs r             = return (f bs r)-    goRImpF bs x i t1 t2 r  = RImpF x i <$> (rebind x <$> go bs t1) <*> go (x:bs) t2 <*> goReft bs r-    goRFun  bs x i t1 t2 r  = RFun  x i{permitTC = Just (typeclass (getConfig env))} <$> (rebind x <$> go bs t1) <*> go (x:bs) t2 <*> goReft bs r-    rebind x t              = F.subst1 t (x, F.EVar $ rTypeValueVar t)-    go bs (RAppTy t1 t2 r)  = RAppTy <$> go bs t1 <*> go bs t2 <*> goReft bs r-    go bs (RApp tc ts rs r) = goRApp bs tc ts rs r-    go bs (RImpF x i t1 t2 r) = goRImpF bs x i t1 t2 r-    go bs (RFun  x i t1 t2 r) = goRFun  bs x i t1 t2 r-    go bs (RVar a r)        = RVar (RT.bareRTyVar a) <$> goReft bs r-    go bs (RAllT a t r)     = RAllT a' <$> go bs t <*> goReft bs r-      where a'              = dropTyVarInfo (mapTyVarValue RT.bareRTyVar a)-    go bs (RAllP a t)       = RAllP a' <$> go bs t-      where a'              = ofBPVar env name l a-    go bs (RAllE x t1 t2)   = RAllE x  <$> go bs t1    <*> go bs t2-    go bs (REx x t1 t2)     = REx   x  <$> go bs t1    <*> go (x:bs) t2-    go bs (RRTy xts r o t)  = RRTy  <$> xts' <*> goReft bs r <*> pure o <*> go bs t-      where xts'            = mapM (Misc.mapSndM (go bs)) xts-    go bs (RHole r)         = RHole    <$> goReft bs r-    go bs (RExprArg le)     = return    $ RExprArg (qualify env name l bs le)-    goRef bs (RProp ss (RHole r)) = rPropP <$> mapM goSyms ss <*> goReft bs r-    goRef bs (RProp ss t)         = RProp  <$> mapM goSyms ss <*> go bs t-    goSyms (x, t)                 = (x,) <$> ofBSortE env name l t-    goRApp bs tc ts rs r          = bareTCApp <$> goReft bs r <*> lc' <*> mapM (goRef bs) rs <*> mapM (go bs) ts-      where-        lc'                    = F.atLoc lc <$> matchTyCon env name lc (length ts)-        lc                     = btc_tc tc-    -- goRApp _ _ _ _             = impossible Nothing "goRApp failed through to final case"--{- -    -- TODO-REBARE: goRImpF bounds _ (RApp c ps' _ _) t _-    -- TODO-REBARE:  | Just bnd <- M.lookup (btc_tc c) bounds-    -- TODO-REBARE:   = do let (ts', ps) = splitAt (length $ tyvars bnd) ps'-    -- TODO-REBARE:        ts <- mapM go ts'-    -- TODO-REBARE:        makeBound bnd ts [x | RVar (BTV x) _ <- ps] <$> go t-    -- TODO-REBARE: goRFun bounds _ (RApp c ps' _ _) t _-    -- TODO-REBARE: | Just bnd <- M.lookup (btc_tc c) bounds-    -- TODO-REBARE: = do let (ts', ps) = splitAt (length $ tyvars bnd) ps'-    -- TODO-REBARE: ts <- mapM go ts'-    -- TODO-REBARE: makeBound bnd ts [x | RVar (BTV x) _ <- ps] <$> go t--  -- TODO-REBARE: ofBareRApp env name t@(F.Loc _ _ !(RApp tc ts _ r))-  -- TODO-REBARE: | Loc l _ c <- btc_tc tc-  -- TODO-REBARE: , Just rta <- M.lookup c aliases-  -- TODO-REBARE: = appRTAlias l rta ts =<< resolveReft r---}--matchTyCon :: Env -> ModName -> LocSymbol -> Int -> Lookup Ghc.TyCon-matchTyCon env name lc@(Loc _ _ c) arity-  | isList c && arity == 1  = Right Ghc.listTyCon-  | isTuple c               = Right tuplTc-  | otherwise               = resolveLocSym env name msg lc-  where-    msg                     = "matchTyCon: " ++ F.showpp c-    tuplTc                  = Ghc.tupleTyCon Ghc.Boxed arity---bareTCApp :: (Expandable r)-          => r-          -> Located Ghc.TyCon-          -> [RTProp RTyCon RTyVar r]-          -> [RType RTyCon RTyVar r]-          -> RType RTyCon RTyVar r-bareTCApp r (Loc l _ c) rs ts | Just rhs <- Ghc.synTyConRhs_maybe c-  = if GM.kindTCArity c < length ts-      then Ex.throw err -- error (F.showpp err)-      else tyApp (RT.subsTyVarsMeet su $ RT.ofType rhs) (drop nts ts) rs r-    where-       tvs = [ v | (v, b) <- zip (GM.tyConTyVarsDef c) (Ghc.tyConBinders c), GM.isAnonBinder b]-       su  = zipWith (\a t -> (RT.rTyVar a, toRSort t, t)) tvs ts-       nts = length tvs--       err :: Error-       err = ErrAliasApp (GM.sourcePosSrcSpan l) (pprint c) (Ghc.getSrcSpan c)-                         (PJ.hcat [ PJ.text "Expects"-                                  , pprint (GM.realTcArity c)-                                  , PJ.text "arguments, but is given"-                                  , pprint (length ts) ] )--- TODO expandTypeSynonyms here to-bareTCApp r (Loc _ _ c) rs ts | Ghc.isFamilyTyCon c && isTrivial t-  = expandRTypeSynonyms (t `RT.strengthen` r)-  where t = RT.rApp c ts rs mempty--bareTCApp r (Loc _ _ c) rs ts-  = RT.rApp c ts rs r---tyApp :: F.Reftable r => RType c tv r -> [RType c tv r] -> [RTProp c tv r] -> r-      -> RType c tv r-tyApp (RApp c ts rs r) ts' rs' r' = RApp c (ts ++ ts') (rs ++ rs') (r `F.meet` r')-tyApp t                []  []  r  = t `RT.strengthen` r-tyApp _                 _  _   _  = panic Nothing "Bare.Type.tyApp on invalid inputs"--expandRTypeSynonyms :: (Expandable r) => RRType r -> RRType r-expandRTypeSynonyms = RT.ofType . Ghc.expandTypeSynonyms . RT.toType False--{- -expandRTypeSynonyms :: (Expandable r) => RRType r -> RRType r-expandRTypeSynonyms t-  | rTypeHasHole t = t -  | otherwise      = expandRTypeSynonyms' t--rTypeHasHole :: RType c tv r -> Bool-rTypeHasHole = foldRType f False-  where -    f _ (RHole _) = True-    f b _         = b--}----------------------------------------------------------------------------------------------- | Is this the SAME as addTyConInfo? No. `txRefSort`--- (1) adds the _real_ sorts to RProp,--- (2) gathers _extra_ RProp at turns them into refinements,---     e.g. tests/pos/multi-pred-app-00.hs---------------------------------------------------------------------------------------------txRefSort :: TyConMap -> F.TCEmb Ghc.TyCon -> LocSpecType -> LocSpecType-txRefSort tyi tce t = F.atLoc t $ mapBot (addSymSort (GM.fSrcSpan t) tce tyi) (val t)--addSymSort :: Ghc.SrcSpan -> F.TCEmb Ghc.TyCon -> TyConMap -> SpecType -> SpecType-addSymSort sp tce tyi (RApp rc@RTyCon{} ts rs rr)-  = RApp rc ts (zipWith3 (addSymSortRef sp rc) pvs rargs [1..]) r2-  where-    (_, pvs)           = RT.appRTyCon tce tyi rc ts-    -- pvs             = rTyConPVs rc'-    (rargs, rrest)     = splitAt (length pvs) rs-    r2                 = L.foldl' go rr rrest-    go r (RProp _ (RHole r')) = r' `F.meet` r-    go r (RProp  _ t' )       = let r' = Mb.fromMaybe mempty (stripRTypeBase t') in r `F.meet` r'--addSymSort _ _ _ t-  = t--addSymSortRef :: (PPrint s) => Ghc.SrcSpan -> s -> RPVar -> SpecProp -> Int -> SpecProp-addSymSortRef sp rc p r i-  | isPropPV p-  = addSymSortRef' sp rc i p r-  | otherwise-  = panic Nothing "addSymSortRef: malformed ref application"--addSymSortRef' :: (PPrint s) => Ghc.SrcSpan -> s -> Int -> RPVar -> SpecProp -> SpecProp-addSymSortRef' _ _ _ p (RProp s (RVar v r)) | isDummy v-  = RProp xs t-    where-      t  = ofRSort (pvType p) `RT.strengthen` r-      xs = spliceArgs "addSymSortRef 1" s p--addSymSortRef' sp rc i p (RProp _ (RHole r@(MkUReft _ (Pr [up]))))-  | length xs == length ts-  = RProp xts (RHole r)-  | otherwise-  = -- Misc.errorP "ZONK" $ F.showpp (rc, pname up, i, length xs, length ts)-    uError $ ErrPartPred sp (pprint rc) (pprint $ pname up) i (length xs) (length ts)-    where-      xts = Misc.safeZipWithError "addSymSortRef'" xs ts-      xs  = Misc.snd3 <$> pargs up-      ts  = Misc.fst3 <$> pargs p--addSymSortRef' _ _ _ _ (RProp s (RHole r))-  = RProp s (RHole r)--addSymSortRef' _ _ _ p (RProp s t)-  = RProp xs t-    where-      xs = spliceArgs "addSymSortRef 2" s p--spliceArgs :: String  -> [(F.Symbol, b)] -> PVar t -> [(F.Symbol, t)]-spliceArgs msg syms p = go (fst <$> syms) (pargs p)-  where-    go []     []           = []-    go []     ((s,x,_):as) = (x, s):go [] as-    go (x:xs) ((s,_,_):as) = (x,s):go xs as-    go xs     []           = panic Nothing $ "spliceArgs: " ++ msg ++ "on XS=" ++ show xs-------------------------------------------------------------------------------------- RJ: formerly, `replaceLocalBinds` AFAICT--- | @resolveLocalBinds@ resolves that the "free" variables that appear in the ---   type-sigs for non-toplevel binders (that correspond to other locally bound)---   source variables that are visible at that at non-top-level scope. ---   e.g. tests-names-pos-local02.hs  -----------------------------------------------------------------------------------resolveLocalBinds :: Env -> [(Ghc.Var, LocBareType, Maybe [Located F.Expr])]-                  -> [(Ghc.Var, LocBareType, Maybe [Located F.Expr])]-----------------------------------------------------------------------------------resolveLocalBinds env xtes = [ (x,t,es) | (x, (t, es)) <- topTs ++ replace locTs ]-  where-    (locTs, topTs)         = partitionLocalBinds [ (x, (t, es)) | (x, t, es) <- xtes]-    replace                = M.toList . replaceSigs . M.fromList-    replaceSigs sigm       = coreVisitor replaceVisitor M.empty sigm cbs-    cbs                    = _giCbs (reSrc env)--replaceVisitor :: CoreVisitor SymMap SigMap-replaceVisitor = CoreVisitor-  { envF  = addBind-  , bindF = updSigMap-  , exprF = \_ m _ -> m-  }--addBind :: SymMap -> Ghc.Var -> SymMap-addBind env v = case localKey v of-  Just vx -> M.insert vx (F.symbol v) env-  Nothing -> env--updSigMap :: SymMap -> SigMap -> Ghc.Var -> SigMap-updSigMap env m v = case M.lookup v m of-  Nothing  -> m-  Just tes -> M.insert v (myTracepp ("UPD-LOCAL-SIG " ++ GM.showPpr v) $ renameLocalSig env tes) m--renameLocalSig :: SymMap -> (LocBareType, Maybe [Located F.Expr])-               -> (LocBareType, Maybe [Located F.Expr])-renameLocalSig env (t, es) = (F.substf tSub t, F.substf esSub es)-  where-    tSub                   = F.EVar . qualifySymMap env-    esSub                  = tSub `F.substfExcept` xs-    xs                     = ty_binds (toRTypeRep (F.val t))--qualifySymMap :: SymMap -> F.Symbol -> F.Symbol-qualifySymMap env x = M.lookupDefault x x env--type SigMap = M.HashMap Ghc.Var  (LocBareType, Maybe [Located F.Expr])-type SymMap = M.HashMap F.Symbol F.Symbol------------------------------------------------------------------------------------partitionLocalBinds :: [(Ghc.Var, a)] -> ([(Ghc.Var, a)], [(Ghc.Var, a)])-----------------------------------------------------------------------------------partitionLocalBinds = L.partition (Mb.isJust . localKey . fst)
− src/Language/Haskell/Liquid/Bare/Slice.hs 
@@ -1,174 +0,0 @@-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE DerivingVia                #-}----- | This module has a function that computes the "slice" i.e. subset of the `Ms.BareSpec` that ---   we actually need to verify a given target module, so that LH doesn't choke trying to resolve ---   names that are not actually relevant and hence, not in the GHC Environment.---   See LH issue 1773 for more details.--- ---   Specifically, this module has datatypes and code for building a Specification Dependency Graph ---   whose vertices are 'names' that need to be resolve, and edges are 'dependencies'.---module Language.Haskell.Liquid.Bare.Slice (sliceSpecs) where---- import qualified Language.Fixpoint.Types as F--- import qualified Data.HashMap.Strict as M-import           Language.Haskell.Liquid.Types--- import Data.Hashable-import qualified Language.Haskell.Liquid.Measure as Ms--- import qualified Data.HashSet as S------------------------------------------------------------------------------------- | Top-level "slicing" function---------------------------------------------------------------------------------sliceSpecs :: GhcSrc -> Ms.BareSpec -> [(ModName, Ms.BareSpec)] -> -        [(ModName, Ms.BareSpec)]-sliceSpecs _tgtSrc _tgtSpec specs = specs --{- ------------------------------------------------------------------------------------ | The different kinds of names we have to resolve---------------------------------------------------------------------------------data Label-  = Sign  -- ^ identifier signature-  | Func  -- ^ measure or reflect-  | DCon  -- ^ data constructor-  | TCon  -- ^ type constructor-  deriving (Eq, Ord, Enum, Show)------------------------------------------------------------------------------------ | A dependency 'Node' is a pair of a name @LocSymbol@ and @Label@---------------------------------------------------------------------------------data Node = MkNode-  { nodeName  :: F.Symbol-  , nodeLabel :: Label-  }-  deriving (Eq, Ord)--instance Hashable Label where-  hashWithSalt s = hashWithSalt s . fromEnum -instance Hashable Node where -  hashWithSalt s MkNode {..} = hashWithSalt s (nodeName, nodeLabel) --newtype DepGraph = MkDepGraph -  { dGraph :: M.HashMap Node [Node] -  }------------------------------------------------------------------------------------ | A way to combine graphs of multiple modules----------------------------------------------------------------------------------instance Semigroup DepGraph where-  x <> y = MkDepGraph { dGraph = M.unionWith (++) (dGraph x) (dGraph y) }--instance Monoid DepGraph where-  mempty = MkDepGraph mempty------------------------------------------------------------------------------------ | A function to build the dependencies for each module----------------------------------------------------------------------------------mkRoots :: GhcSrc -> S.HashSet Node-mkRoots = undefined------------------------------------------------------------------------------------ | A function to build the dependencies for each module----------------------------------------------------------------------------------class Graph a where-  mkGraph :: a -> DepGraph--instance Graph [Ms.BareSpec] where-  mkGraph specs = mconcat [ mkGraph sp | sp <- specs]--instance Graph Ms.BareSpec where-  mkGraph sp = mconcat -    [ undefined -- FIXME -- mkGraph (expSigs sp)-    ]------------------------------------------------------------------------------------ | 'reachable roots g' returns the list of Node transitively reachable from roots---------------------------------------------------------------------------------reachable :: S.HashSet Node -> DepGraph -> S.HashSet Node-reachable roots g = undefined -- _TODO------------------------------------------------------------------------------------ | Extract the dependencies ----------------------------------------------------------------------------------class Deps a where-  deps :: a -> [Node]--instance Deps BareType where-  deps = error "TBD:deps:bareType"--instance Deps DataDecl where-  deps = error "TBD:deps:datadecl"--instance Deps DataCtor where -  deps = error "TBD:deps:datactor"---}----{- -             -- = [ (n, slice nodes sp) | (n, sp) <- specs ]-  -- where-    -- tgtGraph = mkGraph tgtSpec-    -- impGraph = mkGraph (snd <$> specs)-    -- roots    = mkRoots tgtSrc -- S.fromList . M.keys . dGraph $ tgtGraph-    -- nodes    = reachable roots (tgtGraph <> impGraph)--class Sliceable a where-  slice :: S.HashSet Node -> a -> a--instance Sliceable Ms.BareSpec where -  slice nodes sp = sp---}------{- -These are the fields we have to worry about--unsafeFromLiftedSpec :: LiftedSpec -> Spec LocBareType F.LocSymbol-unsafeFromLiftedSpec a = Spec-  { -  --->>> , asmSigs    = S.toList . liftedAsmSigs $ a-  --->>> , sigs       = S.toList . liftedSigs $ a-  --->>> , invariants = S.toList . liftedInvariants $ a-  --->>> , dataDecls  = S.toList . liftedDataDecls $ a-  --->>> , newtyDecls = S.toList . liftedNewtyDecls $ a-    -  , measures   = S.toList . liftedMeasures $ a-  , impSigs    = S.toList . liftedImpSigs $ a-  , expSigs    = S.toList . liftedExpSigs $ a-  , ialiases   = S.toList . liftedIaliases $ a-  , imports    = S.toList . liftedImports $ a-  , aliases    = S.toList . liftedAliases $ a-  , ealiases   = S.toList . liftedEaliases $ a-  , embeds     = liftedEmbeds a-  , qualifiers = S.toList . liftedQualifiers $ a-  , decr       = S.toList . liftedDecr $ a-  , lvars      = liftedLvars a-  , autois     = liftedAutois a-  , autosize   = liftedAutosize a-  , cmeasures  = S.toList . liftedCmeasures $ a-  , imeasures  = S.toList . liftedImeasures $ a-  , classes    = S.toList . liftedClasses $ a-  , claws      = S.toList . liftedClaws $ a-  , rinstance  = S.toList . liftedRinstance $ a-  , ilaws      = S.toList . liftedIlaws $ a-  , dvariance  = S.toList . liftedDvariance $ a-  , bounds     = liftedBounds a-  , defs       = liftedDefs a-  , axeqs      = S.toList . liftedAxeqs $ a-  }--}--
− src/Language/Haskell/Liquid/Bare/ToBare.hs 
@@ -1,90 +0,0 @@--- | This module contains functions that convert things---   to their `Bare` versions, e.g. SpecType -> BareType etc.--module Language.Haskell.Liquid.Bare.ToBare-  ( -- * Types-    specToBare--    -- * Measures-  , measureToBare-  )-  where--import           Data.Bifunctor--import           Language.Fixpoint.Misc (mapSnd)-import qualified Language.Fixpoint.Types as F-import           Liquid.GHC.Misc-import           Liquid.GHC.API-import           Language.Haskell.Liquid.Types--- import           Language.Haskell.Liquid.Measure--- import           Language.Haskell.Liquid.Types.RefType-----------------------------------------------------------------------------------specToBare :: SpecType -> BareType----------------------------------------------------------------------------------specToBare = txRType specToBareTC specToBareTV---- specToBare t = F.tracepp ("specToBare t2 = " ++ F.showpp t2)  t1-  -- where-    -- t1       = bareOfType . toType $ t-    -- t2       = _specToBare           t------------------------------------------------------------------------------------measureToBare :: SpecMeasure -> BareMeasure----------------------------------------------------------------------------------measureToBare = bimap (fmap specToBare) dataConToBare--dataConToBare :: DataCon -> LocSymbol-dataConToBare d = dropModuleNames . F.symbol <$> locNamedThing d-  where-    _msg  = "dataConToBare dc = " ++ show d ++ " v = " ++ show v ++ " vx = " ++ show vx-    v     = dataConWorkId d-    vx    = F.symbol v--specToBareTC :: RTyCon -> BTyCon-specToBareTC = tyConBTyCon . rtc_tc--specToBareTV :: RTyVar -> BTyVar-specToBareTV (RTV α) = BTV (F.symbol α)--txRType :: (c1 -> c2) -> (tv1 -> tv2) -> RType c1 tv1 r -> RType c2 tv2 r-txRType cF vF = go-  where-    -- go :: RType c1 tv1 r -> RType c2 tv2 r-    go (RVar α r)          = RVar  (vF α) r-    go (RAllT α t r)       = RAllT (goRTV α) (go t) r-    go (RAllP π t)         = RAllP (goPV  π) (go t)-    go (RImpF x i t t' r)  = RImpF  x i      (go t) (go t') r-    go (RFun x i t t' r)   = RFun   x i      (go t) (go t') r-    go (RAllE x t t')      = RAllE x         (go t) (go t')-    go (REx x t t')        = REx   x         (go t) (go t')-    go (RAppTy t t' r)     = RAppTy          (go t) (go t') r-    go (RApp c ts rs r)    = RApp  (cF c)    (go <$> ts) (goRTP <$> rs) r-    go (RRTy xts r o t)    = RRTy  (mapSnd go <$> xts) r o (go t)-    go (RExprArg e)        = RExprArg e-    go (RHole r)           = RHole r--    -- go' :: RType c1 tv1 () -> RType c2 tv2 ()-    go' = txRType cF vF--    -- goRTP :: RTProp c1 tv1 r -> RTProp c2 tv2 r-    goRTP (RProp s (RHole r)) = RProp (mapSnd go' <$> s) (RHole r)-    goRTP (RProp s t)         = RProp (mapSnd go' <$> s) (go t)--    -- goRTV :: RTVU c1 tv1 -> RTVU c2 tv2-    goRTV = txRTV cF vF--    -- goPV :: PVU c1 tv1 -> PVU c2 tv2-    goPV = txPV cF vF--txRTV :: (c1 -> c2) -> (tv1 -> tv2) -> RTVU c1 tv1 -> RTVU c2 tv2-txRTV cF vF (RTVar α z) = RTVar (vF α) (txRType cF vF <$> z)--txPV :: (c1 -> c2) -> (tv1 -> tv2) -> PVU c1 tv1 -> PVU c2 tv2-txPV cF vF (PV sym k y txes) = PV sym k' y txes'-  where-    txes'                  = [ (tx t, x, e) | (t, x, e) <- txes]-    k'                     = tx <$> k-    tx                     = txRType cF vF
− src/Language/Haskell/Liquid/Bare/Typeclass.hs 
@@ -1,428 +0,0 @@-{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE FlexibleContexts          #-}--module Language.Haskell.Liquid.Bare.Typeclass-  ( compileClasses-  , elaborateClassDcp-  , makeClassAuxTypes-  -- , makeClassSelectorSigs-  )-where---- TODO: Handle typeclasses with a single method (newtype)--import           Control.Monad                  ( forM, guard )-import qualified Data.List                     as L-import qualified Data.HashSet                  as S-import           Data.Hashable                  ()-import qualified Data.Maybe                    as Mb-import qualified Language.Fixpoint.Types       as F-import qualified Language.Fixpoint.Misc        as Misc-import           Optics-import           Language.Haskell.Liquid.Bare.Elaborate-import qualified Liquid.GHC.Misc-                                               as GM-import qualified Liquid.GHC.API-                                               as Ghc-import qualified Language.Haskell.Liquid.Misc  as Misc-import           Language.Haskell.Liquid.Types-import qualified Language.Haskell.Liquid.Types.RefType-                                               as RT-import qualified Language.Haskell.Liquid.Bare.Types-                                               as Bare-import qualified Language.Haskell.Liquid.Bare.Resolve-                                               as Bare-import qualified Language.Haskell.Liquid.Measure-                                               as Ms--- import           Language.Haskell.Liquid.Types.Types-import qualified Data.HashMap.Strict           as M----compileClasses-  :: GhcSrc-  -> Bare.Env-  -> (ModName, Ms.BareSpec)-  -> [(ModName, Ms.BareSpec)]-  -> (Ms.BareSpec, [(Ghc.ClsInst, [Ghc.Var])])-compileClasses src env (name, spec) rest =-  (spec { sigs = sigsNew } <> clsSpec, instmethods)- where-  clsSpec = mempty-    { dataDecls = clsDecls-    , reflects  = F.notracepp "reflects " $ S.fromList-                    (  fmap-                        ( fmap GM.dropModuleNames-                        . GM.namedLocSymbol-                        . Ghc.instanceDFunId-                        . fst-                        )-                        instClss-                    ++ methods-                    )-    }-  clsDecls                = makeClassDataDecl (M.toList refinedMethods)-      -- class methods-  (refinedMethods, sigsNew) = foldr grabClassSig (mempty, mempty) (sigs spec)-  grabClassSig-    :: (F.LocSymbol, ty)-    -> (M.HashMap Ghc.Class [(Ghc.Id, ty)], [(F.LocSymbol, ty)])-    -> (M.HashMap Ghc.Class [(Ghc.Id, ty)], [(F.LocSymbol, ty)])-  grabClassSig sigPair@(lsym, ref) (refs, sigs') = case clsOp of-    Nothing         -> (refs, sigPair : sigs')-    Just (cls, sig) -> (M.alter (merge sig) cls refs, sigs')-   where-    clsOp = do-      var <- Bare.maybeResolveSym env name "grabClassSig" lsym-      cls <- Ghc.isClassOpId_maybe var-      pure (cls, (var, ref))-    merge sig v = case v of-      Nothing -> Just [sig]-      Just vs -> Just (sig : vs)-  methods = [ GM.namedLocSymbol x | (_, xs) <- instmethods, x <- xs ]-      -- instance methods--  mkSymbol x-    | Ghc.isDictonaryId x = F.mappendSym "$" (F.dropSym 2 $ GM.simplesymbol x)-    | otherwise           = F.dropSym 2 $ GM.simplesymbol x--  instmethods :: [(Ghc.ClsInst, [Ghc.Var])]-  instmethods =-    [ (inst, ms)-    | (inst, cls) <- instClss-    , let selIds = GM.dropModuleNames . F.symbol <$> Ghc.classAllSelIds cls-    , (_, e) <- Mb.maybeToList-      (GM.findVarDefMethod-        (GM.dropModuleNames . F.symbol $ Ghc.instanceDFunId inst)-        (_giCbs src)-      )-    , let ms = filter (\x -> GM.isMethod x && elem (mkSymbol x) selIds)-                      (freeVars mempty e)-    ]-  instClss :: [(Ghc.ClsInst, Ghc.Class)]-  instClss =-    [ (inst, cls)-    | inst <- mconcat . Mb.maybeToList . _gsCls $ src-    , Ghc.moduleName (Ghc.nameModule (Ghc.getName inst)) == getModName name-    , let cls = Ghc.is_cls inst-    , cls `elem` refinedClasses-    ]-  refinedClasses :: [Ghc.Class]-  refinedClasses =-    Mb.mapMaybe resolveClassMaybe clsDecls-      ++ concatMap (Mb.mapMaybe resolveClassMaybe . dataDecls . snd) rest-  resolveClassMaybe :: DataDecl -> Maybe Ghc.Class-  resolveClassMaybe d =-    Bare.maybeResolveSym env-                         name-                         "resolveClassMaybe"-                         (dataNameSymbol . tycName $ d)-      >>= Ghc.tyConClass_maybe----- a list of class with user defined refinements-makeClassDataDecl :: [(Ghc.Class, [(Ghc.Id, LocBareType)])] -> [DataDecl]-makeClassDataDecl = fmap (uncurry classDeclToDataDecl)---- TODO: I should have the knowledge to construct DataConP manually than--- following the rather unwieldy pipeline: Resolved -> Unresolved -> Resolved.--- maybe this should be fixed right after the GHC API refactoring?-classDeclToDataDecl :: Ghc.Class -> [(Ghc.Id, LocBareType)] -> DataDecl-classDeclToDataDecl cls refinedIds = DataDecl-  { tycName   = DnName (F.symbol <$> GM.locNamedThing cls)-  , tycTyVars = tyVars-  , tycPVars  = []-  , tycDCons  = Just [dctor]-  , tycSrcPos = F.loc . GM.locNamedThing $ cls-  , tycSFun   = Nothing-  , tycPropTy = Nothing-  , tycKind   = DataUser-  }- where-  dctor = F.notracepp "classDeclToDataDecl" DataCtor { dcName   = F.dummyLoc $ F.symbol classDc-    -- YL: same as class tyvars??-    -- Ans: it's been working so far so probably yes-                   , dcTyVars = tyVars-    -- YL: what is theta?-    -- Ans: where class constraints should go yet remain unused-    -- maybe should factor this out?-                   , dcTheta  = []-                   , dcFields = fields-                   , dcResult = Nothing-                   }--  tyVars = F.symbol <$> Ghc.classTyVars cls--  fields = fmap attachRef classIds-  attachRef sid-    | Just ref <- L.lookup sid refinedIds-    = (F.symbol sid, RT.subts tyVarSubst (F.val ref))-    | otherwise-    = (F.symbol sid, RT.bareOfType . dropTheta . Ghc.varType $ sid)--  tyVarSubst = [ (GM.dropModuleUnique v, v) | v <- tyVars ]--  -- FIXME: dropTheta should not be needed as long as we -  -- handle classes and ordinary data types separately-  -- Might be helpful if we add an additional field for-  -- typeclasses-  dropTheta :: Ghc.Type -> Ghc.Type-  dropTheta = Misc.thd3 . Ghc.tcSplitMethodTy--  classIds  = Ghc.classAllSelIds cls-  classDc   = Ghc.classDataCon cls---- | 'elaborateClassDcp' behaves differently from other datacon---    functions. Each method type contains the full forall quantifiers---    instead of having them chopped off-elaborateClassDcp-  :: (Ghc.CoreExpr -> F.Expr)-  -> (Ghc.CoreExpr -> Ghc.TcRn Ghc.CoreExpr)-  -> DataConP-  -> Ghc.TcRn (DataConP, DataConP)-elaborateClassDcp coreToLg simplifier dcp = do-  t' <- flip (zipWith addCoherenceOblig) prefts-    <$> forM fts (elaborateSpecType coreToLg simplifier)-  let ts' = elaborateMethod (F.symbol dc) (S.fromList xs) <$> t'-  pure-    ( dcp { dcpTyArgs = zip xs (stripPred <$> ts') }-    , dcp { dcpTyArgs = fmap (\(x, t) -> (x, strengthenTy x t)) (zip xs t') }-    )- where-  addCoherenceOblig :: SpecType -> Maybe RReft -> SpecType-  addCoherenceOblig t Nothing  = t-  addCoherenceOblig t (Just r) = fromRTypeRep rrep-    { ty_res = res `RT.strengthen` r-    }-   where-    rrep = toRTypeRep t-    res  = ty_res rrep-  prefts =-    L.reverse-      .  take (length fts)-      $  fmap (Just . flip MkUReft mempty . mconcat) preftss-      ++ repeat Nothing-  preftss = (fmap . fmap) (uncurry (GM.coherenceObligToRef recsel))-                          (GM.buildCoherenceOblig cls)--  -- ugly, should have passed cls as an argument-  cls      = Mb.fromJust $ Ghc.tyConClass_maybe (Ghc.dataConTyCon dc)-  recsel   = F.symbol ("lq$recsel" :: String)-  resTy    = dcpTyRes dcp-  dc       = dcpCon dcp-  tvars    = (\x -> (makeRTVar x, mempty)) <$> dcpFreeTyVars dcp-      -- check if the names are qualified-  (xs, ts) = unzip (dcpTyArgs dcp)-  fts      = fullTy <$> ts-      -- turns forall a b. (a -> b) -> f a -> f b into-      -- forall f. Functor f => forall a b. (a -> b) -> f a -> f b-  stripPred :: SpecType -> SpecType-  stripPred = Misc.fourth4 . bkUnivClass-  fullTy :: SpecType -> SpecType-  fullTy t = mkArrow-    tvars-    []-    []-    [ ( recsel{- F.symbol dc-}-      , classRFInfo True-      , resTy-      , mempty-      )-    ]-    t-  -- YL: is this redundant if we already have strengthenClassSel?-  strengthenTy :: F.Symbol -> SpecType -> SpecType-  strengthenTy x t = mkUnivs tvs pvs (RFun z i clas (t' `RT.strengthen` mt) r)-   where-    (tvs, pvs, RFun z i clas t' r) = bkUniv t-    vv = rTypeValueVar t'-    mt = RT.uReft (vv, F.PAtom F.Eq (F.EVar vv) (F.EApp (F.EVar x) (F.EVar z)))---elaborateMethod :: F.Symbol -> S.HashSet F.Symbol -> SpecType -> SpecType-elaborateMethod dc methods st = mapExprReft-  (\_ -> substClassOpBinding tcbindSym dc methods)-  st- where-  tcbindSym = grabtcbind st-  grabtcbind :: SpecType -> F.Symbol-  grabtcbind t =-    F.notracepp "grabtcbind"-      $ case Misc.fst4 . Misc.snd3 . bkArrow . Misc.thd3 . bkUniv $ t of-          tcbind : _ -> tcbind-          []         -> impossible-            Nothing-            (  "elaborateMethod: inserted dictionary binder disappeared:"-            ++ F.showpp t-            )----- Before: Functor.fmap ($p1Applicative $dFunctor)--- After: Funcctor.fmap ($p1Applicative##GHC.Base.Applicative)-substClassOpBinding-  :: F.Symbol -> F.Symbol -> S.HashSet F.Symbol -> F.Expr -> F.Expr-substClassOpBinding tcbind dc methods = go- where-  go :: F.Expr -> F.Expr-  go (F.EApp e0 e1)-    | F.EVar x <- e0, F.EVar y <- e1, y == tcbind, S.member x methods = F.EVar-      (x `F.suffixSymbol` dc)-    | otherwise = F.EApp (go e0) (go e1)-  go (F.ENeg e          ) = F.ENeg (go e)-  go (F.EBin bop e0 e1  ) = F.EBin bop (go e0) (go e1)-  go (F.EIte e0  e1 e2  ) = F.EIte (go e0) (go e1) (go e2)-  go (F.ECst e0     s   ) = F.ECst (go e0) s-  go (F.ELam (x, t) body) = F.ELam (x, t) (go body)-  go (F.PAnd es         ) = F.PAnd (go <$> es)-  go (F.POr  es         ) = F.POr (go <$> es)-  go (F.PNot e          ) = F.PNot (go e)-  go (F.PImp e0 e1      ) = F.PImp (go e0) (go e1)-  go (F.PIff e0 e1      ) = F.PIff (go e0) (go e1)-  go (F.PAtom brel e0 e1) = F.PAtom brel (go e0) (go e1)-  -- a catch-all binding is not a good idea-  go e                    = e---renameTvs :: (F.Symbolic tv, F.PPrint tv) => (tv -> tv) -> RType c tv r -> RType c tv r-renameTvs rename t-  | RVar tv r <- t-  = RVar (rename tv) r-  | RFun b i tin tout r <- t-  = RFun b i (renameTvs rename tin) (renameTvs rename tout) r-  | RImpF b i tin tout r <- t-  = RImpF b i (renameTvs rename tin) (renameTvs rename tout) r-  | RAllT (RTVar tv info) tres r <- t-  = RAllT (RTVar (rename tv) info) (renameTvs rename tres) r-  | RAllP b tres <- t-  = RAllP (renameTvs rename <$> b) (renameTvs rename tres)-  | RApp tc ts tps r <- t-  -- TODO: handle rtprop properly-  = RApp tc (renameTvs rename <$> ts) tps r-  | RAllE b allarg ty <- t-  = RAllE b (renameTvs rename allarg) (renameTvs rename ty)-  | REx b exarg ty <- t-  = REx b   (renameTvs rename exarg) (renameTvs rename ty)-  | RExprArg _ <- t-  = t-  | RAppTy arg res r <- t-  = RAppTy (renameTvs rename arg) (renameTvs rename res) r-  | RRTy env r obl ty <- t-  = RRTy (over (each % _2) (renameTvs rename) env) r obl (renameTvs rename ty)-  | RHole _ <- t-  = t---makeClassAuxTypes ::-     (SpecType -> Ghc.TcRn SpecType)-  -> [F.Located DataConP]-  -> [(Ghc.ClsInst, [Ghc.Var])]-  -> Ghc.TcRn [(Ghc.Var, LocSpecType)]-makeClassAuxTypes elab dcps xs = Misc.concatMapM (makeClassAuxTypesOne elab) dcpInstMethods-  where-    dcpInstMethods = do-      dcp <- dcps-      (inst, methods) <- xs-      let dc = dcpCon . F.val $ dcp-              -- YL: only works for non-newtype class-          dc' = Ghc.classDataCon $ Ghc.is_cls inst-      guard $ dc == dc'-      pure (dcp, inst, methods)--makeClassAuxTypesOne ::-     (SpecType -> Ghc.TcRn SpecType)-  -> (F.Located DataConP, Ghc.ClsInst, [Ghc.Var])-  -> Ghc.TcRn [(Ghc.Var, LocSpecType)]-makeClassAuxTypesOne elab (ldcp, inst, methods) =-  forM methods $ \method -> do-    let (headlessSig, preft) =-          case L.lookup (mkSymbol method) yts' of-            Nothing ->-              impossible Nothing ("makeClassAuxTypesOne : unreachable?" ++ F.showpp (mkSymbol method) ++ " " ++ F.showpp yts)-            Just sig -> sig-        -- dict binder will never be changed because we optimized PAnd[]-        -- lq0 lq1 ...-            -- -        ptys    = [(F.vv (Just i), classRFInfo True, pty, mempty) | (i,pty) <- zip [0,1..] isPredSpecTys]-        fullSig =-          mkArrow-            (zip isRTvs (repeat mempty))-            []-            []-            ptys .-          subst (zip clsTvs isSpecTys) $-          headlessSig-    elaboratedSig  <- flip addCoherenceOblig preft <$> elab fullSig--    let retSig =  mapExprReft (\_ -> substAuxMethod dfunSym methodsSet) (F.notracepp ("elaborated" ++ GM.showPpr method) elaboratedSig)-    let tysub  = F.notracepp "tysub" $ M.fromList $ zip (F.notracepp "newtype-vars" $ allTyVars' (F.notracepp "new-type" retSig)) (F.notracepp "ghc-type-vars" (allTyVars' ((F.notracepp "ghc-type" $ ofType (Ghc.varType method)) :: SpecType)))-        cosub  = M.fromList [ (F.symbol a, F.fObj (GM.namedLocSymbol b)) |  (a,RTV b) <- M.toList tysub]-        tysubf x = F.notracepp ("cosub:" ++ F.showpp cosub) $ tysub ^. at x % non x-        subbedTy = mapReft (Bare.coSubRReft cosub) (renameTvs tysubf retSig)-    -- need to make the variable names consistent-    pure (method, F.dummyLoc (F.notracepp ("vars:" ++ F.showpp (F.symbol <$> allTyVars' subbedTy)) subbedTy))--  -- "is" is used as a shorthand for instance, following the convention of the Ghc api-  where-    -- recsel = F.symbol ("lq$recsel" :: String)-    (_,predTys,_,_) = Ghc.instanceSig inst-    dfunApped = F.mkEApp dfunSymL [F.eVar $ F.vv (Just i) | (i,_) <- zip [0,1..] predTys]-    prefts  = L.reverse . take (length yts) $ fmap (F.notracepp "prefts" . Just . flip MkUReft mempty . mconcat) preftss ++ repeat Nothing-    preftss = F.notracepp "preftss" $ (fmap.fmap) (uncurry (GM.coherenceObligToRefE dfunApped)) (GM.buildCoherenceOblig cls)-    yts' = zip (fst <$> yts) (zip (snd <$> yts) prefts)-    cls = Mb.fromJust . Ghc.tyConClass_maybe $ Ghc.dataConTyCon (dcpCon dcp)-    addCoherenceOblig  :: SpecType -> Maybe RReft -> SpecType-    addCoherenceOblig t Nothing = t-    addCoherenceOblig t (Just r) = F.notracepp "SCSel" . fromRTypeRep $ rrep {ty_res = res `strengthen` r}-      where rrep = toRTypeRep t-            res  = ty_res rrep    -- (Monoid.mappend -> $cmappend##Int, ...)-    -- core rewriting mark2: do the same thing except they don't have to be symbols-    -- YL: poorly written. use a comprehension instead of assuming -    methodsSet = F.notracepp "methodSet" $ M.fromList (zip (F.symbol <$> clsMethods) (F.symbol <$> methods))-    -- core rewriting mark1: dfunId-    -- ()-    dfunSymL = GM.namedLocSymbol $ Ghc.instanceDFunId inst-    dfunSym = F.val dfunSymL-    (isTvs, isPredTys, _, isTys) = Ghc.instanceSig inst-    isSpecTys = ofType <$> isTys-    isPredSpecTys = ofType <$> isPredTys-    isRTvs = makeRTVar . rTyVar <$> isTvs-    dcp = F.val ldcp-    -- Monoid.mappend, ...-    clsMethods = filter (\x -> GM.dropModuleNames (F.symbol x) `elem` fmap mkSymbol methods) $-      Ghc.classAllSelIds (Ghc.is_cls inst)-    yts = [(GM.dropModuleNames y, t) | (y, t) <- dcpTyArgs dcp]-    mkSymbol x-      | -- F.notracepp ("isDictonaryId:" ++ GM.showPpr x) $-        Ghc.isDictonaryId x = F.mappendSym "$" (F.dropSym 2 $ GM.simplesymbol x)-      | otherwise = F.dropSym 2 $ GM.simplesymbol x-        -- res = dcpTyRes dcp-    clsTvs = dcpFreeTyVars dcp-        -- copy/pasted from Bare/Class.hs-    subst [] t = t-    subst ((a, ta):su) t = subsTyVarMeet' (a, ta) (subst su t)--substAuxMethod :: F.Symbol -> M.HashMap F.Symbol F.Symbol -> F.Expr -> F.Expr-substAuxMethod dfun methods = F.notracepp "substAuxMethod" . go-  where go :: F.Expr -> F.Expr-        go (F.EApp e0 e1)-          | F.EVar x <- F.notracepp "e0" e0-          , (F.EVar dfun_mb, args)  <- F.splitEApp e1-          , dfun_mb == dfun-          , Just method <- M.lookup x methods-              -- Before: Functor.fmap ($p1Applicative $dFunctor)-              -- After: Funcctor.fmap ($p1Applicative##GHC.Base.Applicative)-           = F.eApps (F.EVar method) args-          | otherwise-          = F.EApp (go e0) (go e1)-        go (F.ENeg e) = F.ENeg (go e)-        go (F.EBin bop e0 e1) = F.EBin bop (go e0) (go e1)-        go (F.EIte e0 e1 e2) = F.EIte (go e0) (go e1) (go e2)-        go (F.ECst e0 s) = F.ECst (go e0) s-        go (F.ELam (x, t) body) = F.ELam (x, t) (go body)-        go (F.PAnd es) = F.PAnd (go <$> es)-        go (F.POr es) = F.POr (go <$> es)-        go (F.PNot e) = F.PNot (go e)-        go (F.PImp e0 e1) = F.PImp (go e0) (go e1)-        go (F.PIff e0 e1) = F.PIff (go e0) (go e1)-        go (F.PAtom brel e0 e1) = F.PAtom brel (go e0) (go e1)-        go e = F.notracepp "LEAF" e
− src/Language/Haskell/Liquid/Bare/Types.hs 
@@ -1,160 +0,0 @@--- | This module has the code that uses the GHC definitions to:---   1. MAKE a name-resolution environment,---   2. USE the environment to translate plain symbols into Var, TyCon, etc. --module Language.Haskell.Liquid.Bare.Types -  ( -- * Name resolution environment -    Env (..)-  , TyThingMap -  , ModSpecs-  , LocalVars --    -- * Tycon and Datacon processing environment-  , TycEnv (..) -  , DataConMap-  , RT.TyConMap--    -- * Signature processing environment -  , SigEnv (..)--    -- * Measure related environment -  , MeasEnv (..)--    -- * Misc -  , PlugTV (..)-  , plugSrc-  , varRSort -  , varSortedReft-  , failMaybe-  ) where --import qualified Text.PrettyPrint.HughesPJ             as PJ -import qualified Data.HashSet                          as S-import qualified Data.HashMap.Strict                   as M-import qualified Language.Fixpoint.Types               as F -import qualified Language.Haskell.Liquid.Measure       as Ms-import qualified Language.Haskell.Liquid.Types.RefType as RT -import           Language.Haskell.Liquid.Types.Types-import           Language.Haskell.Liquid.Types.Specs   hiding (BareSpec)-import           Liquid.GHC.API       as Ghc hiding (Located, Env)-import           Liquid.GHC.Types     (StableName)---type ModSpecs = M.HashMap ModName Ms.BareSpec------------------------------------------------------------------------------------ | See [NOTE: Plug-Holes-TyVars] for a rationale for @PlugTV@ ----------------------------------------------------------------------------------data PlugTV v -  = HsTV v  -- ^ Use tyvars from GHC specification (in the `v`) -  | LqTV v  -- ^ Use tyvars from Liquid specification-  | GenTV   -- ^ Generalize ty-vars -  | RawTV   -- ^ Do NOT generalize ty-vars (e.g. for type-aliases)-  deriving (Show)---instance (Show v, F.PPrint v) => F.PPrint (PlugTV v) where -  pprintTidy _ = PJ.text . show -   -plugSrc ::  PlugTV v -> Maybe v -plugSrc (HsTV v) = Just v -plugSrc (LqTV v) = Just v -plugSrc _        = Nothing------------------------------------------------------------------------------------ | Name resolution environment ---------------------------------------------------------------------------------data Env = RE -  { reLMap      :: !LogicMap-  , reSyms      :: ![(F.Symbol, Ghc.Var)]    -- ^ see "syms" in old makeGhcSpec'-  , _reSubst    :: !F.Subst                  -- ^ see "su"   in old makeGhcSpec'-  , _reTyThings :: !TyThingMap -  , reCfg       :: !Config-  , reQualImps  :: !QImports                 -- ^ qualified imports-  , reAllImps   :: !(S.HashSet F.Symbol)     -- ^ all imported modules-  , reLocalVars :: !LocalVars                -- ^ lines at which local variables are defined.-  , reGlobSyms  :: !(S.HashSet F.Symbol)     -- ^ global symbols, typically unlifted measures like 'len', 'fromJust'-  , reSrc       :: !GhcSrc                   -- ^ all source info-  }--instance HasConfig Env where -  getConfig = reCfg ---- | @LocalVars@ is a map from names to lists of pairs of @Ghc.Var@ and ---   the lines at which they were defined. -type LocalVars = M.HashMap F.Symbol [(Int, Ghc.Var)]------------------------------------------------------------------------------------ | A @TyThingMap@ is used to resolve symbols into GHC @TyThing@ and, ---   from there into Var, TyCon, DataCon, etc.---------------------------------------------------------------------------------type TyThingMap = M.HashMap F.Symbol [(F.Symbol, Ghc.TyThing)]------------------------------------------------------------------------------------ | A @SigEnv@ contains the needed to process type signatures ---------------------------------------------------------------------------------data SigEnv = SigEnv -  { sigEmbs       :: !(F.TCEmb Ghc.TyCon) -  , sigTyRTyMap   :: !RT.TyConMap -  , sigExports    :: !(S.HashSet StableName)-  , sigRTEnv      :: !BareRTEnv-  }------------------------------------------------------------------------------------ | A @TycEnv@ contains the information needed to process Type- and Data- Constructors ---------------------------------------------------------------------------------data TycEnv = TycEnv -  { tcTyCons      :: ![TyConP]-  , tcDataCons    :: ![DataConP]-  , tcSelMeasures :: ![Measure SpecType Ghc.DataCon]-  , tcSelVars     :: ![(Ghc.Var, LocSpecType)]-  , tcTyConMap    :: !RT.TyConMap -  , tcAdts        :: ![F.DataDecl]-  , tcDataConMap  :: !DataConMap -  , tcEmbs        :: !(F.TCEmb Ghc.TyCon)-  , tcName        :: !ModName-  }--type DataConMap = M.HashMap (F.Symbol, Int) F.Symbol------------------------------------------------------------------------------------ | Intermediate representation for Measure information ----------------------------------------------------------------------------------- REBARE: used to be output of makeGhcSpecCHOP2-data MeasEnv = MeasEnv -  { meMeasureSpec :: !(MSpec SpecType Ghc.DataCon)          -  , meClassSyms   :: ![(F.Symbol, Located (RRType F.Reft))] -  , meSyms        :: ![(F.Symbol, Located (RRType F.Reft))]-  , meDataCons    :: ![(Ghc.Var,  LocSpecType)]           -  , meClasses     :: ![DataConP]                           -  , meMethods     :: ![(ModName, Ghc.Var, LocSpecType)]  -  , meCLaws       :: ![(Ghc.Class, [(ModName, Ghc.Var, LocSpecType)])]  -  }--instance Semigroup MeasEnv where-  (<>) = error "FIXME:1773"-instance Monoid MeasEnv where-  mempty = error "FIXME:1773"------------------------------------------------------------------------------------ | Converting @Var@ to @Sort@---------------------------------------------------------------------------------varSortedReft :: F.TCEmb Ghc.TyCon -> Ghc.Var -> F.SortedReft -varSortedReft emb = RT.rTypeSortedReft emb . varRSort --varRSort  :: Ghc.Var -> RSort-varRSort  = RT.ofType . Ghc.varType------------------------------------------------------------------------------------ | Handling failed resolution ---------------------------------------------------------------------------------failMaybe :: Env -> ModName -> Either e r -> Either e (Maybe r)-failMaybe env name res = case res of -  Right r -> Right (Just r) -  Left  e -> if isTargetModName env name -              then Left e-              else Right Nothing --isTargetModName :: Env -> ModName -> Bool -isTargetModName env name = name == _giTargetMod (reSrc env)
− src/Language/Haskell/Liquid/Cabal.hs 
@@ -1,21 +0,0 @@-{- | This module provides a drop-in replacement for Cabal's 'defaultMain', to be used inside 'Setup.hs'-     modules of packages that wants to use the \"dev mode\". For more information, visit the documentation,-     especially the \"Developers' guide\".--}--{-# LANGUAGE LambdaCase #-}-module Language.Haskell.Liquid.Cabal (liquidHaskellMain) where--import Distribution.Simple-import System.Environment--liquidHaskellMain :: IO ()-liquidHaskellMain = do-  mbDevMode <- lookupEnv "LIQUID_DEV_MODE"-  defaultMainWithHooks (devModeHooks mbDevMode)--devModeHooks :: Maybe String -> UserHooks-devModeHooks = \case-  Nothing               -> simpleUserHooks-  Just x | x == "false" -> simpleUserHooks-  Just _                -> simpleUserHooks { buildHook = \_ _ _ _ -> return () }
− src/Language/Haskell/Liquid/Constraint/Constraint.hs 
@@ -1,58 +0,0 @@-{-# LANGUAGE FlexibleInstances    #-}---- TODO: what exactly is the purpose of this module? What do these functions do?--module Language.Haskell.Liquid.Constraint.Constraint (-  constraintToLogic-, addConstraints-) where--import Prelude hiding (error)-import Data.Maybe-import Language.Haskell.Liquid.Types-import Language.Haskell.Liquid.Constraint.Types-import Language.Haskell.Liquid.Constraint.Env-import Language.Fixpoint.Types-----------------------------------------------------------------------------------addConstraints :: CGEnv -> [(Symbol, SpecType)] -> CGEnv----------------------------------------------------------------------------------addConstraints γ t = γ {lcs = mappend (t2c t) (lcs γ)}-  where-    t2c z          = LC [z]-----------------------------------------------------------------------------------constraintToLogic :: REnv -> LConstraint -> Expr----------------------------------------------------------------------------------constraintToLogic γ (LC ts) = pAnd (constraintToLogicOne γ <$> ts)---- RJ: The code below is atrocious. Please fix it!-constraintToLogicOne :: (Reftable r) => REnv -> [(Symbol, RRType r)] -> Expr-constraintToLogicOne γ binds-  = pAnd [subConstraintToLogicOne-          (zip xs xts)-          (last xs,-          (last (fst <$> xts), r))-          | xts <- xss]-  where-   symRts   = init binds-   (xs, ts) = unzip symRts-   r        = snd $ last binds-   xss      = combinations ((\t -> [(x, t) | x <- localBindsOfType t γ]) <$> ts)--subConstraintToLogicOne :: (Foldable t, Reftable r, Reftable r1)-                        => t (Symbol, (Symbol, RType t1 t2 r))-                        -> (Symbol, (Symbol, RType t3 t4 r1)) -> Expr-subConstraintToLogicOne xts (sym', (sym, rt)) = PImp (pAnd rs) r-  where-        (rs , symExprs) = foldl go ([], []) xts-        ([r], _ ) = go ([], symExprs) (sym', (sym, rt))-        go (acc, su) (x', (x, t)) = let (Reft(v, p)) = toReft (fromMaybe mempty (stripRTypeBase t))-                                        su'          = (x', EVar x):(v, EVar x) : su-                                    in-                                     (subst (mkSubst su') p : acc, su')--combinations :: [[a]] -> [[a]]-combinations []           = [[]]-combinations ([]:_)       = []-combinations ((y:ys):yss) = [y:xs | xs <- combinations yss] ++ combinations (ys:yss)
− src/Language/Haskell/Liquid/Constraint/Env.hs 
@@ -1,288 +0,0 @@-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE MultiParamTypeClasses     #-}-{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE ImplicitParams            #-}-{-# LANGUAGE PartialTypeSignatures     #-}---- | This module defines the representation for Environments needed---   during constraint generation.--module Language.Haskell.Liquid.Constraint.Env (--  -- * Insert-    (+++=)-  -- , (++=)-  , (+=)-  , extendEnvWithVV-  , addBinders-  , addSEnv-  , addEEnv-  , (-=)-  , globalize--  -- * Construction-  , fromListREnv-  , toListREnv-  , insertREnv -- TODO: remove this ASAP--  -- * Query-  , localBindsOfType-  , lookupREnv-  , (?=)--  -- * Pruning refinements (TODO: move!)- , rTypeSortedReft'--  -- * Extend CGEnv- , setLocation, setBind, setRecs, setTRec--  -- * Lookup CGEnv- , getLocation--) where----- import Name (getSrcSpan)-import Prelude hiding (error)--- import Outputable--- import FastString (fsLit)-import Control.Monad.State---- import           GHC.Err.Located hiding (error)-import           GHC.Stack--import           Control.Arrow           (first)-import           Data.Maybe              -- (fromMaybe)-import qualified Data.List               as L-import qualified Data.HashSet            as S-import qualified Data.HashMap.Strict     as M-import qualified Language.Fixpoint.Types as F---import           Language.Fixpoint.SortCheck (pruneUnsortedReft)----import           Liquid.GHC.API hiding (panic)-import           Language.Haskell.Liquid.Types.RefType-import qualified Liquid.GHC.SpanStack as Sp-import           Language.Haskell.Liquid.Types            hiding (binds, Loc, loc, freeTyVars, Def)-import           Language.Haskell.Liquid.Constraint.Types-import           Language.Haskell.Liquid.Constraint.Fresh ()-import           Language.Haskell.Liquid.Transforms.RefSplit-import qualified Language.Haskell.Liquid.UX.CTags       as Tg---- import Debug.Trace (trace)------------------------------------------------------------------------------------ | Refinement Type Environments ----------------------------------------------------------------------------------------------------------------------------------- updREnvLocal :: REnv -> (_ -> _) -> REnv-updREnvLocal :: REnv-             -> (M.HashMap F.Symbol SpecType -> M.HashMap F.Symbol SpecType)-             -> REnv-updREnvLocal rE f      = rE { reLocal = f (reLocal rE) }---- RJ: REnv-Split-Bug?-filterREnv :: (SpecType -> Bool) -> REnv -> REnv-filterREnv f rE        = rE `updREnvLocal` M.filter f--fromListREnv :: [(F.Symbol, SpecType)] -> [(F.Symbol, SpecType)] -> REnv-fromListREnv gXts lXts = REnv-  { reGlobal = M.fromList gXts-  , reLocal  = M.fromList lXts-  }---- RJ: REnv-Split-Bug?-deleteREnv :: F.Symbol -> REnv -> REnv-deleteREnv x rE = rE `updREnvLocal` M.delete x--insertREnv :: F.Symbol -> SpecType -> REnv -> REnv-insertREnv x y rE = {- trace ("insertREnv: " ++ show x) $ -} rE `updREnvLocal` M.insert x y--lookupREnv :: F.Symbol -> REnv -> Maybe SpecType-lookupREnv x rE = msum $ M.lookup x <$> renvMaps rE--memberREnv :: F.Symbol -> REnv -> Bool-memberREnv x rE = or   $ M.member x <$> renvMaps rE--globalREnv :: REnv -> REnv-globalREnv (REnv gM lM) = REnv gM' M.empty-  where-    gM'  = M.unionWith (\_ t -> t) gM lM--renvMaps :: REnv -> [M.HashMap F.Symbol SpecType]-renvMaps rE = [reLocal rE, reGlobal rE]-----------------------------------------------------------------------------------localBindsOfType :: RRType r  -> REnv -> [F.Symbol]----------------------------------------------------------------------------------localBindsOfType tx γ = fst <$> localsREnv (filterREnv ((== toRSort tx) . toRSort) γ)---- RJ: REnv-Split-Bug?-localsREnv :: REnv -> [(F.Symbol, SpecType)]-localsREnv = M.toList . reLocal--globalsREnv :: REnv -> [(F.Symbol, SpecType)]-globalsREnv = M.toList . reGlobal--toListREnv :: REnv -> [(F.Symbol, SpecType)]-toListREnv re = globalsREnv re ++ localsREnv re-----------------------------------------------------------------------------------extendEnvWithVV :: CGEnv -> SpecType -> CG CGEnv----------------------------------------------------------------------------------extendEnvWithVV γ t-  | F.isNontrivialVV vv && not (vv `memberREnv` renv γ)-  = γ += ("extVV", vv, t)-  | otherwise-  = return γ-  where-    vv = rTypeValueVar t--addBinders :: CGEnv -> F.Symbol -> [(F.Symbol, SpecType)] -> CG CGEnv-addBinders γ0 x' cbs   = foldM (++=) (γ0 -= x') [("addBinders", x, t) | (x, t) <- cbs]--addBind :: SrcSpan -> F.Symbol -> F.SortedReft -> CG ((F.Symbol, F.Sort), F.BindId)-addBind l x r = do-  st          <- get-  let (i, bs') = F.insertBindEnv x r (Ci l Nothing Nothing) (binds st)-  put          $ st { binds = bs' } { bindSpans = M.insert i l (bindSpans st) }-  return ((x, F.sr_sort r), {- traceShow ("addBind: " ++ showpp x) -} i)--addClassBind :: CGEnv -> SrcSpan -> SpecType -> CG [((F.Symbol, F.Sort), F.BindId)]-addClassBind γ l = mapM (uncurry (addBind l)) . classBinds (emb γ)--{- see tests/pos/polyfun for why you need everything in fixenv -}-addCGEnv :: (SpecType -> SpecType) -> CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv-addCGEnv tx γ (eMsg, x, REx y tyy tyx) = do-  y' <- fresh-  γ' <- addCGEnv tx γ (eMsg, y', tyy)-  addCGEnv tx γ' (eMsg, x, tyx `F.subst1` (y, F.EVar y'))--addCGEnv tx γ (eMsg, sym, RAllE yy tyy tyx)-  = addCGEnv tx γ (eMsg, sym, t)-  where-    xs            = localBindsOfType tyy (renv γ)-    t             = L.foldl' F.meet ttrue [ tyx' `F.subst1` (yy, F.EVar x) | x <- xs]-    (tyx', ttrue) = splitXRelatedRefs yy tyx--addCGEnv tx γ (_, x, t') = do-  idx   <- fresh-  -- allowHOBinders <- allowHO <$> get-  let t  = tx $ normalize idx t'-  let l  = getLocation γ-  let γ' = γ { renv = insertREnv x t (renv γ) }-  tem   <- getTemplates-  is    <- (:) <$> addBind l x (rTypeSortedReft' γ' tem t) <*> addClassBind γ' l t-  return $ γ' { fenv = insertsFEnv (fenv γ) is }--rTypeSortedReft' :: (PPrint r, F.Reftable r, SubsTy RTyVar RSort r, F.Reftable (RTProp RTyCon RTyVar r))-    => CGEnv -> F.Templates -> RRType r -> F.SortedReft-rTypeSortedReft' γ t-  = pruneUnsortedReft (feEnv $ fenv γ) t . f-   where-   f         = rTypeSortedReft (emb γ)---normalize :: Integer -> SpecType -> SpecType-normalize idx = normalizeVV idx . normalizePds--normalizeVV :: Integer -> SpecType -> SpecType-normalizeVV idx t@RApp{}-  | not (F.isNontrivialVV (rTypeValueVar t))-  = shiftVV t (F.vv $ Just idx)--normalizeVV _ t-  = t-----------------------------------------------------------------------------------(+=) :: CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv----------------------------------------------------------------------------------γ += (eMsg, x, r)-  | x == F.dummySymbol-  = return γ-  -- // | x `memberREnv` (renv γ)-  -- // = _dupBindErr x γ-  | otherwise-  =  γ ++= (eMsg, x, r)--_dupBindError :: String -> F.Symbol -> CGEnv -> SpecType -> a-_dupBindError eMsg x γ r = panic Nothing s-  where-    s = unlines [ eMsg ++ " Duplicate binding for " ++ F.symbolString x-                , "   New: " ++ showpp r-                , "   Old: " ++ showpp (x `lookupREnv` renv γ) ]-----------------------------------------------------------------------------------globalize :: CGEnv -> CGEnv----------------------------------------------------------------------------------globalize γ = γ {renv = globalREnv (renv γ)}-----------------------------------------------------------------------------------(++=) :: CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv----------------------------------------------------------------------------------(++=) γ (eMsg, x, t)-  = addCGEnv (addRTyConInv (M.unionWith mappend (invs γ) (ial γ))) γ (eMsg, x, t)-----------------------------------------------------------------------------------addSEnv :: CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv----------------------------------------------------------------------------------addSEnv γ = addCGEnv (addRTyConInv (invs γ)) γ--addEEnv :: CGEnv -> (F.Symbol, SpecType) -> CG CGEnv-addEEnv γ (x,t')= do-  idx   <- fresh-  -- allowHOBinders <- allowHO <$> get-  let t  = addRTyConInv (invs γ) $ normalize idx t'-  let l  = getLocation γ-  let γ' = γ { renv = insertREnv x t (renv γ) }-  tem   <- getTemplates-  is    <- (:) <$> addBind l x (rTypeSortedReft' γ' tem t) <*> addClassBind γ' l t-  modify (\s -> s { ebinds = ebinds s ++ (snd <$> is)})-  return $ γ' { fenv = insertsFEnv (fenv γ) is }---(+++=) :: (CGEnv, String) -> (F.Symbol, CoreExpr, SpecType) -> CG CGEnv-(γ, _) +++= (x, e, t) = (γ {lcb = M.insert x e (lcb γ) }) += ("+++=", x, t)--(-=) :: CGEnv -> F.Symbol -> CGEnv-γ -= x =  γ { renv = deleteREnv x (renv γ)-            , lcb  = M.delete   x (lcb  γ)-            -- , fenv = removeFEnv x (fenv γ)-            }--(?=) :: (?callStack :: CallStack) => CGEnv -> F.Symbol -> Maybe SpecType-γ ?= x  = lookupREnv x (renv γ)---------------------------------------------------------------------------setLocation :: CGEnv -> Sp.Span -> CGEnv--------------------------------------------------------------------------setLocation γ p = γ { cgLoc = Sp.push p $ cgLoc γ }---------------------------------------------------------------------------setBind :: CGEnv -> Var -> CGEnv--------------------------------------------------------------------------setBind γ x = γ `setLocation` Sp.Var x `setBind'` x--setBind' :: CGEnv -> Tg.TagKey -> CGEnv-setBind' γ k-  | Tg.memTagEnv k (tgEnv γ) = γ { tgKey = Just k }-  | otherwise                = γ---------------------------------------------------------------------------setRecs :: CGEnv -> [Var] -> CGEnv--------------------------------------------------------------------------setRecs γ xs   = γ { recs = L.foldl' (flip S.insert) (recs γ) xs }---------------------------------------------------------------------------setTRec :: CGEnv -> [(Var, SpecType)] -> CGEnv--------------------------------------------------------------------------setTRec γ xts  = γ' {trec = Just $ M.fromList xts' `M.union` trec'}-  where-    γ'         = γ `setRecs` (fst <$> xts)-    trec'      = fromMaybe M.empty $ trec γ-    xts'       = first F.symbol <$> xts
− src/Language/Haskell/Liquid/Constraint/Fresh.hs 
@@ -1,154 +0,0 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE UndecidableInstances  #-}-{-# LANGUAGE BangPatterns          #-}-{-# LANGUAGE ConstraintKinds       #-}--{-# OPTIONS_GHC -Wno-orphans #-}--module Language.Haskell.Liquid.Constraint.Fresh-  ( -- module Language.Haskell.Liquid.Types.Fresh-    -- , -    refreshArgsTop-  , freshTyType-  , freshTyExpr-  , trueTy-  , addKuts-  )-  where---- import           Data.Maybe                    (catMaybes) -- , fromJust, isJust)--- import           Data.Bifunctor--- import qualified Data.List                      as L-import qualified Data.HashMap.Strict            as M-import qualified Data.HashSet                   as S-import           Data.Hashable-import           Control.Monad.State            (gets, get, put, modify)-import           Control.Monad                  (when, (>=>))-import           Prelude                        hiding (error)--import           Language.Fixpoint.Misc  ((=>>))-import qualified Language.Fixpoint.Types as F-import           Language.Fixpoint.Types.Visitor (kvarsExpr)-import           Language.Haskell.Liquid.Types--- import           Language.Haskell.Liquid.Types.RefType--- import           Language.Haskell.Liquid.Types.Fresh-import           Language.Haskell.Liquid.Constraint.Types-import qualified Liquid.GHC.Misc as GM-import           Liquid.GHC.API as Ghc------------------------------------------------------------------------------------- | This is all hardwiring stuff to CG --------------------------------------------------------------------------------------------------------------------------instance Freshable CG Integer where-  fresh = do s <- get-             let n = freshIndex s-             put $ s { freshIndex = n + 1 }-             return n-----------------------------------------------------------------------------------refreshArgsTop :: (Var, SpecType) -> CG SpecType----------------------------------------------------------------------------------refreshArgsTop (x, t)-  = do (t', su) <- refreshArgsSub t-       modify $ \s -> s {termExprs = M.adjust (F.subst su <$>) x $ termExprs s}-       return t'------------------------------------------------------------------------------------- | Generation: Freshness ------------------------------------------------------------------------------------------------------------------------------------------ | Right now, we generate NO new pvars. Rather than clutter code---   with `uRType` calls, put it in one place where the above---   invariant is /obviously/ enforced.---   Constraint generation should ONLY use @freshTyType@ and @freshTyExpr@--freshTyType        :: Bool -> KVKind -> CoreExpr -> Type -> CG SpecType-freshTyType allowTC k e τ  =  F.notracepp ("freshTyType: " ++ F.showpp k ++ GM.showPpr e)-                   <$> freshTyReftype allowTC k (ofType τ)--freshTyExpr        :: Bool -> KVKind -> CoreExpr -> Type -> CG SpecType-freshTyExpr allowTC k e _  = freshTyReftype allowTC k $ exprRefType e--freshTyReftype     :: Bool -> KVKind -> SpecType -> CG SpecType-freshTyReftype allowTC k _t = (fixTy t >>= refresh allowTC) =>> addKVars k-  where-    t                = {- F.tracepp ("freshTyReftype:" ++ show k) -} _t---- | Used to generate "cut" kvars for fixpoint. Typically, KVars for recursive---   definitions, and also to update the KVar profile.-addKVars        :: KVKind -> SpecType -> CG ()-addKVars !k !t  = do-    cfg <- gets (getConfig . ghcI)-    when True          $ modify $ \s -> s { kvProf = updKVProf k ks (kvProf s) }-    when (isKut cfg k) $ addKuts k t-  where-    ks         = F.KS $ S.fromList $ specTypeKVars t--isKut :: Config -> KVKind -> Bool-isKut _  (RecBindE _) = True-isKut cfg ProjectE    = not (higherOrderFlag cfg) -- see ISSUE 1034, tests/pos/T1034.hs-isKut _    _          = False--addKuts :: (PPrint a) => a -> SpecType -> CG ()-addKuts _x t = modify $ \s -> s { kuts = mappend (F.KS ks) (kuts s)   }-  where-     ks'     = S.fromList $ specTypeKVars t-     ks-       | S.null ks' = ks'-       | otherwise  = {- F.tracepp ("addKuts: " ++ showpp _x) -} ks'--specTypeKVars :: SpecType -> [F.KVar]-specTypeKVars = foldReft False (\ _ r ks -> kvarsExpr (F.reftPred $ ur_reft r) ++ ks) []-----------------------------------------------------------------------------------trueTy  :: Bool -> Type -> CG SpecType----------------------------------------------------------------------------------trueTy allowTC = ofType' >=> true allowTC--ofType' :: Type -> CG SpecType-ofType' = fixTy . ofType--fixTy :: SpecType -> CG SpecType-fixTy t = do tyi   <- gets tyConInfo-             tce   <- gets tyConEmbed-             return $ addTyConInfo tce tyi t--exprRefType :: CoreExpr -> SpecType-exprRefType = exprRefType_ M.empty--exprRefType_ :: M.HashMap Var SpecType -> CoreExpr -> SpecType-exprRefType_ γ (Let b e)-  = exprRefType_ (bindRefType_ γ b) e--exprRefType_ γ (Lam α e) | isTyVar α-  = RAllT (makeRTVar $ rTyVar α) (exprRefType_ γ e) mempty--exprRefType_ γ (Lam x e)-  = rFun (F.symbol x) (ofType $ varType x) (exprRefType_ γ e)--exprRefType_ γ (Tick _ e)-  = exprRefType_ γ e--exprRefType_ γ (Var x)-  = M.lookupDefault (ofType $ varType x) x γ--exprRefType_ _ e-  = ofType $ exprType e--bindRefType_ :: M.HashMap Var SpecType -> Bind Var -> M.HashMap Var SpecType-bindRefType_ γ (Rec xes)-  = extendγ γ [(x, exprRefType_ γ e) | (x,e) <- xes]--bindRefType_ γ (NonRec x e)-  = extendγ γ [(x, exprRefType_ γ e)]--extendγ :: (Eq k, Foldable t, Hashable k)-        => M.HashMap k v-        -> t (k, v)-        -> M.HashMap k v-extendγ γ xts-  = foldr (\(x,t) m -> M.insert x t m) γ xts
− src/Language/Haskell/Liquid/Constraint/Generate.hs 
@@ -1,1503 +0,0 @@-{-# LANGUAGE DeriveTraversable         #-}-{-# LANGUAGE LambdaCase                #-}-{-# LANGUAGE StandaloneDeriving        #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE PatternGuards             #-}-{-# LANGUAGE MultiParamTypeClasses     #-}-{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE ImplicitParams            #-}--{-# OPTIONS_GHC -Wno-orphans #-}---- | This module defines the representation of Subtyping and WF Constraints,---   and the code for syntax-directed constraint generation.--module Language.Haskell.Liquid.Constraint.Generate ( generateConstraints, generateConstraintsWithEnv, caseEnv, consE ) where--import           Prelude                                       hiding (error)-import           GHC.Stack-import           Liquid.GHC.API                   as Ghc hiding ( panic-                                                                                 , checkErr-                                                                                 , (<+>)-                                                                                 , text-                                                                                 , vcat-                                                                                 )-import           Liquid.GHC.TypeRep           ()-import           Text.PrettyPrint.HughesPJ hiding ((<>))-import           Control.Monad.State-import           Data.Functor ((<&>))-import           Data.Maybe                                    (fromMaybe, catMaybes, isJust, mapMaybe)-import qualified Data.HashMap.Strict                           as M-import qualified Data.HashSet                                  as S-import qualified Data.List                                     as L-import qualified Data.Foldable                                 as F-import qualified Data.Traversable                              as T-import qualified Data.Functor.Identity-import           Language.Fixpoint.Misc-import           Language.Fixpoint.Types.Visitor-import qualified Language.Fixpoint.Types                       as F-import qualified Language.Fixpoint.Types.Visitor               as F-import           Language.Haskell.Liquid.Constraint.Fresh-import           Language.Haskell.Liquid.Constraint.Init-import           Language.Haskell.Liquid.Constraint.Env-import           Language.Haskell.Liquid.Constraint.Monad-import           Language.Haskell.Liquid.Constraint.Split-import           Language.Haskell.Liquid.Constraint.Relational (consAssmRel, consRelTop)-import           Language.Haskell.Liquid.Types.Dictionaries-import           Liquid.GHC.Play          (isHoleVar)-import qualified Liquid.GHC.Resugar           as Rs-import qualified Liquid.GHC.SpanStack         as Sp-import qualified Liquid.GHC.Misc         as GM -- ( isInternal, collectArguments, tickSrcSpan, showPpr )-import           Language.Haskell.Liquid.Misc-import           Language.Haskell.Liquid.Constraint.Types-import           Language.Haskell.Liquid.Constraint.Constraint-import           Language.Haskell.Liquid.Transforms.Rec-import           Language.Haskell.Liquid.Transforms.CoreToLogic (weakenResult, runToLogic, coreToLogic)-import           Language.Haskell.Liquid.Bare.DataType (dataConMap, makeDataConChecker)--import           Language.Haskell.Liquid.Types hiding (binds, Loc, loc, Def)------------------------------------------------------------------------------------- | Constraint Generation: Toplevel -----------------------------------------------------------------------------------------------------------------------------generateConstraints      :: TargetInfo -> CGInfo----------------------------------------------------------------------------------generateConstraints info = {-# SCC "ConsGen" #-} execState act $ initCGI cfg info-  where-    act                  = do { γ <- initEnv info; consAct γ cfg info }-    cfg                  = getConfig   info--generateConstraintsWithEnv :: TargetInfo -> CGInfo -> CGEnv -> CGInfo----------------------------------------------------------------------------------generateConstraintsWithEnv info cgi γ = {-# SCC "ConsGenEnv" #-} execState act cgi-  where-    act                  = consAct γ cfg info-    cfg                  = getConfig   info--consAct :: CGEnv -> Config -> TargetInfo -> CG ()-consAct γ cfg info = do-  let sSpc = gsSig . giSpec $ info-  let gSrc = giSrc info-  when (gradual cfg) (mapM_ (addW . WfC γ . val . snd) (gsTySigs sSpc ++ gsAsmSigs sSpc))-  γ' <- foldM (consCBTop cfg info) γ (giCbs gSrc)-  -- Relational Checking: the following only runs when the list of relational specs is not empty-  (ψ, γ'') <- foldM (consAssmRel cfg info) ([], γ') (gsAsmRel sSpc ++ gsRelation sSpc)-  mapM_ (consRelTop cfg info γ'' ψ) (gsRelation sSpc)-  -- End: Relational Checking-  mapM_ (consClass γ) (gsMethods $ gsSig $ giSpec info)-  hcs <- gets hsCs-  hws <- gets hsWfs-  fcs <- concat <$> mapM (splitC (typeclass (getConfig info))) hcs-  fws <- concat <$> mapM splitW hws-  modify $ \st -> st { fEnv     = fEnv    st `mappend` feEnv (fenv γ)-                     , cgLits   = litEnv   γ-                     , cgConsts = cgConsts st `mappend` constEnv γ-                     , fixCs    = fcs-                     , fixWfs   = fws }--------------------------------------------------------------------------------------- | Ensure that the instance type is a subtype of the class type -------------------------------------------------------------------------------------------------consClass :: CGEnv -> (Var, MethodType LocSpecType) -> CG ()-consClass γ (x,mt)-  | Just ti <- tyInstance mt-  , Just tc <- tyClass    mt-  = addC (SubC (γ `setLocation` Sp.Span (GM.fSrcSpan (F.loc ti))) (val ti) (val tc)) ("cconsClass for " ++ GM.showPpr x)-consClass _ _-  = return ()------------------------------------------------------------------------------------- | TERMINATION TYPE --------------------------------------------------------------------------------------------------------------------------------------------makeDecrIndex :: (Var, Template SpecType, [Var]) -> CG [Int]-makeDecrIndex (x, Assumed t, args)-  = do dindex <- makeDecrIndexTy x t args-       case dindex of-         Left msg -> addWarning msg >> return []-         Right i -> return i-makeDecrIndex (x, Asserted t, args)-  = do dindex <- makeDecrIndexTy x t args-       case dindex of-         Left msg -> addWarning msg >> return []-         Right i  -> return i-makeDecrIndex _ = return []--makeDecrIndexTy :: Var -> SpecType -> [Var] -> CG (Either (TError t) [Int])-makeDecrIndexTy x st args-  = do spDecr <- gets specDecr-       autosz <- gets autoSize-       hint   <- checkHint' autosz (L.lookup x spDecr)-       case dindex autosz of-         Nothing -> return $ Left msg-         Just i  -> return $ Right $ fromMaybe [i] hint-    where-       ts   = ty_args trep-       tvs  = zip ts args-       msg  = ErrTermin (getSrcSpan x) [F.pprint x] (text "No decreasing parameter")-       cenv = makeNumEnv ts-       trep = toRTypeRep $ unOCons st--       p autosz (t, v)   = isDecreasing autosz cenv t && not (isIdTRecBound v)-       checkHint' autosz = checkHint x ts (isDecreasing autosz cenv)-       dindex     autosz = L.findIndex (p autosz) tvs---recType :: F.Symbolic a-        => S.HashSet TyCon-        -> (([a], [Int]), (t, [Int], SpecType))-        -> SpecType-recType _ ((_, []), (_, [], t))-  = t--recType autoenv ((vs, indexc), (_, index, t))-  = makeRecType autoenv t v dxt index-  where v    = (vs !!)  <$> indexc-        dxt  = (xts !!) <$> index-        xts  = zip (ty_binds trep) (ty_args trep)-        trep = toRTypeRep $ unOCons t--checkIndex :: (NamedThing t, PPrint t, PPrint a)-           => (t, [a], Template (RType c tv r), [Int])-           -> CG [Maybe (RType c tv r)]-checkIndex (x, vs, t, index)-  = do mapM_ (safeLogIndex msg1 vs) index-       mapM  (safeLogIndex msg2 ts) index-    where-       loc   = getSrcSpan x-       ts    = ty_args $ toRTypeRep $ unOCons $ unTemplate t-       msg1  = ErrTermin loc [xd] ("No decreasing" <+> F.pprint index <-> "-th argument on" <+> xd <+> "with" <+> F.pprint vs)-       msg2  = ErrTermin loc [xd] "No decreasing parameter"-       xd    = F.pprint x--makeRecType :: (Enum a1, Eq a1, Num a1, F.Symbolic a)-            => S.HashSet TyCon-            -> SpecType-            -> [a]-            -> [(F.Symbol, SpecType)]-            -> [a1]-            -> SpecType-makeRecType autoenv t vs dxs is-  = mergecondition t $ fromRTypeRep $ trep {ty_binds = xs', ty_args = ts'}-  where-    (xs', ts') = unzip $ replaceN (last is) (safeFromLeft "makeRecType" $ makeDecrType autoenv vdxs) xts-    vdxs       = zip vs dxs-    xts        = zip (ty_binds trep) (ty_args trep)-    trep       = toRTypeRep $ unOCons t--unOCons :: RType c tv r -> RType c tv r-unOCons (RAllT v t r)      = RAllT v (unOCons t) r-unOCons (RAllP p t)        = RAllP p $ unOCons t-unOCons (RFun x i tx t r)  = RFun x i (unOCons tx) (unOCons t) r-unOCons (RRTy _ _ OCons t) = unOCons t-unOCons t                  = t--mergecondition :: RType c tv r -> RType c tv r -> RType c tv r-mergecondition (RAllT _ t1 _) (RAllT v t2 r2)          = RAllT v (mergecondition t1 t2) r2-mergecondition (RAllP _ t1) (RAllP p t2)               = RAllP p (mergecondition t1 t2)-mergecondition (RRTy xts r OCons t1) t2                = RRTy xts r OCons (mergecondition t1 t2)-mergecondition (RFun _ _ t11 t12 _) (RFun x2 i t21 t22 r2) = RFun x2 i (mergecondition t11 t21) (mergecondition t12 t22) r2-mergecondition _ t                                     = t--safeLogIndex :: Error -> [a] -> Int -> CG (Maybe a)-safeLogIndex err ls n-  | n >= length ls = addWarning err >> return Nothing-  | otherwise      = return $ Just $ ls !! n--checkHint :: (NamedThing a, PPrint a, PPrint a1)-          => a -> [a1] -> (a1 -> Bool) -> Maybe [Int] -> CG (Maybe [Int])-checkHint _ _ _ Nothing-  = return Nothing--checkHint x _ _ (Just ns) | L.sort ns /= ns-  = addWarning (ErrTermin loc [dx] (text "The hints should be increasing")) >> return Nothing-  where-    loc = getSrcSpan x-    dx  = F.pprint x--checkHint x ts f (Just ns)-  = mapM (checkValidHint x ts f) ns <&> (Just . catMaybes)--checkValidHint :: (NamedThing a, PPrint a, PPrint a1)-               => a -> [a1] -> (a1 -> Bool) -> Int -> CG (Maybe Int)-checkValidHint x ts f n-  | n < 0 || n >= length ts = addWarning err >> return Nothing-  | f (ts L.!! n)           = return $ Just n-  | otherwise               = addWarning err >> return Nothing-  where-    err = ErrTermin loc [xd] (vcat [ "Invalid Hint" <+> F.pprint (n+1) <+> "for" <+> xd-                                   , "in"-                                   , F.pprint ts ])-    loc = getSrcSpan x-    xd  = F.pprint x-----------------------------------------------------------------------------------consCBLet :: CGEnv -> CoreBind -> CG CGEnv----------------------------------------------------------------------------------consCBLet γ cb = do-  oldtcheck <- gets tcheck-  isStr     <- doTermCheck (getConfig γ) cb-  -- TODO: yuck.-  modify $ \s -> s { tcheck = oldtcheck && isStr }-  γ' <- consCB (oldtcheck && isStr) isStr γ cb-  modify $ \s -> s{tcheck = oldtcheck}-  return γ'------------------------------------------------------------------------------------- | Constraint Generation: Corebind -----------------------------------------------------------------------------------------------------------------------------consCBTop :: Config -> TargetInfo -> CGEnv -> CoreBind -> CG CGEnv----------------------------------------------------------------------------------consCBTop cfg info cgenv cb-  | all (trustVar cfg info) xs-  = foldM addB cgenv xs-    where-       xs   = bindersOf cb-       tt   = trueTy (typeclass cfg) . varType-       addB γ x = tt x >>= (\t -> γ += ("derived", F.symbol x, t))--consCBTop _ _ γ cb-  = do oldtcheck <- gets tcheck-       -- lazyVars  <- specLazy <$> get-       isStr     <- doTermCheck (getConfig γ) cb-       modify $ \s -> s { tcheck = oldtcheck && isStr}-       -- remove invariants that came from the cb definition-       let (γ', i) = removeInvariant γ cb                 --- DIFF-       γ'' <- consCB (oldtcheck && isStr) isStr (γ'{cgVar = topBind cb}) cb-       modify $ \s -> s { tcheck = oldtcheck}-       return $ restoreInvariant γ'' i                    --- DIFF-    where-      topBind (NonRec v _)  = Just v-      topBind (Rec [(v,_)]) = Just v-      topBind _             = Nothing--trustVar :: Config -> TargetInfo -> Var -> Bool-trustVar cfg info x = not (checkDerived cfg) && derivedVar (giSrc info) x--derivedVar :: TargetSrc -> Var -> Bool-derivedVar src x = S.member x (giDerVars src)--doTermCheck :: Config -> Bind Var -> CG Bool-doTermCheck cfg bind = do-  lazyVs    <- gets specLazy-  termVs    <- gets specTmVars-  let skip   = any (\x -> S.member x lazyVs || nocheck x) xs-  let chk    = not (structuralTerm cfg) || any (`S.member` termVs) xs-  return     $ chk && not skip-  where-    nocheck  = if typeclass cfg then GM.isEmbeddedDictVar else GM.isInternal-    xs       = bindersOf bind---- nonStructTerm && not skip---- RJ: AAAAAAARGHHH!!!!!! THIS CODE IS HORRIBLE!!!!!!!!!-consCBSizedTys :: CGEnv -> [(Var, CoreExpr)] -> CG CGEnv-consCBSizedTys γ xes-  = do xets     <- forM xes $ \(x, e) -> fmap (x, e,) (varTemplate γ (x, Just e))-       autoenv  <- gets autoSize-       ts       <- mapM (T.mapM refreshArgs) (thd3 <$> xets)-       let vs    = zipWith collectArgs' ts es-       is       <- mapM makeDecrIndex (zip3 vars ts vs) >>= checkSameLens-       let xeets = (\vis -> [(vis, x) | x <- zip3 vars is $ map unTemplate ts]) <$> zip vs is-       _ <- mapM checkIndex (zip4 vars vs ts is) >>= checkEqTypes . L.transpose-       let rts   = (recType autoenv <$>) <$> xeets-       let xts   = zip vars ts-       γ'       <- foldM extender γ xts-       let γs    = zipWith makeRecInvariants [γ' `setTRec` zip vars rts' | rts' <- rts] (filter (not . noMakeRec) <$> vs)-       let xets' = zip3 vars es ts-       mapM_ (uncurry $ consBind True) (zip γs xets')-       return γ'-  where-       noMakeRec      = if allowTC then GM.isEmbeddedDictVar else GM.isPredVar-       allowTC        = typeclass (getConfig γ)-       (vars, es)     = unzip xes-       dxs            = F.pprint <$> vars-       collectArgs'   = GM.collectArguments . length . ty_binds . toRTypeRep . unOCons . unTemplate-       checkEqTypes :: [[Maybe SpecType]] -> CG [[SpecType]]-       checkEqTypes x = mapM (checkAll' err1 toRSort) (catMaybes <$> x)-       checkSameLens  = checkAll' err2 length-       err1           = ErrTermin loc dxs $ text "The decreasing parameters should be of same type"-       err2           = ErrTermin loc dxs $ text "All Recursive functions should have the same number of decreasing parameters"-       loc            = getSrcSpan (head vars)--       checkAll' _   _ []            = return []-       checkAll' err f (x:xs)-         | all (== f x) (f <$> xs) = return (x:xs)-         | otherwise                = addWarning err >> return []--consCBWithExprs :: CGEnv -> [(Var, CoreExpr)] -> CG CGEnv-consCBWithExprs γ xes-  = do xets     <- forM xes $ \(x, e) -> fmap (x, e,) (varTemplate γ (x, Just e))-       texprs   <- gets termExprs-       let xtes  = mapMaybe (`lookup'` texprs) xs-       let ts    = safeFromAsserted err . thd3 <$> xets-       ts'      <- mapM refreshArgs ts-       let xts   = zip xs (Asserted <$> ts')-       γ'       <- foldM extender γ xts-       let γs    = makeTermEnvs γ' xtes xes ts ts'-       let xets' = zip3 xs es (Asserted <$> ts')-       mapM_ (uncurry $ consBind True) (zip γs xets')-       return γ'-  where (xs, es) = unzip xes-        lookup' k m | Just x <- M.lookup k m = Just (k, x)-                    | otherwise              = Nothing-        err      = "Constant: consCBWithExprs"--makeTermEnvs :: CGEnv -> [(Var, [F.Located F.Expr])] -> [(Var, CoreExpr)]-             -> [SpecType] -> [SpecType]-             -> [CGEnv]-makeTermEnvs γ xtes xes ts ts' = setTRec γ . zip xs <$> rts-  where-    vs   = zipWith collectArgs' ts ces-    syms = fst5 . bkArrowDeep <$> ts-    syms' = fst5 . bkArrowDeep <$> ts'-    sus' = zipWith mkSub syms syms'-    sus  = zipWith mkSub syms ((F.symbol <$>) <$> vs)-    ess  = (\x -> safeFromJust (err x) (x `L.lookup` xtes)) <$> xs-    tes  = zipWith (\su es -> F.subst su <$> es)  sus ess-    tes' = zipWith (\su es -> F.subst su <$> es)  sus' ess-    rss  = zipWith makeLexRefa tes' <$> (repeat <$> tes)-    rts  = zipWith (addObligation OTerm) ts' <$> rss-    (xs, ces)    = unzip xes-    mkSub ys ys' = F.mkSubst [(x, F.EVar y) | (x, y) <- zip ys ys']-    collectArgs' = GM.collectArguments . length . ty_binds . toRTypeRep-    err x        = "Constant: makeTermEnvs: no terminating expression for " ++ GM.showPpr x--addObligation :: Oblig -> SpecType -> RReft -> SpecType-addObligation o t r  = mkArrow αs πs yts xts $ RRTy [] r o t2-  where-    (αs, πs, t1) = bkUniv t-    ((xs',is',ts',rs'),(xs, is, ts, rs), t2) = bkArrow t1-    xts              = zip4 xs is ts rs-    yts              = zip4 xs' is' ts' rs'-----------------------------------------------------------------------------------consCB :: Bool -> Bool -> CGEnv -> CoreBind -> CG CGEnv------------------------------------------------------------------------------------ do termination checking-consCB True _ γ (Rec xes)-  = do texprs <- gets termExprs-       modify $ \i -> i { recCount = recCount i + length xes }-       let xxes = mapMaybe (`lookup'` texprs) xs-       if null xxes-         then consCBSizedTys γ xes-         else check xxes <$> consCBWithExprs γ xes-    where-      xs = map fst xes-      check ys r | length ys == length xs = r-                 | otherwise              = panic (Just loc) msg-      msg        = "Termination expressions must be provided for all mutually recursive binders"-      loc        = getSrcSpan (head xs)-      lookup' k m = (k,) <$> M.lookup k m---- don't do termination checking, but some strata checks?-consCB _ False γ (Rec xes)-  = do xets     <- forM xes $ \(x, e) -> (x, e,) <$> varTemplate γ (x, Just e)-       modify     $ \i -> i { recCount = recCount i + length xes }-       let xts    = [(x, to) | (x, _, to) <- xets]-       γ'        <- foldM extender (γ `setRecs` (fst <$> xts)) xts-       mapM_ (consBind True γ') xets-       return γ'---- don't do termination checking, and don't do any strata checks either?-consCB _ _ γ (Rec xes)-  = do xets   <- forM xes $ \(x, e) -> fmap (x, e,) (varTemplate γ (x, Just e))-       modify $ \i -> i { recCount = recCount i + length xes }-       let xts = [(x, to) | (x, _, to) <- xets]-       γ'     <- foldM extender (γ `setRecs` (fst <$> xts)) xts-       mapM_ (consBind True γ') xets-       return γ'---- | NV: Dictionaries are not checked, because--- | class methods' preconditions are not satisfied-consCB _ _ γ (NonRec x _) | isDictionary x-  = do t  <- trueTy (typeclass (getConfig γ)) (varType x)-       extender γ (x, Assumed t)-    where-       isDictionary = isJust . dlookup (denv γ)---consCB _ _ γ (NonRec x _ ) | isHoleVar x && typedHoles (getConfig γ)-  = return γ--consCB _ _ γ (NonRec x def)-  | Just (w, τ) <- grepDictionary def-  , Just d      <- dlookup (denv γ) w-  = do st       <- mapM (trueTy (typeclass (getConfig γ))) τ-       mapM_ addW (WfC γ <$> st)-       let xts   = dmap (fmap (f st)) d-       let  γ'   = γ { denv = dinsert (denv γ) x xts }-       t        <- trueTy (typeclass (getConfig γ)) (varType x)-       extender γ' (x, Assumed t)-   where-    f [t']    (RAllT α te _) = subsTyVarMeet' (ty_var_value α, t') te-    f (t':ts) (RAllT α te _) = f ts $ subsTyVarMeet' (ty_var_value α, t') te-    f _ _ = impossible Nothing "consCB on Dictionary: this should not happen"--consCB _ _ γ (NonRec x e)-  = do to  <- varTemplate γ (x, Nothing)-       to' <- consBind False γ (x, e, to) >>= addPostTemplate γ-       extender γ (x, makeSingleton γ (simplify e) <$> to')--grepDictionary :: CoreExpr -> Maybe (Var, [Type])-grepDictionary = go []-  where-    go ts (App (Var w) (Type t)) = Just (w, reverse (t:ts))-    go ts (App e (Type t))       = go (t:ts) e-    go ts (App e (Var _))        = go ts e-    go ts (Let _ e)              = go ts e-    go _ _                       = Nothing-----------------------------------------------------------------------------------consBind :: Bool -> CGEnv -> (Var, CoreExpr, Template SpecType) -> CG (Template SpecType)----------------------------------------------------------------------------------consBind _ _ (x, _, Assumed t)-  | RecSelId {} <- idDetails x -- don't check record selectors with assumed specs-  = return $ F.notracepp ("TYPE FOR SELECTOR " ++ show x) $ Assumed t--consBind isRec' γ (x, e, Asserted spect)-  = do let γ'       = γ `setBind` x-           (_,πs,_) = bkUniv spect-       cgenv    <- foldM addPToEnv γ' πs--       -- take implcits out of the function's SpecType and into the env-       let tyr = toRTypeRep spect-       let spect' = fromRTypeRep (tyr { ty_ebinds = [], ty_einfo = [], ty_eargs = [], ty_erefts = [] })-       γπ <- foldM (+=) cgenv $ (\(y,t)->("implicitError",y,t)) <$> zip (ty_ebinds tyr) (ty_eargs tyr)--       cconsE γπ e (weakenResult (typeclass (getConfig γ)) x spect')-       when (F.symbol x `elemHEnv` holes γ) $-         -- have to add the wf constraint here for HOLEs so we have the proper env-         addW $ WfC γπ $ fmap killSubst spect-       addIdA x (defAnn isRec' spect)-       return $ Asserted spect--consBind isRec' γ (x, e, Internal spect)-  = do let γ'       = γ `setBind` x-           (_,πs,_) = bkUniv spect-       γπ    <- foldM addPToEnv γ' πs-       let γπ' = γπ {cerr = Just $ ErrHMeas (getLocation γπ) (pprint x) (text explanation)}-       cconsE γπ' e spect-       when (F.symbol x `elemHEnv` holes γ) $-         -- have to add the wf constraint here for HOLEs so we have the proper env-         addW $ WfC γπ $ fmap killSubst spect-       addIdA x (defAnn isRec' spect)-       return $ Internal spect-  where-    explanation = "Cannot give singleton type to the function definition."--consBind isRec' γ (x, e, Assumed spect)-  = do let γ' = γ `setBind` x-       γπ    <- foldM addPToEnv γ' πs-       cconsE γπ e =<< true (typeclass (getConfig γ)) spect-       addIdA x (defAnn isRec' spect)-       return $ Asserted spect-    where πs   = ty_preds $ toRTypeRep spect--consBind isRec' γ (x, e, Unknown)-  = do t'    <- consE (γ `setBind` x) e-       t     <- topSpecType x t'-       addIdA x (defAnn isRec' t)-       when (GM.isExternalId x) (addKuts x t)-       return $ Asserted t--killSubst :: RReft -> RReft-killSubst = fmap killSubstReft--killSubstReft :: F.Reft -> F.Reft-killSubstReft = trans kv () ()-  where-    kv    = defaultVisitor { txExpr = ks }-    ks _ (F.PKVar k _) = F.PKVar k mempty-    ks _ p             = p--defAnn :: Bool -> t -> Annot t-defAnn True  = AnnRDf-defAnn False = AnnDef--addPToEnv :: CGEnv-          -> PVar RSort -> CG CGEnv-addPToEnv γ π-  = do γπ <- γ += ("addSpec1", pname π, pvarRType π)-       foldM (+=) γπ [("addSpec2", x, ofRSort t) | (t, x, _) <- pargs π]--extender :: F.Symbolic a => CGEnv -> (a, Template SpecType) -> CG CGEnv-extender γ (x, Asserted t)-  = case lookupREnv (F.symbol x) (assms γ) of-      Just t' -> γ += ("extender", F.symbol x, t')-      _       -> γ += ("extender", F.symbol x, t)-extender γ (x, Assumed t)-  = γ += ("extender", F.symbol x, t)-extender γ _-  = return γ--data Template a-  = Asserted a-  | Assumed a-  | Internal a-  | Unknown-  deriving (Functor, F.Foldable, T.Traversable)--deriving instance (Show a) => (Show (Template a))--instance PPrint a => PPrint (Template a) where-  pprintTidy k (Asserted t) = "Asserted" <+> pprintTidy k t-  pprintTidy k (Assumed  t) = "Assumed"  <+> pprintTidy k t-  pprintTidy k (Internal t) = "Internal" <+> pprintTidy k t-  pprintTidy _ Unknown      = "Unknown"--unTemplate :: Template t -> t-unTemplate (Asserted t) = t-unTemplate (Assumed t)  = t-unTemplate (Internal t) = t-unTemplate _            = panic Nothing "Constraint.Generate.unTemplate called on `Unknown`"--addPostTemplate :: CGEnv-                -> Template SpecType-                -> CG (Template SpecType)-addPostTemplate γ (Asserted t) = Asserted <$> addPost γ t-addPostTemplate γ (Assumed  t) = Assumed  <$> addPost γ t-addPostTemplate γ (Internal t) = Internal  <$> addPost γ t-addPostTemplate _ Unknown      = return Unknown--safeFromAsserted :: [Char] -> Template t -> t-safeFromAsserted _ (Asserted t) = t-safeFromAsserted msg _ = panic Nothing $ "safeFromAsserted:" ++ msg---- | @varTemplate@ is only called with a `Just e` argument when the `e`--- corresponds to the body of a @Rec@ binder.-varTemplate :: CGEnv -> (Var, Maybe CoreExpr) -> CG (Template SpecType)-varTemplate γ (x, eo) = varTemplate' γ (x, eo) >>= mapM (topSpecType x)---- | @lazVarTemplate@ is like `varTemplate` but for binders that are *not*---   termination checked and hence, the top-level refinement / KVar is---   stripped out. e.g. see tests/neg/T743.hs--- varTemplate :: CGEnv -> (Var, Maybe CoreExpr) -> CG (Template SpecType)--- lazyVarTemplate γ (x, eo) = dbg <$> (topRTypeBase <$>) <$> varTemplate' γ (x, eo)---   where---    dbg   = traceShow ("LAZYVAR-TEMPLATE: " ++ show x)--varTemplate' :: CGEnv -> (Var, Maybe CoreExpr) -> CG (Template SpecType)-varTemplate' γ (x, eo)-  = case (eo, lookupREnv (F.symbol x) (grtys γ), lookupREnv (F.symbol x) (assms γ), lookupREnv (F.symbol x) (intys γ)) of-      (_, Just t, _, _) -> Asserted <$> refreshArgsTop (x, t)-      (_, _, _, Just t) -> Internal <$> refreshArgsTop (x, t)-      (_, _, Just t, _) -> Assumed  <$> refreshArgsTop (x, t)-      (Just e, _, _, _) -> do t  <- freshTyExpr (typeclass (getConfig γ)) (RecBindE x) e (exprType e)-                              addW (WfC γ t)-                              Asserted <$> refreshArgsTop (x, t)-      (_,      _, _, _) -> return Unknown---- | @topSpecType@ strips out the top-level refinement of "derived var"-topSpecType :: Var -> SpecType -> CG SpecType-topSpecType x t = do-  info <- gets ghcI-  return $ if derivedVar (giSrc info) x then topRTypeBase t else t------------------------------------------------------------------------------------- | Bidirectional Constraint Generation: CHECKING ---------------------------------------------------------------------------------------------------------------cconsE :: CGEnv -> CoreExpr -> SpecType -> CG ()----------------------------------------------------------------------------------cconsE g e t = do-  -- NOTE: tracing goes here-  -- traceM $ printf "cconsE:\n  expr = %s\n  exprType = %s\n  lqType = %s\n" (showPpr e) (showPpr (exprType e)) (showpp t)-  cconsE' g e t-----------------------------------------------------------------------------------cconsE' :: CGEnv -> CoreExpr -> SpecType -> CG ()----------------------------------------------------------------------------------cconsE' γ e t-  | Just (Rs.PatSelfBind _x e') <- Rs.lift e-  = cconsE' γ e' t--  | Just (Rs.PatSelfRecBind x e') <- Rs.lift e-  = let γ' = γ { grtys = insertREnv (F.symbol x) t (grtys γ)}-    in void $ consCBLet γ' (Rec [(x, e')])--cconsE' γ e@(Let b@(NonRec x _) ee) t-  = do sp <- gets specLVars-       if x `S.member` sp-         then cconsLazyLet γ e t-         else do γ'  <- consCBLet γ b-                 cconsE γ' ee t--cconsE' γ e (RAllP p t)-  = cconsE γ' e t''-  where-    t'         = replacePredsWithRefs su <$> t-    su         = (uPVar p, pVartoRConc p)-    (css, t'') = splitConstraints (typeclass (getConfig γ)) t'-    γ'         = L.foldl' addConstraints γ css--cconsE' γ (Let b e) t-  = do γ'  <- consCBLet γ b-       cconsE γ' e t--cconsE' γ (Case e x _ cases) t-  = do γ'  <- consCBLet γ (NonRec x e)-       forM_ cases $ cconsCase γ' x t nonDefAlts-    where-       nonDefAlts = [a | (a, _, _) <- cases, a /= DEFAULT]-       _msg = "cconsE' #nonDefAlts = " ++ show (length nonDefAlts)--cconsE' γ (Lam α e) (RAllT α' t r) | isTyVar α-  = do γ' <- updateEnvironment γ α-       addForAllConstraint γ' α e (RAllT α' t r)-       cconsE γ' e $ subsTyVarMeet' (ty_var_value α', rVar α) t--cconsE' γ (Lam x e) (RFun y i ty t r)-  | not (isTyVar x)-  = do γ' <- γ += ("cconsE", x', ty)-       cconsE γ' e t'-       addFunctionConstraint γ x e (RFun x' i ty t' r')-       addIdA x (AnnDef ty)-  where-    x'  = F.symbol x-    t'  = t `F.subst1` (y, F.EVar x')-    r'  = r `F.subst1` (y, F.EVar x')--cconsE' γ (Tick tt e) t-  = cconsE (γ `setLocation` Sp.Tick tt) e t--cconsE' γ (Cast e co) t-  -- See Note [Type classes with a single method]-  | Just f <- isClassConCo co-  = cconsE γ (f e) t--cconsE' γ e@(Cast e' c) t-  = do t' <- castTy γ (exprType e) e' c-       addC (SubC γ (F.notracepp ("Casted Type for " ++ GM.showPpr e ++ "\n init type " ++ showpp t) t') t) ("cconsE Cast: " ++ GM.showPpr e)--cconsE' γ (Var x) t | isHoleVar x && typedHoles (getConfig γ)-  = addHole x t γ--cconsE' γ e t-  = do  te  <- consE γ e-        te' <- instantiatePreds γ e te >>= addPost γ-        addC (SubC γ te' t) ("cconsE: " ++ "\n t = " ++ showpp t ++ "\n te = " ++ showpp te ++ GM.showPpr e)--lambdaSingleton :: CGEnv -> F.TCEmb TyCon -> Var -> CoreExpr -> CG (UReft F.Reft)-lambdaSingleton γ tce x e-  | higherOrderFlag γ-  = lamExpr γ e >>= \case-      Just e' -> return $ uTop $ F.exprReft $ F.ELam (F.symbol x, sx) e'-      _ -> return mempty-  where-    sx = typeSort tce $ Ghc.expandTypeSynonyms $ varType x-lambdaSingleton _ _ _ _-  = return mempty--addForAllConstraint :: CGEnv -> Var -> CoreExpr -> SpecType -> CG ()-addForAllConstraint γ _ _ (RAllT rtv rt rr)-  | F.isTauto rr-  = return ()-  | otherwise-  = do t'       <- true (typeclass (getConfig γ)) rt-       let truet = RAllT rtv $ unRAllP t'-       addC (SubC γ (truet mempty) $ truet rr) "forall constraint true"-  where unRAllP (RAllT a t r) = RAllT a (unRAllP t) r-        unRAllP (RAllP _ t)   = unRAllP t-        unRAllP t             = t-addForAllConstraint γ _ _ _-  = impossible (Just $ getLocation γ) "addFunctionConstraint: called on non function argument"---addFunctionConstraint :: CGEnv -> Var -> CoreExpr -> SpecType -> CG ()-addFunctionConstraint γ x e (RFun y i ty t r)-  = do ty'      <- true (typeclass (getConfig γ)) ty-       t'       <- true (typeclass (getConfig γ)) t-       let truet = RFun y i ty' t'-       lamE <- lamExpr γ e-       case (lamE, higherOrderFlag γ) of-          (Just e', True) -> do tce    <- gets tyConEmbed-                                let sx  = typeSort tce $ varType x-                                let ref = uTop $ F.exprReft $ F.ELam (F.symbol x, sx) e'-                                addC (SubC γ (truet ref) $ truet r)    "function constraint singleton"-          _ -> addC (SubC γ (truet mempty) $ truet r) "function constraint true"-addFunctionConstraint γ _ _ _-  = impossible (Just $ getLocation γ) "addFunctionConstraint: called on non function argument"--splitConstraints :: TyConable c-                 => Bool -> RType c tv r -> ([[(F.Symbol, RType c tv r)]], RType c tv r)-splitConstraints allowTC (RRTy cs _ OCons t)-  = let (css, t') = splitConstraints allowTC t in (cs:css, t')-splitConstraints allowTC (RFun x i tx@(RApp c _ _ _) t r) | isErasable c-  = let (css, t') = splitConstraints allowTC  t in (css, RFun x i tx t' r)-  where isErasable = if allowTC then isEmbeddedDict else isClass-splitConstraints _ t-  = ([], t)------------------------------------------------------------------------ | @instantiateGhosts@ peels away implicit argument binders,--- instantiates them with fresh variables, and adds those variables--- to the context as @ebind@s TODO: the second half---------------------------------------------------------------------instantiateGhosts :: CGEnv-                 -> SpecType-                 -> CG (Bool, CGEnv, SpecType)-instantiateGhosts γ t | not (null yts)-  = do ys' <- mapM (const fresh) ys-       γ'  <- foldM addEEnv γ (zip ys' ts)--       let su = F.mkSubst $ zip ys (F.EVar <$> ys')-       return (True, γ', F.subst su te')-  where (yts, te') = bkImplicit t-        (ys, ts)   = unzip yts--instantiateGhosts γ t = return (False, γ, t)--bkImplicit :: RType c tv r-           -> ( [(F.Symbol, RType c tv r)]-              , RType c tv r)-bkImplicit (RImpF x _ tx t _) = ((x,tx):acc, t')-  where (acc,t') = bkImplicit t-bkImplicit t = ([],t)------------------------------------------------------------------------ | @instantiatePreds@ peels away the universally quantified @PVars@---   of a @RType@, generates fresh @Ref@ for them and substitutes them---   in the body.---------------------------------------------------------------------instantiatePreds :: CGEnv-                 -> CoreExpr-                 -> SpecType-                 -> CG SpecType-instantiatePreds γ e (RAllP π t)-  = do r     <- freshPredRef γ e π-       instantiatePreds γ e $ replacePreds "consE" t [(π, r)]--instantiatePreds _ _ t0-  = return t0-----------------------------------------------------------------------cconsLazyLet :: CGEnv-             -> CoreExpr-             -> SpecType-             -> CG ()-cconsLazyLet γ (Let (NonRec x ex) e) t-  = do tx <- trueTy (typeclass (getConfig γ)) (varType x)-       γ' <- (γ, "Let NonRec") +++= (x', ex, tx)-       cconsE γ' e t-    where-       x' = F.symbol x--cconsLazyLet _ _ _-  = panic Nothing "Constraint.Generate.cconsLazyLet called on invalid inputs"------------------------------------------------------------------------------------- | Bidirectional Constraint Generation: SYNTHESIS --------------------------------------------------------------------------------------------------------------consE :: CGEnv -> CoreExpr -> CG SpecType----------------------------------------------------------------------------------consE γ e-  | patternFlag γ-  , Just p <- Rs.lift e-  = consPattern γ (F.notracepp "CONSE-PATTERN: " p) (exprType e)---- NV CHECK 3 (unVar and does this hack even needed?)--- NV (below) is a hack to type polymorphic axiomatized functions--- no need to check this code with flag, the axioms environment with--- is empty if there is no axiomatization. ---- [NOTE: PLE-OPT] We *disable* refined instantiation for --- reflected functions inside proofs.---- If datacon definitions have references to self for fancy termination,--- ignore them at the construction. -consE γ (Var x) | GM.isDataConId x-  = do t0 <- varRefType γ x-       -- NV: The check is expected to fail most times, so -       --     it is cheaper than direclty fmap ignoreSelf. -       let hasSelf = selfSymbol `elem` F.syms t0-       let t = if hasSelf-                then fmap ignoreSelf <$> t0-                else t0-       addLocA (Just x) (getLocation γ) (varAnn γ x t)-       return t--consE γ (Var x)-  = do t <- varRefType γ x-       addLocA (Just x) (getLocation γ) (varAnn γ x t)-       return t--consE _ (Lit c)-  = refreshVV $ uRType $ literalFRefType c--consE γ e'@(App e a@(Type τ))-  = do RAllT α te _ <- checkAll ("Non-all TyApp with expr", e) γ <$> consE γ e-       t            <- if not (nopolyinfer (getConfig γ)) && isPos α && isGenericVar (ty_var_value α) te-                         then freshTyType (typeclass (getConfig γ)) TypeInstE e τ-                         else trueTy (typeclass (getConfig γ)) τ-       addW          $ WfC γ t-       t'           <- refreshVV t-       tt0          <- instantiatePreds γ e' (subsTyVarMeet' (ty_var_value α, t') te)-       let tt        = makeSingleton γ (simplify e') $ subsTyReft γ (ty_var_value α) τ tt0-       case rTVarToBind α of-         Just (x, _) -> return $ maybe (checkUnbound γ e' x tt a) (F.subst1 tt . (x,)) (argType τ)-         Nothing     -> return tt-  where-    isPos α = not (extensionality (getConfig γ)) || rtv_is_pol (ty_var_info α)--consE γ e'@(App e a) | Just aDict <- getExprDict γ a-  = case dhasinfo (dlookup (denv γ) aDict) (getExprFun γ e) of-      Just riSig -> return $ fromRISig riSig-      _          -> do-        ([], πs, te) <- bkUniv <$> consE γ e-        te'          <- instantiatePreds γ e' $ foldr RAllP te πs-        (γ', te''')  <- dropExists γ te'-        te''         <- dropConstraints γ te'''-        updateLocA {- πs -}  (exprLoc e) te''-        let RFun x _ tx t _ = checkFun ("Non-fun App with caller ", e') γ te''-        cconsE γ' a tx-        addPost γ'        $ maybe (checkUnbound γ' e' x t a) (F.subst1 t . (x,)) (argExpr γ a)--consE γ e'@(App e a)-  = do ([], πs, te) <- bkUniv <$> consE γ {- GM.tracePpr ("APP-EXPR: " ++ GM.showPpr (exprType e)) -} e-       te1        <- instantiatePreds γ e' $ foldr RAllP te πs-       (γ', te2)  <- dropExists γ te1-       te3        <- dropConstraints γ te2-       updateLocA (exprLoc e) te3-       (hasGhost, γ'', te4)     <- instantiateGhosts γ' te3-       let RFun x _ tx t _ = checkFun ("Non-fun App with caller ", e') γ te4-       cconsE γ'' a tx-       tout <- makeSingleton γ'' (simplify e') <$> addPost γ'' (maybe (checkUnbound γ'' e' x t a) (F.subst1 t . (x,)) (argExpr γ $ simplify a))-       if hasGhost-          then do-           tk   <- freshTyType (typeclass (getConfig γ)) ImplictE e' $ exprType e'-           addW $ WfC γ tk-           addC (SubC γ'' tout tk) ""-           return tk-          else return tout--consE γ (Lam α e) | isTyVar α-  = do γ' <- updateEnvironment γ α-       t' <- consE γ' e-       return $ RAllT (makeRTVar $ rTyVar α) t' mempty--consE γ  e@(Lam x e1)-  = do tx      <- freshTyType (typeclass (getConfig γ)) LamE (Var x) τx-       γ'      <- γ += ("consE", F.symbol x, tx)-       t1      <- consE γ' e1-       addIdA x $ AnnDef tx-       addW     $ WfC γ tx-       tce     <- gets tyConEmbed-       lamSing <- lambdaSingleton γ tce x e1-       return   $ RFun (F.symbol x) (mkRFInfo $ getConfig γ) tx t1 lamSing-    where-      FunTy { ft_arg = τx } = exprType e--consE γ e@(Let _ _)-  = cconsFreshE LetE γ e--consE γ e@(Case _ _ _ [_])-  | Just p@Rs.PatProject{} <- Rs.lift e-  = consPattern γ p (exprType e)--consE γ e@(Case _ _ _ cs)-  = cconsFreshE (caseKVKind cs) γ e--consE γ (Tick tt e)-  = do t <- consE (setLocation γ (Sp.Tick tt)) e-       addLocA Nothing (GM.tickSrcSpan tt) (AnnUse t)-       return t---- See Note [Type classes with a single method]-consE γ (Cast e co)-  | Just f <- isClassConCo co-  = consE γ (f e)--consE γ e@(Cast e' c)-  = castTy γ (exprType e) e' c--consE γ e@(Coercion _)-   = trueTy (typeclass (getConfig γ)) $ exprType e--consE _ e@(Type t)-  = panic Nothing $ "consE cannot handle type " ++ GM.showPpr (e, t)--caseKVKind ::[Alt Var] -> KVKind-caseKVKind [(DataAlt _, _, Var _)] = ProjectE-caseKVKind cs                      = CaseE (length cs)--updateEnvironment :: CGEnv  -> TyVar -> CG CGEnv-updateEnvironment γ a-  | isValKind (tyVarKind a)-  = γ += ("varType", F.symbol $ varName a, kindToRType $ tyVarKind a)-  | otherwise-  = return γ--getExprFun :: CGEnv -> CoreExpr -> Var-getExprFun γ e          = go e-  where-    go (App x (Type _)) = go x-    go (Var x)          = x-    go _                = panic (Just (getLocation γ)) msg-    msg                 = "getFunName on \t" ++ GM.showPpr e---- | `exprDict e` returns the dictionary `Var` inside the expression `e`-getExprDict :: CGEnv -> CoreExpr -> Maybe Var-getExprDict γ           =  go-  where-    go (Var x)          = case dlookup (denv γ) x of {Just _ -> Just x; Nothing -> Nothing}-    go (Tick _ e)       = go e-    go (App a (Type _)) = go a-    go (Let _ e)        = go e-    go _                = Nothing------------------------------------------------------------------------------------- | With GADTs and reflection, refinements can contain type variables, ---   as 'coercions' (see ucsd-progsys/#1424). At application sites, we ---   must also substitute those from the refinements (not just the types).---      https://github.com/ucsd-progsys/liquidhaskell/issues/1424--- ---   see: tests/ple/{pos,neg}/T1424.hs--------------------------------------------------------------------------------------subsTyReft :: CGEnv -> RTyVar -> Type -> SpecType -> SpecType-subsTyReft γ a t = mapExprReft (\_ -> F.applyCoSub coSub)-  where-    coSub        = M.fromList [(F.symbol a, typeSort (emb γ) t)]------------------------------------------------------------------------------------- | Type Synthesis for Special @Pattern@s -----------------------------------------------------------------------------------------------------------------------consPattern :: CGEnv -> Rs.Pattern -> Type -> CG SpecType--{- [NOTE] special type rule for monadic-bind application--    G |- e1 ~> m tx     G, x:tx |- e2 ~> m t-    ------------------------------------------          G |- (e1 >>= \x -> e2) ~> m t- -}--consPattern γ (Rs.PatBind e1 x e2 _ _ _ _ _) _ = do-  tx <- checkMonad (msg, e1) γ <$> consE γ e1-  γ' <- γ += ("consPattern", F.symbol x, tx)-  addIdA x (AnnDef tx)-  consE γ' e2-  where-    msg = "This expression has a refined monadic type; run with --no-pattern-inline: "--{- [NOTE] special type rule for monadic-return--           G |- e ~> et-    -------------------------      G |- return e ~ m et- -}-consPattern γ (Rs.PatReturn e m _ _ _) t = do-  et    <- F.notracepp "Cons-Pattern-Ret" <$> consE γ e-  mt    <- trueTy (typeclass (getConfig γ))  m-  tt    <- trueTy (typeclass (getConfig γ))  t-  return (mkRAppTy mt et tt) -- /// {-    $ RAppTy mt et mempty -}--{- [NOTE] special type rule for field projection, is-          t  = G(x)       ti = Proj(t, i)-    ------------------------------------------      G |- case x of C [y1...yn] -> yi : ti- -}--consPattern γ (Rs.PatProject xe _ τ c ys i) _ = do-  let yi = ys !! i-  t    <- (addW . WfC γ) <<= freshTyType (typeclass (getConfig γ)) ProjectE (Var yi) τ-  γ'   <- caseEnv γ xe [] (DataAlt c) ys (Just [i])-  ti   <- {- γ' ??= yi -} varRefType γ' yi-  addC (SubC γ' ti t) "consPattern:project"-  return t--consPattern γ (Rs.PatSelfBind _ e) _ =-  consE γ e--consPattern γ p@Rs.PatSelfRecBind{} _ =-  cconsFreshE LetE γ (Rs.lower p)--mkRAppTy :: SpecType -> SpecType -> SpecType -> SpecType-mkRAppTy mt et RAppTy{}          = RAppTy mt et mempty-mkRAppTy _  et (RApp c [_] [] _) = RApp c [et] [] mempty-mkRAppTy _  _  _                 = panic Nothing "Unexpected return-pattern"--checkMonad :: (Outputable a) => (String, a) -> CGEnv -> SpecType -> SpecType-checkMonad x g = go . unRRTy- where-   go (RApp _ ts [] _)-     | not (null ts) = last ts-   go (RAppTy _ t _) = t-   go t              = checkErr x g t--unRRTy :: SpecType -> SpecType-unRRTy (RRTy _ _ _ t) = unRRTy t-unRRTy t              = t-----------------------------------------------------------------------------------castTy  :: CGEnv -> Type -> CoreExpr -> Coercion -> CG SpecType-castTy' :: CGEnv -> Type -> CoreExpr -> CG SpecType----------------------------------------------------------------------------------castTy γ t e (AxiomInstCo ca _ _)-  = fromMaybe <$> castTy' γ t e <*> lookupNewType (coAxiomTyCon ca)--castTy γ t e (SymCo (AxiomInstCo ca _ _))-  = do mtc <- lookupNewType (coAxiomTyCon ca)-       F.forM_ mtc (cconsE γ e)-       castTy' γ t e--castTy γ t e _-  = castTy' γ t e---castTy' γ τ (Var x)-  = do t0 <- trueTy (typeclass (getConfig γ)) τ-       tx <- varRefType γ x -       let t = mergeCastTys t0 tx -       let ce = if typeclass (getConfig γ) && noADT (getConfig γ) then F.expr x-                else eCoerc (typeSort (emb γ) $ Ghc.expandTypeSynonyms $ varType x)-                       (typeSort (emb γ) τ)-                       $ F.expr x-       return (t `strengthen` uTop (F.uexprReft ce) {- `F.meet` tx -})-  where eCoerc s t e-         | s == t    = e-         | otherwise = F.ECoerc s t e--castTy' γ t (Tick _ e)-  = castTy' γ t e--castTy' _ _ e-  = panic Nothing $ "castTy cannot handle expr " ++ GM.showPpr e---{--mergeCastTys tcorrect trefined -  tcorrect has the correct GHC skeleton, -  trefined has the correct refinements (before coercion)-  mergeCastTys keeps the trefined when the two GHC types match --}--mergeCastTys :: SpecType -> SpecType -> SpecType -mergeCastTys t1 t2 -  | toType False t1 == toType False t2 -  = t2 -mergeCastTys (RApp c1 ts1 ps1 r1) (RApp c2 ts2 _ _) -  | c1 == c2 -  = RApp c1 (zipWith mergeCastTys ts1 ts2) ps1 r1-mergeCastTys t _ -  = t--{--showCoercion :: Coercion -> String-showCoercion (AxiomInstCo co1 co2 co3)-  = "AxiomInstCo " ++ showPpr co1 ++ "\t\t " ++ showPpr co2 ++ "\t\t" ++ showPpr co3 ++ "\n\n" ++-    "COAxiom Tycon = "  ++ showPpr (coAxiomTyCon co1) ++ "\nBRANCHES\n" ++ concatMap showBranch bs-  where-    bs = fromBranchList $ co_ax_branches co1-    showBranch ab = "\nCoAxiom \nLHS = " ++ showPpr (coAxBranchLHS ab) ++-                    "\nRHS = " ++ showPpr (coAxBranchRHS ab)-showCoercion (SymCo c)-  = "Symc :: " ++ showCoercion c-showCoercion c-  = "Coercion " ++ showPpr c--}--isClassConCo :: Coercion -> Maybe (Expr Var -> Expr Var)--- See Note [Type classes with a single method]-isClassConCo co-  | Pair t1 t2 <- coercionKind co-  , isClassPred t2-  , (tc,ts) <- splitTyConApp t2-  , [dc]    <- tyConDataCons tc-  , [tm]    <- map irrelevantMult (Ghc.dataConOrigArgTys dc)-               -- tcMatchTy because we have to instantiate the class tyvars-  , Just _  <- ruleMatchTyX (mkUniqSet $ tyConTyVars tc) (mkRnEnv2 emptyInScopeSet) emptyTvSubstEnv tm t1-  = Just (\e -> mkCoreConApps dc $ map Type ts ++ [e])--  | otherwise-  = Nothing-  where-    ruleMatchTyX =ruleMatchTyKiX -- TODO: is this correct?--------------------------------------------------------------------------- Note [Type classes with a single method]-------------------------------------------------------------------------- GHC 7.10 encodes type classes with a single method as newtypes and--- `cast`s between the method and class type instead of applying the--- class constructor. Just rewrite the core to what we're used to--- seeing..------ specifically, we want to rewrite------   e `cast` ((a -> b) ~ C)------ to------   D:C e------ but only when------   D:C :: (a -> b) -> C------------------------------------------------------------------------------------- | @consFreshE@ is used to *synthesize* types with a **fresh template**.---   e.g. at joins, recursive binders, polymorphic instantiations etc. It is---   the "portal" that connects `consE` (synthesis) and `cconsE` (checking)----------------------------------------------------------------------------------cconsFreshE :: KVKind -> CGEnv -> CoreExpr -> CG SpecType-cconsFreshE kvkind γ e = do-  t   <- freshTyType (typeclass (getConfig γ)) kvkind e $ exprType e-  addW $ WfC γ t-  cconsE γ e t-  return t-----------------------------------------------------------------------------------checkUnbound :: (Show a, Show a2, F.Subable a)-             => CGEnv -> CoreExpr -> F.Symbol -> a -> a2 -> a-checkUnbound γ e x t a-  | x `notElem` F.syms t = t-  | otherwise              = panic (Just $ getLocation γ) msg-  where-    msg = unlines [ "checkUnbound: " ++ show x ++ " is elem of syms of " ++ show t-                  , "In", GM.showPpr e, "Arg = " , show a ]---dropExists :: CGEnv -> SpecType -> CG (CGEnv, SpecType)-dropExists γ (REx x tx t) =         (, t) <$> γ += ("dropExists", x, tx)-dropExists γ t            = return (γ, t)--dropConstraints :: CGEnv -> SpecType -> CG SpecType-dropConstraints cgenv (RFun x i tx@(RApp c _ _ _) t r) | isErasable c-  = flip (RFun x i tx) r <$> dropConstraints cgenv t-  where-    isErasable = if typeclass (getConfig cgenv) then isEmbeddedDict else isClass-dropConstraints cgenv (RRTy cts _ OCons rt)-  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) cgenv xts-       addC (SubC  γ' t1 t2)  "dropConstraints"-       dropConstraints cgenv rt-  where-    (xts, t1, t2) = envToSub cts--dropConstraints _ t = return t----------------------------------------------------------------------------------------cconsCase :: CGEnv -> Var -> SpecType -> [AltCon] -> (AltCon, [Var], CoreExpr) -> CG ()---------------------------------------------------------------------------------------cconsCase γ x t acs (ac, ys, ce)-  = do cγ <- caseEnv γ x acs ac ys mempty-       cconsE cγ ce t--{- --case x :: List b of -  Emp -> e --  Emp :: tdc          forall a. {v: List a | cons v === 0} -  x   :: xt           List b -  ys  == binders      [] ---}---------------------------------------------------------------------------------------caseEnv   :: CGEnv -> Var -> [AltCon] -> AltCon -> [Var] -> Maybe [Int] -> CG CGEnv---------------------------------------------------------------------------------------caseEnv γ x _   (DataAlt c) ys pIs = do--  let (x' : ys')   = F.symbol <$> (x:ys)-  xt0             <- checkTyCon ("checkTycon cconsCase", x) γ <$> γ ??= x-  let rt           = shiftVV xt0 x'-  tdc             <- γ ??= dataConWorkId c >>= refreshVV-  let (rtd,yts',_) = unfoldR tdc rt ys-  yts             <- projectTypes (typeclass (getConfig γ))  pIs yts'-  let ys''         = F.symbol <$> filter (not . if allowTC then GM.isEmbeddedDictVar else GM.isEvVar) ys-  let r1           = dataConReft   c   ys''-  let r2           = dataConMsReft rtd ys''-  let xt           = (xt0 `F.meet` rtd) `strengthen` uTop (r1 `F.meet` r2)-  let cbs          = safeZip "cconsCase" (x':ys')-                         (map (`F.subst1` (selfSymbol, F.EVar x'))-                         (xt0 : yts))-  cγ'             <- addBinders γ x' cbs-  addBinders cγ' x' [(x', substSelf <$> xt)]-  where allowTC    = typeclass (getConfig γ)--caseEnv γ x acs a _ _ = do-  let x'  = F.symbol x-  xt'    <- (`strengthen` uTop (altReft γ acs a)) <$> (γ ??= x)-  addBinders γ x' [(x', xt')]------------------------------------------------------------ SELF special substitutions ---------------------------------------------------------substSelf :: UReft F.Reft -> UReft F.Reft-substSelf (MkUReft r p) = MkUReft (substSelfReft r) p--substSelfReft :: F.Reft -> F.Reft-substSelfReft (F.Reft (v, e)) = F.Reft (v, F.subst1 e (selfSymbol, F.EVar v))--ignoreSelf :: F.Reft -> F.Reft-ignoreSelf = F.mapExpr (\r -> if selfSymbol `elem` F.syms r then F.PTrue else r)------------------------------------------------------------------------------------- | `projectTypes` masks (i.e. true's out) all types EXCEPT those---   at given indices; it is used to simplify the environment used---   when projecting out fields of single-ctor datatypes.----------------------------------------------------------------------------------projectTypes :: Bool -> Maybe [Int] -> [SpecType] -> CG [SpecType]-projectTypes _ Nothing   ts = return ts-projectTypes allowTC (Just ints) ts = mapM (projT ints) (zip [0..] ts)-  where-    projT is (j, t)-      | j `elem` is       = return t-      | otherwise         = true allowTC t--altReft :: CGEnv -> [AltCon] -> AltCon -> F.Reft-altReft _ _ (LitAlt l)   = literalFReft l-altReft γ acs DEFAULT    = mconcat ([notLiteralReft l | LitAlt l <- acs] ++ [notDataConReft d | DataAlt d <- acs])-  where-    notLiteralReft   = maybe mempty F.notExprReft . snd . literalConst (emb γ)-    notDataConReft d | exactDC (getConfig γ)-                     = F.Reft (F.vv_, F.PNot (F.EApp (F.EVar $ makeDataConChecker d) (F.EVar F.vv_)))-                     | otherwise = mempty-altReft _ _ _        = panic Nothing "Constraint : altReft"--unfoldR :: SpecType -> SpecType -> [Var] -> (SpecType, [SpecType], SpecType)-unfoldR td (RApp _ ts rs _) ys = (t3, tvys ++ yts, ignoreOblig rt)-  where-        tbody              = instantiatePvs (instantiateTys td ts) (reverse rs)-        -- TODO: if we ever want to support applying implicits explicitly, will need to rejigger-        ((_,_,_,_),(ys0,_,yts',_), rt) = safeBkArrow (F.notracepp msg $ instantiateTys tbody tvs')-        msg                = "INST-TY: " ++ F.showpp (td, ts, tbody, ys, tvs')-        yts''              = zipWith F.subst sus (yts'++[rt])-        (t3,yts)           = (last yts'', init yts'')-        sus                = F.mkSubst <$> L.inits [(x, F.EVar y) | (x, y) <- zip ys0 ys']-        (αs, ys')          = mapSnd (F.symbol <$>) $ L.partition isTyVar ys-        tvs' :: [SpecType]-        tvs'               = rVar <$> αs-        tvys               = ofType . varType <$> αs--unfoldR _  _                _  = panic Nothing "Constraint.hs : unfoldR"--instantiateTys :: SpecType -> [SpecType] -> SpecType-instantiateTys = L.foldl' go-  where-    go (RAllT α tbody _) t = subsTyVarMeet' (ty_var_value α, t) tbody-    go _ _                 = panic Nothing "Constraint.instantiateTy"--instantiatePvs :: SpecType -> [SpecProp] -> SpecType-instantiatePvs           = L.foldl' go-  where-    go (RAllP p tbody) r = replacePreds "instantiatePv" tbody [(p, r)]-    go t               _ = errorP "" ("Constraint.instantiatePvs: t = " ++ showpp t)--checkTyCon :: (Outputable a) => (String, a) -> CGEnv -> SpecType -> SpecType-checkTyCon _ _ t@RApp{} = t-checkTyCon x g t        = checkErr x g t--checkFun :: (Outputable a) => (String, a) -> CGEnv -> SpecType -> SpecType-checkFun _ _ t@RFun{} = t-checkFun x g t        = checkErr x g t--checkAll :: (Outputable a) => (String, a) -> CGEnv -> SpecType -> SpecType-checkAll _ _ t@RAllT{} = t-checkAll x g t         = checkErr x g t--checkErr :: (Outputable a) => (String, a) -> CGEnv -> SpecType -> SpecType-checkErr (msg, e) γ t         = panic (Just sp) $ msg ++ GM.showPpr e ++ ", type: " ++ showpp t-  where-    sp                        = getLocation γ--varAnn :: CGEnv -> Var -> t -> Annot t-varAnn γ x t-  | x `S.member` recs γ      = AnnLoc (getSrcSpan x)-  | otherwise                = AnnUse t---------------------------------------------------------------------------- | Helpers: Creating Fresh Refinement --------------------------------------------------------------------------------------------------------freshPredRef :: CGEnv -> CoreExpr -> PVar RSort -> CG SpecProp-freshPredRef γ e (PV _ (PVProp rsort) _ as)-  = do t    <- freshTyType (typeclass (getConfig γ))  PredInstE e (toType False rsort)-       args <- mapM (const fresh) as-       let targs = [(x, s) | (x, (s, y, z)) <- zip args as, F.EVar y == z ]-       γ' <- foldM (+=) γ [("freshPredRef", x, ofRSort τ) | (x, τ) <- targs]-       addW $ WfC γ' t-       return $ RProp targs t--freshPredRef _ _ (PV _ PVHProp _ _)-  = todo Nothing "EFFECTS:freshPredRef"-------------------------------------------------------------------------------------- | Helpers: Creating Refinement Types For Various Things -------------------------------------------------------------------------------------------------------argType :: Type -> Maybe F.Expr-argType (LitTy (NumTyLit i))-  = mkI i-argType (LitTy (StrTyLit s))-  = mkS $ bytesFS s-argType (TyVarTy x)-  = Just $ F.EVar $ F.symbol $ varName x-argType t-  | F.symbol (GM.showPpr t) == anyTypeSymbol-  = Just $ F.EVar anyTypeSymbol-argType _-  = Nothing---argExpr :: CGEnv -> CoreExpr -> Maybe F.Expr-argExpr _ (Var v)     = Just $ F.eVar v-argExpr γ (Lit c)     = snd  $ literalConst (emb γ) c-argExpr γ (Tick _ e)  = argExpr γ e-argExpr γ (App e (Type _)) = argExpr γ e-argExpr _ _           = Nothing---lamExpr :: CGEnv -> CoreExpr -> CG (Maybe F.Expr)-lamExpr g e = do-    adts <- gets cgADTs-    allowTC <- gets cgiTypeclass-    let dm = dataConMap adts-    case runToLogic (emb g) mempty dm (\x -> todo Nothing ("coreToLogic not working lamExpr: " ++ x)) (coreToLogic allowTC e) of-               Left  _  -> return Nothing-               Right ce -> return (Just ce)-----------------------------------------------------------------------------------(??=) :: (?callStack :: CallStack) => CGEnv -> Var -> CG SpecType----------------------------------------------------------------------------------γ ??= x = case M.lookup x' (lcb γ) of-            Just e  -> consE (γ -= x') e-            Nothing -> refreshTy tx-          where-            x' = F.symbol x-            tx = fromMaybe tt (γ ?= x')-            tt = ofType $ varType x------------------------------------------------------------------------------------varRefType :: (?callStack :: CallStack) => CGEnv -> Var -> CG SpecType----------------------------------------------------------------------------------varRefType γ x =-  varRefType' γ x <$> (γ ??= x) -- F.tracepp (printf "varRefType x = [%s]" (showpp x))--varRefType' :: CGEnv -> Var -> SpecType -> SpecType-varRefType' γ x t'-  | Just tys <- trec γ, Just tr  <- M.lookup x' tys-  = strengthen' tr xr-  | otherwise-  = strengthen' t' xr-  where-    xr = singletonReft x-    x' = F.symbol x-    strengthen'-      | higherOrderFlag γ-      = strengthenMeet-      | otherwise-      = strengthenTop---- | create singleton types for function application-makeSingleton :: CGEnv -> CoreExpr -> SpecType -> SpecType-makeSingleton γ cexpr t-  | higherOrderFlag γ, App f x <- simplify cexpr-  = case (funExpr γ f, argForAllExpr x) of-      (Just f', Just x')-                 | not (if typeclass (getConfig γ) then GM.isEmbeddedDictExpr x else GM.isPredExpr x) -- (isClassPred $ exprType x)-                 -> strengthenMeet t (uTop $ F.exprReft (F.EApp f' x'))-      (Just f', Just _)-                 -> strengthenMeet t (uTop $ F.exprReft f')-      _ -> t-  | rankNTypes (getConfig γ)-  = case argExpr γ (simplify cexpr) of-       Just e' -> strengthenMeet t $ uTop (F.exprReft e')-       _       -> t-  | otherwise-  = t-  where-    argForAllExpr (Var x)-      | rankNTypes (getConfig γ)-      , Just e <- M.lookup x (forallcb γ)-      = Just e-    argForAllExpr e-      = argExpr γ e----funExpr :: CGEnv -> CoreExpr -> Maybe F.Expr--funExpr _ (Var v)-  = Just $ F.EVar (F.symbol v)--funExpr γ (App e1 e2)-  = case (funExpr γ e1, argExpr γ e2) of-      (Just e1', Just e2') | not (if typeclass (getConfig γ) then GM.isEmbeddedDictExpr e2 else GM.isPredExpr e2) -- (isClassPred $ exprType e2)-                           -> Just (F.EApp e1' e2')-      (Just e1', Just _)-                           -> Just e1'-      _                    -> Nothing--funExpr _ _-  = Nothing--simplify :: CoreExpr -> CoreExpr-simplify (Tick _ e)       = simplify e-simplify (App e (Type _)) = simplify e-simplify (App e1 e2)      = App (simplify e1) (simplify e2)-simplify (Lam x e) | isTyVar x = simplify e-simplify e                = e---singletonReft :: (F.Symbolic a) => a -> UReft F.Reft-singletonReft = uTop . F.symbolReft . F.symbol---- | RJ: `nomeet` replaces `strengthenS` for `strengthen` in the definition---   of `varRefType`. Why does `tests/neg/strata.hs` fail EVEN if I just replace---   the `otherwise` case? The fq file holds no answers, both are sat.-strengthenTop :: (PPrint r, F.Reftable r) => RType c tv r -> r -> RType c tv r-strengthenTop (RApp c ts rs r) r'  = RApp c ts rs $ F.meet r r'-strengthenTop (RVar a r) r'        = RVar a       $ F.meet r r'-strengthenTop (RFun b i t1 t2 r) r'= RFun b i t1 t2 $ F.meet r r'-strengthenTop (RAppTy t1 t2 r) r'  = RAppTy t1 t2 $ F.meet r r'-strengthenTop (RAllT a t r)    r'  = RAllT a t    $ F.meet r r'-strengthenTop t _                  = t---- TODO: this is almost identical to RT.strengthen! merge them!-strengthenMeet :: (PPrint r, F.Reftable r) => RType c tv r -> r -> RType c tv r-strengthenMeet (RApp c ts rs r) r'  = RApp c ts rs (r `F.meet` r')-strengthenMeet (RVar a r) r'        = RVar a       (r `F.meet` r')-strengthenMeet (RFun b i t1 t2 r) r'= RFun b i t1 t2 (r `F.meet` r')-strengthenMeet (RAppTy t1 t2 r) r'  = RAppTy t1 t2 (r `F.meet` r')-strengthenMeet (RAllT a t r) r'     = RAllT a (strengthenMeet t r') (r `F.meet` r')-strengthenMeet t _                  = t---- topMeet :: (PPrint r, F.Reftable r) => r -> r -> r--- topMeet r r' = r `F.meet` r'------------------------------------------------------------------------------------- | Cleaner Signatures For Rec-bindings -------------------------------------------------------------------------------------------------------------------------exprLoc                         :: CoreExpr -> Maybe SrcSpan-exprLoc (Tick tt _)             = Just $ GM.tickSrcSpan tt-exprLoc (App e a) | isType a    = exprLoc e-exprLoc _                       = Nothing--isType :: Expr CoreBndr -> Bool-isType (Type _)                 = True-isType a                        = eqType (exprType a) predType---- | @isGenericVar@ determines whether the @RTyVar@ has no class constraints-isGenericVar :: RTyVar -> SpecType -> Bool-isGenericVar α st =  all (\(c, α') -> (α'/=α) || isGenericClass c ) (classConstrs st)-  where-    classConstrs t = [(c, ty_var_value α')-                        | (c, ts) <- tyClasses t-                        , t'      <- ts-                        , α'      <- freeTyVars t']-    isGenericClass c = className c `elem` [ordClassName, eqClassName] -- , functorClassName, monadClassName]---- instance MonadFail CG where ---  fail msg = panic Nothing msg--instance MonadFail Data.Functor.Identity.Identity where-  fail msg = panic Nothing msg
− src/Language/Haskell/Liquid/Constraint/Init.hs 
@@ -1,305 +0,0 @@-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE MultiParamTypeClasses     #-}-{-# LANGUAGE OverloadedStrings         #-}---- | This module defines the representation of Subtyping and WF Constraints,---   and the code for syntax-directed constraint generation.--module Language.Haskell.Liquid.Constraint.Init (-    initEnv ,-    initCGI,-    ) where--import           Prelude                                       hiding (error, undefined)-import           Control.Monad.State-import           Data.Maybe                                    (isNothing, fromMaybe, catMaybes, mapMaybe)-import qualified Data.HashMap.Strict                           as M-import qualified Data.HashSet                                  as S-import qualified Data.List                                     as L-import           Data.Bifunctor-import qualified Language.Fixpoint.Types                       as F--import qualified Language.Haskell.Liquid.UX.CTags              as Tg-import           Language.Haskell.Liquid.Constraint.Fresh-import           Language.Haskell.Liquid.Constraint.Env-import           Language.Haskell.Liquid.WiredIn               (dictionaryVar)-import qualified Liquid.GHC.SpanStack         as Sp-import           Liquid.GHC.Misc             ( idDataConM, hasBaseTypeVar, isDataConId) -- dropModuleNames, simplesymbol)-import           Liquid.GHC.API               as Ghc hiding (mapSndM)-import           Language.Haskell.Liquid.Misc-import           Language.Fixpoint.Misc-import           Language.Haskell.Liquid.Constraint.Types--import           Language.Haskell.Liquid.Types hiding (binds, Loc, loc, freeTyVars, Def)-----------------------------------------------------------------------------------initEnv :: TargetInfo -> CG CGEnv----------------------------------------------------------------------------------initEnv info-  = do let tce   = gsTcEmbeds (gsName sp)-       let fVars = giImpVars (giSrc info)-       let dcs   = filter isConLikeId (snd <$> gsFreeSyms (gsName sp))-       let dcs'  = filter isConLikeId fVars-       defaults <- forM fVars $ \x -> fmap (x,) (trueTy allowTC $ varType x)-       dcsty    <- forM dcs   (makeDataConTypes allowTC)-       dcsty'   <- forM dcs'  (makeDataConTypes allowTC)-       (hs,f0)  <- refreshHoles allowTC $ grty info                           -- asserted refinements     (for defined vars)-       f0''     <- refreshArgs' =<< grtyTop info                      -- default TOP reftype      (for exported vars without spec)-       let f0'   = if notruetypes $ getConfig sp then [] else f0''-       f1       <- refreshArgs'   defaults                            -- default TOP reftype      (for all vars)-       f1'      <- refreshArgs' $ makeExactDc dcsty                   -- data constructors-       f2       <- refreshArgs' $ assm info                           -- assumed refinements      (for imported vars)-       f3'      <- refreshArgs' =<< recSelectorsTy info                      -- assumed refinements      (for record selectors)-       f3       <- addPolyInfo' <$> refreshArgs' (vals gsAsmSigs (gsSig sp))                 -- assumed refinedments     (with `assume`)-       f40      <- makeExactDc <$> refreshArgs' (vals gsCtors (gsData sp)) -- constructor refinements  (for measures)-       f5       <- refreshArgs' $ vals gsInSigs (gsSig sp)                   -- internal refinements     (from Haskell measures)-       fi       <- refreshArgs' $ catMaybes $ [(x,) . val <$> getMethodType mt | (x, mt) <- gsMethods $ gsSig $ giSpec info ]-       (invs1, f41) <- mapSndM refreshArgs' $ makeAutoDecrDataCons dcsty  (gsAutosize (gsTerm sp)) dcs-       (invs2, f42) <- mapSndM refreshArgs' $ makeAutoDecrDataCons dcsty' (gsAutosize (gsTerm sp)) dcs'-       let f4    = mergeDataConTypes tce (mergeDataConTypes tce f40 (f41 ++ f42)) (filter (isDataConId . fst) f2)-       let tx    = mapFst F.symbol . addRInv ialias . predsUnify sp-       f6       <- map tx . addPolyInfo' <$> refreshArgs' (vals gsRefSigs (gsSig sp))-       let bs    = (tx <$> ) <$> [f0 ++ f0' ++ fi, f1 ++ f1', f2, f3 ++ f3', f4, f5]-       modify $ \s -> s { dataConTys = f4 }-       lt1s     <- gets (F.toListSEnv . cgLits)-       let lt2s  = [ (F.symbol x, rTypeSort tce t) | (x, t) <- f1' ]-       let tcb   = mapSnd (rTypeSort tce) <$> concat bs-       let cbs   = giCbs . giSrc $ info-       rTrue   <- mapM (mapSndM (true allowTC)) f6-       let γ0    = measEnv sp (head bs) cbs tcb lt1s lt2s (f6 ++ bs!!3) (bs!!5) hs info-       γ  <- globalize <$> foldM (+=) γ0 ( [("initEnv", x, y) | (x, y) <- concat (rTrue:tail bs)])-       return γ {invs = is (invs1 ++ invs2)}-  where-    allowTC      = typeclass (getConfig info)-    sp           = giSpec info-    ialias       = mkRTyConIAl (gsIaliases (gsData sp))-    vals f       = map (mapSnd val) . f-    is autoinv   = mkRTyConInv    (gsInvariants (gsData sp) ++ ((Nothing,) <$> autoinv))-    addPolyInfo' = if reflection (getConfig info) then map (mapSnd addPolyInfo) else id--    makeExactDc dcs = if exactDCFlag info then map strengthenDataConType dcs else dcs--addPolyInfo :: SpecType -> SpecType-addPolyInfo t = mkUnivs (go <$> as) ps t'-  where-    (as, ps, t') = bkUniv t-    pos          = tyVarsPosition t'-    go (a,r) = if {- ty_var_value a `elem` ppos pos && -}  ty_var_value a `notElem` pneg pos-               then (setRtvPol a False,r)-               else (a,r)--makeDataConTypes :: Bool -> Var -> CG (Var, SpecType)-makeDataConTypes allowTC x = (x,) <$> trueTy allowTC (varType x)--makeAutoDecrDataCons :: [(Id, SpecType)] -> S.HashSet TyCon -> [Id] -> ([LocSpecType], [(Id, SpecType)])-makeAutoDecrDataCons dcts specenv dcs-  = (simplify rsorts, tys)-  where-    (rsorts, tys) = unzip $ concatMap go tycons-    tycons      = L.nub $ mapMaybe idTyCon dcs--    go tycon-      | S.member tycon specenv =  zipWith (makeSizedDataCons dcts) (tyConDataCons tycon) [0..]-    go _-      = []--    simplify invs = dummyLoc . (`strengthen` invariant) .  fmap (const mempty) <$> L.nub invs-    invariant = MkUReft (F.Reft (F.vv_, F.PAtom F.Ge (lenOf F.vv_) (F.ECon $ F.I 0)) ) mempty--idTyCon :: Id -> Maybe TyCon-idTyCon = fmap dataConTyCon . idDataConM--lenOf :: F.Symbol -> F.Expr-lenOf x = F.mkEApp lenLocSymbol [F.EVar x]--makeSizedDataCons :: [(Id, SpecType)] -> DataCon -> Integer -> (RSort, (Id, SpecType))-makeSizedDataCons dcts x' n = (toRSort $ ty_res trep, (x, fromRTypeRep trep{ty_res = tres}))-    where-      x      = dataConWorkId x'-      st     = fromMaybe (impossible Nothing "makeSizedDataCons: this should never happen") $ L.lookup x dcts-      trep   = toRTypeRep st-      tres   = ty_res trep `strengthen` MkUReft (F.Reft (F.vv_, F.PAtom F.Eq (lenOf F.vv_) computelen)) mempty--      recarguments = filter (\(t,_) -> toRSort t == toRSort tres) (zip (ty_args trep) (ty_binds trep))-      computelen   = foldr (F.EBin F.Plus) (F.ECon $ F.I n) (lenOf .  snd <$> recarguments)--mergeDataConTypes ::  F.TCEmb TyCon -> [(Var, SpecType)] -> [(Var, SpecType)] -> [(Var, SpecType)]-mergeDataConTypes tce xts yts = merge (L.sortBy f xts) (L.sortBy f yts)-  where-    f (x,_) (y,_) = compare x y-    merge [] ys = ys-    merge xs [] = xs-    merge (xt@(x, tx):xs) (yt@(y, ty):ys)-      | x == y    = (x, mXY x tx y ty) : merge xs ys-      | x <  y    = xt : merge xs (yt : ys)-      | otherwise = yt : merge (xt : xs) ys-    mXY x tx y ty = meetVarTypes tce (F.pprint x) (getSrcSpan x, tx) (getSrcSpan y, ty)--refreshArgs' :: [(a, SpecType)] -> CG [(a, SpecType)]-refreshArgs' = mapM (mapSndM refreshArgs)----- | TODO: All this *should* happen inside @Bare@ but appears---   to happen after certain are signatures are @fresh@-ed,---   which is why they are here.---- NV : still some sigs do not get TyConInfo--predsUnify :: TargetSpec -> (Var, RRType RReft) -> (Var, RRType RReft)-predsUnify sp = second (addTyConInfo tce tyi) -- needed to eliminate some @RPropH@-  where-    tce            = gsTcEmbeds (gsName sp)-    tyi            = gsTyconEnv (gsName sp)------------------------------------------------------------------------------------measEnv :: TargetSpec-        -> [(F.Symbol, SpecType)]-        -> [CoreBind]-        -> [(F.Symbol, F.Sort)]-        -> [(F.Symbol, F.Sort)]-        -> [(F.Symbol, F.Sort)]-        -> [(F.Symbol, SpecType)]-        -> [(F.Symbol, SpecType)]-        -> [F.Symbol]-        -> TargetInfo-        -> CGEnv----------------------------------------------------------------------------------measEnv sp xts cbs _tcb lt1s lt2s asms itys hs info = CGE-  { cgLoc    = Sp.empty-  , renv     = fromListREnv (second val <$> gsMeas (gsData sp)) []-  , syenv    = F.fromListSEnv (gsFreeSyms (gsName sp))-  , litEnv   = F.fromListSEnv lts-  , constEnv = F.fromListSEnv lt2s-  , fenv     = initFEnv $ filterHO (tcb' ++ lts ++ (second (rTypeSort tce . val) <$> gsMeas (gsData sp)))-  , denv     = dmapty val $ gsDicts (gsSig sp)-  , recs     = S.empty-  , invs     = mempty-  , rinvs    = mempty-  , ial      = mkRTyConIAl (gsIaliases (gsData sp))-  , grtys    = fromListREnv xts  []-  , assms    = fromListREnv asms []-  , intys    = fromListREnv itys []-  , emb      = tce-  , tgEnv    = Tg.makeTagEnv cbs-  , tgKey    = Nothing-  , trec     = Nothing-  , lcb      = M.empty-  , forallcb = M.empty-  , holes    = fromListHEnv hs-  , lcs      = mempty-  , cerr     = Nothing-  , cgInfo   = info-  , cgVar    = Nothing-  }-  where-      tce         = gsTcEmbeds (gsName sp)-      filterHO xs = if higherOrderFlag sp then xs else filter (F.isFirstOrder . snd) xs-      lts         = lt1s ++ lt2s-      tcb'        = []---assm :: TargetInfo -> [(Var, SpecType)]-assm = assmGrty (giImpVars . giSrc)--grty :: TargetInfo -> [(Var, SpecType)]-grty = assmGrty (giDefVars . giSrc)--assmGrty :: (TargetInfo -> [Var]) -> TargetInfo -> [(Var, SpecType)]-assmGrty f info = [ (x, val t) | (x, t) <- sigs, x `S.member` xs ]-  where-    xs          = S.fromList . f             $ info-    sigs        = gsTySigs  . gsSig . giSpec $ info---recSelectorsTy :: TargetInfo -> CG [(Var, SpecType)]-recSelectorsTy info = forM topVs $ \v -> (v,) <$> trueTy (typeclass (getConfig info)) (varType v)-  where-    topVs        = filter isTop $ giDefVars (giSrc info)-    isTop v      = isExportedVar (giSrc info) v && not (v `S.member` sigVs) &&  isRecordSelector v-    sigVs        = S.fromList [v | (v,_) <- gsTySigs sp ++ gsAsmSigs sp ++ gsRefSigs sp ++ gsInSigs sp]-    sp           = gsSig . giSpec $ info----grtyTop :: TargetInfo -> CG [(Var, SpecType)]-grtyTop info     = forM topVs $ \v -> (v,) <$> trueTy (typeclass (getConfig info)) (varType v)-  where-    topVs        = filter isTop $ giDefVars (giSrc info)-    isTop v      = isExportedVar (giSrc info) v && not (v `S.member` sigVs) && not (isRecordSelector v)-    sigVs        = S.fromList [v | (v,_) <- gsTySigs sp ++ gsAsmSigs sp ++ gsRefSigs sp ++ gsInSigs sp]-    sp           = gsSig . giSpec $ info---infoLits :: (TargetSpec -> [(F.Symbol, LocSpecType)]) -> (F.Sort -> Bool) -> TargetInfo -> F.SEnv F.Sort-infoLits litF selF info = F.fromListSEnv $ cbLits ++ measLits-  where-    cbLits    = filter (selF . snd) $ coreBindLits tce info-    measLits  = filter (selF . snd) $ mkSort <$> litF spc-    spc       = giSpec info-    tce       = gsTcEmbeds (gsName spc)-    mkSort    = mapSnd (F.sr_sort . rTypeSortedReft tce . val)--initCGI :: Config -> TargetInfo -> CGInfo-initCGI cfg info = CGInfo {-    fEnv       = F.emptySEnv-  , hsCs       = []-  , hsWfs      = []-  , fixCs      = []-  , fixWfs     = []-  , freshIndex = 0-  , dataConTys = []-  , binds      = F.emptyBindEnv-  , ebinds     = []-  , annotMap   = AI M.empty-  , holesMap   = M.empty-  , newTyEnv   = M.fromList (mapSnd val <$> gsNewTypes (gsSig spc))-  , tyConInfo  = tyi-  , tyConEmbed = tce-  , kuts       = mempty-  , kvPacks    = mempty-  , cgLits     = infoLits (gsMeas . gsData) (const True) info-  , cgConsts   = infoLits (gsMeas . gsData) notFn        info-  , cgADTs     = gsADTs nspc-  , termExprs  = M.fromList [(v, es) | (v, _, es) <- gsTexprs (gsSig spc) ]-  , specDecr   = gsDecr  tspc-  , specLVars  = gsLvars (gsVars spc)-  , specLazy   = dictionaryVar `S.insert` gsLazy tspc-  , specTmVars = gsNonStTerm tspc-  , tcheck     = terminationCheck cfg-  , cgiTypeclass = typeclass cfg-  , pruneRefs  = pruneUnsorted cfg-  , logErrors  = []-  , kvProf     = emptyKVProf-  , recCount   = 0-  , bindSpans  = M.empty-  , autoSize   = gsAutosize tspc-  , allowHO    = higherOrderFlag cfg-  , ghcI       = info-  , unsorted   = F.notracepp "UNSORTED" $ F.makeTemplates $ gsUnsorted $ gsData spc-  }-  where-    tce        = gsTcEmbeds nspc-    tspc       = gsTerm spc-    spc        = giSpec info-    tyi        = gsTyconEnv nspc-    nspc       = gsName spc-    notFn      = isNothing . F.functionSort--coreBindLits :: F.TCEmb TyCon -> TargetInfo -> [(F.Symbol, F.Sort)]-coreBindLits tce info-  = sortNub      $ [ (F.symbol x, F.strSort) | (_, Just (F.ESym x)) <- lconsts ]    -- strings-                ++ [ (dconToSym dc, dconToSort dc) | dc <- dcons ]                  -- data constructors-  where-    src         = giSrc info-    lconsts      = literalConst tce <$> literals (giCbs src)-    dcons        = filter isDCon freeVs-    freeVs       = giImpVars src ++ freeSyms-    freeSyms     = fmap snd . gsFreeSyms . gsName . giSpec $ info-    dconToSort   = typeSort tce . expandTypeSynonyms . varType-    dconToSym    = F.symbol . idDataCon-    isDCon x     = isDataConId x && not (hasBaseTypeVar x)
− src/Language/Haskell/Liquid/Constraint/Monad.hs 
@@ -1,141 +0,0 @@--- | This module contains various functions that add/update in the CG monad.--{-# LANGUAGE BangPatterns              #-}-{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE FlexibleContexts          #-}--module Language.Haskell.Liquid.Constraint.Monad  where--import qualified Data.HashMap.Strict as M-import qualified Data.Text           as T--import           Control.Monad-import           Control.Monad.State (get, gets, modify)-import           Language.Haskell.Liquid.Types hiding (loc)-import           Language.Haskell.Liquid.Constraint.Types-import           Language.Haskell.Liquid.Constraint.Env-import           Language.Fixpoint.Misc hiding (errorstar)-import           Liquid.GHC.Misc -- (concatMapM)-import           Liquid.GHC.SpanStack (srcSpan)-import           Liquid.GHC.API as Ghc hiding (panic, showPpr)------------------------------------------------------------------------------------- | `addC` adds a subtyping constraint into the global pool.----------------------------------------------------------------------------------addC :: SubC -> String -> CG ()----------------------------------------------------------------------------------addC c@(SubC γ t1 t2) _msg-  | toType False t1 /= toType False t2-  = panic (Just $ getLocation γ) $ "addC: malformed constraint:\n" ++ _msg ++ showpp t1 ++ "\n <: \n" ++ showpp t2-  | otherwise-  = modify $ \s -> s { hsCs  = c : hsCs s }---addC c _msg-  = modify $ \s -> s { hsCs  = c : hsCs s }------------------------------------------------------------------------------------- | addPost: RJ: what DOES this function do?----------------------------------------------------------------------------------addPost :: CGEnv -> SpecType -> CG SpecType----------------------------------------------------------------------------------addPost cgenv (RRTy e r OInv rt)-  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("addPost", x,t)) cgenv e-       addC (SubR γ' OInv r) "precondition-oinv" >> return rt--addPost cgenv (RRTy e r OTerm rt)-  = do γ' <- foldM (\γ (x, t) -> γ += ("addPost", x, t)) cgenv e-       addC (SubR γ' OTerm r) "precondition-oterm" >> return rt--addPost cgenv (RRTy cts _ OCons rt)-  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) cgenv xts-       addC (SubC  γ' t1 t2)  "precondition-ocons"-       addPost cgenv rt-  where-    (xts, t1, t2) = envToSub cts-addPost _ t-  = return t------------------------------------------------------------------------------------- | Add Well formedness Constraint----------------------------------------------------------------------------------addW   :: WfC -> CG ()----------------------------------------------------------------------------------addW !w = modify $ \s -> s { hsWfs = w : hsWfs s }------------------------------------------------------------------------------------- | Add a warning----------------------------------------------------------------------------------addWarning   :: Error -> CG ()----------------------------------------------------------------------------------addWarning w = modify $ \s -> s { logErrors = w : logErrors s }---- | Add Identifier Annotations, used for annotation binders (i.e. at binder sites)-addIdA            :: Var -> Annot SpecType -> CG ()-addIdA !x !t      = modify $ \s -> s { annotMap = upd $ annotMap s }-  where-    l             = getSrcSpan x-    upd m@(AI _)  = if boundRecVar l m then m else addA l (Just x) t m--boundRecVar :: SrcSpan -> AnnInfo (Annot a) -> Bool-boundRecVar l (AI m) = not $ null [t | (_, AnnRDf t) <- M.lookupDefault [] l m]----- | Used for annotating reads (i.e. at Var x sites)--addLocA :: Maybe Var -> SrcSpan -> Annot SpecType -> CG ()-addLocA !xo !l !t-  = modify $ \s -> s { annotMap = addA l xo t $ annotMap s }----- | Used for annotating holes --addHole :: Var -> SpecType -> CGEnv -> CG ()-addHole x t γ-  | typedHoles (getConfig γ) =-      do  st <- get-          modify $ \s -> s {holesMap = M.insert x (hinfo (st, γ)) $ holesMap s}-          -- addWarning $ ErrHole loc ("hole found") (reGlobal env <> reLocal env) x' t -  | otherwise = return ()-    where-      hinfo = HoleInfo t loc env-      loc   = srcSpan $ cgLoc γ-      env   = mconcat [renv γ, grtys γ, assms γ, intys γ]------------------------------------------------------------------------------------- | Update annotations for a location, due to (ghost) predicate applications----------------------------------------------------------------------------------updateLocA :: Maybe SrcSpan -> SpecType -> CG ()----------------------------------------------------------------------------------updateLocA (Just l) t = addLocA Nothing l (AnnUse t)-updateLocA _        _ = return ()--------------------------------------------------------------------------------------------------------------------------------------------------------------------addA :: (Outputable a) => SrcSpan -> Maybe a -> b -> AnnInfo b -> AnnInfo b----------------------------------------------------------------------------------addA !l xo@(Just _) !t (AI m)-  | isGoodSrcSpan l-  = AI $ inserts l (T.pack . showPpr <$> xo, t) m-addA !l xo@Nothing  !t (AI m)-  | l `M.member` m                  -- only spans known to be variables-  = AI $ inserts l (T.pack . showPpr <$> xo, t) m-addA _ _ _ !a-  = a---lookupNewType :: Ghc.TyCon -> CG (Maybe SpecType)-lookupNewType tc-  = gets (M.lookup tc . newTyEnv)------------------------------------------------------------------------------------{-@ envToSub :: {v:[(a, b)] | 2 <= len v} -> ([(a, b)], b, b) @-}-envToSub :: [(a, b)] -> ([(a, b)], b, b)----------------------------------------------------------------------------------envToSub = go []-  where-    go _   []              = impossible Nothing "This cannot happen: envToSub on 0 elems"-    go _   [(_,_)]         = impossible Nothing "This cannot happen: envToSub on 1 elem"-    go ack [(_,l), (_, r)] = (reverse ack, l, r)-    go ack (x:xs)          = go (x:ack) xs
− src/Language/Haskell/Liquid/Constraint/Qualifier.hs 
@@ -1,242 +0,0 @@-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE FlexibleContexts      #-}--{-# OPTIONS_GHC -Wno-name-shadowing #-}--module Language.Haskell.Liquid.Constraint.Qualifier-  ( giQuals-  , useSpcQuals-  )-  where--import           Prelude hiding (error)-import           Data.List                (delete, nub)-import           Data.Maybe               (isJust, catMaybes, fromMaybe, isNothing)-import qualified Data.HashSet        as S-import qualified Data.HashMap.Strict as M-import           Language.Fixpoint.Types                  hiding (panic, mkQual)-import qualified Language.Fixpoint.Types.Config as FC-import           Language.Fixpoint.SortCheck-import           Language.Haskell.Liquid.Types.RefType-import           Liquid.GHC.Misc         (getSourcePos)-import           Language.Haskell.Liquid.Misc             (condNull)-import           Language.Haskell.Liquid.Types.PredType-import           Liquid.GHC.API hiding (Expr, mkQual, panic)--import           Language.Haskell.Liquid.Types------------------------------------------------------------------------------------giQuals :: TargetInfo -> SEnv Sort -> [Qualifier]----------------------------------------------------------------------------------giQuals info lEnv-  =  notracepp ("GI-QUALS: " ++ showpp lEnv)-  $  condNull (useSpcQuals info) (gsQualifiers . gsQual . giSpec $ info)-  ++ condNull (useSigQuals info) (sigQualifiers  info lEnv)-  ++ condNull (useAlsQuals info) (alsQualifiers  info lEnv)---- ----------------------------------------------------------------------------------- qualifiers :: GhcInfo -> SEnv Sort -> [Qualifier]--- ----------------------------------------------------------------------------------- qualifiers info env = spcQs ++ genQs-  -- where-    -- spcQs           = gsQualifiers spc-    -- genQs           = specificationQualifiers info env-    -- n               = maxParams (getConfig spc)-    -- spc             = spec info--maxQualParams :: (HasConfig t) => t -> Int-maxQualParams = maxParams . getConfig---- | Use explicitly given qualifiers .spec or source (.hs, .lhs) files-useSpcQuals :: (HasConfig t) => t -> Bool-useSpcQuals i = useQuals i && not (useAlsQuals i)---- | Scrape qualifiers from function signatures (incr :: x:Int -> {v:Int | v > x})-useSigQuals :: (HasConfig t) => t -> Bool-useSigQuals i = useQuals i && not (useAlsQuals i)---- | Scrape qualifiers from refinement type aliases (type Nat = {v:Int | 0 <= 0})-useAlsQuals :: (HasConfig t) => t -> Bool-useAlsQuals i = useQuals i && i `hasOpt` higherOrderFlag && not (needQuals i)--useQuals :: (HasConfig t) => t -> Bool-useQuals = (FC.All /=) . eliminate . getConfig--needQuals :: (HasConfig t) => t -> Bool-needQuals = (FC.None == ) . eliminate . getConfig-----------------------------------------------------------------------------------alsQualifiers :: TargetInfo -> SEnv Sort -> [Qualifier]----------------------------------------------------------------------------------alsQualifiers info lEnv-  = [ q | a <- gsRTAliases . gsQual . giSpec $ info-        , q <- refTypeQuals lEnv (loc a) tce (rtBody (val a))-        , length (qParams q) <= k + 1-        , validQual lEnv q-    ]-    where-      k   = maxQualParams info-      tce = gsTcEmbeds . gsName . giSpec $ info--validQual :: SEnv Sort -> Qualifier -> Bool-validQual lEnv q = isJust $ checkSortExpr (srcSpan q) env (qBody q)-  where-    env          = unionSEnv lEnv qEnv-    qEnv         = M.fromList (qualBinds q)------------------------------------------------------------------------------------sigQualifiers :: TargetInfo -> SEnv Sort -> [Qualifier]----------------------------------------------------------------------------------sigQualifiers info lEnv-  = [ q | (x, t) <- specBinders info-        , x `S.member` qbs-        , q <- refTypeQuals lEnv (getSourcePos x) tce (val t)-        -- NOTE: large qualifiers are VERY expensive, so we only mine-        -- qualifiers up to a given size, controlled with --max-params-        , length (qParams q) <= k + 1-    ]-    where-      k   = maxQualParams info-      tce = gsTcEmbeds . gsName . giSpec $ info-      qbs = qualifyingBinders info--qualifyingBinders :: TargetInfo -> S.HashSet Var-qualifyingBinders info = S.difference sTake sDrop-  where-    sTake              = S.fromList $ giDefVars src ++ giUseVars src ++ scrapeVars cfg src-    sDrop              = S.fromList $ specAxiomVars info-    cfg                = getConfig info-    src                = giSrc     info---- NOTE: this mines extra, useful qualifiers but causes--- a significant increase in running time, so we hide it--- behind `--scrape-imports` and `--scrape-used-imports`-scrapeVars :: Config -> TargetSrc -> [Var]-scrapeVars cfg src-  | cfg `hasOpt` scrapeUsedImports = giUseVars src-  | cfg `hasOpt` scrapeImports     = giImpVars src-  | otherwise                      = []--specBinders :: TargetInfo -> [(Var, LocSpecType)]-specBinders info = mconcat-  [ gsTySigs  (gsSig  sp)-  , gsAsmSigs (gsSig  sp)-  , gsRefSigs (gsSig  sp)-  , gsCtors   (gsData sp)-  , if info `hasOpt` scrapeInternals then gsInSigs (gsSig sp) else []-  ]-  where-    sp  = giSpec info--specAxiomVars :: TargetInfo -> [Var]-specAxiomVars =  gsReflects . gsRefl . giSpec---- GRAVEYARD: scraping quals from imports kills the system with too much crap--- specificationQualifiers info = {- filter okQual -} qs---   where---     qs                       = concatMap refTypeQualifiers ts---     refTypeQualifiers        = refTypeQuals $ tcEmbeds spc---     ts                       = val <$> t1s ++ t2s---     t1s                      = [t | (x, t) <- tySigs spc, x `S.member` definedVars]---     t2s                      = [] -- [t | (_, t) <- ctor spc                            ]---     definedVars              = S.fromList $ defVars info---     spc                      = spec info------ okQual                       = not . any isPred . map snd . q_params---   where---     isPred (FApp tc _)       = tc == stringFTycon "Pred"---     isPred _                 = False----- TODO: rewrite using foldReft'----------------------------------------------------------------------------------refTypeQuals :: SEnv Sort -> SourcePos -> TCEmb TyCon -> SpecType -> [Qualifier]----------------------------------------------------------------------------------refTypeQuals lEnv l tce t0    = go emptySEnv t0-  where-    scrape                    = refTopQuals lEnv l tce t0-    add x t γ                 = insertSEnv x (rTypeSort tce t) γ-    goBind x t γ t'           = go (add x t γ) t'-    go γ t@(RVar _ _)         = scrape γ t-    go γ (RAllT _ t _)        = go γ t-    go γ (RAllP p t)          = go (insertSEnv (pname p) (rTypeSort tce (pvarRType p :: RSort)) γ) t-    go γ t@(RAppTy t1 t2 _)   = go γ t1 ++ go γ t2 ++ scrape γ t-    go γ (RFun x _ t t' _)    = go γ t ++ goBind x t γ t'-    go γ t@(RApp c ts rs _)   = scrape γ t ++ concatMap (go γ') ts ++ goRefs c γ' rs-                                where γ' = add (rTypeValueVar t) t γ-    go γ (RAllE x t t')       = go γ t ++ goBind x t γ t'-    go γ (REx x t t')         = go γ t ++ goBind x t γ t'-    go _ _                    = []-    goRefs c g rs             = concat $ zipWith (goRef g) rs (rTyConPVs c)-    goRef _ (RProp _ (RHole _)) _ = []-    goRef g (RProp s t)  _    = go (insertsSEnv g s) t-    insertsSEnv               = foldr (\(x, t) γ -> insertSEnv x (rTypeSort tce t) γ)---refTopQuals :: (PPrint t, Reftable t, SubsTy RTyVar RSort t, Reftable (RTProp RTyCon RTyVar (UReft t)))-            => SEnv Sort-            -> SourcePos-            -> TCEmb TyCon-            -> RType RTyCon RTyVar r-            -> SEnv Sort-            -> RRType (UReft t)-            -> [Qualifier]-refTopQuals lEnv l tce t0 γ t-  = [ mkQ v so pa  | let (RR so (Reft (v, ra))) = rTypeSortedReft tce t-                   , pa                        <- conjuncts ra-                   , not $ isHole    pa-                   , not $ isGradual pa-                   , notracepp ("refTopQuals: " ++ showpp pa)-                     $ isNothing $ checkSorted (srcSpan l) (insertSEnv v so γ') pa-    ]-    ++-    [ mkP s e | let (MkUReft _ (Pr ps)) = fromMaybe (msg t) $ stripRTypeBase t-              , p                      <- findPVar (ty_preds $ toRTypeRep t0) <$> ps-              , (s, _, e)              <- pargs p-    ]-    where-      mkQ   = mkQual  lEnv l     t0 γ-      mkP   = mkPQual lEnv l tce t0 γ-      msg t = panic Nothing $ "Qualifier.refTopQuals: no typebase" ++ showpp t-      γ'    = unionSEnv' γ lEnv--mkPQual :: (PPrint r, Reftable r, SubsTy RTyVar RSort r, Reftable (RTProp RTyCon RTyVar r))-        => SEnv Sort-        -> SourcePos-        -> TCEmb TyCon-        -> t-        -> SEnv Sort-        -> RRType r-        -> Expr-        -> Qualifier-mkPQual lEnv l tce t0 γ t e = mkQual lEnv l t0 γ' v so pa-  where-    v                      = "vv"-    so                     = rTypeSort tce t-    γ'                     = insertSEnv v so γ-    pa                     = PAtom Eq (EVar v) e--mkQual :: SEnv Sort-       -> SourcePos-       -> t-       -> SEnv Sort-       -> Symbol-       -> Sort-       -> Expr-       -> Qualifier-mkQual lEnv l _ γ v so p   = mkQ "Auto" ((v, so) : xts) p l-  where-    xs   = delete v $ nub $ syms p-    xts  = catMaybes $ zipWith (envSort l lEnv γ) xs [0..]--envSort :: SourcePos -> SEnv Sort -> SEnv Sort -> Symbol -> Integer -> Maybe (Symbol, Sort)-envSort l lEnv tEnv x i-  | Just t <- lookupSEnv x tEnv = Just (x, t)-  | Just _ <- lookupSEnv x lEnv = Nothing-  | otherwise                   = Just (x, ai)-  where-    ai             = trace msg $ fObj $ Loc l l $ tempSymbol "LHTV" i-    msg            = "Unknown symbol in qualifier: " ++ show x
− src/Language/Haskell/Liquid/Constraint/Relational.hs 
@@ -1,791 +0,0 @@-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE NoMonomorphismRestriction  #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE PatternGuards              #-}-{-# LANGUAGE ScopedTypeVariables        #-}---- | This module defines the representation of Subtyping and WF Constraints,---   and the code for syntax-directed constraint generation.--module Language.Haskell.Liquid.Constraint.Relational (consAssmRel, consRelTop) where--import           Control.Monad.State-import           Data.Bifunctor                                 ( Bifunctor(bimap) )-import qualified Data.HashMap.Strict                            as M-import qualified Data.List                                      as L-import           Data.String                                    ( IsString(..) )-import qualified Language.Fixpoint.Types                        as F-import qualified Language.Fixpoint.Types.Visitor                as F-import           Language.Haskell.Liquid.Constraint.Env-import           Language.Haskell.Liquid.Constraint.Fresh-import           Language.Haskell.Liquid.Constraint.Monad-import           Language.Haskell.Liquid.Constraint.Types-import           Liquid.GHC.API                 ( Alt-                                                , AltCon(..)-                                                , Bind(..)-                                                , CoreBind-                                                , CoreBndr-                                                , CoreExpr-                                                , Expr(..)-                                                , Type(..)-                                                , TyVar-                                                , Var(..))-import qualified Liquid.GHC.API                as Ghc-import qualified Liquid.GHC.Misc               as GM-import           Liquid.GHC.Play               (Subable(sub, subTy))-import qualified Liquid.GHC.SpanStack          as Sp-import           Liquid.GHC.TypeRep            ()-import           Language.Haskell.Liquid.Misc-import           Language.Haskell.Liquid.Types                  hiding (Def,-                                                                 Loc, binds,-                                                                 loc)-import           System.Console.CmdArgs.Verbosity               (whenLoud)-import           System.IO.Unsafe                               (unsafePerformIO)--data RelPred-  = RelPred { fun1 :: Var-            , fun2 :: Var-            , args1 :: [(F.Symbol, [F.Symbol])]-            , args2 :: [(F.Symbol, [F.Symbol])]-            , prop :: RelExpr-            } deriving Show--type PrEnv = [RelPred]--consAssmRel :: Config -> TargetInfo -> (PrEnv, CGEnv) -> (Var, Var, LocSpecType, LocSpecType, RelExpr, RelExpr) -> CG (PrEnv, CGEnv)-consAssmRel _ _ (ψ, γ) (x, y, t, s, _, rp) = traceChk "Assm" x y t s p $ do-  traceWhenLoud ("ASSUME " ++ F.showpp (fromRelExpr p', p)) $ subUnarySig γ' x t'-  subUnarySig γ' y s'-  γ'' <- if base t' && base s'-    then γ' `addPred` F.subst-      (F.mkSubst [(resL, F.EVar $ F.symbol x), (resR, F.EVar $ F.symbol y)])-      (fromRelExpr rp)-    else return γ'-  return (RelPred x' y' bs cs rp : ψ, γ'')- where-    p = fromRelExpr rp-    γ' = γ `setLocation` Sp.Span (GM.fSrcSpan (F.loc t))-    (x', y') = mkRelCopies x y-    t' = val t-    s' = val s-    (vs, ts) = vargs t'-    (us, ss) = vargs s'-    bs = zip vs (fst . vargs <$> ts)-    cs = zip us (fst . vargs <$> ss)-    p' = L.foldl (\q (v, u) -> unapplyRelArgsR v u q) rp (zip vs us)--consRelTop :: Config -> TargetInfo -> CGEnv -> PrEnv -> (Var, Var, LocSpecType, LocSpecType, RelExpr, RelExpr) -> CG ()-consRelTop _ ti γ ψ (x, y, t, s, ra, rp) = traceChk "Init" e d t s p $ do-  subUnarySig γ' x t'-  subUnarySig γ' y s'-  consRelCheckBind γ' ψ e d t' s' ra rp-  where-    p = fromRelExpr rp-    γ' = γ `setLocation` Sp.Span (GM.fSrcSpan (F.loc t))-    cbs = giCbs $ giSrc ti-    e = lookupBind x cbs-    d = lookupBind y cbs-    t' = removeAbsRef $ val t-    s' = removeAbsRef $ val s--removeAbsRef :: SpecType -> SpecType-removeAbsRef (RVar v (MkUReft r _)) -  = out-    where -      r' = MkUReft r mempty-      out = RVar  v r' -removeAbsRef (RFun  b i s t (MkUReft r _))  -  = out-    where -      r' = MkUReft r mempty-      out = RFun  b i (removeAbsRef s) (removeAbsRef t) r'-removeAbsRef (RImpF b i s t (MkUReft r _))  -  = out-    where -      r' = MkUReft r mempty-      out = RImpF b i (removeAbsRef s) (removeAbsRef t) r'-removeAbsRef (RAllT b t r)      -  = RAllT b (removeAbsRef t) r-removeAbsRef (RAllP p t)        -  = removeAbsRef (forgetRAllP p t)-removeAbsRef (RApp  (RTyCon c _ i) as _ (MkUReft r _))   -  = out-    where -      c' = RTyCon c [] i-      as' = map removeAbsRef as-      r' = MkUReft r mempty-      out = RApp c' as' [] r'-removeAbsRef (RAllE b a t)      -  = RAllE b (removeAbsRef a) (removeAbsRef t)-removeAbsRef (REx   b a t)      -  = REx   b (removeAbsRef a) (removeAbsRef t)-removeAbsRef (RAppTy s t r)     -  = RAppTy (removeAbsRef s) (removeAbsRef t) r-removeAbsRef (RRTy  e r o t)    -  = RRTy  e r o (removeAbsRef t)-removeAbsRef t -  = t------------------------------------------------------------------- Core Checking Rules --------------------------------------------------------------------------------------------------------resL, resR :: F.Symbol-resL = fromString "r1"-resR = fromString "r2"--relSuffixL, relSuffixR :: String-relSuffixL = "l"-relSuffixR = "r"---- recursion rule-consRelCheckBind :: CGEnv -> PrEnv -> CoreBind -> CoreBind -> SpecType -> SpecType -> RelExpr -> RelExpr -> CG ()-consRelCheckBind γ ψ b1@(NonRec _ e1) b2@(NonRec _ e2) t1 t2 ra rp-  | Nothing <- args e1 e2 t1 t2 p =-  traceChk "Bind NonRec" b1 b2 t1 t2 p $ do-    γ' <- γ `addPred` a-    consRelCheck γ' ψ e1 e2 t1 t2 p-  where-    a = fromRelExpr ra-    p = fromRelExpr rp--consRelCheckBind γ ψ (NonRec x1 e1) b2 t1 t2 a p =-  consRelCheckBind γ ψ (Rec [(x1, e1)]) b2 t1 t2 a p--consRelCheckBind γ ψ b1 (NonRec x2 e2) t1 t2 a p =-  consRelCheckBind γ ψ b1 (Rec [(x2, e2)]) t1 t2 a p--consRelCheckBind γ ψ b1@(Rec [(f1, e1)]) b2@(Rec [(f2, e2)]) t1 t2 ra rp-  | Just (xs1, xs2, vs1, vs2, ts1, ts2, qs) <- args e1 e2 t1 t2 p-  = traceChk "Bind Rec" b1 b2 t1 t2 p $ do-    forM_ (refts t1 ++ refts t2) (\r -> entlFunReft γ r "consRelCheckBind Rec")-    let xs' = zipWith mkRelCopies xs1 xs2-    let (xs1', xs2') = unzip xs'-    let (e1'', e2'') = L.foldl' subRel (e1', e2') (zip xs1 xs2)-    γ' <- γ += ("Bind Rec f1", F.symbol f1', t1) >>= (+= ("Bind Rec f2", F.symbol f2', t2))-    γ'' <- foldM (\γγ (x, t) -> γγ += ("Bind Rec x1", F.symbol x, t)) γ' (zip (xs1' ++ xs2') (ts1 ++ ts2))-    let vs2xs =  F.subst $ F.mkSubst $ zip (vs1 ++ vs2) $ map (F.EVar . F.symbol) (xs1' ++ xs2')-    let (ho, fo) = partitionArgs xs1 xs2 ts1 ts2 qs-    γ''' <- γ'' `addPreds` traceWhenLoud ("PRECONDITION " ++ F.showpp (vs2xs (F.PAnd fo)) ++ "\n" ++-                                          "ASSUMPTION " ++ F.showpp (vs2xs a))-                              map vs2xs [F.PAnd fo, a]-    let p' = unapp rp (zip vs1 vs2)-    let ψ' = ho ++ ψ-    consRelCheck γ''' ψ' (xbody e1'') (xbody e2'') (vs2xs $ ret t1) (vs2xs $ ret t2) (vs2xs $ concl (fromRelExpr p'))-  where-    a = fromRelExpr ra-    p = fromRelExpr rp-    (f1', f2') = mkRelCopies f1 f2-    (e1', e2') = subRelCopies e1 f1 e2 f2-    unapp :: RelExpr -> [(F.Symbol, F.Symbol)] -> RelExpr-    unapp = L.foldl' (\p' (v1, v2) -> unapplyRelArgsR v1 v2 p')-    subRel (e1'', e2'') (x1, x2) = subRelCopies e1'' x1 e2'' x2--consRelCheckBind _ _ (Rec [(_, e1)]) (Rec [(_, e2)]) t1 t2 _ rp-  = F.panic $ "consRelCheckBind Rec: exprs, types, and pred should have same number of args " ++-    show (args e1 e2 t1 t2 p)-    where-      p = fromRelExpr rp--consRelCheckBind _ _ b1@(Rec _) b2@(Rec _) _ _ _ _-  = F.panic $ "consRelCheckBind Rec: multiple binders are not supported " ++ F.showpp (b1, b2)--consRelCheck :: CGEnv -> PrEnv -> CoreExpr -> CoreExpr ->-  SpecType -> SpecType -> F.Expr -> CG ()-consRelCheck γ ψ (Tick tt e) d t s p =-  consRelCheck (γ `setLocation` Sp.Tick tt) ψ e d t s p--consRelCheck γ ψ e (Tick tt d) t s p =-  consRelCheck (γ `setLocation` Sp.Tick tt) ψ e d t s p--consRelCheck γ ψ l1@(Lam α1 e1) e2 rt1@(RAllT s1 t1 r1) t2 p-  | Ghc.isTyVar α1-  = traceChk "Lam Type L" l1 e2 rt1 t2 p $ do-    entlFunReft γ r1 "consRelCheck Lam Type"-    γ'  <- γ `extendWithTyVar` α1-    consRelCheck γ' ψ e1 e2 (sb (s1, α1) t1) t2 p-  where sb (s, α) = subsTyVarMeet' (ty_var_value s, rVar α)--consRelCheck γ ψ e1 l2@(Lam α2 e2) t1 rt2@(RAllT s2 t2 r2) p-  | Ghc.isTyVar α2-  = traceChk "Lam Type" e1 l2 t1 rt2 p $ do-    entlFunReft γ r2 "consRelCheck Lam Type"-    γ'  <- γ `extendWithTyVar` α2-    consRelCheck γ' ψ e1 e2 t1 (sb (s2, α2) t2) p-  where sb (s, α) = subsTyVarMeet' (ty_var_value s, rVar α)--consRelCheck γ ψ l1@(Lam α1 e1) l2@(Lam α2 e2) rt1@(RAllT s1 t1 r1) rt2@(RAllT s2 t2 r2) p-  | Ghc.isTyVar α1 && Ghc.isTyVar α2-  = traceChk "Lam Type" l1 l2 rt1 rt2 p $ do-    entlFunRefts γ r1 r2 "consRelCheck Lam Type"-    γ'  <- γ `extendWithTyVar` α1-    γ'' <- γ' `extendWithTyVar` α2-    consRelCheck γ'' ψ e1 e2 (sb (s1, α1) t1) (sb (s2, α2) t2) p-  where sb (s, α) = subsTyVarMeet' (ty_var_value s, rVar α)--consRelCheck γ ψ l1@(Lam x1 e1) l2@(Lam x2 e2) rt1@(RFun v1 _ s1 t1 r1) rt2@(RFun v2 _ s2 t2 r2) pr@(F.PImp q p)-  = traceChk "Lam Expr" l1 l2 rt1 rt2 pr $ do-    entlFunRefts γ r1 r2 "consRelCheck Lam Expr"-    let (pvar1, pvar2) = (F.symbol evar1, F.symbol evar2)-    let subst = F.subst $ F.mkSubst [(v1, F.EVar pvar1), (v2, F.EVar pvar2)]-    γ'  <- γ += ("consRelCheck Lam L", pvar1, subst s1)-    γ'' <- γ' += ("consRelCheck Lam R", pvar2, subst s2)-    let p'    = unapplyRelArgs v1 v2 p-    let (ho, fo) = partitionArg x1 x2 s1 s2 q-    γ''' <- γ'' `addPreds` traceWhenLoud ("PRECONDITION " ++ F.showpp (map subst fo)) map subst fo-    consRelCheck γ''' (ho ++ ψ) e1' e2' (subst t1) (subst t2) (subst p')-  where-    (evar1, evar2) = mkRelCopies x1 x2-    (e1', e2')     = subRelCopies e1 x1 e2 x2--consRelCheck γ ψ l1@(Let (NonRec x1 d1) e1) l2@(Let (NonRec x2 d2) e2) t1 t2 p-  = traceChk "Let" l1 l2 t1 t2 p $ do-    (s1, s2, _) <- consRelSynth γ ψ d1 d2-    let (evar1, evar2) = mkRelCopies x1 x2-    let (e1', e2')     = subRelCopies e1 x1 e2 x2-    γ'  <- γ += ("consRelCheck Let L", F.symbol evar1, s1)-    γ'' <- γ' += ("consRelCheck Let R", F.symbol evar2, s2)-    consRelCheck γ'' ψ e1' e2' t1 t2 p-  --consRelCheck γ ψ l1@(Let (Rec []) e1) l2@(Let (Rec []) e2) t1 t2 p-  = traceChk "Let Rec Nil" l1 l2 t1 t2 p $ do-    consRelCheck γ ψ e1 e2 t1 t2 p--consRelCheck γ ψ l1@(Let (Rec ((x1, d1):bs1)) e1) l2@(Let (Rec ((x2, d2):bs2)) e2) t1 t2 p-  = traceChk "Let Rec Cons" l1 l2 t1 t2 p $ do-    (s1, s2, _) <- consRelSynth γ ψ d1 d2-    let (evar1, evar2) = mkRelCopies x1 x2-    let (e1', e2')     = subRelCopies e1 x1 e2 x2-    γ'  <- γ += ("consRelCheck Let L", F.symbol evar1, s1)-    γ'' <- γ' += ("consRelCheck Let R", F.symbol evar2, s2)-    consRelCheck γ'' ψ (Let (Rec bs1) e1') (Let (Rec bs2) e2') t1 t2 p--consRelCheck γ ψ c1@(Case e1 x1 _ alts1) e2 t1 t2 p =-  traceChk "Case Async L" c1 e2 t1 t2 p $ do-    s1 <- consUnarySynth γ e1-    γ' <- γ += ("consRelCheck Case Async L", x1', s1)-    forM_ alts1 $ consRelCheckAltAsyncL γ' ψ t1 t2 p x1' s1 e2-  where-    x1' = F.symbol $ mkCopyWithSuffix relSuffixL x1--consRelCheck γ ψ e1 c2@(Case e2 x2 _ alts2) t1 t2 p =-  traceChk "Case Async R" e1 c2 t1 t2 p $ do-    s2 <- consUnarySynth γ e2-    γ' <- γ += ("consRelCheck Case Async R", x2', s2)-    forM_ alts2 $ consRelCheckAltAsyncR γ' ψ t1 t2 p e1 x2' s2-  where-    x2' = F.symbol $ mkCopyWithSuffix relSuffixR x2--consRelCheck γ ψ e d t1 t2 p =-  traceChk "Synth" e d t1 t2 p $ do-  (s1, s2, qs) <- consRelSynth γ ψ e d-  let psubst = F.substf (matchFunArgs t1 s1) . F.substf (matchFunArgs t2 s2)-  consRelSub γ s1 s2 (F.PAnd qs) (psubst p)-  addC (SubC γ s1 t1) ("consRelCheck (Synth): s1 = " ++ F.showpp s1 ++ " t1 = " ++ F.showpp t1)-  addC (SubC γ s2 t2) ("consRelCheck (Synth): s2 = " ++ F.showpp s2 ++ " t2 = " ++ F.showpp t2)--consExtAltEnv :: CGEnv -> F.Symbol -> SpecType -> AltCon -> [Var] -> CoreExpr -> String -> CG (CGEnv, CoreExpr)-consExtAltEnv γ x s c bs e suf = do-  ct <- ctorTy γ c s-  unapply γ x s bs (removeAbsRef ct) e suf--consRelCheckAltAsyncL :: CGEnv -> PrEnv -> SpecType -> SpecType -> F.Expr ->-  F.Symbol -> SpecType -> CoreExpr -> Alt CoreBndr -> CG ()-consRelCheckAltAsyncL γ ψ t1 t2 p x1 s1 e2 (c, bs1, e1) = do-  (γ', e1') <- consExtAltEnv γ x1 s1 c bs1 e1 relSuffixL-  consRelCheck γ' ψ e1' e2 t1 t2 p--consRelCheckAltAsyncR :: CGEnv -> PrEnv -> SpecType -> SpecType -> F.Expr ->-  CoreExpr -> F.Symbol -> SpecType -> Alt CoreBndr -> CG ()-consRelCheckAltAsyncR γ ψ t1 t2 p e1 x2 s2 (c, bs2, e2) = do-  (γ', e2') <- consExtAltEnv γ x2 s2 c bs2 e2 relSuffixR-  consRelCheck γ' ψ e1 e2' t1 t2 p--ctorTy :: CGEnv -> AltCon -> SpecType -> CG SpecType-ctorTy γ (DataAlt c) (RApp _ ts _ _)-  | Just ct <- mbct = refreshTy $ ct `instantiateTys` ts-  | Nothing <- mbct = F.panic $ "ctorTy: data constructor out of scope" ++ F.showpp c-  where mbct = γ ?= F.symbol (Ghc.dataConWorkId c)-ctorTy _ (DataAlt _) t =-  F.panic $ "ctorTy: type " ++ F.showpp t ++ " doesn't have top-level data constructor"-ctorTy _ (LitAlt c) _ = return $ uTop <$> literalFRefType c-ctorTy _ DEFAULT t = return t--unapply :: CGEnv -> F.Symbol -> SpecType -> [Var] -> SpecType -> CoreExpr -> String -> CG (CGEnv, CoreExpr)-unapply γ y yt (z : zs) (RFun x _ s t _) e suffix = do-  γ' <- γ += ("unapply arg", evar, s)-  unapply γ' y yt zs (t `F.subst1` (x, F.EVar evar)) e' suffix-  where-    z' = mkCopyWithSuffix suffix z-    evar = F.symbol z'-    e' = subVarAndTy z z' e-unapply _ _ _ (_ : _) t _ _ = F.panic $ "can't unapply type " ++ F.showpp t-unapply γ y yt [] t e _ = do-  let yt' = t `F.meet` yt-  γ' <- γ += ("unapply res", y, yt')-  return $ traceWhenLoud ("SCRUTINEE " ++ F.showpp (y, yt')) (γ', e)--instantiateTys :: SpecType -> [SpecType] -> SpecType-instantiateTys = L.foldl' go- where-  go (RAllT α tbody _) t = subsTyVarMeet' (ty_var_value α, t) tbody-  go tbody             t =-    F.panic $ "instantiateTys: non-polymorphic type " ++ F.showpp tbody ++ " to instantiate with " ++ F.showpp t------------------------------------------------------------------- Core Synthesis Rules -------------------------------------------------------------------------------------------------------consRelSynth :: CGEnv -> PrEnv -> CoreExpr -> CoreExpr -> CG (SpecType, SpecType, [F.Expr])-consRelSynth γ ψ (Tick tt e) d =-  consRelSynth (γ `setLocation` Sp.Tick tt) ψ e d--consRelSynth γ ψ e (Tick tt d) =-  consRelSynth (γ `setLocation` Sp.Tick tt) ψ e d--consRelSynth γ ψ a1@(App e1 d1) e2 | Type t1 <- GM.unTickExpr d1 =-  traceSyn "App Ty L" a1 e2 $ do-    (ft1', t2, ps) <- consRelSynth γ ψ e1 e2-    let (α1, ft1, _) = unRAllT ft1' "consRelSynth App Ty L"-    t1' <- trueTy (typeclass (getConfig γ)) t1-    return (subsTyVarMeet' (ty_var_value α1, t1') ft1, t2, ps)--consRelSynth γ ψ e1 a2@(App e2 d2) | Type t2 <- GM.unTickExpr d2 =-  traceSyn "App Ty R" e1 a2 $ do-    (t1, ft2', ps) <- consRelSynth γ ψ e1 e2-    let (α2, ft2, _) = unRAllT ft2' "consRelSynth App Ty R"-    t2' <- trueTy (typeclass (getConfig γ)) t2-    return (t1, subsTyVarMeet' (ty_var_value α2, t2') ft2, ps)--consRelSynth γ ψ a1@(App e1 d1) a2@(App e2 d2) = traceSyn "App Exp Exp" a1 a2 $ do-  (ft1, ft2, fps) <- consRelSynth γ ψ e1 e2-  (t1, t2, ps) <- consRelSynthApp γ ψ ft1 ft2 fps d1 d2-  return (t1, t2, ps)--consRelSynth γ ψ e d = traceSyn "Unary" e d $ do-  t <- consUnarySynth γ e >>= refreshTy-  s <- consUnarySynth γ d >>= refreshTy-  let ps = lookupRelSig ψ e d t s-  return (t, s, traceWhenLoud ("consRelSynth Unary synthed preds:" ++ F.showpp ps) ps)-    -lookupRelSig :: PrEnv -> CoreExpr -> CoreExpr -> SpecType -> SpecType -> [F.Expr] -lookupRelSig ψ (Var x1) (Var x2) t1 t2 = concatMap match ψ-  where -    match :: RelPred -> [F.Expr]-    match (RelPred f1 f2 bs1 bs2 p) | f1 == x1, f2 == x2 = -        let (vs1, ts1') = vargs t1-            (vs2, ts2') = vargs t2-            vs1' = concatMap (fst . vargs) ts1'-            vs2' = concatMap (fst . vargs) ts2'-            bs1' = concatMap snd bs1-            bs2' = concatMap snd bs2-            bs2vs = F.mkSubst $ zip (map fst bs1 ++ map fst bs2 ++ bs1' ++ bs2') $ map F.EVar (vs1 ++ vs2 ++ vs1' ++ vs2')-          in [F.subst bs2vs (fromRelExpr p)]-    match _ = []-lookupRelSig _ _ _ _ _ = []--consRelSynthApp :: CGEnv -> PrEnv -> SpecType -> SpecType ->-  [F.Expr] -> CoreExpr -> CoreExpr -> CG (SpecType, SpecType, [F.Expr])-consRelSynthApp γ ψ ft1 ft2 ps e1 (Tick _ e2) =-  consRelSynthApp γ ψ ft1 ft2 ps e1 e2-consRelSynthApp γ ψ ft1 ft2 ps (Tick t1 e1) e2 =-  consRelSynthApp (γ `setLocation` Sp.Tick t1) ψ ft1 ft2 ps e1 e2--consRelSynthApp γ ψ ft1@(RFun v1 _ s1 t1 r1) ft2@(RFun v2 _ s2 t2 r2) ps@[F.PImp q p] d1@(Var x1) d2@(Var x2)-  = traceSynApp ft1 ft2 ps d1 d2 $ do-    entlFunRefts γ r1 r2 "consRelSynthApp HO"-    let qsubst = F.subst $ F.mkSubst [(v1, F.EVar resL), (v2, F.EVar resR)]-    consRelCheck γ ψ d1 d2 s1 s2 (qsubst q)-    let subst = F.subst $ F.mkSubst [(v1, F.EVar $ F.symbol x1), (v2, F.EVar $ F.symbol x2)]-    return (subst t1, subst t2, [(subst . unapplyRelArgs v1 v2) p])-consRelSynthApp γ ψ ft1@(RFun v1 _ s1 t1 r1) ft2@(RFun v2 _ s2 t2 r2) ps@[] d1@(Var x1) d2@(Var x2)-  = traceSynApp ft1 ft2 ps d1 d2 $ do-    entlFunRefts γ r1 r2 "consRelSynthApp FO"-    consUnaryCheck γ d1 s1-    consUnaryCheck γ d2 s2-    (_, _, qs) <- consRelSynth γ ψ d1 d2-    let subst =-          F.subst $ F.mkSubst-            [(v1, F.EVar $ F.symbol x1), (v2, F.EVar $ F.symbol x2)]-    return (subst t1, subst t2, map subst qs)-consRelSynthApp _ _ RFun{} RFun{} ps d1@(Var _) d2@(Var _)-  = F.panic $ "consRelSynthApp: multiple rel sigs not supported " ++ F.showpp (ps, d1, d2)-consRelSynthApp _ _ RFun{} RFun{} _ d1 d2 =-  F.panic $ "consRelSynthApp: expected application to variables, got" ++ F.showpp (d1, d2)-consRelSynthApp _ _ t1 t2 p d1 d2 =-  F.panic $ "consRelSynthApp: malformed function types or predicate for arguments " ++ F.showpp (t1, t2, p, d1, d2)------------------------------------------------------------------- Unary Rules ----------------------------------------------------------------------------------------------------------------symbolType :: CGEnv -> Var -> String -> SpecType-symbolType γ x msg-  | Just t <- γ ?= F.symbol x = t-  | otherwise = F.panic $ msg ++ " " ++ F.showpp x ++ " not in scope " ++ F.showpp γ--consUnarySynth :: CGEnv -> CoreExpr -> CG SpecType-consUnarySynth γ (Tick t e) = consUnarySynth (γ `setLocation` Sp.Tick t) e-consUnarySynth γ (Var x) = return $ traceWhenLoud ("SELFIFICATION " ++ F.showpp (x, removeAbsRef $ selfify t x)) removeAbsRef $ selfify t x-  where t = symbolType γ x "consUnarySynth (Var)"-consUnarySynth _ e@(Lit c) =-  traceUSyn "Lit" e $ do-  return $ removeAbsRef $ uRType $ literalFRefType c-consUnarySynth γ e@(Let _ _) =-  traceUSyn "Let" e $ do-  t   <- freshTyType (typeclass (getConfig γ)) LetE e $ Ghc.exprType e-  addW $ WfC γ t-  consUnaryCheck γ e t-  return $ removeAbsRef t-consUnarySynth γ e'@(App e d) =-  traceUSyn "App" e' $ do-  et <- consUnarySynth γ e-  consUnarySynthApp γ et d-consUnarySynth γ e'@(Lam α e) | Ghc.isTyVar α =-                             traceUSyn "LamTyp" e' $ do-  γ' <- γ `extendWithTyVar` α-  t' <- consUnarySynth γ' e-  return $ removeAbsRef $ RAllT (makeRTVar $ rTyVar α) t' mempty-consUnarySynth γ e@(Lam x d)  =-  traceUSyn "Lam" e $ do-  let Ghc.FunTy { ft_arg = s' } = checkFun e $ Ghc.exprType e-  s  <- freshTyType (typeclass (getConfig γ)) LamE (Var x) s'-  γ' <- γ += ("consUnarySynth (Lam)", F.symbol x, s)-  t  <- consUnarySynth γ' d-  addW $ WfC γ s-  return $ removeAbsRef $ RFun (F.symbol x) (mkRFInfo $ getConfig γ) s t mempty-consUnarySynth γ e@(Case _ _ _ alts) =-  traceUSyn "Case" e $ do-  t   <- freshTyType (typeclass (getConfig γ)) (caseKVKind alts) e $ Ghc.exprType e-  addW $ WfC γ t-  return $ removeAbsRef t-consUnarySynth _ e@(Cast _ _) = F.panic $ "consUnarySynth is undefined for Cast " ++ F.showpp e-consUnarySynth _ e@(Type _) = F.panic $ "consUnarySynth is undefined for Type " ++ F.showpp e-consUnarySynth _ e@(Coercion _) = F.panic $ "consUnarySynth is undefined for Coercion " ++ F.showpp e--caseKVKind :: [Alt Var] -> KVKind-caseKVKind [(DataAlt _, _, Var _)] = ProjectE-caseKVKind cs                      = CaseE (length cs)--checkFun :: CoreExpr -> Type -> Type-checkFun _ t@Ghc.FunTy{} = t-checkFun e t = F.panic $ "FunTy was expected but got " ++ F.showpp t ++ "\t for expression" ++ F.showpp e--base :: SpecType -> Bool-base RApp{} = True-base RVar{} = True-base _      = False--selfifyExpr :: SpecType -> F.Expr -> Maybe SpecType-selfifyExpr (RFun v i s t r) f = (\t' -> RFun v i s t' r) <$> selfifyExpr t (F.EApp f (F.EVar v))-selfifyExpr t e | base t = Just $ t `strengthen` eq e-  where eq = uTop . F.exprReft-selfifyExpr _ _ = Nothing--selfify :: F.Symbolic a => SpecType -> a -> SpecType-selfify t x | base t = t `strengthen` eq x-  where eq = uTop . F.symbolReft . F.symbol-selfify t e | Just t' <- selfifyExpr t (F.EVar $ F.symbol e) = t'-selfify t _ = t--consUnarySynthApp :: CGEnv -> SpecType -> CoreExpr -> CG SpecType-consUnarySynthApp γ t (Tick y e) = do-  consUnarySynthApp (γ `setLocation` Sp.Tick y) t e-consUnarySynthApp γ (RFun x _ s t _) d@(Var y) = do-  consUnaryCheck γ d s-  return $ t `F.subst1` (x, F.EVar $ F.symbol y)-consUnarySynthApp γ (RAllT α t _) (Type s) = do-    s' <- trueTy (typeclass (getConfig γ)) s-    return $ subsTyVarMeet' (ty_var_value α, s') t-consUnarySynthApp _ RFun{} d =-  F.panic $ "consUnarySynthApp expected Var as a funciton arg, got " ++ F.showpp d-consUnarySynthApp γ t@(RAllP{}) e-  = consUnarySynthApp γ (removeAbsRef t) e--consUnarySynthApp _ ft d =-  F.panic $ "consUnarySynthApp malformed function type " ++ F.showpp ft ++-            " for argument " ++ F.showpp d--consUnaryCheck :: CGEnv -> CoreExpr -> SpecType -> CG ()-consUnaryCheck γ (Let (NonRec x d) e) t = do-  s <- consUnarySynth γ d-  γ' <- γ += ("consUnaryCheck Let", F.symbol x, s)-  consUnaryCheck γ' e t-consUnaryCheck γ e t = do-  s <- consUnarySynth γ e-  addC (SubC γ s t) ("consUnaryCheck (Synth): s = " ++ F.showpp s ++ " t = " ++ F.showpp t)------------------------------------------------------------------- Rel. Predicate Subtyping  --------------------------------------------------------------------------------------------------consRelSub :: CGEnv -> SpecType -> SpecType -> F.Expr -> F.Expr -> CG ()-consRelSub γ f1@(RFun g1 _ s1@RFun{} t1 _) f2@(RFun g2 _ s2@RFun{} t2 _)-             pr1@(F.PImp qr1@F.PImp{} p1)  pr2@(F.PImp qr2@F.PImp{} p2)-  = traceSub "hof" f1 f2 pr1 pr2 $ do-    consRelSub γ s1 s2 qr2 qr1-    γ' <- γ += ("consRelSub HOF", F.symbol g1, s1)-    γ'' <- γ' += ("consRelSub HOF", F.symbol g2, s2)-    let psubst = unapplyArg resL g1 <> unapplyArg resR g2-    consRelSub γ'' t1 t2 (psubst p1) (psubst p2)-consRelSub γ f1@(RFun g1 _ s1@RFun{} t1 _) f2@(RFun g2 _ s2@RFun{} t2 _)-             pr1@(F.PAnd [F.PImp qr1@F.PImp{} p1])            pr2@(F.PImp qr2@F.PImp{} p2)-  = traceSub "hof" f1 f2 pr1 pr2 $ do-    consRelSub γ s1 s2 qr2 qr1-    γ' <- γ += ("consRelSub HOF", F.symbol g1, s1)-    γ'' <- γ' += ("consRelSub HOF", F.symbol g2, s2)-    let psubst = unapplyArg resL g1 <> unapplyArg resR g2-    consRelSub γ'' t1 t2 (psubst p1) (psubst p2)-consRelSub γ f1@(RFun x1 _ s1 e1 _) f2 p1 p2 =-  traceSub "fun" f1 f2 p1 p2 $ do-    γ' <- γ += ("consRelSub RFun L", F.symbol x1, s1)-    let psubst = unapplyArg resL x1-    consRelSub γ' e1 f2 (psubst p1) (psubst p2)-consRelSub γ f1 f2@(RFun x2 _ s2 e2 _) p1 p2 =-  traceSub "fun" f1 f2 p1 p2 $ do-    γ' <- γ += ("consRelSub RFun R", F.symbol x2, s2)-    let psubst = unapplyArg resR x2-    consRelSub γ' f1 e2 (psubst p1) (psubst p2)-consRelSub γ t1 t2 p1 p2 | isBase t1 && isBase t2 =-  traceSub "base" t1 t2 p1 p2 $ do-    rl <- fresh-    rr <- fresh-    γ' <- γ += ("consRelSub Base L", rl, t1)-    γ'' <- γ' += ("consRelSub Base R", rr, t2)-    let cstr = F.subst (F.mkSubst [(resL, F.EVar rl), (resR, F.EVar rr)]) $ F.PImp p1 p2-    entl γ'' (traceWhenLoud ("consRelSub Base cstr " ++ F.showpp cstr) cstr) "consRelSub Base"-consRelSub _ t1@(RHole _) t2@(RHole _) _ _ = F.panic $ "consRelSub is undefined for RHole " ++ show (t1, t2)-consRelSub _ t1@(RExprArg _) t2@(RExprArg _) _ _ = F.panic $ "consRelSub is undefined for RExprArg " ++ show (t1, t2)-consRelSub _ t1@REx {} t2@REx {} _ _ = F.panic $ "consRelSub is undefined for REx " ++ show (t1, t2)-consRelSub _ t1@RAllE {} t2@RAllE {} _ _ = F.panic $ "consRelSub is undefined for RAllE " ++ show (t1, t2)-consRelSub _ t1@RRTy {} t2@RRTy {} _ _ = F.panic $ "consRelSub is undefined for RRTy " ++ show (t1, t2)-consRelSub _ t1@RAllP {} t2@RAllP {} _ _ = F.panic $ "consRelSub is undefined for RAllP " ++ show (t1, t2)-consRelSub _ t1@RAllT {} t2@RAllT {} _ _ = F.panic $ "consRelSub is undefined for RAllT " ++ show (t1, t2)-consRelSub _ t1@RImpF {} t2@RImpF {} _ _ = F.panic $ "consRelSub is undefined for RImpF " ++ show (t1, t2)-consRelSub _ t1 t2 _ _ =  F.panic $ "consRelSub is undefined for different types " ++ show (t1, t2)------------------------------------------------------------------- Helper Definitions ---------------------------------------------------------------------------------------------------------isFuncPred :: F.Expr -> Bool-isFuncPred (F.PImp _ _) = True-isFuncPred _            = False--partitionArg :: Var -> Var -> SpecType -> SpecType -> F.Expr -> (PrEnv, [F.Expr])-partitionArg x1 x2 s1 s2 q = partitionArgs [x1] [x2] [s1] [s2] [q]--partitionArgs :: [Var] -> [Var] -> [SpecType] -> [SpecType] -> [F.Expr] -> (PrEnv, [F.Expr])-partitionArgs xs1 xs2 ts1 ts2 qs = (map toRel ho, map toUnary fo)- where-  (ho, fo) = L.partition (isFuncPred . toUnary) (zip5 xs1 xs2 ts1 ts2 qs)-  toRel (f1, f2, t1, t2, q) =-    let (vs1, ts1') = vargs t1-    in  let (vs2, ts2') = vargs t2-        in  let bs1 = zip vs1 (fst . vargs <$> ts1')-            in  let bs2 = zip vs2 (fst . vargs <$> ts2')-                in  let rp = RelPred f1 f2 bs1 bs2 $ ERBasic q-                    in traceWhenLoud ("partitionArgs toRel: " ++ F.showpp (f1, f2, bs1, bs2, q)) rp-  toUnary (_, _, _, _, q) = q--unRAllT :: SpecType -> String -> (RTVU RTyCon RTyVar, SpecType, RReft)-unRAllT (RAllT α2 ft2 r2) _ = (α2, ft2, r2)-unRAllT t msg = F.panic $ msg ++ ": expected RAllT, got: " ++ F.showpp t--forgetRAllP :: PVU RTyCon RTyVar -> SpecType -> SpecType-forgetRAllP _ t = t--args :: CoreExpr -> CoreExpr -> SpecType -> SpecType -> F.Expr ->-  Maybe ([Var], [Var], [F.Symbol], [F.Symbol], [SpecType], [SpecType], [F.Expr])-args e1 e2 t1 t2 ps-  | xs1 <- xargs e1, xs2 <- xargs e2,-    (vs1, ts1) <- vargs t1, (vs2, ts2) <- vargs t2,-    qs  <- prems ps,-    all (length qs ==) [length xs1, length xs2, length vs1, length vs2, length ts1, length ts2]-  = Just (xs1, xs2, vs1, vs2, ts1, ts2, qs)-args e1 e2 t1 t2 ps = traceWhenLoud ("args guard" ++ F.showpp (xargs e1, xargs e2, vargs t1, vargs t2, prems ps)) Nothing--xargs :: CoreExpr -> [Var]-xargs (Tick _ e) = xargs e-xargs (Lam  x e) | Ghc.isTyVar x = xargs e-xargs (Lam  x e) = x : xargs e-xargs _          = []--xbody :: CoreExpr -> CoreExpr-xbody (Tick _ e) = xbody e-xbody (Lam  _ e) = xbody e-xbody e          = e--refts :: SpecType -> [RReft]-refts (RAllT _ t r ) = r : refts t-refts (RFun _ _ _ t r) = r : refts t-refts _              = []--vargs :: SpecType -> ([F.Symbol], [SpecType])-vargs (RAllT _ t _ ) = vargs t-vargs (RFun v _ s t _) = bimap (v :) (s :) $ vargs t-vargs _              = ([], [])--ret :: SpecType -> SpecType-ret (RAllT _ t _ ) = ret t-ret (RFun _ _ _ t _) = ret t-ret t              = t--prems :: F.Expr -> [F.Expr]-prems (F.PImp q p) = q : prems p-prems _            = []--concl :: F.Expr -> F.Expr-concl (F.PImp _ p) = concl p-concl p            = p--extendWithTyVar :: CGEnv -> TyVar -> CG CGEnv-extendWithTyVar γ a-  | isValKind (Ghc.tyVarKind a)-  = γ += ("extendWithTyVar", F.symbol a, kindToRType $ Ghc.tyVarKind a)-  | otherwise-  = return γ--matchFunArgs :: SpecType -> SpecType -> F.Symbol -> F.Expr-matchFunArgs (RAllT _ t1 _) t2 x = matchFunArgs t1 t2 x-matchFunArgs t1 (RAllT _ t2 _) x = matchFunArgs t1 t2 x-matchFunArgs (RFun x1 _ _ t1 _) (RFun x2 _ _ t2 _) x =-  if x == x1 then F.EVar x2 else matchFunArgs t1 t2 x-matchFunArgs t1 t2 x | isBase t1 && isBase t2 = F.EVar x-matchFunArgs t1 t2 _ = F.panic $ "matchFunArgs undefined for " ++ F.showpp (t1, t2)--entl :: CGEnv -> F.Expr -> String -> CG ()-entl γ p = addC (SubR γ OCons $ uReft (F.vv_, F.PIff (F.EVar F.vv_) p))--entlFunReft :: CGEnv -> RReft -> String -> CG ()-entlFunReft γ r msg = do-  entl γ (F.reftPred $ ur_reft r) $ "entlFunRefts " ++ msg--entlFunRefts :: CGEnv -> RReft -> RReft -> String -> CG ()-entlFunRefts γ r1 r2 msg = do-  entlFunReft γ r1 $ msg ++ " L"-  entlFunReft γ r2 $ msg ++ " R"--subRelCopies :: CoreExpr -> Var -> CoreExpr -> Var -> (CoreExpr, CoreExpr)-subRelCopies e1 x1 e2 x2 = (subVarAndTy x1 evar1 e1, subVarAndTy x2 evar2 e2)-  where (evar1, evar2) = mkRelCopies x1 x2--subVarAndTy :: Var -> Var -> CoreExpr -> CoreExpr-subVarAndTy x v = subTy (M.singleton x $ TyVarTy v) . sub (M.singleton x $ Var v)--mkRelCopies :: Var -> Var -> (Var, Var)-mkRelCopies x1 x2 = (mkCopyWithSuffix relSuffixL x1, mkCopyWithSuffix relSuffixR x2)--mkCopyWithName :: String -> Var -> Var-mkCopyWithName s v =-  Ghc.setVarName v $ Ghc.mkSystemName (Ghc.getUnique v) (Ghc.mkVarOcc s)--mkCopyWithSuffix :: String -> Var -> Var-mkCopyWithSuffix s v = mkCopyWithName (Ghc.getOccString v ++ s) v--lookupBind :: Var -> [CoreBind] -> CoreBind-lookupBind x bs = case lookup x (concatMap binds bs) of-  Nothing -> F.panic $ "Not found definition for " ++ show x-  Just e  -> e- where-  binds b@(NonRec x' _) = [ (x', b) ]-  binds   (Rec bs'    ) = [ (x', Rec [(x',e)]) | (x',e) <- bs' ]--subUnarySig :: CGEnv -> Var -> SpecType -> CG ()-subUnarySig γ x tRel =-  forM_ mkargs $ \(rt, ut) -> addC (SubC γ ut rt) $ "subUnarySig tUn = " ++ F.showpp ut ++ " tRel = " ++ F.showpp rt-  where-    mkargs = zip (snd $ vargs tRel) (snd $ vargs tUn)-    tUn = symbolType γ x $ "subUnarySig " ++ F.showpp x--addPred :: CGEnv -> F.Expr -> CG CGEnv-addPred γ p = extendWithExprs γ [p]--addPreds :: CGEnv -> [F.Expr] -> CG CGEnv-addPreds = extendWithExprs--extendWithExprs :: CGEnv -> [F.Expr] -> CG CGEnv-extendWithExprs γ ps = do-  dummy <- fresh-  let reft = uReft (F.vv_, F.PAnd ps)-  γ += ("extend with predicate env", dummy, RVar (symbolRTyVar F.dummySymbol) reft)--unapplyArg :: F.Symbol -> F.Symbol -> F.Expr -> F.Expr-unapplyArg f y e = F.mapExpr sb e-  where-    sb :: F.Expr -> F.Expr-    sb (F.EApp (F.EVar r) (F.EVar x))-      | r == f && x == y = F.EVar r-    sb e' = e'--unapplyRelArgs :: F.Symbol -> F.Symbol -> F.Expr -> F.Expr-unapplyRelArgs x1 x2 = unapplyArg resL x1 . unapplyArg resR x2--unapplyRelArgsR :: F.Symbol -> F.Symbol -> RelExpr -> RelExpr-unapplyRelArgsR x1 x2 (ERBasic e) = ERBasic (unapplyRelArgs x1 x2 e)-unapplyRelArgsR x1 x2 (ERChecked e re) = ERChecked (unapplyRelArgs x1 x2 e) (unapplyRelArgsR x1 x2 re)-unapplyRelArgsR x1 x2 (ERUnChecked e re) = ERUnChecked (unapplyRelArgs x1 x2 e) (unapplyRelArgsR x1 x2 re)------------------------------------------------------------------- RelExpr & F.Expr -----------------------------------------------------------------------------------------------------------fromRelExpr :: RelExpr -> F.Expr-fromRelExpr (ERBasic e) = e-fromRelExpr (ERChecked a b) = F.PImp a (fromRelExpr b)-fromRelExpr (ERUnChecked a b) = F.PImp a (fromRelExpr b)------------------------------------------------------------------- Debug -----------------------------------------------------------------------------------------------------------------------traceSub :: (PPrint t, PPrint s, PPrint p, PPrint q) => String -> t -> s -> p -> q -> a -> a-traceSub msg t s p q = traceWhenLoud (msg ++ " RelSub\n"-                      ++ "t: " ++ F.showpp t ++ "\n\n"-                      ++ "s: " ++ F.showpp s ++ "\n\n"-                      ++ "p: " ++ F.showpp p ++ "\n\n"-                      ++ "q: " ++ F.showpp q)---traceChk-  :: (PPrint e, PPrint d, PPrint t, PPrint s, PPrint p)-  => String -> e -> d -> t -> s -> p -> a -> a-traceChk expr = trace (expr ++ " To CHECK")--traceSyn-  :: (PPrint e, PPrint d, PPrint a, PPrint b, PPrint c)-  => String -> e -> d -> CG (a, b, c) -> CG (a, b, c)-traceSyn expr e d cg-  = do-    (a, b, c) <- cg-    trace (expr ++ " To SYNTH") e d a b c cg--traceSynApp-  :: (PPrint e, PPrint d, PPrint a, PPrint b, PPrint c)-  => e -> d -> a -> b -> c -> t -> t-traceSynApp = trace "SYNTH APP TO "--traceUSyn-  :: (PPrint e, PPrint a)-  => String -> e -> CG a -> CG a-traceUSyn expr e cg = do-  t <- cg-  trace (expr ++ " To SYNTH UNARY") e dummy t dummy dummy cg-  where dummy = F.PTrue--trace-  :: (PPrint e, PPrint d, PPrint t, PPrint s, PPrint p)-  => String -> e -> d -> t -> s -> p -> a -> a-trace msg e d t s p = traceWhenLoud (msg ++ "\n"-                      ++ "e: " ++ F.showpp e ++ "\n\n"-                      ++ "d: " ++ F.showpp d ++ "\n\n"-                      ++ "t: " ++ F.showpp t ++ "\n\n"-                      ++ "s: " ++ F.showpp s ++ "\n\n"-                      ++ "p: " ++ F.showpp p)--traceWhenLoud :: String -> a -> a-traceWhenLoud s a = unsafePerformIO $ whenLoud (putStrLn s) >> return a
− src/Language/Haskell/Liquid/Constraint/Split.hs 
@@ -1,470 +0,0 @@-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE FlexibleContexts      #-}--{-# OPTIONS_GHC -Wno-name-shadowing #-}------------------------------------------------------------------------------------- | Constraint Splitting -----------------------------------------------------------------------------------------------------------------------------------------module Language.Haskell.Liquid.Constraint.Split (--  -- * Split Subtyping Constraints-    splitC--  -- * Split Well-formedness Constraints-  , splitW--  -- * ???-  , envToSub--  -- * Panic-  , panicUnbound-  ) where--import           Prelude hiding (error)----import           Text.PrettyPrint.HughesPJ hiding (first, parens)--import           Data.Maybe          (fromMaybe)-import           Control.Monad-import           Control.Monad.State (gets)-import qualified Control.Exception as Ex--import qualified Language.Fixpoint.Types            as F-import           Language.Fixpoint.Misc hiding (errorstar)-import           Language.Fixpoint.SortCheck (pruneUnsortedReft)--import           Language.Haskell.Liquid.Misc -- (concatMapM)-import qualified Language.Haskell.Liquid.UX.CTags       as Tg-import           Language.Haskell.Liquid.Types hiding (loc)---import           Language.Haskell.Liquid.Constraint.Types-import           Language.Haskell.Liquid.Constraint.Env-import           Language.Haskell.Liquid.Constraint.Constraint-import           Language.Haskell.Liquid.Constraint.Monad (envToSub)-----------------------------------------------------------------------------------splitW ::  WfC -> CG [FixWfC]----------------------------------------------------------------------------------splitW (WfC γ t@(RFun x _ t1 t2 _))-  =  do ws'  <- splitW (WfC γ t1)-        γ'   <- γ += ("splitW", x, t1)-        ws   <- bsplitW γ t-        ws'' <- splitW (WfC γ' t2)-        return $ ws ++ ws' ++ ws''--splitW (WfC γ t@(RImpF x _ t1 t2 _))-  =  do ws'  <- splitW (WfC γ t1)-        γ'   <- γ += ("splitW", x, t1)-        ws   <- bsplitW γ t-        ws'' <- splitW (WfC γ' t2)-        return $ ws ++ ws' ++ ws''---splitW (WfC γ t@(RAppTy t1 t2 _))-  =  do ws   <- bsplitW γ t-        ws'  <- splitW (WfC γ t1)-        ws'' <- splitW (WfC γ t2)-        return $ ws ++ ws' ++ ws''--splitW (WfC γ t'@(RAllT a t _))-  = do γ'  <- updateEnv γ a-       ws  <- bsplitW γ t'-       ws' <- splitW (WfC γ' t)-       return $ ws ++ ws'--splitW (WfC γ (RAllP _ r))-  = splitW (WfC γ r)--splitW (WfC γ t@(RVar _ _))-  = bsplitW γ t--splitW (WfC γ t@(RApp _ ts rs _))-  =  do ws    <- bsplitW γ t-        γ'    <- if bscope (getConfig γ) then γ `extendEnvWithVV` t else return γ-        ws'   <- concat <$> mapM (splitW . WfC γ') ts-        ws''  <- concat <$> mapM (rsplitW γ)       rs-        return $ ws ++ ws' ++ ws''--splitW (WfC γ (RAllE x tx t))-  = do  ws  <- splitW (WfC γ tx)-        γ'  <- γ += ("splitW1", x, tx)-        ws' <- splitW (WfC γ' t)-        return $ ws ++ ws'--splitW (WfC γ (REx x tx t))-  = do  ws  <- splitW (WfC γ tx)-        γ'  <- γ += ("splitW2", x, tx)-        ws' <- splitW (WfC γ' t)-        return $ ws ++ ws'--splitW (WfC γ (RRTy _ _ _ t))-  = splitW (WfC γ t)--splitW (WfC _ t)-  = panic Nothing $ "splitW cannot handle: " ++ showpp t--rsplitW :: CGEnv-        -> Ref RSort SpecType-        -> CG [FixWfC]-rsplitW _ (RProp _ (RHole _)) =-  panic Nothing "Constrains: rsplitW for RProp _ (RHole _)"--rsplitW γ (RProp ss t0) = do-  γ' <- foldM (+=) γ [("rsplitW", x, ofRSort s) | (x, s) <- ss]-  splitW $ WfC γ' t0---bsplitW :: CGEnv -> SpecType -> CG [FixWfC]-bsplitW γ t =-  do temp  <- getTemplates-     isHO  <- gets allowHO-     return $ bsplitW' γ t temp isHO--bsplitW' :: (PPrint r, F.Reftable r, SubsTy RTyVar RSort r, F.Reftable (RTProp RTyCon RTyVar r))-         => CGEnv -> RRType r -> F.Templates -> Bool -> [F.WfC Cinfo]-bsplitW' γ t temp isHO-  | isHO || F.isNonTrivial r'-  = F.wfC (feBinds $ fenv γ) r' ci-  | otherwise-  = []-  where-    r'                = rTypeSortedReft' γ temp t-    ci                = Ci (getLocation γ) Nothing (cgVar γ)--splitfWithVariance :: Applicative f-                   => (t -> t -> f [a]) -> t -> t -> Variance -> f [a]-splitfWithVariance f t1 t2 Invariant     = (++) <$> f t1 t2 <*> f t2 t1-splitfWithVariance f t1 t2 Bivariant     = (++) <$> f t1 t2 <*> f t2 t1-splitfWithVariance f t1 t2 Covariant     = f t1 t2-splitfWithVariance f t1 t2 Contravariant = f t2 t1--updateEnv :: CGEnv -> RTVar RTyVar (RType RTyCon RTyVar b0) -> CG CGEnv-updateEnv γ a-  | Just (x, s) <- rTVarToBind a-  = γ += ("splitS RAllT", x, fmap (const mempty) s)-  | otherwise-  = return γ---------------------------------------------------------------splitC :: Bool -> SubC -> CG [FixSubC]---------------------------------------------------------------splitC allowTC (SubC γ (REx x tx t1) (REx x2 _ t2)) | x == x2-  = do γ' <- γ += ("addExBind 0", x, forallExprRefType γ tx)-       splitC allowTC (SubC γ' t1 t2)--splitC allowTC (SubC γ t1 (REx x tx t2))-  = do y <- fresh-       γ' <- γ += ("addExBind 1", y, forallExprRefType γ tx)-       splitC allowTC (SubC γ' t1 (F.subst1 t2 (x, F.EVar y)))---- existential at the left hand side is treated like forall-splitC allowTC (SubC γ (REx x tx t1) t2)-  = do -- let tx' = traceShow ("splitC allowTC: " ++ showpp z) tx-       y <- fresh-       γ' <- γ += ("addExBind 2", y, forallExprRefType γ tx)-       splitC allowTC (SubC γ' (F.subst1 t1 (x, F.EVar y)) t2)--splitC allowTC (SubC γ (RAllE x tx t1) (RAllE x2 _ t2)) | x == x2-  = do γ' <- γ += ("addAllBind 3", x, forallExprRefType γ tx)-       splitC allowTC (SubC γ' t1 t2)--splitC allowTC (SubC γ (RAllE x tx t1) t2)-  = do y  <- fresh-       γ' <- γ += ("addAABind 1", y, forallExprRefType γ tx)-       splitC allowTC (SubC γ' (t1 `F.subst1` (x, F.EVar y)) t2)--splitC allowTC (SubC γ t1 (RAllE x tx t2))-  = do y  <- fresh-       γ' <- γ += ("addAllBind 2", y, forallExprRefType γ tx)-       splitC allowTC (SubC γ' t1 (F.subst1 t2 (x, F.EVar y)))--splitC allowTC (SubC γ (RRTy env _ OCons t1) t2)-  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ xts-       c1 <- splitC allowTC (SubC γ' t1' t2')-       c2 <- splitC allowTC (SubC γ  t1  t2 )-       return $ c1 ++ c2-  where-    (xts, t1', t2') = envToSub env--splitC allowTC (SubC γ (RRTy e r o t1) t2)-  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ e-       c1 <- splitC allowTC (SubR γ' o  r)-       c2 <- splitC allowTC (SubC γ t1 t2)-       return $ c1 ++ c2--splitC allowTC (SubC γ (RFun x1 i1 t1 t1' r1) (RFun x2 i2 t2 t2' r2))-  =  do cs'      <- splitC allowTC  (SubC γ t2 t1)-        γ'       <- γ+= ("splitC allowTC", x2, t2)-        cs       <- bsplitC γ (RFun x1 i1 t1 t1' (r1 `F.subst1` (x1, F.EVar x2)))-                              (RFun x2 i2 t2 t2'  r2)-        let t1x2' = t1' `F.subst1` (x1, F.EVar x2)-        cs''     <- splitC allowTC  (SubC γ' t1x2' t2')-        return    $ cs ++ cs' ++ cs''--splitC allowTC (SubC γ (RImpF x1 i1 t1 t1' r1) (RImpF x2 i2 t2 t2' r2))-  =  do cs'      <- splitC allowTC  (SubC γ t2 t1)-        γ'       <- γ+= ("splitC allowTC", x2, t2)-        cs       <- bsplitC γ (RImpF x1 i1 t1 t1' (r1 `F.subst1` (x1, F.EVar x2)))-                              (RImpF x2 i2 t2 t2'  r2)-        let t1x2' = t1' `F.subst1` (x1, F.EVar x2)-        cs''     <- splitC allowTC  (SubC γ' t1x2' t2')-        return    $ cs ++ cs' ++ cs''---splitC allowTC (SubC γ t1@(RAppTy r1 r1' _) t2@(RAppTy r2 r2' _))-  =  do cs    <- bsplitC γ t1 t2-        cs'   <- splitC allowTC  (SubC γ r1 r2)-        cs''  <- splitC allowTC  (SubC γ r1' r2')-        cs''' <- splitC allowTC  (SubC γ r2' r1')-        return $ cs ++ cs' ++ cs'' ++ cs'''--splitC allowTC (SubC γ t1 (RAllP p t))-  = splitC allowTC $ SubC γ t1 t'-  where-    t' = fmap (replacePredsWithRefs su) t-    su = (uPVar p, pVartoRConc p)--splitC _ (SubC γ t1@(RAllP _ _) t2)-  = panic (Just $ getLocation γ) $ "Predicate in lhs of constraint:" ++ showpp t1 ++ "\n<:\n" ++ showpp t2--splitC allowTC (SubC γ t1'@(RAllT α1 t1 _) t2'@(RAllT α2 t2 _))-  |  α1 ==  α2-  = do γ'  <- updateEnv γ α2-       cs  <- bsplitC γ t1' t2'-       cs' <- splitC allowTC $ SubC γ' t1 (F.subst su t2)-       return (cs ++ cs')-  | otherwise-  = do γ'  <- updateEnv γ α2-       cs  <- bsplitC γ t1' t2'-       cs' <- splitC allowTC $ SubC γ' t1 (F.subst su t2'')-       return (cs ++ cs')-  where-    t2'' = subsTyVarMeet' (ty_var_value α2, RVar (ty_var_value α1) mempty) t2-    su = case (rTVarToBind α1, rTVarToBind α2) of-          (Just (x1, _), Just (x2, _)) -> F.mkSubst [(x1, F.EVar x2)]-          _                            -> F.mkSubst []--splitC allowTC (SubC _ (RApp c1 _ _ _) (RApp c2 _ _ _)) | (if allowTC then isEmbeddedDict else isClass) c1 && c1 == c2-  = return []--splitC _ (SubC γ t1@RApp{} t2@RApp{})-  = do (t1',t2') <- unifyVV t1 t2-       cs    <- bsplitC γ t1' t2'-       γ'    <- if bscope (getConfig γ) then γ `extendEnvWithVV` t1' else return γ-       let RApp c t1s r1s _ = t1'-       let RApp _ t2s r2s _ = t2'-       let isapplied = True -- TC.tyConArity (rtc_tc c) == length t1s-       let tyInfo = rtc_info c-       csvar  <-  splitsCWithVariance           γ' t1s t2s $ varianceTyArgs tyInfo-       csvar' <- rsplitsCWithVariance isapplied γ' r1s r2s $ variancePsArgs tyInfo-       return $ cs ++ csvar ++ csvar'--splitC _ (SubC γ t1@(RVar a1 _) t2@(RVar a2 _))-  | a1 == a2-  = bsplitC γ t1 t2--splitC _ (SubC γ t1 t2)-  = panic (Just $ getLocation γ) $ "(Another Broken Test!!!) splitc unexpected:\n" ++ traceTy t1 ++ "\n  <:\n" ++ traceTy t2--splitC _ (SubR γ o r)-  = do ts     <- getTemplates-       let r1' = pruneUnsortedReft γ'' ts r1-       return $ F.subC γ' r1' r2 Nothing tag ci-  where-    γ'' = feEnv $ fenv γ-    γ'  = feBinds $ fenv γ-    r1  = F.RR F.boolSort rr-    r2  = F.RR F.boolSort $ F.Reft (vv, F.EVar vv)-    vv  = "vvRec"-    ci  = Ci src err (cgVar γ)-    err = Just $ ErrAssType src o (text $ show o ++ "type error") g (rHole rr)-    rr  = F.toReft r-    tag = getTag γ-    src = getLocation γ-    g   = reLocal $ renv γ--traceTy :: SpecType -> String-traceTy (RVar v _)      = parens ("RVar " ++ showpp v)-traceTy (RApp c ts _ _) = parens ("RApp " ++ showpp c ++ unwords (traceTy <$> ts))-traceTy (RAllP _ t)     = parens ("RAllP " ++ traceTy t)-traceTy (RAllT _ t _)   = parens ("RAllT " ++ traceTy t)-traceTy (RImpF _ _ t t' _) = parens ("RImpF " ++ parens (traceTy t) ++ parens (traceTy t'))-traceTy (RFun _ _ t t' _) = parens ("RFun " ++ parens (traceTy t) ++ parens (traceTy t'))-traceTy (RAllE _ tx t)  = parens ("RAllE " ++ parens (traceTy tx) ++ parens (traceTy t))-traceTy (REx _ tx t)    = parens ("REx " ++ parens (traceTy tx) ++ parens (traceTy t))-traceTy (RExprArg _)    = "RExprArg"-traceTy (RAppTy t t' _) = parens ("RAppTy " ++ parens (traceTy t) ++ parens (traceTy t'))-traceTy (RHole _)       = "rHole"-traceTy (RRTy _ _ _ t)  = parens ("RRTy " ++ traceTy t)--parens :: String -> String-parens s = "(" ++ s ++ ")"--rHole :: F.Reft -> SpecType-rHole = RHole . uTop---splitsCWithVariance :: CGEnv-                    -> [SpecType]-                    -> [SpecType]-                    -> [Variance]-                    -> CG [FixSubC]-splitsCWithVariance γ t1s t2s variants-  = concatMapM (\(t1, t2, v) -> splitfWithVariance (\s1 s2 -> splitC (typeclass (getConfig γ)) (SubC γ s1 s2)) t1 t2 v) (zip3 t1s t2s variants)--rsplitsCWithVariance :: Bool-                     -> CGEnv-                     -> [SpecProp]-                     -> [SpecProp]-                     -> [Variance]-                     -> CG [FixSubC]-rsplitsCWithVariance False _ _ _ _-  = return []--rsplitsCWithVariance _ γ t1s t2s variants-  = concatMapM (\(t1, t2, v) -> splitfWithVariance (rsplitC γ) t1 t2 v) (zip3 t1s t2s variants)--bsplitC :: CGEnv-        -> SpecType-        -> SpecType-        -> CG [F.SubC Cinfo]-bsplitC γ t1 t2 = do-  temp   <- getTemplates-  isHO   <- gets allowHO-  t1'    <- addLhsInv γ <$> refreshVV t1-  return  $ bsplitC' γ t1' t2 temp isHO--addLhsInv :: CGEnv -> SpecType -> SpecType-addLhsInv γ t = addRTyConInv (invs γ) t `strengthen` r-  where-    r         = (mempty :: UReft F.Reft) { ur_reft = F.Reft (F.dummySymbol, p) }-    p         = constraintToLogic rE' (lcs γ)-    rE'       = insertREnv v t (renv γ)-    v         = rTypeValueVar t---bsplitC' :: CGEnv -> SpecType -> SpecType -> F.Templates -> Bool -> [F.SubC Cinfo]-bsplitC' γ t1 t2 tem isHO- | isHO- = mkSubC γ' r1'  r2' tag ci- | F.isFunctionSortedReft r1' && F.isNonTrivial r2'- = mkSubC γ' (r1' {F.sr_reft = mempty}) r2' tag ci- | F.isNonTrivial r2'- = mkSubC γ' r1'  r2' tag ci- | otherwise- = []-  where-    γ'  = feBinds $ fenv γ-    r1' = rTypeSortedReft' γ tem t1-    r2' = rTypeSortedReft' γ tem t2-    tag = getTag γ-    src = getLocation γ-    g   = reLocal $ renv γ--    ci sr  = Ci src (err sr) (cgVar γ)-    err sr = Just $ fromMaybe (ErrSubType src (text "subtype") Nothing g t1 (replaceTop t2 sr)) (cerr γ)--mkSubC :: F.IBindEnv -> F.SortedReft -> F.SortedReft -> F.Tag -> (F.SortedReft -> a) -> [F.SubC a]-mkSubC g sr1 sr2 tag ci = concatMap (\sr2' -> F.subC g sr1 sr2' Nothing tag (ci sr2')) (splitSortedReft sr2)--splitSortedReft :: F.SortedReft -> [F.SortedReft]-splitSortedReft (F.RR t (F.Reft (v, r))) = [ F.RR t (F.Reft (v, ra)) | ra <- refaConjuncts r ]--refaConjuncts :: F.Expr -> [F.Expr]-refaConjuncts p = [p' | p' <- F.conjuncts p, not $ F.isTautoPred p']--replaceTop :: SpecType -> F.SortedReft -> SpecType-replaceTop (RApp c ts rs r) r'  = RApp c ts rs $ replaceReft r r'-replaceTop (RVar a r) r'        = RVar a       $ replaceReft r r'-replaceTop (RFun b i t1 t2 r) r' = RFun b i t1 t2 $ replaceReft r r'-replaceTop (RAppTy t1 t2 r) r'  = RAppTy t1 t2 $ replaceReft r r'-replaceTop (RAllT a t r)    r'  = RAllT a t    $ replaceReft r r'-replaceTop t _                  = t--replaceReft :: RReft -> F.SortedReft -> RReft-replaceReft rr (F.RR _ r) = rr {ur_reft = F.Reft (v, F.subst1  p (vr, F.EVar v) )}-  where-    F.Reft (v, _)         = ur_reft rr-    F.Reft (vr,p)         = r--unifyVV :: SpecType -> SpecType -> CG (SpecType, SpecType)-unifyVV t1@RApp{} t2@RApp{}-  = do vv <- F.vv . Just <$> fresh-       return (shiftVV t1 vv, shiftVV t2 vv)--unifyVV _ _-  = panic Nothing "Constraint.Generate.unifyVV called on invalid inputs"--rsplitC :: CGEnv-        -> SpecProp-        -> SpecProp-        -> CG [FixSubC]-rsplitC _ _ (RProp _ (RHole _))-  = panic Nothing "RefTypes.rsplitC on RProp _ (RHole _)"--rsplitC _ (RProp _ (RHole _)) _-  = panic Nothing "RefTypes.rsplitC on RProp _ (RHole _)"--rsplitC γ (RProp s1 r1) (RProp s2 r2)-  = do γ'  <-  foldM (+=) γ [("rsplitC1", x, ofRSort s) | (x, s) <- s2]-       splitC (typeclass (getConfig γ)) (SubC γ' (F.subst su r1) r2)-  where su = F.mkSubst [(x, F.EVar y) | ((x,_), (y,_)) <- zip s1 s2]-------------------------------------------------------------------------------------- | Reftypes from F.Fixpoint Expressions ------------------------------------------------------------------------------------------------------------------------forallExprRefType     :: CGEnv -> SpecType -> SpecType-forallExprRefType γ t = t `strengthen` uTop r'-  where-    r'                = fromMaybe mempty $ forallExprReft γ r-    r                 = F.sr_reft $ rTypeSortedReft (emb γ) t--forallExprReft :: CGEnv -> F.Reft -> Maybe F.Reft-forallExprReft γ r =-  do e <- F.isSingletonReft r-     forallExprReft_ γ $ F.splitEApp e--forallExprReft_ :: CGEnv -> (F.Expr, [F.Expr]) -> Maybe F.Reft-forallExprReft_ γ (F.EVar x, [])-  = case forallExprReftLookup γ x of-      Just (_,_,_,_,t)  -> Just $ F.sr_reft $ rTypeSortedReft (emb γ) t-      Nothing         -> Nothing--forallExprReft_ γ (F.EVar f, es)-  = case forallExprReftLookup γ f of-      Just (xs,_,_,_,t) -> let su = F.mkSubst $ safeZip "fExprRefType" xs es in-                       Just $ F.subst su $ F.sr_reft $ rTypeSortedReft (emb γ) t-      Nothing       -> Nothing--forallExprReft_ _ _-  = Nothing---- forallExprReftLookup :: CGEnv -> F.Symbol -> Int-forallExprReftLookup :: CGEnv-                     -> F.Symbol-                     -> Maybe ([F.Symbol], [RFInfo], [SpecType], [RReft], SpecType)-forallExprReftLookup γ x = snap <$> F.lookupSEnv x (syenv γ)-  where-    snap     = mapFifth5 ignoreOblig . (\(_,(x,a,b,c),t)->(x,a,b,c,t)) . bkArrow . thd3 . bkUniv . lookup-    lookup z = fromMaybe (panicUnbound γ z) (γ ?= F.symbol z)------------------------------------------------------------------------------------getTag :: CGEnv -> F.Tag----------------------------------------------------------------------------------getTag γ = maybe Tg.defaultTag (`Tg.getTag` tgEnv γ) (tgKey γ)-------------------------------------------------------------------------------------- | Constraint Generation Panic ---------------------------------------------------------------------------------------------------------------------------------panicUnbound :: (PPrint x) => CGEnv -> x -> a-panicUnbound γ x = Ex.throw (ErrUnbound (getLocation γ) (F.pprint x) :: Error)
− src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs 
@@ -1,318 +0,0 @@-{-# LANGUAGE FlexibleContexts          #-}--{-# OPTIONS_GHC -Wno-name-shadowing #-}--module Language.Haskell.Liquid.Constraint.ToFixpoint-  ( cgInfoFInfo-  , fixConfig-  , refinementEQs-  , canRewrite-  ) where--import           Prelude hiding (error)-import qualified Liquid.GHC.API as Ghc-import           Liquid.GHC.API (Var, Id, TyCon)-import qualified Language.Fixpoint.Types.Config as FC-import           System.Console.CmdArgs.Default (def)-import qualified Language.Fixpoint.Types        as F-import           Language.Fixpoint.Solver.Rewrite (unify)-import           Language.Haskell.Liquid.Constraint.Types-import qualified Language.Haskell.Liquid.Types.RefType as RT-import           Language.Haskell.Liquid.Constraint.Qualifier-import           Control.Monad (guard)-import qualified Data.Maybe as Mb---- AT: Move to own module?--- imports for AxiomEnv-import qualified Language.Haskell.Liquid.UX.Config as Config-import           Language.Haskell.Liquid.UX.DiffCheck (coreDefs, coreDeps, dependsOn, Def(..))-import qualified Liquid.GHC.Misc  as GM -- (simplesymbol)-import qualified Data.List                         as L-import qualified Data.HashMap.Strict               as M-import qualified Data.HashSet                      as S--- import           Language.Fixpoint.Misc-import qualified Language.Haskell.Liquid.Misc      as Misc--import           Language.Haskell.Liquid.Types hiding     ( binds )--fixConfig :: FilePath -> Config -> FC.Config-fixConfig tgt cfg = def-  { FC.solver                   = Mb.fromJust (smtsolver cfg)-  , FC.linear                   = linear            cfg-  , FC.eliminate                = eliminate         cfg-  , FC.nonLinCuts               = not (higherOrderFlag cfg) -- eliminate cfg /= FC.All-  , FC.save                     = saveQuery         cfg-  , FC.srcFile                  = tgt-  , FC.cores                    = cores             cfg-  , FC.minPartSize              = minPartSize       cfg-  , FC.maxPartSize              = maxPartSize       cfg-  , FC.elimStats                = elimStats         cfg-  , FC.elimBound                = elimBound         cfg-  , FC.allowHO                  = higherOrderFlag   cfg-  , FC.allowHOqs                = higherorderqs     cfg-  , FC.smtTimeout               = smtTimeout        cfg-  , FC.stringTheory             = stringTheory      cfg-  , FC.gradual                  = gradual           cfg-  , FC.ginteractive             = ginteractive       cfg-  , FC.noslice                  = noslice           cfg-  , FC.rewriteAxioms            = Config.allowPLE   cfg-  , FC.pleWithUndecidedGuards   = Config.pleWithUndecidedGuards cfg-  , FC.etaElim                  = not (exactDC cfg) && extensionality cfg -- SEE: https://github.com/ucsd-progsys/liquidhaskell/issues/1601-  , FC.extensionality           = extensionality    cfg-  , FC.interpreter              = interpreter    cfg-  , FC.oldPLE                   = oldPLE cfg-  , FC.rwTerminationCheck       = rwTerminationCheck cfg-  , FC.noLazyPLE                = noLazyPLE cfg-  , FC.fuel                     = fuel      cfg-  , FC.noEnvironmentReduction   = not (environmentReduction cfg)-  , FC.inlineANFBindings        = inlineANFBindings cfg-  }--cgInfoFInfo :: TargetInfo -> CGInfo -> IO (F.FInfo Cinfo)-cgInfoFInfo info cgi = return (targetFInfo info cgi)--targetFInfo :: TargetInfo -> CGInfo -> F.FInfo Cinfo-targetFInfo info cgi = mappend (mempty { F.ae = ax }) fi-  where-    fi               = F.fi cs ws bs ls consts ks qs bi aHO aHOqs es mempty adts ebs-    cs               = fixCs    cgi-    ws               = fixWfs   cgi-    bs               = binds    cgi-    ebs              = ebinds   cgi-    ls               = fEnv     cgi-    consts           = cgConsts cgi-    ks               = kuts     cgi-    adts             = cgADTs   cgi-    qs               = giQuals info (fEnv cgi)-    bi               = (\x -> Ci x Nothing Nothing) <$> bindSpans cgi-    aHO              = allowHO cgi-    aHOqs            = higherOrderFlag info-    es               = [] -- makeAxioms info-    ax               = makeAxiomEnvironment info (dataConTys cgi) (F.cm fi)-    -- msg              = show . map F.symbol . M.keys . tyConInfo--makeAxiomEnvironment :: TargetInfo -> [(Var, SpecType)] -> M.HashMap F.SubcId (F.SubC Cinfo) -> F.AxiomEnv-makeAxiomEnvironment info xts fcs-  = F.AEnv eqs-           (concatMap makeSimplify xts)-           (doExpand sp cfg <$> fcs)-           (makeRewrites info <$> fcs)-  where-    eqs      = if oldPLE cfg-                then makeEquations (typeclass cfg) sp ++ map (uncurry $ specTypeEq emb) xts-                else axioms-    emb      = gsTcEmbeds (gsName sp)-    cfg      = getConfig  info-    sp       = giSpec     info-    axioms   = gsMyAxioms refl ++ gsImpAxioms refl-    refl     = gsRefl sp---makeRewrites :: TargetInfo -> F.SubC Cinfo -> [F.AutoRewrite]-makeRewrites info sub = concatMap (makeRewriteOne tce) $ filter ((`S.member` rws) . fst) sigs-  where-    tce        = gsTcEmbeds (gsName spec)-    spec       = giSpec info-    sig        = gsSig spec-    sigs       = gsTySigs sig ++ gsAsmSigs sig-    isGlobalRw = Mb.maybe False (`elem` globalRws) parentFunction--    parentFunction :: Maybe Var-    parentFunction =-      case subVar sub of-        Just v -> Just v-        Nothing ->-          Mb.listToMaybe $ do-            D s e v <- coreDefs $ giCbs $ giSrc info-            let (Ghc.RealSrcSpan cc _) = ci_loc $ F.sinfo sub-            guard $ s <= Ghc.srcSpanStartLine cc && e >= Ghc.srcSpanEndLine cc-            return v--    rws =-      if isGlobalRw-      then S.empty-      else S.difference-        (S.union localRws globalRws)-        (Mb.maybe S.empty forbiddenRWs parentFunction)--    allDeps         = coreDeps $ giCbs $ giSrc info-    forbiddenRWs sv =-      S.insert sv $ dependsOn allDeps [sv]--    localRws = Mb.fromMaybe S.empty $ do-      var    <- parentFunction-      usable <- M.lookup var $ gsRewritesWith $ gsRefl spec-      return $ S.fromList usable--    globalRws = S.map val $ gsRewrites $ gsRefl spec---canRewrite :: S.HashSet F.Symbol -> F.Expr -> F.Expr -> Bool-canRewrite freeVars from to = noFreeSyms && doesNotDiverge-  where-    fromSyms           = S.intersection freeVars (S.fromList $ F.syms from)-    toSyms             = S.intersection freeVars (S.fromList $ F.syms to)-    noFreeSyms         = S.null $ S.difference toSyms fromSyms-    doesNotDiverge     = Mb.isNothing (unify (S.toList freeVars) from to)-                      || Mb.isJust (unify (S.toList freeVars) to from)--refinementEQs :: LocSpecType -> [(F.Expr, F.Expr)]-refinementEQs t =-  case stripRTypeBase tres of-    Just r ->-      [ (lhs, rhs) | (F.EEq lhs rhs) <- F.splitPAnd $ F.reftPred (F.toReft r) ]-    Nothing ->-      []-  where-    tres = ty_res tRep-    tRep = toRTypeRep $ val t--makeRewriteOne :: F.TCEmb TyCon -> (Var, LocSpecType) -> [F.AutoRewrite]-makeRewriteOne tce (_, t)-  = [rw | (lhs, rhs) <- refinementEQs t , rw <- rewrites lhs rhs ]-  where--    rewrites :: F.Expr -> F.Expr -> [F.AutoRewrite]-    rewrites lhs rhs =-         (guard (canRewrite freeVars lhs rhs) >> [F.AutoRewrite xs lhs rhs])-      ++ (guard (canRewrite freeVars rhs lhs) >> [F.AutoRewrite xs rhs lhs])--    freeVars = S.fromList (ty_binds tRep)--    xs = do-      (sym, arg) <- zip (ty_binds tRep) (ty_args tRep)-      let e = maybe F.PTrue (F.reftPred . F.toReft) (stripRTypeBase arg)-      return $ F.RR (rTypeSort tce arg) (F.Reft (sym, e))--    tRep = toRTypeRep $ val t--_isClassOrDict :: Id -> Bool-_isClassOrDict x = F.tracepp ("isClassOrDict: " ++ F.showpp x) (hasClassArg x || GM.isDictionary x || Mb.isJust (Ghc.isClassOpId_maybe x))--hasClassArg :: Id -> Bool-hasClassArg x = F.tracepp msg (GM.isDataConId x && any Ghc.isClassPred (t:ts'))-  where-    msg       = "hasClassArg: " ++ showpp (x, t:ts')-    (ts, t)   = Ghc.splitFunTys . snd . Ghc.splitForAllTys . Ghc.varType $ x-    ts'       = map Ghc.irrelevantMult ts---doExpand :: TargetSpec -> Config -> F.SubC Cinfo -> Bool-doExpand sp cfg sub = Config.allowGlobalPLE cfg-                   || (Config.allowLocalPLE cfg && maybe False (isPLEVar sp) (subVar sub))---- [TODO:missing-sorts] data-constructors often have unelaboratable 'define' so either--- 1. Make `elaborate` robust so it doesn't crash and returns maybe or--- 2. Make the `ctor` well-sorted or --- 3. Don't create `define` for the ctor. --- Unfortunately 3 breaks a bunch of tests...--specTypeEq :: F.TCEmb TyCon -> Var -> SpecType -> F.Equation-specTypeEq emb f t = F.mkEquation (F.symbol f) xts body tOut-  where-    xts            = Misc.safeZipWithError "specTypeEq" xs (RT.rTypeSort emb <$> ts)-    body           = specTypeToResultRef bExp t-    tOut           = RT.rTypeSort emb (ty_res tRep)-    tRep           = toRTypeRep t-    xs             = ty_binds tRep-    ts             = ty_args  tRep-    bExp           = F.eApps (F.eVar f) (F.EVar <$> xs)--makeSimplify :: (Var, SpecType) -> [F.Rewrite]-makeSimplify (x, t)-  | not (GM.isDataConId x)-  = []-  | otherwise-  = go $ specTypeToResultRef (F.eApps (F.EVar $ F.symbol x) (F.EVar <$> ty_binds (toRTypeRep t))) t-  where-    go (F.PAnd es) = concatMap go es--    go (F.PAtom eq (F.EApp (F.EVar f) dc) bd)-      | eq `elem` [F.Eq, F.Ueq]-      , (F.EVar dc, xs) <- F.splitEApp dc-      , dc == F.symbol x-      , all isEVar xs-      = [F.SMeasure f dc (fromEVar <$> xs) bd]--    go (F.PIff (F.EApp (F.EVar f) dc) bd)-      | (F.EVar dc, xs) <- F.splitEApp dc-      , dc == F.symbol x-      , all isEVar xs-      = [F.SMeasure f dc (fromEVar <$> xs) bd]--    go (F.EApp (F.EVar f) dc)-      | (F.EVar dc, xs) <- F.splitEApp dc-      , dc == F.symbol x-      , all isEVar xs-      = [F.SMeasure f dc (fromEVar <$> xs) F.PTrue]--    go (F.PNot (F.EApp (F.EVar f) dc))-      | (F.EVar dc, xs) <- F.splitEApp dc-      , dc == F.symbol x-      , all isEVar xs-      = [F.SMeasure f dc (fromEVar <$> xs) F.PFalse]--    go _ = []--    isEVar (F.EVar _) = True-    isEVar _ = False--    fromEVar (F.EVar x) = x-    fromEVar _ = impossible Nothing "makeSimplify.fromEVar"--makeEquations :: Bool -> TargetSpec -> [F.Equation]-makeEquations allowTC sp = [ F.mkEquation f xts (equationBody allowTC (F.EVar f) xArgs e mbT) t-                      | F.Equ f xts e t _ <- axioms-                      , let xArgs          = F.EVar . fst <$> xts-                      , let mbT            = if null xArgs then Nothing else M.lookup f sigs-                   ]-  where-    axioms       = gsMyAxioms refl ++ gsImpAxioms refl-    refl         = gsRefl sp-    sigs         = M.fromList [ (GM.simplesymbol v, t) | (v, t) <- gsTySigs (gsSig sp) ]--equationBody :: Bool -> F.Expr -> [F.Expr] -> F.Expr -> Maybe LocSpecType -> F.Expr-equationBody allowTC f xArgs e mbT-  | Just t <- mbT = F.pAnd [eBody, rBody t]-  | otherwise     = eBody-  where-    eBody         = F.PAtom F.Eq (F.eApps f xArgs) e-    rBody t       = specTypeToLogic allowTC xArgs (F.eApps f xArgs) (val t)---- NV Move this to types?--- sound but imprecise approximation of a type in the logic-specTypeToLogic :: Bool -> [F.Expr] -> F.Expr -> SpecType -> F.Expr-specTypeToLogic allowTC es e t-  | ok        = F.subst su (F.PImp (F.pAnd args) res)-  | otherwise = F.PTrue-  where-    res       = specTypeToResultRef e t-    args      = zipWith mkExpr (mkReft <$> ts) es-    mkReft t  =  F.toReft $ Mb.fromMaybe mempty (stripRTypeBase t)-    mkExpr (F.Reft (v, ev)) e = F.subst1 ev (v, e)---    ok      = okLen && okClass && okArgs-    okLen   = length xs == length xs-    okClass = all (F.isTauto . snd) cls-    okArgs  = all okArg ts--    okArg (RVar _ _) = True-    okArg t@RApp{}   = F.isTauto (t{rt_reft = mempty})-    okArg _          = False---    su           = F.mkSubst $ zip xs es-    (cls, nocls) = L.partition ((if allowTC then isEmbeddedClass else isClassType).snd) $ zip (ty_binds trep) (ty_args trep)-                 :: ([(F.Symbol, SpecType)], [(F.Symbol, SpecType)])-    (xs, ts)     = unzip nocls :: ([F.Symbol], [SpecType])--    trep = toRTypeRep t---specTypeToResultRef :: F.Expr -> SpecType -> F.Expr-specTypeToResultRef e t-  = mkExpr $ F.toReft $ Mb.fromMaybe mempty (stripRTypeBase $ ty_res trep)-  where-    mkExpr (F.Reft (v, ev)) = F.subst1 ev (v, e)-    trep                   = toRTypeRep t
− src/Language/Haskell/Liquid/Constraint/Types.hs 
@@ -1,474 +0,0 @@-{-# LANGUAGE OverloadedStrings    #-}-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE TupleSections        #-}-{-# LANGUAGE FlexibleInstances    #-}--{-# OPTIONS_GHC -Wno-name-shadowing #-}--module Language.Haskell.Liquid.Constraint.Types-  ( -- * Constraint Generation Monad-    CG--    -- * Constraint information-  , CGInfo (..)--    -- * Constraint Generation Environment-  , CGEnv (..)--    -- * Logical constraints (FIXME: related to bounds?)-  , LConstraint (..)--    -- * Fixpoint environment-  , FEnv (..)-  , initFEnv-  , insertsFEnv-  -- , removeFEnv--   -- * Hole Environment-  , HEnv-  , fromListHEnv-  , elemHEnv--   -- * Subtyping Constraints-  , SubC (..)-  , FixSubC--  , subVar--   -- * Well-formedness Constraints-  , WfC (..)-  , FixWfC--   -- * Invariants-  , RTyConInv-  , mkRTyConInv-  , addRTyConInv-  , addRInv--  -- * Aliases?-  , RTyConIAl-  , mkRTyConIAl--  , removeInvariant, restoreInvariant, makeRecInvariants--  , getTemplates--  , getLocation-  ) where--import Prelude hiding (error)-import           Text.PrettyPrint.HughesPJ hiding ((<>))-import qualified Data.HashMap.Strict as M-import qualified Data.HashSet        as S-import qualified Data.List           as L-import           Control.DeepSeq-import           Data.Maybe               (isJust, mapMaybe)-import           Control.Monad.State--import           Liquid.GHC.SpanStack-import           Liquid.GHC.API    as Ghc hiding ( (<+>)-                                                                  , vcat-                                                                  , parens-                                                                  , ($+$)-                                                                  , LC-                                                                  )-import           Language.Haskell.Liquid.Misc           (thrd3)-import           Language.Haskell.Liquid.WiredIn        (wiredSortedSyms)-import qualified Language.Fixpoint.Types            as F-import           Language.Fixpoint.Misc--import qualified Language.Haskell.Liquid.UX.CTags      as Tg--import           Language.Haskell.Liquid.Types hiding   (binds)--type CG = State CGInfo--data CGEnv = CGE-  { cgLoc    :: !SpanStack         -- ^ Location in original source file-  , renv     :: !REnv              -- ^ SpecTypes for Bindings in scope-  , syenv    :: !(F.SEnv Var)      -- ^ Map from free Symbols (e.g. datacons) to Var-  , denv     :: !RDEnv             -- ^ Dictionary Environment-  , litEnv   :: !(F.SEnv F.Sort)   -- ^ Global  literals-  , constEnv :: !(F.SEnv F.Sort)   -- ^ Distinct literals-  , fenv   :: !FEnv              -- ^ Fixpoint Environment-  , recs   :: !(S.HashSet Var)   -- ^ recursive defs being processed (for annotations)-  , invs   :: !RTyConInv         -- ^ Datatype invariants-  , rinvs  :: !RTyConInv         -- ^ Datatype recursive invariants: ignored in the base case assumed in rec call-  , ial    :: !RTyConIAl         -- ^ Datatype checkable invariants-  , grtys  :: !REnv              -- ^ Top-level variables with (assert)-guarantees to verify-  , assms  :: !REnv              -- ^ Top-level variables with assumed types-  , intys  :: !REnv              -- ^ Top-level variables with auto generated internal types-  , emb    :: F.TCEmb Ghc.TyCon   -- ^ How to embed GHC Tycons into fixpoint sorts-  , tgEnv  :: !Tg.TagEnv          -- ^ Map from top-level binders to fixpoint tag-  , tgKey  :: !(Maybe Tg.TagKey)                     -- ^ Current top-level binder-  , trec   :: !(Maybe (M.HashMap F.Symbol SpecType)) -- ^ Type of recursive function with decreasing constraints-  , lcb    :: !(M.HashMap F.Symbol CoreExpr)         -- ^ Let binding that have not been checked (c.f. LAZYVARs)-  , forallcb :: !(M.HashMap Var F.Expr)              -- ^ Polymorhic let bindings-  , holes  :: !HEnv                                  -- ^ Types with holes, will need refreshing-  , lcs    :: !LConstraint                           -- ^ Logical Constraints-  , cerr   :: !(Maybe (TError SpecType))             -- ^ error that should be reported at the user-  , cgInfo :: !TargetInfo                            -- ^ top-level TargetInfo-  , cgVar  :: !(Maybe Var)                           -- ^ top level function being checked-  } -- deriving (Data, Typeable)--instance HasConfig CGEnv where-  getConfig = getConfig . cgInfo--newtype LConstraint = LC [[(F.Symbol, SpecType)]]--instance Monoid LConstraint where-  mempty  = LC []-  mappend = (<>)--instance Semigroup LConstraint where-  LC cs1 <> LC cs2 = LC (cs1 ++ cs2)--instance PPrint CGEnv where-  pprintTidy k = pprintTidy k . renv--instance Show CGEnv where-  show = showpp--getLocation :: CGEnv -> SrcSpan-getLocation = srcSpan . cgLoc------------------------------------------------------------------------------------- | Subtyping Constraints ------------------------------------------------------------------------------------------------------------------------------------------ RJ: what is the difference between these two?--data SubC     = SubC { senv  :: !CGEnv-                     , lhs   :: !SpecType-                     , rhs   :: !SpecType-                     }-              | SubR { senv  :: !CGEnv-                     , oblig :: !Oblig-                     , ref   :: !RReft-                     }--data WfC      = WfC  !CGEnv !SpecType-              -- deriving (Data, Typeable)--type FixSubC    = F.SubC Cinfo-type FixWfC     = F.WfC Cinfo-type FixBindEnv = F.BindEnv Cinfo--subVar :: FixSubC -> Maybe Var-subVar = ci_var . F.sinfo--instance PPrint SubC where-  pprintTidy k c@SubC {} =-    "The environment:"-    $+$-    ""-    $+$-    pprintTidy k (senv c)-    $+$-    ""-    $+$-    "Location: " <> pprintTidy k (getLocation (senv c))-    $+$-    "The constraint:"-    $+$-    ""-    $+$-    "||-" <+> vcat [ pprintTidy k (lhs c)-                   , "<:"-                   , pprintTidy k (rhs c) ]--  pprintTidy k c@SubR {} =-    "The environment:"-    $+$-    ""-    $+$-    pprintTidy k (senv c)-    $+$-    ""-    $+$-    "Location: " <> pprintTidy k (getLocation (senv c))-    $+$-    "The constraint:"-    $+$-    ""-    $+$-    "||-" <+> vcat [ pprintTidy k (ref c)-                   , parens (pprintTidy k (oblig c))]--instance PPrint WfC where-  pprintTidy k (WfC _ r) = {- pprintTidy k w <> text -} "<...> |-" <+> pprintTidy k r-------------------------------------------------------------------------------------- | Generation: Types -------------------------------------------------------------------------------------------------------------------------------------------data CGInfo = CGInfo-  { fEnv       :: !(F.SEnv F.Sort)             -- ^ top-level fixpoint env-  , hsCs       :: ![SubC]                      -- ^ subtyping constraints over RType-  , hsWfs      :: ![WfC]                       -- ^ wellformedness constraints over RType-  , fixCs      :: ![FixSubC]                   -- ^ subtyping over Sort (post-splitting)-  , fixWfs     :: ![FixWfC]                    -- ^ wellformedness constraints over Sort (post-splitting)-  , freshIndex :: !Integer                     -- ^ counter for generating fresh KVars-  , binds      :: !FixBindEnv                   -- ^ set of environment binders-  , ebinds     :: ![F.BindId]                  -- ^ existentials-  , annotMap   :: !(AnnInfo (Annot SpecType))  -- ^ source-position annotation map-  , holesMap   :: !(M.HashMap Var (HoleInfo (CGInfo, CGEnv) SpecType))    -- ^ information for ghc hole expressions-  , tyConInfo  :: !TyConMap                    -- ^ information about type-constructors-  , specDecr   :: ![(Var, [Int])]              -- ^ ^ Lexicographic order of decreasing args (DEPRECATED)-  , newTyEnv   :: !(M.HashMap Ghc.TyCon SpecType)        -- ^ Mapping of new type type constructors with their refined types.-  , termExprs  :: !(M.HashMap Var [F.Located F.Expr])   -- ^ Terminating Metrics for Recursive functions-  , specLVars  :: !(S.HashSet Var)             -- ^ Set of variables to ignore for termination checking-  , specLazy   :: !(S.HashSet Var)             -- ^ "Lazy binders", skip termination checking-  , specTmVars :: !(S.HashSet Var)             -- ^ Binders that FAILED struct termination check that MUST be checked-  , autoSize   :: !(S.HashSet Ghc.TyCon)        -- ^ ? FIX THIS-  , tyConEmbed :: !(F.TCEmb Ghc.TyCon)          -- ^ primitive Sorts into which TyCons should be embedded-  , kuts       :: !F.Kuts                      -- ^ Fixpoint Kut variables (denoting "back-edges"/recursive KVars)-  , kvPacks    :: ![S.HashSet F.KVar]          -- ^ Fixpoint "packs" of correlated kvars-  , cgLits     :: !(F.SEnv F.Sort)             -- ^ Global symbols in the refinement logic-  , cgConsts   :: !(F.SEnv F.Sort)             -- ^ Distinct constant symbols in the refinement logic-  , cgADTs     :: ![F.DataDecl]                -- ^ ADTs extracted from Haskell 'data' definitions-  , tcheck     :: !Bool                        -- ^ Check Termination (?)-  , cgiTypeclass :: !Bool                      -- ^ Enable typeclass support-  , pruneRefs  :: !Bool                        -- ^ prune unsorted refinements-  , logErrors  :: ![Error]                     -- ^ Errors during constraint generation-  , kvProf     :: !KVProf                      -- ^ Profiling distribution of KVars-  , recCount   :: !Int                         -- ^ number of recursive functions seen (for benchmarks)-  , bindSpans  :: M.HashMap F.BindId SrcSpan   -- ^ Source Span associated with Fixpoint Binder-  , allowHO    :: !Bool-  , ghcI       :: !TargetInfo-  , dataConTys :: ![(Var, SpecType)]           -- ^ Refined Types of Data Constructors-  , unsorted   :: !F.Templates                 -- ^ Potentially unsorted expressions-  }---getTemplates :: CG F.Templates-getTemplates = do-  fg    <- gets pruneRefs-  ts    <- gets unsorted-  return $ if fg then F.anything else ts---instance PPrint CGInfo where-  pprintTidy = pprCGInfo--pprCGInfo :: F.Tidy -> CGInfo -> Doc-pprCGInfo _k _cgi-  =  "*********** Constraint Information (omitted) *************"-  -- -$$ (text "*********** Haskell SubConstraints ***********")-  -- -$$ (pprintLongList $ hsCs  cgi)-  -- -$$ (text "*********** Haskell WFConstraints ************")-  -- -$$ (pprintLongList $ hsWfs cgi)-  -- -$$ (text "*********** Fixpoint SubConstraints **********")-  -- -$$ (F.toFix  $ fixCs cgi)-  -- -$$ (text "*********** Fixpoint WFConstraints ************")-  -- -$$ (F.toFix  $ fixWfs cgi)-  -- -$$ (text "*********** Fixpoint Kut Variables ************")-  -- -$$ (F.toFix  $ kuts cgi)-  -- -$$ "*********** Literals in Source     ************"-  -- -$$ F.pprint (cgLits _cgi)-  -- -$$ (text "*********** KVar Distribution *****************")-  -- -$$ (pprint $ kvProf cgi)-  -- -$$ (text "Recursive binders:" <+> pprint (recCount cgi))-------------------------------------------------------------------------------------- | Helper Types: HEnv -------------------------------------------------------------------------------------------------------------------------------------------newtype HEnv = HEnv (S.HashSet F.Symbol)--fromListHEnv :: [F.Symbol] -> HEnv-fromListHEnv = HEnv . S.fromList--elemHEnv :: F.Symbol -> HEnv -> Bool-elemHEnv x (HEnv s) = x `S.member` s------------------------------------------------------------------------------------- | Helper Types: Invariants ------------------------------------------------------------------------------------------------------------------------------------data RInv = RInv { _rinv_args :: [RSort]   -- empty list means that the invariant is generic-                                           -- for all type arguments-                 , _rinv_type :: SpecType-                 , _rinv_name :: Maybe Var-                 } deriving Show--type RTyConInv = M.HashMap RTyCon [RInv]-type RTyConIAl = M.HashMap RTyCon [RInv]-----------------------------------------------------------------------------------mkRTyConInv    :: [(Maybe Var, F.Located SpecType)] -> RTyConInv----------------------------------------------------------------------------------mkRTyConInv ts = group [ (c, RInv (go ts) t v) | (v, t@(RApp c ts _ _)) <- strip <$> ts]-  where-    strip = mapSnd (thrd3 . bkUniv . val)-    go ts | generic (toRSort <$> ts) = []-          | otherwise                = toRSort <$> ts--    generic ts = let ts' = L.nub ts in-                 all isRVar ts' && length ts' == length ts--mkRTyConIAl :: [(a, F.Located SpecType)] -> RTyConInv-mkRTyConIAl    = mkRTyConInv . fmap ((Nothing,) . snd)--addRTyConInv :: RTyConInv -> SpecType -> SpecType-addRTyConInv m t-  = case lookupRInv t m of-      Nothing -> t-      Just ts -> L.foldl' conjoinInvariantShift t ts--lookupRInv :: SpecType -> RTyConInv -> Maybe [SpecType]-lookupRInv (RApp c ts _ _) m-  = case M.lookup c m of-      Nothing   -> Nothing-      Just invs -> Just (mapMaybe (goodInvs ts) invs)-lookupRInv _ _-  = Nothing--goodInvs :: [SpecType] -> RInv -> Maybe SpecType-goodInvs _ (RInv []  t _)-  = Just t-goodInvs ts (RInv ts' t _)-  | and (zipWith unifiable ts' (toRSort <$> ts))-  = Just t-  | otherwise-  = Nothing---unifiable :: RSort -> RSort -> Bool-unifiable t1 t2 = isJust $ tcUnifyTy (toType False t1) (toType False t2)--addRInv :: RTyConInv -> (Var, SpecType) -> (Var, SpecType)-addRInv m (x, t)-  | x `elem` ids , Just invs <- lookupRInv (res t) m-  = (x, addInvCond t (mconcat $ mapMaybe stripRTypeBase invs))-  | otherwise-  = (x, t)-   where-     ids = [id | tc <- M.keys m-               , dc <- Ghc.tyConDataCons $ rtc_tc tc-               , AnId id <- Ghc.dataConImplicitTyThings dc]-     res = ty_res . toRTypeRep--conjoinInvariantShift :: SpecType -> SpecType -> SpecType-conjoinInvariantShift t1 t2-  = conjoinInvariant t1 (shiftVV t2 (rTypeValueVar t1))--conjoinInvariant :: SpecType -> SpecType -> SpecType-conjoinInvariant (RApp c ts rs r) (RApp ic its _ ir)-  | c == ic && length ts == length its-  = RApp c (zipWith conjoinInvariantShift ts its) rs (r `F.meet` ir)--conjoinInvariant t@(RApp _ _ _ r) (RVar _ ir)-  = t { rt_reft = r `F.meet` ir }--conjoinInvariant t@(RVar _ r) (RVar _ ir)-  = t { rt_reft = r `F.meet` ir }--conjoinInvariant t _-  = t--removeInvariant  :: CGEnv -> CoreBind -> (CGEnv, RTyConInv)-removeInvariant γ cbs-  = (γ { invs  = M.map (filter f) (invs γ)-       , rinvs = M.map (filter (not . f)) (invs γ)}-    , invs γ)-  where-    f i | Just v  <- _rinv_name i, v `elem` binds cbs-        = False-        | otherwise-        = True-    binds (NonRec x _) = [x]-    binds (Rec xes)    = map fst xes--restoreInvariant :: CGEnv -> RTyConInv -> CGEnv-restoreInvariant γ is = γ {invs = is}--makeRecInvariants :: CGEnv -> [Var] -> CGEnv-makeRecInvariants γ [x] = γ {invs = M.unionWith (++) (invs γ) is}-  where-    is  =  M.map (map f . filter (isJust . (varType x `tcUnifyTy`) . toType False . _rinv_type)) (rinvs γ)-    f i = i{_rinv_type = guard $ _rinv_type i}--    guard (RApp c ts rs r)-      | Just f <- szFun <$> sizeFunction (rtc_info c)-      = RApp c ts rs (MkUReft (ref f $ F.toReft r) mempty)-      | otherwise-      = RApp c ts rs mempty-    guard t-      = t--    ref f (F.Reft(v, rr))-      = F.Reft (v, F.PImp (F.PAtom F.Lt (f v) (f $ F.symbol x)) rr)--makeRecInvariants γ _ = γ------------------------------------------------------------------------------------- | Fixpoint Environment -----------------------------------------------------------------------------------------------------------------------------------------data FEnv = FE-  { feBinds :: !F.IBindEnv        -- ^ Integer Keys for Fixpoint Environment-  , feEnv   :: !(F.SEnv F.Sort)   -- ^ Fixpoint Environment-  , feIdEnv :: !(F.SEnv F.BindId) -- ^ Map from Symbol to current BindId-  }--insertFEnv :: FEnv -> ((F.Symbol, F.Sort), F.BindId) -> FEnv-insertFEnv (FE benv env ienv) ((x, t), i)-  = FE (F.insertsIBindEnv [i] benv)-       (F.insertSEnv x t      env)-       (F.insertSEnv x i      ienv)--insertsFEnv :: FEnv -> [((F.Symbol, F.Sort), F.BindId)] -> FEnv-insertsFEnv = L.foldl' insertFEnv--initFEnv :: [(F.Symbol, F.Sort)] -> FEnv-initFEnv xts = FE benv0 env0 ienv0-  where-    benv0    = F.emptyIBindEnv-    env0     = F.fromListSEnv (wiredSortedSyms ++ xts)-    ienv0    = F.emptySEnv------------------------------------------------------------------------------------- | Forcing Strictness ------------------------------------------------------------------------------------------------------------------------------------------instance NFData RInv where-  rnf (RInv x y z) = rnf x `seq` rnf y `seq` rnf z--instance NFData CGEnv where-  rnf (CGE x1 _ x3 _ x4 x5 x55 x6 x7 x8 x9 _ _ _ x10 _ _ _ _ _ _ _ _ _ _)-    = x1 `seq` {- rnf x2 `seq` -} seq x3-         `seq` rnf x5-         `seq` rnf x55-         `seq` rnf x6-         `seq` x7-         `seq` rnf x8-         `seq` rnf x9-         `seq` rnf x10-         `seq` rnf x4--instance NFData FEnv where-  rnf (FE x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3--instance NFData SubC where-  rnf (SubC x1 x2 x3)-    = rnf x1 `seq` rnf x2 `seq` rnf x3-  rnf (SubR x1 _ x2)-    = rnf x1 `seq` rnf x2--instance NFData WfC where-  rnf (WfC x1 x2)-    = rnf x1 `seq` rnf x2--instance NFData CGInfo where-  rnf x = ({-# SCC "CGIrnf1" #-}  rnf (hsCs x))       `seq`-          ({-# SCC "CGIrnf2" #-}  rnf (hsWfs x))      `seq`-          ({-# SCC "CGIrnf3" #-}  rnf (fixCs x))      `seq`-          ({-# SCC "CGIrnf4" #-}  rnf (fixWfs x))     `seq`-          ({-# SCC "CGIrnf6" #-}  rnf (freshIndex x)) `seq`-          ({-# SCC "CGIrnf7" #-}  rnf (binds x))      `seq`-          ({-# SCC "CGIrnf8" #-}  rnf (annotMap x))   `seq`-          ({-# SCC "CGIrnf10" #-} rnf (kuts x))       `seq`-          ({-# SCC "CGIrnf10" #-} rnf (kvPacks x))    `seq`-          ({-# SCC "CGIrnf10" #-} rnf (cgLits x))     `seq`-          ({-# SCC "CGIrnf10" #-} rnf (cgConsts x))   `seq`-          ({-# SCC "CGIrnf10" #-} rnf (kvProf x))
− src/Language/Haskell/Liquid/GHC/Plugin.hs 
@@ -1,646 +0,0 @@--- | This module provides a GHC 'Plugin' that allows LiquidHaskell to be hooked directly into GHC's--- compilation pipeline, facilitating its usage and adoption.--{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE LambdaCase                 #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE RecordWildCards            #-}-{-# LANGUAGE ViewPatterns               #-}--module Language.Haskell.Liquid.GHC.Plugin (--  plugin--  ) where--import qualified Liquid.GHC.API         as O-import           Liquid.GHC.API         as GHC hiding (Target, Type)-import qualified Text.PrettyPrint.HughesPJ               as PJ-import qualified Language.Fixpoint.Types                 as F-import qualified Liquid.GHC.Misc        as LH-import qualified Language.Haskell.Liquid.UX.CmdLine      as LH-import qualified Liquid.GHC.Interface   as LH-import qualified Language.Haskell.Liquid.Liquid          as LH-import qualified Language.Haskell.Liquid.Types.PrettyPrint as LH ( filterReportErrors-                                                                 , filterReportErrorsWith-                                                                 , defaultFilterReporter-                                                                 , reduceFilters )-import qualified Liquid.GHC.Logging     as LH   (fromPJDoc)--import           Language.Haskell.Liquid.GHC.Plugin.Types-import           Language.Haskell.Liquid.GHC.Plugin.Util as Util-import           Language.Haskell.Liquid.GHC.Plugin.SpecFinder-                                                         as SpecFinder--import           Liquid.GHC.Types       (MGIModGuts(..), miModGuts)-import qualified Liquid.GHC.GhcMonadLike-                                                         as GhcMonadLike-import           Liquid.GHC.GhcMonadLike ( GhcMonadLike-                                                          , askHscEnv-                                                          , isBootInterface-                                                          )-import           GHC.LanguageExtensions--import           Control.Monad--import           Data.Coerce-import           Data.Kind                                ( Type )-import           Data.List                               as L-                                                   hiding ( intersperse )-import           Data.IORef-import qualified Data.Set                                as S-import           Data.Set                                 ( Set )---import qualified Data.HashSet                            as HS-import qualified Data.HashMap.Strict                     as HM--import           System.IO.Unsafe                         ( unsafePerformIO )-import           Language.Fixpoint.Types           hiding ( errs-                                                          , panic-                                                          , Error-                                                          , Result-                                                          , Expr-                                                          )--import qualified Language.Haskell.Liquid.Measure         as Ms-import           Language.Haskell.Liquid.Parse-import           Language.Haskell.Liquid.Transforms.ANF-import           Language.Haskell.Liquid.Types     hiding ( getConfig )-import           Language.Haskell.Liquid.Bare-import           Language.Haskell.Liquid.UX.CmdLine--import           Optics---- | Represents an abnormal but non-fatal state of the plugin. Because it is not--- meant to escape the plugin, it is not thrown in IO but instead carried around--- in an `Either`'s `Left` case and handled at the top level of the plugin--- function.-newtype LiquidCheckException = ErrorsOccurred [Filter] -- Unmatched expected errors-  deriving (Eq, Ord, Show)-------------------------------------------------------------------------------------- | State and configuration management ------------------------------------------------------------------------------------------------------------------------------- | A reference to cache the LH's 'Config' and produce it only /once/, during the dynFlags hook.-cfgRef :: IORef Config-cfgRef = unsafePerformIO $ newIORef defConfig-{-# NOINLINE cfgRef #-}---- | Set to 'True' to enable debug logging.-debugLogs :: Bool-debugLogs = False-------------------------------------------------------------------------------------- | Useful functions ------------------------------------------------------------------------------------------------------------------------------------------------- | Reads the 'Config' out of a 'IORef'.-getConfig :: IO Config-getConfig = readIORef cfgRef---- | Combinator which conditionally print on the screen based on the value of 'debugLogs'.-debugLog :: MonadIO m => String -> m ()-debugLog msg = when debugLogs $ liftIO (putStrLn msg)-------------------------------------------------------------------------------------- | The Plugin entrypoint ------------------------------------------------------------------------------------------------------------------------------------------plugin :: GHC.Plugin-plugin = GHC.defaultPlugin {-    typeCheckResultAction = liquidPlugin-  , dynflagsPlugin        = customDynFlags-  , pluginRecompile       = purePlugin-  }-  where-    -- Unfortunately, we can't make Haddock run the LH plugin, because the former-    -- does mangle the '.hi' files, causing annotations to not be persisted in the-    -- 'ExternalPackageState' and/or 'HomePackageTable'. For this reason we disable-    -- the plugin altogether is the module is being compiled with Haddock.-    -- See also: https://github.com/ucsd-progsys/liquidhaskell/issues/1727-    -- for a post-mortem.-    liquidPlugin :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv-    liquidPlugin opts summary gblEnv = do-      dynFlags <- getDynFlags-      withTiming dynFlags (text "LiquidHaskell" <+> brackets (ppr $ ms_mod_name summary)) (const ()) $ do-        if gopt Opt_Haddock dynFlags-          then do-            -- Warn the user-            let msg     = PJ.vcat [ PJ.text "LH can't be run with Haddock."-                                  , PJ.nest 4 $ PJ.text "Documentation will still be created."-                                  ]-            let srcLoc  = mkSrcLoc (mkFastString $ ms_hspp_file summary) 1 1-            let warning = mkWarning (mkSrcSpan srcLoc srcLoc) msg-            liftIO $ printWarning dynFlags warning-            pure gblEnv-          else do-            newGblEnv <- typecheckHook opts summary gblEnv-            case newGblEnv of-              -- Exit with success if all expected errors were found-              Left (ErrorsOccurred []) -> pure gblEnv-              -- Exit with error if there were unmatched expected errors-              Left (ErrorsOccurred errorFilters) -> do-                defaultFilterReporter (LH.modSummaryHsFile summary) errorFilters-                failM-              Right newGblEnv' ->-                pure newGblEnv'------------------------------------------------------------------------------------- | GHC Configuration & Setup -------------------------------------------------------------------------------------------------------------------------------------- | Overrides the default 'DynFlags' options. Specifically, we need the GHC--- lexer not to throw away block comments, as this is where the LH spec comments--- would live. This is why we set the 'Opt_KeepRawTokenStream' option.-customDynFlags :: [CommandLineOption] -> DynFlags -> IO DynFlags-customDynFlags opts dflags = do-  cfg <- liftIO $ LH.getOpts opts-  writeIORef cfgRef cfg-  configureDynFlags dflags-  where-    configureDynFlags :: DynFlags -> IO DynFlags-    configureDynFlags df =-      pure $ df `gopt_set` Opt_ImplicitImportQualified-                `gopt_set` Opt_PIC-                `gopt_set` Opt_DeferTypedHoles-                `gopt_set` Opt_KeepRawTokenStream-                `xopt_set` MagicHash-                `xopt_set` DeriveGeneric-                `xopt_set` StandaloneDeriving------------------------------------------------------------------------------------- | \"Unoptimising\" things ----------------------------------------------------------------------------------------------------------------------------------------- | LiquidHaskell requires the unoptimised core binds in order to work correctly, but at the same time the--- user can invoke GHC with /any/ optimisation flag turned out. This is why we grab the core binds by--- desugaring the module during /parsing/ (before that's already too late) and we cache the core binds for--- the rest of the program execution.-class Unoptimise a where-  type UnoptimisedTarget a :: Type-  unoptimise :: a -> UnoptimisedTarget a--instance Unoptimise DynFlags where-  type UnoptimisedTarget DynFlags = DynFlags-  unoptimise df = updOptLevel 0 df-    { debugLevel   = 1-    , ghcLink      = LinkInMemory-    , hscTarget    = HscInterpreted-    , ghcMode      = CompManager-    }--instance Unoptimise ModSummary where-  type UnoptimisedTarget ModSummary = ModSummary-  unoptimise modSummary = modSummary { ms_hspp_opts = unoptimise (ms_hspp_opts modSummary) }--instance Unoptimise (DynFlags, HscEnv) where-  type UnoptimisedTarget (DynFlags, HscEnv) = HscEnv-  unoptimise (unoptimise -> df, env) = env { hsc_dflags = df }------------------------------------------------------------------------------------- | Typechecking phase --------------------------------------------------------------------------------------------------------------------------------------------- | We hook at this stage of the pipeline in order to call \"liquidhaskell\". This--- might seems counterintuitive as LH works on a desugared module. However, there--- are a bunch of reasons why we do this:------ 1. Tools like \"ghcide\" works by running the compilation pipeline up until---    this stage, which means that we won't be able to report errors and warnings---    if we call /LH/ any later than here;------ 2. Although /LH/ works on \"Core\", it requires the _unoptimised_ \"Core\" that we---    grab from parsing (again) the module by using the GHC API, so we are really---    independent from the \"normal\" compilation pipeline.----typecheckHook :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM (Either LiquidCheckException TcGblEnv)-typecheckHook _ (unoptimise -> modSummary) tcGblEnv = do-  debugLog $ "We are in module: " <> show (toStableModule thisModule)--  parsed        <- GhcMonadLike.parseModule (LH.keepRawTokenStream cleanedSummary)-  let comments  = LH.extractSpecComments (pm_annotations parsed)-  typechecked     <- GhcMonadLike.typecheckModule (LH.ignoreInline parsed)-  env             <- askHscEnv-  resolvedNames   <- LH.lookupTyThings env modSummary tcGblEnv-  availTyCons     <- LH.availableTyCons env modSummary tcGblEnv (tcg_exports tcGblEnv)-  availVars       <- LH.availableVars env modSummary tcGblEnv (tcg_exports tcGblEnv)--  unoptimisedGuts <- GhcMonadLike.desugarModule modSummary typechecked--  let tcData = mkTcData (tcg_rn_imports tcGblEnv) resolvedNames availTyCons availVars-  let pipelineData = PipelineData (toUnoptimised unoptimisedGuts) tcData (map SpecComment comments)--  liquidHaskellCheck pipelineData modSummary tcGblEnv--  where-    thisModule :: Module-    thisModule = tcg_mod tcGblEnv--    cleanedSummary :: ModSummary-    cleanedSummary =-        modSummary { ms_hspp_opts = (ms_hspp_opts modSummary) { cachedPlugins = []-                                                              , staticPlugins = []-                                                              }-                   }--serialiseSpec :: Module -> TcGblEnv -> LiquidLib -> TcM TcGblEnv-serialiseSpec thisModule tcGblEnv liquidLib = do-  -- ----  -- -- CAN WE 'IGNORE' THE BELOW? TODO:IGNORE -- issue use `emptyLiquidLib` instead of pmrClientLib-  -- ProcessModuleResult{..} <- processModule lhContext--  -- liftIO $ putStrLn "liquidHaskellCheck 7"--  -- -- Call into the existing Liquid interface-  -- out <- liftIO $ LH.checkTargetInfo pmrTargetInfo--  -- liftIO $ putStrLn "liquidHaskellCheck 8"--  -- -- Report the outcome of the checking-  -- LH.reportResult errorLogger cfg [giTarget (giSrc pmrTargetInfo)] out-  -- case o_result out of-  --   Safe _stats -> pure ()-  --   _           -> failM--  -- liftIO $ putStrLn "liquidHaskellCheck 9"-  -- -----  let serialisedSpec = Util.serialiseLiquidLib liquidLib thisModule-  debugLog $ "Serialised annotation ==> " ++ (O.showSDocUnsafe . O.ppr $ serialisedSpec)--  -- liftIO $ putStrLn "liquidHaskellCheck 10"--  pure $ tcGblEnv { tcg_anns = serialisedSpec : tcg_anns tcGblEnv }--processInputSpec :: Config -> PipelineData -> ModSummary -> TcGblEnv -> BareSpec -> TcM (Either LiquidCheckException TcGblEnv)-processInputSpec cfg pipelineData modSummary tcGblEnv inputSpec = do-  debugLog $ " Input spec: \n" ++ show inputSpec-  debugLog $ "Relevant ===> \n" ++ unlines (renderModule <$> S.toList (relevantModules modGuts))--  logicMap :: LogicMap <- liftIO LH.makeLogicMap--  -- debugLog $ "Logic map:\n" ++ show logicMap--  let lhContext = LiquidHaskellContext {-        lhGlobalCfg       = cfg-      , lhInputSpec       = inputSpec-      , lhModuleLogicMap  = logicMap-      , lhModuleSummary   = modSummary-      , lhModuleTcData    = pdTcData pipelineData-      , lhModuleGuts      = pdUnoptimisedCore pipelineData-      , lhRelevantModules = relevantModules modGuts-      }--  -- liftIO $ putStrLn ("liquidHaskellCheck 6: " ++ show isIg)-  if isIgnore inputSpec-    then pure $ Left (ErrorsOccurred [])-    else do-      liquidLib' <- checkLiquidHaskellContext lhContext-      traverse (serialiseSpec thisModule tcGblEnv) liquidLib'--  where-    thisModule :: Module-    thisModule = tcg_mod tcGblEnv--    modGuts :: ModGuts-    modGuts = fromUnoptimised . pdUnoptimisedCore $ pipelineData--liquidHaskellCheckWithConfig :: Config -> PipelineData -> ModSummary -> TcGblEnv -> TcM (Either LiquidCheckException TcGblEnv)-liquidHaskellCheckWithConfig globalCfg pipelineData modSummary tcGblEnv = do-  -- The 'specQuotes' contain stuff we need from imported modules, extracted-  -- from the annotations in their interface files.-  let specQuotes :: [BPspec]-      specQuotes = LH.extractSpecQuotes' tcg_mod tcg_anns tcGblEnv--  -- Here, we are calling Liquid Haskell's parser, acting on the unparsed-  -- spec comments stored in the pipeline data, supported by the specQuotes-  -- obtained from the imported modules.-  inputSpec' :: Either LiquidCheckException BareSpec <--    getLiquidSpec thisFile thisModule (pdSpecComments pipelineData) specQuotes--  case inputSpec' of-    Left e -> pure $ Left e-    Right inputSpec ->-      withPragmas globalCfg thisFile (Ms.pragmas $ review bareSpecIso inputSpec) $ \moduleCfg -> do-        processInputSpec moduleCfg pipelineData modSummary tcGblEnv inputSpec-          `gcatch` (\(e :: UserError) -> reportErrs moduleCfg [e])-          `gcatch` (\(e :: Error) -> reportErrs moduleCfg [e])-          `gcatch` (\(es :: [Error]) -> reportErrs moduleCfg es)--  where-    thisFile :: FilePath-    thisFile = LH.modSummaryHsFile modSummary--    continue :: TcM (Either LiquidCheckException TcGblEnv)-    continue = pure $ Left (ErrorsOccurred [])--    reportErrs :: (Show e, F.PPrint e) => Config -> [TError e] -> TcM (Either LiquidCheckException TcGblEnv)-    reportErrs cfg = LH.filterReportErrors thisFile GHC.failM continue (getFilters cfg) Full--    thisModule :: Module-    thisModule = tcg_mod tcGblEnv---- | Partially calls into LiquidHaskell's GHC API.-liquidHaskellCheck :: PipelineData -> ModSummary -> TcGblEnv -> TcM (Either LiquidCheckException TcGblEnv)-liquidHaskellCheck pipelineData modSummary tcGblEnv = do-  cfg <- liftIO getConfig-  liquidHaskellCheckWithConfig cfg pipelineData modSummary tcGblEnv--checkLiquidHaskellContext :: LiquidHaskellContext -> TcM (Either LiquidCheckException LiquidLib)-checkLiquidHaskellContext lhContext = do-  pmr <- processModule lhContext-  case pmr of-    Left e -> pure $ Left e-    Right ProcessModuleResult{..} -> do-      -- Call into the existing Liquid interface-      out <- liftIO $ LH.checkTargetInfo pmrTargetInfo--      let bareSpec = lhInputSpec lhContext-          file = LH.modSummaryHsFile $ lhModuleSummary lhContext--      withPragmas (lhGlobalCfg lhContext) file (Ms.pragmas $ review bareSpecIso bareSpec) $ \moduleCfg ->  do-        let filters = getFilters moduleCfg-        -- Report the outcome of the checking-        LH.reportResult (errorLogger file filters) moduleCfg [giTarget (giSrc pmrTargetInfo)] out-        -- If there are unmatched filters or errors, and we are not reporting with-        -- json, we don't make it to this part of the code because errorLogger-        -- will throw an exception.-        case o_result out of-          F.Safe _ -> return $ Right pmrClientLib-          _ | json moduleCfg -> failM-            | otherwise -> return $ Left $ ErrorsOccurred []--errorLogger :: FilePath -> [Filter] -> OutputResult -> TcM ()-errorLogger file filters outputResult = do-  LH.filterReportErrorsWith-    FilterReportErrorsArgs { msgReporter = GHC.reportErrors-                           , filterReporter = LH.defaultFilterReporter file-                           , failure = GHC.failM-                           , continue = pure ()-                           , pprinter = \(spn, e) -> mkLongErrAt spn (LH.fromPJDoc e) O.empty-                           , matchingFilters = LH.reduceFilters (\(src, doc) -> PJ.render doc ++ " at " ++ LH.showPpr src) filters-                           , filters = filters-                           }-    (LH.orMessages outputResult)--isIgnore :: BareSpec -> Bool-isIgnore (MkBareSpec sp) = any ((== "--skip-module") . F.val) (pragmas sp)------------------------------------------------------------------------------------- | Working with bare & lifted specs -----------------------------------------------------------------------------------------------------------------------------loadDependencies :: forall m. GhcMonadLike m-                 => Config-                 -- ^ The 'Config' associated to the /current/ module being compiled.-                 -> ExternalPackageState-                 -> HomePackageTable-                 -> Module-                 -> [Module]-                 -> m TargetDependencies-loadDependencies currentModuleConfig eps hpt thisModule mods = do-  results   <- SpecFinder.findRelevantSpecs eps hpt mods-  deps      <- foldlM processResult mempty (reverse results)-  redundant <- configToRedundantDependencies currentModuleConfig--  debugLog $ "Redundant dependencies ==> " ++ show redundant--  pure $ foldl' (flip dropDependency) deps redundant-  where-    processResult :: TargetDependencies -> SpecFinderResult -> m TargetDependencies-    processResult !acc (SpecNotFound mdl) = do-      debugLog $ "[T:" ++ renderModule thisModule-              ++ "] Spec not found for " ++ renderModule mdl-      pure acc-    processResult _ (SpecFound originalModule location _) = do-      dynFlags <- getDynFlags-      debugLog $ "[T:" ++ show (moduleName thisModule)-              ++ "] Spec found for " ++ renderModule originalModule ++ ", at location " ++ show location-      Util.pluginAbort (O.showSDoc dynFlags $ O.text "A BareSpec was returned as a dependency, this is not allowed, in " O.<+> O.ppr thisModule)-    processResult !acc (LibFound originalModule location lib) = do-      debugLog $ "[T:" ++ show (moduleName thisModule)-              ++ "] Lib found for " ++ renderModule originalModule ++ ", at location " ++ show location-      pure $ TargetDependencies {-          getDependencies = HM.insert (toStableModule originalModule) (libTarget lib) (getDependencies $ acc <> libDeps lib)-        }---- | The collection of dependencies and usages modules which are relevant for liquidHaskell-relevantModules :: ModGuts -> Set Module-relevantModules modGuts = used `S.union` dependencies-  where-    dependencies :: Set Module-    dependencies = S.fromList $ map (toModule . gwib_mod)-                              . filter (not . isBootInterface . gwib_isBoot)-                              . getDependenciesModuleNames $ deps--    deps :: Dependencies-    deps = mg_deps modGuts--    thisModule :: Module-    thisModule = mg_module modGuts--    toModule :: ModuleName -> Module-    toModule = unStableModule . mkStableModule (moduleUnitId thisModule)--    used :: Set Module-    used = S.fromList $ foldl' collectUsage mempty . mg_usages $ modGuts-      where-        collectUsage :: [Module] -> Usage -> [Module]-        collectUsage acc = \case-          UsagePackageModule     { usg_mod      = modl    } -> modl : acc-          UsageHomeModule        { usg_mod_name = modName } -> toModule modName : acc-          UsageMergedRequirement { usg_mod      = modl    } -> modl : acc-          _ -> acc---data LiquidHaskellContext = LiquidHaskellContext {-    lhGlobalCfg        :: Config-  , lhInputSpec        :: BareSpec-  , lhModuleLogicMap   :: LogicMap-  , lhModuleSummary    :: ModSummary-  , lhModuleTcData     :: TcData-  , lhModuleGuts       :: Unoptimised ModGuts-  , lhRelevantModules  :: Set Module-  }------------------------------------------------------------------------------------- | Per-Module Pipeline ------------------------------------------------------------------------------------------------------------------------------------------data ProcessModuleResult = ProcessModuleResult {-    pmrClientLib  :: LiquidLib-  -- ^ The \"client library\" we will serialise on disk into an interface's 'Annotation'.-  , pmrTargetInfo :: TargetInfo-  -- ^ The 'GhcInfo' for the current 'Module' that LiquidHaskell will process.-  }---- | Parse the spec comments from one module, supported by the--- spec quotes from the imported module. Also looks for--- "companion specs" for the current module and merges them in--- if it finds one.-getLiquidSpec :: FilePath -> Module -> [SpecComment] -> [BPspec] -> TcM (Either LiquidCheckException BareSpec)-getLiquidSpec thisFile thisModule specComments specQuotes = do-  globalCfg <- liftIO getConfig-  let commSpecE :: Either [Error] (ModName, Spec LocBareType LocSymbol)-      commSpecE = hsSpecificationP (moduleName thisModule) (coerce specComments) specQuotes-  case commSpecE of-    Left errors ->-      LH.filterReportErrors thisFile GHC.failM continue (getFilters globalCfg) Full errors-    Right (view bareSpecIso . snd -> commSpec) -> do-      res <- SpecFinder.findCompanionSpec thisModule-      case res of-        SpecFound _ _ companionSpec -> do-          debugLog $ "Companion spec found for " ++ renderModule thisModule-          pure $ Right $ commSpec <> companionSpec-        _ -> pure $ Right commSpec-  where-    continue = pure $ Left (ErrorsOccurred [])--processModule :: LiquidHaskellContext -> TcM (Either LiquidCheckException ProcessModuleResult)-processModule LiquidHaskellContext{..} = do-  debugLog ("Module ==> " ++ renderModule thisModule)-  hscEnv              <- askHscEnv--  let bareSpec        = lhInputSpec-  -- /NOTE/: For the Plugin to work correctly, we shouldn't call 'canonicalizePath', because otherwise-  -- this won't trigger the \"external name resolution\" as part of 'Language.Haskell.Liquid.Bare.Resolve'-  -- (cfr. 'allowExtResolution').-  let file            = LH.modSummaryHsFile lhModuleSummary--  _                   <- LH.checkFilePragmas $ Ms.pragmas (review bareSpecIso bareSpec)--  withPragmas lhGlobalCfg file (Ms.pragmas $ review bareSpecIso bareSpec) $ \moduleCfg -> do-    eps                 <- liftIO $ readIORef (hsc_EPS hscEnv)--    dependencies       <- loadDependencies moduleCfg-                                           eps-                                           (hsc_HPT hscEnv)-                                           thisModule-                                           (S.toList lhRelevantModules)--    debugLog $ "Found " <> show (HM.size $ getDependencies dependencies) <> " dependencies:"-    when debugLogs $-      forM_ (HM.keys . getDependencies $ dependencies) $ debugLog . moduleStableString . unStableModule--    debugLog $ "mg_exports => " ++ O.showSDocUnsafe (O.ppr $ mg_exports modGuts)-    debugLog $ "mg_tcs => " ++ O.showSDocUnsafe (O.ppr $ mg_tcs modGuts)--    targetSrc  <- makeTargetSrc moduleCfg file lhModuleTcData modGuts hscEnv-    dynFlags <- getDynFlags--    -- See https://github.com/ucsd-progsys/liquidhaskell/issues/1711-    -- Due to the fact the internals can throw exceptions from pure code at any point, we need to-    -- call 'evaluate' to force any exception and catch it, if we can.---    result <--      makeTargetSpec moduleCfg lhModuleLogicMap targetSrc bareSpec dependencies--    let continue = pure $ Left (ErrorsOccurred [])-        reportErrs :: (Show e, F.PPrint e) => [TError e] -> TcRn (Either LiquidCheckException ProcessModuleResult)-        reportErrs = LH.filterReportErrors file GHC.failM continue (getFilters moduleCfg) Full--    (case result of-      -- Print warnings and errors, aborting the compilation.-      Left diagnostics -> do-        liftIO $ mapM_ (printWarning dynFlags)    (allWarnings diagnostics)-        reportErrs $ allErrors diagnostics-      Right (warnings, targetSpec, liftedSpec) -> do-        liftIO $ mapM_ (printWarning dynFlags) warnings-        let targetInfo = TargetInfo targetSrc targetSpec--        debugLog $ "bareSpec ==> "   ++ show bareSpec-        debugLog $ "liftedSpec ==> " ++ show liftedSpec--        let clientLib  = mkLiquidLib liftedSpec & addLibDependencies dependencies--        let result' = ProcessModuleResult {-              pmrClientLib  = clientLib-            , pmrTargetInfo = targetInfo-            }--        pure $ Right result')-      `gcatch` (\(e :: UserError) -> reportErrs [e])-      `gcatch` (\(e :: Error) -> reportErrs [e])-      `gcatch` (\(es :: [Error]) -> reportErrs es)--  where-    modGuts    = fromUnoptimised lhModuleGuts-    thisModule = mg_module modGuts-------------------------------------------------------------------------------------------- | @makeGhcSrc@ builds all the source-related information needed for consgen------------------------------------------------------------------------------------------makeTargetSrc :: GhcMonadLike m-              => Config-              -> FilePath-              -> TcData-              -> ModGuts-              -> HscEnv-              -> m TargetSrc-makeTargetSrc cfg file tcData modGuts hscEnv = do-  coreBinds      <- liftIO $ anormalize cfg hscEnv modGuts--  -- The type constructors for a module are the (nubbed) union of the ones defined and-  -- the ones exported. This covers the case of \"wrapper modules\" that simply re-exports-  -- everything from the imported modules.-  let availTcs    = tcAvailableTyCons tcData-  let allTcs      = L.nub (mgi_tcs mgiModGuts ++ availTcs)--  let dataCons       = concatMap (map dataConWorkId . tyConDataCons) allTcs-  let (fiTcs, fiDcs) = LH.makeFamInstEnv (getFamInstances modGuts)-  let things         = tcResolvedNames tcData-  let impVars        = LH.importVars coreBinds ++ LH.classCons (mgi_cls_inst mgiModGuts)--  debugLog $ "_gsTcs   => " ++ show allTcs-  debugLog $ "_gsFiTcs => " ++ show fiTcs-  debugLog $ "_gsFiDcs => " ++ show fiDcs-  debugLog $ "dataCons => " ++ show dataCons-  debugLog $ "coreBinds => " ++ (O.showSDocUnsafe . O.ppr $ coreBinds)-  debugLog $ "impVars => " ++ (O.showSDocUnsafe . O.ppr $ impVars)-  debugLog $ "defVars  => " ++ show (L.nub $ dataCons ++ letVars coreBinds ++ tcAvailableVars tcData)-  debugLog $ "useVars  => " ++ (O.showSDocUnsafe . O.ppr $ readVars coreBinds)-  debugLog $ "derVars  => " ++ (O.showSDocUnsafe . O.ppr $ HS.fromList (LH.derivedVars cfg mgiModGuts))-  debugLog $ "gsExports => " ++ show (mgi_exports  mgiModGuts)-  debugLog $ "gsTcs     => " ++ (O.showSDocUnsafe . O.ppr $ allTcs)-  debugLog $ "gsCls     => " ++ (O.showSDocUnsafe . O.ppr $ mgi_cls_inst mgiModGuts)-  debugLog $ "gsFiTcs   => " ++ (O.showSDocUnsafe . O.ppr $ fiTcs)-  debugLog $ "gsFiDcs   => " ++ show fiDcs-  debugLog $ "gsPrimTcs => " ++ (O.showSDocUnsafe . O.ppr $ GHC.primTyCons)-  debugLog $ "things   => " ++ (O.showSDocUnsafe . O.vcat . map O.ppr $ things)-  debugLog $ "allImports => " ++ show (tcAllImports tcData)-  debugLog $ "qualImports => " ++ show (tcQualifiedImports tcData)--  return $ TargetSrc-    { giIncDir    = mempty-    , giTarget    = file-    , giTargetMod = ModName Target (moduleName (mg_module modGuts))-    , giCbs       = coreBinds-    , giImpVars   = impVars-    , giDefVars   = L.nub $ dataCons ++ letVars coreBinds ++ tcAvailableVars tcData-    , giUseVars   = readVars coreBinds-    , giDerVars   = HS.fromList (LH.derivedVars cfg mgiModGuts)-    , gsExports   = mgi_exports  mgiModGuts-    , gsTcs       = allTcs-    , gsCls       = mgi_cls_inst mgiModGuts-    , gsFiTcs     = fiTcs-    , gsFiDcs     = fiDcs-    , gsPrimTcs   = GHC.primTyCons-    , gsQualImps  = tcQualifiedImports tcData-    , gsAllImps   = tcAllImports       tcData-    , gsTyThings  = [ t | (_, Just t) <- things ]-    }-  where-    mgiModGuts :: MGIModGuts-    mgiModGuts = miModGuts deriv modGuts-      where-        deriv   = Just $ instEnvElts $ mg_inst_env modGuts--getFamInstances :: ModGuts -> [FamInst]-getFamInstances guts = famInstEnvElts (mg_fam_inst_env guts)
− src/Language/Haskell/Liquid/GHC/Plugin/SpecFinder.hs 
@@ -1,145 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE RankNTypes   #-}--module Language.Haskell.Liquid.GHC.Plugin.SpecFinder-    ( findRelevantSpecs-    , findCompanionSpec-    , SpecFinderResult(..)-    , SearchLocation(..)-    , configToRedundantDependencies-    ) where--import           Liquid.GHC.GhcMonadLike as GhcMonadLike ( GhcMonadLike-                                                                          , lookupModSummary-                                                                          , askHscEnv-                                                                          )-import           Language.Haskell.Liquid.GHC.Plugin.Util  ( pluginAbort, deserialiseLiquidLib )-import           Language.Haskell.Liquid.GHC.Plugin.Types-import           Language.Haskell.Liquid.Types.Types-import           Language.Haskell.Liquid.Types.Specs     hiding (Spec)-import qualified Language.Haskell.Liquid.Misc            as Misc-import           Language.Haskell.Liquid.Parse            ( specSpecificationP )-import           Language.Fixpoint.Utils.Files            ( Ext(Spec), withExt )--import           Optics-import qualified Liquid.GHC.API         as O-import           Liquid.GHC.API         as GHC--import           Data.Bifunctor-import           Data.Maybe--import           Control.Exception-import           Control.Monad.Trans                      ( lift )-import           Control.Monad.Trans.Maybe--import           Text.Megaparsec.Error--type SpecFinder m = GhcMonadLike m => Module -> MaybeT m SpecFinderResult---- | The result of searching for a spec.-data SpecFinderResult = -    SpecNotFound Module-  | SpecFound Module SearchLocation BareSpec-  | LibFound  Module SearchLocation LiquidLib--data SearchLocation =-    InterfaceLocation-  -- ^ The spec was loaded from the annotations of an interface.-  | DiskLocation-  -- ^ The spec was loaded from disk (e.g. 'Prelude.spec' or similar)-  deriving Show---- | Load any relevant spec for the input list of 'Module's, by querying both the 'ExternalPackageState'--- and the 'HomePackageTable'.-findRelevantSpecs :: forall m. GhcMonadLike m-                  => ExternalPackageState-                  -> HomePackageTable-                  -> [Module]-                  -- ^ Any relevant module fetched during dependency-discovery.-                  -> m [SpecFinderResult]-findRelevantSpecs eps hpt mods = foldlM loadRelevantSpec mempty mods-  where--    loadRelevantSpec :: [SpecFinderResult] -> Module -> m [SpecFinderResult]-    loadRelevantSpec !acc currentModule = do-      res <- runMaybeT $ lookupInterfaceAnnotations eps hpt currentModule-      pure $ case res of-        Nothing         -> SpecNotFound currentModule : acc-        Just specResult -> specResult : acc---- | If this module has a \"companion\" '.spec' file sitting next to it, this 'SpecFinder'--- will try loading it.-findCompanionSpec :: GhcMonadLike m => Module -> m SpecFinderResult-findCompanionSpec m = do-  res <- runMaybeT $ lookupCompanionSpec m-  case res of-    Nothing -> pure $ SpecNotFound m-    Just s  -> pure s---- | Load a spec by trying to parse the relevant \".spec\" file from the filesystem.-lookupInterfaceAnnotations :: ExternalPackageState -> HomePackageTable -> SpecFinder m-lookupInterfaceAnnotations eps hpt thisModule = do-  lib <- MaybeT $ pure $ deserialiseLiquidLib thisModule eps hpt-  pure $ LibFound thisModule InterfaceLocation lib---- | If this module has a \"companion\" '.spec' file sitting next to it, this 'SpecFinder'--- will try loading it.-lookupCompanionSpec :: SpecFinder m-lookupCompanionSpec thisModule = do--  modSummary <- MaybeT $ GhcMonadLike.lookupModSummary (moduleName thisModule)-  file       <- MaybeT $ pure (ml_hs_file . ms_location $ modSummary)-  parsed     <- MaybeT $ do-    mbSpecContent <- liftIO $ try (Misc.sayReadFile (specFile file))-    case mbSpecContent of-      Left (_e :: SomeException) -> pure Nothing-      Right raw -> pure $ Just $ specSpecificationP (specFile file) raw--  case parsed of-    Left peb -> do-      dynFlags <- lift getDynFlags-      let errMsg = O.text "Error when parsing "-             O.<+> O.text (specFile file) O.<+> O.text ":"-             O.<+> O.text (errorBundlePretty peb)-      lift $ pluginAbort (O.showSDoc dynFlags errMsg)-    Right (_, spec) -> do-      let bareSpec = view bareSpecIso spec-      pure $ SpecFound thisModule DiskLocation bareSpec-  where-    specFile :: FilePath -> FilePath-    specFile fp = withExt fp Spec---- | Returns a list of 'StableModule's which can be filtered out of the dependency list, because they are--- selectively \"toggled\" on and off by the LiquidHaskell's configuration, which granularity can be--- /per module/.-configToRedundantDependencies :: forall m. GhcMonadLike m => Config -> m [StableModule]-configToRedundantDependencies cfg = do-  env <- askHscEnv-  catMaybes <$> mapM (lookupModule' env . first ($ cfg)) configSensitiveDependencies-  where-    lookupModule' :: HscEnv -> (Bool, ModuleName) -> m (Maybe StableModule)-    lookupModule' env (fetchModule, modName)-      | fetchModule = liftIO $ lookupLiquidBaseModule env modName-      | otherwise   = pure Nothing--    lookupLiquidBaseModule :: HscEnv -> ModuleName -> IO (Maybe StableModule)-    lookupLiquidBaseModule env mn = do-      res <- liftIO $ findExposedPackageModule env mn (Just "liquid-base")-      case res of-        Found _ mdl -> pure $ Just (toStableModule mdl)-        _           -> pure Nothing---- | Static associative map of the 'ModuleName' that needs to be filtered from the final 'TargetDependencies'--- due to some particular configuration options.------ Modify this map to add any extra special case. Remember that the semantic is not which module will be--- /added/, but rather which one will be /removed/ from the final list of dependencies.----configSensitiveDependencies :: [(Config -> Bool, ModuleName)]-configSensitiveDependencies = [-    (not . totalityCheck, mkModuleName "Liquid.Prelude.Totality")-  , (not . linear, mkModuleName "Liquid.Prelude.NotReal")-  , (linear, mkModuleName "Liquid.Prelude.Real")-  ]
− src/Language/Haskell/Liquid/GHC/Plugin/Tutorial.hs 
@@ -1,236 +0,0 @@--module Language.Haskell.Liquid.GHC.Plugin.Tutorial (--  -- * Introduction and Requirements-  -- $introduction--  -- * Your first package-  -- $firstPackage--  -- * Using GHCi-  -- $usingGHCi--  -- * Passing options-  -- $passingOptions--  -- * Understanding LiquidHaskell Spec resolution strategies-  -- $specResolutionStrategies--  -- * Providing specifications for existing packages-  -- $specForExisting--) where--{- $introduction--This tutorial describes the general approach of using LiquidHaskell using the new compiler plugin. Due-to some recent changes and improvements to the compiler plugin API (which LiquidHaskell requires) the-__minimum supported version of GHC is 8.10.1.__---}--{- $firstPackage--Generally speaking, in order to integrate LiquidHaskell (/LH/ for brevity from now on) with your existing-(or brand new) project, we need a few things:--* We need to tell GHC that we want to __use the LH plugin__, and it can be done by adding the-  @-fplugin=LiquidHaskell@ option in the @ghc-options@ of your Cabal manifest;--* We need to tell LH where to find the /specs/ (i.e. the refinements) for the types in @base@. To do this,-  we need to depend on a special, __drop-in replacement__ for @base@ called @liquid-base@.--If we do all the above, our Cabal manifest should look similar to this:--@-cabal-version: 1.12--name:           toy-package-a-version:        0.1.0.0-description:    This is a toy example.-homepage:-bug-reports:-author:         Author name here-maintainer:     example@example.com-copyright:      2019 Author name here-license:        BSD3-license-file:   LICENSE-build-type:     Simple--library-  exposed-modules:-      Toy.A-  hs-source-dirs:-      src-  build-depends:-        liquid-base                    -- Add this!-      , liquidhaskell-  default-language: Haskell2010-  ghc-options: -fplugin=LiquidHaskell  -- Add this!-@--Let's now define a very simple module called 'Toy.A':--@-module Toy.A ( notThree, one, two) where--\{\-\@ one :: {v:Int | v = 1 } \@\-\}-one :: Int-one = 1--\{\-\@ assume notThree :: {v : Nat | v != 3 } \@\-\}-notThree :: Int-notThree = 4--\{\-\@ two :: Nat \@\-\}-two :: Int-two = one + one-@--Now, if we build the package with (for example) @cabal v2-build toy-package-a@, we should see something-like this:--@-Resolving dependencies...-Build profile: -w ghc-8.10.1 -O1-In order, the following will be built (use -v for more details):- - toy-package-a-0.1.0.0 (lib) (configuration changed)-Configuring library for toy-package-a-0.1.0.0..-Warning: The 'license-file' field refers to the file 'LICENSE' which does not-exist.-Preprocessing library for toy-package-a-0.1.0.0..-Building library for toy-package-a-0.1.0.0..--[3 of 3] Compiling Toy.A            ( src\/Toy\/A.hs, ... )--**** LIQUID: SAFE (7 constraints checked) **************************************-@--The \"SAFE\" banner here is LH's way of saying "all is well". What happens if we try to violate a-refinement? Let's find out. If change @one@ to look like this:--@-{-@ one :: {v:Int | v = 1 } @-}-one :: Int-one = 2-@--Upon next recompilation, GHC (or rather, /LH/) will bark at us:--@-Building library for toy-package-a-0.1.0.0..-[3 of 3] Compiling Toy.A            ( src\/Toy\/A.hs, ... )--**** LIQUID: UNSAFE ************************************************************--src\/Toy\/A.hs:36:1: error:-    Liquid Type Mismatch-    .-    The inferred type-      VV : {v : GHC.Types.Int | v == 2}-    .-    is not a subtype of the required type-      VV : {VV : GHC.Types.Int | VV == 1}-    .-   |-36 | one = 2-   | ^^^^^^^-@---}--{- $passingOptions--Passing options to /LH/ is possible and works using the standard mechanism the plugin system already provides.-For example let's image we want to skip verification of our 'Toy.A' module. At this point, we have two options:--1. We can add the option directly in the module, as a \"pragma\":--    @-    \{\-\@ LIQUID "--compilespec" \@\-\}-    module Toy.A ( notThree, one, two) where-    ...-    @--2. We can add this \"globally\" (if that's really what we want), like this:--    @-    cabal-version: 1.12-    name:           toy-package-a-      ..-      default-language: Haskell2010-      ghc-options: -fplugin=LiquidHaskell -fplugin-opt=LiquidHaskell:--compilespec-    @---}--{- $usingGHCi--Using GHCi is supported out of the box, and it will work as expected.---}--{- $specResolutionStrategies--Let's revisit our 'Toy.A' module. There are two different ways to annotate an existing Haskell module,-and they are the following:--1. __(Recommended)__ Add the /LH/ annotations directly inside the Haskell file (like in the example above).-   This has the advantage that any changes to the annotations trigger recompilation, and ensure the specs-   will never get stale and go out-of-sync. The disadvantage of this approach is that it can clutter quite a-   bit the target 'Module'.--2. Add the specifications as a separate __companion__ @.spec@ file to be placed alongside the Haskell one.-   To rehash the example above, we could have also added a new @Toy/A.spec@ file living in the same folder-   of our @A.hs@ file, with a content like this:--   @-   module spec Toy.A where--   one :: {v:Int | v = 1 }-   assume notThree :: {v : Nat | v != 3 }-   two :: Nat-   @--   This has the advantage of being more compartmentalised, but it's also a weakness as it might not be-   immediately obvious that a Haskell module has associated refinements.---}--{- $specForExisting--If you have control over the package or project you would like to annotate with /LH/ refinements, all is well.-But what about packages you don't own or maintain? Typically, one solution would be to convince the-project's maintainers to get on board and to add /LH/ annotations to the code themselves, but this might not-be so easy, for a number of reasons:--* The package you are trying to \"refine\" is not maintained anymore, or the maintainer is very difficult-  to reach;--* The package is fairly important in the Haskell ecosystem and making changes to it might not be so easy,-  especially for packages which come as part of a GHC installation (think @base@, for example).--The designed workflow in these cases is to create a __brand new package__ (that we can call \"mirror\" package),-which would re-export /everything/ from the \"mirrored\" package while adding all the required /LH/-annotations. This is what we have done for things like @base@, @ghc-prim@ and @containers@, for example, by-providing @liquid-containers@, @liquid-ghc-prim@ and @liquid-base@, the latter being what we have used in-the tutorial to get started.--There are some very simple guidelines to drive this process:--1. Typically you want to clearly identify this package as part of the /LH ecosystem/ by using an-   appropriate prefix for your package name, something like @liquid-foo@ where @foo@ is the original-   package you are adding annotations for;--2. You need to abide to a set of PVP rules, like tracking the version of the upstream package first and-   in case of changes to either the LH language or the specs in the mirror package, bump the last two-   digits of the version scheme, in a format like this:--   @liquid-\<package-name\>-A.B.C.D.X.Y@--   Where @A.B.C.D@ would be used to track the upstream package version and @X.Y@ would enumerate the-   versions of this mirror package. Bumping @X@ would signify there was a breaking change in the /LH/-   language that required a new release of this plugin, whereas bumping @Y@ would mean something changed-   in the __specs__ provided as part of this mirror package (e.g. more refinements were added, bugs were-   fixed etc).--}
− src/Language/Haskell/Liquid/GHC/Plugin/Types.hs 
@@ -1,221 +0,0 @@-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}--module Language.Haskell.Liquid.GHC.Plugin.Types-    ( SpecComment(..)--    -- * Dealing with specs and their dependencies-    , LiquidLib-    , mkLiquidLib-    , libTarget-    , libDeps-    , allDeps-    , addLibDependencies--    -- * Caching specs into interfaces-    , CachedSpec-    , toCached-    , cachedSpecStableModuleId-    , cachedSpecModule-    , fromCached--    -- * Merging specs together-    , InputSpec-    , CompanionSpec-    , LiquidSpec-    , downcastSpec-    , mkInputSpec-    , mkCompanionSpec-    , mergeInputWithCompanion--    -- * Carrying data across stages of the compilation pipeline-    , PipelineData(..)--    -- * Acquiring and manipulating data from the typechecking phase-    , TcData-    , tcAllImports-    , tcQualifiedImports-    , tcResolvedNames-    , tcAvailableTyCons-    , tcAvailableVars-    , mkTcData--    -- * Wrapper type to talk about unoptimised things-    , Unoptimised(fromUnoptimised)-    , toUnoptimised-    ) where--import           Data.Binary                             as B-import           Data.Data                                ( Data )-import           Data.Foldable-import           GHC.Generics                      hiding ( moduleName )--import qualified Data.HashSet        as HS-import           Data.Hashable--import           Language.Fixpoint.Types.Spans-import           Language.Haskell.Liquid.Types.Specs-import           Liquid.GHC.API         as GHC-import qualified Liquid.GHC.Interface   as LH-import           Language.Fixpoint.Types.Names            ( Symbol )---data LiquidLib = LiquidLib-  {  llTarget :: LiftedSpec-  -- ^ The target /LiftedSpec/.-  ,  llDeps   :: TargetDependencies-  -- ^ The specs which were necessary to produce the target 'BareSpec'.-  } deriving (Show, Generic)--instance B.Binary LiquidLib---- | Creates a new 'LiquidLib' with no dependencies.-mkLiquidLib :: LiftedSpec -> LiquidLib-mkLiquidLib s = LiquidLib s mempty---- | Adds a set of dependencies to the input 'LiquidLib'.-addLibDependencies :: TargetDependencies -> LiquidLib -> LiquidLib-addLibDependencies deps lib = lib { llDeps = deps <> llDeps lib }---- | Returns the target 'LiftedSpec' of this 'LiquidLib'.-libTarget :: LiquidLib -> LiftedSpec-libTarget = llTarget---- | Returns all the dependencies of this 'LiquidLib'.-libDeps :: LiquidLib -> TargetDependencies-libDeps = llDeps---- | Extracts all the dependencies from a collection of 'LiquidLib's.-allDeps :: Foldable f => f LiquidLib -> TargetDependencies-allDeps = foldl' (\acc lib -> acc <> llDeps lib) mempty---- | A cached spec which can be serialised into an interface.-data CachedSpec = CachedSpec GHC.StableModule LiftedSpec deriving (Show, Generic)--instance Binary CachedSpec--instance Eq CachedSpec where-    (CachedSpec id1 _) == (CachedSpec id2 _) = id1 == id2--instance Hashable CachedSpec where-    hashWithSalt s (CachedSpec (unStableModule -> mdl) _) =-      hashWithSalt s (moduleStableString mdl)---- | Converts the input 'BareSpec' into a 'CachedSpec', inforcing the invariant that termination checking--- needs to be disabled as this is now considered safe to use for \"clients\".-toCached :: Module -> LiftedSpec -> CachedSpec-toCached mdl liftedSpec = CachedSpec (toStableModule mdl) liftedSpec--cachedSpecStableModuleId :: CachedSpec -> String-cachedSpecStableModuleId (CachedSpec (unStableModule -> m) _) = moduleStableString m--cachedSpecModule :: CachedSpec -> Module-cachedSpecModule (CachedSpec (unStableModule -> m) _) = m--fromCached :: CachedSpec -> (StableModule, LiftedSpec)-fromCached (CachedSpec sm s) = (sm, s)--------- A Liquid spec and its (many) flavours------data InputSpec-data CompanionSpec--data LiquidSpec t where-    MkInputSpec     :: BareSpec   -> LiquidSpec InputSpec-    MkCompanionSpec :: BareSpec   -> LiquidSpec CompanionSpec--deriving instance Show (LiquidSpec InputSpec)-deriving instance Show (LiquidSpec CompanionSpec)--mkInputSpec :: BareSpec -> LiquidSpec InputSpec-mkInputSpec = MkInputSpec--mkCompanionSpec :: BareSpec -> LiquidSpec CompanionSpec-mkCompanionSpec = MkCompanionSpec--downcastSpec :: LiquidSpec t -> BareSpec-downcastSpec = \case-  MkInputSpec s    -> s-  MkCompanionSpec s -> s---- | Merges a 'InputSpec' with its 'CompanionSpec'. Here duplicates are not checked as it's--- user's responsibility to make sure there are no duplicates between the in-module annotations and the--- companion spec.-mergeInputWithCompanion :: LiquidSpec InputSpec -> LiquidSpec CompanionSpec -> LiquidSpec InputSpec-mergeInputWithCompanion (MkInputSpec s1) (MkCompanionSpec s2) = MkInputSpec (s1 <> s2)---- | Just a small wrapper around the 'SourcePos' and the text fragment of a LH spec comment.-newtype SpecComment =-    SpecComment (SourcePos, String)-    deriving (Show, Data)--newtype Unoptimised a = Unoptimised { fromUnoptimised :: a }--toUnoptimised :: a -> Unoptimised a-toUnoptimised = Unoptimised------- Passing data between stages of the pipeline------ The plugin architecture doesn't provide a default system to \"thread\" data across stages of the--- compilation pipeline, which means that plugin implementors have two choices:------ 1. Serialise any data they want to carry around inside annotations, but this can be potentially costly;--- 2. Pass data inside IORefs.--data PipelineData = PipelineData {-    pdUnoptimisedCore :: Unoptimised ModGuts-  , pdTcData :: TcData-  , pdSpecComments :: [SpecComment]-  }---- | Data which can be \"safely\" passed to the \"Core\" stage of the pipeline.--- The notion of \"safely\" here is a bit vague: things like imports are somewhat--- guaranteed not to change, but things like identifiers might, so they shouldn't--- land here.-data TcData = TcData {-    tcAllImports       :: HS.HashSet Symbol-  , tcQualifiedImports :: QImports-  , tcResolvedNames    :: [(Name, Maybe TyThing)]-  , tcAvailableTyCons  :: [GHC.TyCon]-  -- ^ Sometimes we might be in a situation where we have \"wrapper\" modules that-  -- simply re-exports everything from the original module, and therefore when LH-  -- tries to resolve the GHC identifier associated to a data constructor in scope-  -- (from the call to 'lookupTyThings') we might not be able to find a match because-  -- the 'mg_tcs' for the input 'ModGuts' is empty (because the type constructor are not-  -- defined in the /wrapper/ module, but rather in the /wrapped/ module itself). This is-  -- why we look at the 'ModGuts' 's 'AvailInfo' to extract any re-exported 'TyCon' out of that.-  , tcAvailableVars    :: [Var]-  -- ^ Ditto as for 'reflectedTyCons', but for identifiers.-  }--instance Outputable TcData where-    ppr (TcData{..}) =-          text "TcData { imports     = " <+> text (show $ HS.toList tcAllImports)-      <+> text "       , qImports    = " <+> text (show tcQualifiedImports)-      <+> text "       , names       = " <+> ppr tcResolvedNames-      <+> text "       , availTyCons = " <+> ppr tcAvailableTyCons-      <+> text " }"---- | Constructs a 'TcData' out of a 'TcGblEnv'.-mkTcData :: [LImportDecl GhcRn]-         -> [(Name, Maybe TyThing)]-         -> [TyCon]-         -> [Var]-         -> TcData-mkTcData imps resolvedNames availTyCons availVars = TcData {-    tcAllImports       = LH.allImports       imps-  , tcQualifiedImports = LH.qualifiedImports imps-  , tcResolvedNames    = resolvedNames-  , tcAvailableTyCons  = availTyCons-  , tcAvailableVars    = availVars-  }
− src/Language/Haskell/Liquid/GHC/Plugin/Util.hs 
@@ -1,102 +0,0 @@-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Language.Haskell.Liquid.GHC.Plugin.Util (-        partitionMaybe-      , extractSpecComments--      -- * Serialising and deserialising things from/to specs.-      , serialiseLiquidLib-      , deserialiseLiquidLib--      -- * Aborting the plugin execution-      , pluginAbort-      ) where--import           Data.Foldable                            ( asum )--import           Control.Monad.IO.Class-import           Control.Monad--import qualified Data.Binary                             as B-import           Data.Binary                              ( Binary )-import qualified Data.ByteString.Lazy                    as B-import           Data.Typeable-import           Data.Maybe                               ( listToMaybe )-import           Data.Data-import           Data.Either                              ( partitionEithers )--import           Liquid.GHC.API-import           Language.Haskell.Liquid.GHC.Plugin.Types ( SpecComment-                                                          , LiquidLib-                                                          )---pluginAbort :: MonadIO m => String -> m a-pluginAbort = liftIO . throwGhcExceptionIO . ProgramError---- | Courtesy of [inspection testing](https://github.com/nomeata/inspection-testing/blob/master/src/Test/Inspection/Plugin.hs)-partitionMaybe :: (a -> Maybe b) -> [a] -> ([a], [b])-partitionMaybe f = partitionEithers . map (\x -> maybe (Left x) Right (f x))---- | Extracts the spec comments from the Core 'Annotation's. It returns a--- "cleaned" 'ModGuts' which doesn't contain the deserialised 'Annotation's.--- This also means that these 'Annotation's /won't/ land into an interface file,--- and we won't be able to retrieve them back later on.-extractSpecComments :: ModGuts -> (ModGuts, [SpecComment])-extractSpecComments = extractModuleAnnotations---- | Tries to deserialise the 'Annotation's in the input 'ModGuts', pruning the latter--- upon successful deserialisation.-extractModuleAnnotations :: forall a. (Typeable a, Data a) => ModGuts -> (ModGuts, [a])-extractModuleAnnotations guts = (guts', extracted)-  where-    thisModule = mg_module guts-    (anns_clean, extracted) = partitionMaybe tryDeserialise (mg_anns guts)-    guts' = guts { mg_anns = anns_clean }--    tryDeserialise :: Annotation -> Maybe a-    tryDeserialise (Annotation (ModuleTarget m) payload)-        | thisModule == m = fromSerialized deserializeWithData payload-        | otherwise       = Nothing-    tryDeserialise (Annotation (NamedTarget _) payload) --NOTE(adn) What is the correct behaviour here?-        | Just a <- fromSerialized deserializeWithData payload-        = Just a-    tryDeserialise _-        = Nothing------- Serialising and deserialising Specs-----deserialiseBinaryObject :: forall a. (Typeable a, Binary a)-                        => Module-                        -> ExternalPackageState-                        -> HomePackageTable-                        -> Maybe a-deserialiseBinaryObject thisModule eps hpt = asum [extractFromHpt, extractFromEps]-  where-    extractFromEps :: Maybe a-    extractFromEps = listToMaybe $ findAnns deserialise (eps_ann_env eps) (ModuleTarget thisModule)--    extractFromHpt :: Maybe a-    extractFromHpt = do-      modInfo <- lookupUDFM hpt (moduleName thisModule)-      guard (thisModule == (mi_module . hm_iface $ modInfo))-      xs <- mapM (fromSerialized deserialise . ifAnnotatedValue) (mi_anns . hm_iface $ modInfo)-      listToMaybe xs--    deserialise :: [B.Word8] -> a-    deserialise payload = B.decode (B.pack payload)--serialiseBinaryObject :: forall a. (Binary a, Typeable a) => a -> Module -> Annotation-serialiseBinaryObject obj thisModule = serialised-  where-    serialised :: Annotation-    serialised = Annotation (ModuleTarget thisModule) (toSerialized (B.unpack . B.encode) obj)---- | Serialise a 'LiquidLib', removing the termination checks from the target.-serialiseLiquidLib :: LiquidLib -> Module -> Annotation-serialiseLiquidLib lib = serialiseBinaryObject @LiquidLib lib--deserialiseLiquidLib :: Module -> ExternalPackageState -> HomePackageTable -> Maybe LiquidLib-deserialiseLiquidLib thisModule = deserialiseBinaryObject @LiquidLib thisModule
− src/Language/Haskell/Liquid/Interactive/Handler.hs 
@@ -1,30 +0,0 @@-module Language.Haskell.Liquid.Interactive.Handler (-    -- * Initial state for server-    initial--    -- * Command handler-  , handler-  ) where--import Prelude hiding (error)-import Control.Concurrent.MVar-import Language.Haskell.Liquid.Interactive.Types-import Language.Haskell.Liquid.Liquid---------------------------------------------------------------------------------handler :: MVar State -> Command -> IO Response--------------------------------------------------------------------------------handler r = modifyMVar r . runLiquid'--runLiquid' :: Command -> State -> IO (State, Response)-runLiquid' cfg s = do-  let mE    = sMbEnv s-  let n     = sCount s-  (c, mE') <- runLiquid mE cfg-  let s'    = State (n + 1) mE'-  return      (s', (status c, n))---------------------------------------------------------------------------------initial :: State--------------------------------------------------------------------------------initial = State 0 Nothing
− src/Language/Haskell/Liquid/Interactive/Types.hs 
@@ -1,57 +0,0 @@-{-# LANGUAGE DeriveGeneric      #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances  #-}--module Language.Haskell.Liquid.Interactive.Types-  (-    -- * Commands-    Command--    -- * Response-  , Response--  , status--    -- * State-  , State (..)--  ) where--import Prelude        hiding (error)-import Data.Serialize        ( Serialize )-import GHC.Generics-import System.Console.CmdArgs-import System.Exit-import Language.Haskell.Liquid.Types (Config (..))-import Language.Haskell.Liquid.Liquid-import Language.Fixpoint.Types ()------------------------------------------------------------------------------------ | State ------------------------------------------------------------------------------------------------------------------------------------------------------data State = State { sCount  :: Int-                   , sMbEnv :: MbEnv-                   }------------------------------------------------------------------------------------ | Command ----------------------------------------------------------------------------------------------------------------------------------------------------type Command = Config------------------------------------------------------------------------------------ | Response ---------------------------------------------------------------------------------------------------------------------------------------------------data Status = ResOk-            | ResFail Int-               deriving ( Generic, Data, Typeable, Show )--type Response = (Status, Int)--instance Serialize Status--status :: ExitCode -> Status-status ExitSuccess     = ResOk-status (ExitFailure n) = ResFail n
− src/Language/Haskell/Liquid/LawInstances.hs 
@@ -1,101 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-module Language.Haskell.Liquid.LawInstances ( checkLawInstances ) where--import qualified Data.List                                  as L-import qualified Data.Maybe                                 as Mb-import           Text.PrettyPrint.HughesPJ                  hiding ((<>))--import           Language.Haskell.Liquid.Types-import           Language.Haskell.Liquid.Types.Equality-import           Liquid.GHC.API            hiding ((<+>), text)-import qualified Language.Fixpoint.Types                    as F--checkLawInstances :: GhcSpecLaws -> Diagnostics-checkLawInstances speclaws = foldMap go (gsLawInst speclaws)-  where go l = checkOneInstance (lilName l) (Mb.fromMaybe [] $ L.lookup (lilName l) (gsLawDefs speclaws)) l--checkOneInstance :: Class -> [(Var, LocSpecType)] -> LawInstance -> Diagnostics-checkOneInstance c laws li-  = checkExtra c li ((fst <$> laws) ++ classMethods c) (lilEqus li) <> foldMap (\l -> checkOneLaw c l li) laws--checkExtra :: Class-           -> LawInstance-           -> [Var]-           -> [(VarOrLocSymbol, (VarOrLocSymbol, Maybe LocSpecType))]-           -> Diagnostics-checkExtra c li _laws insts =-    let allMsgs = {- (msgExtra <$> extra) ++ -} (msgUnfoundLaw <$> unfoundLaws) ++ (msgUnfoundInstance <$> unfoundInstances)-    in mkDiagnostics mempty (mkError <$> allMsgs)-    where-        unfoundInstances = [ x | (_, (Right x,_)) <- insts]-        unfoundLaws = [ x | (Right x, _) <- insts]-        _extra = [] -- this breaks on extra super requirements [ (x,i) | (Left x, (Left i, _)) <- insts, not (x `L.elem` laws)] -        mkError = ErrILaw (lilPos li) (pprint c) (pprint $ lilTyArgs li)-        _msgExtra (x,_)      = pprint x <+> text "is not a defined law."-        msgUnfoundLaw i      = pprint i <+> text "is not a defined law."-        msgUnfoundInstance i = pprint i <+> text "is not a defined instance."--checkOneLaw :: Class -> (Var, LocSpecType) -> LawInstance -> Diagnostics-checkOneLaw c (x, t) li-  | Just (Left _, Just ti) <- lix-  = unify mkError c li t ti-  | Just (Right _l, _) <- lix-  = mkDiagnostics mempty [mkError (text "is not found.")]-  | otherwise-  = mkDiagnostics mempty [mkError (text "is not defined.")]-  where-    lix = L.lookup (Left x) (lilEqus li)-    mkError txt = ErrILaw (lilPos li) (pprint c) (pprintXs $ lilTyArgs li)-                          (text "The instance for the law" <+> pprint x <+> txt)-    pprintXs [l] = pprint l-    pprintXs xs  = pprint xs--unify :: (Doc -> Error) -> Class -> LawInstance -> LocSpecType -> LocSpecType -> Diagnostics-unify mkError c li t1 t2-  = if t11 =*= t22 then emptyDiagnostics else err-  where-    err = mkDiagnostics mempty [mkError (text "is invalid:\nType" <+> pprint t1 <+> text "\nis different than\n" <+> pprint t2-       --  text "\nesubt1 = " <+> pprint esubst1  -       -- text "\nesubt = " <+> pprint esubst  -       -- text "\ncompared\n" <+> pprint t11 <+> text "\nWITH\n" <+> pprint t22 -           )]--    t22 = fromRTypeRep (trep2 {ty_vars = [], ty_binds = fst <$> args2, ty_args = snd <$> args2, ty_refts = drop (length tc2) (ty_refts trep2)})-    t11 = fromRTypeRep (trep1 { ty_vars = []-                              , ty_binds = fst <$> args2-                              , ty_args = tx . snd <$> args1-                              , ty_refts = F.subst esubst <$> drop (length tc1) (ty_refts trep1)-                              , ty_res = tx $ ty_res trep1})-    tx = subtsSpec tsubst . F.subst esubst-    subtsSpec = subts :: ([(TyVar, Type)] -> SpecType -> SpecType)--    trep1 = toRTypeRep $ val t1 -    trep2 = toRTypeRep $ val t2 -    (tc1, args1) = splitTypeConstraints $ zip (ty_binds trep1) (ty_args trep1)-    (tc2, args2) = splitTypeConstraints $ zip (ty_binds trep2) (ty_args trep2)-    esubst = F.mkSubst (esubst1-                 ++  [(F.symbol x, F.EVar (F.symbol y)) | (Left x, (Left y, _)) <- lilEqus li]-                     )-    esubst1 = zip  (fst <$> args1) (F.EVar . fst <$> args2)--    tsubst = reverse $ zip ((\(RTV v) -> v) <$> (findTyVars tc1 ++ (ty_var_value <$> concat argVars)))-                 (toType False <$> (argBds ++ ((`RVar` mempty) . ty_var_value <$> (fst <$> ty_vars trep2))))--    (argVars, argBds) = unzip (splitForall [] . val <$> lilTyArgs li)--    splitForall vs (RAllT v t _) = splitForall (v:vs) t -    splitForall vs  t            = (vs, t) --    findTyVars (((_x, RApp cc as _ _):_ts)) | rtc_tc cc == classTyCon c -      = [v | RVar v _ <- as ]-    findTyVars (_:ts) = findTyVars ts -    findTyVars [] = [] ---splitTypeConstraints :: [(F.Symbol, SpecType)] -> ([(F.Symbol, SpecType)], [(F.Symbol, SpecType)])-splitTypeConstraints = go []  -  where  -    go cs (b@(_x, RApp c _ _ _):ts) -      | isClass c-      = go (b:cs) ts -    go cs r = (reverse cs, map (\(x, t) -> (x, shiftVV t x)) r)
− src/Language/Haskell/Liquid/Liquid.hs 
@@ -1,324 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--{-@ LIQUID "--diff"     @-}--module Language.Haskell.Liquid.Liquid (-   -- * Executable command-    liquid--   -- * Single query-  , runLiquid--   -- * Ghci State-  , MbEnv--   -- * Liquid Constraint Generation -  , liquidConstraints--   -- * Checking a single module-  , checkTargetInfo-  ) where--import           Prelude hiding (error)-import           Data.Bifunctor-import qualified Data.HashSet as S -import           System.Exit-import           Text.PrettyPrint.HughesPJ-import           System.Console.CmdArgs.Verbosity (whenLoud, whenNormal)-import           Control.Monad (when, unless)-import qualified Data.Maybe as Mb-import qualified Data.List  as L -import qualified Control.Exception as Ex-import qualified Language.Haskell.Liquid.UX.DiffCheck as DC-import           Language.Haskell.Liquid.Misc-import           Language.Fixpoint.Misc-import           Language.Fixpoint.Solver-import qualified Language.Fixpoint.Types as F-import           Language.Haskell.Liquid.Types-import           Language.Haskell.Liquid.Synthesize (synthesize)-import           Language.Haskell.Liquid.UX.Errors-import           Language.Haskell.Liquid.UX.CmdLine-import           Language.Haskell.Liquid.UX.Tidy-import           Liquid.GHC.Misc (showCBs, ignoreCoreBinds) -- howPpr)-import           Liquid.GHC.Interface-import           Language.Haskell.Liquid.Constraint.Generate-import           Language.Haskell.Liquid.Constraint.ToFixpoint-import           Language.Haskell.Liquid.Constraint.Types-import           Language.Haskell.Liquid.UX.Annotate (mkOutput)-import qualified Language.Haskell.Liquid.Termination.Structural as ST-import qualified Liquid.GHC.Misc          as GM -import           Liquid.GHC.API as GHC hiding (text, vcat, ($+$), getOpts, (<+>))--type MbEnv = Maybe HscEnv------------------------------------------------------------------------------------liquid :: [String] -> IO b----------------------------------------------------------------------------------liquid args = do -  cfg     <- getOpts args -  printLiquidHaskellBanner-  (ec, _) <- runLiquid Nothing cfg-  exitWith ec-----------------------------------------------------------------------------------liquidConstraints :: Config -> IO (Either [CGInfo] ExitCode) ----------------------------------------------------------------------------------liquidConstraints cfg = do -  z <- actOrDie $ second Just <$> getTargetInfos Nothing cfg (files cfg)-  case z of-    Left e -> do-      exitWithResult cfg (files cfg) $ mempty { o_result = e }-      return $ Right $ resultExit e -    Right (gs, _) -> -      return $ Left $ map generateConstraints gs-----------------------------------------------------------------------------------runLiquid :: MbEnv -> Config -> IO (ExitCode, MbEnv)----------------------------------------------------------------------------------runLiquid mE cfg  = do -  reals <- realTargets mE cfg (files cfg)-  whenNormal $ putStrLn $ showpp (text "Targets:" <+> vcat (text <$> reals))-  checkTargets cfg mE reals--checkTargets :: Config -> MbEnv -> [FilePath] -> IO (ExitCode, MbEnv)-checkTargets cfg  = go -  where-    go env []     = return (ExitSuccess, env)-    go env (f:fs) = do -- whenLoud $ colorPhaseLn Loud ("[Checking: " ++ f ++ "]") ""-                       (ec, env') <- runLiquidTargets env cfg [f] -                       case ec of -                         ExitSuccess -> go env' fs-                         _           -> return (ec, env')-------------------------------------------------------------------------------------- | @runLiquid@ checks a *target-list* of files, ASSUMING that we have ---   already  run LH on ALL the (transitive) home imports -- i.e. other ---   imports files for which we have source -- in order to build the .bspec ---   files for those specs.----------------------------------------------------------------------------------runLiquidTargets :: MbEnv -> Config -> [FilePath] -> IO (ExitCode, MbEnv)----------------------------------------------------------------------------------runLiquidTargets mE cfg targetFiles = do-  z <- actOrDie $ second Just <$> getTargetInfos mE cfg targetFiles-  case z of-    Left e -> do-      exitWithResult cfg targetFiles $ mempty { o_result = e }-      return (resultExit e, mE)-    Right (gs, mE') -> do-      d <- checkMany cfg mempty gs-      return (ec d, mE')-  where-    ec = resultExit . o_result-----------------------------------------------------------------------------------checkMany :: Config -> Output Doc -> [TargetInfo] -> IO (Output Doc)----------------------------------------------------------------------------------checkMany cfg d (g:gs) = do-  d' <- checkOne cfg g-  checkMany cfg (d `mappend` d') gs--checkMany _ d [] =-  return d-----------------------------------------------------------------------------------checkOne :: Config -> TargetInfo -> IO (Output Doc)----------------------------------------------------------------------------------checkOne cfg g = do-  z <- actOrDie $ liquidOne g-  case z of-    Left  e -> do-      let out = mempty { o_result = e }-      exitWithResult cfg [giTarget (giSrc g)] out-      pure out-    Right r -> return r---actOrDie :: IO a -> IO (Either ErrorResult a)-actOrDie act =-    (Right <$> act)-      `Ex.catch` (\(e :: SourceError) -> handle e)-      `Ex.catch` (\(e :: Error)       -> handle e)-      `Ex.catch` (\(e :: UserError)   -> handle e)-      `Ex.catch` (\(e :: [Error])     -> handle e)--handle :: (Result a) => a -> IO (Either ErrorResult b)-handle = return . Left . result-----------------------------------------------------------------------------------liquidOne :: TargetInfo -> IO (Output Doc)----------------------------------------------------------------------------------liquidOne info = do-  out' <- checkTargetInfo info-  exitWithResult cfg [tgt] out'-  pure out'-  where-    cfg  = getConfig info-    tgt  = giTarget (giSrc info)-----------------------------------------------------------------------------------checkTargetInfo :: TargetInfo -> IO (Output Doc)----------------------------------------------------------------------------------checkTargetInfo info = do-  out <- check-  unless (compileSpec cfg) $ DC.saveResult tgt out-  pure out-  where-    check :: IO (Output Doc)-    check-      | compileSpec cfg = do-        -- donePhase Loud "Only compiling specifications [skipping verification]"-        pure mempty { o_result = F.Safe mempty }-      | otherwise = do-        whenNormal $ donePhase Loud "Extracted Core using GHC"-        -- whenLoud  $ do putStrLn $ showpp info-                     -- putStrLn "*************** Original CoreBinds ***************************"-                     -- putStrLn $ render $ pprintCBs (cbs info)-        whenNormal $ donePhase Loud "Transformed Core"-        whenLoud  $ do donePhase Loud "transformRecExpr-1773-hoho"-                       putStrLn "*************** Transform Rec Expr CoreBinds *****************"-                       putStrLn $ showCBs (untidyCore cfg) cbs'-                       -- putStrLn $ render $ pprintCBs cbs'-                       -- putStrLn $ showPpr cbs'-        edcs <- newPrune cfg cbs' tgt info-        liquidQueries cfg tgt info edcs--    cfg :: Config-    cfg  = getConfig info--    tgt :: FilePath-    tgt  = giTarget (giSrc info)--    cbs' :: [CoreBind]-    cbs' = giCbs (giSrc info)--newPrune :: Config -> [CoreBind] -> FilePath -> TargetInfo -> IO (Either [CoreBind] [DC.DiffCheck])-newPrune cfg cbs tgt info-  | not (null vs) = return . Right $ [DC.thin cbs sp vs]-  | timeBinds cfg = return . Right $ [DC.thin cbs sp [v] | v <- expVars]-  | diffcheck cfg = maybeEither cbs <$> DC.slice tgt cbs sp-  | otherwise     = return $ Left (ignoreCoreBinds ignores cbs)-  where-    ignores       = gsIgnoreVars (gsVars sp)-    vs            = gsTgtVars    (gsVars sp)-    sp            = giSpec       info-    expVars       = exportedVars (giSrc info)--exportedVars :: TargetSrc -> [Var]-exportedVars src = filter (isExportedVar src) (giDefVars src)--maybeEither :: a -> Maybe b -> Either a [b]-maybeEither d Nothing  = Left d-maybeEither _ (Just x) = Right [x]--liquidQueries :: Config -> FilePath -> TargetInfo -> Either [CoreBind] [DC.DiffCheck] -> IO (Output Doc)-liquidQueries cfg tgt info (Left cbs')-  = liquidQuery cfg tgt info (Left cbs')-liquidQueries cfg tgt info (Right dcs)-  = mconcat <$> mapM (liquidQuery cfg tgt info . Right) dcs--liquidQuery   :: Config -> FilePath -> TargetInfo -> Either [CoreBind] DC.DiffCheck -> IO (Output Doc)-liquidQuery cfg tgt info edc = do-  let names   = either (const Nothing) (Just . map show . DC.checkedVars)   edc-  let oldOut  = either (const mempty)  DC.oldOutput                         edc-  let info1   = either (const info)    (\z -> info {giSpec = DC.newSpec z}) edc-  let cbs''   = either id              DC.newBinds                          edc-  let info2   = info1 { giSrc = (giSrc info1) {giCbs = cbs''}}-  let info3   = updTargetInfoTermVars info2 -  let cgi     = {-# SCC "generateConstraints" #-} generateConstraints $! info3 -  when False (dumpCs cgi)-  -- whenLoud $ mapM_ putStrLn [ "****************** CGInfo ********************"-                            -- , render (pprint cgi)                            ]-  out        <- timedAction names $ solveCs cfg tgt cgi info3 names-  return      $ mconcat [oldOut, out]--updTargetInfoTermVars    :: TargetInfo -> TargetInfo -updTargetInfoTermVars i  = updInfo i  (ST.terminationVars i) -  where -    updInfo   info vs = info { giSpec = updSpec   (giSpec info) vs }-    updSpec   sp   vs = sp   { gsTerm = updSpTerm (gsTerm sp)   vs }-    updSpTerm gsT  vs = gsT  { gsNonStTerm = S.fromList vs         } -      -dumpCs :: CGInfo -> IO ()-dumpCs cgi = do-  putStrLn "***************************** SubCs *******************************"-  putStrLn $ render $ pprintMany (hsCs cgi)-  putStrLn "***************************** FixCs *******************************"-  putStrLn $ render $ pprintMany (fixCs cgi)-  putStrLn "***************************** WfCs ********************************"-  putStrLn $ render $ pprintMany (hsWfs cgi)--pprintMany :: (PPrint a) => [a] -> Doc-pprintMany xs = vcat [ F.pprint x $+$ text " " | x <- xs ]--solveCs :: Config -> FilePath -> CGInfo -> TargetInfo -> Maybe [String] -> IO (Output Doc)-solveCs cfg tgt cgi info names = do-  finfo            <- cgInfoFInfo info cgi-  let fcfg          = fixConfig tgt cfg-  F.Result {resStatus=r0, resSolution=sol} <- solve fcfg finfo-  let failBs        = gsFail $ gsTerm $ giSpec info-  let (r,rf)        = splitFails (S.map val failBs) r0 -  let resErr        = second (applySolution sol . cinfoError) <$> r-  -- resModel_        <- fmap (e2u cfg sol) <$> getModels info cfg resErr-  let resModel_     = cidE2u cfg sol <$> resErr-  let resModel'     = resModel_  `addErrors` (e2u cfg sol <$> logErrors cgi)-                                 `addErrors` makeFailErrors (S.toList failBs) rf -                                 `addErrors` makeFailUseErrors (S.toList failBs) (giCbs $ giSrc info)-  let lErrors       = applySolution sol <$> logErrors cgi-  hErrors          <- if typedHoles cfg -                        then synthesize tgt fcfg (cgi{holesMap = applySolution sol <$> holesMap  cgi}) -                        else return [] -  let resModel      = resModel' `addErrors` (e2u cfg sol <$> (lErrors ++ hErrors)) -  let out0          = mkOutput cfg resModel sol (annotMap cgi)-  return            $ out0 { o_vars    = names    }-                           { o_result  = resModel }---e2u :: Config -> F.FixSolution -> Error -> UserError-e2u cfg s = fmap F.pprint . tidyError cfg s--cidE2u :: Config -> F.FixSolution -> (Integer, Error) -> UserError-cidE2u cfg s (subcId, e) =-  let e' = attachSubcId e-   in fmap F.pprint (tidyError cfg s e')-  where-    attachSubcId es@ErrSubType{}      = es { cid = Just subcId }-    attachSubcId es@ErrSubTypeModel{} = es { cid = Just subcId }-    attachSubcId es = es---- writeCGI tgt cgi = {-# SCC "ConsWrite" #-} writeFile (extFileName Cgi tgt) str---   where---     str          = {-# SCC "PPcgi" #-} showpp cgi---makeFailUseErrors :: [F.Located Var] -> [CoreBind] -> [UserError]-makeFailUseErrors fbs cbs = [ mkError x bs | x <- fbs-                                          , let bs = clients (val x)-                                          , not (null bs) ]  -  where -    mkError x bs = ErrFailUsed (GM.sourcePosSrcSpan $ loc x) (pprint $ val x) (pprint <$> bs)-    clients x    = map fst $ filter (elem x . snd) allClients--    allClients = concatMap go cbs --    go :: CoreBind -> [(Var,[Var])]-    go (NonRec x e) = [(x, readVars e)] -    go (Rec xes)    = [(x,cls) | x <- map fst xes] where cls = concatMap readVars (snd <$> xes)--makeFailErrors :: [F.Located Var] -> [Cinfo] -> [UserError]-makeFailErrors bs cis = [ mkError x | x <- bs, notElem (val x) vs ]  -  where -    mkError  x = ErrFail (GM.sourcePosSrcSpan $ loc x) (pprint $ val x)-    vs         = Mb.mapMaybe ci_var cis--splitFails :: S.HashSet Var -> F.FixResult (a, Cinfo) -> (F.FixResult (a, Cinfo),  [Cinfo])-splitFails _ r@(F.Crash _ _) = (r,mempty)-splitFails _ r@(F.Safe _)    = (r,mempty)-splitFails fs (F.Unsafe s xs)  = (mkRes r, snd <$> rfails)-  where -    (rfails,r) = L.partition (Mb.maybe False (`S.member` fs) . ci_var . snd) xs -    mkRes [] = F.Safe s-    mkRes ys = F.Unsafe s ys --
− src/Language/Haskell/Liquid/Measure.hs 
@@ -1,248 +0,0 @@-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FlexibleContexts       #-}-{-# LANGUAGE UndecidableInstances   #-}-{-# LANGUAGE OverloadedStrings      #-}-{-# LANGUAGE ConstraintKinds        #-}--module Language.Haskell.Liquid.Measure (-  -- * Specifications-    Spec (..)-  , MSpec (..)--  -- * Type Aliases-  , BareSpec-  , BareMeasure-  , SpecMeasure--  -- * Constructors-  , mkM, mkMSpec, mkMSpec'-  , dataConTypes-  , defRefType-  , bodyPred-  ) where--import           GHC                                    hiding (Located)-import           Prelude                                hiding (error)-import           Text.PrettyPrint.HughesPJ              hiding ((<>)) --- import           Data.Binary                            as B--- import           GHC.Generics-import qualified Data.HashMap.Strict                    as M-import qualified Data.List                              as L-import qualified Data.Maybe                             as Mb -- (fromMaybe, isNothing)--import           Language.Fixpoint.Misc-import           Language.Fixpoint.Types                hiding (panic, R, DataDecl, SrcSpan, LocSymbol)-import           Liquid.GHC.API        as Ghc hiding (Expr, showPpr, panic, (<+>))-import           Liquid.GHC.Misc--- import qualified Language.Haskell.Liquid.Misc as Misc-import           Language.Haskell.Liquid.Types.Types    -- hiding (GhcInfo(..), GhcSpec (..))-import           Language.Haskell.Liquid.Types.RefType--- import           Language.Haskell.Liquid.Types.Variance--- import           Language.Haskell.Liquid.Types.Bounds-import           Language.Haskell.Liquid.Types.Specs hiding (BareSpec)-import           Language.Haskell.Liquid.UX.Tidy---- /FIXME/: This needs to be removed once the port to the new API is complete.-type BareSpec = Spec LocBareType LocSymbol--mkM ::  LocSymbol -> ty -> [Def ty bndr] -> MeasureKind -> UnSortedExprs -> Measure ty bndr-mkM name typ eqns kind u-  | all ((name ==) . measure) eqns-  = M name typ eqns kind u-  | otherwise-  = panic Nothing $ "invalid measure definition for " ++ show name--mkMSpec' :: Symbolic ctor => [Measure ty ctor] -> MSpec ty ctor-mkMSpec' ms = MSpec cm mm M.empty []-  where-    cm     = groupMap (symbol . ctor) $ concatMap msEqns ms-    mm     = M.fromList [(msName m, m) | m <- ms ]--mkMSpec :: [Measure t LocSymbol] -> [Measure t ()] -> [Measure t LocSymbol] -> MSpec t LocSymbol-mkMSpec ms cms ims = MSpec cm mm cmm ims-  where-    cm     = groupMap (val . ctor) $ concatMap msEqns (ms'++ims)-    mm     = M.fromList [(msName m, m) | m <- ms' ]-    cmm    = M.fromList [(msName m, m) | m <- cms ]-    ms'    = checkDuplicateMeasure ms---checkDuplicateMeasure :: [Measure ty ctor] -> [Measure ty ctor]-checkDuplicateMeasure measures-  = case M.toList dups of-      []         -> measures-      (m,ms):_   -> uError $ mkErr m (msName <$> ms)-    where-      gms        = group [(msName m , m) | m <- measures]-      dups       = M.filter ((1 <) . length) gms-      mkErr m ms = ErrDupMeas (fSrcSpan m) (pprint (val m)) (fSrcSpan <$> ms)---dataConTypes :: Bool -> MSpec (RRType Reft) DataCon -> ([(Var, RRType Reft)], [(LocSymbol, RRType Reft)])-dataConTypes allowTC  s = (ctorTys, measTys)-  where-    measTys     = [(msName m, msSort m) | m <- M.elems (measMap s) ++ imeas s]-    ctorTys     = concatMap (makeDataConType allowTC) (notracepp "HOHOH" . snd <$> M.toList (ctorMap s))--makeDataConType :: Bool -> [Def (RRType Reft) DataCon] -> [(Var, RRType Reft)]-makeDataConType _ []-  = []-makeDataConType allowTC ds | Mb.isNothing (dataConWrapId_maybe dc)-  = notracepp _msg [(woId, notracepp _msg $ combineDCTypes "cdc0" t ts)]-  where-    dc   = ctor (head ds)-    woId = dataConWorkId dc-    t    = varType woId-    ts   = defRefType allowTC t <$> ds-    _msg  = "makeDataConType0" ++ showpp (woId, t, ts)--makeDataConType allowTC ds-  = [(woId, extend allowTC loci woRType wrRType), (wrId, extend allowTC loci wrRType woRType)]-  where-    (wo, wr) = L.partition isWorkerDef ds-    dc       = ctor $ head ds-    loci     = loc $ measure $ head ds-    woId     = dataConWorkId dc-    wot      = varType woId-    wrId     = dataConWrapId dc-    wrt      = varType wrId-    wots     = defRefType allowTC wot <$> wo-    wrts     = defRefType allowTC wrt <$> wr--    wrRType  = combineDCTypes "cdc1" wrt wrts-    woRType  = combineDCTypes "cdc2" wot wots---    isWorkerDef def-      -- types are missing for arguments, so definition came from a logical measure-      -- and it is for the worker datacon-      | any Mb.isNothing (snd <$> binds def)-      = True-      | otherwise-      = length (binds def) == length (fst $ splitFunTys $ snd $ splitForAllTys wot)---extend :: Bool-       -> SourcePos-       -> RType RTyCon RTyVar Reft-       -> RRType Reft-       -> RType RTyCon RTyVar Reft-extend allowTC lc t1' t2-  | Just su <- mapArgumens allowTC lc t1 t2-  = t1 `strengthenResult` subst su (Mb.fromMaybe mempty (stripRTypeBase $ resultTy t2))-  | otherwise-  = t1-  where-    t1 = noDummySyms t1'---resultTy :: RType c tv r -> RType c tv r-resultTy = ty_res . toRTypeRep--strengthenResult :: Reftable r => RType c tv r -> r -> RType c tv r-strengthenResult t r = fromRTypeRep $ rep {ty_res = ty_res rep `strengthen` r}-  where-    rep              = toRTypeRep t---noDummySyms :: (OkRT c tv r) => RType c tv r -> RType c tv r-noDummySyms t-  | any isDummy (ty_binds rep)-  = subst su $ fromRTypeRep $ rep{ty_binds = xs'}-  | otherwise-  = t-  where-    rep = toRTypeRep t-    xs' = zipWith (\_ i -> symbol ("x" ++ show i)) (ty_binds rep) [(1::Int)..]-    su  = mkSubst $ zip (ty_binds rep) (EVar <$> xs')--combineDCTypes :: String -> Type -> [RRType Reft] -> RRType Reft-combineDCTypes _msg t ts = L.foldl' strengthenRefTypeGen (ofType t) ts--mapArgumens :: Bool -> SourcePos -> RRType Reft -> RRType Reft -> Maybe Subst-mapArgumens allowTC lc t1 t2 = go xts1' xts2'-  where-    xts1 = zip (ty_binds rep1) (ty_args rep1)-    xts2 = zip (ty_binds rep2) (ty_args rep2)-    rep1 = toRTypeRep t1-    rep2 = toRTypeRep t2--    xts1' = dropWhile canDrop xts1-    xts2' = dropWhile canDrop xts2--    canDrop (_, t) = if allowTC then isEmbeddedClass t else isClassType t || isEqType t--    go xs ys-      | length xs == length ys && and (zipWith (==) (toRSort . snd <$> xts1') (toRSort . snd <$> xts2'))-      = Just $ mkSubst $ zipWith (\y x -> (fst x, EVar $ fst y)) xts1' xts2'-      | otherwise-      = panic (Just $ sourcePosSrcSpan lc) ("The types for the wrapper and worker data constructors cannot be merged\n"-          ++ show t1 ++ "\n" ++ show t2 )---- should constructors have implicits? probably not-defRefType :: Bool -> Type -> Def (RRType Reft) DataCon -> RRType Reft-defRefType allowTC tdc (Def f dc mt xs body)-                    = generalize $ mkArrow as' [] [] xts t'-  where-    xts             = stitchArgs allowTC (fSrcSpan f) dc xs ts -    t'              = refineWithCtorBody dc f body t-    t               = Mb.fromMaybe (ofType tr) mt-    (αs, ts, tr)    = splitType tdc-    as              = if Mb.isJust mt then [] else makeRTVar . rTyVar <$> αs-    as'             = zip as (repeat mempty)--splitType :: Type -> ([TyVar],[Type], Type)-splitType t  = (αs, map irrelevantMult ts, tr)-  where-    (αs, tb) = splitForAllTys t-    (ts, tr) = splitFunTys tb--stitchArgs :: (Monoid t1, PPrint a)-           => Bool-           -> SrcSpan-           -> a-           -> [(Symbol, Maybe (RRType Reft))]-           -> [Type]-           -> [(Symbol, RFInfo, RRType Reft, t1)]-stitchArgs allowTC sp dc allXs allTs-  | nXs == nTs         = (g (dummySymbol, Nothing) . ofType <$> pts)-                      ++ zipWith g xs (ofType <$> ts)-  | otherwise          = panicFieldNumMismatch sp dc nXs nTs-    where-      (pts, ts)        = L.partition (\t -> notracepp ("isPredTy: " ++ showpp t) $ (if allowTC then isEmbeddedDictType else Ghc.isEvVarType ) t) allTs-      (_  , xs)        = L.partition (coArg . snd) allXs-      nXs              = length xs-      nTs              = length ts-      g (x, Just t) _  = (x, classRFInfo allowTC, t, mempty)-      g (x, _)      t  = (x, classRFInfo allowTC, t, mempty)-      coArg Nothing    = False-      coArg (Just t)   = (if allowTC then isEmbeddedDictType else Ghc.isEvVarType ). toType False $ t--panicFieldNumMismatch :: (PPrint a, PPrint a1, PPrint a3)-                      => SrcSpan -> a3 -> a1 -> a -> a2-panicFieldNumMismatch sp dc nXs nTs  = panicDataCon sp dc msg-  where-    msg = "Requires" <+> pprint nTs <+> "fields but given" <+> pprint nXs--panicDataCon :: PPrint a1 => SrcSpan -> a1 -> Doc -> a-panicDataCon sp dc d-  = panicError $ ErrDataCon sp (pprint dc) d--refineWithCtorBody :: Outputable a-                   => a-                   -> LocSymbol-                   -> Body-                   -> RType c tv Reft-                   -> RType c tv Reft-refineWithCtorBody dc f body t =-  case stripRTypeBase t of-    Just (Reft (v, _)) ->-      strengthen t $ Reft (v, bodyPred (mkEApp f [eVar v]) body)-    Nothing ->-      panic Nothing $ "measure mismatch " ++ showpp f ++ " on con " ++ showPpr dc---bodyPred ::  Expr -> Body -> Expr-bodyPred fv (E e)    = PAtom Eq fv e-bodyPred fv (P p)    = PIff  fv p-bodyPred fv (R v' p) = subst1 p (v', fv)
− src/Language/Haskell/Liquid/Misc.hs 
@@ -1,450 +0,0 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE DoAndIfThenElse #-}--module Language.Haskell.Liquid.Misc where--import Prelude hiding (error)-import Control.Monad.State--import Control.Arrow (first)-import System.FilePath-import System.Directory   (getModificationTime, doesFileExist)-import System.Environment (getExecutablePath)--import qualified Control.Exception     as Ex --(evaluate, catch, IOException)-import qualified Data.HashSet          as S-import qualified Data.HashMap.Strict   as M-import qualified Data.List             as L-import           Data.Maybe-import           Data.Tuple-import           Data.Hashable-import           Data.Time-import           Data.Function (on)-import qualified Data.ByteString       as B-import           Data.ByteString.Char8 (pack, unpack)-import qualified Text.PrettyPrint.HughesPJ as PJ -- (char, Doc)-import           Text.Printf-import           Language.Fixpoint.Misc-import           Paths_liquidhaskell--type Nat = Int--(.&&.), (.||.) :: (a -> Bool) -> (a -> Bool) -> a -> Bool-(.&&.) = up (&&)-(.||.) = up (||)--up :: (b -> c -> d) -> (a -> b) -> (a -> c) -> (a -> d)-up o f g x = f x `o` g x--timedAction :: (Show msg) => Maybe msg -> IO a -> IO a-timedAction label io = do-  t0 <- getCurrentTime-  a <- io-  t1 <- getCurrentTime-  let time = realToFrac (t1 `diffUTCTime` t0) :: Double-  case label of-    Just x  -> printf "Time (%.2fs) for action %s \n" time (show x)-    Nothing -> return ()-  return a--(!?) :: [a] -> Int -> Maybe a-[]     !? _ = Nothing-(x:_)  !? 0 = Just x-(_:xs) !? n = xs !? (n-1)--safeFromJust :: String -> Maybe t -> t-safeFromJust _  (Just x) = x-safeFromJust err _       = errorstar err--safeFromLeft :: String -> Either a b -> a-safeFromLeft _   (Left l) = l-safeFromLeft err _        = errorstar err---takeLast :: Int -> [a] -> [a]-takeLast n xs = drop (m - n) xs-  where-    m         = length xs--getNth :: Int -> [a] -> Maybe a-getNth 0 (x:_)  = Just x-getNth n (_:xs) = getNth (n-1) xs-getNth _ _      = Nothing--fst4 :: (t, t1, t2, t3) -> t-fst4 (a,_,_,_) = a--snd4 :: (t, t1, t2, t3) -> t1-snd4 (_,b,_,_) = b--thd4 :: (t1, t2, t3, t4) -> t3-thd4 (_,_,b,_) = b---thrd3 :: (t1, t2, t3) -> t3-thrd3 (_,_,c) = c--mapFifth5 :: (t -> t4) -> (t0, t1, t2, t3, t) -> (t0, t1, t2, t3, t4)-mapFifth5 f (a, x, y, z, w) = (a, x, y, z, f w)--mapFourth4 :: (t -> t4) -> (t1, t2, t3, t) -> (t1, t2, t3, t4)-mapFourth4 f (x, y, z, w) = (x, y, z, f w)--addFst3 :: t -> (t1, t2) -> (t, t1, t2)-addFst3   a (b, c) = (a, b, c)--addThd3 :: t2 -> (t, t1) -> (t, t1, t2)-addThd3   c (a, b) = (a, b, c)--dropFst3 :: (t, t1, t2) -> (t1, t2)-dropFst3 (_, x, y) = (x, y)--dropThd3 :: (t1, t2, t) -> (t1, t2)-dropThd3 (x, y, _) = (x, y)--replaceN :: (Enum a, Eq a, Num a) => a -> t -> [t] -> [t]-replaceN n y ls = [if i == n then y else x | (x, i) <- zip ls [0..]]---thd5 :: (t0, t1, t2, t3,t4) -> t2-thd5 (_,_,x,_,_) = x--snd5 :: (t0, t1, t2, t3,t4) -> t1-snd5 (_,x,_,_,_) = x--fst5 :: (t0, t1, t2, t3,t4) -> t0-fst5 (x,_,_,_,_) = x--fourth4 :: (t, t1, t2, t3) -> t3-fourth4 (_,_,_,x) = x--third4 :: (t, t1, t2, t3) -> t2-third4  (_,_,x,_) = x--mapSndM :: (Applicative m) => (b -> m c) -> (a, b) -> m (a, c)--- mapSndM f (x, y) = return . (x,) =<< f y-mapSndM f (x, y) = (x, ) <$> f y--firstM :: Functor f => (t -> f a) -> (t, t1) -> f (a, t1)-firstM  f (a,b) = (,b) <$> f a--secondM :: Functor f => (t -> f a) -> (t1, t) -> f (t1, a)-secondM f (a,b) = (a,) <$> f b--first3M :: Functor f => (t -> f a) -> (t, t1, t2) -> f (a, t1, t2)-first3M  f (a,b,c) = (,b,c) <$> f a--second3M :: Functor f => (t -> f a) -> (t1, t, t2) -> f (t1, a, t2)-second3M f (a,b,c) = (a,,c) <$> f b--third3M :: Functor f => (t -> f a) -> (t1, t2, t) -> f (t1, t2, a)-third3M  f (a,b,c) = (a,b,) <$> f c--third3 :: (t -> t3) -> (t1, t2, t) -> (t1, t2, t3)-third3 f (a,b,c) = (a,b,f c)--zip4 :: [t] -> [t1] -> [t2] -> [t3] -> [(t, t1, t2, t3)]-zip4 (x1:xs1) (x2:xs2) (x3:xs3) (x4:xs4) = (x1, x2, x3, x4) : zip4 xs1 xs2 xs3 xs4-zip4 _ _ _ _                             = []--zip5 :: [t] -> [t1] -> [t2] -> [t3] -> [t4] -> [(t, t1, t2, t3, t4)]-zip5 (x1:xs1) (x2:xs2) (x3:xs3) (x4:xs4) (x5:xs5) = (x1, x2, x3, x4,x5) : zip5 xs1 xs2 xs3 xs4 xs5-zip5 _ _ _ _ _                                    = []----unzip4 :: [(t, t1, t2, t3)] -> ([t],[t1],[t2],[t3])-unzip4 = go [] [] [] []-  where go a1 a2 a3 a4 ((x1,x2,x3,x4):xs) = go (x1:a1) (x2:a2) (x3:a3) (x4:a4) xs-        go a1 a2 a3 a4 [] = (reverse  a1, reverse a2, reverse a3, reverse a4)---isIncludeFile :: FilePath -> FilePath -> Bool-isIncludeFile incDir src = -- do -  -- incDir <- getIncludeDir -  -- return -  incDir `L.isPrefixOf` src--getIncludeDir :: IO FilePath-getIncludeDir = dropFileName <$> getDataFileName ("include" </> "Prelude.spec")-{-# DEPRECATED getIncludeDir "getIncludeDir is deprecated. The hardcoded include folder will be removed in the future." #-}--getCssPath :: IO FilePath-getCssPath         = getDataFileName $ "syntax" </> "liquid.css"--getCoreToLogicPath :: IO FilePath-getCoreToLogicPath = do-    let fileName = "CoreToLogic.lg"--    -- Try to find it first at executable path-    exePath <- dropFileName <$> getExecutablePath-    let atExe = exePath </> fileName-    exists <- doesFileExist atExe--    if exists then-      return atExe-    else-      fmap (</> fileName) getIncludeDir---{-@ type ListN a N = {v:[a] | len v = N} @-}-{-@ type ListL a L = ListN a (len L) @-}--zipMaybe :: [a] -> [b] -> Maybe [(a, b)]-zipMaybe xs ys-  | length xs == length ys = Just (zip xs ys)-  | otherwise              = Nothing--{-@ safeZipWithError :: _ -> xs:[a] -> ListL b xs -> ListL (a,b) xs / [xs] @-}-safeZipWithError :: String -> [t] -> [t1] -> [(t, t1)]-safeZipWithError msg (x:xs) (y:ys) = (x,y) : safeZipWithError msg xs ys-safeZipWithError _   []     []     = []-safeZipWithError msg _      _      = errorstar msg--safeZip3WithError :: String -> [t] -> [t1] -> [t2] -> [(t, t1, t2)]-safeZip3WithError msg (x:xs) (y:ys) (z:zs) = (x,y,z) : safeZip3WithError msg xs ys zs-safeZip3WithError _   []     []     []     = []-safeZip3WithError msg _      _      _      = errorstar msg--safeZip4WithError :: String -> [t1] -> [t2] -> [t3] -> [t4] -> [(t1, t2, t3, t4)]-safeZip4WithError msg (x:xs) (y:ys) (z:zs) (w:ws) = (x,y,z,w) : safeZip4WithError msg xs ys zs ws-safeZip4WithError _   []     []     []     []     = []-safeZip4WithError msg _      _      _      _      = errorstar msg---mapNs :: (Eq a, Num a, Foldable t) => t a -> (a1 -> a1) -> [a1] -> [a1]-mapNs ns f xs = foldl (\ys n -> mapN n f ys) xs ns--mapN :: (Eq a, Num a) => a -> (a1 -> a1) -> [a1] -> [a1]-mapN 0 f (x:xs) = f x : xs-mapN n f (x:xs) = x : mapN (n-1) f xs-mapN _ _ []     = []--zipWithDefM :: Monad m => (a -> a -> m a) -> [a] -> [a] -> m [a]-zipWithDefM _ []     []     = return []-zipWithDefM _ xs     []     = return xs-zipWithDefM _ []     ys     = return ys-zipWithDefM f (x:xs) (y:ys) = (:) <$> f x y <*> zipWithDefM f xs ys--zipWithDef :: (a -> a -> a) -> [a] -> [a] -> [a]-zipWithDef _ []     []     = []-zipWithDef _ xs     []     = xs-zipWithDef _ []     ys     = ys-zipWithDef f (x:xs) (y:ys) = f x y : zipWithDef f xs ys-------------------------------------------------------------------------------------- Originally part of Fixpoint's Misc:-----------------------------------------------------------------------------------single :: t -> [t]-single x = [x]--mapFst3 :: (t -> t1) -> (t, t2, t3) -> (t1, t2, t3)-mapFst3 f (x, y, z) = (f x, y, z)--mapSnd3 :: (t -> t2) -> (t1, t, t3) -> (t1, t2, t3)-mapSnd3 f (x, y, z) = (x, f y, z)--mapThd3 :: (t -> t3) -> (t1, t2, t) -> (t1, t2, t3)-mapThd3 f (x, y, z) = (x, y, f z)--firstMaybes :: [Maybe a] -> Maybe a-firstMaybes = listToMaybe . catMaybes--fromFirstMaybes :: a -> [Maybe a] -> a-fromFirstMaybes x = fromMaybe x . firstMaybes--- fromFirstMaybes x = fromMaybe x . listToMaybe . catMaybes--hashMapMapWithKey   :: (k -> v1 -> v2) -> M.HashMap k v1 -> M.HashMap k v2-hashMapMapWithKey f = fromJust . M.traverseWithKey (\k v -> Just (f k v))--hashMapMapKeys   :: (Eq k2, Hashable k2) => (k1 -> k2) -> M.HashMap k1 v -> M.HashMap k2 v-hashMapMapKeys f = M.fromList . fmap (first f) . M.toList--concatMapM :: (Monad m, Traversable t) => (a -> m [b]) -> t a -> m [b]-concatMapM f = fmap concat . mapM f--replaceSubset :: (Eq k, Hashable k) => [(k, a)] -> [(k, a)] -> [(k, a)]-replaceSubset kvs kvs' = M.toList (L.foldl' upd m0 kvs')-  where-    m0                = M.fromList kvs-    upd m (k, v')-      | M.member k m  = M.insert k v' m-      | otherwise     = m--replaceWith :: (Eq a, Hashable a) => (b -> a) -> [b] -> [b] -> [b]-replaceWith f xs ys = snd <$> replaceSubset xs' ys'-  where-    xs'             = [ (f x, x) | x <- xs ]-    ys'             = [ (f y, y) | y <- ys ]-----firstElems ::  [(B.ByteString, B.ByteString)] -> B.ByteString -> Maybe (Int, B.ByteString, (B.ByteString, B.ByteString))-firstElems seps str-  = case splitters seps str of-      [] -> Nothing-      is -> Just $ L.minimumBy (compare `on` fst3) is--splitters :: [(B.ByteString, t)]-          -> B.ByteString -> [(Int, t, (B.ByteString, B.ByteString))]-splitters seps str-  = [(i, c', z) | (c, c') <- seps-                , let z   = B.breakSubstring c str-                , let i   = B.length (fst z)-                , i < B.length str                 ]--bchopAlts :: [(B.ByteString, B.ByteString)] -> B.ByteString -> [B.ByteString]-bchopAlts seps  = go-  where-    go  s               = maybe [s] go' (firstElems seps s)-    go' (_,c',(s0, s1)) = if B.length s2 == B.length s1 then [B.concat [s0,s1]] else s0 : s2' : go s3'-                          where (s2, s3) = B.breakSubstring c' s1-                                s2'      = B.append s2 c'-                                s3'      = B.drop (B.length c') s3--chopAlts :: [(String, String)] -> String -> [String]-chopAlts seps str = unpack <$> bchopAlts [(pack c, pack c') | (c, c') <- seps] (pack str)--sortDiff :: (Ord a) => [a] -> [a] -> [a]-sortDiff x1s x2s             = go (sortNub x1s) (sortNub x2s)-  where-    go xs@(x:xs') ys@(y:ys')-      | x <  y               = x : go xs' ys-      | x == y               = go xs' ys'-      | otherwise            = go xs ys'-    go xs []                 = xs-    go [] _                  = []--(<->) :: PJ.Doc -> PJ.Doc -> PJ.Doc-x <-> y = x PJ.<> y--angleBrackets :: PJ.Doc -> PJ.Doc-angleBrackets p = PJ.char '<' <-> p <-> PJ.char '>'--mkGraph :: (Eq a, Eq b, Hashable a, Hashable b) => [(a, b)] -> M.HashMap a (S.HashSet b)-mkGraph = fmap S.fromList . group--tryIgnore :: String -> IO () -> IO ()-tryIgnore s a =-  Ex.catch a $ \e -> do-    let err = show (e :: Ex.IOException)-    writeLoud ("Warning: Couldn't do " ++ s ++ ": " ++ err)-    return ()---condNull :: Monoid m => Bool -> m -> m-condNull c xs = if c then xs else mempty--firstJust :: (a -> Maybe b) -> [a] -> Maybe b-firstJust f xs = listToMaybe $ mapMaybe f xs--intToString :: Int -> String-intToString 1 = "1st"-intToString 2 = "2nd"-intToString 3 = "3rd"-intToString n = show n ++ "th"--mapAccumM :: (Monad m, Traversable t) => (a -> b -> m (a, c)) -> a -> t b -> m (a, t c)-mapAccumM f acc0 xs =-  swap <$> runStateT (traverse (StateT . (\x acc -> swap <$> f acc x)) xs) acc0--ifM :: (Monad m) => m Bool -> m b -> m b -> m b-ifM b x y = b >>= \z -> if z then x else y--nubHashOn :: (Eq k, Hashable k) => (a -> k) -> [a] -> [a]-nubHashOn f = map head . M.elems . groupMap f--nubHashLast :: (Eq k, Hashable k) => (a -> k) -> [a] -> [a]-nubHashLast f xs = M.elems $ M.fromList [ (f x, x) | x <- xs ]--nubHashLastM :: (Eq k, Hashable k, Monad m) => (a -> m k) -> [a] -> m [a]-nubHashLastM f xs =  M.elems . M.fromList . (`zip` xs) <$> mapM f xs--uniqueByKey :: (Eq k, Hashable k) => [(k, v)] -> Either (k, [v]) [v]-uniqueByKey = uniqueByKey' tx-  where-    tx (_, [v]) = Right v-    tx (k, vs)  = Left  (k, vs)--uniqueByKey' :: (Eq k, Hashable k) => ((k, [v]) -> Either e v) -> [(k, v)] -> Either e [v]-uniqueByKey' tx = mapM tx . groupList---join :: (Eq b, Hashable b) => [(a, b)] -> [(b, c)] -> [(a, c)]-join aBs bCs = [ (a, c) | (a, b) <- aBs, c <- b2cs b ]-  where-    bM       = M.fromList bCs-    b2cs b   = maybeToList (M.lookup b bM)---fstByRank :: (Ord r, Hashable k, Eq k) => [(r, k, v)] -> [(r, k, v)]-fstByRank rkvs = [ (r, k, v) | (k, rvs) <- krvss, let (r, v) = getFst rvs ]-  where-    getFst     = head . sortOn fst-    krvss      = groupList [ (k, (r, v)) | (r, k, v) <- rkvs ]--sortOn :: (Ord b) => (a -> b) -> [a] -> [a]-sortOn f = L.sortBy (compare `on` f)--firstGroup :: (Eq k, Ord k, Hashable k) => [(k, a)] -> [a]-firstGroup kvs = case groupList kvs of-  []   -> []-  kvss -> snd . head . sortOn fst $ kvss--{- mapEither :: (a -> Either b c) -> [a] -> ([b], [c])-mapEither f []     = ([], [])-mapEither f (x:xs) = case f x of -                       Left y  -> (y:ys, zs)-                       Right z -> (ys, z:zs)-                     where -                       (ys, zs) = mapEither f xs --}-mapErr :: (a -> Either e b) -> [a] -> Either [e] [b]-mapErr f xs = catEithers (map f xs)--catEithers :: [ Either a b ] -> Either [a] [b]-catEithers zs = case ls of-  [] -> Right rs-  _  -> Left ls-  where-    ls = [ l | Left  l <- zs ]-    rs = [ r | Right r <- zs ]---keyDiff :: (Eq k, Hashable k) => (a -> k) -> [a] -> [a] -> [a]-keyDiff f x1s x2s = M.elems (M.difference (m x1s) (m x2s))-  where-    m xs          = M.fromList [(f x, x) | x <- xs]--concatUnzip :: [([a], [b])] -> ([a], [b])-concatUnzip xsyss = (concatMap fst xsyss, concatMap snd xsyss)---sayReadFile :: FilePath -> IO String-sayReadFile f = do-  -- print ("SAY-READ-FILE: " ++ f)-  res <- readFile f-  Ex.evaluate res--lastModified :: FilePath -> IO (Maybe UTCTime)-lastModified f = do-  ex  <- doesFileExist f-  if ex then Just <$> getModificationTime f-        else return   Nothing---data Validate e a = Err e | Val a--instance Functor (Validate e) where-  fmap _ (Err e) = Err e-  fmap f (Val v)  = Val (f v)--instance Monoid e => Applicative (Validate e) where-  pure = Val-  (Err e1) <*> Err e2 = Err (e1 <> e2)-  (Err e1) <*> _      = Err e1-  _        <*> Err e2 = Err e2-  (Val f)  <*> Val x  = Val (f x)
− src/Language/Haskell/Liquid/Parse.hs 
@@ -1,1759 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE UndecidableInstances      #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE DeriveDataTypeable        #-}-{-# LANGUAGE ScopedTypeVariables       #-}--module Language.Haskell.Liquid.Parse-  ( hsSpecificationP-  , specSpecificationP-  , singleSpecP-  , BPspec-  , Pspec(..)-  , parseSymbolToLogic-  , parseTest'-  )-  where--import           Control.Arrow                          (second)-import           Control.Monad-import           Control.Monad.Identity-import qualified Data.Foldable                          as F-import           Data.String-import           Data.Void-import           Prelude                                hiding (error)-import           Text.Megaparsec                        hiding (ParseError)-import           Text.Megaparsec.Char-import qualified Data.HashMap.Strict                    as M-import qualified Data.HashSet                           as S-import           Data.Data-import qualified Data.Maybe                             as Mb -- (isNothing, fromMaybe)-import           Data.Char                              (isSpace, isAlphaNum)-import           Data.List                              (foldl', partition)-import           GHC                                    (ModuleName, mkModuleName)-import qualified Text.PrettyPrint.HughesPJ              as PJ-import           Text.PrettyPrint.HughesPJ.Compat       ((<+>))-import           Language.Fixpoint.Types                hiding (panic, SVar, DDecl, DataDecl, DataCtor (..), Error, R, Predicate)-import           Liquid.GHC.Misc       hiding (getSourcePos)-import           Language.Haskell.Liquid.Types--- import           Language.Haskell.Liquid.Types.Errors-import qualified Language.Fixpoint.Misc                 as Misc-import qualified Language.Haskell.Liquid.Misc           as Misc-import qualified Language.Haskell.Liquid.Measure        as Measure-import           Language.Fixpoint.Parse                hiding (defineP, dataDeclP, refBindP, refP, refDefP, parseTest')--import Control.Monad.State---- import Debug.Trace---- * Top-level parsing API---- | Used to parse .hs and .lhs files (via ApiAnnotations).-hsSpecificationP :: ModuleName-                 -> [(SourcePos, String)]-                 -> [BPspec]-                 -> Either [Error] (ModName, Measure.BareSpec)-hsSpecificationP modName specComments specQuotes =-  case go ([], []) initPStateWithList $ reverse specComments of-    ([], specs) ->-      Right $ mkSpec (ModName SrcImport modName) (specs ++ specQuotes)-    (errors, _) ->-      Left errors-  where-    go :: ([Error], [BPspec])   -- accumulated errors and parsed specs (in reverse order)-       -> PState                -- parser state (primarily infix operator priorities)-       -> [(SourcePos, String)] -- remaining unparsed spec comments-       -> ([Error], [BPspec])   -- final errors and parsed specs-    go (errors, specs) _ []-      = (reverse errors, reverse specs)-    go (errors, specs) pstate ((pos, specComment):xs)-      = -- 'specP' parses a single spec comment, i.e., a single LH directive-        -- we allow a "block" of specs now-        case parseWithError pstate (block specP) pos specComment of-          Left err'       -> go (parseErrorBundleToErrors err' ++ errors, specs) pstate xs-          Right (st,spec) -> go (errors,spec ++ specs) st xs--initPStateWithList :: PState-initPStateWithList-  = (initPState composeFun)-               { empList    = Just (EVar ("GHC.Types.[]" :: Symbol))-               , singList   = Just (\e -> EApp (EApp (EVar ("GHC.Types.:"  :: Symbol)) e) (EVar ("GHC.Types.[]" :: Symbol)))-               }-  where composeFun = Just $ EVar functionComposisionSymbol---- | Used to parse .spec files.-specSpecificationP  :: SourceName -> String -> Either (ParseErrorBundle String Void) (ModName, Measure.BareSpec)----------------------------------------------------------------------------specSpecificationP f s = mapRight snd $  parseWithError initPStateWithList (specificationP <* eof) (initialPos f) s---- | Parses a module spec.------ A module spec is a module only containing spec constructs for Liquid Haskell,--- and no "normal" Haskell code.----specificationP :: Parser (ModName, Measure.BareSpec)-specificationP = do-  reserved "module"-  reserved "spec"-  name   <- symbolP-  reserved "where"-  xs     <- block specP-  return $ mkSpec (ModName SpecImport $ mkModuleName $ symbolString name) xs---- debugP = grabs (specP <* whiteSpace)----------------------------------------------------------------------------------singleSpecP :: SourcePos -> String -> Either (ParseErrorBundle String Void) BPspec---------------------------------------------------------------------------------singleSpecP pos = mapRight snd . parseWithError initPStateWithList specP pos--mapRight :: (a -> b) -> Either l a -> Either l b-mapRight f (Right x) = Right $ f x-mapRight _ (Left x)  = Left x---- Note [PState in parser]------ In the original parsec parser, 'PState' did not contain the supply counter.--- The supply counter was separately initialised to 0 on every parser call, e.g.--- in 'parseWithError'.------ Now, the supply counter is a part of 'PState' and would normally be threaded--- between subsequent parsing calls within s single file, as for example issued--- by 'hsSpecificationP'. This threading seems correct to me (Andres). It sounds--- like we would want to have the same behaviour of the counter whether we are--- parsing several separate specs or a single combined spec.------ However, I am getting one test failure due to the threading change, namely--- Tests.Micro.class-laws-pos.FreeVar.hs, because in a unification call two--- variables occurring in a binding position do not match. This seems like a bug--- in the unifier. I'm nevertheless reproucing the "old" supply behaviour for--- now. This should be revisited later. TODO.---- | Entry point for parsers.------ Resets the supply in the given state to 0, see Note [PState in parser].--- Also resets the layout stack, as different spec comments in a file can--- start at different columns, and we do not want layout info to carry--- across different such comments.----parseWithError :: forall a. PState -> Parser a -> SourcePos -> String -> Either (ParseErrorBundle String Void) (PState, a)-parseWithError pstate parser p s =-  case snd (runIdentity (runParserT' (runStateT doParse pstate{supply = 0, layoutStack = Empty}) internalParserState)) of-    Left peb -> Left peb-    Right (r, st) -> Right (st, r)-  where-    doParse :: Parser a-    doParse = spaces *> parser <* eof-    internalParserState =-      State-        { stateInput = s-        , stateOffset = 0-        , statePosState =-          PosState-            { pstateInput = s-            , pstateOffset = 0-            , pstateSourcePos = p-            , pstateTabWidth = defaultTabWidth-            , pstateLinePrefix = ""-            }-        , stateParseErrors = []-        }---- | Function to test parsers interactively.-parseTest' :: Show a => Parser a -> String -> IO ()-parseTest' parser input =-  parseTest (evalStateT parser initPStateWithList) input--parseErrorBundleToErrors :: ParseErrorBundle String Void -> [Error]-parseErrorBundleToErrors (ParseErrorBundle errors posState) =-  let-    (es, _) = attachSourcePos errorOffset errors posState-  in-    parseErrorError <$> F.toList es------------------------------------------------------------------------------parseErrorError     :: (ParseError, SourcePos) -> Error-----------------------------------------------------------------------------parseErrorError (e, pos) = ErrParse sp msg e-  where-    sp              = sourcePosSrcSpan pos-    msg             = "Error Parsing Specification from:" <+> PJ.text (sourceName pos)------------------------------------------------------------------------------------- Parse to Logic  ------------------------------------------------------------------------------------------------------------------------------------------------parseSymbolToLogic :: SourceName -> String -> Either (ParseErrorBundle String Void) LogicMap-parseSymbolToLogic f = mapRight snd . parseWithError initPStateWithList toLogicP (initialPos f)--toLogicP :: Parser LogicMap-toLogicP-  = toLogicMap <$> many toLogicOneP--toLogicOneP :: Parser  (LocSymbol, [Symbol], Expr)-toLogicOneP-  = do reserved "define"-       (x:xs) <- some locSymbolP-       reservedOp "="-       e      <- exprP <|> predP-       return (x, val <$> xs, e)---defineP :: Parser (LocSymbol, Symbol)-defineP =-  (,) <$> locBinderP <* reservedOp "=" <*> binderP------------------------------------------------------------------------------------- | BareTypes ----------------------------------------------------------------------------------------------------------------------------------------------------{- | [NOTE:BARETYPE-PARSE] Fundamentally, a type is of the form--      comp -> comp -> ... -> comp--So--  bt = comp-     | comp '->' bt--  comp = circle-       | '(' bt ')'--  circle = the ground component of a baretype, sans parens or "->" at the top level--Each 'comp' should have a variable to refer to it,-either a parser-assigned one or given explicitly. e.g.--  xs : [Int]---}--data ParamComp = PC { _pci :: PcScope-                    , _pct :: BareType }-                    deriving (Show)--data PcScope = PcImplicit Symbol-             | PcExplicit Symbol-             | PcNoSymbol-             deriving (Eq,Show)--nullPC :: BareType -> ParamComp-nullPC bt = PC PcNoSymbol bt--btP :: Parser ParamComp-btP = do-  c@(PC sb _) <- compP-  case sb of-    PcNoSymbol   -> return c-    PcImplicit b -> parseFun c b-    PcExplicit b -> parseFun c b-  <?> "btP"-  where-    parseFun c@(PC sb t1) sym  =-      (do-            reservedOp "->"-            PC _ t2 <- btP-            return (PC sb (rFun sym t1 t2)))-        <|>-         (do-            reservedOp "~>"-            PC _ t2 <- btP-            return (PC sb (rImpF sym t1 t2)))-        <|>-         (do-            reservedOp "=>"-            PC _ t2 <- btP-            -- TODO:AZ return an error if s == PcExplicit-            return $ PC sb $ foldr (rFun dummySymbol) t2 (getClasses t1))-         <|>-          (do-             b <- locInfixSymbolP-             PC _ t2 <- btP-             return $ PC sb $ RApp (mkBTyCon b) [t1,t2] [] mempty)-         <|> return c---compP :: Parser ParamComp-compP = circleP <|> parens btP <?> "compP"--circleP :: Parser ParamComp-circleP-  =  nullPC <$> (reserved "forall" >> bareAllP)- <|> holePC                                 -- starts with '_'- <|> namedCircleP                           -- starts with lower- <|> bareTypeBracesP                        -- starts with '{'- <|> unnamedCircleP- <|> anglesCircleP                          -- starts with '<'- <|> nullPC <$> dummyP bbaseP               -- starts with '_' or '[' or '(' or lower or "'" or upper- <?> "circleP"--anglesCircleP :: Parser ParamComp-anglesCircleP-  = angles $ do-      PC sb t <- parens btP-      p       <- monoPredicateP-      return   $ PC sb (t `strengthen` MkUReft mempty p)--holePC :: Parser ParamComp-holePC = do-  h <- holeP-  b <- dummyBindP-  return (PC (PcImplicit b) h)--namedCircleP :: Parser ParamComp-namedCircleP = do-  lb <- locLowerIdP-  do _ <- reservedOp ":"-     let b = val lb-     PC (PcExplicit b) <$> bareArgP b-    <|> do-      b <- dummyBindP-      PC (PcImplicit b) <$> dummyP (lowerIdTail (val lb))--unnamedCircleP :: Parser ParamComp-unnamedCircleP = do-  lb <- located dummyBindP-  let b = val lb-  t1 <- bareArgP b-  return $ PC (PcImplicit b) t1---- ------------------------------------------------------------------------- | The top-level parser for "bare" refinement types. If refinements are--- not supplied, then the default "top" refinement is used.--bareTypeP :: Parser BareType-bareTypeP = do-  PC _ v <- btP-  return v--bareTypeBracesP :: Parser ParamComp-bareTypeBracesP = do-  t <-  try (braces (-            try (Right <$> constraintP)-           <|>-            (do-                    x  <- symbolP-                    _ <- reservedOp ":"-                    -- NOSUBST i  <- freshIntP-                    t  <- bbaseP-                    reservedOp "|"-                    ra <- refasHoleP-                    -- xi is a unique var based on the name in x.-                    -- su replaces any use of x in the balance of the expression with the unique val-                    -- NOSUBST let xi = intSymbol x i-                    -- NOSUBST let su v = if v == x then xi else v-                    return $ Left $ PC (PcExplicit x) $ t (Reft (x, ra)) )-            )) <|> try (helper holeOrPredsP) <|> helper predP-  case t of-    Left l -> return l-    Right ct -> do-      PC _sb tt <- btP-      return $ nullPC $ rrTy ct tt-  where-    holeOrPredsP-      = (reserved "_" >> return hole)-     <|> try (pAnd <$> brackets (sepBy predP semi))-    helper p = braces $ do-      t <- RHole . uTop . Reft . ("VV",) <$> p-      return (Left $ nullPC t)---bareArgP :: Symbol -> Parser BareType-bareArgP vvv-  =  refDefP vvv refasHoleP bbaseP    -- starts with '{'- <|> holeP                            -- starts with '_'- <|> dummyP bbaseP- <|> parens bareTypeP                 -- starts with '('-                                      -- starts with '_', '[', '(', lower, upper- <?> "bareArgP"--bareAtomP :: (Parser Expr -> Parser (Reft -> BareType) -> Parser BareType)-          -> Parser BareType-bareAtomP ref-  =  ref refasHoleP bbaseP- <|> holeP- <|> dummyP bbaseP- <?> "bareAtomP"--bareAtomBindP :: Parser BareType-bareAtomBindP = bareAtomP refBindBindP----- Either---  { x : t | ra }--- or---  { ra }-refBindBindP :: Parser Expr-             -> Parser (Reft -> BareType)-             -> Parser BareType-refBindBindP rp kindP'-  = braces (-      (do-              x  <- symbolP-              _ <- reservedOp ":"-              -- NOSUBST i  <- freshIntP-              t  <- kindP'-              reservedOp "|"-              ra <- rp-              -- xi is a unique var based on the name in x.-              -- su replaces any use of x in the balance of the expression with the unique val-              -- NOSUBST let xi = intSymbol x i-              -- NOSUBST let su v = if v == x then xi else v-              return $ {- substa su $ NOSUBST -} t (Reft (x, ra)) )-     <|> (RHole . uTop . Reft . ("VV",) <$> rp)-     <?> "refBindBindP"-   )---refDefP :: Symbol-        -> Parser Expr-        -> Parser (Reft -> BareType)-        -> Parser BareType-refDefP sym rp kindP' = braces $ do-  x       <- optBindP sym-  -- NOSUBST i       <- freshIntP-  t       <- try (kindP' <* reservedOp "|") <|> return (RHole . uTop) <?> "refDefP"-  ra      <- rp-  -- xi is a unique var based on the name in x.-  -- su replaces any use of x in the balance of the expression with the unique val-  -- NOSUBST let xi   = intSymbol x i-  -- NOSUBST let su v = if v == x then xi else v-  return   $ {- substa su $ NOSUBST -} t (Reft (x, ra))-       -- substa su . t . Reft . (x,) <$> (rp <* spaces))-      --  <|> ((RHole . uTop . Reft . ("VV",)) <$> (rp <* spaces))--refP :: Parser (Reft -> BareType) -> Parser BareType-refP = refBindBindP refaP--relrefaP :: Parser RelExpr -relrefaP =-  try (ERUnChecked <$> refaP <* reserved ":=>" <*> relrefaP)-    <|> try (ERChecked <$> refaP <* reserved "!=>" <*> relrefaP)-    <|> ERBasic <$> refaP---- "sym :" or return the devault sym-optBindP :: Symbol -> Parser Symbol-optBindP x = try bindP <|> return x--holeP :: Parser BareType-holeP    = reserved "_" >> return (RHole $ uTop $ Reft ("VV", hole))--holeRefP :: Parser (Reft -> BareType)-holeRefP = reserved "_" >> return (RHole . uTop)---- NOPROP refasHoleP :: Parser Expr--- NOPROP refasHoleP  = try refaP--- NOPROP          <|> (reserved "_" >> return hole)--refasHoleP :: Parser Expr-refasHoleP-  =  (reserved "_" >> return hole)- <|> refaP- <?> "refasHoleP"--bbaseP :: Parser (Reft -> BareType)-bbaseP-  =  holeRefP  -- Starts with '_'- <|> liftM2 bLst (brackets (optional bareTypeP)) predicatesP- <|> liftM2 bTup (parens $ sepBy (maybeBind bareTypeP) comma) predicatesP- <|> try parseHelper  -- starts with lower- <|> liftM4 bCon bTyConP predicatesP (many bareTyArgP) mmonoPredicateP-           -- starts with "'" or upper case char- <?> "bbaseP"- where-   parseHelper = do-     l <- lowerIdP-     lowerIdTail l--maybeBind :: Parser a -> Parser (Maybe Symbol, a)-maybeBind parser = do {bd <- maybeP' bbindP; ty <- parser ; return (bd, ty)}-  where-    maybeP' p = try (Just <$> p)-             <|> return Nothing--lowerIdTail :: Symbol -> Parser (Reft -> BareType)-lowerIdTail l =-          fmap (bAppTy (bTyVar l)) (some bareTyArgP)-      <|> fmap (bRVar (bTyVar l)) monoPredicateP--bTyConP :: Parser BTyCon-bTyConP-  =  (reservedOp "'" >> (mkPromotedBTyCon <$> locUpperIdP))- <|> mkBTyCon <$> locUpperIdP- <|> (reserved "*" >> return (mkBTyCon (dummyLoc $ symbol ("*" :: String))))- <?> "bTyConP"--mkPromotedBTyCon :: LocSymbol -> BTyCon-mkPromotedBTyCon x = BTyCon x False True -- (consSym '\'' <$> x) False True--classBTyConP :: Parser BTyCon-classBTyConP = mkClassBTyCon <$> locUpperIdP--mkClassBTyCon :: LocSymbol -> BTyCon-mkClassBTyCon x = BTyCon x True False--bbaseNoAppP :: Parser (Reft -> BareType)-bbaseNoAppP-  =  holeRefP- <|> liftM2 bLst (brackets (optional bareTypeP)) predicatesP- <|> liftM2 bTup (parens $ sepBy (maybeBind bareTypeP) comma) predicatesP- <|> try (liftM4 bCon bTyConP predicatesP (return []) (return mempty))- <|> liftM2 bRVar (bTyVar <$> lowerIdP) monoPredicateP- <?> "bbaseNoAppP"--bareTyArgP :: Parser BareType-bareTyArgP-  =  (RExprArg . fmap expr <$> locNatural)- <|> try (braces $ RExprArg <$> located exprP)- <|> try bareAtomNoAppP- <|> try (parens bareTypeP)- <?> "bareTyArgP"--bareAtomNoAppP :: Parser BareType-bareAtomNoAppP-  =  refP bbaseNoAppP- <|> dummyP bbaseNoAppP- <?> "bareAtomNoAppP"---constraintP :: Parser BareType-constraintP-  = do xts <- constraintEnvP-       t1  <- bareTypeP-       reservedOp "<:"-       fromRTypeRep . RTypeRep [] [] []-                                        [] [] []-                                        ((val . fst <$> xts) ++ [dummySymbol])-                                        (replicate (length xts + 1) defRFInfo)-                                        (replicate (length xts + 1) mempty)-                                        ((snd <$> xts) ++ [t1]) <$> bareTypeP--constraintEnvP :: Parser [(LocSymbol, BareType)]-constraintEnvP-   =  try (do xts <- sepBy tyBindNoLocP comma-              reservedOp "|-"-              return xts)-  <|> return []-  <?> "constraintEnvP"--rrTy :: Monoid r => RType c tv r -> RType c tv r -> RType c tv r-rrTy ct = RRTy (xts ++ [(dummySymbol, tr)]) mempty OCons-  where-    tr   = ty_res trep-    xts  = zip (ty_binds trep) (ty_args trep)-    trep = toRTypeRep ct----  "forall <z w> . TYPE"--- or---  "forall x y <z :: Nat, w :: Int> . TYPE"-bareAllP :: Parser BareType-bareAllP = do-  sp <- getSourcePos-  as  <- tyVarDefsP-  ps  <- angles inAngles-        <|> return []-  _ <- dot-  t <- bareTypeP-  return $ foldr rAllT (foldr (rAllP sp) t ps) (makeRTVar <$> as)-  where-    rAllT a t = RAllT a t mempty-    inAngles  = try  (sepBy  predVarDefP comma)---- See #1907 for why we have to alpha-rename pvar binders-rAllP :: SourcePos -> PVar BSort -> BareType -> BareType-rAllP sp p t = RAllP p' ({- F.tracepp "rAllP" $ -} substPVar p p' t)-  where-    p'  = p { pname = pn' }-    pn' = pname p `intSymbol` lin `intSymbol` col-    lin = unPos (sourceLine sp)-    col = unPos (sourceColumn  sp)--tyVarDefsP :: Parser [BTyVar]-tyVarDefsP-  = parens (many (bTyVar <$> tyKindVarIdP))- <|> many (bTyVar <$> tyVarIdP)- <?> "tyVarDefsP"--tyKindVarIdP :: Parser Symbol-tyKindVarIdP = do-   tv <- tyVarIdP-   do reservedOp "::"; _ <- kindP; return tv <|> return tv--kindP :: Parser BareType-kindP = bareAtomBindP--predVarDefsP :: Parser [PVar BSort]-predVarDefsP-  =  angles (sepBy1 predVarDefP comma)- <|> return []- <?> "predVarDefP"--predVarDefP :: Parser (PVar BSort)-predVarDefP-  = bPVar <$> predVarIdP <*> reservedOp "::" <*> propositionSortP--predVarIdP :: Parser Symbol-predVarIdP-  = symbol <$> tyVarIdP--bPVar :: Symbol -> t -> [(Symbol, t1)] -> PVar t1-bPVar p _ xts  = PV p (PVProp τ) dummySymbol τxs-  where-    (_, τ) = safeLast "bPVar last" xts-    τxs    = [ (τ', x, EVar x) | (x, τ') <- init xts ]-    safeLast _ xs@(_:_) = last xs-    safeLast msg _      = panic Nothing $ "safeLast with empty list " ++ msg--propositionSortP :: Parser [(Symbol, BSort)]-propositionSortP = map (Misc.mapSnd toRSort) <$> propositionTypeP--propositionTypeP :: Parser [(Symbol, BareType)]-propositionTypeP = either fail return . mkPropositionType =<< bareTypeP--mkPropositionType :: BareType -> Either String [(Symbol, BareType)]-mkPropositionType t-  | isOk      = Right $ zip (ty_binds tRep) (ty_args tRep)-  | otherwise = Left mkErr-  where-    isOk      = isPropBareType (ty_res tRep)-    tRep      = toRTypeRep t-    mkErr     = "Proposition type with non-Bool output: " ++ showpp t--xyP :: Parser x -> Parser a -> Parser y -> Parser (x, y)-xyP lP sepP rP =-  (,) <$> lP <* sepP <*> rP--dummyBindP :: Parser Symbol-dummyBindP = tempSymbol "db" <$> freshIntP--isPropBareType :: RType BTyCon t t1 -> Bool-isPropBareType  = isPrimBareType boolConName--isPrimBareType :: Symbol -> RType BTyCon t t1 -> Bool-isPrimBareType n (RApp tc [] _ _) = val (btc_tc tc) == n-isPrimBareType _ _                = False--getClasses :: RType BTyCon t t1 -> [RType BTyCon t t1]-getClasses (RApp tc ts ps r)-  | isTuple tc-  = concatMap getClasses ts-  | otherwise-  = [RApp (tc { btc_class = True }) ts ps r]-getClasses t-  = [t]--dummyP ::  Monad m => m (Reft -> b) -> m b-dummyP fm-  = fm `ap` return dummyReft--symsP :: (IsString tv, Monoid r)-      => Parser [(Symbol, RType c tv r)]-symsP-  = do reservedOp "\\"-       ss <- many symbolP-       reservedOp "->"-       return $ (, dummyRSort) <$> ss- <|> return []- <?> "symsP"--dummyRSort :: (IsString tv, Monoid r) => RType c tv r-dummyRSort-  = RVar "dummy" mempty--predicatesP :: (IsString tv, Monoid r)-            => Parser [Ref (RType c tv r) BareType]-predicatesP-   =  angles (sepBy1 predicate1P comma)-  <|> return []-  <?> "predicatesP"--predicate1P :: (IsString tv, Monoid r)-            => Parser (Ref (RType c tv r) BareType)-predicate1P-   =  try (RProp <$> symsP <*> refP bbaseP)-  <|> (rPropP [] . predUReft <$> monoPredicate1P)-  <|> braces (bRProp <$> symsP' <*> refaP)-  <?> "predicate1P"-   where-    symsP'       = do ss    <- symsP-                      fs    <- mapM refreshSym (fst <$> ss)-                      return $ zip ss fs-    refreshSym s = intSymbol s <$> freshIntP--mmonoPredicateP :: Parser Predicate-mmonoPredicateP-   = try (angles $ angles monoPredicate1P)-  <|> return mempty-  <?> "mmonoPredicateP"--monoPredicateP :: Parser Predicate-monoPredicateP-   = try (angles monoPredicate1P)-  <|> return mempty-  <?> "monoPredicateP"--monoPredicate1P :: Parser Predicate-monoPredicate1P-   =  (reserved "True" >> return mempty)-  <|> (pdVar <$> parens predVarUseP)-  <|> (pdVar <$>        predVarUseP)-  <?> "monoPredicate1P"--predVarUseP :: Parser (PVar String)-predVarUseP-  = do (p, xs) <- funArgsP-       return   $ PV p (PVProp dummyTyId) dummySymbol [ (dummyTyId, dummySymbol, x) | x <- xs ]--funArgsP :: Parser (Symbol, [Expr])-funArgsP  = try realP <|> empP <?> "funArgsP"-  where-    empP  = (,[]) <$> predVarIdP-    realP = do (EVar lp, xs) <- splitEApp <$> funAppP-               return (lp, xs)--boundP :: Parser (Bound (Located BareType) Expr)-boundP = do-  name   <- locUpperIdP-  reservedOp "="-  vs      <- bvsP-  params' <- many (parens tyBindP)-  args    <- bargsP-  Bound name vs params' args <$> predP- where-    bargsP =     ( do reservedOp "\\"-                      xs <- many (parens tyBindP)-                      reservedOp  "->"-                      return xs-                 )-           <|> return []-           <?> "bargsP"-    bvsP   =     ( do reserved "forall"-                      xs <- many (fmap bTyVar <$> locSymbolP)-                      reservedOp  "."-                      return (fmap (`RVar` mempty) <$> xs)-                 )-           <|> return []---infixGenP :: Assoc -> Parser ()-infixGenP assoc = do-   p <- maybeDigit-   s <- infixIdP -- TODO: Andres: infixIdP was defined as many (satisfy (`notElem` [' ', '.'])) which does not make sense at all-   -- Andres: going via Symbol seems unnecessary and wasteful here-   addOperatorP (FInfix p (symbolString s) Nothing assoc)--infixP :: Parser ()-infixP = infixGenP AssocLeft--infixlP :: Parser ()-infixlP = infixGenP AssocLeft--infixrP :: Parser ()-infixrP = infixGenP AssocRight--maybeDigit :: Parser (Maybe Int)-maybeDigit-  = optional (lexeme (read . pure <$> digitChar))-------------------------------------------------------------------------------------------------- Wrapped Constructors ------------------------------------------------------------------------------------------------------bRProp :: [((Symbol, τ), Symbol)]-       -> Expr -> Ref τ (RType c BTyVar (UReft Reft))-bRProp []    _    = panic Nothing "Parse.bRProp empty list"-bRProp syms' epr  = RProp ss $ bRVar (BTV dummyName) mempty r-  where-    (ss, (v, _))  = (init symsf, last symsf)-    symsf         = [(y, s) | ((_, s), y) <- syms']-    su            = mkSubst [(x, EVar y) | ((x, _), y) <- syms']-    r             = su `subst` Reft (v, epr)--bRVar :: tv -> Predicate -> r -> RType c tv (UReft r)-bRVar α p r = RVar α (MkUReft r p)--bLst :: Maybe (RType BTyCon tv (UReft r))-     -> [RTProp BTyCon tv (UReft r)]-     -> r-     -> RType BTyCon tv (UReft r)-bLst (Just t) rs r = RApp (mkBTyCon $ dummyLoc listConName) [t] rs (reftUReft r)-bLst Nothing  rs r = RApp (mkBTyCon $ dummyLoc listConName) []  rs (reftUReft r)--bTup :: (PPrint r, Reftable r, Reftable (RType BTyCon BTyVar (UReft r)), Reftable (RTProp BTyCon BTyVar (UReft r)))-     => [(Maybe Symbol, RType BTyCon BTyVar (UReft r))]-     -> [RTProp BTyCon BTyVar (UReft r)]-     -> r-     -> RType BTyCon BTyVar (UReft r)-bTup [(_,t)] _ r-  | isTauto r  = t-  | otherwise  = t `strengthen` reftUReft r-bTup ts rs r-  | all Mb.isNothing (fst <$> ts) || length ts < 2-  = RApp (mkBTyCon $ dummyLoc tupConName) (snd <$> ts) rs (reftUReft r)-  | otherwise-  = RApp (mkBTyCon $ dummyLoc tupConName) (top . snd <$> ts) rs' (reftUReft r)-  where-    args       = [(Mb.fromMaybe dummySymbol x, mapReft mempty t) | (x,t) <- ts]-    makeProp i = RProp (take i args) ((snd <$> ts)!!i)-    rs'        = makeProp <$> [1..(length ts-1)]----- Temporarily restore this hack benchmarks/esop2013-submission/Array.hs fails--- w/o it--- TODO RApp Int [] [p] true should be syntactically different than RApp Int [] [] p--- bCon b s [RProp _ (RHole r1)] [] _ r = RApp b [] [] $ r1 `meet` (MkUReft r mempty s)-bCon :: c-     -> [RTProp c tv (UReft r)]-     -> [RType c tv (UReft r)]-     -> Predicate-     -> r-     -> RType c tv (UReft r)-bCon b rs ts p r = RApp b ts rs $ MkUReft r p--bAppTy :: (Foldable t, PPrint r, Reftable r)-       => tv -> t (RType c tv (UReft r)) -> r -> RType c tv (UReft r)-bAppTy v ts r  = ts' `strengthen` reftUReft r-  where-    ts'        = foldl' (\a b -> RAppTy a b mempty) (RVar v mempty) ts--reftUReft :: r -> UReft r-reftUReft r    = MkUReft r mempty--predUReft :: Monoid r => Predicate -> UReft r-predUReft p    = MkUReft dummyReft p--dummyReft :: Monoid a => a-dummyReft      = mempty--dummyTyId :: IsString a => a-dummyTyId      = ""------------------------------------------------------------------------------------------------ Measures --------------------------------------------------------------------------------------------------type BPspec = Pspec LocBareType LocSymbol---- | The AST for a single parsed spec.-data Pspec ty ctor-  = Meas    (Measure ty ctor)                             -- ^ 'measure' definition-  | Assm    (LocSymbol, ty)                               -- ^ 'assume' signature (unchecked)-  | Asrt    (LocSymbol, ty)                               -- ^ 'assert' signature (checked)-  | LAsrt   (LocSymbol, ty)                               -- ^ 'local' assertion -- RJ: what is this-  | Asrts   ([LocSymbol], (ty, Maybe [Located Expr]))     -- ^ RJ: what is this-  | Impt    Symbol                                        -- ^ 'import' a specification module-  | DDecl   DataDecl                                      -- ^ refined 'data'    declaration -  | NTDecl  DataDecl                                      -- ^ refined 'newtype' declaration-  | Relational (LocSymbol, LocSymbol, ty, ty, RelExpr, RelExpr) -- ^ relational signature-  | AssmRel (LocSymbol, LocSymbol, ty, ty, RelExpr, RelExpr) -- ^ 'assume' relational signature-  | Class   (RClass ty)                                   -- ^ refined 'class' definition-  | CLaws   (RClass ty)                                   -- ^ 'class laws' definition-  | ILaws   (RILaws ty)-  | RInst   (RInstance ty)                                -- ^ refined 'instance' definition-  | Incl    FilePath                                      -- ^ 'include' a path -- TODO: deprecate -  | Invt    ty                                            -- ^ 'invariant' specification-  | Using  (ty, ty)                                       -- ^ 'using' declaration (for local invariants on a type) -  | Alias   (Located (RTAlias Symbol BareType))           -- ^ 'type' alias declaration  -  | EAlias  (Located (RTAlias Symbol Expr))               -- ^ 'predicate' alias declaration-  | Embed   (LocSymbol, FTycon, TCArgs)                   -- ^ 'embed' declaration-  | Qualif  Qualifier                                     -- ^ 'qualif' definition-  | Decr    (LocSymbol, [Int])                            -- ^ 'decreasing' annotation -- TODO: deprecate-  | LVars   LocSymbol                                     -- ^ 'lazyvar' annotation, defer checks to *use* sites-  | Lazy    LocSymbol                                     -- ^ 'lazy' annotation, skip termination check on binder-  | Fail    LocSymbol                                     -- ^ 'fail' annotation, the binder should be unsafe-  | Rewrite LocSymbol                                     -- ^ 'rewrite' annotation, the binder generates a rewrite rule-  | Rewritewith (LocSymbol, [LocSymbol])                  -- ^ 'rewritewith' annotation, the first binder is using the rewrite rules of the second list,-  | Insts   (LocSymbol, Maybe Int)                        -- ^ 'auto-inst' or 'ple' annotation; use ple locally on binder -  | HMeas   LocSymbol                                     -- ^ 'measure' annotation; lift Haskell binder as measure-  | Reflect LocSymbol                                     -- ^ 'reflect' annotation; reflect Haskell binder as function in logic-  | Inline  LocSymbol                                     -- ^ 'inline' annotation;  inline (non-recursive) binder as an alias-  | Ignore  LocSymbol                                     -- ^ 'ignore' annotation; skip all checks inside this binder-  | ASize   LocSymbol                                     -- ^ 'autosize' annotation; automatically generate size metric for this type-  | HBound  LocSymbol                                     -- ^ 'bound' annotation; lift Haskell binder as an abstract-refinement "bound"-  | PBound  (Bound ty Expr)                               -- ^ 'bound' definition-  | Pragma  (Located String)                              -- ^ 'LIQUID' pragma, used to save configuration options in source files-  | CMeas   (Measure ty ())                               -- ^ 'class measure' definition-  | IMeas   (Measure ty ctor)                             -- ^ 'instance measure' definition-  | Varia   (LocSymbol, [Variance])                       -- ^ 'variance' annotations, marking type constructor params as co-, contra-, or in-variant-  | DSize   ([ty], LocSymbol)                             -- ^ 'data size' annotations, generating fancy termination metric -  | BFix    ()                                            -- ^ fixity annotation-  | Define  (LocSymbol, Symbol)                           -- ^ 'define' annotation for specifying aliases c.f. `include-CoreToLogic.lg`-  deriving (Data, Show, Typeable)--instance (PPrint ty, PPrint ctor) => PPrint (Pspec ty ctor) where-  pprintTidy = ppPspec--splice :: PJ.Doc -> [PJ.Doc] -> PJ.Doc-splice sep = PJ.hcat . PJ.punctuate sep--ppAsserts :: (PPrint t) => Tidy -> [LocSymbol] -> t -> Maybe [Located Expr] -> PJ.Doc-ppAsserts k lxs t mles-  = PJ.hcat [ splice ", " (pprintTidy k <$> (val <$> lxs))-            , " :: "-            , pprintTidy k t-            , ppLes mles-            ]-  where-    ppLes Nothing    = ""-    ppLes (Just les) = "/" <+> pprintTidy k (val <$> les)--ppPspec :: (PPrint t, PPrint c) => Tidy -> Pspec t c -> PJ.Doc-ppPspec k (Meas m)-  = "measure" <+> pprintTidy k m-ppPspec k (Assm (lx, t))-  = "assume"  <+> pprintTidy k (val lx) <+> "::" <+> pprintTidy k t-ppPspec k (Asrt (lx, t))-  = "assert"  <+> pprintTidy k (val lx) <+> "::" <+> pprintTidy k t-ppPspec k (LAsrt (lx, t))-  = "local assert"  <+> pprintTidy k (val lx) <+> "::" <+> pprintTidy k t-ppPspec k (Asrts (lxs, (t, les)))-  = ppAsserts k lxs t les-ppPspec k (Impt  x)-  = "import" <+> pprintTidy k x-ppPspec k (DDecl d)-  = pprintTidy k d-ppPspec k (NTDecl d)-  = "newtype" <+> pprintTidy k d-ppPspec _ (Incl f)-  = "include" <+> "<" PJ.<> PJ.text f PJ.<> ">"-ppPspec k (Invt t)-  = "invariant" <+> pprintTidy k t-ppPspec k (Using (t1, t2))-  = "using" <+> pprintTidy k t1 <+> "as" <+> pprintTidy k t2-ppPspec k (Alias   (Loc _ _ rta))-  = "type" <+> pprintTidy k rta-ppPspec k (EAlias  (Loc _ _ rte))-  = "predicate" <+> pprintTidy k rte-ppPspec k (Embed   (lx, tc, NoArgs))-  = "embed" <+> pprintTidy k (val lx)         <+> "as" <+> pprintTidy k tc-ppPspec k (Embed   (lx, tc, WithArgs))-  = "embed" <+> pprintTidy k (val lx) <+> "*" <+> "as" <+> pprintTidy k tc-ppPspec k (Qualif  q)-  = pprintTidy k q-ppPspec k (Decr (lx, ns))-  = "decreasing" <+> pprintTidy k (val lx) <+> pprintTidy k ns-ppPspec k (LVars   lx)-  = "lazyvar" <+> pprintTidy k (val lx)-ppPspec k (Lazy   lx)-  = "lazy" <+> pprintTidy k (val lx)-ppPspec k (Rewrite   lx)-  = "rewrite" <+> pprintTidy k (val lx)-ppPspec k (Rewritewith (lx, lxs))-  = "rewriteWith" <+> pprintTidy k (val lx) <+> PJ.hsep (map go lxs)-  where-    go s = pprintTidy k $ val s-ppPspec k (Fail   lx)-  = "fail" <+> pprintTidy k (val lx)-ppPspec k (Insts   (lx, mbN))-  = "automatic-instances" <+> pprintTidy k (val lx) <+> maybe "" (("with" <+>) . pprintTidy k) mbN-ppPspec k (HMeas   lx)-  = "measure" <+> pprintTidy k (val lx)-ppPspec k (Reflect lx)-  = "reflect" <+> pprintTidy k (val lx)-ppPspec k (Inline  lx)-  = "inline" <+> pprintTidy k (val lx)-ppPspec k (Ignore  lx)-  = "ignore" <+> pprintTidy k (val lx)-ppPspec k (HBound  lx)-  = "bound" <+> pprintTidy k (val lx)-ppPspec k (ASize   lx)-  = "autosize" <+> pprintTidy k (val lx)-ppPspec k (PBound  bnd)-  = pprintTidy k bnd-ppPspec _ (Pragma  (Loc _ _ s))-  = "LIQUID" <+> PJ.text s-ppPspec k (CMeas   m)-  = "class measure" <+> pprintTidy k m-ppPspec k (IMeas   m)-  = "instance  measure" <+> pprintTidy k m-ppPspec k (Class   cls) -  = pprintTidy k cls -ppPspec k (CLaws  cls) -  = pprintTidy k cls -ppPspec k (RInst   inst) -  = pprintTidy k inst -ppPspec k (Varia   (lx, vs))  -  = "data variance" <+> pprintTidy k (val lx) <+> splice " " (pprintTidy k <$> vs) -ppPspec k (DSize   (ds, ss))  -  = "data size" <+> splice " " (pprintTidy k <$> ds) <+> pprintTidy k (val ss) -ppPspec _ (BFix    _)           -- -  = "fixity"-ppPspec k (Define  (lx, y))-  = "define" <+> pprintTidy k (val lx) <+> "=" <+> pprintTidy k y-ppPspec _ ILaws{}-  = "TBD-INSTANCE-LAWS"-ppPspec k (Relational (lxl, lxr, tl, tr, q, p))-  = "relational" -        <+> pprintTidy k (val lxl) <+> "::" <+> pprintTidy k tl <+> "~" -        <+> pprintTidy k (val lxr) <+> "::" <+> pprintTidy k tr <+> "|" -        <+> pprintTidy k q <+> "=>" <+> pprintTidy k p-ppPspec k (AssmRel (lxl, lxr, tl, tr, q, p))-  = "assume relational" -        <+> pprintTidy k (val lxl) <+> "::" <+> pprintTidy k tl <+> "~" -        <+> pprintTidy k (val lxr) <+> "::" <+> pprintTidy k tr <+> "|" -        <+> pprintTidy k q <+> "=>" <+> pprintTidy k p----- | For debugging-{-instance Show (Pspec a b) where-  show (Meas   _) = "Meas"-  show (Assm   _) = "Assm"-  show (Asrt   _) = "Asrt"-  show (LAsrt  _) = "LAsrt"-  show (Asrts  _) = "Asrts"-  show (Impt   _) = "Impt"-  shcl  _) = "DDecl"-  show (NTDecl _) = "NTDecl"-  show (Incl   _) = "Incl"-  show (Invt   _) = "Invt"-  show (Using _) = "Using"-  show (Alias  _) = "Alias"-  show (EAlias _) = "EAlias"-  show (Embed  _) = "Embed"-  show (Qualif _) = "Qualif"-  show (Decr   _) = "Decr"-  show (LVars  _) = "LVars"-  show (Lazy   _) = "Lazy"-  -- show (Axiom  _) = "Axiom"-  show (Insts  _) = "Insts"-  show (Reflect _) = "Reflect"-  show (HMeas  _) = "HMeas"-  show (HBound _) = "HBound"-  show (Inline _) = "Inline"-  show (Pragma _) = "Pragma"-  show (CMeas  _) = "CMeas"-  show (IMeas  _) = "IMeas"-  show (Class  _) = "Class"-  show (Varia  _) = "Varia"-  show (PBound _) = "Bound"-  show (RInst  _) = "RInst"-  show (ASize  _) = "ASize"-  show (BFix   _) = "BFix"-  show (Define _) = "Define"-}--qualifySpec :: Symbol -> Spec ty bndr -> Spec ty bndr-qualifySpec name sp = sp { sigs      = [ (tx x, t)  | (x, t)  <- sigs sp]-                         -- , asmSigs   = [ (tx x, t)  | (x, t)  <- asmSigs sp]-                         }-  where-    tx :: Located Symbol -> Located Symbol-    tx = fmap (qualifySymbol name)---- | Turns a list of parsed specifications into a "bare spec".------ This is primarily a rearrangement, as the bare spec is a record containing--- different kinds of spec directives in different positions, whereas the input--- list is a mixed list.------ In addition, the sigs of the spec (these are asserted/checked LH type--- signatues) are being qualified, i.e., the binding occurrences are prefixed--- with the module name.------ Andres: It is unfortunately totally unclear to me what the justification--- for the qualification is, and in particular, why it is being done for--- the asserted signatures only. My trust is not exactly improved by the--- commented out line in 'qualifySpec'.----mkSpec :: ModName -> [BPspec] -> (ModName, Measure.Spec LocBareType LocSymbol)-mkSpec name xs         = (name,) $ qualifySpec (symbol name) Measure.Spec-  { Measure.measures   = [m | Meas   m <- xs]-  , Measure.asmSigs    = [a | Assm   a <- xs]-  , Measure.sigs       = [a | Asrt   a <- xs]-                      ++ [(y, t) | Asrts (ys, (t, _)) <- xs, y <- ys]-  , Measure.localSigs  = []-  , Measure.reflSigs   = []-  , Measure.impSigs    = []-  , Measure.expSigs    = []-  , Measure.invariants = [(Nothing, t) | Invt   t <- xs]-  , Measure.ialiases   = [t | Using t <- xs]-  , Measure.imports    = [i | Impt   i <- xs]-  , Measure.dataDecls  = [d | DDecl  d <- xs] ++ [d | NTDecl d <- xs]-  , Measure.newtyDecls = [d | NTDecl d <- xs]-  , Measure.includes   = [q | Incl   q <- xs]-  , Measure.aliases    = [a | Alias  a <- xs]-  , Measure.ealiases   = [e | EAlias e <- xs]-  , Measure.embeds     = tceFromList [(c, (fTyconSort tc, a)) | Embed (c, tc, a) <- xs]-  , Measure.qualifiers = [q | Qualif q <- xs]-  , Measure.decr       = [d | Decr d   <- xs]-  , Measure.lvars      = S.fromList [d | LVars d  <- xs]-  , Measure.autois     = M.fromList [s | Insts s <- xs]-  , Measure.pragmas    = [s | Pragma s <- xs]-  , Measure.cmeasures  = [m | CMeas  m <- xs]-  , Measure.imeasures  = [m | IMeas  m <- xs]-  , Measure.classes    = [c | Class  c <- xs]-  , Measure.relational = [r | Relational r <- xs]-  , Measure.asmRel     = [r | AssmRel r <- xs]-  , Measure.claws      = [c | CLaws  c <- xs]-  , Measure.dvariance  = [v | Varia  v <- xs]-  , Measure.dsize      = [v | DSize  v <- xs]-  , Measure.rinstance  = [i | RInst  i <- xs]-  , Measure.ilaws      = [i | ILaws  i <- xs]-  , Measure.termexprs  = [(y, es) | Asrts (ys, (_, Just es)) <- xs, y <- ys]-  , Measure.lazy       = S.fromList [s | Lazy   s <- xs]-  , Measure.fails      = S.fromList [s | Fail   s <- xs]-  , Measure.rewrites   = S.fromList [s | Rewrite s <- xs]-  , Measure.rewriteWith = M.fromList [s | Rewritewith s <- xs]-  , Measure.bounds     = M.fromList [(bname i, i) | PBound i <- xs]-  , Measure.reflects   = S.fromList [s | Reflect s <- xs]-  , Measure.hmeas      = S.fromList [s | HMeas  s <- xs]-  , Measure.inlines    = S.fromList [s | Inline s <- xs]-  , Measure.ignores    = S.fromList [s | Ignore s <- xs]-  , Measure.autosize   = S.fromList [s | ASize  s <- xs]-  , Measure.hbounds    = S.fromList [s | HBound s <- xs]-  , Measure.defs       = M.fromList [d | Define d <- xs]-  , Measure.axeqs      = []-  }---- | Parse a single top level liquid specification-specP :: Parser BPspec-specP-  =     fallbackSpecP "assume"      -    ((reserved "relational" >>  fmap AssmRel relationalP)-        <|>                           fmap Assm   tyBindP  )-    <|> fallbackSpecP "assert"      (fmap Asrt    tyBindP  )-    <|> fallbackSpecP "autosize"    (fmap ASize   asizeP   )-    <|> (reserved "local"         >> fmap LAsrt   tyBindP  )--    -- TODO: These next two are synonyms, kill one-    <|> fallbackSpecP "axiomatize"  (fmap Reflect axiomP   )-    <|> fallbackSpecP "reflect"     (fmap Reflect axiomP   )--    <|> fallbackSpecP "measure"    hmeasureP--    <|> fallbackSpecP "define"      (fmap Define  defineP  )-    <|> (reserved "infixl"        >> fmap BFix    infixlP  )-    <|> (reserved "infixr"        >> fmap BFix    infixrP  )-    <|> (reserved "infix"         >> fmap BFix    infixP   )-    <|> fallbackSpecP "inline"      (fmap Inline  inlineP  )-    <|> fallbackSpecP "ignore"      (fmap Ignore  inlineP  )--    <|> fallbackSpecP "bound"       (fmap PBound  boundP-                                 <|> fmap HBound  hboundP  )-    <|> (reserved "class"-         >> ((reserved "measure"  >> fmap CMeas  cMeasureP )-         <|> (reserved "laws"     >> fmap CLaws  classP)-         <|> fmap Class  classP                            ))-    <|> (reserved "instance"-         >> ((reserved "measure"  >> fmap IMeas  iMeasureP )-         <|> (reserved "laws"     >> fmap ILaws instanceLawP)-         <|> fmap RInst  instanceP ))--    <|> (reserved "import"        >> fmap Impt   symbolP   )--    <|> (reserved "data"-        >> ((reserved "variance"  >> fmap Varia  datavarianceP)-        <|> (reserved "size"      >> fmap DSize  dsizeP)-        <|> fmap DDecl  dataDeclP ))-    <|> (reserved "newtype"       >> fmap NTDecl dataDeclP )-    <|> (reserved "relational"    >> fmap Relational relationalP )-    <|> (reserved "include"       >> fmap Incl   filePathP )-    <|> fallbackSpecP "invariant"   (fmap Invt   invariantP)-    <|> (reserved "using"          >> fmap Using invaliasP )-    <|> (reserved "type"          >> fmap Alias  aliasP    )--    -- TODO: Next two are basically synonyms-    <|> fallbackSpecP "predicate"   (fmap EAlias ealiasP   )-    <|> fallbackSpecP "expression"  (fmap EAlias ealiasP   )--    <|> fallbackSpecP "embed"       (fmap Embed  embedP    )-    <|> fallbackSpecP "qualif"      (fmap Qualif (qualifierP sortP))-    <|> (reserved "decrease"      >> fmap Decr   decreaseP )-    <|> (reserved "lazyvar"       >> fmap LVars  lazyVarP  )--    <|> (reserved "lazy"          >> fmap Lazy   lazyVarP  )-    <|> (reserved "rewrite"       >> fmap Rewrite   rewriteVarP )-    <|> (reserved "rewriteWith"   >> fmap Rewritewith   rewriteWithP )-    <|> (reserved "fail"          >> fmap Fail   failVarP  )-    <|> (reserved "ple"           >> fmap Insts autoinstP  )-    <|> (reserved "automatic-instances" >> fmap Insts autoinstP  )-    <|> (reserved "LIQUID"        >> fmap Pragma pragmaP   )-    <|> (reserved "liquid"        >> fmap Pragma pragmaP   )-    <|> {- DEFAULT -}                fmap Asrts  tyBindsP-    <?> "specP"---- | Try the given parser on the tail after matching the reserved word, and if--- it fails fall back to parsing it as a haskell signature for a function with--- the same name.-fallbackSpecP :: String -> Parser BPspec -> Parser BPspec-fallbackSpecP kw p = do-  (Loc l1 l2 _) <- locReserved kw-  p <|> fmap Asrts (tyBindsRemP (Loc l1 l2 (symbol kw)) )---- | Same as tyBindsP, except the single initial symbol has already been matched-tyBindsRemP :: LocSymbol -> Parser ([LocSymbol], (Located BareType, Maybe [Located Expr]))-tyBindsRemP sym = do-  reservedOp "::"-  tb <- termBareTypeP-  return ([sym],tb)--pragmaP :: Parser (Located String)-pragmaP = locStringLiteral--autoinstP :: Parser (LocSymbol, Maybe Int)-autoinstP = do x <- locBinderP-               i <- optional (reserved "with" >> natural)-               return (x, fromIntegral <$> i)--lazyVarP :: Parser LocSymbol-lazyVarP = locBinderP---rewriteVarP :: Parser LocSymbol-rewriteVarP = locBinderP--rewriteWithP :: Parser (LocSymbol, [LocSymbol])-rewriteWithP = (,) <$> locBinderP <*> brackets (sepBy1 locBinderP comma)--failVarP :: Parser LocSymbol-failVarP = locBinderP--axiomP :: Parser LocSymbol-axiomP = locBinderP--hboundP :: Parser LocSymbol-hboundP = locBinderP--inlineP :: Parser LocSymbol-inlineP = locBinderP--asizeP :: Parser LocSymbol-asizeP = locBinderP--decreaseP :: Parser (LocSymbol, [Int])-decreaseP = Misc.mapSnd f <$> liftM2 (,) locBinderP (many natural)-  where-    f     = ((\n -> fromInteger n - 1) <$>)--filePathP     :: Parser FilePath-filePathP     = angles $ some pathCharP-  where-    pathCharP :: Parser Char-    pathCharP = choice $ char <$> pathChars--    pathChars :: [Char]-    pathChars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['.', '/']--datavarianceP :: Parser (Located Symbol, [Variance])-datavarianceP = liftM2 (,) locUpperIdP (many varianceP)--dsizeP :: Parser ([Located BareType], Located Symbol)-dsizeP = liftM2 (,) (parens $ sepBy (located genBareTypeP) comma) locBinderP---varianceP :: Parser Variance-varianceP = (reserved "bivariant"     >> return Bivariant)-        <|> (reserved "invariant"     >> return Invariant)-        <|> (reserved "covariant"     >> return Covariant)-        <|> (reserved "contravariant" >> return Contravariant)-        <?> "Invalid variance annotation\t Use one of bivariant, invariant, covariant, contravariant"--tyBindsP :: Parser ([LocSymbol], (Located BareType, Maybe [Located Expr]))-tyBindsP =-  xyP (sepBy1 locBinderP comma) (reservedOp "::") termBareTypeP--tyBindNoLocP :: Parser (LocSymbol, BareType)-tyBindNoLocP = second val <$> tyBindP---- | Parses a type signature as it occurs in "assume" and "assert" directives.-tyBindP :: Parser (LocSymbol, Located BareType)-tyBindP =-  (,) <$> locBinderP <* reservedOp "::" <*> located genBareTypeP--termBareTypeP :: Parser (Located BareType, Maybe [Located Expr])-termBareTypeP = do-  t <- located genBareTypeP-  termTypeP t <|> return (t, Nothing)--termTypeP :: Located BareType ->Parser (Located BareType, Maybe [Located Expr])-termTypeP t-  = do-       reservedOp "/"-       es <- brackets $ sepBy (located exprP) comma-       return (t, Just es)---- ---------------------------------------invariantP :: Parser (Located BareType)-invariantP = located genBareTypeP--invaliasP :: Parser (Located BareType, Located BareType)-invaliasP-  = do t  <- located genBareTypeP-       reserved "as"-       ta <- located genBareTypeP-       return (t, ta)--genBareTypeP :: Parser BareType-genBareTypeP = bareTypeP--embedP :: Parser (Located Symbol, FTycon, TCArgs)-embedP = do-  x <- locUpperIdP-  a <- try (reserved "*" >> return WithArgs) <|> return NoArgs -- TODO: reserved "*" looks suspicious-  _ <- reserved "as"-  t <- fTyConP-  return (x, t, a)-  --  = xyP locUpperIdP symbolTCArgs (reserved "as") fTyConP---aliasP :: Parser (Located (RTAlias Symbol BareType))-aliasP  = rtAliasP id     bareTypeP <?> "aliasP"--ealiasP :: Parser (Located (RTAlias Symbol Expr))-ealiasP = try (rtAliasP symbol predP)-      <|> rtAliasP symbol exprP-      <?> "ealiasP"---- | Parser for a LH type synonym.-rtAliasP :: (Symbol -> tv) -> Parser ty -> Parser (Located (RTAlias tv ty))-rtAliasP f bodyP-  = do pos  <- getSourcePos-       name <- upperIdP-       args <- many aliasIdP-       reservedOp "="-       body <- bodyP-       posE <- getSourcePos-       let (tArgs, vArgs) = partition (isSmall . headSym) args-       return $ Loc pos posE (RTA name (f <$> tArgs) vArgs body)--hmeasureP :: Parser BPspec-hmeasureP = do-  setLayout-  b <- locBinderP-  (do reservedOp "::"-      ty <- located genBareTypeP-      popLayout >> popLayout-      eqns <- block $ try $ measureDefP (rawBodyP <|> tyBodyP ty)-      return (Meas $ Measure.mkM b ty eqns MsMeasure mempty))-    <|> (popLayout >> popLayout >> return (HMeas b))--measureP :: Parser (Measure (Located BareType) LocSymbol)-measureP = do-  (x, ty) <- indentedLine tyBindP-  _ <- optional semi-  eqns    <- block $ measureDefP (rawBodyP <|> tyBodyP ty)-  return   $ Measure.mkM x ty eqns MsMeasure mempty---- | class measure-cMeasureP :: Parser (Measure (Located BareType) ())-cMeasureP-  = do (x, ty) <- tyBindP-       return $ Measure.mkM x ty [] MsClass mempty--iMeasureP :: Parser (Measure (Located BareType) LocSymbol)-iMeasureP = measureP---oneClassArg :: Parser [Located BareType]-oneClassArg-  = sing <$> located (rit <$> classBTyConP <*> (map val <$> classParams))-  where-    rit t as    = RApp t ((`RVar` mempty) <$> as) [] mempty-    classParams =  (reserved "where" >> return [])-               <|> ((:) <$> (fmap bTyVar <$> locLowerIdP) <*> classParams)-    sing x      = [x]---superP :: Parser (Located BareType)-superP = located (toRCls <$> bareAtomBindP)-  where toRCls x = x--instanceLawP :: Parser (RILaws (Located BareType))-instanceLawP-  = do l1   <- getSourcePos-       sups <- supersP-       c    <- classBTyConP-       tvs  <- manyTill (located bareTypeP) (try $ reserved "where")-       ms   <- block eqBinderP-       l2   <- getSourcePos-       return $ RIL c sups tvs ms (Loc l1 l2 ())-  where-    supersP  = try ((parens (superP `sepBy1` comma) <|> fmap pure superP)-                       <* reservedOp "=>")-               <|> return []--    eqBinderP = xyP xP (reservedOp "=") xP--    xP = locBinderP--instanceP :: Parser (RInstance (Located BareType))-instanceP-  = do _    <- supersP-       c    <- classBTyConP-       tvs  <- try oneClassArg <|> manyTill iargsP (try $ reserved "where")-       ms   <- block riMethodSigP-       return $ RI c tvs ms-  where-    supersP  = try ((parens (superP `sepBy1` comma) <|> fmap pure superP)-                       <* reservedOp "=>")-               <|> return []--    iargsP   =   (mkVar . bTyVar <$> tyVarIdP)-            <|> parens (located bareTypeP)---    mkVar v  = dummyLoc $ RVar v mempty---riMethodSigP :: Parser (LocSymbol, RISig (Located BareType))-riMethodSigP-  = try (do reserved "assume"-            (x, t) <- tyBindP-            return (x, RIAssumed t) )- <|> do (x, t) <- tyBindP-        return (x, RISig t)- <?> "riMethodSigP"--classP :: Parser (RClass (Located BareType))-classP-  = do sups <- supersP-       c    <- classBTyConP-       tvs  <- manyTill (bTyVar <$> tyVarIdP) (try $ reserved "where")-       ms   <- block tyBindP -- <|> sepBy tyBindP semi-       return $ RClass c sups tvs ms-  where-    supersP  = try ((parens (superP `sepBy1` comma) <|> fmap pure superP)-                       <* reservedOp "=>")-               <|> return []--rawBodyP :: Parser Body-rawBodyP-  = braces $ do-      v <- symbolP-      reservedOp "|"-      R v <$> predP--tyBodyP :: Located BareType -> Parser Body-tyBodyP ty-  = case outTy (val ty) of-      Just bt | isPropBareType bt-                -> P <$> predP-      _         -> E <$> exprP-    where outTy (RAllT _ t _)  = outTy t-          outTy (RAllP _ t)    = outTy t-          outTy (RImpF _ _ _ t _)= Just t-          outTy (RFun _ _ _ t _) = Just t-          outTy _              = Nothing--locUpperOrInfixIdP :: Parser (Located Symbol)-locUpperOrInfixIdP = locUpperIdP' <|> locInfixCondIdP--locBinderP :: Parser (Located Symbol)-locBinderP =-  located binderP -- TODO---- | LHS of the thing being defined------ TODO, Andres: this is still very broken----{--binderP :: Parser Symbol-binderP    = pwr    <$> parens (idP bad)-         <|> symbol <$> idP badc-  where-    idP p  = takeWhile1P Nothing (not . p)-    badc c = (c == ':') || (c == ',') || bad c-    bad c  = isSpace c || c `elem` ("(,)[]" :: String)-    pwr s  = symbol $ "(" `mappend` s `mappend` ")"--}-binderP :: Parser Symbol-binderP =-      symbol . (\ x -> "(" <> x <> ")") . symbolText <$> parens infixBinderIdP-  <|> binderIdP-  -- Note: It is important that we do *not* use the LH/fixpoint reserved words here,-  -- because, for example, we must be able to use "assert" as an identifier.-  ---  -- TODO, Andres: I have no idea why we make the parens part of the symbol here.-  -- But I'm reproducing this behaviour for now, as it is backed up via a few tests.--measureDefP :: Parser Body -> Parser (Def (Located BareType) LocSymbol)-measureDefP bodyP-  = do mname   <- locSymbolP-       (c, xs) <- measurePatP-       reservedOp "="-       body    <- bodyP-       let xs'  = symbol . val <$> xs-       return   $ Def mname (symbol <$> c) Nothing ((, Nothing) <$> xs') body--measurePatP :: Parser (LocSymbol, [LocSymbol])-measurePatP-  =  parens (try conPatP <|> try consPatP <|> nilPatP <|> tupPatP)- <|> nullaryConPatP- <?> "measurePatP"--tupPatP :: Parser (Located Symbol, [Located Symbol])-tupPatP  = mkTupPat  <$> sepBy1 locLowerIdP comma--conPatP :: Parser (Located Symbol, [Located Symbol])-conPatP  = (,)       <$> dataConNameP <*> many locLowerIdP--consPatP :: IsString a-         => Parser (Located a, [Located Symbol])-consPatP = mkConsPat <$> locLowerIdP  <*> reservedOp ":" <*> locLowerIdP--nilPatP :: IsString a-        => Parser (Located a, [t])-nilPatP  = mkNilPat  <$> brackets (pure ())--nullaryConPatP :: Parser (Located Symbol, [t])-nullaryConPatP = nilPatP <|> ((,[]) <$> dataConNameP)-                 <?> "nullaryConPatP"--mkTupPat :: Foldable t => t a -> (Located Symbol, t a)-mkTupPat zs     = (tupDataCon (length zs), zs)--mkNilPat :: IsString a => t -> (Located a, [t1])-mkNilPat _      = (dummyLoc "[]", []    )--mkConsPat :: IsString a => t1 -> t -> t1 -> (Located a, [t1])-mkConsPat x _ y = (dummyLoc ":" , [x, y])--tupDataCon :: Int -> Located Symbol-tupDataCon n    = dummyLoc $ symbol $ "(" <> replicate (n - 1) ',' <> ")"-------------------------------------------------------------------------------------------------------------------- Predicates --------------------------------------------------------------------------------------------------------------------dataConFieldsP :: Parser [(Symbol, BareType)]-dataConFieldsP-   =  explicitCommaBlock predTypeDDP -- braces (sepBy predTypeDDP comma)-  <|> many dataConFieldP-  <?> "dataConFieldP"--dataConFieldP :: Parser (Symbol, BareType)-dataConFieldP-   =  parens (try predTypeDDP <|> dbTypeP)-  <|> dbTyArgP -- unparenthesised constructor fields must be "atomic"-  <?> "dataConFieldP"-  where-    dbTypeP = (,) <$> dummyBindP <*> bareTypeP-    dbTyArgP = (,) <$> dummyBindP <*> bareTyArgP--predTypeDDP :: Parser (Symbol, BareType)-predTypeDDP = (,) <$> bbindP <*> bareTypeP--bbindP   :: Parser Symbol-bbindP   = lowerIdP <* reservedOp "::"--dataConP :: [Symbol] -> Parser DataCtor-dataConP as = do-  x   <- dataConNameP-  xts <- dataConFieldsP-  return $ DataCtor x as [] xts Nothing--adtDataConP :: [Symbol] -> Parser DataCtor-adtDataConP as = do-  x     <- dataConNameP-  reservedOp "::"-  tr    <- toRTypeRep <$> bareTypeP-  return $ DataCtor x (tRepVars as tr) [] (tRepFields tr) (Just $ ty_res tr)--tRepVars :: Symbolic a => [Symbol] -> RTypeRep c a r -> [Symbol]-tRepVars as tr = case fst <$> ty_vars tr of-  [] -> as-  vs -> symbol . ty_var_value <$> vs--tRepFields :: RTypeRep c tv r -> [(Symbol, RType c tv r)]-tRepFields tr = zip (ty_binds tr) (ty_args tr)---- TODO: fix Located-dataConNameP :: Parser (Located Symbol)-dataConNameP-  =  located- (   try upperIdP- <|> pwr <$> parens (idP bad)- <?> "dataConNameP"- )-  where-     idP p  = takeWhile1P Nothing (not . p)-     bad c  = isSpace c || c `elem` ("(,)" :: String)-     pwr s  = symbol $ "(" <> s <> ")"--dataSizeP :: Parser (Maybe SizeFun)-dataSizeP-  = brackets (Just . SymSizeFun <$> locLowerIdP)-  <|> return Nothing--relationalP :: Parser (LocSymbol, LocSymbol, LocBareType, LocBareType, RelExpr, RelExpr)-relationalP = do -   x <- locBinderP-   reserved "~"-   y <- locBinderP-   reserved "::"-   braces $ do -    tx <- located genBareTypeP-    reserved "~"-    ty <- located genBareTypeP-    reserved "|"-    assm <- try (relrefaP <* reserved "|-") <|> return (ERBasic PTrue)-    ex <- relrefaP-    return (x,y,tx,ty,assm,ex)--dataDeclP :: Parser DataDecl-dataDeclP = do-  pos <- getSourcePos-  x   <- locUpperOrInfixIdP-  fsize <- dataSizeP-  dataDeclBodyP pos x fsize <|> return (emptyDecl x pos fsize)--emptyDecl :: LocSymbol -> SourcePos -> Maybe SizeFun -> DataDecl-emptyDecl x pos fsize@(Just _)-  = DataDecl (DnName x) [] [] Nothing pos fsize Nothing DataUser-emptyDecl x pos _-  = uError (ErrBadData (sourcePosSrcSpan pos) (pprint (val x)) msg)-  where-    msg = "You should specify either a default [size] or one or more fields in the data declaration"--dataDeclBodyP :: SourcePos -> LocSymbol -> Maybe SizeFun -> Parser DataDecl-dataDeclBodyP pos x fsize = do-  vanilla    <- null <$> many locUpperIdP-  as         <- many noWhere -- TODO: check this again-  ps         <- predVarDefsP-  (pTy, dcs) <- dataCtorsP as-  let dn      = dataDeclName pos x vanilla dcs-  return      $ DataDecl dn as ps (Just dcs) pos fsize pTy DataUser--dataDeclName :: SourcePos -> LocSymbol -> Bool -> [DataCtor] -> DataName-dataDeclName _ x True  _     = DnName x               -- vanilla data    declaration-dataDeclName _ _ False (d:_) = DnCon  (dcName d)      -- family instance declaration-dataDeclName p x _  _        = uError (ErrBadData (sourcePosSrcSpan p) (pprint (val x)) msg)-  where-    msg                  = "You should specify at least one data constructor for a family instance"---- | Parse the constructors of a datatype, allowing both classic and GADT-style syntax.------ Note that as of 2020-10-14, we changed the syntax of GADT-style datatype declarations--- to match Haskell more closely and parse all constructors in a layout-sensitive block,--- whereas before we required them to be separated by @|@.----dataCtorsP :: [Symbol] -> Parser (Maybe BareType, [DataCtor])-dataCtorsP as = do-  (pTy, dcs) <-     (reservedOp "="     >> ((Nothing, ) <$>                 sepBy (dataConP    as) (reservedOp "|")))-                <|> (reserved   "where" >> ((Nothing, ) <$>                 block (adtDataConP as)                 ))-                <|>                        ((,)         <$> dataPropTyP <*> block (adtDataConP as)                  )-  return (pTy, Misc.sortOn (val . dcName) dcs)--noWhere :: Parser Symbol-noWhere =-  try $ do-  s <- tyVarIdP-  guard (s /= "where")-  return s--dataPropTyP :: Parser (Maybe BareType)-dataPropTyP = Just <$> between (reservedOp "::") (reserved "where") bareTypeP-------------------------------------------------------------------------- | Parsing Qualifiers ---------------------------------------------------------------------------------------------------------------------fTyConP :: Parser FTycon-fTyConP-  =   (reserved "int"     >> return intFTyCon)-  <|> (reserved "Integer" >> return intFTyCon)-  <|> (reserved "Int"     >> return intFTyCon)-  <|> (reserved "real"    >> return realFTyCon)-  <|> (reserved "bool"    >> return boolFTyCon)-  <|> (symbolFTycon      <$> locUpperIdP)-  <?> "fTyConP"-------------------------------------------------------------------------- Identifiers -------------------------------------------------------------------------------------------------------------------------------- Andres, TODO: Fix all the rules for identifiers. This was limited to all lowercase letters before.-tyVarIdR :: Parser Symbol-tyVarIdR =-  condIdR (lowerChar <|> char '_') isAlphaNum isNotReserved "unexpected reserved name"--tyVarIdP :: Parser Symbol-tyVarIdP =-  lexeme tyVarIdR--aliasIdR :: Parser Symbol-aliasIdR =-  condIdR (letterChar <|> char '_') isAlphaNum (const True) "unexpected"--aliasIdP :: Parser Symbol-aliasIdP =-  lexeme aliasIdR---- | Andres, TODO: This must be liberal with respect to reserved words (LH reserved words are--- not Haskell reserved words, and we want to redefine all sorts of internal stuff).------ Also, this currently accepts qualified names by allowing '.' ...--- Moreover, it seems that it is currently allowed to use qualified symbolic names in--- unparenthesised form. Oh, the parser is also used for reflect, where apparently--- symbolic names appear in unqualified and unparenthesised form.--- Furthermore, : is explicitly excluded because a : can directly, without whitespace,--- follow a binder ...----binderIdR :: Parser Symbol-binderIdR =-  condIdR (letterChar <|> char '_' <|> satisfy isHaskellOpStartChar) (\ c -> isAlphaNum c || isHaskellOpStartChar c || c `elem` ("_'" :: String)) (const True) "unexpected"--binderIdP :: Parser Symbol-binderIdP =-  lexeme binderIdR--infixBinderIdR :: Parser Symbol-infixBinderIdR =-  condIdR (letterChar <|> char '_' <|> satisfy isHaskellOpChar) (\ c -> isAlphaNum c || isHaskellOpChar c || c `elem` ("_'" :: String)) (const True) "unexpected"--infixBinderIdP :: Parser Symbol-infixBinderIdP =-  lexeme infixBinderIdR--upperIdR' :: Parser Symbol-upperIdR' =-  condIdR upperChar (\ c -> isAlphaNum c || c == '\'') (const True) "unexpected"--locUpperIdP' :: Parser (Located Symbol)-locUpperIdP' =-  locLexeme upperIdR'---- Andres, TODO: This used to force a colon at the end. Also, it used to not--- allow colons in the middle. Finally, it should probably exclude all reserved--- operators. I'm just excluding :: because I'm pretty sure that would be--- undesired.----infixCondIdR :: Parser Symbol-infixCondIdR =-  condIdR (char ':') isHaskellOpChar (/= "::") "unexpected double colon"---- Andres, TODO: This used to be completely ad-hoc. It's still not good though.-infixIdR :: Parser Symbol-infixIdR =-  condIdR (satisfy isHaskellOpChar) isHaskellOpChar (/= "::") "unexpected double colon"--infixIdP :: Parser Symbol-infixIdP =-  lexeme infixIdR--{--infixVarIdR :: Parser Symbol-infixVarIdR =-  condIdR (satisfy isHaskellOpStartChar) isHaskellOpChar (const True)--infixVarIdP :: Parser Symbol-infixVarIdP =-  lexeme infixVarIdR--}--isHaskellOpChar :: Char -> Bool-isHaskellOpChar c-  = c `elem` (":!#$%&*+./<=>?@\\^|~-" :: String)--isHaskellOpStartChar :: Char -> Bool-isHaskellOpStartChar c-  = c `elem` ("!#$%&*+./<=>?@\\^|~-" :: String)--locInfixCondIdP :: Parser (Located Symbol)-locInfixCondIdP =-  locLexeme infixCondIdR
− src/Language/Haskell/Liquid/Synthesize.hs 
@@ -1,180 +0,0 @@-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE FlexibleContexts #-}--module Language.Haskell.Liquid.Synthesize (-    synthesize-  ) where--import           Language.Haskell.Liquid.Types-import           Language.Haskell.Liquid.Constraint.Types-import           Language.Haskell.Liquid.Constraint.Generate-import qualified Language.Haskell.Liquid.Types.RefType as R-import           Language.Haskell.Liquid.Synthesize.Termination-import           Language.Haskell.Liquid.Synthesize.Generate-import           Language.Haskell.Liquid.Synthesize.GHC hiding (SSEnv)-import           Language.Haskell.Liquid.Synthesize.Monad-import           Language.Haskell.Liquid.Synthesize.Misc hiding (notrace)-import           Language.Haskell.Liquid.Constraint.Fresh (trueTy)-import qualified Language.Fixpoint.Smt.Interface as SMT-import           Language.Fixpoint.Types hiding (SEnv, SVar, Error)-import qualified Language.Fixpoint.Types        as F-import qualified Language.Fixpoint.Types.Config as F-import           Language.Haskell.Liquid.Synthesize.Env-import           Liquid.GHC.API as GHC hiding (text, ($+$))--import           Text.PrettyPrint.HughesPJ (text, ($+$))-import           Control.Monad.State.Lazy-import qualified Data.HashMap.Strict as M-import           Data.Maybe--synthesize :: FilePath -> F.Config -> CGInfo -> IO [Error]-synthesize tgt fcfg cginfo =-  mapM go (M.toList $ holesMap cginfo)-  where-    measures = map (val . msName) ((gsMeasures . gsData . giSpec . ghcI) cginfo)-    go (x, HoleInfo _ loc env (cgi,cge)) = do-      let topLvlBndr = fromMaybe (error "Top-level binder not found") (cgVar cge)-          typeOfTopLvlBnd = fromMaybe (error "Type: Top-level symbol not found") (M.lookup (symbol topLvlBndr) (reGlobal env))-          coreProgram = giCbs $ giSrc $ ghcI cgi-          (uniVars, _) = getUniVars coreProgram topLvlBndr-          fromREnv' = filterREnv (reLocal env)-          fromREnv'' = M.fromList (filter (rmClassVars . toType False . snd) (M.toList fromREnv'))-          rmClassVars t = case t of { TyConApp c _ -> not . isClassTyCon $ c; _ -> True }-          fromREnv  = M.fromList (rmMeasures measures (M.toList fromREnv''))-          isForall t = case t of { ForAllTy{} -> True; _ -> False}-          rEnvForalls = M.fromList (filter (isForall . toType False . snd) (M.toList fromREnv))-          fs = map (snd . snd) $ M.toList (symbolToVar coreProgram topLvlBndr rEnvForalls)--          ssenv0 = symbolToVar coreProgram topLvlBndr fromREnv-          (senv1, foralls') = initSSEnv typeOfTopLvlBnd cginfo ssenv0--      ctx <- SMT.makeContext fcfg tgt-      state0 <- initState ctx fcfg cgi cge env topLvlBndr (reverse uniVars) M.empty-      let foralls = foralls' ++ fs-      fills <- synthesize' ctx cgi senv1 typeOfTopLvlBnd topLvlBndr typeOfTopLvlBnd foralls state0--      return $ ErrHole loc (-        if not (null fills)-          then text "\n Hole Fills:" $+$ pprintMany (map (coreToHs typeOfTopLvlBnd topLvlBndr . fromAnf) fills)-          else mempty) mempty (symbol x) typeOfTopLvlBnd---synthesize' :: SMT.Context -> CGInfo -> SSEnv -> SpecType ->  Var -> SpecType -> [Var] -> SState -> IO [CoreExpr]-synthesize' ctx cgi ssenv tx xtop ttop foralls st2- = evalSM (go tx) ctx ssenv st2-  where--    go :: SpecType -> SM [CoreExpr]--    -- Type Abstraction -    go (RAllT a t _x)      = GHC.Lam (tyVarVar a) <$$> go t--    go t@(RApp c _ts _ _r) = do-      let coreProgram = giCbs $ giSrc $ ghcI cgi-          args  = drop 1 (argsP coreProgram xtop)-          (_, (xs, _, txs, _), _) = bkArrow ttop-      addEnv xtop $ decrType xtop ttop args (zip xs txs)--      if R.isNumeric (tyConEmbed cgi) c-          then error " [ Numeric in synthesize ] Update liquid fixpoint. "-          else do let ts = unifyWith (toType False t)-                  if null ts  then modify (\s -> s { sUGoalTy = Nothing } )-                              else modify (\s -> s { sUGoalTy = Just ts } )-                  modify (\s -> s {sForalls = (foralls, [])})-                  emem0 <- insEMem0 ssenv-                  modify (\s -> s { sExprMem = emem0 })-                  synthesizeBasic t--    go (RAllP _ t) = go t--    go (RRTy _env _ref _obl t) = go t--    go t@RFun{}-         = do ys <- mapM freshVar txs-              let su = F.mkSubst $ zip xs (EVar . symbol <$> ys)-              mapM_ (uncurry addEnv) (zip ys (subst su<$> txs))-              let dt = decrType xtop ttop ys (zip xs txs)-              addEnv xtop dt-              mapM_ (uncurry addEmem) (zip ys (subst su <$> txs))-              addEmem xtop dt-              senv1 <- getSEnv-              let goalType' = subst su to-                  hsGoalTy = toType False goalType'-                  ts = unifyWith hsGoalTy-              if null ts  then modify (\s -> s { sUGoalTy = Nothing } )-                          else modify (\s -> s { sUGoalTy = Just ts } )-              modify (\s -> s { sForalls = (foralls, []) } )-              emem0 <- insEMem0 senv1-              modify (\s -> s { sExprMem = emem0 })-              mapM_ (`addDecrTerm` []) ys-              scruts <- synthesizeScrut ys-              modify (\s -> s { scrutinees = scruts })-              GHC.mkLams ys <$$> synthesizeBasic goalType'-      where (_, (xs, _,txs, _), to) = bkArrow t--    go t = error (" Unmatched t = " ++ show t)--synthesizeBasic :: SpecType -> SM [CoreExpr]-synthesizeBasic t = do-  let ts = unifyWith (toType False t) -- All the types that are used for instantiation.-  if null ts  then  modify (\s -> s { sUGoalTy = Nothing } )-              else  modify (\s -> s { sUGoalTy = Just ts } )-  modify (\s -> s { sGoalTys = [] })-  fixEMem t-  es <- genTerms t-  if null es  then synthesizeMatch t-              else return es--synthesizeMatch :: SpecType -> SM [CoreExpr]-synthesizeMatch t = do-  scruts <- scrutinees <$> get-  i <- incrCase-  case safeIxScruts i scruts of-    Nothing  ->  return []-    Just id' ->  if null scruts-                  then return []-                  else withIncrDepth (matchOnExpr t (scruts !! id'))--synthesizeScrut :: [Var] -> SM [(CoreExpr, Type, TyCon)]-synthesizeScrut vs = do-  exprs <- synthesizeScrutinee vs-  let exprs' = map (\e -> (exprType e, e)) exprs-      isDataCon v = case varType v of { TyConApp c _ -> not . isClassTyCon $ c; _ -> False }-      vs0 = filter isDataCon vs-      es0 = map GHC.Var vs0-      es1 = map (\e -> (exprType e, e)) es0-      es2 = [(e, t, c) | (t@(TyConApp c _), e) <- es1]-  return (es2 ++ [(e, t, c) | (t@(TyConApp c _), e) <- exprs'])--matchOnExpr :: SpecType -> (CoreExpr, Type, TyCon) -> SM [CoreExpr]-matchOnExpr t (GHC.Var v, tx, c)-  = matchOn t (v, tx, c)-matchOnExpr t (e, tx, c)-  = do  freshV <- freshVarType tx-        freshSpecTy <- liftCG $ trueTy False tx-        -- use consE-        addEnv freshV freshSpecTy-        es <- matchOn t (freshV, tx, c)-        return $ GHC.Let (GHC.NonRec freshV e) <$> es--matchOn :: SpecType -> (Var, Type, TyCon) -> SM [CoreExpr]-matchOn t (v, tx, c) =-  (GHC.Case (GHC.Var v) v tx <$$> sequence) <$> mapM (makeAlt t (v, tx)) (tyConDataCons c)---makeAlt :: SpecType -> (Var, Type) -> DataCon -> SM [GHC.CoreAlt]-makeAlt t (x, TyConApp _ kts) c = locally $ do-  ts <- liftCG $ mapM (trueTy False) τs-  xs <- mapM freshVar ts-  newScruts <- synthesizeScrut xs-  modify (\s -> s { scrutinees = scrutinees s ++ newScruts } )-  addsEnv $ zip xs ts-  addsEmem $ zip xs ts-  addDecrTerm x xs-  liftCG0 (\γ -> caseEnv γ x mempty (GHC.DataAlt c) xs Nothing)-  es <- synthesizeBasic t-  return $ (GHC.DataAlt c, xs, ) <$> es-  where-    (_, _, τs) = dataConInstSig c kts-makeAlt _ _ _ = error "makeAlt.bad argument "
− src/Language/Haskell/Liquid/Synthesize/Check.hs 
@@ -1,99 +0,0 @@-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE BangPatterns #-}--{-# OPTIONS_GHC -Wno-name-shadowing #-}--module Language.Haskell.Liquid.Synthesize.Check (check, hasType, isWellTyped, checkError) where---import           Language.Fixpoint.Types.Constraints-import qualified Language.Fixpoint.Types.Config-                                               as F-import qualified Language.Fixpoint.Types       as F-import           Language.Fixpoint.Solver-import           Language.Haskell.Liquid.Types.Types-import           Language.Haskell.Liquid.Types.Specs-import           Language.Haskell.Liquid.Constraint.Env-import           Language.Haskell.Liquid.Constraint.Generate-import           Language.Haskell.Liquid.Constraint.Types-import           Language.Haskell.Liquid.Constraint.Fresh-                                                ( trueTy )-import           Language.Haskell.Liquid.Constraint.ToFixpoint-import           Language.Haskell.Liquid.Synthesize.Monad-import           Language.Haskell.Liquid.Synthesize.GHC-import           Liquid.GHC.API as Ghc-import           Language.Haskell.Liquid.Misc   ( mapThd3 )-import           Control.Monad.State.Lazy-import           System.Console.CmdArgs.Verbosity-import           Liquid.GHC.TypeRep-import           Language.Haskell.Liquid.Types--hasType :: SpecType -> CoreExpr -> SM Bool-hasType t !e' = notrace (" [ Check ] " ++ show e') $ do -  x  <- freshVar t -  st <- get -  let tpOfE = exprType e'-      ht    = toType False t-  if tpOfE == ht-    then liftIO $ quietly $ check (sCGI st) (sCGEnv st) (sFCfg st) x e (Just t) -    else error $ " [ hasType ] Expression = " ++ show e' ++ " with type " ++ showTy tpOfE ++ " , specType = " ++ show t- where e = tx e' ---- Returns true if the expression is well-typed.-isWellTyped :: CoreExpr -> SM Bool-isWellTyped e =  do -  t <- liftCG $ trueTy False $ exprType e -  hasType t e ---tx :: CoreExpr -> CoreExpr-tx (Case e b t alts) = Case e b t (mapThd3 tx <$> alts)-tx e@(Let _ _) = let (bs,e') = unbind e in foldr Let e' bs -tx e = e --unbind :: CoreExpr -> ([CoreBind], CoreExpr)-unbind (Let (NonRec x ex) e) = let (bs,e') = unbind ex in (bs ++ [NonRec x e'],e)-unbind e = ([], e)---check :: CGInfo -> CGEnv -> F.Config -> Var -> CoreExpr -> Maybe SpecType -> IO Bool -check cgi γ cfg x e t = do-    finfo <- cgInfoFInfo info' cs-    isSafe <$> solve cfg{F.srcFile = "SCheck" <> F.srcFile cfg} finfo -  where -    cs = generateConstraintsWithEnv info' (cgi{hsCs = []}) (γ{grtys = insertREnv' (F.symbol x) t (grtys γ)}) -    info' = info {giSrc = giSrc', giSpec = giSpec'}-    giSrc' = (giSrc info) {giCbs = [Rec [(x, e)]]}-    giSpec' = giSpecOld{gsSig = gsSig'}-    giSpecOld = giSpec info -    gsSigOld  = gsSig giSpecOld-    gsSig' = gsSigOld {gsTySigs = addTySig x t (gsTySigs gsSigOld)}-    info = ghcI cgi --    insertREnv' _ Nothing g = g -    insertREnv' x (Just t) g = insertREnv x t g-    -    addTySig _ Nothing  ts = ts -    addTySig x (Just t) ts = (x,dummyLoc t):ts-    -checkError :: SpecType -> SM (Maybe CoreExpr)-checkError t = do -  errVar <- varError-  let errorExpr   = App (App (Var errVar) (Type (toType False t))) errorInt-      globalFlags = unsafeGlobalDynFlags-      platform    = targetPlatform globalFlags-      errorInt    = mkIntExprInt platform 42-  b <- hasType t errorExpr-  if b -    then return $ Just errorExpr-    else return Nothing--quietly :: IO a -> IO a-quietly act = do-  vb <- getVerbosity-  setVerbosity Quiet-  r  <- act-  setVerbosity vb-  return r--
− src/Language/Haskell/Liquid/Synthesize/Env.hs 
@@ -1,47 +0,0 @@-{-# OPTIONS_GHC -Wno-name-shadowing #-}--module Language.Haskell.Liquid.Synthesize.Env where --import           Language.Fixpoint.Types-import           Liquid.GHC.API as GHC-import           Language.Haskell.Liquid.Constraint.Types-import           Language.Haskell.Liquid.Types-import           Language.Haskell.Liquid.Synthesize.Monad-import qualified Data.HashMap.Strict           as M-import qualified Data.HashSet                  as S-import           Data.List --initSSEnv :: SpecType -> CGInfo -> SSEnv -> (SSEnv, [Var])-initSSEnv rt info senv = (M.union senv (M.fromList foralls), vs)-  where foralls = filter iNeedIt (mkElem <$> prims)-        vs = map (snd . snd) foralls-        dataCons = typeToCons rt -        mkElem (v, lt) = (symbol v, (val lt, v))-        prims = gsCtors $ gsData $ giSpec $ ghcI info-        iNeedIt (_, (_, v)) = v `elem` (dataConWorkId <$> dataCons)---- | For algebraic datatypes: Find (in the refinement type) ---   all the datatypes that are used and ---   get their constructors.-tpToCons :: SpecType -> [DataCon] -tpToCons (RAllT _a t _x)  -  = tpToCons t -tpToCons (RApp c args _ _r) -  = tyConDataCons (rtc_tc c) ++ concatMap tpToCons args-tpToCons (RFun _sym _ rt0 rt1 _reft)-  = tpToCons rt0 ++ tpToCons rt1-tpToCons RVar{} -  = []-tpToCons (RAllP _ t)-  = tpToCons t-tpToCons (RRTy _ _ _ t)-  = tpToCons t-tpToCons _ -  = []--typeToCons :: SpecType -> [DataCon]-typeToCons rt = S.toList $ S.fromList (tpToCons rt)--rmMeasures :: [Symbol] -> [(Symbol, SpecType)] -> [(Symbol, SpecType)]-rmMeasures meas = filter (\(s,_) -> case find (== s) meas of  Nothing -> True-                                                              Just _  -> False)
− src/Language/Haskell/Liquid/Synthesize/GHC.hs 
@@ -1,414 +0,0 @@-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE LambdaCase #-}--{-# OPTIONS_GHC -Wno-orphans #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-}--module Language.Haskell.Liquid.Synthesize.GHC where--import qualified Language.Fixpoint.Types       as F-import           Language.Haskell.Liquid.Types-import           Data.Default-import           Data.Maybe                     ( fromMaybe )-import           Liquid.GHC.TypeRep-import           Liquid.GHC.API as GHC-import           Language.Fixpoint.Types-import qualified Data.HashMap.Strict           as M--import           Data.List-import           Data.List.Split--instance Default Type where-    def = TyVarTy alphaTyVar--mkVar :: Maybe String -> Int -> Type -> Var-mkVar x i t = mkGlobalVar VanillaId name t vanillaIdInfo-  where-    name = mkSystemName (mkUnique 'S' i) (mkVarOcc x')-    x'   = fromMaybe (freshName i) x--freshName :: Int -> String-freshName i = "lSyn$" ++ show i---- | Assuming that the functions are instantiated when this function is called.-goalType ::  Type ->   --  This is the goal type. It is used for basic types.-              Type ->  --   This type comes from the environment.-              Bool     --   True if the 2nd arg produces expression -                       --   of type equal to 1st argument.-goalType τ FunTy{ ft_res = t'' }-  | t'' == τ  = True-  | otherwise = goalType τ t''-goalType τ                 t-  | τ == t    = True-  | otherwise = False---- Subgoals are function's arguments.-createSubgoals :: Type -> [Type]-createSubgoals (ForAllTy _ htype) = createSubgoals htype-createSubgoals (FunTy { ft_arg = t1, ft_res = t2 }) = t1 : createSubgoals t2-createSubgoals t                                    = [t]--subgoals :: Type ->               -- Given a function type,-            Maybe (Type, [Type])  -- separate the result type from the input types.-subgoals t = if null gTys then Nothing else Just (resTy, inpTys)-  where gTys            = createSubgoals t-        (resTy, inpTys) = (last gTys, take (length gTys - 1) gTys)----- @withSubgoal@ :: Takes a subgoal type, and --- returns all expressions in @ExprMemory@ that have the same type.-withSubgoal :: [(Type, CoreExpr, Int)] -> Type -> [(CoreExpr, Int)]-withSubgoal []                  _ = []-withSubgoal ((t, e, i) : exprs) τ =-  if τ == t-    then (e, i) : withSubgoal exprs τ-    else withSubgoal exprs τ---- | Assuming that goals are type variables or constructors.---    Note: We maintain ordering from the goal type.---    Not handled (compared to @varsInType): function types, type applications-unifyWith :: Type -> [Type]-unifyWith v@(TyVarTy _)   = [v]-unifyWith (TyConApp _ ts) = ts-unifyWith t               = error $ " [ unifyWith ] " ++ showTy t--fromAnf :: CoreExpr -> CoreExpr-fromAnf e = fst $ fromAnf' e []---- | Replace let bindings in applications.---   > If you find a binding add it to the second argument.---                    | (lhs, rhs)      |-fromAnf' :: CoreExpr -> [(Var, CoreExpr)] -> (CoreExpr, [(Var, CoreExpr)])-fromAnf' (Lam b e) bnds-  = let (e', bnds') = fromAnf' e bnds-    in  (Lam b e', bnds')-fromAnf' (Let bnd e) bnds-  = case bnd of Rec {}       -> error " By construction, no recursive bindings in let expression. "-                NonRec rb lb -> let (lb', bnds') = fromAnf' lb bnds-                                in  fromAnf' e ((rb, lb') : bnds')-fromAnf' (Var var) bnds-  = (fromMaybe (Var var) (lookup var bnds), bnds)-fromAnf' (Case scr bnd tp alts) bnds-  = (Case scr bnd tp (map (\(altc, xs, e) -> (altc, xs, fst $ fromAnf' e bnds)) alts), bnds)-fromAnf' (App e1 e2) bnds-  = let (e1', bnds')  = fromAnf' e1 bnds-        (e2', bnds'') = fromAnf' e2 bnds'-    in  (App e1' e2', bnds'')-fromAnf' t@Type{} bnds-  = (t, bnds)-fromAnf' l@Lit{} bnds-  = (l, bnds)-fromAnf' _ _-  = error " Should not reach this point. "---- | Function used for pretty printing core as Haskell source.---   Input does not contain let bindings.-coreToHs :: SpecType -> Var -> CoreExpr -> String-coreToHs t v e = pprintSymbols (discardModName v ++ pprintFormals caseIndent v e (tracepp " cnt " cnt) [])-  where cnt = countTcConstraints t--symbols :: String-symbols = [':']--pprintSymbols :: String -> String-pprintSymbols txt = foldr (\x xs -> pprintSym symbols x ++ xs) [] txt--pprintSym :: String -> Char -> String-pprintSym symbols s-  = case find (== s) symbols of-      Nothing -> [s]-      Just s' -> ['(', s', ')']--discardModName :: Var -> String-discardModName v = last (splitOn "." (show v))--rmModName :: String -> String-rmModName s =-  let ts = splitOn "." s-  in  maintainLParen ts ++ last ts ++ maintainRParen ts--maintainLParen :: [String] -> String-maintainLParen ts-  = if length ts > 1 && head (head ts) == '('-      then  "("-      else  ""--maintainRParen :: [String] -> String-maintainRParen ts-  = if last (last ts) == '('-      then  ")"-      else  ""--pprintFormals :: Int -> Var -> CoreExpr -> Int -> [Var] -> String-pprintFormals i v (Lam b e) cnt vs-  | isTyVar b = pprintFormals i v e cnt vs-  | cnt > 0 = pprintFormals i v e (cnt - 1) (b:vs)-  | otherwise = " " ++ show b ++ pprintFormals i v e cnt vs-pprintFormals i _ e _ vs-  = " =" ++ pprintBody vs i e--caseIndent :: Int-caseIndent = 4--indent :: Int -> String-indent i = replicate i ' '--errorExprPp :: CoreExpr -> Bool-errorExprPp (GHC.App (GHC.App err@(GHC.Var _) (GHC.Type _)) _)-  = show err == "Language.Haskell.Liquid.Synthesize.Error.err"-errorExprPp _-  = False--pprintVar :: Var -> String-pprintVar v = if isTyVar v then "" else " " ++ discardModName v--pprintBody :: [Var] -> Int -> CoreExpr -> String-pprintBody vs i (Lam b e)-  = pprintFormals i b e 0 vs-pprintBody vs _ (Var v)-  = case find (== v) vs of-      Nothing -> pprintVar v-      Just _  -> ""-pprintBody vs _ e@App{}-  = let pprintApp = fixApplication (show e)-        noTcVars  = filter (\x -> case find (== x) (map show vs) of-                                    Nothing -> True-                                    Just _  -> False) (words pprintApp)-    in  if errorExprPp e-          then " error \" Dead code! \" "-          else " " ++ unwords noTcVars-pprintBody _ _ l@Lit{}-  = " " ++ show l-pprintBody vs i (Case scr _ _ alts)-  = "\n" ++ indent i ++-    "case" ++ pprintBody vs i scr ++ " of\n" ++-    concatMap (pprintAlts vs (i + caseIndent)) alts-pprintBody _ _ Type{}-  = ""-pprintBody _ _ e-  = error (" Not yet implemented for e = " ++ show e)--fixApplication :: String -> String-fixApplication e =-  let ws' = words (replaceNewLine e)-      ws = handleCommas ws'-      cleanWs = rmTypeAppl ws-  in  unwords (fixCommas $ fixParen (map rmModName cleanWs))--handleCommas :: [String] -> [String]-handleCommas [] = []-handleCommas (c:cs)-  = if last c == ','-      then init c : "," : handleCommas cs-      else c : handleCommas cs--fixCommas :: [String] -> [String]-fixCommas [] = []-fixCommas [x] = [x]-fixCommas (x:y:xs)-  = if y == ","-      then (x++y) : fixCommas xs-      else x : fixCommas (y:xs)--fixParen :: [String] -> [String]-fixParen [] = []-fixParen [x] = [x]-fixParen (x:y:xs)-  = if replicate (length y) ')' == y-      then  let w0 = x ++ y-                w = if head w0 == '(' && last w0 == ')'-                      then tail (init w0)-                      else w0-            in  w : fixParen xs-      else x : fixParen (y:xs)--rmTypeAppl :: [String] -> [String]-rmTypeAppl []-  = []-rmTypeAppl (c:cs)-  = if c == "@"-      then  case cs of-              [] -> error " Type application: Badly formatted string. "-              (c': cs') ->-                let p = paren c'-                in  if null p then rmTypeAppl cs' else p : rmTypeAppl cs'-      else c:rmTypeAppl cs--paren :: String -> String-paren []-  = []-paren (c:cs)-  = if c == ')' then c : paren cs else paren cs--replaceNewLine :: String -> String-replaceNewLine []-  = []-replaceNewLine (c:cs)-  = if c == '\n'-      then ' ' : replaceNewLine cs-      else c : replaceNewLine cs--pprintAlts :: [Var] -> Int -> Alt Var -> String-pprintAlts vars i (DataAlt dataCon, vs, e)-  = indent i ++ show dataCon ++ concatMap (\v -> " " ++ show v) vs ++ " ->" ++-    pprintBody vars (i+caseIndent) e ++ "\n"-pprintAlts _ _ _-  = error " Pretty printing for pattern match on datatypes. "---- TODO Remove variables generated for type class constraints-countTcConstraints :: SpecType -> Int-countTcConstraints t =-  let ws = words (show t)--      countCommas :: [String] -> Int-      countCommas []     = 0-      countCommas (x:xs) =-        case find (== ',') x of-          Nothing -> countCommas xs-          Just _  -> 1 + countCommas xs--  in  case find (== "=>") ws of-        Nothing -> 0-        Just _  -> 1 + countCommas (takeWhile (/= "=>") ws)------------------------------------------------------------------------------------------  |                          Prune trivial expressions                       | ---------------------------------------------------------------------------------------nonTrivial :: GHC.CoreExpr -> Bool-nonTrivial (GHC.App _ (GHC.Type _)) = False-nonTrivial _                        = True--nonTrivials :: [GHC.CoreExpr] -> Bool-nonTrivials = foldr (\x b -> nonTrivial x || b) False--trivial :: GHC.CoreExpr -> Bool-trivial (GHC.App (GHC.Var _) (GHC.Type _)) = True -- Is this a nullary constructor?-trivial _ = False--hasTrivial :: [GHC.CoreExpr] -> Bool-hasTrivial es = foldr (\x b -> trivial x || b) False es--allTrivial :: [[GHC.CoreExpr]] -> Bool-allTrivial es = foldr (\x b -> hasTrivial x && b) True es--rmTrivials :: [(GHC.CoreExpr, Int)] -> [(GHC.CoreExpr, Int)]-rmTrivials = filter (not . trivial . fst)---------------------------------------------------------------------------------------  |                        Scrutinee filtering                              | ---------------------------------------------------------------------------------------isVar :: GHC.CoreExpr -> Bool-isVar (GHC.Var _) = True-isVar _           = False--returnsTuple :: Var -> Bool-returnsTuple v =-  case subgoals (varType v) of-    Nothing      -> False-    Just (t, _) ->-      case t of-        TyConApp c _ts -> c == pairTyCon-        _              -> False----------------------------------------------------------------------------------------------------------------------------------------- Handle REnv ------------------------------------------------------------------------------------------------------------------------------------------------- Duplicate from Monad due to dependencies between modules.-type SSEnv = M.HashMap Symbol (SpecType, Var)--filterREnv :: M.HashMap Symbol SpecType -> M.HashMap Symbol SpecType-filterREnv renv =-  let renv_lst  = M.toList renv-      renv_lst' = filter (\(_, specT) ->  let ht = toType False specT-                                          in  showTy ht /= "(RApp   GHC.Prim.Addr# )") renv_lst-  in  M.fromList renv_lst'--getTopLvlBndrs :: GHC.CoreProgram -> [Var]-getTopLvlBndrs = concatMap (\case GHC.NonRec b _ -> [b]-                                  GHC.Rec recs   -> map fst recs)---- | That' s a hack to get the type variables we need for instantiation.-getUniVars :: GHC.CoreProgram -> Var -> ([Var], [Var])-getUniVars cp tlVar =-  case filter (`isInCB` tlVar) cp of-    [cb] -> getUniVars0 (getBody cb tlVar) ([], [])-    _    -> error " Every top-level corebind must be unique! "--getUniVars0 :: GHC.CoreExpr -> ([Var], [Var]) -> ([Var], [Var])-getUniVars0 (Lam b e) (uvs, tcDicts)-  = case varType b of-      TyConApp c _ ->-        if isClassTyCon c-          then getUniVars0 e (uvs, b : tcDicts)-          else getUniVars0 e (b:uvs, tcDicts)-      _ -> getUniVars0 e (b:uvs, tcDicts)-getUniVars0 _ vs-  = vs--getBody :: GHC.CoreBind -> Var -> GHC.CoreExpr-getBody (GHC.NonRec b e) tlVar = if b == tlVar then e else error " [ getBody ] "-getBody (GHC.Rec _)   _ = error "Assuming our top-level binder is non-recursive (only contains a hole)"----                       | Current top-level binder |-varsP :: GHC.CoreProgram -> Var -> (GHC.CoreExpr -> [Var]) -> [Var]-varsP cp tlVar f =-  case filter (`isInCB` tlVar) cp of-    [cb] -> varsCB cb f-    _    -> error " Every top-level corebind must be unique! "--isInCB :: GHC.CoreBind -> Var -> Bool-isInCB (GHC.NonRec b _) tlVar = b == tlVar-isInCB (GHC.Rec recs) tlVar   = foldr ((\v b -> v == tlVar && b) . fst) True recs--varsCB :: GHC.CoreBind -> (GHC.CoreExpr -> [Var]) -> [Var]-varsCB (GHC.NonRec _ e) f = f e-varsCB (GHC.Rec _) _ = notrace " [ symbolToVarCB ] Rec " []--varsE :: GHC.CoreExpr -> [Var]-varsE (GHC.Lam a e) = a : varsE e-varsE (GHC.Let (GHC.NonRec b _) e) = b : varsE e-varsE (GHC.Case _ b _ alts) = foldr (\(_, vars, e) res -> vars ++ varsE e ++ res) [b] alts-varsE (GHC.Tick _ e) = varsE e-varsE _ = []--caseVarsE :: GHC.CoreExpr -> [Var]-caseVarsE (GHC.Lam _ e) = caseVarsE e-caseVarsE (GHC.Let (GHC.NonRec _ _) e) = caseVarsE e-caseVarsE (GHC.Case _ b _ alts) = foldr (\(_, _, e) res -> caseVarsE e ++ res) [b] alts-caseVarsE (GHC.Tick _ e) = caseVarsE e-caseVarsE _ = []--instance Default Var where-  def = alphaTyVar--symbolToVar :: GHC.CoreProgram -> Var -> M.HashMap Symbol SpecType -> SSEnv-symbolToVar cp tlBndr renv =-  let vars = [(F.symbol x, x) | x <- varsP cp tlBndr varsE]-      casevars = [F.symbol x | x <- varsP cp tlBndr caseVarsE]-      tlVars = [(F.symbol x, x) | x <- getTopLvlBndrs cp]-      lookupErrorMsg x = " [ symbolToVar ] impossible lookup for x = " ++ show x-      symbolVar x = fromMaybe (fromMaybe (error (lookupErrorMsg x)) $ lookup x tlVars) $ lookup x vars-      renv' = foldr M.delete renv casevars-  in  M.fromList [ (s, (t, symbolVar s)) | (s, t) <- M.toList renv']--argsP :: GHC.CoreProgram -> Var -> [Var]-argsP []         tlVar = error $ " [ argsP ] " ++ show tlVar-argsP (cb : cbs) tlVar-  | isInCB cb tlVar = argsCB cb-  | otherwise = argsP cbs tlVar--argsCB :: GHC.CoreBind -> [Var]-argsCB (GHC.NonRec _ e) = argsE e-argsCB _                = error " [ argsCB ] "--argsE :: GHC.CoreExpr -> [Var]-argsE (GHC.Lam a e) = a : argsE e-argsE (GHC.Let (GHC.NonRec _ _) e) = argsE e-argsE _ = []--notrace :: String -> a -> a-notrace _ a = a-
− src/Language/Haskell/Liquid/Synthesize/Generate.hs 
@@ -1,252 +0,0 @@-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE BangPatterns #-}--{-# OPTIONS_GHC -Wno-name-shadowing #-}--module Language.Haskell.Liquid.Synthesize.Generate where--import           Liquid.GHC.API as GHC hiding (Depth)-import           Language.Haskell.Liquid.Types-import           Language.Haskell.Liquid.Synthesize.GHC-                                         hiding ( SSEnv )-import           Language.Haskell.Liquid.Synthesize.Monad-import           Language.Haskell.Liquid.Synthesize.Misc-                                         hiding ( notrace )-import           Language.Haskell.Liquid.Synthesize.Check-import           Data.Maybe-import           Control.Monad.State.Lazy-import           Language.Haskell.Liquid.Constraint.Fresh-                                                ( trueTy )-import           Data.List-import           Data.Tuple.Extra-import           Language.Fixpoint.Types.PrettyPrint (tracepp)---- Generate terms that have type t: This changes the @ExprMemory@ in @SM@ state.--- Return expressions type checked against type @specTy@.-genTerms :: SpecType -> SM [CoreExpr] -genTerms = genTerms' ResultMode ---data SearchMode -  = ArgsMode          -- ^ searching for arguments of functions that can eventually -                      --   produce the top level hole fill-  | ResultMode        -- ^ searching for the hole fill -  deriving (Eq, Show) --genTerms' :: SearchMode -> SpecType -> SM [CoreExpr] -genTerms' i specTy = -  do  goalTys <- sGoalTys <$> get-      case find (== toType False specTy) goalTys of -        Nothing -> modify (\s -> s { sGoalTys = toType False specTy : sGoalTys s })-        Just _  -> return ()-      fixEMem specTy -      fnTys <- functionCands (toType False specTy)-      es    <- withTypeEs specTy -      es0   <- structuralCheck es--      err <- checkError specTy -      case err of -        Nothing ->-          filterElseM (hasType specTy) es0 $ -            withDepthFill i specTy 0 fnTys-        Just e -> return [e]--genArgs :: SpecType -> SM [CoreExpr]-genArgs t =-  do  goalTys <- sGoalTys <$> get-      case find (== toType False t) goalTys of -        Nothing -> do modify (\s -> s { sGoalTys = toType False t : sGoalTys s }) -                      fixEMem t -                      fnTys <- functionCands (toType False t)-                      es <- withDepthFillArgs t 0 fnTys-                      if null es-                        then  return []-                        else  do  -- modify (\s -> s {sExprId = sExprId s + 1})-                                  return es-        Just _  -> return []--withDepthFillArgs :: SpecType -> Int -> [(Type, CoreExpr, Int)] -> SM [CoreExpr]-withDepthFillArgs t depth cs = do-  thisEm <- sExprMem <$> get-  es <- argsFill thisEm cs []-  argsDepth <- localMaxArgsDepth--  filterElseM (hasType t) es $-    if depth < argsDepth-      then  trace (" [ withDepthFillArgs ] argsDepth = " ++ show argsDepth) $ withDepthFillArgs t (depth + 1) cs-      else  return []--argsFill :: ExprMemory -> [(Type, CoreExpr, Int)] -> [CoreExpr] -> SM [CoreExpr]-argsFill _   []               es0 = return es0 -argsFill em0 (c:cs) es0 =-  case subgoals (fst3 c) of-    Nothing             -> return [] -    Just (resTy, subGs) -> -      do  let argCands = map (withSubgoal em0) subGs-              toGen    = foldr (\x b -> (not . null) x && b) True (tracepp (" [ argsFill ] for c = " ++ show (snd3 c) ++ " argCands ") argCands)-          es <- do  curExprId <- sExprId <$> get-                    if toGen then -                      prune curExprId c argCands-                      else return []-          curExprId <- sExprId <$> get-          let nextEm = map (resTy, , curExprId + 1) es-          modify (\s -> s {sExprMem = nextEm ++ sExprMem s })-          argsFill em0 cs (es ++ es0)--withDepthFill :: SearchMode -> SpecType -> Int -> [(Type, GHC.CoreExpr, Int)] -> SM [CoreExpr]-withDepthFill i t depth tmp = do-  exprs <- fill i depth tmp []-  appDepth <- localMaxAppDepth--  filterElseM (hasType t) exprs $ -      if depth < appDepth-        then do modify (\s -> s { sExprId = sExprId s + 1 })-                withDepthFill i t (depth + 1) tmp-        else return []--fill :: SearchMode -> Int -> [(Type, GHC.CoreExpr, Int)] -> [CoreExpr] -> SM [CoreExpr] -fill _ _     []                 accExprs -  = return accExprs-fill i depth (c : cs) accExprs -  = case subgoals (fst3 c) of -      Nothing             -> return [] -- Not a function type-      Just (resTy, subGs) ->-        do  specSubGs <- liftCG $ mapM (trueTy False) (filter (not . isFunction) subGs)-            mapM_ genArgs specSubGs-            em <- sExprMem <$> get-            let argCands  = map (withSubgoal em) subGs-                toGen    = foldr (\x b -> (not . null) x && b) True argCands-            newExprs <- do  curExprId <- sExprId <$> get -                            if toGen -                              then prune curExprId c (tracepp (" [ fill " ++ show curExprId ++ " ] For c = " ++ show (snd3 c) ++ " argCands ") argCands)-                              else return []-            curExprId <- sExprId <$> get-            let nextEm = map (resTy, , curExprId + 1) newExprs-            modify (\s -> s {sExprMem = nextEm ++ sExprMem s }) -            let accExprs' = newExprs ++ accExprs-            fill i depth cs accExprs' ------------------------------------------------------------------------------------------------ |                       Pruning terms for function application                      | -----------------------------------------------------------------------------------------------type Depth = Int--feasible :: Depth -> (CoreExpr, Int) -> Bool-feasible d c = snd c >= d--feasibles :: Depth -> Int -> [(CoreExpr, Int)] -> [Int]-feasibles _ _ []-  = []-feasibles d i (c:cs) -  = if feasible d c -      then i : feasibles d (i+1) cs-      else feasibles d (i+1) cs--isFeasible :: Depth -> [[(CoreExpr, Int)]] -> [[Int]]-isFeasible d =  map (feasibles d 0)--findFeasibles :: Depth -> [[(CoreExpr, Int)]] -> ([[Int]], [Int])-findFeasibles d cs = (fs, ixs)-  where fs  = isFeasible d cs-        ixs = [i | (i, f) <- zip [0..] fs, not (null f)]--toExpr :: [Int] ->                    --  Produced from @isFeasible@.-                                      --   Assumed in increasing order.-          [(GHC.CoreExpr, Int)] ->    --  The candidate expressions.-          ([(GHC.CoreExpr, Int)],     --  Expressions from 2nd argument.-           [(GHC.CoreExpr, Int)])     --  The rest of the expressions-toExpr ixs args = ( [ args !! i | (ix, i) <- is, ix == i ], -                    [ args !! i | (ix, i) <- is, ix /= i ])-    where is = zip [0..] ixs--fixCands :: Int -> [Int] -> [[(CoreExpr, Int)]] -> ([[(CoreExpr, Int)]], [[(CoreExpr, Int)]])-fixCands i ixs args -  = let cs = args !! i-        (cur, next)    = toExpr ixs cs-        (args0, args1) = (replace (i+1) cur args, replace (i+1) next args)-    in  (args0, args1)---- | The first argument should be an 1-based index.-replace :: Int -> a -> [a] -> [a]-replace i x l-  = left ++ [x] ++ right-    where left  = take (i-1) l-          right = drop i l--repeatFix :: [Int] -> [[Int]] -> (Type, CoreExpr, Int) -> [[(CoreExpr, Int)]] -> [CoreExpr] -> SM [CoreExpr]-repeatFix [ ] _ _ _ es -  = return es-repeatFix (i:is) ixs toFill args es-  = do  let (args0, args1) = fixCands i (ixs !! i) args-        es0 <- fillOne toFill args0-        es1 <- structuralCheck es0-        es2 <- (++ es) <$> filterM isWellTyped es1-        repeatFix is ixs toFill args1 es2--prune :: Depth -> (Type, CoreExpr, Int) -> [[(CoreExpr, Int)]] -> SM [CoreExpr]-prune d toFill args -  = do  let (ixs, is) = findFeasibles d args -        repeatFix is ixs toFill args []----------------------------------------------------------------------------------  | Term generation: Perform type and term application for functions. | ---------------------------------------------------------------------------------fillOne :: (Type, GHC.CoreExpr, Int) -> [[(CoreExpr, Int)]] -> SM [CoreExpr]-fillOne _ [] -  = return []-fillOne (t, e, _) cs -  = applyTerms [e] cs ((snd . fromJust . subgoals) t)--applyTerm :: [GHC.CoreExpr] -> [(CoreExpr, Int)] -> Type -> SM [CoreExpr]-applyTerm es args t = do-  es1 <- mapM (\x -> applyArg es x t) args-  return (concat es1)--applyArg :: [GHC.CoreExpr] -> (CoreExpr, Int) -> Type -> SM [CoreExpr]-applyArg es (arg, _) t -  = do  !idx <- incrSM-        return  [ case arg of GHC.Var _ -> GHC.App e arg-                              _         ->  let letv = mkVar (Just ("x" ++ show idx)) idx t-                                            in  GHC.Let (GHC.NonRec letv arg) (GHC.App e (GHC.Var letv))-                | e <- es -                ]--applyTerms :: [GHC.CoreExpr] -> [[(CoreExpr, Int)]] -> [Type] -> SM [CoreExpr]-applyTerms es []     []      -  = return es-applyTerms es0 (c:cs) (t:ts) -  = do  es1 <- applyTerm es0 c t-        applyTerms es1 cs ts-applyTerms _es _cs _ts -  = error "[ applyTerms ] Wildcard. " -----------------------------------------------------------------------------------------prodScrutinees :: [(Type, CoreExpr, Int)] -> [[[(CoreExpr, Int)]]] -> SM [CoreExpr]-prodScrutinees []     []     = return []-prodScrutinees (c:cs) (a:as) = do -  es <- fillOne c a-  (++ es) <$> prodScrutinees cs as-prodScrutinees _ _ = error " prodScrutinees "--synthesizeScrutinee :: [Var] -> SM [CoreExpr]-synthesizeScrutinee vars = do-  s <- get-  let foralls = (fst . sForalls) s-      insVs = sUniVars s-      fix   = sFix s-      -- Assign higher priority to function candidates that return tuples-      fnCs0 = filter returnsTuple foralls -      fnCs  = if returnsTuple fix then fix : fnCs0 else fnCs0--      fnEs  = map GHC.Var fnCs-      fnCs' = map (\e -> instantiate e (Just insVs)) fnEs-      sGs   = map ((snd . fromJust) . subgoals . exprType) fnCs'-      argCands = map (map (withSubgoal vs)) sGs-      fnCs'' = map (\e -> (exprType e, e, 0)) fnCs'-      -      vs' = filter ((not . isFunction) . varType) vars-      vs  = map (\v -> (varType v, GHC.Var v, 0)) vs'-  prodScrutinees fnCs'' argCands
− src/Language/Haskell/Liquid/Synthesize/Misc.hs 
@@ -1,94 +0,0 @@-{-# LANGUAGE FlexibleInstances    #-}--{-# OPTIONS_GHC -Wno-orphans #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-}--module Language.Haskell.Liquid.Synthesize.Misc where--import qualified Language.Fixpoint.Types        as F-import           Control.Monad.State.Lazy-import           Text.PrettyPrint.HughesPJ (text, Doc, vcat, ($+$))-import           Language.Haskell.Liquid.Synthesize.GHC-import           Liquid.GHC.TypeRep-import           Liquid.GHC.API hiding (text, ($+$), vcat)-import           Language.Fixpoint.Types---isFunction :: Type -> Bool-isFunction FunTy{}    = True-isFunction ForAllTy{} = True-isFunction _          = False--(<$$>) :: (Functor m, Functor n) => (a -> b) -> m (n a) -> m (n b)-(<$$>) = fmap . fmap--filterElseM :: Monad m => (a -> m Bool) -> [a] -> m [a] -> m [a]-filterElseM f as ms = do-    rs <- filterM f as-    if null rs then-        ms-    else-        return rs---- Replaces    | old w   | new  | symbol name in expr.-substInFExpr :: F.Symbol -> F.Symbol -> F.Expr -> F.Expr-substInFExpr pn nn e = F.subst1 e (pn, F.EVar nn)---findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)-findM _ []     = return Nothing-findM p (x:xs) = do b <- p x ; if b then return (Just x) else findM p xs ---composeM :: Monad m => (a -> m b) -> (b -> c) -> a -> m c-composeM f g x = do -    mx <- f x-    return (g mx)-----------------------------------------------------------------------------------------------------------Printing----------------------------------------------------------------------------------------------------------------------solDelim :: String-solDelim = "*********************************************"---- pprintMany :: (F.PPrint a) => [a] -> Doc--- pprintMany xs = vcat [ F.pprint x $+$ text solDelim | x <- xs ]--pprintMany :: [String] -> Doc-pprintMany xs = vcat [ text x $+$ text solDelim | x <- xs ]--showGoals :: [[String]] -> String-showGoals []             = ""-showGoals (goal : goals) = -    show goal        ++ -    "\n"             ++ -    replicate 12 ' ' ++ -    showGoals goals--showEmem :: (Show a1, Show a2) => [(Type, a1, a2)] -> String-showEmem  emem = show $ showEmem' emem--showEmem' :: (Show a1, Show a2) => [(Type, a1, a2)] -> [(String, String, String)]-showEmem' emem = map (\(t, e, i) -> (show e, showTy t, show i)) emem--exprmemToExpr :: [(a2, CoreExpr, Int)] -> String-exprmemToExpr em = show $ map (\(_, e, i) -> show (fromAnf e, i) ++ " * ") em --showCand :: (a, (Type, b)) -> (String, b)-showCand (_, (t, v)) = (showTy t, v)--showCands :: [(a, (Type, b))] -> [(String, b)]-showCands = map showCand--notrace :: String -> a -> a -notrace _ a = a --instance PPrint AltCon--showCoreAlt :: CoreAlt -> String-showCoreAlt (DataAlt altCon, vars, expr) = -  " For " ++ show altCon ++ " vars " ++ show vars ++ " expr " ++ show expr-showCoreAlt _ = " No! "--showCoreAlts :: [CoreAlt] -> String-showCoreAlts alts = concatMap showCoreAlt alts
− src/Language/Haskell/Liquid/Synthesize/Monad.hs 
@@ -1,423 +0,0 @@-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE FlexibleContexts #-}--{-# OPTIONS_GHC -Wno-name-shadowing #-}--module Language.Haskell.Liquid.Synthesize.Monad where---import           Liquid.GHC.API as GHC-import           Language.Haskell.Liquid.Bare.Resolve-                                               as B-import           Language.Haskell.Liquid.Types-import           Language.Haskell.Liquid.Constraint.Types-import           Language.Haskell.Liquid.Constraint.Env-import           Language.Haskell.Liquid.Synthesize.GHC-                                         hiding ( SSEnv )-import           Language.Haskell.Liquid.Synthesize.Misc-                                         hiding ( notrace )-import qualified Language.Fixpoint.Smt.Interface-                                               as SMT-import           Language.Fixpoint.Types hiding ( SEnv-                                                , SVar-                                                , Error-                                                )-import qualified Language.Fixpoint.Types       as F-import qualified Language.Fixpoint.Types.Config-                                               as F-import           Control.Monad.State.Lazy-import qualified Data.HashMap.Strict           as M-import           Data.Maybe-import           Data.List-import           Data.Tuple.Extra--localMaxMatchDepth :: SM Int-localMaxMatchDepth = maxMatchDepth . getConfig . sCGEnv <$> get------------------------------------------------------------------------------------ | Synthesis Monad ---------------------------------------------------------------------------------------------------------------------------------------------- The state keeps a unique index for generation of fresh variables --- and the environment of variables to types that is expanded on lambda terms-type SSEnv = M.HashMap Symbol (SpecType, Var)-type SSDecrTerm = [(Var, [Var])]--type ExprMemory = [(Type, CoreExpr, Int)]-type T = M.HashMap Type (CoreExpr, Int)-data SState-  = SState { rEnv       :: !REnv-           , ssEnv      :: !SSEnv -- Local Binders Generated during Synthesis -           , ssIdx      :: !Int-           , ssDecrTerm :: !SSDecrTerm-           , sContext   :: !SMT.Context-           , sCGI       :: !CGInfo-           , sCGEnv     :: !CGEnv-           , sFCfg      :: !F.Config-           , sDepth     :: !Int-           , sExprMem   :: !ExprMemory-           , sExprId    :: !Int-           , sArgsId    :: !Int-           , sArgsDepth :: !Int-           , sUniVars   :: ![Var]-           , sFix       :: !Var-           , sGoalTys   :: ![Type]-           , sGoalTyVar :: !(Maybe [TyVar])-           , sUGoalTy   :: !(Maybe [Type])     -- Types used for instantiation.-                                               --   Produced by @withUnify@.-           , sForalls   :: !([Var], [[Type]])  -- [Var] are the parametric functions (except for the fixpoint)-                                               --    e.g. Constructors, top-level functions.-                                               -- [[Type]]: all the types that have instantiated [Var] so far.-           , caseIdx    :: !Int                -- [ Temporary ] Index in list of scrutinees.-           , scrutinees :: ![(CoreExpr, Type, TyCon)]-           }--type SM = StateT SState IO--localMaxAppDepth :: SM Int-localMaxAppDepth = maxAppDepth . getConfig . sCGEnv <$> get--localMaxArgsDepth :: SM Int-localMaxArgsDepth = maxArgsDepth . getConfig . sCGEnv <$> get--locally :: SM a -> SM a-locally act = do-  st <- get-  r <- act-  modify $ \s -> s{sCGEnv = sCGEnv st, sCGI = sCGI st, sExprMem = sExprMem st, scrutinees = scrutinees st}-  return r---evalSM :: SM a -> SMT.Context -> SSEnv -> SState -> IO a-evalSM act ctx env st = do-  let st' = st {ssEnv = env}-  r <- evalStateT act st'-  _ <- SMT.cleanupContext ctx-  return r--initState :: SMT.Context -> F.Config -> CGInfo -> CGEnv -> REnv -> Var -> [Var] -> SSEnv -> IO SState-initState ctx fcfg cgi cgenv renv xtop uniVars env =-  return $ SState renv env 0 [] ctx cgi cgenv fcfg 0 exprMem0 0 0 0 uniVars xtop [] Nothing Nothing ([], []) 0 []-  where exprMem0 = initExprMem env--getSEnv :: SM SSEnv-getSEnv = ssEnv <$> get--getSEMem :: SM ExprMemory-getSEMem = sExprMem <$> get--getSFix :: SM Var-getSFix = sFix <$> get--getSUniVars :: SM [Var]-getSUniVars = sUniVars <$> get--getSDecrTerms :: SM SSDecrTerm-getSDecrTerms = ssDecrTerm <$> get--addsEnv :: [(Var, SpecType)] -> SM ()-addsEnv xts =-  mapM_ (\(x,t) -> modify (\s -> s {ssEnv = M.insert (symbol x) (t,x) (ssEnv s)})) xts--addsEmem :: [(Var, SpecType)] -> SM ()-addsEmem xts = do-  curAppDepth <- sExprId <$> get-  mapM_ (\(x,t) -> modify (\s -> s {sExprMem = (toType False t, GHC.Var x, curAppDepth+1) : sExprMem s})) xts---addEnv :: Var -> SpecType -> SM ()-addEnv x t = do-  liftCG0 (\γ -> γ += ("arg", symbol x, t))-  modify (\s -> s {ssEnv = M.insert (symbol x) (t,x) (ssEnv s)})--addEmem :: Var -> SpecType -> SM ()-addEmem x t = do-  let ht0 = toType False t-  curAppDepth <- sExprId <$> get-  xtop <- getSFix-  (ht1, _) <- instantiateTL-  let ht = if x == xtop then ht1 else ht0-  modify (\s -> s {sExprMem = (ht, GHC.Var x, curAppDepth) : sExprMem s})--------------------------------------------------------------------------------------------------                         Handle structural termination checking                          -------------------------------------------------------------------------------------------------addDecrTerm :: Var -> [Var] -> SM ()-addDecrTerm x vars = do-  decrTerms <- getSDecrTerms-  case lookup x decrTerms of-    Nothing    -> lookupAll x vars decrTerms-    Just vars' -> do-      let ix = elemIndex (x, vars') decrTerms-          newDecrs = thisReplace (fromMaybe (error " [ addDecrTerm ] Index ") ix) (x, vars ++ vars') decrTerms-      modify (\s -> s { ssDecrTerm =  newDecrs })---- -lookupAll :: Var -> [Var] -> SSDecrTerm -> SM ()-lookupAll x vars []               = modify (\s -> s {ssDecrTerm = (x, vars) : ssDecrTerm s})-lookupAll x vars ((xl, vs):decrs) =-  case find (== x) vs of-    Nothing -> lookupAll x vars decrs-    Just _  -> do-      sDecrs <- ssDecrTerm <$> get-      let newDecr  = (xl, vars ++ [x] ++ vs)-          i        = fromMaybe (error " Write sth ") (elemIndex (xl, vs) sDecrs)-          newDecrs = thisReplace i newDecr decrs-      modify (\s -> s { ssDecrTerm = newDecrs })--thisReplace :: Int -> a -> [a] -> [a]-thisReplace i x l-  = left ++ [x] ++ right-    where left  = take (i-1) l-          right = drop i l---- | Entry point.-structuralCheck :: [CoreExpr] -> SM [CoreExpr]-structuralCheck es-  = do  decr <- ssDecrTerm <$> get-        fix <- sFix <$> get-        return (filter (notStructural decr fix) es)--structCheck :: Var -> CoreExpr -> (Maybe Var, [CoreExpr])-structCheck xtop var@(GHC.Var v)-  = if v == xtop-      then (Just xtop, [])-      else (Nothing, [var])-structCheck xtop (GHC.App e1 (GHC.Type _))-  = structCheck xtop e1-structCheck xtop (GHC.App e1 e2)-  =  (mbVar, e2:es)-    where (mbVar, es) = structCheck xtop e1-structCheck xtop (GHC.Let _ e)-  = structCheck xtop e-structCheck _ e-  = error (" StructCheck " ++ show e)--notStructural :: SSDecrTerm -> Var -> CoreExpr -> Bool-notStructural decr xtop e-  = case v of-      Nothing -> True-      Just _  -> foldr (\x b -> isDecreasing' x decr || b) False args-  where (v, args) = structCheck xtop e--isDecreasing' :: CoreExpr -> SSDecrTerm -> Bool-isDecreasing' (GHC.Var v) decr-  = v `notElem` map fst decr-isDecreasing' _e _decr-  = True-------------------------------------------------------------------------------------------------                               END OF STRUCTURAL CHECK                                   --------------------------------------------------------------------------------------------------liftCG0 :: (CGEnv -> CG CGEnv) -> SM ()-liftCG0 act = do-  st <- get-  let (cgenv, cgi) = runState (act (sCGEnv st)) (sCGI st)-  modify (\s -> s {sCGI = cgi, sCGEnv = cgenv})---liftCG :: CG a -> SM a-liftCG act = do-  st <- get-  let (x, cgi) = runState act (sCGI st)-  modify (\s -> s {sCGI = cgi})-  return x---freshVarType :: Type -> SM Var-freshVarType t = (\i -> mkVar (Just "x") i t) <$> incrSM---freshVar :: SpecType -> SM Var-freshVar = freshVarType . toType False--withIncrDepth :: Monoid a => SM a -> SM a-withIncrDepth m = do-    s <- get-    matchBound <- localMaxMatchDepth-    let d = sDepth s-    if d + 1 > matchBound-      then return mempty-      else do put s{sDepth = d + 1}-              r <- m-              modify $ \s -> s{sDepth = d}-              return r---incrSM :: SM Int-incrSM = do s <- get-            put s{ssIdx = ssIdx s + 1}-            return (ssIdx s)--incrCase :: SM Int-incrCase-  = do  s <- get-        put s { caseIdx = caseIdx s + 1 }-        return (caseIdx s)--safeIxScruts :: Int -> [a] -> Maybe Int-safeIxScruts i l-  | i >= length l = Nothing-  | otherwise     = Just i--symbolExpr :: Type -> F.Symbol -> SM CoreExpr-symbolExpr τ x = incrSM >>= (\i -> return $ F.notracepp ("symExpr for " ++ F.showpp x) $  GHC.Var $ mkVar (Just $ F.symbolString x) i τ)---------------------------------------------------------------------------------------------------------------------------------------------------- Handle ExprMemory ------------------------------------------------------------------------------------------------------------------------------------------------------- | Initializes @ExprMemory@ structure.---    1. Transforms refinement types to conventional (Haskell) types.---    2. All @Depth@s are initialized to 0.-initExprMem :: SSEnv -> ExprMemory-initExprMem sEnv = map (\(_, (t, v)) -> (toType False t, GHC.Var v, 0)) (M.toList sEnv)----------------- Init @ExprMemory@ with instantiated functions with the right type (sUGoalTy) ------------insEMem0 :: SSEnv -> SM ExprMemory-insEMem0 senv = do-  xtop      <- getSFix-  (ttop, _) <- instantiateTL-  mbUTy     <- sUGoalTy <$> get-  uniVs <- sUniVars <$> get--  let ts = fromMaybe [] mbUTy-  ts0 <- snd . sForalls <$> get-  fs0 <- fst . sForalls <$> get-  modify ( \s -> s { sForalls = (fs0, ts : ts0) } )--  let handleIt e = case e of  GHC.Var v -> if xtop == v-                                              then (instantiate e (Just uniVs), ttop)-                                              else change e-                              _         -> change e-      change e =  let { e' = instantiateTy e mbUTy; t' = exprType e' }-                  in  (e', t')--      em0 = initExprMem senv-  return $ map (\(_, e, i) -> let (e', t') = handleIt e-                              in  (t', e', i)) em0--instantiateTy :: CoreExpr -> Maybe [Type] -> CoreExpr-instantiateTy e mbTy =-  case mbTy of-    Nothing  -> e-    Just tys -> fromMaybe e (applyTy tys e)---- | Used for instantiation: Applies types to an expression.---   > The result does not have @forall@.---   Nothing as a result suggests that there are more types than foralls in the expression.-applyTy :: [Type] -> GHC.CoreExpr -> Maybe GHC.CoreExpr-applyTy []     e =  case exprType e of-                      ForAllTy{} -> Nothing-                      _          -> Just e-applyTy (t:ts) e =  case exprType e of-                      ForAllTy{} -> applyTy ts (GHC.App e (GHC.Type t))-                      _          -> Nothing---- | Instantiation based on current goal-type.-fixEMem :: SpecType -> SM ()-fixEMem t-  = do  (fs, ts) <- sForalls <$> get-        let uTys = unifyWith (toType False t)-        needsFix <- case find (== uTys) ts of-                      Nothing -> return True   -- not yet instantiated-                      Just _  -> return False  -- already instantiated--        when needsFix $-          do  modify (\s -> s { sForalls = (fs, uTys : ts)})-              let notForall e = case exprType e of {ForAllTy{} -> False; _ -> True}-                  es = map (\v -> instantiateTy (GHC.Var v) (Just uTys)) fs-                  fixEs = filter notForall es-              thisDepth <- sDepth <$> get-              let fixedEMem = map (\e -> (exprType e, e, thisDepth + 1)) fixEs-              modify (\s -> s {sExprMem = fixedEMem ++ sExprMem s})--------------------------------------------------------------------------------------------------------------------------------- Special handle for the current fixpoint ------------------------------------------------------------------------------------------------------------------------------ | Instantiate the top-level variable.-instantiateTL :: SM (Type, GHC.CoreExpr)-instantiateTL = do-  uniVars <- getSUniVars-  xtop <- getSFix-  let e = fromJust $ apply uniVars (GHC.Var xtop)-  return (exprType e, e)---- | Applies type variables (1st argument) to an expression.---   The expression is guaranteed to have the same level of ---   parametricity (same number of @forall@) as the length of the 1st argument.---   > The result has zero @forall@.-apply :: [Var] -> GHC.CoreExpr -> Maybe GHC.CoreExpr-apply []     e =-  case exprType e of-    ForAllTy {} -> Nothing-    _           -> Just e-apply (v:vs) e-  = case exprType e of-      ForAllTy{} -> apply vs (GHC.App e (GHC.Type (TyVarTy v)))-      _          -> Nothing--instantiate :: CoreExpr -> Maybe [Var] -> CoreExpr-instantiate e mbt =-  case mbt of-    Nothing     -> e-    Just tyVars -> fromMaybe e (apply tyVars e)---------------------------------------------------------------------------------------------------------withTypeEs :: SpecType -> SM [CoreExpr]-withTypeEs t = do-    em <- sExprMem <$> get-    return (map snd3 (filter (\x -> fst3 x == toType False t) em))--findCandidates :: Type ->         -- Goal type: Find all candidate expressions of this type,-                                  --   or that produce this type (i.e. functions).-                  SM ExprMemory-findCandidates goalTy = do-  sEMem <- sExprMem <$> get-  return (filter (goalType goalTy . fst3) sEMem)--functionCands :: Type -> SM [(Type, GHC.CoreExpr, Int)]-functionCands goalTy = do-  all <- findCandidates goalTy-  return (filter (isFunction . fst3) all)---------------------------------------------------------------------------------------------------------------- Generate error expression ---------------------------------------------------------------------------------------------------------------varError :: SM Var-varError = do-  info      <- ghcI . sCGI <$> get-  let env    = B.makeEnv (gsConfig $ giSpec info) (toGhcSrc $ giSrc info) mempty mempty-  let name   = giTargetMod $ giSrc info-  let errSym = dummyLoc $ symbol "Language.Haskell.Liquid.Synthesize.Error.err"-  case B.lookupGhcVar env name "Var" errSym of-    Right v -> return v-    Left e  -> error (show e)---toGhcSrc :: TargetSrc -> GhcSrc-toGhcSrc a = Src-      { _giIncDir    = giIncDir a-      , _giTarget    = giTarget a-      , _giTargetMod = giTargetMod a-      , _giCbs       = giCbs a-      , _gsTcs       = gsTcs a-      , _gsCls       = gsCls a-      , _giDerVars   = giDerVars a-      , _giImpVars   = giImpVars a-      , _giDefVars   = giDefVars a-      , _giUseVars   = giUseVars a-      , _gsExports   = gsExports a-      , _gsFiTcs     = gsFiTcs a-      , _gsFiDcs     = gsFiDcs a-      , _gsPrimTcs   = gsPrimTcs a-      , _gsQualImps  = gsQualImps a-      , _gsAllImps   = gsAllImps a-      , _gsTyThings  = gsTyThings a-      }
− src/Language/Haskell/Liquid/Synthesize/Termination.hs 
@@ -1,22 +0,0 @@-{-# LANGUAGE FlexibleInstances    #-}--module Language.Haskell.Liquid.Synthesize.Termination (-    decrType-  ) where--import           Language.Haskell.Liquid.Types-import qualified Language.Haskell.Liquid.Types.RefType-                                               as R-import qualified Language.Fixpoint.Types       as F-import           Liquid.GHC.API--decrType :: Var -> SpecType -> [Var] -> [(F.Symbol, SpecType)] -> SpecType-decrType _x ti xs _xts =-  go xs ti -  where-    go (v:_) (RFun x i tx t r) -      | isDecreasing mempty mempty tx  = let Left (x', tx') = R.makeDecrType mempty [(v,(x,tx))] -                                         in  RFun x' i tx' t r -    go (_:vs) (RFun x i tx t r) = RFun x i tx (go vs t) r-    go vs (RAllT a t x) = RAllT a (go vs t) x-    go _     t = t
− src/Language/Haskell/Liquid/Termination/Structural.hs 
@@ -1,352 +0,0 @@-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-}--{-# OPTIONS_GHC -Wno-name-shadowing #-}--module Language.Haskell.Liquid.Termination.Structural (terminationVars) where--import Language.Haskell.Liquid.Types hiding (isDecreasing)-import Liquid.GHC.Misc (showPpr)-import Liquid.GHC.API  as GHC hiding ( showPpr-                                                      , Env-                                                      , text-                                                      )--import Text.PrettyPrint.HughesPJ hiding ((<>))--import qualified Data.HashSet as HS-import Data.HashSet (HashSet)-import qualified Data.Map.Strict as M-import Data.Map.Strict (Map)-import qualified Data.List as L--import Control.Monad (liftM, ap)-import Data.Foldable (fold)--terminationVars :: TargetInfo -> [Var]-terminationVars info = failingBinds info >>= allBoundVars--failingBinds :: TargetInfo -> [CoreBind]-failingBinds info = filter (hasErrors . checkBind) structBinds-  where-    structCheckWholeProgram = structuralTerm info-    program = giCbs . giSrc $ info-    structFuns = gsStTerm . gsTerm . giSpec $ info-    structBinds-      | structCheckWholeProgram = program-      | otherwise = findStructBinds structFuns program--checkBind :: CoreBind -> Result ()-checkBind bind = do-  srcCallInfo <- getCallInfoBind emptyEnv (deShadowBind bind)-  let structCallInfo = fmap toStructCall <$> srcCallInfo-  fold $ mapWithFun structDecreasing structCallInfo--deShadowBind :: CoreBind -> CoreBind-deShadowBind bind = head $ deShadowBinds [bind]--findStructBinds :: HashSet Var -> CoreProgram -> [CoreBind]-findStructBinds structFuns program = filter isStructBind program-  where-    isStructBind (NonRec f _) = f `HS.member` structFuns-    isStructBind (Rec []) = False-    isStructBind (Rec ((f,_):xs)) = f `HS.member` structFuns || isStructBind (Rec xs)--allBoundVars :: CoreBind -> [Var]-allBoundVars (NonRec v e) = v : (nextBinds e >>= allBoundVars)-allBoundVars (Rec binds) = map fst binds ++ (map snd binds >>= nextBinds >>= allBoundVars)--nextBinds :: CoreExpr -> [CoreBind]-nextBinds = \case-  App e a -> nextBinds e ++ nextBinds a-  Lam _ e -> nextBinds e-  Let b e -> b : nextBinds e-  Case scrut _ _ alts -> nextBinds scrut ++ ([body | (_, _, body) <- alts] >>= nextBinds)-  Cast e _ -> nextBinds e-  Tick _ e -> nextBinds e-  Var{} -> []-  Lit{} -> []-  Coercion{} -> []-  Type{} -> []------------------------------------------------------------------------------------------------ Note that this is *not* the Either/Maybe monad, since it's important that we--- collect all errors, not just the first error.-data Result a = Result-  { resultVal :: a-  , resultErrors :: [TermError]-  } deriving (Show)--data TermError = TE-  { teVar   :: Var-  , teError :: UserError-  } deriving (Show)--hasErrors :: Result a -> Bool-hasErrors = not . null . resultErrors--addError :: Var -> Doc -> Result a -> Result a-addError fun expl (Result x errs) = Result x (mkTermError fun expl : errs)--mkTermError :: Var -> Doc -> TermError-mkTermError fun expl = TE-  { teVar   = fun-  , teError = ErrStTerm (getSrcSpan fun) (text $ showPpr fun) expl-  }--instance Monoid a => Monoid (Result a) where-  mempty  = Result mempty []--instance Semigroup a => Semigroup (Result a) where-  Result x e1 <> Result y e2 = Result (x <> y) (e1 ++ e2)--instance Monad Result where-  Result x e1 >>= f =-    let Result y e2 = f x in-    Result y (e2 ++ e1)--instance Applicative Result where-  pure x = Result x []-  (<*>) = ap--instance Functor Result where-  fmap = liftM------------------------------------------------------------------------------------data Env = Env-  { envCurrentFun :: Maybe Var-  , envCurrentArgs :: [CoreArg]-  , envCheckedFuns :: [Fun]-  }--data Fun = Fun-  { funName :: Var-  , funParams :: [Param]-  }--data Param = Param-  { paramNames :: VarSet-  , paramSubterms :: VarSet-  } deriving (Eq)--emptyEnv :: Env-emptyEnv = Env-  { envCurrentFun = Nothing-  , envCurrentArgs = []-  , envCheckedFuns = []-  }--mkFun :: Var -> Fun-mkFun name = Fun-  { funName = name-  , funParams = []-  }--mkParam :: Var -> Param-mkParam name = Param-  { paramNames = unitVarSet name-  , paramSubterms = emptyVarSet-  }--lookupFun :: Env -> Var -> Maybe Fun-lookupFun env name = L.find (\fun -> funName fun == name) $ envCheckedFuns env--clearCurrentArgs :: Env -> Env-clearCurrentArgs env = env { envCurrentArgs = [] }--setCurrentFun :: Var -> Env -> Env-setCurrentFun fun env = env { envCurrentFun = Just fun }--clearCurrentFun :: Env -> Env-clearCurrentFun env = env { envCurrentFun = Nothing }--addArg :: CoreArg -> Env -> Env-addArg arg env = env { envCurrentArgs = arg:envCurrentArgs env }--addParam :: Var -> Env -> Env-addParam param env = case envCurrentFun env of-  Nothing -> env-  Just name -> env { envCheckedFuns = updateFunNamed name <$> envCheckedFuns env }-  where-    updateFunNamed name fun-      | funName fun == name = fun { funParams = mkParam param : funParams fun }-      | otherwise = fun--addSynonym :: Var -> Var -> Env -> Env-addSynonym oldName newName env = env { envCheckedFuns = updateFun <$> envCheckedFuns env }-  where-    updateFun fun = fun { funParams = updateParam <$> funParams fun }-    updateParam param-      | oldName `elemVarSet` paramNames param = param { paramNames = paramNames param `extendVarSet` newName }-      | oldName `elemVarSet` paramSubterms param = param { paramSubterms = paramSubterms param `extendVarSet` newName }-      | otherwise = param--addSubterms :: Var -> [Var] -> Env -> Env-addSubterms var subterms env = env { envCheckedFuns = updateFun <$> envCheckedFuns env }-  where-    updateFun fun = fun { funParams = updateParam <$> funParams fun }-    updateParam param-      | var `elemVarSet` paramNames param || var `elemVarSet` paramSubterms param = param { paramSubterms = paramSubterms param `extendVarSetList` subterms }-      | otherwise = param--addCheckedFun :: Var -> Env -> Env-addCheckedFun name env = env { envCheckedFuns = mkFun name : envCheckedFuns env }--isParam :: Var -> Param -> Bool-var `isParam` param = var `elemVarSet` paramNames param--isParamSubterm :: Var -> Param -> Bool-var `isParamSubterm` param = var `elemVarSet` paramSubterms param------------------------------------------------------------------------------------newtype FunInfo a = FunInfo (Map Var a)--data SrcCall = SrcCall-  { srcCallFun :: Var-  , srcCallArgs :: [(Param, CoreArg)]-  }--instance Semigroup a => Semigroup (FunInfo a) where-  FunInfo xs <> FunInfo ys = FunInfo $ M.unionWith (<>) xs ys--instance Semigroup a => Monoid (FunInfo a) where-  mempty = FunInfo M.empty--instance Functor FunInfo where-  fmap f (FunInfo xs) = FunInfo (fmap f xs)--instance Foldable FunInfo where-  foldMap f (FunInfo m) = foldMap f m--mapWithFun :: (Var -> a -> b) -> FunInfo a -> FunInfo b-mapWithFun f (FunInfo x) = FunInfo (M.mapWithKey f x)--mkFunInfo :: Var -> a -> FunInfo a-mkFunInfo fun x = FunInfo $ M.singleton fun x--mkSrcCall :: Var -> [(Param, CoreArg)] -> SrcCall-mkSrcCall fun args = SrcCall-  { srcCallFun = fun-  , srcCallArgs = args-  }--toVar :: CoreExpr -> Maybe Var-toVar (Var x) = Just x-toVar (Cast e _) = toVar e-toVar (Tick _ e) = toVar e-toVar _ = Nothing--zipExact :: [a] -> [b] -> Maybe [(a, b)]-zipExact [] [] = Just []-zipExact (x:xs) (y:ys) = ((x, y):) <$> zipExact xs ys-zipExact _ _ = Nothing---- Collect information about all of the recursive calls in a function--- definition which will be needed to check for structural termination.-getCallInfoExpr :: Env -> CoreExpr -> Result (FunInfo [SrcCall])-getCallInfoExpr env = \case-  Var (lookupFun env -> Just fun) ->-    case zipExact (funParams fun) (reverse $ envCurrentArgs env) of-      Just args -> pure $ mkFunInfo (funName fun) [mkSrcCall (funName fun) args]-      Nothing -> addError (funName fun) "Unsaturated call to function" mempty--  App e a-    | isTypeArg a -> getCallInfoExpr env e-    | otherwise -> getCallInfoExpr argEnv a <> getCallInfoExpr appEnv e-      where-        argEnv = clearCurrentFun . clearCurrentArgs $ env-        appEnv = clearCurrentFun . addArg a $ env--  Lam x e-    | isTyVar x -> getCallInfoExpr env e-    | otherwise -> getCallInfoExpr (addParam x env) e--  Let bind e -> getCallInfoBind env bind <> getCallInfoExpr env e--  Case (toVar -> Just var) bndr _ alts -> foldMap getCallInfoAlt alts-    where-      getCallInfoAlt (_, subterms, body) = getCallInfoExpr (branchEnv subterms) body-      branchEnv subterms = addSubterms var subterms . addSynonym var bndr $ env--  Case scrut _ _ alts -> getCallInfoExpr env scrut <> foldMap getCallInfoAlt alts-    where-      getCallInfoAlt (_, _, body) = getCallInfoExpr env body--  Cast e _ -> getCallInfoExpr env e-  Tick _ e -> getCallInfoExpr env e--  Var{} -> pure mempty-  Lit{} -> pure mempty-  Coercion{} -> pure mempty-  Type{} -> pure mempty--getCallInfoBind :: Env -> CoreBind -> Result (FunInfo [SrcCall])-getCallInfoBind env = \case-  NonRec _ e -> getCallInfoExpr (clearCurrentFun env) e-  Rec [] -> pure mempty-  Rec [(f, e)] -> getCallInfoExpr (addCheckedFun f . setCurrentFun f $ env) e-  Rec binds -> foldMap failBind binds-    where failBind (f, e) =-            addError f "Structural checking of mutually-recursive functions is not supported" $-            getCallInfoExpr (clearCurrentFun env) e------------------------------------------------------------------------------------data StructInfo = Unchanged Int | Decreasing Int--unStructInfo :: StructInfo -> Int-unStructInfo (Unchanged p) = p-unStructInfo (Decreasing p) = p--isDecreasing :: StructInfo -> Bool-isDecreasing (Decreasing _) = True-isDecreasing (Unchanged _) = False--data StructCall = StructCall-  { structCallFun :: Var-  , structCallArgs :: [Int]-  , structCallDecArgs :: [Int]-  }--mkStructCall :: Var -> [StructInfo] -> StructCall-mkStructCall fun sis = StructCall-  { structCallFun = fun-  , structCallArgs = map unStructInfo sis-  , structCallDecArgs = map unStructInfo . filter isDecreasing $ sis-  }---- This is where we  check a function call. We go through  the list of arguments--- and find the  indices of those which are decreasing.  Note that this approach--- is only guaranteed to  work when the arguments to the  function are named, so--- e.g.--- foo (x:xs) (y:ys) = foo xs (y:ys)--- won't necessarily work, but--- foo (x:xs) yys@(y:ys) = foo xs yys--- will.-toStructCall :: SrcCall -> StructCall-toStructCall srcCall = mkStructCall (srcCallFun srcCall) $ toStructArgs 0 (srcCallArgs srcCall)-  where-    toStructArgs _ [] = []-    toStructArgs index ((param, toVar -> Just v):args)-      | v `isParam` param = Unchanged index : toStructArgs (index + 1) args-      | v `isParamSubterm` param = Decreasing index : toStructArgs (index + 1) args-    toStructArgs index (_:args) = toStructArgs (index + 1) args---- Check if there is some way to lexicographically order the arguments so that--- they are structurally decreasing. Essentially, in order for there to be, we--- must be able to find some argument which is always either unchanged or--- decreasing. We can then remove every call where that argument is decreasing--- and recurse.-structDecreasing :: Var -> [StructCall] -> Result ()-structDecreasing _ [] = mempty-structDecreasing funName calls-  | null sharedArgs = addError funName "Non-structural recursion" mempty-  | otherwise = structDecreasing funName $ (map removeSharedArgs . filter noneDecreasing) calls-  where-    sharedArgs = foldl1 L.intersect (structCallArgs <$> calls)-    noneDecreasing call = null $ structCallDecArgs call `L.intersect` sharedArgs-    removeSharedArgs call = call { structCallArgs = structCallArgs call L.\\ sharedArgs }
− src/Language/Haskell/Liquid/Transforms/ANF.hs 
@@ -1,434 +0,0 @@------------------------------------------------------------------------------------ | Convert GHC Core into Administrative Normal Form (ANF) -------------------------------------------------------------------------------------------------------{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE NoMonomorphismRestriction  #-}-{-# LANGUAGE TupleSections              #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE ViewPatterns               #-}---module Language.Haskell.Liquid.Transforms.ANF (anormalize) where--import           Prelude                          hiding (error)-import           Liquid.GHC.TypeRep-import           Liquid.GHC.API  as Ghc hiding ( mkTyArg-                                                                , showPpr-                                                                , DsM-                                                                , panic)-import qualified Liquid.GHC.API  as Ghc-import           Control.Monad.State.Lazy-import           System.Console.CmdArgs.Verbosity (whenLoud)-import qualified Language.Fixpoint.Misc     as F-import qualified Language.Fixpoint.Types    as F--import           Language.Haskell.Liquid.UX.Config  as UX-import qualified Language.Haskell.Liquid.Misc       as Misc-import           Liquid.GHC.Misc   as GM-import           Language.Haskell.Liquid.Transforms.Rec-import           Language.Haskell.Liquid.Transforms.InlineAux-import           Language.Haskell.Liquid.Transforms.Rewrite-import           Language.Haskell.Liquid.Types.Errors--import qualified Liquid.GHC.SpanStack as Sp-import qualified Liquid.GHC.Resugar   as Rs-import           Data.Maybe                       (fromMaybe)-import           Data.List                        (sortBy, (\\))-import           Data.Function                    (on)-import qualified Text.Printf as Printf-import           Data.Hashable-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HM------------------------------------------------------------------------------------- | A-Normalize a module ----------------------------------------------------------------------------------------------------------------------------------------anormalize :: UX.Config -> HscEnv -> ModGuts -> IO [CoreBind]----------------------------------------------------------------------------------anormalize cfg hscEnv modGuts = do-  whenLoud $ do-    putStrLn "***************************** GHC CoreBinds ***************************"-    putStrLn $ GM.showCBs untidy (mg_binds modGuts)-    putStrLn "***************************** REC CoreBinds ***************************"-    putStrLn $ GM.showCBs untidy orig_cbs-    putStrLn "***************************** RWR CoreBinds ***************************"-    putStrLn $ GM.showCBs untidy rwr_cbs-  fromMaybe err . snd <$> initDsWithModGuts hscEnv modGuts act -- hscEnv m grEnv tEnv emptyFamInstEnv act-    where-      err      = panic Nothing "Oops, cannot A-Normalize GHC Core!"-      act      = Misc.concatMapM (normalizeTopBind γ0) rwr_cbs-      γ0       = emptyAnfEnv cfg-      rwr_cbs  = rewriteBinds cfg orig_cbs-      orig_cbs = transformRecExpr inl_cbs-      inl_cbs  = inlineAux cfg (mg_module modGuts) $ mg_binds modGuts-      untidy   = UX.untidyCore cfg--{--      m        = mgi_module modGuts-      grEnv    = mgi_rdr_env modGuts-      tEnv     = modGutsTypeEnv modGuts--modGutsTypeEnv :: MGIModGuts -> TypeEnv-modGutsTypeEnv mg  = typeEnvFromEntities ids tcs fis-  where-    ids            = bindersOfBinds (mgi_binds mg)-    tcs            = mgi_tcs mg-    fis            = mgi_fam_insts mg--}------------------------------------------------------------------------------------- | A-Normalize a @CoreBind@ --------------------------------------------------------------------------------------------------------------------------------------- Can't make the below default for normalizeBind as it--- fails tests/pos/lets.hs due to GHCs odd let-bindings--normalizeTopBind :: AnfEnv -> Bind CoreBndr -> Ghc.DsM [CoreBind]-normalizeTopBind γ (NonRec x e)-  = do e' <- runDsM $ evalStateT (stitch γ e) (DsST [])-       return [normalizeTyVars $ NonRec x e']--normalizeTopBind γ (Rec xes)-  = do xes' <- runDsM $ execStateT (normalizeBind γ (Rec xes)) (DsST [])-       return $ map normalizeTyVars (st_binds xes')--normalizeTyVars :: Bind Id -> Bind Id-normalizeTyVars (NonRec x e) = NonRec (setVarType x t') $ normalizeForAllTys e-  where-    t'       = subst msg as as' bt-    msg      = "WARNING: unable to renameVars on " ++ GM.showPpr x-    as'      = fst $ splitForAllTys $ exprType e-    (as, bt) = splitForAllTys (varType x)-normalizeTyVars (Rec xes)    = Rec xes'-  where-    nrec     = normalizeTyVars <$> (uncurry NonRec <$> xes)-    xes'     = (\(NonRec x e) -> (x, e)) <$> nrec--subst :: String -> [TyVar] -> [TyVar] -> Type -> Type-subst msg as as' bt-  | length as == length as'-  = mkForAllTys (mkTyArg <$> as') $ substTy su bt-  | otherwise-  = trace msg $ mkForAllTys (mkTyArg <$> as) bt-  where su = mkTvSubstPrs $ zip as (mkTyVarTys as')---- | eta-expand CoreBinds with quantified types-normalizeForAllTys :: CoreExpr -> CoreExpr-normalizeForAllTys e = case e of-  Lam b _ | isTyVar b-    -> e-  _ -> mkLams tvs (mkTyApps e (map mkTyVarTy tvs))-  where-  (tvs, _) = splitForAllTys (exprType e)---newtype DsM a = DsM {runDsM :: Ghc.DsM a}-   deriving (Functor, Monad, MonadUnique, Applicative)--newtype DsST = DsST { st_binds :: [CoreBind] }--type DsMW = StateT DsST DsM---------------------------------------------------------------------normalizeBind :: AnfEnv -> CoreBind -> DsMW ()--------------------------------------------------------------------normalizeBind γ (NonRec x e)-  = do e' <- normalize γ e-       add [NonRec x e']--normalizeBind γ (Rec xes)-  = do es' <- mapM (stitch γ) es-       add [Rec (zip xs es')]-    where-       (xs, es) = unzip xes-----------------------------------------------------------------------normalizeName :: AnfEnv -> CoreExpr -> DsMW CoreExpr------------------------------------------------------------------------- normalizeNameDebug γ e---   = liftM (tracePpr ("normalizeName" ++ showPpr e)) $ normalizeName γ e--normalizeName γ e@(Lit l)-  | shouldNormalize l-  = normalizeLiteral γ e-  | otherwise-  = return e--normalizeName γ (Var x)-  = return $ Var (lookupAnfEnv γ x x)--normalizeName _ e@(Type _)-  = return e--normalizeName γ e@(Coercion _)-  = do x     <- lift $ freshNormalVar γ $ exprType e-       add  [NonRec x e]-       return $ Var x--normalizeName γ (Tick tt e)-  = do e'    <- normalizeName (γ `at` tt) e-       return $ Tick tt e'--normalizeName γ e-  = do e'   <- normalize γ e-       x    <- lift $ freshNormalVar γ $ exprType e-       add [NonRec x e']-       return $ Var x--shouldNormalize :: Literal -> Bool-shouldNormalize (LitNumber {})  = True-shouldNormalize (LitString {})    = True-shouldNormalize _               = False--add :: [CoreBind] -> DsMW ()-add w = modify $ \s -> s { st_binds = st_binds s ++ w}-----------------------------------------------------------------------------------normalizeLiteral :: AnfEnv -> CoreExpr -> DsMW CoreExpr----------------------------------------------------------------------------------normalizeLiteral γ e =-  do x <- lift $ freshNormalVar γ $ exprType e-     add [NonRec x e]-     return $ Var x-----------------------------------------------------------------------------------normalize :: AnfEnv -> CoreExpr -> DsMW CoreExpr----------------------------------------------------------------------------------normalize γ e-  | UX.patternFlag γ-  , Just p <- Rs.lift e-  = normalizePattern γ p--normalize γ (Lam x e) | isTyVar x-  = do e' <- normalize γ e-       return $ Lam x e'--normalize γ (Lam x e)-  = do e' <- stitch γ e-       return $ Lam x e'--normalize γ (Let b e)-  = do normalizeBind γ b-       normalize γ e-       -- Need to float bindings all the way up to the top-       -- Due to GHCs odd let-bindings (see tests/pos/lets.hs)--normalize γ (Case e x t as)-  = do n     <- normalizeName γ e-       x'    <- lift $ freshNormalVar γ τx -- rename "wild" to avoid shadowing-       let γ' = extendAnfEnv γ x x'-       as'   <- forM as $ \(c, xs, e') -> fmap (c, xs,) (stitch (incrCaseDepth c γ') e')-       as''  <- lift $ expandDefaultCase γ τx as'-       return $ Case n x' t as''-    where τx = GM.expandVarType x--normalize γ (Var x)-  = return $ Var (lookupAnfEnv γ x x)--normalize _ e@(Lit _)-  = return e--normalize _ e@(Type _)-  = return e--normalize γ (Cast e τ)-  = do e' <- normalizeName γ e-       return $ Cast e' τ--normalize γ (App e1 e2@(Type _))-  = do e1' <- normalize γ e1-       e2' <- normalize γ e2-       return $ App e1' e2'--normalize γ (App e1 e2)-  = do e1' <- normalize γ e1-       n2  <- normalizeName γ e2-       return $ App e1' n2--normalize γ (Tick tt e)-  = do e' <- normalize (γ `at` tt) e-       return $ Tick tt e'--normalize _ (Coercion c)-  = return $ Coercion c-----------------------------------------------------------------------------------stitch :: AnfEnv -> CoreExpr -> DsMW CoreExpr----------------------------------------------------------------------------------stitch γ e-  = do bs'   <- get-       modify $ \s -> s { st_binds = [] }-       e'    <- normalize γ e-       bs    <- st_binds <$> get-       put bs'-       return $ mkCoreLets bs e'--_mkCoreLets' :: [CoreBind] -> CoreExpr -> CoreExpr-_mkCoreLets' bs e = mkCoreLets bs1 e1-  where-    (e1, bs1)    = GM.tracePpr "MKCORELETS" (e, bs)-----------------------------------------------------------------------------------normalizePattern :: AnfEnv -> Rs.Pattern -> DsMW CoreExpr----------------------------------------------------------------------------------normalizePattern γ p@(Rs.PatBind {}) = do-  -- don't normalize the >>= itself, we have a special typing rule for it-  e1'   <- normalize γ (Rs.patE1 p)-  e2'   <- stitch    γ (Rs.patE2 p)-  return $ Rs.lower p { Rs.patE1 = e1', Rs.patE2 = e2' }--normalizePattern γ p@(Rs.PatReturn {}) = do-  e'    <- normalize γ (Rs.patE p)-  return $ Rs.lower p { Rs.patE = e' }--normalizePattern _ p@(Rs.PatProject {}) =-  return (Rs.lower p)--normalizePattern γ p@(Rs.PatSelfBind {}) = do-  normalize γ (Rs.patE p)--normalizePattern γ p@(Rs.PatSelfRecBind {}) = do-  e'    <- normalize γ (Rs.patE p)-  return $ Rs.lower p { Rs.patE = e' }------------------------------------------------------------------------------------expandDefault :: AnfEnv -> Bool----------------------------------------------------------------------------------expandDefault γ = aeCaseDepth γ <= maxCaseExpand γ-----------------------------------------------------------------------------------expandDefaultCase :: AnfEnv-                  -> Type-                  -> [(AltCon, [Id], CoreExpr)]-                  -> DsM [(AltCon, [Id], CoreExpr)]----------------------------------------------------------------------------------expandDefaultCase γ tyapp zs@((DEFAULT, _ ,_) : _) | expandDefault γ-  = expandDefaultCase' γ tyapp zs--expandDefaultCase γ tyapp@(TyConApp tc _) z@((DEFAULT, _ ,_):dcs)-  = case tyConDataCons_maybe tc of-       Just ds -> do let ds' = ds \\ [ d | (DataAlt d, _ , _) <- dcs]-                     let n   = length ds'-                     if n == 1-                       then expandDefaultCase' γ tyapp z-                       else if maxCaseExpand γ /= 2-                            then return z-                            else return (trace (expandMessage False γ n) z)-       Nothing -> return z ----expandDefaultCase _ _ z-   = return z--expandDefaultCase'-  :: AnfEnv -> Type -> [(AltCon, [Id], c)] -> DsM [(AltCon, [Id], c)]-expandDefaultCase' γ t ((DEFAULT, _, e) : dcs)-  | Just dtss <- GM.defaultDataCons t (F.fst3 <$> dcs) = do-      dcs'    <- warnCaseExpand γ <$> forM dtss (cloneCase γ e)-      return   $ sortCases (dcs' ++ dcs)-expandDefaultCase' _ _ z-   = return z--cloneCase :: AnfEnv -> e -> (DataCon, [TyVar], [Type]) -> DsM (AltCon, [Id], e)-cloneCase γ e (d, as, ts) = do-  xs  <- mapM (freshNormalVar γ) ts-  return (DataAlt d, as ++ xs, e)--sortCases :: [(AltCon, b, c)] -> [(AltCon, b, c)]-sortCases = sortBy (cmpAltCon `on` F.fst3)--warnCaseExpand :: AnfEnv -> [a] -> [a]-warnCaseExpand γ xs-  | 10 < n          = trace (expandMessage True γ n) xs-  | otherwise       = xs-  where-   n                = length xs--expandMessage :: Bool -> AnfEnv -> Int -> String-expandMessage expand γ n = unlines [msg1, msg2]-  where-    msg1            = Printf.printf "WARNING: (%s) %s DEFAULT with %d cases at depth %d" (showPpr sp) v1 n d-    msg2            = Printf.printf "%s expansion with --max-case-expand=%d" v2 d'-    (v1, v2, d')-      | expand      = ("Expanding"    , "Disable", d-1) :: (String, String, Int)-      | otherwise   = ("Not expanding", "Enable" , d+1)-    d               = aeCaseDepth γ-    sp              = Sp.srcSpan (aeSrcSpan γ)------------------------------------------------------------------------------------- | ANF Environments --------------------------------------------------------------------------------------------------------------------------------------------freshNormalVar :: AnfEnv -> Type -> DsM Id-freshNormalVar γ t = do-  u     <- getUniqueM-  let i  = getKey u-  let sp = Sp.srcSpan (aeSrcSpan γ)-  return (mkUserLocal (anfOcc i) u Ghc.Many t sp)--anfOcc :: Int -> OccName-anfOcc = mkVarOccFS . GM.symbolFastString . F.intSymbol F.anfPrefix--data AnfEnv = AnfEnv-  { aeVarEnv    :: HashMap StableId Id-  -- ^ A mapping between a 'StableId' (see below) and an 'Id'.-  , aeSrcSpan   :: Sp.SpanStack-  , aeCfg       :: UX.Config-  , aeCaseDepth :: !Int-  }---- | A \"stable\" 'Id'. When transforming 'Core' into ANF notation, we need to keep around a mapping between--- a particular 'Var' (typically an 'Id') and an 'Id'. Previously this was accomplished using a 'VarEnv',--- a GHC data structure where keys are 'Unique's. Working with 'Unique' in GHC is not always robust enough--- when it comes to LH. First of all, the /way/ 'Unique's are constructed might change between GHC versions,--- and they are not stable between rebuilds/compilations. In the case of this module, in GHC 9 the test--- BST.hs was failing because two different 'Id's, namely \"wild_X2\" and \"dOrd_X2\" were being given the--- same 'Unique' by GHC (i.e. \"X2\") which was causing the relevant entry to be overwritten in the 'AnfEnv'--- causing a unification error.------ A 'StableId' is simply a wrapper over an 'Id' with a different 'Eq' instance that really guarantee--- uniqueness (for our purposes, anyway).-newtype StableId = StableId Id--instance Eq StableId where-  (StableId id1) == (StableId id2) =-    -- We first use the default 'Eq' instance, which works on uniques (basically, integers) and is-    -- efficient. If we get 'False' it means those 'Unique' are really different, but if we get 'True',-    -- we need to be /really/ sure that's the case by using the 'stableNameCmp' function on the 'Name's.-    -- Nothing to do when id1 == id2 as the uniques are /really/ different.-    (id1 == id2) && (stableNameCmp (getName id1) (getName id2) == EQ) -- Avoid unique clashing.---- For the 'Hashable' instance, we rely on the 'Unique'. This means in pratice there is a tiny chance--- of collision, but this should only marginally affects the efficiency of the data structure.-instance Hashable StableId where-  hashWithSalt s (StableId id1) = hashWithSalt s (getKey $ getUnique id1)---- Shows this 'StableId' by also outputting the associated unique.-instance Show StableId where-  show (StableId id1) = nameStableString (getName id1) <> "_" <> show (getUnique id1)--instance UX.HasConfig AnfEnv where-  getConfig = aeCfg--emptyAnfEnv :: UX.Config -> AnfEnv-emptyAnfEnv cfg = AnfEnv-  { aeVarEnv    = mempty-  , aeSrcSpan   = Sp.empty-  , aeCfg       = cfg-  , aeCaseDepth = 1-  }--lookupAnfEnv :: AnfEnv -> Id -> Id -> Id-lookupAnfEnv γ x (StableId -> y) = HM.lookupDefault x y (aeVarEnv γ)--extendAnfEnv :: AnfEnv -> Id -> Id -> AnfEnv-extendAnfEnv γ (StableId -> x) y = γ { aeVarEnv = HM.insert x y (aeVarEnv γ) }--incrCaseDepth :: AltCon -> AnfEnv -> AnfEnv-incrCaseDepth DEFAULT γ = γ { aeCaseDepth = 1 + aeCaseDepth γ }-incrCaseDepth _       γ = γ--at :: AnfEnv -> Tickish Id -> AnfEnv-at γ tt = γ { aeSrcSpan = Sp.push (Sp.Tick tt) (aeSrcSpan γ)}
− src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs 
@@ -1,673 +0,0 @@-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FlexibleContexts       #-}-{-# LANGUAGE UndecidableInstances   #-}-{-# LANGUAGE OverloadedStrings      #-}-{-# LANGUAGE TupleSections          #-}--{-# OPTIONS_GHC -Wno-orphans #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-}--module Language.Haskell.Liquid.Transforms.CoreToLogic-  ( coreToDef-  , coreToFun-  , coreToLogic-  , mkLit, mkI, mkS-  , runToLogic-  , runToLogicWithBoolBinds-  , logicType-  , inlineSpecType-  , measureSpecType-  , weakenResult-  , normalize-  ) where--import           Data.ByteString                       (ByteString)-import           Prelude                               hiding (error)-import           Liquid.GHC.TypeRep   () -- needed for Eq 'Type'-import           Liquid.GHC.API       hiding (Expr, Located, panic)-import qualified Liquid.GHC.API       as Ghc-import qualified Liquid.GHC.API       as C-import qualified Data.List                             as L-import           Data.Maybe                            (listToMaybe)-import qualified Data.Text                             as T-import qualified Data.Char-import qualified Text.Printf as Printf-import           Data.Text.Encoding-import           Data.Text.Encoding.Error-import           Control.Monad.State-import           Control.Monad.Except-import           Control.Monad.Identity-import qualified Language.Fixpoint.Misc                as Misc-import qualified Language.Haskell.Liquid.Misc          as Misc-import           Language.Fixpoint.Types               hiding (panic, Error, R, simplify)-import qualified Language.Fixpoint.Types               as F-import qualified Liquid.GHC.Misc      as GM---import           Language.Haskell.Liquid.Bare.Types-import           Language.Haskell.Liquid.Bare.DataType-import           Language.Haskell.Liquid.Bare.Misc     (simpleSymbolVar)-import           Liquid.GHC.Play-import           Language.Haskell.Liquid.Types.Types   --     hiding (GhcInfo(..), GhcSpec (..), LM)-import           Language.Haskell.Liquid.Types.RefType--import qualified Data.HashMap.Strict                   as M--logicType :: (Reftable r) => Bool -> Type -> RRType r-logicType allowTC τ      = fromRTypeRep $ t { ty_binds = bs, ty_info = is, ty_args = as, ty_refts = rs}-  where-    t            = toRTypeRep $ ofType τ-    (bs, is, as, rs) = Misc.unzip4 $ dropWhile (isErasable . Misc.thd4) $ Misc.zip4 (ty_binds t) (ty_info t) (ty_args t) (ty_refts t)-    isErasable   = if allowTC then isEmbeddedClass else isClassType--{- | [NOTE:inlineSpecType type]: the refinement depends on whether the result type is a Bool or not:-      CASE1: measure f@logic :: X -> Bool <=> f@haskell :: x:X -> {v:Bool | v <=> (f@logic x)}-     CASE2: measure f@logic :: X -> Y    <=> f@haskell :: x:X -> {v:Y    | v = (f@logic x)}- -}--- formerly: strengthenResult-inlineSpecType :: Bool -> Var -> SpecType-inlineSpecType  allowTC v = fromRTypeRep $ rep {ty_res = res `strengthen` r , ty_binds = xs}-  where-    r              = MkUReft (mkR (mkEApp f (mkA <$> vxs))) mempty-    rep            = toRTypeRep t-    res            = ty_res rep-    xs             = intSymbol (symbol ("x" :: String)) <$> [1..length $ ty_binds rep]-    vxs            = dropWhile (isErasable . snd) $ zip xs (ty_args rep)-    isErasable     = if allowTC then isEmbeddedClass else isClassType-    f              = dummyLoc (symbol v)-    t              = ofType (GM.expandVarType v) :: SpecType-    mkA            = EVar . fst-    mkR            = if isBool res then propReft else exprReft---- | Refine types of measures: keep going until you find the last data con!---   this code is a hack! we refine the last data constructor,---   it got complicated to support both---   1. multi parameter measures     (see tests/pos/HasElem.hs)---   2. measures returning functions (fromReader :: Reader r a -> (r -> a) )---   TODO: SIMPLIFY by dropping support for multi parameter measures---- formerly: strengthenResult'-measureSpecType :: Bool -> Var -> SpecType-measureSpecType allowTC v = go mkT [] [(1::Int)..] t-  where-    mkR | boolRes   = propReft-        | otherwise = exprReft-    mkT xs          = MkUReft (mkR $ mkEApp f (EVar <$> reverse xs)) mempty-    f               = dummyLoc (symbol v)-    t               = ofType (GM.expandVarType v) :: SpecType-    boolRes         =  isBool $ ty_res $ toRTypeRep t--    go f args i (RAllT a t r)    = RAllT a (go f args i t) r-    go f args i (RAllP p t)      = RAllP p $ go f args i t-    go f args i (RFun x ii t1 t2 r)-     | (if allowTC then isEmbeddedClass else isClassType) t1           = RFun x ii t1 (go f args i t2) r-    go f args i t@(RFun _ ii t1 t2 r)-     | hasRApps t               = RFun x' ii t1 (go f (x':args) (tail i) t2) r-                                       where x' = intSymbol (symbol ("x" :: String)) (head i)-    go f args _ t                = t `strengthen` f args--    hasRApps (RFun _ _ t1 t2 _) = hasRApps t1 || hasRApps t2-    hasRApps RApp {}          = True-    hasRApps _                = False----- | 'weakenResult foo t' drops the singleton constraint `v = foo x y` ---   that is added, e.g. for measures in /strengthenResult'. ---   This should only be used _when_ checking the body of 'foo' ---   where the output, is, by definition, equal to the singleton.-weakenResult :: Bool -> Var -> SpecType -> SpecType-weakenResult allowTC v t = F.notracepp msg t'-  where-    msg          = "weakenResult v =" ++ GM.showPpr v ++ " t = " ++ showpp t-    t'           = fromRTypeRep $ rep { ty_res = mapExprReft weaken (ty_res rep) }-    rep          = toRTypeRep t-    weaken x     = pAnd . filter ((Just vE /=) . isSingletonExpr x) . conjuncts-    vE           = mkEApp vF xs-    xs           = EVar . fst <$> dropWhile ((if allowTC then isEmbeddedClass else isClassType) . snd) xts-    xts          = zip (ty_binds rep) (ty_args rep)-    vF           = dummyLoc (symbol v)--type LogicM = ExceptT Error (StateT LState Identity)--data LState = LState-  { lsSymMap  :: LogicMap-  , lsError   :: String -> Error-  , lsEmb     :: TCEmb TyCon-  , lsBools   :: [Var]-  , lsDCMap   :: DataConMap-  }--throw :: String -> LogicM a-throw str = do-  fmkError  <- gets lsError-  throwError $ fmkError str--getState :: LogicM LState-getState = get--runToLogic-  :: TCEmb TyCon -> LogicMap -> DataConMap -> (String -> Error)-  -> LogicM t -> Either Error t-runToLogic = runToLogicWithBoolBinds []--runToLogicWithBoolBinds-  :: [Var] -> TCEmb TyCon -> LogicMap -> DataConMap -> (String -> Error)-  -> LogicM t -> Either Error t-runToLogicWithBoolBinds xs tce lmap dm ferror m-  = evalState (runExceptT m) $ LState-      { lsSymMap = lmap-      , lsError  = ferror-      , lsEmb    = tce-      , lsBools  = xs-      , lsDCMap  = dm-      }--coreAltToDef :: (Reftable r) => Bool -> LocSymbol -> Var -> [Var] -> Var -> Type -> [C.CoreAlt]-             -> LogicM [Def (Located (RRType r)) DataCon]-coreAltToDef allowTC x z zs y t alts-  | not (null litAlts) = measureFail x "Cannot lift definition with literal alternatives"-  | otherwise          = do-      d1s <- F.notracepp "coreAltDefs-1" <$> mapM (mkAlt x cc myArgs z) dataAlts-      d2s <- F.notracepp "coreAltDefs-2" <$>       mkDef x cc myArgs z  defAlts defExpr-      return (d1s ++ d2s)-  where-    myArgs   = reverse zs-    cc       = if eqType t boolTy then P else E-    defAlts  = GM.defaultDataCons (GM.expandVarType y) (Misc.fst3 <$> alts)-    defExpr  = listToMaybe [ e |   (C.DEFAULT  , _, e) <- alts ]-    dataAlts =             [ a | a@(C.DataAlt _, _, _) <- alts ]-    litAlts  =             [ a | a@(C.LitAlt _, _, _) <- alts ]--    -- mkAlt :: LocSymbol -> (Expr -> Body) -> [Var] -> Var -> (C.AltCon, [Var], C.CoreExpr)-    mkAlt x ctor _args dx (C.DataAlt d, xs, e)-      = Def x {- (toArgs id args) -} d (Just $ varRType dx) (toArgs Just xs')-      . ctor-      . (`subst1` (F.symbol dx, F.mkEApp (GM.namedLocSymbol d) (F.eVar <$> xs')))-     <$> coreToLg allowTC e-      where xs' = filter (not . if allowTC then GM.isEmbeddedDictVar else GM.isEvVar) xs-    mkAlt _ _ _ _ alt-      = throw $ "Bad alternative" ++ GM.showPpr alt--    mkDef x ctor _args dx (Just dtss) (Just e) = do-      eDef   <- ctor <$> coreToLg allowTC e-      -- let ys  = toArgs id args-      let dxt = Just (varRType dx)-      return  [ Def x {- ys -} d dxt (defArgs x ts) eDef | (d, _, ts) <- dtss ]--    mkDef _ _ _ _ _ _ =-      return []--toArgs :: Reftable r => (Located (RRType r) -> b) -> [Var] -> [(Symbol, b)]-toArgs f args = [(symbol x, f $ varRType x) | x <- args]--defArgs :: Monoid r => LocSymbol -> [Type] -> [(Symbol, Maybe (Located (RRType r)))]-defArgs x     = zipWith (\i t -> (defArg i, defRTyp t)) [0..]-  where-    defArg    = tempSymbol (val x)-    defRTyp   = Just . F.atLoc x . ofType--coreToDef :: Reftable r => Bool -> LocSymbol -> Var -> C.CoreExpr-          -> LogicM [Def (Located (RRType r)) DataCon]-coreToDef allowTC x _ e                   = go [] $ inlinePreds $ simplify allowTC  e-  where-    go args   (C.Lam  x e)        = go (x:args) e-    go args   (C.Tick _ e)        = go args e-    go (z:zs) (C.Case _ y t alts) = coreAltToDef allowTC x z zs y t alts-    go (z:zs) e-      | Just t <- isMeasureArg z  = coreAltToDef allowTC x z zs z t [(C.DEFAULT, [], e)]-    go _ _                        = measureFail x "Does not have a case-of at the top-level"--    inlinePreds   = inline (eqType boolTy . GM.expandVarType)--measureFail       :: LocSymbol -> String -> a-measureFail x msg = panic sp e-  where-    sp            = Just (GM.fSrcSpan x)-    e             = Printf.printf "Cannot create measure '%s': %s" (F.showpp x) msg----- | 'isMeasureArg x' returns 'Just t' if 'x' is a valid argument for a measure.-isMeasureArg :: Var -> Maybe Type-isMeasureArg x-  | Just tc <- tcMb-  , Ghc.isAlgTyCon tc = F.notracepp "isMeasureArg" $ Just t-  | otherwise           = Nothing-  where-    t                   = GM.expandVarType x-    tcMb                = tyConAppTyCon_maybe t---varRType :: (Reftable r) => Var -> Located (RRType r)-varRType = GM.varLocInfo ofType--coreToFun :: Bool -> LocSymbol -> Var -> C.CoreExpr ->  LogicM ([Var], Either Expr Expr)-coreToFun allowTC _ _v e = go [] $ normalize allowTC e-  where-    isE = if allowTC then GM.isEmbeddedDictVar else isErasable-    go acc (C.Lam x e)  | isTyVar    x = go acc e-    go acc (C.Lam x e)  | isE x = go acc e-    go acc (C.Lam x e)  = go (x:acc) e-    go acc (C.Tick _ e) = go acc e-    go acc e            = (reverse acc,) . Right <$> coreToLg allowTC e---instance Show C.CoreExpr where-  show = GM.showPpr--coreToLogic :: Bool -> C.CoreExpr -> LogicM Expr-coreToLogic allowTC cb = coreToLg allowTC (normalize allowTC cb)---coreToLg :: Bool -> C.CoreExpr -> LogicM Expr-coreToLg allowTC  (C.Let (C.NonRec x (C.Coercion c)) e)-  = coreToLg allowTC (C.substExpr (C.extendCvSubst C.emptySubst x c) e)-coreToLg allowTC  (C.Let b e)-  = subst1 <$> coreToLg allowTC e <*>  makesub allowTC b-coreToLg allowTC (C.Tick _ e)          = coreToLg allowTC e-coreToLg allowTC (C.App (C.Var v) e)-  | ignoreVar v                = coreToLg allowTC e-coreToLg _allowTC (C.Var x)-  | x == falseDataConId        = return PFalse-  | x == trueDataConId         = return PTrue-  | otherwise                  = getState >>= eVarWithMap x . lsSymMap-coreToLg allowTC e@(C.App _ _)         = toPredApp allowTC e-coreToLg allowTC (C.Case e b _ alts)-  | eqType (GM.expandVarType b) boolTy  = checkBoolAlts alts >>= coreToIte allowTC e--- coreToLg (C.Lam x e)           = do p     <- coreToLg e---                                     tce   <- lsEmb <$> getState---                                     return $ ELam (symbol x, typeSort tce (GM.expandVarType x)) p-coreToLg allowTC (C.Case e b _ alts)   = do p <- coreToLg allowTC e-                                            casesToLg allowTC b p alts-coreToLg _ (C.Lit l)             = case mkLit l of-                                          Nothing -> throw $ "Bad Literal in measure definition" ++ GM.showPpr l-                                          Just i  -> return i-coreToLg allowTC (C.Cast e c)          = do (s, t) <- coerceToLg c-                                            e'     <- coreToLg allowTC e-                                            return (ECoerc s t e')--- elaboration reuses coretologic--- TODO: fix this-coreToLg True (C.Lam x e) = do p     <- coreToLg True e-                               tce   <- lsEmb <$> getState-                               return $ ELam (symbol x, typeSort tce (GM.expandVarType x)) p-coreToLg _ e@(C.Lam _ _)        = throw ("Cannot transform lambda abstraction to Logic:\t" ++ GM.showPpr e ++-                                            "\n\n Try using a helper function to remove the lambda.")-coreToLg _ e                     = throw ("Cannot transform to Logic:\t" ++ GM.showPpr e)-----coerceToLg :: Coercion -> LogicM (Sort, Sort)-coerceToLg = typeEqToLg . coercionTypeEq--coercionTypeEq :: Coercion -> (Type, Type)-coercionTypeEq co-  | Ghc.Pair s t <- -- GM.tracePpr ("coercion-type-eq-1: " ++ GM.showPpr co) $-                       coercionKind co-  = (s, t)--typeEqToLg :: (Type, Type) -> LogicM (Sort, Sort)-typeEqToLg (s, t) = do-  tce   <- gets lsEmb-  let tx = typeSort tce . expandTypeSynonyms-  return $ F.notracepp "TYPE-EQ-TO-LOGIC" (tx s, tx t)--checkBoolAlts :: [C.CoreAlt] -> LogicM (C.CoreExpr, C.CoreExpr)-checkBoolAlts [(C.DataAlt false, [], efalse), (C.DataAlt true, [], etrue)]-  | false == falseDataCon, true == trueDataCon-  = return (efalse, etrue)--checkBoolAlts [(C.DataAlt true, [], etrue), (C.DataAlt false, [], efalse)]-  | false == falseDataCon, true == trueDataCon-  = return (efalse, etrue)-checkBoolAlts alts-  = throw ("checkBoolAlts failed on " ++ GM.showPpr alts)--casesToLg :: Bool -> Var -> Expr -> [C.CoreAlt] -> LogicM Expr-casesToLg allowTC v e alts = mapM (altToLg allowTC e) normAlts >>= go-  where-    normAlts       = normalizeAlts alts-    go :: [(C.AltCon, Expr)] -> LogicM Expr-    go [(_,p)]     = return (p `subst1` su)-    go ((d,p):dps) = do c <- checkDataAlt d e-                        e' <- go dps-                        return (EIte c p e' `subst1` su)-    go []          = panic (Just (getSrcSpan v)) "Unexpected empty cases in casesToLg"-    su             = (symbol v, e)--checkDataAlt :: C.AltCon -> Expr -> LogicM Expr-checkDataAlt (C.DataAlt d) e = return $ EApp (EVar (makeDataConChecker d)) e-checkDataAlt C.DEFAULT     _ = return PTrue-checkDataAlt (C.LitAlt l)  e-  | Just le <- mkLit l       = return (EEq le e)-  | otherwise                = throw $ "Oops, not yet handled: checkDataAlt on Lit: " ++ GM.showPpr l---- | 'altsDefault' reorders the CoreAlt to ensure that 'DEFAULT' is at the end.-normalizeAlts :: [C.CoreAlt] -> [C.CoreAlt]-normalizeAlts alts      = ctorAlts ++ defAlts-  where-    (defAlts, ctorAlts) = L.partition isDefault alts-    isDefault (c,_,_)   = c == C.DEFAULT--altToLg :: Bool -> Expr -> C.CoreAlt -> LogicM (C.AltCon, Expr)-altToLg allowTC de (a@(C.DataAlt d), xs, e) = do-  p  <- coreToLg allowTC e-  dm <- gets lsDCMap-  let su = mkSubst $ concat [ dataConProj dm de d x i | (x, i) <- zip (filter (not . if allowTC then GM.isEmbeddedDictVar else GM.isEvVar) xs) [1..]]-  return (a, subst su p)--altToLg allowTC _ (a, _, e)-  = (a, ) <$> coreToLg allowTC e--dataConProj :: DataConMap -> Expr -> DataCon -> Var -> Int -> [(Symbol, Expr)]-dataConProj dm de d x i = [(symbol x, t), (GM.simplesymbol x, t)]-  where-    t | primDataCon  d  = de-      | otherwise       = EApp (EVar $ makeDataConSelector (Just dm) d i) de--primDataCon :: DataCon -> Bool-primDataCon d = d == intDataCon--coreToIte :: Bool -> C.CoreExpr -> (C.CoreExpr, C.CoreExpr) -> LogicM Expr-coreToIte allowTC e (efalse, etrue)-  = do p  <- coreToLg allowTC e-       e1 <- coreToLg allowTC efalse-       e2 <- coreToLg allowTC etrue-       return $ EIte p e2 e1--toPredApp :: Bool -> C.CoreExpr -> LogicM Expr-toPredApp allowTC p = go . Misc.mapFst opSym . splitArgs allowTC $ p-  where-    opSym = fmap GM.dropModuleNamesAndUnique . tomaybesymbol-    go (Just f, [e1, e2])-      | Just rel <- M.lookup f brels-      = PAtom rel <$> coreToLg allowTC e1 <*> coreToLg allowTC e2-    go (Just f, [e])-      | f == symbol ("not" :: String)-      = PNot <$>  coreToLg allowTC e-      | f == symbol ("len" :: String)-      = EApp (EVar "len") <$> coreToLg allowTC e-    go (Just f, [e1, e2])-      | f == symbol ("||" :: String)-      = POr <$> mapM (coreToLg allowTC) [e1, e2]-      | f == symbol ("&&" :: String)-      = PAnd <$> mapM (coreToLg allowTC) [e1, e2]-      | f == symbol ("==>" :: String)-      = PImp <$> coreToLg allowTC e1 <*> coreToLg allowTC e2-      | f == symbol ("<=>" :: String)-      = PIff <$> coreToLg allowTC e1 <*> coreToLg allowTC e2-    go (Just f, [es])-      | f == symbol ("or" :: String)-      = POr  . deList <$> coreToLg allowTC es-      | f == symbol ("and" :: String)-      = PAnd . deList <$> coreToLg allowTC es-    go (_, _)-      = toLogicApp allowTC p--    deList :: Expr -> [Expr]-    deList (EApp (EApp (EVar cons) e) es)-      | cons == symbol ("GHC.Types.:" :: String)-      = e:deList es-    deList (EVar nil)-      | nil == symbol ("GHC.Types.[]" :: String)-      = []-    deList e-      = [e]--toLogicApp :: Bool -> C.CoreExpr -> LogicM Expr-toLogicApp allowTC e = do-  let (f, es) = splitArgs allowTC e-  case f of-    C.Var _ -> do args <- mapM (coreToLg allowTC) es-                  lmap <- lsSymMap <$> getState-                  def  <- (`mkEApp` args) <$> tosymbol f-                  (\x -> makeApp def lmap x args) <$> tosymbol' f-    _       -> do fe   <- coreToLg allowTC f-                  args <- mapM (coreToLg allowTC) es-                  return $ foldl EApp fe args--makeApp :: Expr -> LogicMap -> Located Symbol-> [Expr] -> Expr-makeApp _ _ f [e]-  | val f == symbol ("GHC.Num.negate" :: String)-  = ENeg e-  | val f == symbol ("GHC.Num.fromInteger" :: String)-  , ECon c <- e-  = ECon c-  | (modName, sym) <- GM.splitModuleName (val f)-  , symbol ("Ghci" :: String) `isPrefixOfSym` modName-  , sym == "len"-  = EApp (EVar sym) e--makeApp _ _ f [e1, e2]-  | Just op <- M.lookup (val f) bops-  = EBin op e1 e2-  -- Hack for typeclass support. (overriden == without Eq constraint defined at Ghci)-  | (modName, sym) <- GM.splitModuleName (val f)-  , symbol ("Ghci" :: String) `isPrefixOfSym` modName-  , Just op <- M.lookup (mappendSym (symbol ("GHC.Num." :: String)) sym) bops-  = EBin op e1 e2--makeApp def lmap f es-  = eAppWithMap lmap f es def-  -- where msg = "makeApp f = " ++ show f ++ " es = " ++ show es ++ " def = " ++ show def--eVarWithMap :: Id -> LogicMap -> LogicM Expr-eVarWithMap x lmap = do-  f'     <- tosymbol' (C.Var x :: C.CoreExpr)-  -- let msg = "eVarWithMap x = " ++ show x ++ " f' = " ++ show f'-  return $ eAppWithMap lmap f' [] (varExpr x)--varExpr :: Var -> Expr-varExpr x-  | isPolyCst t = mkEApp (dummyLoc s) []-  | otherwise   = EVar s-  where-    t           = GM.expandVarType x-    s           = symbol x--isPolyCst :: Type -> Bool-isPolyCst (ForAllTy _ t) = isCst t-isPolyCst _              = False--isCst :: Type -> Bool-isCst (ForAllTy _ t) = isCst t-isCst FunTy{}        = False-isCst _              = True---brels :: M.HashMap Symbol Brel-brels = M.fromList [ (symbol ("==" :: String), Eq)-                   , (symbol ("/=" :: String), Ne)-                   , (symbol (">=" :: String), Ge)-                   , (symbol (">" :: String) , Gt)-                   , (symbol ("<=" :: String), Le)-                   , (symbol ("<" :: String) , Lt)-                   ]--bops :: M.HashMap Symbol Bop-bops = M.fromList [ (numSymbol "+", Plus)-                  , (numSymbol "-", Minus)-                  , (numSymbol "*", Times)-                  , (numSymbol "/", Div)-                  , (realSymbol "/", Div)-                  , (numSymbol "%", Mod)-                  ]-  where-    numSymbol :: String -> Symbol-    numSymbol =  symbol . (++) "GHC.Num."-    realSymbol :: String -> Symbol-    realSymbol =  symbol . (++) "GHC.Real."--splitArgs :: Bool -> C.Expr t -> (C.Expr t, [C.Arg t])-splitArgs allowTC e = (f, reverse es)- where-    (f, es) = go e--    go (C.App (C.Var i) e) | ignoreVar i       = go e-    go (C.App f (C.Var v)) | if allowTC then GM.isEmbeddedDictVar v else isErasable v   = go f-    go (C.App f e) = (f', e:es) where (f', es) = go f-    go f           = (f, [])--tomaybesymbol :: C.CoreExpr -> Maybe Symbol-tomaybesymbol (C.Var x) = Just $ symbol x-tomaybesymbol _         = Nothing--tosymbol :: C.CoreExpr -> LogicM (Located Symbol)-tosymbol e- = case tomaybesymbol e of-    Just x -> return $ dummyLoc x-    _      -> throw ("Bad Measure Definition:\n" ++ GM.showPpr e ++ "\t cannot be applied")--tosymbol' :: C.CoreExpr -> LogicM (Located Symbol)-tosymbol' (C.Var x) = return $ dummyLoc $ symbol x-tosymbol' e        = throw ("Bad Measure Definition:\n" ++ GM.showPpr e ++ "\t cannot be applied")--makesub :: Bool -> C.CoreBind -> LogicM (Symbol, Expr)-makesub allowTC (C.NonRec x e) =  (symbol x,) <$> coreToLg allowTC e-makesub _       _              = throw "Cannot make Logical Substitution of Recursive Definitions"--mkLit :: Literal -> Maybe Expr-mkLit (LitNumber _ n _) = mkI n--- mkLit (MachInt64  n)    = mkI n--- mkLit (MachWord   n)    = mkI n--- mkLit (MachWord64 n)    = mkI n--- mkLit (LitInteger n _)  = mkI n-mkLit (LitFloat  n)    = mkR n-mkLit (LitDouble n)    = mkR n-mkLit (LitString    s)    = mkS s-mkLit (LitChar   c)    = mkC c-mkLit _                 = Nothing -- ELit sym sort--mkI :: Integer -> Maybe Expr-mkI = Just . ECon . I--mkR :: Rational -> Maybe Expr-mkR                    = Just . ECon . F.R . fromRational--mkS :: ByteString -> Maybe Expr-mkS                    = Just . ESym . SL  . decodeUtf8With lenientDecode--mkC :: Char -> Maybe Expr-mkC                    = Just . ECon . (`F.L` F.charSort)  . repr-  where-    repr               = T.pack . show . Data.Char.ord--ignoreVar :: Id -> Bool-ignoreVar i = simpleSymbolVar i `elem` ["I#", "D#"]---- | Tries to determine if a 'CoreAlt' maps to one of the 'Integer' type constructors.--- We need the disjuction for GHC >= 9, where the Integer now comes from the \"ghc-bignum\" package,--- and it has different names for the constructors.-isBangInteger :: [C.CoreAlt] -> Bool-isBangInteger [(C.DataAlt s, _, _), (C.DataAlt jp,_,_), (C.DataAlt jn,_,_)]-  =  (symbol s  == "GHC.Integer.Type.S#"  || symbol s  == "GHC.Num.Integer.IS")-  && (symbol jp == "GHC.Integer.Type.Jp#" || symbol jp == "GHC.Num.Integer.IP")-  && (symbol jn == "GHC.Integer.Type.Jn#" || symbol jn == "GHC.Num.Integer.IN")-isBangInteger _ = False--isErasable :: Id -> Bool-isErasable v = F.notracepp msg $ isGhcSplId v && not (isDCId v)-  where-    msg      = "isErasable: " ++ GM.showPpr (v, Ghc.idDetails v)--isGhcSplId :: Id -> Bool-isGhcSplId v = isPrefixOfSym (symbol ("$" :: String)) (simpleSymbolVar v)--isDCId :: Id -> Bool-isDCId v = case Ghc.idDetails v of-  DataConWorkId _ -> True-  DataConWrapId _ -> True-  _               -> False--isANF :: Id -> Bool-isANF      v = isPrefixOfSym (symbol ("lq_anf" :: String)) (simpleSymbolVar v)--isDead :: Id -> Bool-isDead     = isDeadOcc . occInfo . Ghc.idInfo--class Simplify a where-  simplify :: Bool -> a -> a-  inline   :: (Id -> Bool) -> a -> a--  normalize :: Bool -> a -> a-  normalize allowTC = inline_preds . inline_anf . simplify allowTC-   where-    inline_preds = inline (eqType boolTy . GM.expandVarType)-    inline_anf   = inline isANF--instance Simplify C.CoreExpr where-  simplify _ e@(C.Var _)-    = e-  simplify _ e@(C.Lit _)-    = e-  simplify allowTC (C.App e (C.Type _))-    = simplify allowTC e-  simplify allowTC (C.App e (C.Var dict))  | (if allowTC then GM.isEmbeddedDictVar else isErasable) dict-    = simplify allowTC e-  simplify allowTC (C.App (C.Lam x e) _)   | isDead x-    = simplify allowTC e-  simplify allowTC (C.App e1 e2)-    = C.App (simplify allowTC e1) (simplify allowTC e2)-  simplify allowTC (C.Lam x e) | isTyVar x-    = simplify allowTC e-  simplify allowTC (C.Lam x e) | (if allowTC then GM.isEmbeddedDictVar else isErasable) x-    = simplify allowTC e-  simplify allowTC (C.Lam x e)-    = C.Lam x (simplify allowTC e)-  simplify allowTC (C.Let (C.NonRec x _) e) | (if allowTC then GM.isEmbeddedDictVar else isErasable) x-    = simplify allowTC e-  simplify allowTC (C.Let (C.Rec xes) e)    | all ((if allowTC then GM.isEmbeddedDictVar else isErasable) . fst) xes-    = simplify allowTC e-  simplify allowTC (C.Let xes e)-    = C.Let (simplify allowTC xes) (simplify allowTC e)-  simplify allowTC (C.Case e x _t alts@[(_,_,ee),_,_]) | isBangInteger alts-  -- XXX(matt): seems to be for debugging?-    = -- Misc.traceShow ("To simplify allowTC case") $ -       sub (M.singleton x (simplify allowTC e)) (simplify allowTC ee)-  simplify allowTC (C.Case e x t alts)-    = C.Case (simplify allowTC e) x t (filter (not . isUndefined) (simplify allowTC <$> alts))-  simplify allowTC (C.Cast e c)-    = C.Cast (simplify allowTC e) c-  simplify allowTC (C.Tick _ e)-    = simplify allowTC e-  simplify _ (C.Coercion c)-    = C.Coercion c-  simplify _ (C.Type t)-    = C.Type t--  inline p (C.Let (C.NonRec x ex) e) | p x-                               = sub (M.singleton x (inline p ex)) (inline p e)-  inline p (C.Let xes e)       = C.Let (inline p xes) (inline p e)-  inline p (C.App e1 e2)       = C.App (inline p e1) (inline p e2)-  inline p (C.Lam x e)         = C.Lam x (inline p e)-  inline p (C.Case e x t alts) = C.Case (inline p e) x t (inline p <$> alts)-  inline p (C.Cast e c)        = C.Cast (inline p e) c-  inline p (C.Tick t e)        = C.Tick t (inline p e)-  inline _ (C.Var x)           = C.Var x-  inline _ (C.Lit l)           = C.Lit l-  inline _ (C.Coercion c)      = C.Coercion c-  inline _ (C.Type t)          = C.Type t--isUndefined :: (t, t1, C.Expr t2) -> Bool-isUndefined (_, _, e) = isUndefinedExpr e-  where-   -- auto generated undefined case: (\_ -> (patError @type "error message")) void-   isUndefinedExpr (C.App (C.Var x) _) | show x `elem` perrors = True-   isUndefinedExpr (C.Let _ e) = isUndefinedExpr e-   -- otherwise-   isUndefinedExpr _ = False--   perrors = ["Control.Exception.Base.patError"]---instance Simplify C.CoreBind where-  simplify allowTC (C.NonRec x e) = C.NonRec x (simplify allowTC e)-  simplify allowTC (C.Rec xes)    = C.Rec (Misc.mapSnd (simplify allowTC) <$> xes )--  inline p (C.NonRec x e) = C.NonRec x (inline p e)-  inline p (C.Rec xes)    = C.Rec (Misc.mapSnd (inline p) <$> xes)--instance Simplify C.CoreAlt where-  simplify allowTC (c, xs, e) = (c, xs, simplify allowTC e)-    -- where xs   = F.tracepp _msg xs0-    --      _msg = "isCoVars? " ++ F.showpp [(x, isCoVar x, varType x) | x <- xs0]-  inline p (c, xs, e) = (c, xs, inline p e)
− src/Language/Haskell/Liquid/Transforms/InlineAux.hs 
@@ -1,104 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--{-# OPTIONS_GHC -Wno-name-shadowing #-}--module Language.Haskell.Liquid.Transforms.InlineAux-  ( inlineAux-  )-where-import qualified Language.Haskell.Liquid.UX.Config  as UX-import           Liquid.GHC.API-import           Control.Arrow                  (second)-import qualified Liquid.GHC.Misc-                                               as GM-import qualified Data.HashMap.Strict           as M--inlineAux :: UX.Config -> Module -> CoreProgram -> CoreProgram-inlineAux cfg m cbs =  if UX.auxInline cfg then occurAnalysePgm m (const False) (const False) [] (map f cbs) else cbs- where-  f :: CoreBind -> CoreBind-  f all@(NonRec x e)-    | Just (dfunId, methodToAux) <- M.lookup x auxToMethodToAux = NonRec-      x-      (inlineAuxExpr dfunId methodToAux e)-    | otherwise = all-  f (Rec bs) = Rec (fmap g bs)-   where-    g all@(x, e)-      | Just (dfunId, methodToAux) <- M.lookup x auxToMethodToAux-      = (x, inlineAuxExpr dfunId methodToAux e)-      | otherwise-      = all-  auxToMethodToAux = mconcat $ fmap (uncurry dfunIdSubst) (grepDFunIds cbs)----- inlineDFun :: DynFlags -> CoreProgram -> IO CoreProgram--- inlineDFun df cbs = mapM go cbs---  where---   go orig@(NonRec x e) | isDFunId x = do---                            -- e''' <- simplifyExpr df e''---                            let newBody = mkCoreApps (GM.tracePpr ("substituted type:" ++ GM.showPpr (exprType (mkCoreApps e' (Var <$> binders)))) e') (fmap Var binders)---                                bind = NonRec (mkWildValBinder (exprType newBody)) newBody---                            pure $ NonRec x (mkLet bind e)---                        | otherwise  = pure orig---    where---     -- wcBinder = mkWildValBinder t---     (binders, _) = GM.tracePpr "collectBinders"$ collectBinders e---     e' = substExprAll empty subst e---   go recs = pure recs---   subst = buildDictSubst cbs---- grab the dictionaries-grepDFunIds :: CoreProgram -> [(DFunId, CoreExpr)]-grepDFunIds = filter (isDFunId . fst) . flattenBinds--isClassOpAuxOccName :: OccName -> Bool-isClassOpAuxOccName occ = case occNameString occ of-  '$' : 'c' : _ -> True-  _             -> False--isClassOpAuxOf :: Id -> Id -> Bool-isClassOpAuxOf aux method = case occNameString $ getOccName aux of-  '$' : 'c' : rest -> rest == occNameString (getOccName method)-  _                -> False--dfunIdSubst :: DFunId -> CoreExpr -> M.HashMap Id (Id, M.HashMap Id Id)-dfunIdSubst dfunId e = M.fromList $ zip auxIds (repeat (dfunId, methodToAux))- where-  methodToAux = M.fromList-    [ (m, aux) | m <- methods, aux <- auxIds, aux `isClassOpAuxOf` m ]-  (_, _, cls, _) = tcSplitDFunTy (idType dfunId)-  auxIds = filter (isClassOpAuxOccName . getOccName) (exprFreeVarsList e)-  methods = classAllSelIds cls--inlineAuxExpr :: DFunId -> M.HashMap Id Id -> CoreExpr -> CoreExpr-inlineAuxExpr dfunId methodToAux e = go e- where-  go :: CoreExpr -> CoreExpr-  go (Lam b body) = Lam b (go body)-  go (Let b body)-    | NonRec x e <- b, isDictId x =-        go $ substExpr (extendIdSubst emptySubst x e) body-    | otherwise = Let (mapBnd go b) (go body)-  go (Case e x t alts) = Case (go e) x t (fmap (mapAlt go) alts)-  go (Cast e c       ) = Cast (go e) c-  go (Tick t e       ) = Tick t (go e)-  go e-    | (Var m, args) <- collectArgs e-    , Just aux <- M.lookup m methodToAux-    , arg : argsNoTy <- dropWhile isTypeArg args-    , (Var x, argargs) <- collectArgs arg-    , x == dfunId-    = GM.notracePpr ("inlining in" ++ GM.showPpr e)-      $ mkCoreApps (Var aux) (argargs ++ (go <$> argsNoTy))-  go (App e0 e1) = App (go e0) (go e1)-  go e           = e----- modified from Rec.hs-mapBnd :: (Expr b -> Expr b) -> Bind b -> Bind b-mapBnd f (NonRec b e) = NonRec b (f e)-mapBnd f (Rec bs    ) = Rec (map (second f) bs)--mapAlt :: (Expr b -> Expr b) -> (t, t1, Expr b) -> (t, t1, Expr b)-mapAlt f (d, bs, e) = (d, bs, f e)
− src/Language/Haskell/Liquid/Transforms/Rec.hs 
@@ -1,293 +0,0 @@-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE ScopedTypeVariables       #-}--{-# OPTIONS_GHC -Wno-name-shadowing #-}--module Language.Haskell.Liquid.Transforms.Rec (-     transformRecExpr, transformScope-     , outerScTr , innerScTr-     , isIdTRecBound, setIdTRecBound-     ) where--import           Control.Arrow                        (second)-import           Control.Monad.State-import qualified Data.HashMap.Strict                  as M-import           Data.Hashable-import           Liquid.GHC.API      as Ghc hiding (panic, mapSndM)-import           Liquid.GHC.Misc-import           Liquid.GHC.Play-import           Language.Haskell.Liquid.Misc         (mapSndM)-import           Language.Fixpoint.Misc               (mapSnd) -- , traceShow)-import           Language.Haskell.Liquid.Types.Errors-import           Prelude                              hiding (error)--import qualified Data.List                            as L---transformRecExpr :: CoreProgram -> CoreProgram-transformRecExpr cbs = pg-  -- TODO-REBARE weird GHC crash on Data/Text/Array.hs | isEmptyBag $ filterBag isTypeError e-  -- TODO-REBARE weird GHC crash on Data/Text/Array.hs = pg-  -- TODO-REBARE weird GHC crash on Data/Text/Array.hs | otherwise-  -- TODO-REBARE weird GHC crash on Data/Text/Array.hs = panic Nothing ("Type-check" ++ showSDoc (pprMessageBag e))-  where-    pg     = inlineFailCases pg0-    pg0    = evalState (transPg (inlineLoopBreaker <$> cbs)) initEnv-    -- (_, e) = lintCoreBindings [] pg-----inlineLoopBreaker :: Bind Id -> Bind Id-inlineLoopBreaker (NonRec x e) | Just (lbx, lbe) <- hasLoopBreaker be-  = Rec [(x, foldr Lam (sub (M.singleton lbx e') lbe) (αs ++ as))]-  where-    (αs, as, be) = collectTyAndValBinders e--    e' = L.foldl' App (L.foldl' App (Var x) (Type . TyVarTy <$> αs)) (Var <$> as)--    hasLoopBreaker (Let (Rec [(x1, e1)]) (Var x2)) | isLoopBreaker x1 && x1 == x2 = Just (x1, e1)-    hasLoopBreaker _                               = Nothing--    isLoopBreaker =  isStrongLoopBreaker . occInfo . idInfo--inlineLoopBreaker bs-  = bs--inlineFailCases :: CoreProgram -> CoreProgram-inlineFailCases = (go [] <$>)-  where-    go su (Rec xes)    = Rec (mapSnd (go' su) <$> xes)-    go su (NonRec x e) = NonRec x (go' su e)--    go' su (App (Var x) _)       | isFailId x, Just e <- getFailExpr x su = e-    go' su (Let (NonRec x ex) e) | isFailId x   = go' (addFailExpr x (go' su ex) su) e--    go' su (App e1 e2)      = App (go' su e1) (go' su e2)-    go' su (Lam x e)        = Lam x (go' su e)-    go' su (Let xs e)       = Let (go su xs) (go' su e)-    go' su (Case e x t alt) = Case (go' su e) x t (goalt su <$> alt)-    go' su (Cast e c)       = Cast (go' su e) c-    go' su (Tick t e)       = Tick t (go' su e)-    go' _  e                = e--    goalt su (c, xs, e)     = (c, xs, go' su e)--    isFailId x  = isLocalId x && isSystemName (varName x) && L.isPrefixOf "fail" (show x)-    getFailExpr = L.lookup--    addFailExpr x (Lam _ e) su = (x, e):su-    addFailExpr _ _         _  = impossible Nothing "internal error" -- this cannot happen---- isTypeError :: SDoc -> Bool--- isTypeError s | isInfixOf "Non term variable" (showSDoc s) = False--- isTypeError _ = True---- No need for this transformation after ghc-8!!!-transformScope :: [Bind Id] -> [Bind Id]-transformScope = outerScTr . innerScTr--outerScTr :: [Bind Id] -> [Bind Id]-outerScTr = mapNonRec (go [])-  where-   go ack x (xe : xes) | isCaseArg x xe = go (xe:ack) x xes-   go ack _ xes        = ack ++ xes--isCaseArg :: Id -> Bind t -> Bool-isCaseArg x (NonRec _ (Case (Var z) _ _ _)) = z == x-isCaseArg _ _                               = False--innerScTr :: Functor f => f (Bind Id) -> f (Bind Id)-innerScTr = (mapBnd scTrans <$>)--scTrans :: Id -> Expr Id -> Expr Id-scTrans x e = mapExpr scTrans $ foldr Let e0 bs-  where (bs, e0)           = go [] x e-        go bs x (Let b e)  | isCaseArg x b = go (b:bs) x e-        go bs x (Tick t e) = second (Tick t) $ go bs x e-        go bs _ e          = (bs, e)--type TE = State TrEnv--data TrEnv = Tr { freshIndex  :: !Int-                , _loc        :: SrcSpan-                }--initEnv :: TrEnv-initEnv = Tr 0 noSrcSpan--transPg :: Traversable t-        => t (Bind CoreBndr)-        -> State TrEnv (t (Bind CoreBndr))-transPg = mapM transBd--transBd :: Bind CoreBndr-        -> State TrEnv (Bind CoreBndr)-transBd (NonRec x e) = fmap (NonRec x) (transExpr =<< mapBdM transBd e)-transBd (Rec xes)    = Rec <$> mapM (mapSndM (mapBdM transBd)) xes--transExpr :: CoreExpr -> TE CoreExpr-transExpr e-  | isNonPolyRec e' && not (null tvs)-  = trans tvs ids bs e'-  | otherwise-  = return e-  where (tvs, ids, e'')       = collectTyAndValBinders e-        (bs, e')              = collectNonRecLets e''--isNonPolyRec :: Expr CoreBndr -> Bool-isNonPolyRec (Let (Rec xes) _) = any nonPoly (snd <$> xes)-isNonPolyRec _                 = False--nonPoly :: CoreExpr -> Bool-nonPoly = null . fst . splitForAllTys . exprType--collectNonRecLets :: Expr t -> ([Bind t], Expr t)-collectNonRecLets = go []-  where go bs (Let b@(NonRec _ _) e') = go (b:bs) e'-        go bs e'                      = (reverse bs, e')--appTysAndIds :: [Var] -> [Id] -> Id -> Expr b-appTysAndIds tvs ids x = mkApps (mkTyApps (Var x) (map TyVarTy tvs)) (map Var ids)--trans :: Foldable t-      => [TyVar]-      -> [Var]-      -> t (Bind Id)-      -> Expr Var-      -> State TrEnv (Expr Id)-trans vs ids bs (Let (Rec xes) e)-  = fmap (mkLam . mkLet) (makeTrans vs liveIds e')-  where liveIds = mkAlive <$> ids-        mkLet e = foldr Let e bs-        mkLam e = foldr Lam e $ vs ++ liveIds-        e'      = Let (Rec xes') e-        xes'    = second mkLet <$> xes--trans _ _ _ _ = panic Nothing "TransformRec.trans called with invalid input"--makeTrans :: [TyVar]-          -> [Var]-          -> Expr Var-          -> State TrEnv (Expr Var)-makeTrans vs ids (Let (Rec xes) e)- = do fids    <- mapM (mkFreshIds vs ids) xs-      let (ids', ys) = unzip fids-      let yes  = appTysAndIds vs ids <$> ys-      ys'     <- mapM fresh xs-      let su   = M.fromList $ zip xs (Var <$> ys')-      let rs   = zip ys' yes-      let es'  = zipWith (mkE ys) ids' es-      let xes' = zip ys es'-      return   $ mkRecBinds rs (Rec xes') (sub su e)- where-   (xs, es)       = unzip xes-   mkSu ys ids'   = mkSubs ids vs ids' (zip xs ys)-   mkE ys ids' e' = mkCoreLams (vs ++ ids') (sub (mkSu ys ids') e')--makeTrans _ _ _ = panic Nothing "TransformRec.makeTrans called with invalid input"--mkRecBinds :: [(b, Expr b)] -> Bind b -> Expr b -> Expr b-mkRecBinds xes rs e = Let rs (L.foldl' f e xes)-  where f e (x, xe) = Let (NonRec x xe) e--mkSubs :: (Eq k, Hashable k)-       => [k] -> [Var] -> [Id] -> [(k, Id)] -> M.HashMap k (Expr b)-mkSubs ids tvs xs ys = M.fromList $ s1 ++ s2-  where s1 = second (appTysAndIds tvs xs) <$> ys-        s2 = zip ids (Var <$> xs)--mkFreshIds :: [TyVar]-           -> [Var]-           -> Var-           -> State TrEnv ([Var], Id)-mkFreshIds tvs ids x-  = do ids'  <- mapM fresh ids-       let ids'' = map setIdTRecBound ids'-       let t  = mkForAllTys ((`Bndr` Required) <$> tvs) $ mkType (reverse ids'') $ varType x-       let x' = setVarType x t-       return (ids'', x')-  where-    mkType ids ty = foldl (\t x -> FunTy VisArg Many (varType x) t) ty ids -- FIXME(adinapoli): Is 'VisArg' OK here?---- NOTE [Don't choose transform-rec binders as decreasing params]--- -------------------------------------------------------------------- We don't want to select a binder created by TransformRec as the--- decreasing parameter, since the user didn't write it. Furthermore,--- consider T1065. There we have an inner loop that decreases on the--- sole list parameter. But TransformRec prepends the parameters to the--- outer `groupByFB` to the inner `groupByFBCore`, and now the first--- decreasing parameter is the constant `xs0`. Disaster!------ So we need a way to signal to L.H.L.Constraint.Generate that we--- should ignore these copied Vars. The easiest way to do that is to set--- a flag on the Var that we know won't be set, and it just so happens--- GHC has a bunch of optional flags that can be set by various Core--- analyses that we don't run...-setIdTRecBound :: Id -> Id--- This is an ugly hack..-setIdTRecBound = modifyIdInfo (`setCafInfo` NoCafRefs)--isIdTRecBound :: Id -> Bool-isIdTRecBound = not . mayHaveCafRefs . cafInfo . idInfo--class Freshable a where-  fresh :: a -> TE a--instance Freshable Int where-  fresh _ = freshInt--instance Freshable Unique where-  fresh _ = freshUnique--instance Freshable Var where-  fresh v = fmap (setVarUnique v) freshUnique--freshInt :: MonadState TrEnv m => m Int-freshInt-  = do s <- get-       let n = freshIndex s-       put s{freshIndex = n+1}-       return n--freshUnique :: MonadState TrEnv m => m Unique-freshUnique = fmap (mkUnique 'X') freshInt---mapNonRec :: (b -> [Bind b] -> [Bind b]) -> [Bind b] -> [Bind b]-mapNonRec f (NonRec x xe:xes) = NonRec x xe : f x (mapNonRec f xes)-mapNonRec f (xe:xes)          = xe : mapNonRec f xes-mapNonRec _ []                = []--mapBnd :: (b -> Expr b -> Expr b) -> Bind b -> Bind b-mapBnd f (NonRec b e)             = NonRec b (mapExpr f  e)-mapBnd f (Rec bs)                 = Rec (map (second (mapExpr f)) bs)--mapExpr :: (b -> Expr b -> Expr b) -> Expr b -> Expr b-mapExpr f (Let (NonRec x ex) e)   = Let (NonRec x (f x ex) ) (f x e)-mapExpr f (App e1 e2)             = App  (mapExpr f e1) (mapExpr f e2)-mapExpr f (Lam b e)               = Lam b (mapExpr f e)-mapExpr f (Let bs e)              = Let (mapBnd f bs) (mapExpr f e)-mapExpr f (Case e b t alt)        = Case e b t (map (mapAlt f) alt)-mapExpr f (Tick t e)              = Tick t (mapExpr f e)-mapExpr _  e                      = e--mapAlt :: (b -> Expr b -> Expr b) -> (t, t1, Expr b) -> (t, t1, Expr b)-mapAlt f (d, bs, e) = (d, bs, mapExpr f e)---- Do not apply transformations to inner code--mapBdM :: Monad m => t -> a -> m a-mapBdM _ = return---- mapBdM f (Let b e)        = liftM2 Let (f b) (mapBdM f e)--- mapBdM f (App e1 e2)      = liftM2 App (mapBdM f e1) (mapBdM f e2)--- mapBdM f (Lam b e)        = liftM (Lam b) (mapBdM f e)--- mapBdM f (Case e b t alt) = liftM (Case e b t) (mapM (mapBdAltM f) alt)--- mapBdM f (Tick t e)       = liftM (Tick t) (mapBdM f e)--- mapBdM _  e               = return  e------ mapBdAltM f (d, bs, e) = liftM ((,,) d bs) (mapBdM f e)
− src/Language/Haskell/Liquid/Transforms/RefSplit.hs 
@@ -1,120 +0,0 @@-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE UndecidableInstances #-}--{-# OPTIONS_GHC -Wno-orphans #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-}--module Language.Haskell.Liquid.Transforms.RefSplit (--        splitXRelatedRefs--        ) where--import Prelude hiding (error)--import Data.List (partition)-import Text.PrettyPrint.HughesPJ--import Language.Haskell.Liquid.Types-import Language.Haskell.Liquid.Types.PrettyPrint ()--import Language.Fixpoint.Types hiding (Predicate)-import Language.Fixpoint.Misc--splitXRelatedRefs :: Symbol -> SpecType -> (SpecType, SpecType)-splitXRelatedRefs x t = splitRType x t----splitRType :: Symbol-           -> RType c tv (UReft Reft)-           -> (RType c tv (UReft Reft), RType c tv (UReft Reft))-splitRType f (RVar a r) = (RVar a r1, RVar a r2)-  where-        (r1, r2) = splitRef f r-splitRType f (RImpF x i tx t r) = (RImpF x i tx1 t1 r1, RImpF x i tx2 t2 r2)-  where-        (tx1, tx2) = splitRType f tx-        (t1,  t2)  = splitRType f t-        (r1,  r2)  = splitRef   f r-splitRType f (RFun x i tx t r) = (RFun x i tx1 t1 r1, RFun x i tx2 t2 r2)-  where-        (tx1, tx2) = splitRType f tx-        (t1,  t2)  = splitRType f t-        (r1,  r2)  = splitRef   f r-splitRType f (RAllT v t r) = (RAllT v t1 r1, RAllT v t2 r2)-  where-        (t1, t2) = splitRType f t-        (r1,  r2)  = splitRef   f r-splitRType f (RAllP p t) = (RAllP p t1, RAllP p t2)-  where-        (t1, t2) = splitRType f t-splitRType f (RApp c ts rs r) = (RApp c ts1 rs1 r1, RApp c ts2 rs2 r2)-  where-        (ts1, ts2) = unzip (splitRType f <$> ts)-        (rs1, rs2) = unzip (splitUReft f <$> rs)-        (r1,  r2)  = splitRef f r-splitRType f (RAllE x tx t) = (RAllE x tx1 t1, RAllE x tx2 t2)-  where-        (tx1, tx2) = splitRType f tx-        (t1, t2)   = splitRType f t-splitRType f (REx x tx t) = (REx x tx1 t1, REx x tx2 t2)-  where-        (tx1, tx2) = splitRType f tx-        (t1, t2)   = splitRType f t-splitRType _ (RExprArg e) = (RExprArg e, RExprArg e)-splitRType f (RAppTy tx t r) = (RAppTy tx1 t1 r1, RAppTy tx2 t2 r2)-  where-        (tx1, tx2) = splitRType f tx-        (t1,  t2)  = splitRType f t-        (r1,  r2)  = splitRef   f r-splitRType f (RRTy xs r o t) = (RRTy xs1 r1 o t1, RRTy xs2 r2 o t2)-  where-        (xs1, xs2) = unzip (go <$> xs)-        (r1, r2) = splitRef   f r-        (t1, t2) = splitRType f t--        go (x, t) = let (t1, t2) = splitRType f t in ((x,t1), (x, t2))-splitRType f (RHole r) = (RHole r1, RHole r2)-  where-        (r1, r2) = splitRef f r---splitUReft :: Symbol -> RTProp c tv (UReft Reft) -> (RTProp c tv (UReft Reft), RTProp c tv (UReft Reft))-splitUReft x (RProp xs (RHole r)) = (RProp xs (RHole r1), RProp xs (RHole r2))-  where-        (r1, r2) = splitRef x r-splitUReft x (RProp xs t) = (RProp xs t1, RProp xs t2)-  where-        (t1, t2) = splitRType x t--splitRef :: Symbol -> UReft Reft -> (UReft Reft, UReft Reft)-splitRef f (MkUReft r p) = (MkUReft r1 p1, MkUReft r2 p2)-        where-                (r1, r2) = splitReft f r-                (p1, p2) = splitPred f p--splitReft :: Symbol -> Reft -> (Reft, Reft)-splitReft f (Reft (v, xs)) = (Reft (v, pAnd xs1), Reft (v, pAnd xs2))-  where-    (xs1, xs2)       = partition (isFree f) (unPAnd xs)--    unPAnd (PAnd ps) = concatMap unPAnd ps-    unPAnd p         = [p]---splitPred :: Symbol -> Predicate -> (Predicate, Predicate)-splitPred f (Pr ps) = (Pr ps1, Pr ps2)-  where-    (ps1, ps2) = partition g ps-    g p = any (isFree f) (thd3 <$> pargs p)---class IsFree a where-        isFree :: Symbol -> a -> Bool--instance (Subable x) => (IsFree x) where-        isFree x p = x `elem` syms p--instance Show (UReft Reft) where-         show = render . pprint
− src/Language/Haskell/Liquid/Transforms/Rewrite.hs 
@@ -1,504 +0,0 @@-{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE UndecidableInstances      #-}-{-# LANGUAGE FlexibleContexts          #-}--{-# OPTIONS_GHC -Wno-name-shadowing #-}---- | This module contains functions for recursively "rewriting"---   GHC core using "rules".--module Language.Haskell.Liquid.Transforms.Rewrite-  ( -- * Top level rewrite function-    rewriteBinds--  -- * Low-level Rewriting Function-  -- , rewriteWith--  -- * Rewrite Rule-  -- ,  RewriteRule--  ) where--import           Liquid.GHC.API as Ghc hiding (showPpr, substExpr)-import           Liquid.GHC.TypeRep ()-import           Data.Maybe     (fromMaybe)-import           Control.Monad.State hiding (lift)-import           Language.Fixpoint.Misc       ({- mapFst, -}  mapSnd)-import qualified          Language.Fixpoint.Types as F-import           Language.Haskell.Liquid.Misc (safeZipWithError, mapThd3, Nat)-import           Liquid.GHC.Play (substExpr)-import           Liquid.GHC.Resugar-import           Liquid.GHC.Misc (unTickExpr, isTupleId, showPpr, mkAlive) -- , showPpr, tracePpr)-import           Language.Haskell.Liquid.UX.Config  (Config, noSimplifyCore)-import qualified Data.List as L-import qualified Data.HashMap.Strict as M------------------------------------------------------------------------------------- | Top-level rewriter ------------------------------------------------------------------------------------------------------------------------------------------rewriteBinds :: Config -> [CoreBind] -> [CoreBind]-rewriteBinds cfg-  | simplifyCore cfg-  = fmap (normalizeTuples -       . rewriteBindWith undollar -       . rewriteBindWith tidyTuples -       . rewriteBindWith simplifyPatTuple)-  | otherwise-  = id--simplifyCore :: Config -> Bool-simplifyCore = not . noSimplifyCore--undollar :: RewriteRule-undollar = go -  where -    go e -     -- matches `$ t1 t2 t3 f a`  -     | App e1 a  <- untick e-     , App e2 f  <- untick e1-     , App e3 t3 <- untick e2 -     , App e4 t2 <- untick e3 -     , App d t1  <- untick e4 -     , Var v     <- untick d -     , v `hasKey` dollarIdKey-     , Type _    <- untick t1-     , Type _    <- untick t2-     , Type _    <- untick t3-     = Just $ App f a -    go (Tick t e)-      = Tick t <$> go e-    go (Let (NonRec x ex) e)-      = do ex' <- go ex-           e'  <- go e-           return $ Let (NonRec x ex') e'-    go (Let (Rec bes) e)-      = Let <$> (Rec <$> mapM goRec bes) <*> go e-    go (Case e x t alts)-      = Case e x t <$> mapM goAlt alts-    go (App e1 e2)-      = App <$> go e1 <*> go e2-    go (Lam x e)-      = Lam x <$> go e-    go (Cast e c)-      = (`Cast` c) <$> go e-    go e-      = return e--    goRec (x, e)-      = (x,) <$> go e--    goAlt (c, bs, e)-      = (c, bs,) <$> go e--  - --untick :: CoreExpr -> CoreExpr -untick (Tick _ e) = untick e -untick e          = e --tidyTuples :: RewriteRule-tidyTuples e = Just $ evalState (go e) []-  where-    go (Tick t e)-      = Tick t <$> go e-    go (Let (NonRec x ex) e)-      = do ex' <- go ex-           e'  <- go e-           return $ Let (NonRec x ex') e'-    go (Let (Rec bes) e)-      = Let <$> (Rec <$> mapM goRec bes) <*> go e-    go (Case (Var v) x t alts)-      = Case (Var v) x t <$> mapM (goAltR v) alts-    go (Case e x t alts)-      = Case e x t <$> mapM goAlt alts-    go (App e1 e2)-      = App <$> go e1 <*> go e2-    go (Lam x e)-      = Lam x <$> go e-    go (Cast e c)-      = (`Cast` c) <$> go e-    go e-      = return e--    goRec (x, e)-      = (x,) <$> go e--    goAlt (c, bs, e)-      = (c, bs,) <$> go e--    goAltR v (c, bs, e)-      = do m <- get-           case L.lookup (c,v) m of-            Just bs' -> return (c, bs', substTuple bs' bs e)-            Nothing  -> do let bs' = mkAlive <$> bs-                           modify (((c,v),bs'):)-                           return (c, bs', e)----normalizeTuples :: CoreBind -> CoreBind-normalizeTuples b-  | NonRec x e <- b-  = NonRec x $ go e-  | Rec xes <- b-  = let (xs,es) = unzip xes in-    Rec $ zip xs (go <$> es)-  where-    go (Let (NonRec x ex) e)-      | Case _ _ _ alts  <- unTickExpr ex-      , [(_, vs, Var z)] <- alts-      , z `elem` vs-      = Let (NonRec z (go ex)) (substTuple [z] [x] (go e))-    go (Let (NonRec x ex) e)-      = Let (NonRec x (go ex)) (go e)-    go (Let (Rec xes) e)-      = Let (Rec (mapSnd go <$> xes)) (go e)-    go (App e1 e2)-      = App (go e1) (go e2)-    go (Lam x e)-      = Lam x (go e)-    go (Case e b t alt)-      = Case (go e) b t (mapThd3 go <$> alt)-    go (Cast e c)-      = Cast (go e) c-    go (Tick t e)-      = Tick t (go e)-    go (Type t)-      = Type t-    go (Coercion c)-      = Coercion c-    go (Lit l)-      = Lit l-    go (Var x)-      = Var x-------------------------------------------------------------------------------------- | A @RewriteRule@ is a function that maps a CoreExpr to another----------------------------------------------------------------------------------type RewriteRule = CoreExpr -> Maybe CoreExpr--------------------------------------------------------------------------------------------------------------------------------------------------------------------rewriteBindWith :: RewriteRule -> CoreBind -> CoreBind----------------------------------------------------------------------------------rewriteBindWith r (NonRec x e) = NonRec x (rewriteWith r e)-rewriteBindWith r (Rec xes)    = Rec    (mapSnd (rewriteWith r) <$> xes)-----------------------------------------------------------------------------------rewriteWith :: RewriteRule -> CoreExpr -> CoreExpr----------------------------------------------------------------------------------rewriteWith tx           = go-  where-    go                   = txTop . step-    txTop e              = fromMaybe e (tx e)-    goB (Rec xes)        = Rec         (mapSnd go <$> xes)-    goB (NonRec x e)     = NonRec x    (go e)-    step (Let b e)       = Let (goB b) (go e)-    step (App e e')      = App (go e)  (go e')-    step (Lam x e)       = Lam x       (go e)-    step (Cast e c)      = Cast (go e) c-    step (Tick t e)      = Tick t      (go e)-    step (Case e x t cs) = Case (go e) x t (mapThd3 go <$> cs)-    step e@(Type _)      = e-    step e@(Lit _)       = e-    step e@(Var _)       = e-    step e@(Coercion _)  = e-------------------------------------------------------------------------------------- | Rewriting Pattern-Match-Tuples -------------------------------------------------------------------------------------------------------------------------------{--    let CrazyPat x1 ... xn = e in e'--    let t : (t1,...,tn) = "CrazyPat e ... (y1, ..., yn)"-        xn = Proj t n-        ...-        x1 = Proj t 1-    in-        e'--    "crazy-pat"- -}--{- [NOTE] The following is the structure of a @PatMatchTup@--      let x :: (t1,...,tn) = E[(x1,...,xn)]-          yn = case x of (..., yn) -> yn-          …-          y1 = case x of (y1, ...) -> y1-      in-          E'--  GOAL: simplify the above to:--      E [ (x1,...,xn) := E' [y1 := x1,...,yn := xn] ]--  TODO: several tests (e.g. tests/pos/zipper000.hs) fail because-  the above changes the "type" the expression `E` and in "other branches"-  the new type may be different than the old, e.g.--     let (x::y::_) = e in-     x + y--     let t = case e of-               h1::t1 -> case t1 of-                            (h2::t2) ->  (h1, h2)-                            DEFAULT  ->  error @ (Int, Int)-               DEFAULT   -> error @ (Int, Int)-         x = case t of (h1, _) -> h1-         y = case t of (_, h2) -> h2-     in-         x + y--  is rewritten to:--              h1::t1    -> case t1 of-                            (h2::t2) ->  h1 + h2-                            DEFAULT  ->  error @ (Int, Int)-              DEFAULT   -> error @ (Int, Int)--     case e of-       h1 :: h2 :: _ -> h1 + h2-       DEFAULT       -> error @ (Int, Int)--  which, alas, is ill formed.---}-------------------------------------------------------------------------------------- simplifyPatTuple :: RewriteRule--- simplifyPatTuple e =---  case simplifyPatTuple' e of---    Just e' -> if Ghc.exprType e == Ghc.exprType e'---                 then Just e'---                 else Just (tracePpr ("YIKES: RWR " ++ showPpr e) e')---    Nothing -> Nothing---_safeSimplifyPatTuple :: RewriteRule-_safeSimplifyPatTuple e-  | Just e' <- simplifyPatTuple e-  , Ghc.exprType e' == Ghc.exprType e-  = Just e'-  | otherwise-  = Nothing-----------------------------------------------------------------------------------simplifyPatTuple :: RewriteRule-----------------------------------------------------------------------------------_tidyAlt :: Int -> Maybe CoreExpr -> Maybe CoreExpr--_tidyAlt n (Just (Let (NonRec x e) rest))-  | Just (yes, e') <- takeBinds n rest-  = Just $ Let (NonRec x e) $ foldl (\e (x, ex) -> Let (NonRec x ex) e) e' (reverse $ go $ reverse yes)--  where-    go xes@((_, e):_) = let bs = grapBinds e in mapSnd (replaceBinds bs) <$> xes-    go [] = []-    replaceBinds bs (Case c x t alt) = Case c x t (replaceBindsAlt bs <$> alt)-    replaceBinds bs (Tick t e)       = Tick t (replaceBinds bs e)-    replaceBinds _ e                 = e-    replaceBindsAlt bs (c, _, e)     = (c, bs, e)--    grapBinds (Case _ _ _ alt) = grapBinds' alt-    grapBinds (Tick _ e) = grapBinds e-    grapBinds _ = []-    grapBinds' [] = []-    grapBinds' ((_,bs,_):_) = bs--_tidyAlt _ e-  = e--simplifyPatTuple (Let (NonRec x e) rest)-  | Just (n, ts  ) <- varTuple x-  , 2 <= n-  , Just (yes, e') <- takeBinds n rest-  , let ys          = fst <$> yes-  , Just _         <- hasTuple ys e-  , matchTypes yes ts-  = replaceTuple ys e e'--simplifyPatTuple _-  = Nothing--varTuple :: Var -> Maybe (Int, [Type])-varTuple x-  | TyConApp c ts <- Ghc.varType x-  , isTupleTyCon c-  = Just (length ts, ts)-  | otherwise-  = Nothing--takeBinds  :: Nat -> CoreExpr -> Maybe ([(Var, CoreExpr)], CoreExpr)-takeBinds n e-  | n < 2     = Nothing-  | otherwise = {- mapFst reverse <$> -} go n e-    where-      go 0 e                      = Just ([], e)-      go n (Let (NonRec x e) e')  = do (xes, e'') <- go (n-1) e'-                                       Just ((x,e) : xes, e'')-      go _ _                      = Nothing--matchTypes :: [(Var, CoreExpr)] -> [Type] -> Bool-matchTypes xes ts =  xN == tN-                  && all (uncurry eqType) (safeZipWithError msg xts ts)-                  && all isProjection es-  where-    xN            = length xes-    tN            = length ts-    xts           = Ghc.varType <$> xs-    (xs, es)      = unzip xes-    msg           = "RW:matchTypes"--isProjection :: CoreExpr -> Bool-isProjection e = case lift e of-                   Just PatProject{} -> True-                   _                 -> False------------------------------------------------------------------------------------- | `hasTuple ys e` CHECKS if `e` contains a tuple that "looks like" (y1...yn)----------------------------------------------------------------------------------hasTuple :: [Var] -> CoreExpr -> Maybe [Var]----------------------------------------------------------------------------------hasTuple ys = stepE-  where-    stepE e-     | Just xs <- isVarTup ys e = Just xs-     | otherwise                = go e-    stepA (DEFAULT,_,_)         = Nothing-    stepA (_, _, e)             = stepE e-    go (Let _ e)                = stepE e-    go (Case _ _ _ cs)          = msum (stepA <$> cs)-    go _                        = Nothing------------------------------------------------------------------------------------- | `replaceTuple ys e e'` REPLACES tuples that "looks like" (y1...yn) with e'-----------------------------------------------------------------------------------replaceTuple :: [Var] -> CoreExpr -> CoreExpr -> Maybe CoreExpr-replaceTuple ys e e'           = stepE e-  where-    t'                          = Ghc.exprType e'-    stepE e-     | Just xs <- isVarTup ys e = Just $ substTuple xs ys e'-     | otherwise                = go e-    stepA (DEFAULT, xs, err)    = Just (DEFAULT, xs, replaceIrrefutPat t' err)-    stepA (c, xs, e)            = (c, xs,)   <$> stepE e-    go (Let b e)                = Let b      <$> stepE e-    go (Case e x t cs)          = fixCase e x t <$> mapM stepA cs-    go _                        = Nothing--_showExpr :: CoreExpr -> String-_showExpr e = show' e-  where-    show' (App e1 e2) = show' e1 ++ " " ++ show' e2-    show' (Var x)     = _showVar x-    show' (Let (NonRec x ex) e) = "Let " ++ _showVar x ++ " = " ++ show' ex ++ "\nIN " ++ show' e-    show' (Tick _ e) = show' e-    show' (Case e x _ alt) = "Case " ++ _showVar x ++ " = " ++ show' e ++ " OF " ++ unlines (showAlt' <$> alt)-    show' e           = showPpr e--    showAlt' (c, bs, e) = showPpr c ++ unwords (_showVar <$> bs) ++ " -> " ++ show' e--_showVar :: Var -> String-_showVar = show . F.symbol--_errorSkip :: String -> a -> b-_errorSkip x _ = error x---- replaceTuple :: [Var] -> CoreExpr -> CoreExpr -> Maybe CoreExpr--- replaceTuple ys e e' = tracePpr msg (_replaceTuple ys e e')---  where---    msg = "replaceTuple: ys = " ++ showPpr ys ++---                        " e = " ++ showPpr e  ++---                        " e' =" ++ showPpr e'---- | The substitution (`substTuple`) can change the type of the overall---   case-expression, so we must update the type of each `Case` with its---   new, possibly updated type. See:---   https://github.com/ucsd-progsys/liquidhaskell/pull/752#issuecomment-228946210--fixCase :: CoreExpr -> Var -> Type -> ListNE (Alt Var) -> CoreExpr-fixCase e x _t cs' = Case e x t' cs'-  where-    t'            = Ghc.exprType body-    (_,_,body)    = c-    c:_           = cs'--{-@  type ListNE a = {v:[a] | len v > 0} @-}-type ListNE a = [a]--replaceIrrefutPat :: Type -> CoreExpr -> CoreExpr-replaceIrrefutPat t (App (Lam z e) eVoid)-  | Just e' <- replaceIrrefutPat' t e-  = App (Lam z e') eVoid--replaceIrrefutPat t e-  | Just e' <- replaceIrrefutPat' t e-  = e'--replaceIrrefutPat _ e-  = e--replaceIrrefutPat' :: Type -> CoreExpr -> Maybe CoreExpr-replaceIrrefutPat' t e-  | (Var x, rep:_:args) <- collectArgs e-  , isIrrefutErrorVar x-  = Just (Ghc.mkCoreApps (Var x) (rep : Type t : args))-  | otherwise-  = Nothing--isIrrefutErrorVar :: Var -> Bool--- isIrrefutErrorVar _x = False -- Ghc.iRREFUT_PAT_ERROR_ID == x -- TODO:GHC-863-isIrrefutErrorVar x = x == Ghc.pAT_ERROR_ID------------------------------------------------------------------------------------- | `substTuple xs ys e'` returns e' [y1 := x1,...,yn := xn]----------------------------------------------------------------------------------substTuple :: [Var] -> [Var] -> CoreExpr -> CoreExpr-substTuple xs ys = substExpr (M.fromList $ zip ys xs)------------------------------------------------------------------------------------- | `isVarTup xs e` returns `Just ys` if e == (y1, ... , yn) and xi ~ yi-----------------------------------------------------------------------------------isVarTup :: [Var] -> CoreExpr -> Maybe [Var]-isVarTup xs e-  | Just ys <- isTuple e-  , eqVars xs ys        = Just ys-isVarTup _ _             = Nothing--eqVars :: [Var] -> [Var] -> Bool-eqVars xs ys = {- F.tracepp ("eqVars: " ++ show xs' ++ show ys') -} xs' == ys'-  where-    xs' = {- F.symbol -} show <$> xs-    ys' = {- F.symbol -} show <$> ys--isTuple :: CoreExpr -> Maybe [Var]-isTuple e-  | (Var t, es) <- collectArgs e-  , isTupleId t-  , Just xs     <- mapM isVar (secondHalf es)-  = Just xs-  | otherwise-  = Nothing--isVar :: CoreExpr -> Maybe Var-isVar (Var x) = Just x-isVar _       = Nothing--secondHalf :: [a] -> [a]-secondHalf xs = drop (n `div` 2) xs-  where-    n         = length xs
− src/Language/Haskell/Liquid/Transforms/Simplify.hs 
@@ -1,43 +0,0 @@-module Language.Haskell.Liquid.Transforms.Simplify (simplifyBounds) where--import Prelude hiding (error)-import Language.Haskell.Liquid.Types-import Language.Fixpoint.Types-import Language.Fixpoint.Types.Visitor--- import Control.Applicative                 ((<$>))---simplifyBounds :: SpecType -> SpecType-simplifyBounds = fmap go-  where-    go x       = x { ur_reft = go' $ ur_reft x }-    -- OLD go' (Reft (v, rs)) = Reft(v, filter (not . isBoundLike) rs)-    go' (Reft (v, p)) = Reft(v, dropBoundLike p)--dropBoundLike :: Expr -> Expr-dropBoundLike p-  | isKvar p          = p-  | isBoundLikePred p = mempty-  | otherwise         = p-  where-    isKvar            = not . null . kvarsExpr--isBoundLikePred :: Expr -> Bool-isBoundLikePred (PAnd ps) = simplifyLen <= length [p | p <- ps, isImp p ]-isBoundLikePred _         = False--isImp :: Expr -> Bool-isImp (PImp _ _) = True-isImp _          = False---- OLD isBoundLike (RConc pred)  = isBoundLikePred pred--- OLD isBoundLike (RKvar _ _)   = False----- OLD moreThan 0 _            = True--- OLD moreThan _ []           = False--- OLD moreThan i (True  : xs) = moreThan (i-1) xs--- OLD moreThan i (False : xs) = moreThan i xs--simplifyLen :: Int-simplifyLen = 5
− src/Language/Haskell/Liquid/Types.hs 
@@ -1,17 +0,0 @@--- | This module re-exports a bunch of the Types modules --module Language.Haskell.Liquid.Types (module Types) where --import Language.Haskell.Liquid.Types.Types          as Types-import Language.Haskell.Liquid.Types.Dictionaries   as Types-import Language.Haskell.Liquid.Types.Fresh          as Types-import Language.Haskell.Liquid.Types.Meet           as Types-import Language.Haskell.Liquid.Types.PredType       as Types-import Language.Haskell.Liquid.Types.RefType        as Types-import Language.Haskell.Liquid.Types.Variance       as Types-import Language.Haskell.Liquid.Types.Bounds         as Types-import Language.Haskell.Liquid.Types.Literals       as Types-import Language.Haskell.Liquid.Types.Names          as Types-import Language.Haskell.Liquid.Types.PrettyPrint    as Types-import Language.Haskell.Liquid.Types.Specs          as Types-import Language.Haskell.Liquid.Types.Visitors       as Types
− src/Language/Haskell/Liquid/Types/Bounds.hs 
@@ -1,162 +0,0 @@-{-# LANGUAGE FlexibleContexts   #-}-{-# LANGUAGE TupleSections      #-}-{-# LANGUAGE OverloadedStrings  #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}--{-# OPTIONS_GHC -Wno-name-shadowing #-}--module Language.Haskell.Liquid.Types.Bounds (--    Bound(..),--    RBound, RRBound,--    RBEnv, RRBEnv,--    makeBound,--    ) where--import Prelude hiding (error)-import Text.PrettyPrint.HughesPJ-import GHC.Generics-import Data.List (partition)-import Data.Maybe-import Data.Hashable-import Data.Bifunctor-import Data.Data-import qualified Data.Binary         as B-import qualified Data.HashMap.Strict as M--import qualified Language.Fixpoint.Types as F-import qualified Language.Fixpoint.Misc  as Misc -- (mapFst, mapSnd)-import Language.Haskell.Liquid.Types.Types-import Language.Haskell.Liquid.Types.RefType---data Bound t e = Bound-  { bname   :: LocSymbol         -- ^ The name of the bound-  , tyvars  :: [t]               -- ^ Type variables that appear in the bounds-  , bparams :: [(LocSymbol, t)]  -- ^ These are abstract refinements, for now-  , bargs   :: [(LocSymbol, t)]  -- ^ These are value variables-  , bbody   :: e                 -- ^ The body of the bound-  } deriving (Data, Typeable, Generic)--instance (B.Binary t, B.Binary e) => B.Binary (Bound t e)--type RBound        = RRBound RSort-type RRBound tv    = Bound tv F.Expr-type RBEnv         = M.HashMap LocSymbol RBound-type RRBEnv tv     = M.HashMap LocSymbol (RRBound tv)---instance Hashable (Bound t e) where-  hashWithSalt i = hashWithSalt i . bname--instance Eq (Bound t e) where-  b1 == b2 = bname b1 == bname b2--instance (PPrint e, PPrint t) => (Show (Bound t e)) where-  show = showpp---instance (PPrint e, PPrint t) => (PPrint (Bound t e)) where-  pprintTidy k (Bound s vs ps xs e) = "bound" <+> pprintTidy k s <+>-                                      "forall" <+> pprintTidy k vs <+> "." <+>-                                      pprintTidy k (fst <$> ps) <+> "=" <+>-                                      ppBsyms k (fst <$> xs) <+> pprintTidy k e-    where-      ppBsyms _ [] = ""-      ppBsyms k xs = "\\" <+> pprintTidy k xs <+> "->"--instance Bifunctor Bound where-  first  f (Bound s vs ps xs e) = Bound s (f <$> vs) (Misc.mapSnd f <$> ps) (Misc.mapSnd f <$> xs) e-  second f (Bound s vs ps xs e) = Bound s vs ps xs (f e)--makeBound :: (PPrint r, UReftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r)-          => RRBound RSort -> [RRType r] -> [F.Symbol] -> RRType r -> RRType r-makeBound (Bound _  vs ps xs p) ts qs-         = RRTy cts mempty OCons-  where-    cts  = (\(x, t) -> (x, foldr subsTyVarMeet t su)) <$> cts'--    cts' = makeBoundType penv rs xs--    penv = zip (val . fst <$> ps) qs-    rs   = bkImp [] p--    bkImp acc (F.PImp p q) = bkImp (p:acc) q-    bkImp acc p          = p:acc--    su  = [(α, toRSort t, t) | (RVar α _, t) <-  zip vs ts ]--makeBoundType :: (PPrint r, UReftable r)-              => [(F.Symbol, F.Symbol)]-              -> [F.Expr]-              -> [(LocSymbol, RSort)]-              -> [(F.Symbol, RRType r)]-makeBoundType penv (q:qs) xts = go xts-  where-    -- NV TODO: Turn this into a proper error-    go [] = panic Nothing "Bound with empty symbols"--    go [(x, t)]      = [(F.dummySymbol, tp t x), (F.dummySymbol, tq t x)]-    go ((x, t):xtss) = (val x, mkt t x) : go xtss--    mkt t x = ofRSort t `strengthen` ofUReft (MkUReft (F.Reft (val x, mempty))-                                                (Pr $ M.lookupDefault [] (val x) ps))-    tp t x  = ofRSort t `strengthen` ofUReft (MkUReft (F.Reft (val x, F.pAnd rs))-                                                (Pr $ M.lookupDefault [] (val x) ps))-    tq t x  = ofRSort t `strengthen` makeRef penv x q--    (ps, rs) = partitionPs penv qs----- NV TODO: Turn this into a proper error-makeBoundType _ _ _           = panic Nothing "Bound with empty predicates"---partitionPs :: [(F.Symbol, F.Symbol)] -> [F.Expr] -> (M.HashMap F.Symbol [UsedPVar], [F.Expr])-partitionPs penv qs = Misc.mapFst makeAR $ partition (isPApp penv) qs-  where-    makeAR ps       = M.fromListWith (++) $ map (toUsedPVars penv) ps--isPApp :: [(F.Symbol, a)] -> F.Expr -> Bool-isPApp penv (F.EApp (F.EVar p) _)  = isJust $ lookup p penv-isPApp penv (F.EApp e _)         = isPApp penv e-isPApp _    _                  = False--toUsedPVars :: [(F.Symbol, F.Symbol)] -> F.Expr -> (F.Symbol, [PVar ()])-toUsedPVars penv q@(F.EApp _ e) = (x, [toUsedPVar penv q])-  where-    -- NV : TODO make this a better error-    x = case {- unProp -} e of {F.EVar x -> x; e -> todo Nothing ("Bound fails in " ++ show e) }-toUsedPVars _ _ = impossible Nothing "This cannot happen"--toUsedPVar :: [(F.Symbol, F.Symbol)] -> F.Expr -> PVar ()-toUsedPVar penv ee@(F.EApp _ _)-  = PV q (PVProp ()) e (((), F.dummySymbol,) <$> es')-   where-     F.EVar e = {- unProp $ -} last es-     es'    = init es-     Just q = lookup p penv-     (F.EVar p, es) = F.splitEApp ee--toUsedPVar _ _ = impossible Nothing "This cannot happen"---- `makeRef` is used to make the refinement of the last implication,--- thus it can contain both concrete and abstract refinements--makeRef :: (UReftable r) => [(F.Symbol, F.Symbol)] -> LocSymbol -> F.Expr -> r-makeRef penv v (F.PAnd rs) = ofUReft (MkUReft (F.Reft (val v, F.pAnd rrs)) r)-  where-    r                    = Pr  (toUsedPVar penv <$> pps)-    (pps, rrs)           = partition (isPApp penv) rs--makeRef penv v rr-  | isPApp penv rr       = ofUReft (MkUReft (F.Reft(val v, mempty)) r)-  where-    r                    = Pr [toUsedPVar penv rr]--makeRef _    v p         = F.ofReft (F.Reft (val v, p))
− src/Language/Haskell/Liquid/Types/Dictionaries.hs 
@@ -1,95 +0,0 @@-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleContexts     #-}-module Language.Haskell.Liquid.Types.Dictionaries (-    makeDictionaries-  , makeDictionary-  , dfromList-  , dmapty-  , dmap-  , dinsert-  , dlookup-  , dhasinfo-  , fromRISig-  ) where--import           Data.Hashable--- import           Data.Maybe (catMaybes)--import           Prelude                                   hiding (error)-import qualified Language.Fixpoint.Types as F-import           Language.Haskell.Liquid.Types.PrettyPrint ()-import qualified Liquid.GHC.Misc       as GM-import qualified Liquid.GHC.API        as Ghc-import           Language.Haskell.Liquid.Types.Types--- import           Language.Haskell.Liquid.Types.Visitors (freeVars)-import           Language.Haskell.Liquid.Types.RefType ()-import           Language.Fixpoint.Misc                (mapFst)-import qualified Data.HashMap.Strict                       as M------makeDictionaries :: [RInstance LocSpecType] -> DEnv F.Symbol LocSpecType-makeDictionaries = DEnv . M.fromList . map makeDictionary---makeDictionary :: RInstance LocSpecType -> (F.Symbol, M.HashMap F.Symbol (RISig LocSpecType))-makeDictionary (RI c ts xts) = (makeDictionaryName (btc_tc c) ts, M.fromList (mapFst val <$> xts))--makeDictionaryName :: LocSymbol -> [LocSpecType] -> F.Symbol-makeDictionaryName t ts-  = F.notracepp _msg $ F.symbol ("$f" ++ F.symbolString (val t) ++ concatMap mkName ts)-  where-    mkName = makeDicTypeName sp . dropUniv . val-    sp     = GM.fSrcSpan t-    _msg   = "MAKE-DICTIONARY " ++ F.showpp (val t, ts)---- | @makeDicTypeName@ DOES NOT use show/symbol in the @RVar@ case ---   as those functions add the unique-suffix which then breaks the ---   class resolution.--makeDicTypeName :: Ghc.SrcSpan -> SpecType -> String-makeDicTypeName _ RFun{}           = "(->)"-makeDicTypeName _ (RApp c _ _ _)   = F.symbolString . GM.dropModuleNamesCorrect . F.symbol . rtc_tc $ c-makeDicTypeName _ (RVar (RTV a) _) = show (Ghc.getName a)-makeDicTypeName sp t               = panic (Just sp) ("makeDicTypeName: called with invalid type " ++ show t)--dropUniv :: SpecType -> SpecType-dropUniv t = t' where (_,_,t') = bkUniv t------------------------------------------------------------------------------------- | Dictionary Environment ---------------------------------------------------------------------------------------------------------------------------------------dfromList :: [(Ghc.Var, M.HashMap F.Symbol (RISig t))] -> DEnv Ghc.Var t-dfromList = DEnv . M.fromList--dmapty :: (a -> b) -> DEnv v a -> DEnv v b-dmapty f (DEnv e) = DEnv (M.map (M.map (fmap f)) e)---- REBARE: mapRISig :: (a -> b) -> RISig a -> RISig b--- REBARE: mapRISig f (RIAssumed t) = RIAssumed (f t)--- REBARE: mapRISig f (RISig     t) = RISig     (f t)--fromRISig :: RISig a -> a-fromRISig (RIAssumed t) = t-fromRISig (RISig     t) = t--dmap :: (v1 -> v2) -> M.HashMap k v1 -> M.HashMap k v2-dmap f xts = M.map f xts--dinsert :: (Eq x, Hashable x)-        => DEnv x ty -> x -> M.HashMap F.Symbol (RISig ty) -> DEnv x ty-dinsert (DEnv denv) x xts = DEnv $ M.insert x xts denv--dlookup :: (Eq k, Hashable k)-        => DEnv k t -> k -> Maybe (M.HashMap F.Symbol (RISig t))-dlookup (DEnv denv) x     = M.lookup x denv---dhasinfo :: (F.Symbolic a1, Show a) => Maybe (M.HashMap F.Symbol a) -> a1 -> Maybe a-dhasinfo Nothing _    = Nothing-dhasinfo (Just xts) x = M.lookup x' xts-  where-     x'               = GM.dropModuleNamesCorrect (F.symbol x)
− src/Language/Haskell/Liquid/Types/Equality.hs 
@@ -1,87 +0,0 @@-{-# LANGUAGE FlexibleInstances    #-}--{-# OPTIONS_GHC -Wno-name-shadowing #-}---- Syntactic Equality of Types up tp forall type renaming--module Language.Haskell.Liquid.Types.Equality where --import qualified Language.Fixpoint.Types as F-import           Language.Haskell.Liquid.Types-import qualified Liquid.GHC.API as Ghc--import Control.Monad.Writer.Lazy--- import Control.Monad-import qualified Data.List as L--instance REq SpecType where -  t1 =*= t2 = compareRType t1 t2 -  -compareRType :: SpecType -> SpecType -> Bool -compareRType i1 i2 = res && unify vs   -  where -    unify vs = and (sndEq <$> L.groupBy (\(x1,_) (x2,_) -> x1 == x2) vs) -    sndEq [] = True -    sndEq [_] = True -    sndEq ((_,y):xs) = all (==y) (snd <$> xs)--    (res, vs) = runWriter (go i1 i2)-    go :: SpecType -> SpecType -> Writer [(RTyVar, RTyVar)] Bool  -    go (RAllT x1 t1 r1) (RAllT x2 t2 r2)-      | RTV v1 <- ty_var_value x1-      , RTV v2 <- ty_var_value x2 -      , r1 =*= r2-      = go t1 (subt (v2, Ghc.mkTyVarTy v1) t2) --    go (RVar v1 r1) (RVar v2 r2) -      = do tell [(v1, v2)]-           return (r1 =*= r2) -     -- = v1 == v2 && r1 =*= r2 -    go (RFun x1 _ t11 t12 r1) (RFun x2 _ t21 t22 r2)-      | x1 == x2 && r1 =*= r2-      = liftM2 (&&) (go t11 t21) (go t12 t22)-    go (RImpF x1 _ t11 t12 r1) (RImpF x2 _ t21 t22 r2)-      | x1 == x2    && r1 =*= r2-      = liftM2 (&&) (go t11 t21) (go t12 t22)    -    go (RAllP x1 t1) (RAllP x2 t2)-      | x1 == x2 -      = go t1 t2 -    go (RApp x1 ts1 ps1 r1) (RApp x2 ts2 ps2 r2)-      | x1 == x2 &&  -        r1 =*= r2 && and (zipWith (=*=) ps1 ps2) -      = and <$> zipWithM go ts1 ts2-    go (RAllE x1 t11 t12) (RAllE x2 t21 t22) | x1 == x2 -      = liftM2 (&&) (go t11 t21) (go t12 t22) -    go (REx x1 t11 t12) (REx x2 t21 t22) | x1 == x2-      = liftM2 (&&) (go t11 t21) (go t12 t22)-    go (RExprArg e1) (RExprArg e2)-      = return (e1 =*= e2) -    go (RAppTy t11 t12 r1) (RAppTy t21 t22 r2) | r1 =*= r2 -      = liftM2 (&&) (go t11 t21) (go t12 t22)  -    go (RRTy _ _ _ r1) (RRTy _ _ _ r2) -      = return (r1 =*= r2)-    go (RHole r1) (RHole r2)-      = return (r1 =*= r2)  -    go _t1 _t2 -      = return False --class REq a where -  (=*=) :: a -> a -> Bool --instance REq t2 => REq (Ref t1 t2) where-    (RProp _ t1) =*= (RProp _ t2) = t1 =*= t2 --instance REq (UReft F.Reft) where-  (MkUReft r1 p1) =*= (MkUReft r2 p2)-     = r1 =*= r2 && p1 == p2-  -instance REq F.Reft where -  F.Reft (v1, e1) =*= F.Reft (v2, e2) = F.subst1 e1 (v1, F.EVar v2) =*= e2 --instance REq F.Expr where -  e1 =*= e2 = go (F.simplify e1) (F.simplify e2)-    where go r1 r2 = F.notracepp ("comparing " ++ showpp (F.toFix r1, F.toFix r2)) $ r1 == r2 --instance REq r => REq (Located r) where -  t1 =*= t2 = val t1 =*= val t2         -
− src/Language/Haskell/Liquid/Types/Errors.hs 
@@ -1,1091 +0,0 @@-{-# LANGUAGE FlexibleInstances   #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE DeriveGeneric       #-}-{-# LANGUAGE DeriveDataTypeable  #-}-{-# LANGUAGE DeriveFunctor       #-}-{-# LANGUAGE DerivingVia         #-}--{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- TODO(#1918): Only needed for GHC <9.0.1.-{-# OPTIONS_GHC -Wno-orphans #-} -- PPrint and aeson instances.---- | This module contains the *types* related creating Errors.---   It depends only on Fixpoint and basic haskell libraries,---   and hence, should be importable everywhere.--module Language.Haskell.Liquid.Types.Errors (-  -- * Generic Error Type-    TError (..)--  -- * Parse error synonym-  , ParseError--  -- * Error with Source Context-  , CtxError (..)-  , errorsWithContext--  -- * Subtyping Obligation Type-  , Oblig (..)--  -- * Adding a Model of the context-  , WithModel (..), dropModel--  -- * Panic (unexpected failures)-  , UserError-  , panic-  , panicDoc-  , todo-  , impossible-  , uError-  , sourceErrors-  , errDupSpecs--  -- * Printing Errors-  , ppError-  , ppTicks--  -- * SrcSpan Helpers-  , realSrcSpan-  , unpackRealSrcSpan-  , srcSpanFileMb-  ) where--import           Prelude                      hiding (error, span)--import           GHC.Generics-import           Control.DeepSeq-import qualified Control.Exception            as Ex-import           Data.Typeable                (Typeable)-import           Data.Generics                (Data)-import qualified Data.Binary                  as B-import qualified Data.Maybe                   as Mb-import           Data.Aeson                   hiding (Result)-import           Data.Hashable-import qualified Data.HashMap.Strict          as M-import qualified Data.List                    as L-import           Data.Void-import           System.Directory-import           System.FilePath-import           Text.PrettyPrint.HughesPJ-import qualified Text.Megaparsec              as P--import           Liquid.GHC.API as Ghc hiding ( Expr-                                                               , panicDoc-                                                               , ($+$)-                                                               , nest-                                                               , text-                                                               , blankLine-                                                               , (<+>)-                                                               , vcat-                                                               , hsep-                                                               , comma-                                                               , colon-                                                               , parens-                                                               , empty-                                                               , char-                                                               , panic-                                                               , int-                                                               , hcat-                                                               , spans-                                                               )-import           Language.Fixpoint.Types      (pprint, showpp, Tidy (..), PPrint (..), Symbol, Expr, SubcId)-import qualified Language.Fixpoint.Misc       as Misc-import qualified Language.Haskell.Liquid.Misc     as Misc-import           Language.Haskell.Liquid.Misc ((<->))-import           Language.Haskell.Liquid.Types.Generics--type ParseError = P.ParseError String Void--instance PPrint ParseError where-  pprintTidy _ e = vcat $ text <$> ls-    where-      ls         = lines $ P.parseErrorTextPretty e------------------------------------------------------------------------------------- | Context information for Error Messages ----------------------------------------------------------------------------------------------------------------------data CtxError t = CtxError-  { ctErr :: TError t-  , ctCtx :: Doc-  } deriving (Functor)--instance Eq (CtxError t) where-  e1 == e2 = ctErr e1 == ctErr e2-----------------------------------------------------------------------------------errorsWithContext :: [TError Doc] -> IO [CtxError Doc]----------------------------------------------------------------------------------errorsWithContext es-  = Misc.concatMapM fileErrors-  $ Misc.groupList [ (srcSpanFileMb (pos e), e) | e <- es ]--fileErrors :: (Maybe FilePath, [TError Doc]) -> IO [CtxError Doc]-fileErrors (fp, errs) = do-  fb  <- getFileBody fp-  return (errorWithContext fb <$> errs)--errorWithContext :: FileBody -> TError Doc -> CtxError Doc-errorWithContext fb e = CtxError e (srcSpanContext fb (pos e))--srcSpanContext :: FileBody -> SrcSpan -> Doc-srcSpanContext fb sp-  | Just (l, c, l', c') <- srcSpanInfo sp-  = makeContext l c c' (getFileLines fb l l')-  | otherwise-  = empty--srcSpanInfo :: SrcSpan -> Maybe (Int, Int, Int, Int)-srcSpanInfo (RealSrcSpan s _)-              = Just (l, c, l', c')-  where-     l        = srcSpanStartLine s-     c        = srcSpanStartCol  s-     l'       = srcSpanEndLine   s-     c'       = srcSpanEndCol    s-srcSpanInfo _ = Nothing--getFileLines :: FileBody -> Int -> Int -> [String]-getFileLines fb i j = slice (i - 1) (j - 1) fb--getFileBody :: Maybe FilePath -> IO FileBody-getFileBody Nothing  =-  return []-getFileBody (Just f) = do-  b <- doesFileExist f-  if b then lines <$> Misc.sayReadFile f-       else return []--type FileBody = [String]--slice :: Int -> Int -> [a] -> [a]-slice i j xs = take (j - i + 1) (drop i xs)--makeContext :: Int -> Int -> Int -> [String] -> Doc-makeContext _ _ _  []  = empty-makeContext l c c' [s] = makeContext1 l c c' s-makeContext l _ _  ss  = vcat $ text " "-                              : zipWith makeContextLine [l..] ss-                              ++ [ text " "-                                 , text " " ]--makeContextLine :: Int -> String -> Doc-makeContextLine l s = lnum l <+> text s-  where-    lnum n          = text (show n) <+> text "|"--makeContext1 :: Int -> Int -> Int -> String -> Doc-makeContext1 l c c' s = vcat [ text " "-                             , lnum l <+> (text s $+$ cursor)-                             , text " "-                             , text " "-                             ]-  where-    lnum n            = text (show n) <+> text "|"-    cursor            = blanks (c - 1) <-> pointer (max 1 (c' - c))-    blanks n          = text $ replicate n ' '-    pointer n         = text $ replicate n '^'------------------------------------------------------------------------------------- | Different kinds of Check "Obligations" -----------------------------------------------------------------------------------------------------------------------data Oblig-  = OTerm -- ^ Obligation that proves termination-  | OInv  -- ^ Obligation that proves invariants-  | OCons -- ^ Obligation that proves subtyping constraints-  deriving (Eq, Generic, Data, Typeable)-  deriving Hashable via Generically Oblig--instance B.Binary Oblig-instance Show Oblig where-  show OTerm = "termination-condition"-  show OInv  = "invariant-obligation"-  show OCons = "constraint-obligation"--instance NFData Oblig--instance PPrint Oblig where-  pprintTidy _ = ppOblig--ppOblig :: Oblig -> Doc-ppOblig OCons = text "Constraint Check"-ppOblig OTerm = text "Termination Check"-ppOblig OInv  = text "Invariant Check"------------------------------------------------------------------------------------- | Generic Type for Error Messages -------------------------------------------------------------------------------------------------------------------------------- | INVARIANT : all Error constructors should have a pos field--data TError t =-    ErrSubType { pos  :: !SrcSpan-               , msg  :: !Doc-               , cid  :: Maybe SubcId-               , ctx  :: !(M.HashMap Symbol t)-               , tact :: !t-               , texp :: !t-               } -- ^ liquid type error--  | ErrSubTypeModel-               { pos  :: !SrcSpan-               , msg  :: !Doc-               , cid  :: Maybe SubcId-               , ctxM  :: !(M.HashMap Symbol (WithModel t))-               , tactM :: !(WithModel t)-               , texp :: !t-               } -- ^ liquid type error with a counter-example--  | ErrFCrash  { pos  :: !SrcSpan-               , msg  :: !Doc-               , ctx  :: !(M.HashMap Symbol t)-               , tact :: !t-               , texp :: !t-               } -- ^ liquid type error--  | ErrHole    { pos  :: !SrcSpan-               , msg  :: !Doc-               , ctx  :: !(M.HashMap Symbol t)-               , svar :: !Symbol-               , thl  :: !t-               } -- ^ hole type--  | ErrHoleCycle-               { pos  :: !SrcSpan-               , holesCycle :: [Symbol] -- Var?-               } -- ^ hole dependencies form a cycle error--  | ErrAssType { pos  :: !SrcSpan-               , obl  :: !Oblig-               , msg  :: !Doc-               , ctx  :: !(M.HashMap Symbol t)-               , cond :: t-               } -- ^ condition failure error--  | ErrParse    { pos  :: !SrcSpan-                , msg  :: !Doc-                , pErr :: !ParseError-                } -- ^ specification parse error--  | ErrTySpec   { pos :: !SrcSpan-                , knd :: !(Maybe Doc)-                , var :: !Doc-                , typ :: !t-                , msg :: !Doc-                } -- ^ sort error in specification--  | ErrTermSpec { pos  :: !SrcSpan-                , var  :: !Doc-                , msg  :: !Doc-                , exp  :: !Expr-                , typ  :: !t-                , msg' :: !Doc-                } -- ^ sort error in specification--  | ErrDupAlias { pos  :: !SrcSpan-                , var  :: !Doc-                , kind :: !Doc-                , locs :: ![SrcSpan]-                } -- ^ multiple alias with same name error--  | ErrDupSpecs { pos :: !SrcSpan-                , var :: !Doc-                , locs:: ![SrcSpan]-                } -- ^ multiple specs for same binder error--  | ErrDupIMeas { pos   :: !SrcSpan-                , var   :: !Doc-                , tycon :: !Doc-                , locs  :: ![SrcSpan]-                } -- ^ multiple definitions of the same instance measure--  | ErrDupMeas  { pos   :: !SrcSpan-                , var   :: !Doc-                , locs  :: ![SrcSpan]-                } -- ^ multiple definitions of the same measure--  | ErrDupField { pos   :: !SrcSpan-                , dcon  :: !Doc-                , field :: !Doc-                } -- ^ duplicate fields in same datacon--  | ErrDupNames { pos   :: !SrcSpan-                , var   :: !Doc-                , names :: ![Doc]-                } -- ^ name resolves to multiple possible GHC vars--  | ErrBadData  { pos :: !SrcSpan-                , var :: !Doc-                , msg :: !Doc-                } -- ^ bad data type specification (?)--  | ErrDataCon  { pos :: !SrcSpan-                , var :: !Doc-                , msg :: !Doc-                } -- ^ refined datacon mismatches haskell datacon--  | ErrDataConMismatch-                { pos  :: !SrcSpan-                , var  :: !Doc-                , dcs  :: [Doc]-                , rdcs :: [Doc]-                } -- ^ constructors in refinement do not match original datatype--  | ErrInvt     { pos :: !SrcSpan-                , inv :: !t-                , msg :: !Doc-                } -- ^ Invariant sort error--  | ErrIAl      { pos :: !SrcSpan-                , inv :: !t-                , msg :: !Doc-                } -- ^ Using  sort error--  | ErrIAlMis   { pos :: !SrcSpan-                , tAs :: !t-                , tUs :: !t-                , msg :: !Doc-                } -- ^ Incompatible using error--  | ErrMeas     { pos :: !SrcSpan-                , ms  :: !Doc-                , msg :: !Doc-                } -- ^ Measure sort error--  | ErrHMeas    { pos :: !SrcSpan-                , ms  :: !Doc-                , msg :: !Doc-                } -- ^ Haskell bad Measure error--  | ErrUnbound  { pos :: !SrcSpan-                , var :: !Doc-                } -- ^ Unbound symbol in specification--  | ErrUnbPred  { pos :: !SrcSpan-                , var :: !Doc-                } -- ^ Unbound predicate being applied--  | ErrGhc      { pos :: !SrcSpan-                , msg :: !Doc-                } -- ^ GHC error: parsing or type checking--  | ErrResolve  { pos  :: !SrcSpan-                , kind :: !Doc-                , var  :: !Doc-                , msg  :: !Doc-                } -- ^ Name resolution error--  | ErrMismatch { pos   :: !SrcSpan -- ^ haskell type location-                , var   :: !Doc-                , msg   :: !Doc-                , hs    :: !Doc-                , lqTy  :: !Doc-                , diff  :: !(Maybe (Doc, Doc))  -- ^ specific pair of things that mismatch-                , lqPos :: !SrcSpan -- ^ lq type location-                } -- ^ Mismatch between Liquid and Haskell types--  | ErrPartPred { pos  :: !SrcSpan-                , ectr :: !Doc-                , var  :: !Doc-                , argN :: !Int-                , expN :: !Int-                , actN :: !Int-                } -- ^ Mismatch in expected/actual args of abstract refinement--  | ErrAliasCycle { pos    :: !SrcSpan-                  , acycle :: ![(SrcSpan, Doc)]-                  } -- ^ Cyclic Refined Type Alias Definitions--  | ErrIllegalAliasApp { pos   :: !SrcSpan-                       , dname :: !Doc-                       , dpos  :: !SrcSpan-                       } -- ^ Illegal RTAlias application (from BSort, eg. in PVar)--  | ErrAliasApp { pos   :: !SrcSpan-                , dname :: !Doc-                , dpos  :: !SrcSpan-                , msg   :: !Doc-                }--  | ErrTermin   { pos  :: !SrcSpan-                , bind :: ![Doc]-                , msg  :: !Doc-                } -- ^ Termination Error--  | ErrStTerm   { pos  :: !SrcSpan-                , dname :: !Doc-                , msg  :: !Doc-                } -- ^ Termination Error--  | ErrILaw     { pos   :: !SrcSpan-                , cname :: !Doc-                , iname :: !Doc-                , msg   :: !Doc-                } -- ^ Instance Law Error--  | ErrRClass   { pos   :: !SrcSpan-                , cls   :: !Doc-                , insts :: ![(SrcSpan, Doc)]-                } -- ^ Refined Class/Interfaces Conflict--  | ErrMClass   { pos   :: !SrcSpan-                , var   :: !Doc-                } -- ^ Standalone class method refinements--  | ErrBadQual  { pos   :: !SrcSpan-                , qname :: !Doc-                , msg   :: !Doc-                } -- ^ Non well sorted Qualifier--  | ErrSaved    { pos :: !SrcSpan-                , nam :: !Doc-                , msg :: !Doc-                } -- ^ Previously saved error, that carries over after DiffCheck--  | ErrFilePragma { pos :: !SrcSpan-                  }--  | ErrTyCon    { pos    :: !SrcSpan-                , msg    :: !Doc-                , tcname :: !Doc-                }--  | ErrLiftExp  { pos    :: !SrcSpan-                , msg    :: !Doc-                }--  | ErrParseAnn { pos :: !SrcSpan-                , msg :: !Doc-                }--  | ErrNoSpec   { pos  :: !SrcSpan-                , srcF :: !Doc-                , bspF :: !Doc-                }--  | ErrFail     { pos :: !SrcSpan-                , var :: !Doc-                }--  | ErrFailUsed { pos     :: !SrcSpan-                , var     :: !Doc-                , clients :: ![Doc]-                }--  | ErrRewrite  { pos :: !SrcSpan-                , msg :: !Doc-                }--  | ErrPosTyCon { pos  :: SrcSpan-                , tc   :: !Doc-                , dc   :: !Doc-                }---  | ErrOther    { pos   :: SrcSpan-                , msg   :: !Doc-                } -- ^ Sigh. Other.--  deriving (Typeable, Generic , Functor )--errDupSpecs :: Doc -> Misc.ListNE SrcSpan -> TError t-errDupSpecs d spans@(sp:_) = ErrDupSpecs sp d spans-errDupSpecs _ _            = impossible Nothing "errDupSpecs with empty spans!"---- FIXME ES: this is very suspicious, why can't we have multiple errors--- arising from the same span?--instance Eq (TError a) where-  e1 == e2 = errSpan e1 == errSpan e2--errSpan :: TError a -> SrcSpan-errSpan =  pos------------------------------------------------------------------------------------- | Simple unstructured type for panic --------------------------------------------------------------------------------------------------------------------------type UserError  = TError Doc--instance PPrint UserError where-  pprintTidy k = ppError k empty . fmap (pprintTidy Lossy)--data WithModel t-  = NoModel t-  | WithModel !Doc t-  deriving (Functor, Show, Eq, Generic)--instance NFData t => NFData (WithModel t)--dropModel :: WithModel t -> t-dropModel m = case m of-  NoModel t     -> t-  WithModel _ t -> t--instance PPrint SrcSpan where-  pprintTidy _ = pprSrcSpan--pprSrcSpan :: SrcSpan -> Doc-pprSrcSpan (UnhelpfulSpan reason) = text $ case reason of-  UnhelpfulNoLocationInfo -> "UnhelpfulNoLocationInfo"-  UnhelpfulWiredIn        -> "UnhelpfulWiredIn"-  UnhelpfulInteractive    -> "UnhelpfulInteractive"-  UnhelpfulGenerated      -> "UnhelpfulGenerated"-  UnhelpfulOther fs       -> unpackFS fs-pprSrcSpan (RealSrcSpan s _)      = pprRealSrcSpan s--pprRealSrcSpan :: RealSrcSpan -> Doc-pprRealSrcSpan span-  | sline == eline && scol == ecol =-    hcat [ pathDoc <-> colon-         , int sline <-> colon-         , int scol-         ]-  | sline == eline =-    hcat $ [ pathDoc <-> colon-           , int sline <-> colon-           , int scol-           ] ++ [char '-' <-> int (ecol - 1) | (ecol - scol) > 1]-  | otherwise =-    hcat [ pathDoc <-> colon-         , parens (int sline <-> comma <-> int scol)-         , char '-'-         , parens (int eline <-> comma <-> int ecol')-         ]- where-   path  = srcSpanFile      span-   sline = srcSpanStartLine span-   eline = srcSpanEndLine   span-   scol  = srcSpanStartCol  span-   ecol  = srcSpanEndCol    span--   pathDoc = text $ normalise $ unpackFS path-   ecol'   = if ecol == 0 then ecol else ecol - 1--instance Show UserError where-  show = showpp--instance Ex.Exception UserError---- | Construct and show an Error, then crash-uError :: UserError -> a-uError = Ex.throw---- | Construct and show an Error, then crash-panicDoc :: {- (?callStack :: CallStack) => -} SrcSpan -> Doc -> a-panicDoc sp d = Ex.throw (ErrOther sp d :: UserError)---- | Construct and show an Error, then crash-panic :: {- (?callStack :: CallStack) => -} Maybe SrcSpan -> String -> a-panic sp d = panicDoc (sspan sp) (text d)-  where-    sspan  = Mb.fromMaybe noSrcSpan---- | Construct and show an Error with an optional SrcSpan, then crash---   This function should be used to mark unimplemented functionality-todo :: {- (?callStack :: CallStack) => -} Maybe SrcSpan -> String -> a-todo s m  = panic s $ unlines-            [ "This functionality is currently unimplemented. "-            , "If this functionality is critical to you, please contact us at: "-            , "https://github.com/ucsd-progsys/liquidhaskell/issues"-            , m-            ]---- | Construct and show an Error with an optional SrcSpan, then crash---   This function should be used to mark impossible-to-reach codepaths-impossible :: {- (?callStack :: CallStack) => -} Maybe SrcSpan -> String -> a-impossible s m = panic s $ unlines msg ++ m-   where-      msg = [ "This should never happen! If you are seeing this message, "-            , "please submit a bug report at "-            , "https://github.com/ucsd-progsys/liquidhaskell/issues "-            , "with this message and the source file that caused this error."-            , ""-            ]------ type CtxError = Error----------------------------------------------------------------------------------ppError :: (PPrint a, Show a) => Tidy -> Doc -> TError a -> Doc----------------------------------------------------------------------------------ppError k dCtx e = ppError' k dCtx e--nests :: Int -> [Doc] -> Doc-nests n = foldr (\d acc ->  d $+$ nest n acc) empty--- nests n = foldr (\d acc -> nest n (d $+$ acc)) empty--sepVcat :: Doc -> [Doc] -> Doc-sepVcat d ds = vcat $ L.intersperse d ds--blankLine :: Doc-blankLine = sizedText 5 "."--ppFull :: Tidy -> Doc -> Doc-ppFull Full  d = d-ppFull Lossy _ = empty--ppReqInContext :: PPrint t => Tidy -> t -> t -> M.HashMap Symbol t -> Doc-ppReqInContext td tA tE c-  = sepVcat blankLine-      [ nests 2 [ text "The inferred type"-                , text "VV :" <+> pprintTidy td tA]-      , nests 2 [ text "is not a subtype of the required type"-                , text "VV :" <+> pprintTidy td tE]-      , ppContext td c-      ]--ppContext :: PPrint t => Tidy -> M.HashMap Symbol t -> Doc-ppContext td c-  | not (null xts) = nests 2 [ text "in the context"-                             , vsep (map (uncurry (pprintBind td)) xts)-                             ]-  | otherwise      = empty-  where-    xts            = M.toList c--pprintBind :: PPrint t => Tidy -> Symbol -> t -> Doc-pprintBind td v t = pprintTidy td v <+> char ':' <+> pprintTidy td t--ppReqModelInContext-  :: (PPrint t) => Tidy -> WithModel t -> t -> M.HashMap Symbol (WithModel t) -> Doc-ppReqModelInContext td tA tE c-  = sepVcat blankLine-      [ nests 2 [ text "The inferred type"-                , pprintModel td "VV" tA]-      , nests 2 [ text "is not a subtype of the required type"-                , pprintModel td "VV" (NoModel tE)]-      , nests 2 [ text "in the context"-                , vsep (map (uncurry (pprintModel td)) (M.toList c))-                ]-      ]--vsep :: [Doc] -> Doc-vsep = vcat . L.intersperse (char ' ')--pprintModel :: PPrint t => Tidy -> Symbol -> WithModel t -> Doc-pprintModel td v wm = case wm of-  NoModel t-    -> pprintTidy td v <+> char ':' <+> pprintTidy td t-  WithModel m t-    -> pprintTidy td v <+> char ':' <+> pprintTidy td t $+$-       pprintTidy td v <+> char '=' <+> pprintTidy td m--ppPropInContext :: (PPrint p, PPrint c) => Tidy -> p -> c -> Doc-ppPropInContext td p c-  = sepVcat blankLine-      [ nests 2 [ text "Property"-                , pprintTidy td p]-      , nests 2 [ text "Not provable in context"-                , pprintTidy td c-                ]-      ]--instance ToJSON RealSrcSpan where-  toJSON sp = object [ "filename"  .= f-                     , "startLine" .= l1-                     , "startCol"  .= c1-                     , "endLine"   .= l2-                     , "endCol"    .= c2-                     ]-    where-      (f, l1, c1, l2, c2) = unpackRealSrcSpan sp--unpackRealSrcSpan :: RealSrcSpan -> (String, Int, Int, Int, Int)-unpackRealSrcSpan rsp = (f, l1, c1, l2, c2)-  where-    f                 = unpackFS $ srcSpanFile rsp-    l1                = srcSpanStartLine rsp-    c1                = srcSpanStartCol  rsp-    l2                = srcSpanEndLine   rsp-    c2                = srcSpanEndCol    rsp---instance FromJSON RealSrcSpan where-  parseJSON (Object v) = realSrcSpan <$> v .: "filename"-                                     <*> v .: "startLine"-                                     <*> v .: "startCol"-                                     <*> v .: "endLine"-                                     <*> v .: "endCol"-  parseJSON _          = mempty--realSrcSpan :: FilePath -> Int -> Int -> Int -> Int -> RealSrcSpan-realSrcSpan f l1 c1 l2 c2 = mkRealSrcSpan loc1 loc2-  where-    loc1                  = mkRealSrcLoc (fsLit f) l1 c1-    loc2                  = mkRealSrcLoc (fsLit f) l2 c2--srcSpanFileMb :: SrcSpan -> Maybe FilePath-srcSpanFileMb (RealSrcSpan s _) = Just $ unpackFS $ srcSpanFile s-srcSpanFileMb _                 = Nothing---instance ToJSON SrcSpan where-  toJSON (RealSrcSpan rsp _) = object [ "realSpan" .= True, "spanInfo" .= rsp ]-  toJSON (UnhelpfulSpan _)   = object [ "realSpan" .= False ]--instance FromJSON SrcSpan where-  parseJSON (Object v) = do tag <- v .: "realSpan"-                            if tag-                              then RealSrcSpan <$> v .: "spanInfo" <*> pure Nothing-                              else return noSrcSpan-  parseJSON _          = mempty---- Default definition use ToJSON and FromJSON-instance ToJSONKey SrcSpan-instance FromJSONKey SrcSpan--instance (PPrint a, Show a) => ToJSON (TError a) where-  toJSON e = object [ "pos" .= pos e-                    , "msg" .= render (ppError' Full empty e)-                    ]--instance FromJSON (TError a) where-  parseJSON (Object v) = errSaved <$> v .: "pos"-                                  <*> v .: "msg"-  parseJSON _          = mempty--errSaved :: SrcSpan -> String -> TError a-errSaved sp body = ErrSaved sp (text n) (text $ unlines m)-  where-    n : m        = lines body--totalityType :: PPrint a =>  Tidy -> a -> Bool-totalityType td tE = pprintTidy td tE == text "{VV : Addr# | 5 < 4}"--hint :: TError a -> Doc-hint e = maybe empty (\d -> "" $+$ ("HINT:" <+> d)) (go e)-  where-    go ErrMismatch {} = Just "Use the hole '_' instead of the mismatched component (in the Liquid specification)"-    go ErrSubType {}  = Just "Use \"--no-totality\" to deactivate totality checking."-    go ErrNoSpec {}   = Just "Run 'liquid' on the source file first."-    go _              = Nothing-----------------------------------------------------------------------------------ppError' :: (PPrint a, Show a) => Tidy -> Doc -> TError a -> Doc----------------------------------------------------------------------------------ppError' td dCtx (ErrAssType _ o _ c p)-  = pprintTidy td o-        $+$ dCtx-        $+$ ppFull td (ppPropInContext td p c)--ppError' td dCtx err@(ErrSubType _ _ _ _ _ tE)-  | totalityType td tE-  = text "Totality Error"-        $+$ dCtx-        $+$ text "Your function is not total: not all patterns are defined."-        $+$ hint err -- "Hint: Use \"--no-totality\" to deactivate totality checking."--ppError' _td _dCtx (ErrHoleCycle _ holes)-  = "Cycle of holes found"-        $+$ pprint holes--ppError' _td _dCtx (ErrHole _ msg _ x t)-  = "Hole Found"-        $+$ pprint x <+> "::" <+> pprint t-        $+$ msg--ppError' td dCtx (ErrSubType _ _ cid c tA tE)-  = text "Liquid Type Mismatch"-    $+$ nest 4-          (blankLine-           $+$ dCtx-           $+$ ppFull td (ppReqInContext td tA tE c)-           $+$ maybe mempty (\i -> text "Constraint id" <+> text (show i)) cid)--ppError' td dCtx (ErrSubTypeModel _ _ cid c tA tE)-  = text "Liquid Type Mismatch"-    $+$ nest 4-          (dCtx-          $+$ ppFull td (ppReqModelInContext td tA tE c)-          $+$ maybe mempty (\i -> text "Constraint id" <+> text (show i)) cid)--ppError' td  dCtx (ErrFCrash _ _ c tA tE)-  = text "Fixpoint Crash on Constraint"-        $+$ dCtx-        $+$ ppFull td (ppReqInContext td tA tE c)--ppError' _ dCtx (ErrParse _ _ e)-  = text "Cannot parse specification:"-        $+$ dCtx-        $+$ nest 4 (pprint e)--ppError' _ dCtx (ErrTySpec _ _k v t s)-  = ("Illegal type specification for" <+> ppTicks v) --  <-> ppKind k <-> ppTicks v)-  -- = dSp <+> ("Illegal type specification for" <+> _ppKind k <-> ppTicks v)-        $+$ dCtx-        $+$ nest 4 (vcat [ pprint v <+> Misc.dcolon <+> pprint t-                         , pprint s-                         , pprint _k-                         ])-    where-      _ppKind Nothing  = empty-      _ppKind (Just d) = d <-> " "--ppError' _ dCtx (ErrLiftExp _ v)-  = text "Cannot lift" <+> ppTicks v <+> "into refinement logic"-        $+$ dCtx-        $+$ nest 4 (text "Please export the binder from the module to enable lifting.")--ppError' _ dCtx (ErrBadData _ v s)-  = text "Bad Data Specification"-        $+$ dCtx-        $+$ (pprint s <+> "for" <+> ppTicks v)--ppError' _ dCtx (ErrDataCon _ d s)-  = "Malformed refined data constructor" <+> ppTicks d-        $+$ dCtx-        $+$ s--ppError' _ dCtx (ErrDataConMismatch _ d dcs rdcs)-  = text "Data constructors in refinement do not match original datatype for" <+> ppTicks d-        $+$ dCtx-        $+$ nest 4 (text "Constructors in Haskell declaration: " <+> hsep (L.intersperse comma dcs))-        $+$ nest 4 (text "Constructors in refinement         : " <+> hsep (L.intersperse comma rdcs))--ppError' _ dCtx (ErrBadQual _ n d)-  = text "Illegal qualifier specification for" <+> ppTicks n-        $+$ dCtx-        $+$ pprint d--ppError' _ dCtx (ErrTermSpec _ v msg e t s)-  = text "Illegal termination specification for" <+> ppTicks v-        $+$ dCtx-        $+$ nest 4 ((text "Termination metric" <+> ppTicks e <+> text "is" <+> msg <+> "in type signature")-                     $+$ nest 4 (pprint t)-                     $+$ pprint s)--ppError' _ _ (ErrInvt _ t s)-  = text "Bad Invariant Specification"-        $+$ nest 4 (text "invariant " <+> pprint t $+$ pprint s)--ppError' _ _ (ErrIAl _ t s)-  = text "Bad Using Specification"-        $+$ nest 4 (text "as" <+> pprint t $+$ pprint s)--ppError' _ _ (ErrIAlMis _ t1 t2 s)-  = text "Incompatible Using Specification"-        $+$ nest 4 ((text "using" <+> pprint t1 <+> text "as" <+> pprint t2) $+$ pprint s)--ppError' _ _ (ErrMeas _ t s)-  = text "Bad Measure Specification"-        $+$ nest 4 (text "measure " <+> pprint t $+$ pprint s)--ppError' _ dCtx (ErrHMeas _ t s)-  = text "Cannot lift Haskell function" <+> ppTicks t <+> text "to logic"-        $+$ dCtx-        $+$ nest 4 (pprint s)--ppError' _ dCtx (ErrDupSpecs _ v ls)-  = text "Multiple specifications for" <+> ppTicks v <+> colon-        $+$ dCtx-        $+$ ppSrcSpans ls--ppError' _ dCtx (ErrDupIMeas _ v t ls)-  = text "Multiple instance measures" <+> ppTicks v <+> text "for type" <+> ppTicks t-        $+$ dCtx-        $+$ ppSrcSpans ls--ppError' _ dCtx (ErrDupMeas _ v ls)-  = text "Multiple measures named" <+> ppTicks v-        $+$ dCtx-        $+$ ppSrcSpans ls--ppError' _ dCtx (ErrDupField _ dc x)-  = text "Malformed refined data constructor" <+> dc-        $+$ dCtx-        $+$ nest 4 (text "Duplicated definitions for field" <+> ppTicks x)--ppError' _ dCtx (ErrDupNames _ x ns)-  = text "Ambiguous specification symbol" <+> ppTicks x-        $+$ dCtx-        $+$ ppNames ns--ppError' _ dCtx (ErrDupAlias _ k v ls)-  = text "Multiple definitions of" <+> pprint k <+> ppTicks v-        $+$ dCtx-        $+$ ppSrcSpans ls--ppError' _ dCtx (ErrUnbound _ x)-  = text "Unbound variable" <+> pprint x-        $+$ dCtx--ppError' _ dCtx (ErrUnbPred _ p)-  = text "Cannot apply unbound abstract refinement" <+> ppTicks p-        $+$ dCtx--ppError' _ dCtx (ErrGhc _ s)-  = text "GHC Error"-        $+$ dCtx-        $+$ nest 4 (pprint s)--ppError' _ _ (ErrFail _ s)-  = text "Failure Error:"-        $+$ text "Definition of" <+> pprint s <+> text "declared to fail is safe."--ppError' _ _ (ErrFailUsed _ s xs)-  = text "Failure Error:"-        $+$ text "Binder" <+> pprint s <+> text "declared to fail is used by"-        <+> hsep (L.intersperse comma xs)--ppError' _ dCtx (ErrResolve _ kind v msg)-  = (text "Unknown" <+> kind <+> ppTicks v)-        $+$ dCtx-        $+$ nest 4 msg--ppError' _ dCtx (ErrPartPred _ c p i eN aN)-  = text "Malformed predicate application"-        $+$ dCtx-        $+$ nest 4 (vcat-                        [ "The" <+> text (Misc.intToString i) <+> "argument of" <+> c <+> "is predicate" <+> ppTicks p-                        , "which expects" <+> pprint eN <+> "arguments" <+> "but is given only" <+> pprint aN-                        , " "-                        , "Abstract predicates cannot be partially applied; for a possible fix see:"-                        , " "-                        , nest 4 "https://github.com/ucsd-progsys/liquidhaskell/issues/594"-                        ])--ppError' _ dCtx e@(ErrMismatch _ x msg τ t cause hsSp)-  = "Specified type does not refine Haskell type for" <+> ppTicks x <+> parens msg-        $+$ dCtx-        $+$ sepVcat blankLine-              [ "The Liquid type"-              , nest 4 t-              , "is inconsistent with the Haskell type"-              , nest 4 τ-              , "defined at" <+> pprint hsSp-              , maybe empty ppCause cause-              ]-    where-      ppCause (hsD, lqD) = sepVcat blankLine-              [ "Specifically, the Liquid component"-              , nest 4 lqD-              , "is inconsistent with the Haskell component"-              , nest 4 hsD-              , hint e-              ]--ppError' _ dCtx (ErrAliasCycle _ acycle)-  = text "Cyclic type alias definition for" <+> ppTicks n0-        $+$ dCtx-        $+$ nest 4 (sepVcat blankLine (hdr : map describe acycle))-  where-    hdr             = text "The following alias definitions form a cycle:"-    describe (p, n) = text "*" <+> ppTicks n <+> parens (text "defined at:" <+> pprint p)-    n0              = snd . head $ acycle--ppError' _ dCtx (ErrIllegalAliasApp _ dn dl)-  = text "Refinement type alias cannot be used in this context"-        $+$ dCtx-        $+$ text "Type alias:" <+> pprint dn-        $+$ text "Defined at:" <+> pprint dl--ppError' _ dCtx (ErrAliasApp _ name dl s)-  = text "Malformed application of type alias" <+> ppTicks name-        $+$ dCtx-        $+$ nest 4 (vcat [ text "The alias" <+> ppTicks name <+> "defined at:" <+> pprint dl-                           , s ])--ppError' _ dCtx (ErrSaved _ name s)-  = name -- <+> "(saved)"-        $+$ dCtx-        $+$ {- nest 4 -} s--ppError' _ dCtx (ErrFilePragma _)-  = text "Illegal pragma"-        $+$ dCtx-        $+$ text "--idirs, --c-files, and --ghc-option cannot be used in file-level pragmas"--ppError' _ _ err@(ErrNoSpec _ srcF bspecF)-  =   vcat [ text "Cannot find .bspec file "-           , nest 4 bspecF-           , text "for the source file "-           , nest 4 srcF-           , hint err-           ]--ppError' _ dCtx (ErrOther _ s)-  = text "Uh oh."-        $+$ dCtx-        $+$ nest 4 s--ppError' _ dCtx (ErrTermin _ xs s)-  = text "Termination Error"-        $+$ dCtx-        <+> hsep (L.intersperse comma xs) $+$ s--ppError' _ dCtx (ErrStTerm _ x s)-  = text "Structural Termination Error"-        $+$ dCtx-        <+> (text "Cannot prove termination for size" <+> x) $+$ s-ppError' _ dCtx (ErrILaw _ c i s)-  = text "Law Instance Error"-        $+$ dCtx-        <+> (text "The instance" <+> i <+> text "of class" <+> c <+> text "is not valid.") $+$ s--ppError' _ dCtx (ErrMClass _ v)-  = text "Standalone class method refinement"-    $+$ dCtx-    $+$ (text "Invalid type specification for" <+> v)-    $+$ text "Use class or instance refinements instead."--ppError' _ _ (ErrRClass p0 c is)-  = text "Refined classes cannot have refined instances"-    $+$ nest 4 (sepVcat blankLine $ describeCls : map describeInst is)-  where-    describeCls-      =   text "Refined class definition for:" <+> c-      $+$ text "Defined at:" <+> pprint p0-    describeInst (p, t)-      =   text "Refined instance for:" <+> t-      $+$ text "Defined at:" <+> pprint p--ppError' _ dCtx (ErrTyCon _ msg ty)-  = text "Illegal data refinement for" <+> ppTicks ty-        $+$ dCtx-        $+$ nest 4 msg--ppError' _ dCtx (ErrRewrite _ msg )-  = text "Rewrite error"-        $+$ dCtx-        $+$ nest 4 msg--ppError' _ dCtx (ErrPosTyCon _ tc dc)-  = text "Negative occurence of" <+> tc <+> "in" <+> dc-        $+$ dCtx-        $+$ vcat-            ["\n"-             , "To deactivate or understand the need of positivity check, see:"-             , " "-             , nest 2 "https://ucsd-progsys.github.io/liquidhaskell/options/#positivity-check"-            ]--ppError' _ dCtx (ErrParseAnn _ msg)-  = text "Malformed annotation"-        $+$ dCtx-        $+$ nest 4 msg--ppTicks :: PPrint a => a -> Doc-ppTicks = ticks . pprint--ticks :: Doc -> Doc-ticks d = text "`" <-> d <-> text "`"--ppSrcSpans :: [SrcSpan] -> Doc-ppSrcSpans = ppList (text "Conflicting definitions at")--ppNames :: [Doc] -> Doc-ppNames ds = ppList "Could refer to any of the names" ds -- [text "-" <+> d | d <- ds]--ppList :: (PPrint a) => Doc -> [a] -> Doc-ppList d ls-  = nest 4 (sepVcat blankLine (d : [ text "*" <+> pprint l | l <- ls ]))---- | Convert a GHC error into a list of our errors.--sourceErrors :: String -> SourceError -> [TError t]-sourceErrors s = concatMap (errMsgErrors s) . bagToList . srcErrorMessages--errMsgErrors :: String -> ErrMsg -> [TError t]-errMsgErrors s e = [ ErrGhc (errMsgSpan e) msg ]-   where-     msg         =  text s-                $+$ nest 4 (text (show e))
− src/Language/Haskell/Liquid/Types/Fresh.hs 
@@ -1,288 +0,0 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE UndecidableInstances  #-}-{-# LANGUAGE ConstraintKinds       #-}--{-# OPTIONS_GHC -Wno-name-shadowing #-}--module Language.Haskell.Liquid.Types.Fresh-  ( Freshable(..)-  , refreshTy-  , refreshVV-  , refreshArgs-  , refreshHoles-  , refreshArgsSub-  )-  where--import           Data.Maybe                    (catMaybes) -- , fromJust, isJust)-import           Data.Bifunctor-import qualified Data.List                      as L--- import qualified Data.HashMap.Strict            as M--- import qualified Data.HashSet                   as S--- import           Data.Hashable--- import           Control.Monad.State            (gets, get, put, modify)--- import           Control.Monad                  (when, (>=>))--- import           CoreUtils  (exprType)-import           Prelude                        hiding (error)--- import           Type       (Type)--- import           CoreSyn--- import           Var        (varType, isTyVar, Var)--import qualified Language.Fixpoint.Types as F--- import           Language.Fixpoint.Types.Visitor (kvars)-import           Language.Haskell.Liquid.Misc  (single)-import           Language.Haskell.Liquid.Types.Types-import           Language.Haskell.Liquid.Types.RefType---class (Applicative m, Monad m) => Freshable m a where-  fresh   :: m a-  true    :: Bool -> a -> m a-  true _  = return-  refresh :: Bool -> a -> m a-  refresh _ = return---instance (Freshable m Integer, Monad m, Applicative m) => Freshable m F.Symbol where-  fresh = F.tempSymbol "x" <$> fresh--instance (Freshable m Integer, Monad m, Applicative m) => Freshable m F.Expr where-  fresh  = kv <$> fresh-    where-      kv = (`F.PKVar` mempty) . F.intKvar--instance (Freshable m Integer, Monad m, Applicative m) => Freshable m [F.Expr] where-  fresh = single <$> fresh--instance (Freshable m Integer, Monad m, Applicative m) => Freshable m F.Reft where-  fresh                  = panic Nothing "fresh Reft"-  true    _ (F.Reft (v,_)) = return $ F.Reft (v, mempty)-  refresh _ (F.Reft (_,_)) = (F.Reft .) . (,) <$> freshVV <*> fresh-    where-      freshVV            = F.vv . Just <$> fresh--instance Freshable m Integer => Freshable m RReft where-  fresh             = panic Nothing "fresh RReft"-  true allowTC (MkUReft r _)    = MkUReft <$> true allowTC r    <*> return mempty-  refresh allowTC (MkUReft r _) = MkUReft <$> refresh allowTC r <*> return mempty--instance (Freshable m Integer, Freshable m r, F.Reftable r ) => Freshable m (RRType r) where-  fresh   = panic Nothing "fresh RefType"-  refresh = refreshRefType-  true    = trueRefType--------------------------------------------------------------------------------------------------trueRefType :: (Freshable m Integer, Freshable m r, F.Reftable r) => Bool -> RRType r -> m (RRType r)-------------------------------------------------------------------------------------------------trueRefType allowTC (RAllT α t r)-  = RAllT α <$> true allowTC t <*> true allowTC r --trueRefType allowTC (RAllP π t)-  = RAllP π <$> true allowTC t--trueRefType allowTC (RImpF _ _ t t' _)-  = rImpF <$> fresh <*> true allowTC t <*> true allowTC t'--trueRefType allowTC (RFun _ _ t t' _)-  -- YL: attaching rfinfo here is crucial-  = rFun' (classRFInfo allowTC) <$> fresh <*> true allowTC t <*> true allowTC t'--trueRefType allowTC (RApp c ts _  _) | if allowTC then isEmbeddedDict c else isClass c-  = rRCls c <$> mapM (true allowTC) ts--trueRefType allowTC (RApp c ts rs r)-  = RApp c <$> mapM (true allowTC) ts <*> mapM (trueRef allowTC) rs <*> true allowTC r--trueRefType allowTC (RAppTy t t' _)-  = RAppTy <$> true allowTC t <*> true allowTC t' <*> return mempty--trueRefType allowTC (RVar a r)-  = RVar a <$> true allowTC r--trueRefType allowTC (RAllE y ty tx)-  = do y'  <- fresh-       ty' <- true allowTC ty-       tx' <- true allowTC tx-       return $ RAllE y' ty' (tx' `F.subst1` (y, F.EVar y'))--trueRefType allowTC (RRTy e o r t)-  = RRTy e o r <$> trueRefType allowTC t--trueRefType allowTC (REx _ t t')-  = REx <$> fresh <*> true allowTC t <*> true allowTC t'--trueRefType _ t@(RExprArg _)-  = return t--trueRefType _ t@(RHole _)-  = return t--trueRef :: (F.Reftable r, Freshable f r, Freshable f Integer)-        => Bool -> Ref τ (RType RTyCon RTyVar r) -> f (Ref τ (RRType r))-trueRef _ (RProp _ (RHole _)) = panic Nothing "trueRef: unexpected RProp _ (RHole _))"-trueRef allowTC (RProp s t) = RProp s <$> trueRefType allowTC t---------------------------------------------------------------------------------------------------refreshRefType :: (Freshable m Integer, Freshable m r, F.Reftable r) => Bool -> RRType r -> m (RRType r)-------------------------------------------------------------------------------------------------refreshRefType allowTC (RAllT α t r)-  = RAllT α <$> refresh allowTC t <*> true allowTC r--refreshRefType allowTC (RAllP π t)-  = RAllP π <$> refresh allowTC t--refreshRefType allowTC (RImpF b i t t' _)-  | b == F.dummySymbol = (\b t1 t2 -> RImpF b i t1 t2 mempty) <$> fresh <*> refresh allowTC t <*> refresh allowTC t'-  | otherwise          = (\t1 t2 -> RImpF b i t1 t2 mempty)   <$> refresh allowTC t <*> refresh allowTC t'--refreshRefType allowTC (RFun b i t t' _)-  | b == F.dummySymbol = (\b t1 t2 -> RFun b i t1 t2 mempty) <$> fresh <*> refresh allowTC t <*> refresh allowTC t'-  | otherwise          = (\t1 t2 -> RFun b i t1 t2 mempty)   <$> refresh allowTC t <*> refresh allowTC t'--refreshRefType _ (RApp rc ts _ _) | isClass rc-  = return $ rRCls rc ts--refreshRefType allowTC (RApp rc ts rs r)-  = RApp rc <$> mapM (refresh allowTC) ts <*> mapM (refreshRef allowTC) rs <*> refresh allowTC r--refreshRefType allowTC (RVar a r)-  = RVar a <$> refresh allowTC r--refreshRefType allowTC (RAppTy t t' r)-  = RAppTy <$> refresh allowTC t <*> refresh allowTC t' <*> refresh allowTC r--refreshRefType allowTC (RAllE y ty tx)-  = do y'  <- fresh-       ty' <- refresh allowTC ty-       tx' <- refresh allowTC tx-       return $ RAllE y' ty' (tx' `F.subst1` (y, F.EVar y'))--refreshRefType allowTC (RRTy e o r t)-  = RRTy e o r <$> refreshRefType allowTC t--refreshRefType _ t-  = return t--refreshRef :: (F.Reftable r, Freshable f r, Freshable f Integer)-           => Bool -> Ref τ (RType RTyCon RTyVar r) -> f (Ref τ (RRType r))-refreshRef _ (RProp _ (RHole _)) = panic Nothing "refreshRef: unexpected (RProp _ (RHole _))"-refreshRef allowTC (RProp s t) = RProp <$> mapM freshSym s <*> refreshRefType allowTC t--freshSym :: Freshable f a => (t, t1) -> f (a, t1)-freshSym (_, t)        = (, t) <$> fresh------------------------------------------------------------------------------------refreshTy :: (FreshM m) => SpecType -> m SpecType----------------------------------------------------------------------------------refreshTy t = refreshVV t >>= refreshArgs-----------------------------------------------------------------------------------type FreshM m = Freshable m Integer--------------------------------------------------------------------------------------------------------------------------------------------------------------------refreshVV :: FreshM m => SpecType -> m SpecType----------------------------------------------------------------------------------refreshVV (RAllT a t r) = -  RAllT a <$> refreshVV t <*> return r --refreshVV (RAllP p t) = -  RAllP p <$> refreshVV t--refreshVV (REx x t1 t2) = do -  t1' <- refreshVV t1-  t2' <- refreshVV t2-  shiftVV (REx x t1' t2') <$> fresh--refreshVV (RImpF x i t1 t2 r) = do-  t1' <- refreshVV t1-  t2' <- refreshVV t2-  shiftVV (RImpF x i t1' t2' r) <$> fresh--refreshVV (RFun x i t1 t2 r) = do-  t1' <- refreshVV t1-  t2' <- refreshVV t2-  shiftVV (RFun x i t1' t2' r) <$> fresh--refreshVV (RAppTy t1 t2 r) = do -  t1' <- refreshVV t1-  t2' <- refreshVV t2-  shiftVV (RAppTy t1' t2' r) <$> fresh--refreshVV (RApp c ts rs r) = do -  ts' <- mapM refreshVV    ts-  rs' <- mapM refreshVVRef rs-  shiftVV (RApp c ts' rs' r) <$> fresh--refreshVV t = -  shiftVV t <$> fresh--refreshVVRef :: Freshable m Integer => Ref b SpecType -> m (Ref b SpecType)-refreshVVRef (RProp ss (RHole r))-  = return $ RProp ss (RHole r)--refreshVVRef (RProp ss t)-  = do xs    <- mapM (const fresh) (fst <$> ss)-       let su = F.mkSubst $ zip (fst <$> ss) (F.EVar <$> xs)-       RProp (zip xs (snd <$> ss)) . F.subst su <$> refreshVV t-----------------------------------------------------------------------------------refreshArgs :: (FreshM m) => SpecType -> m SpecType----------------------------------------------------------------------------------refreshArgs t = fst <$> refreshArgsSub t----- NV TODO: this does not refresh args if they are wrapped in an RRTy-refreshArgsSub :: (FreshM m) => SpecType -> m (SpecType, F.Subst)-refreshArgsSub t-  = do ts     <- mapM refreshArgs ts_u-       xs'    <- mapM (const fresh) xs-       let sus = F.mkSubst <$> L.inits (zip xs (F.EVar <$> xs'))-       let su  = last sus-       ts'    <- mapM refreshPs $ zipWith F.subst sus ts-       let rs' = zipWith F.subst sus rs-       tr     <- refreshPs $ F.subst su tbd-       let t'  = fromRTypeRep $ trep {ty_binds = xs', ty_args = ts', ty_res = tr, ty_refts = rs'}-       return (t', su)-    where-       trep    = toRTypeRep t-       xs      = ty_binds trep-       ts_u    = ty_args  trep-       tbd     = ty_res   trep-       rs      = ty_refts trep--refreshPs :: (FreshM m) => SpecType -> m SpecType-refreshPs = mapPropM go-  where-    go (RProp s t) = do-      t'    <- refreshPs t-      xs    <- mapM (const fresh) s-      let su = F.mkSubst [(y, F.EVar x) | (x, (y, _)) <- zip xs s]-      return $ RProp [(x, t) | (x, (_, t)) <- zip xs s] $ F.subst su t'-----------------------------------------------------------------------------------refreshHoles :: (F.Symbolic t, F.Reftable r, TyConable c, Freshable f r)-             => Bool -> [(t, RType c tv r)] -> f ([F.Symbol], [(t, RType c tv r)])-refreshHoles allowTC vts = first catMaybes . unzip . map extract <$> mapM (refreshHoles' allowTC) vts-  where-  --   extract :: (t, t1, t2) -> (t, (t1, t2))-    extract (a,b,c) = (a,(b,c))--refreshHoles' :: (F.Symbolic a, F.Reftable r, TyConable c, Freshable m r)-              => Bool -> (a, RType c tv r) -> m (Maybe F.Symbol, a, RType c tv r)-refreshHoles' allowTC (x,t)-  | noHoles t = return (Nothing, x, t)-  | otherwise = (Just $ F.symbol x,x,) <$> mapReftM tx t-  where-    tx r | hasHole r = refresh allowTC r-         | otherwise = return r--noHoles :: (F.Reftable r, TyConable c) => RType c tv r -> Bool-noHoles = and . foldReft False (\_ r bs -> not (hasHole r) : bs) []
− src/Language/Haskell/Liquid/Types/Generics.hs 
@@ -1,62 +0,0 @@-{- | Geriving instances, generically.-   This module shares some of the underlying ideas and implementations of the-   [generic-data](https://hackage.haskell.org/package/generic-data-0.8.1.0/docs/Generic-Data.html)-   package, allowing us to derive a bunch of instances using the underlying 'Generic' implementation,-   but in a more declarative way.--   In particular we introduc the 'Generically' newtype wrapper to be used with '-XDerivingVia' to make-   derivation explicit. For example:--@-  data Foo = Foo-       deriving Generic-       deriving Eq via Generically Foo-@---}--{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-}--module Language.Haskell.Liquid.Types.Generics where--import GHC.Generics-import Data.Hashable-import Data.Binary-import Data.Hashable.Generic-import Data.Function--newtype Generically a = Generically a deriving Generic---- * 'Hashable'--instance (Generic a, GHashable Zero (Rep a)) => Hashable (Generically a) where-  hashWithSalt s (Generically a) = genericHashWithSalt s a---- * 'Binary'--instance (Generic a, GBinaryPut (Rep a), GBinaryGet (Rep a)) => Binary (Generically a) where-  get = Generically . to' <$> gget-  put (Generically a) = gput (from' a)---- * 'Eq'---- | Generic @('==')@.------ @--- instance 'Eq' MyType where---   ('==') = 'geq'--- @-geq :: (Generic a, Eq (Rep a ())) => a -> a -> Bool-geq = (==) `on` from'--instance (Generic a, Eq (Rep a ())) => Eq (Generically a) where-  (Generically a) == (Generically b) = geq a b---- | A helper for better type inference.-from' :: Generic a => a -> Rep a ()-from' = from--to' :: Generic a => Rep a () -> a-to' = to
− src/Language/Haskell/Liquid/Types/Literals.hs 
@@ -1,49 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Language.Haskell.Liquid.Types.Literals -  ( literalFRefType-  , literalFReft-  , literalConst-  , mkI, mkS-  ) where--import Prelude hiding (error)-import Liquid.GHC.TypeRep ()-import Liquid.GHC.API hiding (panic)--import Language.Haskell.Liquid.Types.Types-import Language.Haskell.Liquid.Types.RefType-import Language.Haskell.Liquid.Transforms.CoreToLogic (mkLit, mkI, mkS)--import qualified Language.Fixpoint.Types as F----------------------------------------------------------------------------------------- Typing Literals -----------------------------------------------------------------------------------------makeRTypeBase :: Monoid r => Type -> r -> RType RTyCon RTyVar r-makeRTypeBase (TyVarTy α)    x-  = RVar (rTyVar α) x-makeRTypeBase (TyConApp c ts) x-  = rApp c ((`makeRTypeBase` mempty) <$> ts) [] x-makeRTypeBase _              _-  = panic Nothing "RefType : makeRTypeBase"--literalFRefType :: Literal -> RType RTyCon RTyVar F.Reft-literalFRefType l-  = makeRTypeBase (literalType l) (literalFReft l)--literalFReft :: Literal -> F.Reft-literalFReft l = maybe mempty mkReft $ mkLit l--mkReft :: F.Expr -> F.Reft-mkReft = F.exprReft---- | `literalConst` returns `Nothing` for unhandled lits because---    otherwise string-literals show up as global int-constants---    which blow up qualifier instantiation.--literalConst :: F.TCEmb TyCon -> Literal -> (F.Sort, Maybe F.Expr)-literalConst tce l = (t, mkLit l)-  where-    t              = typeSort tce $ literalType l
− src/Language/Haskell/Liquid/Types/Meet.hs 
@@ -1,36 +0,0 @@--- | This code has various wrappers around `meet` and `strengthen`---   that are here so that we can throw decent error messages if---   they fail. The module depends on `RefType` and `UX.Tidy`.--module Language.Haskell.Liquid.Types.Meet ( meetVarTypes ) where--import           Text.PrettyPrint.HughesPJ (Doc)-import qualified Language.Fixpoint.Types as F-import           Language.Haskell.Liquid.Types.Types-import           Language.Haskell.Liquid.Types.RefType ()-import           Liquid.GHC.API as Ghc--meetVarTypes :: F.TCEmb TyCon -> Doc -> (SrcSpan, SpecType) -> (SrcSpan, SpecType) -> SpecType-meetVarTypes _emb _v hs lq = {- meetError emb err -} F.meet hsT lqT-  where-    (_hsSp, hsT)      = hs-    (_lqSp, lqT)      = lq-    -- _err              = ErrMismatch lqSp v (text "meetVarTypes") hsD lqD hsSp-    -- _hsD              = F.pprint hsT-    -- _lqD              = F.pprint lqT-{- -  -_meetError :: F.TCEmb TyCon -> Error -> SpecType -> SpecType -> SpecType-_meetError _emb _e t t'-  -- // | meetable emb t t'-  | True              = t `F.meet` t'-  -- // | otherwise         = panicError e--_meetable :: F.TCEmb TyCon -> SpecType -> SpecType -> Bool-_meetable _emb t1 t2 = F.notracepp ("meetable: " ++  showpp (s1, t1, s2, t2)) (s1 == s2)-  where-    s1              = tx t1-    s2              = tx t2-    tx              = rTypeSort _emb . toRSort---}
− src/Language/Haskell/Liquid/Types/Names.hs 
@@ -1,20 +0,0 @@-module Language.Haskell.Liquid.Types.Names-  (lenLocSymbol, anyTypeSymbol, functionComposisionSymbol, selfSymbol) where--import Language.Fixpoint.Types---- RJ: Please add docs-lenLocSymbol :: Located Symbol-lenLocSymbol = dummyLoc $ symbol ("autolen" :: String)--anyTypeSymbol :: Symbol-anyTypeSymbol = symbol ("GHC.Prim.Any" :: String)-----  defined in include/GHC/Base.hs-functionComposisionSymbol :: Symbol-functionComposisionSymbol = symbol ("GHC.Base.." :: String)---selfSymbol :: Symbol-selfSymbol = symbol ("liquid_internal_this" :: String)
− src/Language/Haskell/Liquid/Types/PredType.hs 
@@ -1,581 +0,0 @@-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE OverloadedStrings    #-}-{-# LANGUAGE TupleSections        #-}-{-# LANGUAGE UndecidableInstances #-}--{-# OPTIONS_GHC -Wno-orphans #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-}--module Language.Haskell.Liquid.Types.PredType (-    PrType-  , TyConP (..), DataConP (..)-  , dataConTy-  , dataConPSpecType-  , makeTyConInfo-  , replacePreds-  , replacePredsWithRefs-  , pVartoRConc--  -- * Dummy `Type` that represents _all_ abstract-predicates-  , predType--  -- * Compute @RType@ of a given @PVar@-  , pvarRType-  , substParg-  , pApp-  , pappSort-  , pappArity--  -- * should be elsewhere-  , dataConWorkRep-  , substPVar-  ) where--import           Prelude                         hiding (error)-import           Text.PrettyPrint.HughesPJ-import           Liquid.GHC.API hiding ( panic-                                                        , (<+>)-                                                        , hsep-                                                        , punctuate-                                                        , comma-                                                        , parens-                                                        , showPpr-                                                        )-import           Liquid.GHC.TypeRep ()-import           Data.Hashable-import qualified Data.HashMap.Strict             as M-import qualified Data.Maybe                                 as Mb-import qualified Data.List         as L -- (foldl', partition)--- import           Data.List                       (nub)--import           Language.Fixpoint.Misc---- import           Language.Fixpoint.Types         hiding (Expr, Predicate)-import qualified Language.Fixpoint.Types                    as F-import qualified Liquid.GHC.API            as Ghc-import           Liquid.GHC.Misc-import           Language.Haskell.Liquid.Misc-import           Language.Haskell.Liquid.Types.RefType hiding (generalize)-import           Language.Haskell.Liquid.Types.Types-import           Data.Default--makeTyConInfo :: F.TCEmb Ghc.TyCon -> [Ghc.TyCon] -> [TyConP] -> TyConMap-makeTyConInfo tce fiTcs tcps = TyConMap-  { tcmTyRTy    = tcM-  , tcmFIRTy    = tcInstM-  , tcmFtcArity = arities-  }-  where-    tcM         = M.fromList [(tcpCon tcp, mkRTyCon tcp) | tcp <- tcps ]-    tcInstM     = mkFInstRTyCon tce fiTcs tcM-    arities     = safeFromList "makeTyConInfo" [ (c, length ts) | (c, ts) <- M.keys tcInstM ]--mkFInstRTyCon :: F.TCEmb Ghc.TyCon -> [Ghc.TyCon] -> M.HashMap Ghc.TyCon RTyCon -> M.HashMap (Ghc.TyCon, [F.Sort]) RTyCon-mkFInstRTyCon tce fiTcs tcm = M.fromList-  [ ((c, typeSort tce <$> ts), rtc)-    | fiTc    <- fiTcs-    , rtc     <- Mb.maybeToList (M.lookup fiTc tcm)-    , (c, ts) <- Mb.maybeToList (famInstArgs fiTc)-  ]--mkRTyCon ::  TyConP -> RTyCon-mkRTyCon (TyConP _ tc αs' ps tyvariance predvariance size)-  = RTyCon tc pvs' (mkTyConInfo tc tyvariance predvariance size)-  where-    τs   = [rVar α :: RSort |  α <- tyConTyVarsDef tc]-    pvs' = subts (zip αs' τs) <$> ps------------------------------------------------------------------------------------- | @dataConPSpecType@ converts a @DataConP@, LH's internal representation for ---   a (refined) data constructor into a @SpecType@ for that constructor.---   TODO: duplicated with Liquid.Measure.makeDataConType---------------------------------------------------------------------------------dataConPSpecType :: Bool -> DataConP -> [(Var, SpecType)]---------------------------------------------------------------------------------dataConPSpecType allowTC dcp    = [(workX, workT), (wrapX, wrapT) ]-  where-    workT | isVanilla   = wrapT-          | otherwise   = dcWorkSpecType   dc wrapT-    wrapT               = dcWrapSpecType   allowTC  dc dcp-    workX               = dataConWorkId    dc            -- This is the weird one for GADTs-    wrapX               = dataConWrapId    dc            -- This is what the user expects to see-    isVanilla           = isVanillaDataCon dc-    dc                  = dcpCon dcp--dcWorkSpecType :: DataCon -> SpecType -> SpecType-dcWorkSpecType c wrT    = fromRTypeRep (meetWorkWrapRep c wkR wrR)-  where-    wkR                 = dataConWorkRep c-    wrR                 = toRTypeRep wrT--dataConWorkRep :: DataCon -> SpecRep-dataConWorkRep c = toRTypeRep-                 -- . F.tracepp ("DCWR-2: " ++ F.showpp c)-                 . ofType-                 -- . F.tracepp ("DCWR-1: " ++ F.showpp c)-                 . dataConRepType-                 -- . Var.varType-                 -- . dataConWorkId-                 $ c-{--dataConWorkRep :: DataCon -> SpecRep-dataConWorkRep dc = RTypeRep-  { ty_vars   = as-  , ty_preds  = []-  , ty_labels = []-  , ty_binds  = replicate nArgs F.dummySymbol-  , ty_refts  = replicate nArgs mempty-  , ty_args   = ts'-  , ty_res    = t'-  }-  where-    (ts', t')          = F.tracepp "DCWR-1" (ofType <$> ts, ofType t)-    as                 = makeRTVar . rTyVar <$> αs-    tArg-    (αs,_,eqs,th,ts,t) = dataConFullSig dc-    nArgs              = length ts--dataConResultTy :: DataCon -> [TyVar] -> Type -> Type-dataConResultTy dc αs t = mkFamilyTyConApp tc tArgs'-  where-    tArgs'              = take (nArgs - nVars) tArgs ++ (mkTyVarTy <$> αs)-    nVars               = length αs-    nArgs               = length tArgs-    (tc, tArgs)         = fromMaybe err (splitTyConApp_maybe _t)-    err                 = GM.namedPanic dc ("Cannot split result type of DataCon " ++ show dc)--  --  t                 = RT.ofType  $  mkFamilyTyConApp tc tArgs'-  -- as                = makeRTVar . rTyVar <$> αs-  --  (αs,_,_,_,_ts,_t) = dataConFullSig dc---}--meetWorkWrapRep :: DataCon -> SpecRep -> SpecRep -> SpecRep-meetWorkWrapRep c workR wrapR-  | 0 <= pad-  = workR { ty_binds = xs ++ ty_binds wrapR-          , ty_args  = ts ++ zipWith F.meet ts' (ty_args wrapR)-          , ty_res   = strengthenRType (ty_res workR)    (ty_res  wrapR)-          , ty_preds = ty_preds wrapR-          }-  | otherwise-  = panic (Just (getSrcSpan c)) errMsg-  where-    pad       = {- F.tracepp ("MEETWKRAP: " ++ show (ty_vars workR)) $ -} workN - wrapN-    (xs, _)   = splitAt pad (ty_binds workR)-    (ts, ts') = splitAt pad (ty_args  workR)-    workN     = length      (ty_args  workR)-    wrapN     = length      (ty_args  wrapR)-    errMsg    = "Unsupported Work/Wrap types for Data Constructor " ++ showPpr c--strengthenRType :: SpecType -> SpecType -> SpecType-strengthenRType wkT wrT = maybe wkT (strengthen wkT) (stripRTypeBase wrT)----- maybe a tc flag is unnecessary but I don't know if {-@ class ... @-}--- would reach here-dcWrapSpecType :: Bool -> DataCon -> DataConP -> SpecType-dcWrapSpecType allowTC dc (DataConP _ _ vs ps cs yts rt _ _ _)-  = {- F.tracepp ("dcWrapSpecType: " ++ show dc ++ " " ++ F.showpp rt) $ -}-    mkArrow makeVars' ps [] ts' rt'-  where-    isCls    = Ghc.isClassTyCon $ Ghc.dataConTyCon dc-    (xs, ts) = unzip (reverse yts)-    mkDSym z = F.symbol z `F.suffixSymbol` F.symbol dc-    ys       = mkDSym <$> xs-    tx _  []     []     []     = []-    tx su (x:xs) (y:ys) (t:ts) = (y, classRFInfo allowTC , if allowTC && isCls then t else F.subst (F.mkSubst su) t, mempty)-                               : tx ((x, F.EVar y):su) xs ys ts-    tx _ _ _ _ = panic Nothing "PredType.dataConPSpecType.tx called on invalid inputs"-    yts'     = tx [] xs ys ts-    ts'      = map ("" , classRFInfo allowTC , , mempty) cs ++ yts'-    su       = F.mkSubst [(x, F.EVar y) | (x, y) <- zip xs ys]-    rt'      = F.subst su rt-    makeVars = zipWith (\v a -> RTVar v (rTVarInfo a :: RTVInfo RSort)) vs (fst $ splitForAllTys $ dataConRepType dc)-    makeVars' = zip makeVars (repeat mempty)--instance PPrint TyConP where-  pprintTidy k tc = "data" <+> pprintTidy k (tcpCon tc)-                           <+> ppComm     k (tcpFreeTyVarsTy tc)-                           <+> ppComm     k (tcpFreePredTy   tc)-      --  (parens $ hsep (punctuate comma (pprintTidy k <$> vs))) <+>-      -- (parens $ hsep (punctuate comma (pprintTidy k <$> ps))) <+>-      -- (parens $ hsep (punctuate comma (pprintTidy k <$> ls)))--ppComm :: PPrint a => F.Tidy -> [a] -> Doc-ppComm k = parens . hsep . punctuate comma . fmap (pprintTidy k)-----instance Show TyConP where- show = showpp -- showSDoc . ppr--instance PPrint DataConP where-  pprintTidy k (DataConP _ dc vs ps cs yts t isGadt mname _)-     =  pprintTidy k dc-    <+> parens (hsep (punctuate comma (pprintTidy k <$> vs)))-    <+> parens (hsep (punctuate comma (pprintTidy k <$> ps)))-    <+> parens (hsep (punctuate comma (pprintTidy k <$> cs)))-    <+> parens (hsep (punctuate comma (pprintTidy k <$> yts)))-    <+> pprintTidy k isGadt-    <+> pprintTidy k mname-    <+>  pprintTidy k t--instance Show DataConP where-  show = showpp--dataConTy :: Monoid r-          => M.HashMap RTyVar (RType RTyCon RTyVar r)-          -> Type -> RType RTyCon RTyVar r-dataConTy m (TyVarTy v)-  = M.lookupDefault (rVar v) (RTV v) m-dataConTy m (FunTy _ _ t1 t2)-  = rFun F.dummySymbol (dataConTy m t1) (dataConTy m t2)-dataConTy m (ForAllTy (Bndr α _) t) -- α :: TyVar-  = RAllT (makeRTVar (RTV α)) (dataConTy m t) mempty-dataConTy m (TyConApp c ts)-  = rApp c (dataConTy m <$> ts) [] mempty-dataConTy _ _-  = panic Nothing "ofTypePAppTy"--------------------------------------------------------------------------------- | Interface: Replace Predicate With Uninterpreted Function Symbol -------------------------------------------------------------------------------------replacePredsWithRefs :: (UsedPVar, (F.Symbol, [((), F.Symbol, F.Expr)]) -> F.Expr)-                     -> UReft F.Reft -> UReft F.Reft-replacePredsWithRefs (p, r) (MkUReft (F.Reft(v, rs)) (Pr ps))-  = MkUReft (F.Reft (v, rs'')) (Pr ps2)-  where-    rs''             = mconcat $ rs : rs'-    rs'              = r . (v,) . pargs <$> ps1-    (ps1, ps2)       = L.partition (== p) ps--pVartoRConc :: PVar t -> (F.Symbol, [(a, b, F.Expr)]) -> F.Expr-pVartoRConc p (v, args) | length args == length (pargs p)-  = pApp (pname p) $ F.EVar v : (thd3 <$> args)--pVartoRConc p (v, args)-  = pApp (pname p) $ F.EVar v : args'-  where-    args' = (thd3 <$> args) ++ drop (length args) (thd3 <$> pargs p)---------------------------------------------------------------------------- | @pvarRType π@ returns a trivial @RType@ corresponding to the---   function signature for a @PVar@ @π@. For example, if---      @π :: T1 -> T2 -> T3 -> Prop@---   then @pvarRType π@ returns an @RType@ with an @RTycon@ called---   @predRTyCon@ `RApp predRTyCon [T1, T2, T3]`-------------------------------------------------------------------------pvarRType :: (PPrint r, F.Reftable r) => PVar RSort -> RRType r-------------------------------------------------------------------------pvarRType (PV _ k {- (PVProp τ) -} _ args) = rpredType k (fst3 <$> args) -- (ty:tys)-  -- where-  --   ty  = uRTypeGen τ-  --   tys = uRTypeGen . fst3 <$> args----- rpredType    :: (PPrint r, Reftable r) => PVKind (RRType r) -> [RRType r] -> RRType r-rpredType :: F.Reftable r-          => PVKind (RType RTyCon tv a)-          -> [RType RTyCon tv a] -> RType RTyCon tv r-rpredType (PVProp t) ts = RApp predRTyCon  (uRTypeGen <$> t : ts) [] mempty-rpredType PVHProp    ts = RApp wpredRTyCon (uRTypeGen <$>     ts) [] mempty--predRTyCon   :: RTyCon-predRTyCon   = symbolRTyCon predName--wpredRTyCon   :: RTyCon-wpredRTyCon   = symbolRTyCon wpredName--symbolRTyCon   :: F.Symbol -> RTyCon-symbolRTyCon n = RTyCon (stringTyCon 'x' 42 $ F.symbolString n) [] def------------------------------------------------------------------------------------------ | Instantiate `PVar` with `RTProp` ---------------------------------------------------------------------------------------------------------------------------------------- | @replacePreds@ is the main function used to substitute an (abstract)---   predicate with a concrete Ref, that is either an `RProp` or `RHProp`---   type. The substitution is invoked to obtain the `SpecType` resulting---   at /predicate application/ sites in 'Language.Haskell.Liquid.Constraint'.---   The range of the `PVar` substitutions are /fresh/ or /true/ `RefType`.---   That is, there are no further _quantified_ `PVar` in the target.---------------------------------------------------------------------------------------replacePreds                 :: String -> SpecType -> [(RPVar, SpecProp)] -> SpecType---------------------------------------------------------------------------------------replacePreds msg                 = L.foldl' go-  where-     go _ (_, RProp _ (RHole _)) = panic Nothing "replacePreds on RProp _ (RHole _)"-     go z (π, t)                 = substPred msg   (π, t)     z----- TODO: replace `replacePreds` with--- instance SubsTy RPVar (Ref RReft SpecType) SpecType where---   subt (pv, r) t = replacePreds "replacePred" t (pv, r)---- replacePreds :: String -> SpecType -> [(RPVar, Ref Reft RefType)] -> SpecType--- replacePreds msg       = foldl' go---   where go z (π, RProp t) = substPred msg   (π, t)     z---         go z (π, RPropP r) = replacePVarReft (π, r) <$> z----------------------------------------------------------------------------------------substPVar :: PVar BSort -> PVar BSort -> BareType -> BareType---------------------------------------------------------------------------------------substPVar src dst = go-  where-    go :: BareType -> BareType-    go (RVar a r)         = RVar a (goRR r)-    go (RApp c ts rs r)   = RApp c (go <$> ts) (goR <$> rs) (goRR r)-    go (RAllP q t)-     | pname q == pname src = RAllP q t-     | otherwise            = RAllP q (go t)-    go (RAllT a t r)      = RAllT a   (go t)  (goRR r)-    go (RFun x i t t' r)  = RFun x i  (go t)  (go t') (goRR r)-    go (RImpF x i t t' r) = RImpF x i (go t)  (go t') (goRR r)-    go (RAllE x t t')     = RAllE x   (go t)  (go t')-    go (REx x t t')       = REx x     (go t)  (go t')-    go (RRTy e r o t)     = RRTy e'   (goRR r) o (go t) where e' = [(x, go t) | (x, t) <- e]-    go (RAppTy t1 t2 r)   = RAppTy    (go t1) (go t2) (goRR r)-    go (RHole r)          = RHole     (goRR r)-    go t@(RExprArg  _)    = t-    goR :: BRProp RReft -> BRProp RReft-    goR rp = rp {rf_body = go (rf_body rp) }-    goRR :: RReft -> RReft-    goRR rr = rr { ur_pred = goP (ur_pred rr) }-    goP :: Predicate -> Predicate-    goP (Pr ps) = Pr (goPV <$> ps)-    goPV :: UsedPVar -> UsedPVar-    goPV pv-      | pname pv == pname src = pv { pname = pname dst }-      | otherwise             = pv----------------------------------------------------------------------------------substPred :: String -> (RPVar, SpecProp) -> SpecType -> SpecType----------------------------------------------------------------------------------substPred _   (π, RProp ss (RVar a1 r1)) t@(RVar a2 r2)-  | isPredInReft && a1 == a2    = RVar a1 $ meetListWithPSubs πs ss r1 r2'-  | isPredInReft                = panic Nothing ("substPred RVar Var Mismatch" ++ show (a1, a2))-  | otherwise                   = t-  where-    (r2', πs)                   = splitRPvar π r2-    isPredInReft                = not $ null πs--substPred msg su@(π, _ ) (RApp c ts rs r)-  | null πs                     = t'-  | otherwise                   = substRCon msg su t' πs r2'-  where-    t'                          = RApp c (substPred msg su <$> ts) (substPredP msg su <$> rs) r-    (r2', πs)                   = splitRPvar π r--substPred msg (p, tp) (RAllP q@PV{} t)-  | p /= q                      = RAllP q $ substPred msg (p, tp) t-  | otherwise                   = RAllP q t--substPred msg su (RAllT a t r)  = RAllT a (substPred msg su t) r--substPred msg su@(π,prop) (RFun x i t t' r)---                        = RFun x (substPred msg su t) (substPred msg su t') r-  | null πs                     = RFun x i (substPred msg su t) (substPred msg su t') r-  | otherwise                   =-      let sus = (\π -> F.mkSubst (zip (fst <$> rf_args prop) (thd3 <$> pargs π))) <$> πs in-      foldl (\t su -> t `F.meet` F.subst su (rf_body prop)) (RFun x i (substPred msg su t) (substPred msg su t') r') sus-  where (r', πs)                = splitRPvar π r--- ps has   , pargs :: ![(t, Symbol, Expr)]---- AT: just a copy of the other case, mutatis mutandi. (is there a less hacky way?)-substPred msg su@(π,prop) (RImpF x i t t' r)-  | null πs                     = RImpF x i (substPred msg su t) (substPred msg su t') r-  | otherwise                   =-      let sus = (\π -> F.mkSubst (zip (fst <$> rf_args prop) (thd3 <$> pargs π))) <$> πs in-      foldl (\t su -> t `F.meet` F.subst su (rf_body prop)) (RImpF x i (substPred msg su t) (substPred msg su t') r') sus-  where (r', πs)                = splitRPvar π r----substPred msg su (RRTy e r o t) = RRTy (mapSnd (substPred msg su) <$> e) r o (substPred msg su t)-substPred msg su (RAllE x t t') = RAllE x (substPred msg su t) (substPred msg su t')-substPred msg su (REx x t t')   = REx   x (substPred msg su t) (substPred msg su t')-substPred _   _  t              = t---- | Requires: @not $ null πs@--- substRCon :: String -> (RPVar, SpecType) -> SpecType -> SpecType--substRCon-  :: (PPrint t, PPrint t2, Eq tv, F.Reftable r, Hashable tv, PPrint tv, PPrint r,-      SubsTy tv (RType RTyCon tv ()) r,-      SubsTy tv (RType RTyCon tv ()) (RType RTyCon tv ()),-      SubsTy tv (RType RTyCon tv ()) RTyCon,-      SubsTy tv (RType RTyCon tv ()) tv,-      F.Reftable (RType RTyCon tv r),-      SubsTy tv (RType RTyCon tv ()) (RTVar tv (RType RTyCon tv ())),-      FreeVar RTyCon tv,-      F.Reftable (RTProp RTyCon tv r),-      F.Reftable (RTProp RTyCon tv ()))-  => [Char]-  -> (t, Ref RSort (RType RTyCon tv r))-  -> RType RTyCon tv r-  -> [PVar t2]-  -> r-  -> RType RTyCon tv r-substRCon msg (_, RProp ss t1@(RApp c1 ts1 rs1 r1)) t2@(RApp c2 ts2 rs2 _) πs r2'-  | rtc_tc c1 == rtc_tc c2 = RApp c1 ts rs $ meetListWithPSubs πs ss r1 r2'-  where-    ts                     = F.subst su $ safeZipWith (msg ++ ": substRCon")  strSub  ts1  ts2-    rs                     = F.subst su $ safeZipWith (msg ++ ": substRCon2") strSubR rs1' rs2'-    (rs1', rs2')           = pad "substRCon" F.top rs1 rs2-    strSub r1 r2           = meetListWithPSubs πs ss r1 r2-    strSubR r1 r2          = meetListWithPSubsRef πs ss r1 r2--    su = F.mkSubst $ zipWith (\s1 s2 -> (s1, F.EVar s2)) (rvs t1) (rvs t2)--    rvs      = foldReft False (\_ r acc -> rvReft r : acc) []-    rvReft r = let F.Reft(s,_) = F.toReft r in s--substRCon msg su t _ _        = {- panic Nothing -} errorP "substRCon: " $ msg ++ " " ++ showpp (su, t)--pad :: [Char] -> (a -> a) -> [a] -> [a] -> ([a], [a])-pad _ f [] ys   = (f <$> ys, ys)-pad _ f xs []   = (xs, f <$> xs)-pad msg _ xs ys-  | nxs == nys  = (xs, ys)-  | otherwise   = panic Nothing $ "pad: " ++ msg-  where-    nxs         = length xs-    nys         = length ys--substPredP :: [Char]-           -> (RPVar, Ref RSort (RRType RReft))-           -> Ref RSort (RType RTyCon RTyVar RReft)-           -> Ref RSort SpecType-substPredP _ su p@(RProp _ (RHole _))-  = panic Nothing ("PredType.substPredP1 called on invalid inputs: " ++ showpp (su, p))-substPredP msg (p, RProp ss prop) (RProp s t)-  = RProp ss' $ substPred (msg ++ ": substPredP") (p, RProp ss {- (subst su prop) -} prop ) t- where-   ss' = drop n ss ++  s-   n   = length ss - length (freeArgsPs p t)-   -- su  = mkSubst (zip (fst <$> ss) (EVar . fst <$> ss'))---splitRPvar :: PVar t -> UReft r -> (UReft r, [UsedPVar])-splitRPvar pv (MkUReft x (Pr pvs)) = (MkUReft x (Pr pvs'), epvs)-  where-    (epvs, pvs')               = L.partition (uPVar pv ==) pvs---- TODO: rewrite using foldReft-freeArgsPs :: PVar (RType t t1 ()) -> RType t t1 (UReft t2) -> [F.Symbol]-freeArgsPs p (RVar _ r)-  = freeArgsPsRef p r-freeArgsPs p (RImpF _ _ t1 t2 r)-  = L.nub $  freeArgsPsRef p r ++ freeArgsPs p t1 ++ freeArgsPs p t2-freeArgsPs p (RFun _ _ t1 t2 r)-  = L.nub $  freeArgsPsRef p r ++ freeArgsPs p t1 ++ freeArgsPs p t2-freeArgsPs p (RAllT _ t r)-  = L.nub $  freeArgsPs p t ++ freeArgsPsRef p r-freeArgsPs p (RAllP p' t)-  | p == p'   = []-  | otherwise = freeArgsPs p t-freeArgsPs p (RApp _ ts _ r)-  = L.nub $ freeArgsPsRef p r ++ concatMap (freeArgsPs p) ts-freeArgsPs p (RAllE _ t1 t2)-  = L.nub $ freeArgsPs p t1 ++ freeArgsPs p t2-freeArgsPs p (REx _ t1 t2)-  = L.nub $ freeArgsPs p t1 ++ freeArgsPs p t2-freeArgsPs p (RAppTy t1 t2 r)-  = L.nub $ freeArgsPsRef p r ++ freeArgsPs p t1 ++ freeArgsPs p t2-freeArgsPs _ (RExprArg _)-  = []-freeArgsPs p (RHole r)-  = freeArgsPsRef p r-freeArgsPs p (RRTy env r _ t)-  = L.nub $ concatMap (freeArgsPs p) (snd <$> env) ++ freeArgsPsRef p r ++ freeArgsPs p t--freeArgsPsRef :: PVar t1 -> UReft t -> [F.Symbol]-freeArgsPsRef p (MkUReft _ (Pr ps)) = [x | (_, x, w) <- concatMap pargs ps', F.EVar x == w]-  where-   ps' = f <$> filter (uPVar p ==) ps-   f q = q {pargs = pargs q ++ drop (length (pargs q)) (pargs $ uPVar p)}--meetListWithPSubs :: (Foldable t, PPrint t1, F.Reftable b)-                  => t (PVar t1) -> [(F.Symbol, RSort)] -> b -> b -> b-meetListWithPSubs πs ss r1 r2    = L.foldl' (meetListWithPSub ss r1) r2 πs--meetListWithPSubsRef :: (Foldable t, F.Reftable (RType t1 t2 t3))-                     => t (PVar t4)-                     -> [(F.Symbol, b)]-                     -> Ref τ (RType t1 t2 t3)-                     -> Ref τ (RType t1 t2 t3)-                     -> Ref τ (RType t1 t2 t3)-meetListWithPSubsRef πs ss r1 r2 = L.foldl' (meetListWithPSubRef ss r1) r2 πs--meetListWithPSub ::  (F.Reftable r, PPrint t) => [(F.Symbol, RSort)]-> r -> r -> PVar t -> r-meetListWithPSub ss r1 r2 π-  | all (\(_, x, F.EVar y) -> x == y) (pargs π)-  = r2 `F.meet` r1-  | all (\(_, x, F.EVar y) -> x /= y) (pargs π)-  = r2 `F.meet` F.subst su r1-  | otherwise-  = panic Nothing $ "PredType.meetListWithPSub partial application to " ++ showpp π-  where-    su  = F.mkSubst [(x, y) | (x, (_, _, y)) <- zip (fst <$> ss) (pargs π)]--meetListWithPSubRef :: (F.Reftable (RType t t1 t2))-                    => [(F.Symbol, b)]-                    -> Ref τ (RType t t1 t2)-                    -> Ref τ (RType t t1 t2)-                    -> PVar t3-                    -> Ref τ (RType t t1 t2)-meetListWithPSubRef _ (RProp _ (RHole _)) _ _ -- TODO: Is this correct?-  = panic Nothing "PredType.meetListWithPSubRef called with invalid input"-meetListWithPSubRef _ _ (RProp _ (RHole _)) _-  = panic Nothing "PredType.meetListWithPSubRef called with invalid input"-meetListWithPSubRef ss (RProp s1 r1) (RProp s2 r2) π-  | all (\(_, x, F.EVar y) -> x == y) (pargs π)-  = RProp s1 $ F.subst su' r2 `F.meet` r1-  | all (\(_, x, F.EVar y) -> x /= y) (pargs π)-  = RProp s2 $ r2 `F.meet` F.subst su r1-  | otherwise-  = panic Nothing $ "PredType.meetListWithPSubRef partial application to " ++ showpp π-  where-    su  = F.mkSubst [(x, y) | (x, (_, _, y)) <- zip (fst <$> ss) (pargs π)]-    su' = F.mkSubst [(x, F.EVar y) | (x, y) <- zip (fst <$> s2) (fst <$> s1)]---------------------------------------------------------------------------------- | Interface: Modified CoreSyn.exprType due to predApp -------------------------------------------------------------------------------------------------predType   :: Type-predType   = symbolType predName--wpredName, predName :: F.Symbol-predName   = "Pred"-wpredName  = "WPred"--symbolType :: F.Symbol -> Type-symbolType = TyVarTy . symbolTyVar---substParg :: Functor f => (F.Symbol, F.Expr) -> f Predicate -> f Predicate-substParg (x, y) = fmap fp-  where-    fxy s        = if s == F.EVar x then y else s-    fp           = subvPredicate (\pv -> pv { pargs = mapThd3 fxy <$> pargs pv })---------------------------------------------------------------------------------------------------------------  Predicate Application -----------------------------------------------------------------------------------------------------------pappArity :: Int-pappArity  = 7--pappSort :: Int -> F.Sort-pappSort n = F.mkFFunc (2 * n) $ [ptycon] ++ args ++ [F.boolSort]-  where-    ptycon = F.fAppTC predFTyCon $ F.FVar <$> [0..n-1]-    args   = F.FVar <$> [n..(2*n-1)]---predFTyCon :: F.FTycon-predFTyCon = F.symbolFTycon $ dummyLoc predName
− src/Language/Haskell/Liquid/Types/PrettyPrint.hs 
@@ -1,568 +0,0 @@--- | This module contains a single function that converts a RType -> Doc---   without using *any* simplifications.--{-# LANGUAGE OverloadedStrings    #-}-{-# LANGUAGE ConstraintKinds      #-}-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE TupleSections        #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MonoLocalBinds       #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE RecordWildCards      #-}-{-# LANGUAGE ScopedTypeVariables  #-}--{-# OPTIONS_GHC -Wno-orphans #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-}--module Language.Haskell.Liquid.Types.PrettyPrint-  ( -- * Printable RTypes-    OkRT--    -- * Printers-  , rtypeDoc--  -- * Printing Lists (TODO: move to fixpoint)-  , pprManyOrdered-  , pprintLongList-  , pprintSymbol--  -- * Printing diagnostics-  , printWarning-  , printError--  -- * Filtering errors-  , Filter(..)-  , getFilters-  , reduceFilters-  , defaultFilterReporter--  -- * Reporting errors in the typechecking phase-  , FilterReportErrorsArgs(..)-  , filterReportErrorsWith-  , filterReportErrors--  ) where--import           Control.Monad                           (void)-import qualified Data.HashMap.Strict              as M-import qualified Data.List                        as L                               -- (sort)-import qualified Data.Set                         as Set-import           Data.String-import           Language.Fixpoint.Misc-import qualified Language.Fixpoint.Types          as F-import qualified Liquid.GHC.API  as Ghc-import           Liquid.GHC.API  as Ghc ( Class-                                                         , SrcSpan-                                                         , PprPrec-                                                         , DynFlags-                                                         , Type-                                                         , Var-                                                         , Name-                                                         , ErrMsg-                                                         , SourceError-                                                         , TyCon-                                                         , topPrec-                                                         , funPrec-                                                         , srcSpanStartLine-                                                         , srcSpanStartCol-                                                         )-import           Liquid.GHC.Logging (putErrMsg, mkLongErrAt)-import           Liquid.GHC.Misc-import           Language.Haskell.Liquid.Misc-import           Language.Haskell.Liquid.Types.Types-import           Prelude                          hiding (error)-import           Text.PrettyPrint.HughesPJ        hiding ((<>))---- | `Filter`s match errors. They are used to ignore classes of errors they--- match. `AnyFilter` matches all errors. `StringFilter` matches any error whose--- \"representation\" contains the given `String`. A \"representation\" is--- pretty-printed String of the error.-data Filter = StringFilter String-            | AnyFilter-  deriving (Eq, Ord, Show)-----------------------------------------------------------------------------------pprManyOrdered :: (PPrint a, Ord a) => F.Tidy -> String -> [a] -> [Doc]----------------------------------------------------------------------------------pprManyOrdered k msg = map ((text msg <+>) . pprintTidy k) . L.sort-----------------------------------------------------------------------------------pprintLongList :: PPrint a => F.Tidy -> [a] -> Doc----------------------------------------------------------------------------------pprintLongList k = brackets . vcat . map (pprintTidy k)------------------------------------------------------------------------------------pprintSymbol :: F.Symbol -> Doc----------------------------------------------------------------------------------pprintSymbol x = char '‘' <-> pprint x <-> char '’'-------------------------------------------------------------------------------------- | A whole bunch of PPrint instances follow --------------------------------------------------------------------------------------------------------------------instance PPrint ErrMsg where-  pprintTidy _ = text . show--instance PPrint SourceError where-  pprintTidy _ = text . show--instance PPrint Var where-  pprintTidy _ = pprDoc--instance PPrint (Ghc.Expr Var) where-  pprintTidy _ = pprDoc--instance PPrint (Ghc.Bind Var) where-  pprintTidy _ = pprDoc--instance PPrint Name where-  pprintTidy _ = pprDoc--instance PPrint TyCon where-  pprintTidy F.Lossy = shortModules . pprDoc-  pprintTidy F.Full  =                pprDoc--instance PPrint Type where-  pprintTidy _ = pprDoc -- . tidyType emptyTidyEnv -- WHY WOULD YOU DO THIS???--instance PPrint Class where-  pprintTidy F.Lossy = shortModules . pprDoc-  pprintTidy F.Full  =                pprDoc--instance Show Predicate where-  show = showpp--instance (PPrint t) => PPrint (Annot t) where-  pprintTidy k (AnnUse t) = text "AnnUse" <+> pprintTidy k t-  pprintTidy k (AnnDef t) = text "AnnDef" <+> pprintTidy k t-  pprintTidy k (AnnRDf t) = text "AnnRDf" <+> pprintTidy k t-  pprintTidy _ (AnnLoc l) = text "AnnLoc" <+> pprDoc l--instance PPrint a => PPrint (AnnInfo a) where-  pprintTidy k (AI m) = vcat $ pprAnnInfoBinds k <$> M.toList m--instance PPrint a => Show (AnnInfo a) where-  show = showpp--pprAnnInfoBinds :: (PPrint a, PPrint b) => F.Tidy -> (SrcSpan, [(Maybe a, b)]) -> Doc-pprAnnInfoBinds k (l, xvs)-  = vcat $ pprAnnInfoBind k . (l,) <$> xvs--pprAnnInfoBind :: (PPrint a, PPrint b) => F.Tidy -> (SrcSpan, (Maybe a, b)) -> Doc-pprAnnInfoBind k (Ghc.RealSrcSpan sp _, xv)-  = xd $$ pprDoc l $$ pprDoc c $$ pprintTidy k n $$ vd $$ text "\n\n\n"-    where-      l        = srcSpanStartLine sp-      c        = srcSpanStartCol sp-      (xd, vd) = pprXOT k xv-      n        = length $ lines $ render vd--pprAnnInfoBind _ (_, _)-  = empty--pprXOT :: (PPrint a, PPrint a1) => F.Tidy -> (Maybe a, a1) -> (Doc, Doc)-pprXOT k (x, v) = (xd, pprintTidy k v)-  where-    xd          = maybe "unknown" (pprintTidy k) x--instance PPrint LMap where-  pprintTidy _ (LMap x xs e) = hcat [pprint x, pprint xs, text "|->", pprint e ]--instance PPrint LogicMap where-  pprintTidy _ (LM lm am) = vcat [ text "Logic Map"-                                 , nest 2 $ text "logic-map"-                                 , nest 4 $ pprint lm-                                 , nest 2 $ text "axiom-map"-                                 , nest 4 $ pprint am-                                 ]------------------------------------------------------------------------------------- | Pretty Printing RefType -------------------------------------------------------------------------------------------------------------------------------------instance (OkRT c tv r) => PPrint (RType c tv r) where-  -- RJ: THIS IS THE CRUCIAL LINE, the following prints short types.-  pprintTidy _ = rtypeDoc F.Lossy-  -- pprintTidy _ = ppRType topPrec--instance (PPrint tv, PPrint ty) => PPrint (RTAlias tv ty) where-  pprintTidy = ppAlias--ppAlias :: (PPrint tv, PPrint ty) => F.Tidy -> RTAlias tv ty -> Doc-ppAlias k a =   pprint (rtName a)-            <+> pprints k space (rtTArgs a)-            <+> pprints k space (rtVArgs a)-            <+> text " = "-            <+> pprint (rtBody a)--instance (F.PPrint tv, F.PPrint t) => F.PPrint (RTEnv tv t) where-  pprintTidy k rte-    =   text "** Type Aliaes *********************"-    $+$ nest 4 (F.pprintTidy k (typeAliases rte))-    $+$ text "** Expr Aliases ********************"-    $+$ nest 4 (F.pprintTidy k (exprAliases rte))--pprints :: (PPrint a) => F.Tidy -> Doc -> [a] -> Doc-pprints k c = sep . punctuate c . map (pprintTidy k)-----------------------------------------------------------------------------------rtypeDoc :: (OkRT c tv r) => F.Tidy -> RType c tv r -> Doc----------------------------------------------------------------------------------rtypeDoc k      = pprRtype (ppE k) topPrec-  where-    ppE F.Lossy = ppEnvShort ppEnv-    ppE F.Full  = ppEnv--instance PPrint F.Tidy where-  pprintTidy _ F.Full  = "Full"-  pprintTidy _ F.Lossy = "Lossy"--type Prec = PprPrec-----------------------------------------------------------------------------------pprRtype :: (OkRT c tv r) => PPEnv -> Prec -> RType c tv r -> Doc----------------------------------------------------------------------------------pprRtype bb p t@(RAllT _ _ r)-  = F.ppTy r $ pprForall bb p t-pprRtype bb p t@(RAllP _ _)-  = pprForall bb p t-pprRtype _ _ (RVar a r)-  = F.ppTy r $ pprint a-pprRtype bb p t@RImpF{}-  = maybeParen p funPrec (pprRtyFun bb empty t)-pprRtype bb p t@RFun{}-  = maybeParen p funPrec (pprRtyFun bb empty t)-pprRtype bb p (RApp c [t] rs r)-  | isList c-  = F.ppTy r $ brackets (pprRtype bb p t) <-> ppReftPs bb p rs-pprRtype bb p (RApp c ts rs r)-  | isTuple c-  = F.ppTy r $ parens (intersperse comma (pprRtype bb p <$> ts)) <-> ppReftPs bb p rs-pprRtype bb p (RApp c ts rs r)-  | isEmpty rsDoc && isEmpty tsDoc-  = F.ppTy r $ ppT c-  | otherwise-  = F.ppTy r $ parens $ ppT c <+> rsDoc <+> tsDoc-  where-    rsDoc            = ppReftPs bb p rs-    tsDoc            = hsep (pprRtype bb p <$> ts)-    ppT              = ppTyConB bb--pprRtype bb p t@REx{}-  = ppExists bb p t-pprRtype bb p t@RAllE{}-  = ppAllExpr bb p t-pprRtype _ _ (RExprArg e)-  = braces $ pprint e-pprRtype bb p (RAppTy t t' r)-  = F.ppTy r $ pprRtype bb p t <+> pprRtype bb p t'-pprRtype bb p (RRTy e _ OCons t)-  = sep [braces (pprRsubtype bb p e) <+> "=>", pprRtype bb p t]-pprRtype bb p (RRTy e r o t)-  = sep [ppp (pprint o <+> ppe <+> pprint r), pprRtype bb p t]-  where-    ppe         = hsep (punctuate comma (ppxt <$> e)) <+> dcolon-    ppp  doc    = text "<<" <+> doc <+> text ">>"-    ppxt (x, t) = pprint x <+> ":" <+> pprRtype bb p t-pprRtype _ _ (RHole r)-  = F.ppTy r $ text "_"--ppTyConB :: TyConable c => PPEnv -> c -> Doc-ppTyConB bb-  | ppShort bb = {- shortModules . -} ppTycon-  | otherwise  = ppTycon--shortModules :: Doc -> Doc-shortModules = text . F.symbolString . dropModuleNames . F.symbol . render--pprRsubtype-  :: (OkRT c tv r, PPrint a, PPrint (RType c tv r), PPrint (RType c tv ()))-  => PPEnv -> Prec -> [(a, RType c tv r)] -> Doc-pprRsubtype bb p e-  = pprint_env <+> text "|-" <+> pprRtype bb p tl <+> "<:" <+> pprRtype bb p tr-  where-    (el, r)  = (init e,  last e)-    (env, l) = (init el, last el)-    tr   = snd r-    tl   = snd l-    pprint_bind (x, t) = pprint x <+> colon <-> colon <+> pprRtype bb p t-    pprint_env         = hsep $ punctuate comma (pprint_bind <$> env)---- | From GHC: TypeRep-maybeParen :: Prec -> Prec -> Doc -> Doc-maybeParen ctxt_prec inner_prec pretty-  | ctxt_prec < inner_prec = pretty-  | otherwise                  = parens pretty--ppExists-  :: (OkRT c tv r, PPrint c, PPrint tv, PPrint (RType c tv r),-      PPrint (RType c tv ()), F.Reftable (RTProp c tv r),-      F.Reftable (RTProp c tv ()))-  => PPEnv -> Prec -> RType c tv r -> Doc-ppExists bb p t-  = text "exists" <+> brackets (intersperse comma [pprDbind bb topPrec x t | (x, t) <- zs]) <-> dot <-> pprRtype bb p t'-    where (zs,  t')               = split [] t-          split zs (REx x t t')   = split ((x,t):zs) t'-          split zs t                = (reverse zs, t)--ppAllExpr-  :: (OkRT c tv r, PPrint (RType c tv r), PPrint (RType c tv ()))-  => PPEnv -> Prec -> RType c tv r -> Doc-ppAllExpr bb p t-  = text "forall" <+> brackets (intersperse comma [pprDbind bb topPrec x t | (x, t) <- zs]) <-> dot <-> pprRtype bb p t'-    where-      (zs,  t')               = split [] t-      split zs (RAllE x t t') = split ((x,t):zs) t'-      split zs t              = (reverse zs, t)--ppReftPs-  :: (OkRT c tv r, PPrint (RType c tv r), PPrint (RType c tv ()),-      F.Reftable (Ref (RType c tv ()) (RType c tv r)))-  => t -> t1 -> [Ref (RType c tv ()) (RType c tv r)] -> Doc-ppReftPs _ _ rs-  | all F.isTauto rs   = empty-  | not (ppPs ppEnv) = empty-  | otherwise        = angleBrackets $ hsep $ punctuate comma $ pprRef <$> rs--pprDbind-  :: (OkRT c tv r, PPrint (RType c tv r), PPrint (RType c tv ()))-  => PPEnv -> Prec -> F.Symbol -> RType c tv r -> Doc-pprDbind bb p x t-  | F.isNonSymbol x || (x == F.dummySymbol)-  = pprRtype bb p t-  | otherwise-  = pprint x <-> colon <-> pprRtype bb p t----pprRtyFun-  :: ( OkRT c tv r, PPrint (RType c tv r), PPrint (RType c tv ()))-  => PPEnv -> Doc -> RType c tv r -> Doc-pprRtyFun bb prefix t = hsep (prefix : dArgs ++ [dOut])-  where-    dArgs               = concatMap ppArg args-    dOut                = pprRtype bb topPrec out-    ppArg (b, t, a)     = [pprDbind bb funPrec b t, a]-    (args, out)         = brkFun t--{--pprRtyFun bb prefix t-  = prefix <+> pprRtyFun' bb t--pprRtyFun'-  :: ( OkRT c tv r, PPrint (RType c tv r), PPrint (RType c tv ()))-  => PPEnv -> RType c tv r -> Doc-pprRtyFun' bb (RImpF b t t' r)-  = F.ppTy r $ pprDbind bb funPrec b t $+$ pprRtyFun bb (text "~>") t'-pprRtyFun' bb (RFun b t t' r)-  = F.ppTy r $ pprDbind bb funPrec b t $+$ pprRtyFun bb arrow t'-pprRtyFun' bb t-  = pprRtype bb topPrec t--}--brkFun :: RType c tv r -> ([(F.Symbol, RType c tv r, Doc)], RType c tv r)-brkFun (RImpF b _ t t' _) = ((b, t, text "~>") : args, out)   where (args, out)     = brkFun t'-brkFun (RFun b _ t t' _)  = ((b, t, text "->") : args, out)   where (args, out)     = brkFun t'-brkFun out                = ([], out)-----pprForall :: (OkRT c tv r) => PPEnv -> Prec -> RType c tv r -> Doc-pprForall bb p t = maybeParen p funPrec $ sep [-                      pprForalls (ppPs bb) (fst <$> ty_vars trep) (ty_preds trep)-                    , pprClss cls-                    , pprRtype bb topPrec t'-                    ]-  where-    trep          = toRTypeRep t-    -- YL: remember to revert back-    (cls, t')     = bkClass $ fromRTypeRep $ trep {ty_vars = [], ty_preds = []}-    -- t' = fromRTypeRep $ trep {ty_vars = [], ty_preds = []}--    pprForalls False _ _  = empty-    pprForalls _    [] [] = empty-    pprForalls True αs πs = text "forall" <+> dαs αs <+> dπs (ppPs bb) πs <-> dot--    pprClss []               = empty-    pprClss cs               = parens (hsep $ punctuate comma (uncurry (pprCls bb p) <$> cs)) <+> text "=>"--    dαs αs                    = pprRtvarDef αs--    -- dπs :: Bool -> [PVar a] -> Doc-    dπs _ []                  = empty-    dπs False _               = empty-    dπs True πs               = angleBrackets $ intersperse comma $ pprPvarDef bb p <$> πs--pprRtvarDef :: (PPrint tv) => [RTVar tv (RType c tv ())] -> Doc-pprRtvarDef = sep . map (pprint . ty_var_value)--pprCls-  :: (OkRT c tv r, PPrint a, PPrint (RType c tv r),-      PPrint (RType c tv ()))-  => PPEnv -> Prec -> a -> [RType c tv r] -> Doc-pprCls bb p c ts-  = pp c <+> hsep (map (pprRtype bb p) ts)-  where-    pp | ppShort bb = text . F.symbolString . dropModuleNames . F.symbol . render . pprint-       | otherwise  = pprint---pprPvarDef :: (OkRT c tv ()) => PPEnv -> Prec -> PVar (RType c tv ()) -> Doc-pprPvarDef bb p (PV s t _ xts)-  = pprint s <+> dcolon <+> intersperse arrow dargs <+> pprPvarKind bb p t-  where-    dargs = [pprPvarSort bb p xt | (xt,_,_) <- xts]---pprPvarKind :: (OkRT c tv ()) => PPEnv -> Prec -> PVKind (RType c tv ()) -> Doc-pprPvarKind bb p (PVProp t) = pprPvarSort bb p t <+> arrow <+> pprName F.boolConName -- propConName-pprPvarKind _ _ PVHProp     = panic Nothing "TODO: pprPvarKind:hprop" -- pprName hpropConName--pprName :: F.Symbol -> Doc-pprName                      = text . F.symbolString--pprPvarSort :: (OkRT c tv ()) => PPEnv -> Prec -> RType c tv () -> Doc-pprPvarSort bb p t = pprRtype bb p t--pprRef :: (OkRT c tv r) => Ref (RType c tv ()) (RType c tv r) -> Doc-pprRef  (RProp ss s) = ppRefArgs (fst <$> ss) <+> pprint s--- pprRef (RProp ss s) = ppRefArgs (fst <$> ss) <+> pprint (fromMaybe mempty (stripRTypeBase s))--ppRefArgs :: [F.Symbol] -> Doc-ppRefArgs [] = empty-ppRefArgs ss = text "\\" <-> hsep (ppRefSym <$> ss ++ [F.vv Nothing]) <+> arrow--ppRefSym :: (Eq a, IsString a, PPrint a) => a -> Doc-ppRefSym "" = text "_"-ppRefSym s  = pprint s--dot :: Doc-dot                = char '.'--instance (PPrint r, F.Reftable r) => PPrint (UReft r) where-  pprintTidy k (MkUReft r p)-    | F.isTauto r  = pprintTidy k p-    | F.isTauto p  = pprintTidy k r-    | otherwise  = pprintTidy k p <-> text " & " <-> pprintTidy k r----------------------------------------------------------------------------------------------------------------------------------------------------------------------- | Pretty-printing errors ---------------------------------------------------------------------------------------------------------------------------------------printError :: (Show e, F.PPrint e) => F.Tidy -> DynFlags -> TError e -> IO ()-printError k dyn err = putErrMsg dyn (pos err) (ppError k empty err)---- | Similar in spirit to 'reportErrors' from the GHC API, but it uses our--- pretty-printer and shim functions under the hood. Also filters the errors--- according to the given `Filter` list.------ @filterReportErrors failure continue filters k@ will call @failure@ if there--- are unexpected errors, or will call @continue@ otherwise.------ An error is expected if there is any filter that matches it.-filterReportErrors :: forall e' a. (Show e', F.PPrint e') => FilePath -> Ghc.TcRn a -> Ghc.TcRn a -> [Filter] -> F.Tidy -> [TError e'] -> Ghc.TcRn a-filterReportErrors path failure continue filters k =-  filterReportErrorsWith-    FilterReportErrorsArgs { msgReporter = Ghc.reportErrors-                           , filterReporter = defaultFilterReporter path-                           , failure = failure-                           , continue = continue-                           , pprinter = \err -> mkLongErrAt (pos err) (ppError k empty err) mempty-                           , matchingFilters = reduceFilters renderer filters-                           , filters = filters-                           }-  where-    renderer e = render (ppError k empty e $+$ pprint (pos e))----- | Retrieve the `Filter`s from the Config.-getFilters :: Config -> [Filter]-getFilters cfg = anyFilter <> stringFilters-  where-    anyFilter = [AnyFilter | expectAnyError cfg]-    stringFilters = StringFilter <$> expectErrorContaining cfg---- | Return the list of @filters@ that matched the @err@ , given a @renderer@--- for the @err@ and some @filters@-reduceFilters :: (e -> String) -> [Filter] -> e -> [Filter]-reduceFilters renderer fs err = filter (filterDoesMatchErr renderer err) fs--filterDoesMatchErr :: (e -> String) -> e -> Filter -> Bool-filterDoesMatchErr _        _ AnyFilter = True-filterDoesMatchErr renderer e (StringFilter filter) = stringMatch filter (renderer e)--stringMatch :: String -> String -> Bool-stringMatch filter str = filter `L.isInfixOf` str---- | Used in `filterReportErrorsWith'`-data FilterReportErrorsArgs m filter msg e a =-  FilterReportErrorsArgs-  {-    -- | Report the @msgs@ to the monad (usually IO)-    msgReporter :: [msg] -> m ()-  ,-    -- | Report unmatched @filters@ to the monad-    filterReporter :: [filter] -> m ()-  ,-    -- | Continuation for when there are unmatched filters or unmatched errors-    failure :: m a-  ,-    -- | Continuation for when there are no unmatched errors or filters-    continue :: m a-  ,-    -- | Compute a representation of the given error; does not report the error-    pprinter :: e -> m msg-  ,-    -- | Yields the filters that map a given error. Must only yield-    -- filters in the @filters@ field.-    matchingFilters :: e -> [filter]-  ,-    -- | List of filters which could have been matched-    filters :: [filter]-  }---- | Calls the continuations in FilterReportErrorsArgs depending on whethere there--- are unmatched errors, unmatched filters or none.-filterReportErrorsWith :: (Monad m, Ord filter) => FilterReportErrorsArgs m filter msg e a -> [e] -> m a-filterReportErrorsWith FilterReportErrorsArgs {..} errs =-  let-    (unmatchedErrors, matchedFilters) =-      L.partition (null . snd) [ (e, fs) | e <- errs, let fs = matchingFilters e ]-    unmatchedFilters = Set.toList $-      Set.fromList filters `Set.difference` Set.fromList (concatMap snd matchedFilters)-  in-    if null unmatchedErrors then-      if null unmatchedFilters then-        continue-      else do-        filterReporter unmatchedFilters-        failure-    else do-      msgs <- traverse (pprinter . fst) unmatchedErrors-      void $ msgReporter msgs-      failure---- | Report errors via GHC's API stating the given `Filter`s did not get--- matched. Does nothing if the list of filters is empty.-defaultFilterReporter :: FilePath -> [Filter] -> Ghc.TcRn ()-defaultFilterReporter _ [] = pure ()-defaultFilterReporter path fs = Ghc.reportError =<< mkLongErrAt srcSpan (vcat $ leaderMsg : (nest 4 <$> filterMsgs)) empty-  where-    leaderMsg :: Doc-    leaderMsg = text "Could not match the following expected errors with actual thrown errors:"--    filterToMsg :: Filter -> Doc-    filterToMsg AnyFilter = text "<Any Liquid error>"-    filterToMsg (StringFilter s) = text "String filter: " <-> quotes (text s)--    filterMsgs :: [Doc]-    filterMsgs = filterToMsg <$> fs--    beginningOfFile :: Ghc.SrcLoc-    beginningOfFile = Ghc.mkSrcLoc (fromString path) 1 1--    srcSpan :: SrcSpan-    srcSpan = Ghc.mkSrcSpan beginningOfFile beginningOfFile
− src/Language/Haskell/Liquid/Types/RefType.hs 
@@ -1,1948 +0,0 @@-{-# LANGUAGE IncoherentInstances       #-}-{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE MultiParamTypeClasses     #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE UndecidableInstances      #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE PatternGuards             #-}-{-# LANGUAGE ConstraintKinds           #-}-{-# LANGUAGE ViewPatterns              #-}--{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- TODO(#1918): Only needed for GHC <9.0.1.-{-# OPTIONS_GHC -Wno-orphans #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-}---- | Refinement Types. Mostly mirroring the GHC Type definition, but with---   room for refinements of various sorts.--- TODO: Desperately needs re-organization.--module Language.Haskell.Liquid.Types.RefType (--    TyConMap--  -- * Functions for lifting Reft-values to Spec-values-  , uTop, uReft, uRType, uRType', uRTypeGen, uPVar--  -- * Applying a solution to a SpecType-  , applySolution--  -- * Functions for decreasing arguments-  , isDecreasing, makeDecrType, makeNumEnv-  , makeLexRefa--  -- * Functions for manipulating `Predicate`s-  , pdVar-  , findPVar-  , FreeVar, allTyVars, allTyVars', freeTyVars, tyClasses, tyConName--  -- * Quantifying RTypes-  , quantifyRTy-  , quantifyFreeRTy--  -- * RType constructors-  , ofType, toType, bareOfType-  , bTyVar, rTyVar, rVar, rApp, gApp, rEx-  , symbolRTyVar, bareRTyVar-  , tyConBTyCon-  , pdVarReft--  -- * Substitutions-  , subts, subvPredicate, subvUReft-  , subsTyVarMeet, subsTyVarMeet', subsTyVarNoMeet-  , subsTyVarsNoMeet, subsTyVarsMeet--  -- * Destructors-  , addTyConInfo-  , appRTyCon-  , typeUniqueSymbol-  , classBinds-  , isSizeable-  , famInstTyConType-  , famInstArgs--  -- * Manipulating Refinements in RTypes-  , strengthen-  , generalize-  , normalizePds-  , dataConMsReft-  , dataConReft-  , rTypeSortedReft-  , rTypeSort-  , typeSort-  , shiftVV--  -- * TODO: classify these-  -- , mkDataConIdsTy-  , expandProductType-  , mkTyConInfo-  , strengthenRefTypeGen-  , strengthenDataConType-  , isBaseTy-  , updateRTVar, isValKind, kindToRType-  , rTVarInfo--  , tyVarsPosition, Positions(..)--  , isNumeric--  ) where---- import           GHC.Stack-import Prelude hiding (error)--- import qualified Prelude-import           Data.Maybe               (fromMaybe, isJust)-import           Data.Bifunctor           (first)-import           Data.Monoid              (First(..))-import           Data.Hashable-import qualified Data.HashMap.Strict  as M-import qualified Data.HashSet         as S-import qualified Data.List as L-import           Control.Monad  (void)-import           Text.Printf-import           Text.PrettyPrint.HughesPJ hiding ((<>), first)-import           Language.Fixpoint.Misc-import           Language.Fixpoint.Types hiding (DataDecl (..), DataCtor (..), panic, shiftVV, Predicate, isNumeric)-import           Language.Fixpoint.Types.Visitor (mapKVars, Visitable)-import qualified Language.Fixpoint.Types as F-import           Language.Haskell.Liquid.Types.Errors-import           Language.Haskell.Liquid.Types.PrettyPrint--import           Language.Haskell.Liquid.Types.Types hiding (R, DataConP (..))-import           Language.Haskell.Liquid.Types.Variance-import           Language.Haskell.Liquid.Misc-import           Language.Haskell.Liquid.Types.Names-import qualified Liquid.GHC.Misc as GM-import           Liquid.GHC.Play (mapType, stringClassArg, isRecursivenewTyCon)-import           Liquid.GHC.API        as Ghc hiding ( Expr-                                                                      , Located-                                                                      , tyConName-                                                                      , punctuate-                                                                      , hcat-                                                                      , (<+>)-                                                                      , parens-                                                                      , empty-                                                                      , dcolon-                                                                      , vcat-                                                                      , nest-                                                                      , ($+$)-                                                                      , panic-                                                                      , text-                                                                      )-import           Liquid.GHC.TypeRep () -- Eq Type instance-import Data.List (foldl')--------strengthenDataConType :: (Var, SpecType) -> (Var, SpecType)-strengthenDataConType (x, t) = (x, fromRTypeRep trep {ty_res = tres})-  where-    tres     = F.notracepp _msg $ ty_res trep `strengthen` MkUReft (exprReft expr) mempty-    trep     = toRTypeRep t-    _msg     = "STRENGTHEN-DATACONTYPE x = " ++ F.showpp (x, zip xs ts)-    (xs, ts) = dataConArgs trep-    as       = ty_vars  trep-    x'       = symbol x-    expr | null xs && null as = EVar x'-         | otherwise          = mkEApp (dummyLoc x') (EVar <$> xs)---dataConArgs :: SpecRep -> ([Symbol], [SpecType])-dataConArgs trep = unzip [ (x, t) | (x, t) <- zip xs ts, isValTy t]-  where-    xs           = ty_binds trep-    ts           = ty_args trep-    isValTy      = not . Ghc.isEvVarType . toType False---pdVar :: PVar t -> Predicate-pdVar v        = Pr [uPVar v]--findPVar :: [PVar (RType c tv ())] -> UsedPVar -> PVar (RType c tv ())-findPVar ps p = PV name ty v (zipWith (\(_, _, e) (t, s, _) -> (t, s, e)) (pargs p) args)-  where-    PV name ty v args = fromMaybe (msg p) $ L.find ((== pname p) . pname) ps-    msg p = panic Nothing $ "RefType.findPVar" ++ showpp p ++ "not found"---- | Various functions for converting vanilla `Reft` to `Spec`--uRType          ::  RType c tv a -> RType c tv (UReft a)-uRType          = fmap uTop--uRType'         ::  RType c tv (UReft a) -> RType c tv a-uRType'         = fmap ur_reft--uRTypeGen       :: Reftable b => RType c tv a -> RType c tv b-uRTypeGen       = fmap $ const mempty--uPVar           :: PVar t -> UsedPVar-uPVar           = void--uReft           :: (Symbol, Expr) -> UReft Reft-uReft           = uTop . Reft--uTop            ::  r -> UReft r-uTop r          = MkUReft r mempty------------------------------------------------------------------------------------- (Class) Predicates for Valid Refinement Types --------------------------------------------------------------------------------- Monoid Instances -----------------------------------------------------------instance ( SubsTy tv (RType c tv ()) (RType c tv ())-         , SubsTy tv (RType c tv ()) c-         , OkRT c tv r-         , FreeVar c tv-         , SubsTy tv (RType c tv ()) r-         , SubsTy tv (RType c tv ()) tv-         , SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ()))-         )-        => Semigroup (RType c tv r)  where-  (<>) = strengthenRefType---- TODO: remove, use only Semigroup?-instance ( SubsTy tv (RType c tv ()) (RType c tv ())-         , SubsTy tv (RType c tv ()) c-         , OkRT c tv r-         , FreeVar c tv-         , SubsTy tv (RType c tv ()) r-         , SubsTy tv (RType c tv ()) tv-         , SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ()))-         )-        => Monoid (RType c tv r)  where-  mempty  = panic Nothing "mempty: RType"-  mappend = strengthenRefType---- MOVE TO TYPES-instance ( SubsTy tv (RType c tv ()) c-         , OkRT c tv r-         , FreeVar c tv-         , SubsTy tv (RType c tv ()) r-         , SubsTy tv (RType c tv ()) (RType c tv ())-         , SubsTy tv (RType c tv ()) tv-         , SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ()))-         )-         => Semigroup (RTProp c tv r) where-  (<>) (RProp s1 (RHole r1)) (RProp s2 (RHole r2))-    | isTauto r1 = RProp s2 (RHole r2)-    | isTauto r2 = RProp s1 (RHole r1)-    | otherwise  = RProp s1 $ RHole $ r1 `meet`-                               subst (mkSubst $ zip (fst <$> s2) (EVar . fst <$> s1)) r2--  (<>) (RProp s1 t1) (RProp s2 t2)-    | isTrivial t1 = RProp s2 t2-    | isTrivial t2 = RProp s1 t1-    | otherwise    = RProp s1 $ t1  `strengthenRefType`-                                subst (mkSubst $ zip (fst <$> s2) (EVar . fst <$> s1)) t2---- TODO: remove and use only Semigroup?-instance ( SubsTy tv (RType c tv ()) c-         , OkRT c tv r-         , FreeVar c tv-         , SubsTy tv (RType c tv ()) r-         , SubsTy tv (RType c tv ()) (RType c tv ())-         , SubsTy tv (RType c tv ()) tv-         , SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ()))-         )-         => Monoid (RTProp c tv r) where-  mempty  = panic Nothing "mempty: RTProp"-  mappend = (<>)--{--NV: The following makes ghc diverge thus dublicating the code-instance ( OkRT c tv r-         , FreeVar c tv-         , SubsTy tv (RType c tv ()) r-         , SubsTy tv (RType c tv ()) (RType c tv ())-         , SubsTy tv (RType c tv ()) c-         , SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ()))-         , SubsTy tv (RType c tv ()) tv-         ) => Reftable (RTProp c tv r) where-  isTauto (RProp _ (RHole r)) = isTauto r-  isTauto (RProp _ t)         = isTrivial t-  top (RProp _ (RHole _))     = panic Nothing "RefType: Reftable top called on (RProp _ (RHole _))"-  top (RProp xs t)            = RProp xs $ mapReft top t-  ppTy (RProp _ (RHole r)) d  = ppTy r d-  ppTy (RProp _ _) _          = panic Nothing "RefType: Reftable ppTy in RProp"-  toReft                      = panic Nothing "RefType: Reftable toReft"-  params                      = panic Nothing "RefType: Reftable params for Ref"-  bot                         = panic Nothing "RefType: Reftable bot    for Ref"-  ofReft                      = panic Nothing "RefType: Reftable ofReft for Ref"--}--instance Reftable (RTProp RTyCon RTyVar (UReft Reft)) where-  isTauto (RProp _ (RHole r)) = isTauto r-  isTauto (RProp _ t)         = isTrivial t-  top (RProp _ (RHole _))     = panic Nothing "RefType: Reftable top called on (RProp _ (RHole _))"-  top (RProp xs t)            = RProp xs $ mapReft top t-  ppTy (RProp _ (RHole r)) d  = ppTy r d-  ppTy (RProp _ _) _          = panic Nothing "RefType: Reftable ppTy in RProp"-  toReft                      = panic Nothing "RefType: Reftable toReft"-  params                      = panic Nothing "RefType: Reftable params for Ref"-  bot                         = panic Nothing "RefType: Reftable bot    for Ref"-  ofReft                      = panic Nothing "RefType: Reftable ofReft for Ref"--instance Reftable (RTProp RTyCon RTyVar ()) where-  isTauto (RProp _ (RHole r)) = isTauto r-  isTauto (RProp _ t)         = isTrivial t-  top (RProp _ (RHole _))     = panic Nothing "RefType: Reftable top called on (RProp _ (RHole _))"-  top (RProp xs t)            = RProp xs $ mapReft top t-  ppTy (RProp _ (RHole r)) d  = ppTy r d-  ppTy (RProp _ _) _          = panic Nothing "RefType: Reftable ppTy in RProp"-  toReft                      = panic Nothing "RefType: Reftable toReft"-  params                      = panic Nothing "RefType: Reftable params for Ref"-  bot                         = panic Nothing "RefType: Reftable bot    for Ref"-  ofReft                      = panic Nothing "RefType: Reftable ofReft for Ref"--instance Reftable (RTProp BTyCon BTyVar (UReft Reft)) where-  isTauto (RProp _ (RHole r)) = isTauto r-  isTauto (RProp _ t)         = isTrivial t-  top (RProp _ (RHole _))     = panic Nothing "RefType: Reftable top called on (RProp _ (RHole _))"-  top (RProp xs t)            = RProp xs $ mapReft top t-  ppTy (RProp _ (RHole r)) d  = ppTy r d-  ppTy (RProp _ _) _          = panic Nothing "RefType: Reftable ppTy in RProp"-  toReft                      = panic Nothing "RefType: Reftable toReft"-  params                      = panic Nothing "RefType: Reftable params for Ref"-  bot                         = panic Nothing "RefType: Reftable bot    for Ref"-  ofReft                      = panic Nothing "RefType: Reftable ofReft for Ref"--instance Reftable (RTProp BTyCon BTyVar ())  where-  isTauto (RProp _ (RHole r)) = isTauto r-  isTauto (RProp _ t)         = isTrivial t-  top (RProp _ (RHole _))     = panic Nothing "RefType: Reftable top called on (RProp _ (RHole _))"-  top (RProp xs t)            = RProp xs $ mapReft top t-  ppTy (RProp _ (RHole r)) d  = ppTy r d-  ppTy (RProp _ _) _          = panic Nothing "RefType: Reftable ppTy in RProp"-  toReft                      = panic Nothing "RefType: Reftable toReft"-  params                      = panic Nothing "RefType: Reftable params for Ref"-  bot                         = panic Nothing "RefType: Reftable bot    for Ref"-  ofReft                      = panic Nothing "RefType: Reftable ofReft for Ref"--instance Reftable (RTProp RTyCon RTyVar Reft) where-  isTauto (RProp _ (RHole r)) = isTauto r-  isTauto (RProp _ t)         = isTrivial t-  top (RProp _ (RHole _))     = panic Nothing "RefType: Reftable top called on (RProp _ (RHole _))"-  top (RProp xs t)            = RProp xs $ mapReft top t-  ppTy (RProp _ (RHole r)) d  = ppTy r d-  ppTy (RProp _ _) _          = panic Nothing "RefType: Reftable ppTy in RProp"-  toReft                      = panic Nothing "RefType: Reftable toReft"-  params                      = panic Nothing "RefType: Reftable params for Ref"-  bot                         = panic Nothing "RefType: Reftable bot    for Ref"-  ofReft                      = panic Nothing "RefType: Reftable ofReft for Ref"--------------------------------------------------------------------------------- | Subable Instances ------------------------------------------------------------------------------------------------------------------------------------instance Subable (RRProp Reft) where-  syms (RProp ss (RHole r)) = (fst <$> ss) ++ syms r-  syms (RProp ss t)      = (fst <$> ss) ++ syms t---  subst su (RProp ss (RHole r)) = RProp (mapSnd (subst su) <$> ss) $ RHole $ subst su r-  subst su (RProp ss r)  = RProp  (mapSnd (subst su) <$> ss) $ subst su r---  substf f (RProp ss (RHole r)) = RProp (mapSnd (substf f) <$> ss) $ RHole $ substf f r-  substf f (RProp ss r) = RProp  (mapSnd (substf f) <$> ss) $ substf f r--  substa f (RProp ss (RHole r)) = RProp (mapSnd (substa f) <$> ss) $ RHole $ substa f r-  substa f (RProp ss r) = RProp  (mapSnd (substa f) <$> ss) $ substa f r------------------------------------------------------------------------------------- | Reftable Instances -----------------------------------------------------------------------------------------------------------------------------------------instance (PPrint r, Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, Reftable (RTProp RTyCon RTyVar r))-    => Reftable (RType RTyCon RTyVar r) where-  isTauto     = isTrivial-  ppTy        = panic Nothing "ppTy RProp Reftable"-  toReft      = panic Nothing "toReft on RType"-  params      = panic Nothing "params on RType"-  bot         = panic Nothing "bot on RType"-  ofReft      = panic Nothing "ofReft on RType"---instance Reftable (RType BTyCon BTyVar (UReft Reft)) where-  isTauto     = isTrivial-  top t       = mapReft top t-  ppTy        = panic Nothing "ppTy RProp Reftable"-  toReft      = panic Nothing "toReft on RType"-  params      = panic Nothing "params on RType"-  bot         = panic Nothing "bot on RType"-  ofReft      = panic Nothing "ofReft on RType"------ MOVE TO TYPES-instance Fixpoint String where-  toFix = text---- MOVE TO TYPES-instance Fixpoint Class where-  toFix = text . GM.showPpr---- MOVE TO TYPES-class FreeVar a v where-  freeVars :: a -> [v]---- MOVE TO TYPES-instance FreeVar RTyCon RTyVar where-  freeVars = (RTV <$>) . GM.tyConTyVarsDef . rtc_tc---- MOVE TO TYPES-instance FreeVar BTyCon BTyVar where-  freeVars _ = []---- Eq Instances ---------------------------------------------------------- MOVE TO TYPES-instance (Eq c, Eq tv, Hashable tv, PPrint tv, TyConable c, PPrint c, Reftable (RTProp c tv ()))-      => Eq (RType c tv ()) where-  (==) = eqRSort M.empty--eqRSort :: (Eq a, Eq k, Hashable k, TyConable a, PPrint a, PPrint k, Reftable (RTProp a k ()))-        => M.HashMap k k -> RType a k () -> RType a k () -> Bool-eqRSort m (RAllP _ t) (RAllP _ t')-  = eqRSort m t t'-eqRSort m (RAllP _ t) t'-  = eqRSort m t t'-eqRSort m (RAllT a t _) (RAllT a' t' _)-  | a == a'-  = eqRSort m t t'-  | otherwise-  = eqRSort (M.insert (ty_var_value a') (ty_var_value a) m) t t'-eqRSort m (RAllT _ t _) t'-  = eqRSort m t t'-eqRSort m t (RAllT _ t' _)-  = eqRSort m t t'-eqRSort m (RFun _ _ t1 t2 _) (RFun _ _ t1' t2' _)-  = eqRSort m t1 t1' && eqRSort m t2 t2'-eqRSort m (RAppTy t1 t2 _) (RAppTy t1' t2' _)-  = eqRSort m t1 t1' && eqRSort m t2 t2'-eqRSort m (RApp c ts _ _) (RApp c' ts' _ _)-  = c == c' && length ts == length ts' && and (zipWith (eqRSort m) ts ts')-eqRSort m (RVar a _) (RVar a' _)-  = a == M.lookupDefault a' a' m-eqRSort _ (RHole _) _-  = True-eqRSort _ _         (RHole _)-  = True-eqRSort _ _ _-  = False------------------------------------------------------------------------------------- | Wrappers for GHC Type Elements -------------------------------------------------------------------------------------------------------------------------------instance Eq RTyVar where-  -- FIXME: need to compare unique and string because we reuse-  -- uniques in stringTyVar and co.-  RTV α == RTV α' = α == α' && getOccName α == getOccName α'--instance Ord RTyVar where-  compare (RTV α) (RTV α') = case compare α α' of-    EQ -> compare (getOccName α) (getOccName α')-    o  -> o--instance Hashable RTyVar where-  hashWithSalt i (RTV α) = hashWithSalt i α---- TyCon isn't comparable---instance Ord RTyCon where---  compare x y = compare (rtc_tc x) (rtc_tc y)--instance Hashable RTyCon where-  hashWithSalt i = hashWithSalt i . rtc_tc------------------------------------------------------------------------------------- | Helper Functions (RJ: Helping to do what?) -------------------------------------------------------------------------------------------------------------------rVar :: Monoid r => TyVar -> RType c RTyVar r-rVar   = (`RVar` mempty) . RTV--rTyVar :: TyVar -> RTyVar-rTyVar = RTV--updateRTVar :: Monoid r => RTVar RTyVar i -> RTVar RTyVar (RType RTyCon RTyVar r)-updateRTVar (RTVar (RTV a) _) = RTVar (RTV a) (rTVarInfo a)--rTVar :: Monoid r => TyVar -> RTVar RTyVar (RRType r)-rTVar a = RTVar (RTV a) (rTVarInfo a)--bTVar :: Monoid r => TyVar -> RTVar BTyVar (BRType r)-bTVar a = RTVar (BTV (symbol a)) (bTVarInfo a)--bTVarInfo :: Monoid r => TyVar -> RTVInfo (BRType r)-bTVarInfo = mkTVarInfo kindToBRType--rTVarInfo :: Monoid r => TyVar -> RTVInfo (RRType r)-rTVarInfo = mkTVarInfo kindToRType--mkTVarInfo :: (Kind -> s) -> TyVar -> RTVInfo s-mkTVarInfo k2t a = RTVInfo-  { rtv_name   = symbol    $ varName a-  , rtv_kind   = k2t       $ tyVarKind a-  , rtv_is_val = isValKind $ tyVarKind a-  , rtv_is_pol = True-  }--kindToRType :: Monoid r => Type -> RRType r-kindToRType = kindToRType_ ofType--kindToBRType :: Monoid r => Type -> BRType r-kindToBRType = kindToRType_ bareOfType--kindToRType_ :: (Type -> z) -> Type -> z-kindToRType_ ofType        = ofType . go-  where-    go t-     | t == typeSymbolKind = stringTy-     | t == typeNatKind    = intTy-     | otherwise           = t--isValKind :: Kind -> Bool-isValKind x = x == typeNatKind || x == typeSymbolKind--bTyVar :: Symbol -> BTyVar-bTyVar      = BTV--symbolRTyVar :: Symbol -> RTyVar-symbolRTyVar = rTyVar . GM.symbolTyVar--bareRTyVar :: BTyVar -> RTyVar-bareRTyVar (BTV tv) = symbolRTyVar tv--normalizePds :: (OkRT c tv r) => RType c tv r -> RType c tv r-normalizePds t = addPds ps t'-  where-    (t', ps)   = nlzP [] t--rPred :: PVar (RType c tv ()) -> RType c tv r -> RType c tv r-rPred     = RAllP--rEx :: Foldable t-    => t (Symbol, RType c tv r) -> RType c tv r -> RType c tv r-rEx xts t = foldr (\(x, tx) t -> REx x tx t) t xts--rApp :: TyCon-     -> [RType RTyCon tv r]-     -> [RTProp RTyCon tv r]-     -> r-     -> RType RTyCon tv r-rApp c = RApp (tyConRTyCon c)--gApp :: TyCon -> [RTyVar] -> [PVar a] -> SpecType-gApp tc αs πs = rApp tc-                  [rVar α | RTV α <- αs]-                  (rPropP [] . pdVarReft <$> πs)-                  mempty--pdVarReft :: PVar t -> UReft Reft-pdVarReft = (\p -> MkUReft mempty p) . pdVar--tyConRTyCon :: TyCon -> RTyCon-tyConRTyCon c = RTyCon c [] (mkTyConInfo c [] [] Nothing)---- bApp :: (Monoid r) => TyCon -> [BRType r] -> BRType r-bApp :: TyCon -> [BRType r] -> [BRProp r] -> r -> BRType r-bApp c = RApp (tyConBTyCon c)--tyConBTyCon :: TyCon -> BTyCon-tyConBTyCon = mkBTyCon . fmap tyConName . GM.locNamedThing--- tyConBTyCon = mkBTyCon . fmap symbol . locNamedThing----- NV TODO : remove this code!!!--addPds :: Foldable t-       => t (PVar (RType c tv ())) -> RType c tv r -> RType c tv r-addPds ps (RAllT v t r) = RAllT v (addPds ps t) r-addPds ps t             = foldl' (flip rPred) t ps--nlzP :: (OkRT c tv r) => [PVar (RType c tv ())] -> RType c tv r -> (RType c tv r, [PVar (RType c tv ())])-nlzP ps t@(RVar _ _ )- = (t, ps)-nlzP ps (RImpF b i t1 t2 r)- = (RImpF b i t1' t2' r, ps ++ ps1 ++ ps2)-  where (t1', ps1) = nlzP [] t1-        (t2', ps2) = nlzP [] t2-nlzP ps (RFun b i t1 t2 r)- = (RFun b i t1' t2' r, ps ++ ps1 ++ ps2)-  where (t1', ps1) = nlzP [] t1-        (t2', ps2) = nlzP [] t2-nlzP ps (RAppTy t1 t2 r)- = (RAppTy t1' t2' r, ps ++ ps1 ++ ps2)-  where (t1', ps1) = nlzP [] t1-        (t2', ps2) = nlzP [] t2-nlzP ps (RAllT v t r)- = (RAllT v t' r, ps ++ ps')-  where (t', ps') = nlzP [] t-nlzP ps t@RApp{}- = (t, ps)-nlzP ps (RAllP p t)- = (t', [p] ++ ps ++ ps')-  where (t', ps') = nlzP [] t-nlzP ps t@REx{}- = (t, ps)-nlzP ps t@(RRTy _ _ _ t')- = (t, ps ++ ps')- where ps' = snd $ nlzP [] t'-nlzP ps t@RAllE{}- = (t, ps)-nlzP _ t- = panic Nothing $ "RefType.nlzP: cannot handle " ++ show t--strengthenRefTypeGen, strengthenRefType ::-         (  OkRT c tv r-         , FreeVar c tv-         , SubsTy tv (RType c tv ()) (RType c tv ())-         , SubsTy tv (RType c tv ()) c-         , SubsTy tv (RType c tv ()) r-         , SubsTy tv (RType c tv ()) tv-         , SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ()))-         ) => RType c tv r -> RType c tv r -> RType c tv r--strengthenRefType_ ::-         ( OkRT c tv r-         , FreeVar c tv-         , SubsTy tv (RType c tv ()) (RType c tv ())-         , SubsTy tv (RType c tv ()) c-         , SubsTy tv (RType c tv ()) r-         , SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ()))-         , SubsTy tv (RType c tv ()) tv-         ) => (RType c tv r -> RType c tv r -> RType c tv r)-           ->  RType c tv r -> RType c tv r -> RType c tv r--strengthenRefTypeGen t1 t2 = strengthenRefType_ f t1 t2-  where-    f (RVar v1 r1) t  = RVar v1 (r1 `meet` fromMaybe mempty (stripRTypeBase t))-    f t (RVar _ r1)  = t `strengthen` r1-    f t1 t2           = panic Nothing $ printf "strengthenRefTypeGen on differently shaped types \nt1 = %s [shape = %s]\nt2 = %s [shape = %s]"-                         (pprRaw t1) (showpp (toRSort t1)) (pprRaw t2) (showpp (toRSort t2))--pprRaw :: (OkRT c tv r) => RType c tv r -> String-pprRaw = render . rtypeDoc Full--{- [NOTE:StrengthenRefType] disabling the `meetable` check because--      (1) It requires the 'TCEmb TyCon' to deal with the fact that sometimes,-          GHC uses the "Family Instance" TyCon e.g. 'R:UniquePerson' and sometimes-          the vanilla TyCon App form, e.g. 'Unique Person'-      (2) We could pass in the TCEmb but that would break the 'Monoid' instance for-          RType. The 'Monoid' instance was was probably a bad idea to begin with,-          and we probably ought to do away with it entirely, but thats a battle I'll-          leave for another day.--    Consequently, its up to users of `strengthenRefType` (and associated functions)-    to make sure that the two types are compatible. For an example, see 'meetVarTypes'.- -}--strengthenRefType t1 t2-  -- | _meetable t1 t2-  = strengthenRefType_ const t1 t2-  -- | otherwise-  -- = panic Nothing msg-  -- where-  --   msg = printf "strengthen on differently shaped reftypes \nt1 = %s [shape = %s]\nt2 = %s [shape = %s]"-  --           (showpp t1) (showpp (toRSort t1)) (showpp t2) (showpp (toRSort t2))--_meetable :: (OkRT c tv r) => RType c tv r -> RType c tv r -> Bool-_meetable t1 t2 = toRSort t1 == toRSort t2--strengthenRefType_ f (RAllT a1 t1 r1) (RAllT a2 t2 r2)-  = RAllT a1 (strengthenRefType_ f t1 (subsTyVarMeet (ty_var_value a2, toRSort t, t) t2)) (r1 `meet` r2)-  where t = RVar (ty_var_value a1) mempty--strengthenRefType_ f (RAllT a t1 r1) t2-  = RAllT a (strengthenRefType_ f t1 t2) r1--strengthenRefType_ f t1 (RAllT a t2 r2)-  = RAllT a (strengthenRefType_ f t1 t2) r2--strengthenRefType_ f (RAllP p1 t1) (RAllP _ t2)-  = RAllP p1 $ strengthenRefType_ f t1 t2--strengthenRefType_ f (RAllP p t1) t2-  = RAllP p $ strengthenRefType_ f t1 t2--strengthenRefType_ f t1 (RAllP p t2)-  = RAllP p $ strengthenRefType_ f t1 t2--strengthenRefType_ f (RAllE x tx t1) (RAllE y ty t2) | x == y-  = RAllE x (strengthenRefType_ f tx ty) $ strengthenRefType_ f t1 t2--strengthenRefType_ f (RAllE x tx t1) t2-  = RAllE x tx $ strengthenRefType_ f t1 t2--strengthenRefType_ f t1 (RAllE x tx t2)-  = RAllE x tx $ strengthenRefType_ f t1 t2--strengthenRefType_ f (RAppTy t1 t1' r1) (RAppTy t2 t2' r2)-  = RAppTy t t' (r1 `meet` r2)-    where t  = strengthenRefType_ f t1 t2-          t' = strengthenRefType_ f t1' t2'--strengthenRefType_ f (RImpF x1 i t1 t1' r1) (RImpF x2 _ t2 t2' r2)-  = RImpF x2 i t t' (r1 `meet` r2)-    where t  = strengthenRefType_ f t1 t2-          t' = strengthenRefType_ f (subst1 t1' (x1, EVar x2)) t2'---- YL: Evidence that we need a Monoid instance for RFInfo?-strengthenRefType_ f (RFun x1 i1 t1 t1' r1) (RFun x2 i2 t2 t2' r2)-  | x2 /= F.dummySymbol-  = RFun x2 i1{permitTC = getFirst b} t t' (r1 `meet` r2)-    where t  = strengthenRefType_ f t1 t2-          t' = strengthenRefType_ f (subst1 t1' (x1, EVar x2)) t2'-          b  = First (permitTC i1) <> First (permitTC i2)--strengthenRefType_ f (RFun x1 i1 t1 t1' r1) (RFun x2 i2 t2 t2' r2)-  = RFun x1 i1{permitTC = getFirst b} t t' (r1 `meet` r2)-    where t  = strengthenRefType_ f t1 t2-          t' = strengthenRefType_ f t1' (subst1 t2' (x2, EVar x1))-          b  = First (permitTC i1) <> First (permitTC i2)--strengthenRefType_ f (RApp tid t1s rs1 r1) (RApp _ t2s rs2 r2)-  = RApp tid ts rs (r1 `meet` r2)-    where ts  = zipWith (strengthenRefType_ f) t1s t2s-          rs  = meets rs1 rs2---strengthenRefType_ _ (RVar v1 r1)  (RVar v2 r2) | v1 == v2-  = RVar v1 (r1 `meet` r2)-strengthenRefType_ f t1 t2-  = f t1 t2--meets :: (F.Reftable r) => [r] -> [r] -> [r]-meets [] rs                 = rs-meets rs []                 = rs-meets rs rs'-  | length rs == length rs' = zipWith meet rs rs'-  | otherwise               = panic Nothing "meets: unbalanced rs"--strengthen :: Reftable r => RType c tv r -> r -> RType c tv r-strengthen (RApp c ts rs r) r'  = RApp c ts rs (r `F.meet` r')-strengthen (RVar a r) r'        = RVar a       (r `F.meet` r')-strengthen (RImpF b i t1 t2 r) r' = RImpF b i t1 t2 (r `F.meet` r')-strengthen (RFun b i t1 t2 r) r'  = RFun b i t1 t2 (r `F.meet` r')-strengthen (RAppTy t1 t2 r) r'  = RAppTy t1 t2 (r `F.meet` r')-strengthen (RAllT a t r)    r'  = RAllT a t    (r `F.meet` r')-strengthen t _                  = t---quantifyRTy :: (Monoid r, Eq tv) => [RTVar tv (RType c tv ())] -> RType c tv r -> RType c tv r-quantifyRTy tvs ty = foldr rAllT ty tvs-  where rAllT a t = RAllT a t mempty--quantifyFreeRTy :: (Monoid r, Eq tv) => RType c tv r -> RType c tv r-quantifyFreeRTy ty = quantifyRTy (freeTyVars ty) ty-----------------------------------------------------------------------------addTyConInfo :: (PPrint r, Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, Reftable (RTProp RTyCon RTyVar r))-             => TCEmb TyCon-             -> TyConMap-             -> RRType r-             -> RRType r---------------------------------------------------------------------------addTyConInfo tce tyi = mapBot (expandRApp tce tyi)----------------------------------------------------------------------------expandRApp :: (PPrint r, Reftable r, SubsTy RTyVar RSort r, Reftable (RRProp r))-           => TCEmb TyCon -> TyConMap -> RRType r -> RRType r---------------------------------------------------------------------------expandRApp tce tyi t@RApp{} = RApp rc' ts rs' r-  where-    RApp rc ts rs r            = t-    (rc', _)                   = appRTyCon tce tyi rc as-    pvs                        = rTyConPVs rc'-    rs'                        = applyNonNull rs0 (rtPropPV rc pvs) rs-    rs0                        = rtPropTop <$> pvs-    n                          = length fVs-    fVs                        = GM.tyConTyVarsDef $ rtc_tc rc-    as                         = choosen n ts (rVar <$> fVs)-expandRApp _ _ t               = t--choosen :: Int -> [a] -> [a] -> [a]-choosen 0 _ _           = []-choosen i (x:xs) (_:ys) = x:choosen (i-1) xs ys-choosen i []     (y:ys) = y:choosen (i-1) [] ys-choosen _ _ _           = impossible Nothing "choosen: this cannot happen"---rtPropTop-  :: (OkRT c tv r,-      SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,-      SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,-      SubsTy tv (RType c tv ()) tv,-      SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))-   => PVar (RType c tv ()) -> Ref (RType c tv ()) (RType c tv r)-rtPropTop pv = case ptype pv of-                 PVProp t -> RProp xts $ ofRSort t-                 PVHProp  -> RProp xts mempty-               where-                 xts      =  pvArgs pv--rtPropPV :: (Fixpoint a, Reftable r)-         => a-         -> [PVar (RType c tv ())]-         -> [Ref (RType c tv ()) (RType c tv r)]-         -> [Ref (RType c tv ()) (RType c tv r)]-rtPropPV _rc = zipWith mkRTProp--mkRTProp :: Reftable r-         => PVar (RType c tv ())-         -> Ref (RType c tv ()) (RType c tv r)-         -> Ref (RType c tv ()) (RType c tv r)-mkRTProp pv (RProp ss (RHole r))-  = RProp ss $ ofRSort (pvType pv) `strengthen` r--mkRTProp pv (RProp ss t)-  | length (pargs pv) == length ss-  = RProp ss t-  | otherwise-  = RProp (pvArgs pv) t--pvArgs :: PVar t -> [(Symbol, t)]-pvArgs pv = [(s, t) | (t, s, _) <- pargs pv]--{- | [NOTE:FamInstPredVars] related to [NOTE:FamInstEmbeds]-     See tests/datacon/pos/T1446.hs -     The function txRefSort converts--        Int<p>              ===> {v:Int | p v}--     which is fine, but also converts--        Field<q> Blob a     ===> {v:Field Blob a | q v}-        -     which is NOT ok, because q expects a different arg.--     The above happens because, thanks to instance-family stuff,-     LH doesn't realize that q is actually an ARG of Field Blob-     Note that Field itself has no args, but Field Blob does...--     That is, it is not enough to store the refined `TyCon` info,-     solely in the `RTyCon` as with family instances, you need BOTH -     the `TyCon` and the args to determine the extra info. -     -     We do so in `TyConMap`, and by crucially extending --     @RefType.appRTyCon@ whose job is to use the Refined @TyCon@ -     that is, the @RTyCon@ generated from the @TyConP@ to strengthen-     individual occurrences of the TyCon applied to various arguments.-- -}--appRTyCon :: (ToTypeable r) => TCEmb TyCon -> TyConMap -> RTyCon -> [RRType r] -> (RTyCon, [RPVar])-appRTyCon tce tyi rc ts = F.notracepp _msg (resTc, ps'')-  where-    _msg  = "appRTyCon-family: " ++ showpp (Ghc.isFamilyTyCon c, Ghc.tyConRealArity c, toType False <$> ts)-    resTc = RTyCon c ps'' (rtc_info rc'')-    c     = rtc_tc rc--    (rc', ps') = rTyConWithPVars tyi rc (rTypeSort tce <$> ts)-    -- TODO:faminst-preds rc'   = M.lookupDefault rc c (tcmTyRTy tyi)-    -- TODO:faminst-preds ps'   = rTyConPVs rc' --    -- TODO:faminst-preds: these substitutions may be WRONG if we are using FAMINST.-    ps''  = subts (zip (RTV <$> αs) ts') <$> ps'-      where-        ts' = if null ts then rVar <$> βs else toRSort <$> ts-        αs  = GM.tyConTyVarsDef (rtc_tc rc')-        βs  = GM.tyConTyVarsDef c--    rc''  = if isNumeric tce rc' then addNumSizeFun rc' else rc'--rTyConWithPVars :: TyConMap -> RTyCon -> [F.Sort] -> (RTyCon, [RPVar])-rTyConWithPVars tyi rc ts = case famInstTyConMb tyi rc ts of-  Just fiRc    -> (rc', rTyConPVs fiRc)       -- use the PVars from the family-instance TyCon-  Nothing      -> (rc', ps')                  -- use the PVars from the origin          TyCon-  where-    (rc', ps') = plainRTyConPVars tyi rc---- | @famInstTyConMb rc args@ uses the @RTyCon@ AND @args@ to see if ---   this is a family instance @RTyCon@, and if so, returns it.---   see [NOTE:FamInstPredVars]---   eg: 'famInstTyConMb tyi Field [Blob, a]' should give 'Just R:FieldBlob' --famInstTyConMb :: TyConMap -> RTyCon -> [F.Sort] -> Maybe RTyCon-famInstTyConMb tyi rc ts = do-  let c = rtc_tc rc-  n    <- M.lookup c      (tcmFtcArity tyi)-  M.lookup (c, take n ts) (tcmFIRTy    tyi)--famInstTyConType :: Ghc.TyCon -> Maybe Ghc.Type-famInstTyConType c = uncurry Ghc.mkTyConApp <$> famInstArgs c---- | @famInstArgs c@ destructs a family-instance @TyCon@ into its components, e.g. ---   e.g. 'famInstArgs R:FieldBlob' is @(Field, [Blob])@ --famInstArgs :: Ghc.TyCon -> Maybe (Ghc.TyCon, [Ghc.Type])-famInstArgs c = case Ghc.tyConFamInst_maybe c of-    Just (c', ts) -> F.notracepp ("famInstArgs: " ++ F.showpp (c, cArity, ts))-                     $ Just (c', take (length ts - cArity) ts)-    Nothing       -> Nothing-    where-      cArity      = Ghc.tyConRealArity c---- TODO:faminst-preds: case Ghc.tyConFamInst_maybe c of--- TODO:faminst-preds:   Just (c', ts) -> F.tracepp ("famInstTyConType: " ++ F.showpp (c, Ghc.tyConArity c, ts)) --- TODO:faminst-preds:                    $ Just (famInstType (Ghc.tyConArity c) c' ts)--- TODO:faminst-preds:   Nothing       -> Nothing---- TODO:faminst-preds: famInstType :: Int -> Ghc.TyCon -> [Ghc.Type] -> Ghc.Type--- TODO:faminst-preds: famInstType n c ts = Ghc.mkTyConApp c (take (length ts - n) ts)------- | @plainTyConPVars@ uses the @TyCon@ to return the ---   "refined" @RTyCon@ and @RPVars@ from the refined ---   'data' definition for the @TyCon@, e.g. will use ---   'List Int' to return 'List<p> Int' (if List has an abs-ref).-plainRTyConPVars :: TyConMap -> RTyCon -> (RTyCon, [RPVar])-plainRTyConPVars tyi rc = (rc', rTyConPVs rc')-  where-    rc'                   = M.lookupDefault rc (rtc_tc rc) (tcmTyRTy tyi)------ RJ: The code of `isNumeric` is incomprehensible.--- Please fix it to use intSort instead of intFTyCon-isNumeric :: TCEmb TyCon -> RTyCon -> Bool-isNumeric tce c = F.isNumeric mySort-  where-    -- mySort      = M.lookupDefault def rc tce-    mySort      = maybe def fst (F.tceLookup rc tce)-    def         = FTC . symbolFTycon . dummyLoc . tyConName $ rc-    rc          = rtc_tc c--addNumSizeFun :: RTyCon -> RTyCon-addNumSizeFun c-  = c {rtc_info = (rtc_info c) {sizeFunction = Just IdSizeFun } }---generalize :: (Eq tv, Monoid r) => RType c tv r -> RType c tv r-generalize t = mkUnivs (zip (freeTyVars t) (repeat mempty)) [] t--allTyVars :: (Ord tv) => RType c tv r -> [tv]-allTyVars = sortNub . allTyVars'--allTyVars' :: (Eq tv) => RType c tv r -> [tv]-allTyVars' t = fmap ty_var_value $ vs ++ vs'-  where-    vs      = map fst . fst3 . bkUniv $ t-    vs'     = freeTyVars t---freeTyVars :: Eq tv => RType c tv r -> [RTVar tv (RType c tv ())]-freeTyVars (RAllP _ t)     = freeTyVars t-freeTyVars (RAllT α t _)   = freeTyVars t L.\\ [α]-freeTyVars (RImpF _ _ t t' _)= freeTyVars t `L.union` freeTyVars t'-freeTyVars (RFun _ _ t t' _) = freeTyVars t `L.union` freeTyVars t'-freeTyVars (RApp _ ts _ _) = L.nub $ concatMap freeTyVars ts-freeTyVars (RVar α _)      = [makeRTVar α]-freeTyVars (RAllE _ tx t)  = freeTyVars tx `L.union` freeTyVars t-freeTyVars (REx _ tx t)    = freeTyVars tx `L.union` freeTyVars t-freeTyVars (RExprArg _)    = []-freeTyVars (RAppTy t t' _) = freeTyVars t `L.union` freeTyVars t'-freeTyVars (RHole _)       = []-freeTyVars (RRTy e _ _ t)  = L.nub $ concatMap freeTyVars (t:(snd <$> e))---tyClasses :: (OkRT RTyCon tv r) => RType RTyCon tv r -> [(Class, [RType RTyCon tv r])]-tyClasses (RAllP _ t)     = tyClasses t-tyClasses (RAllT _ t _)   = tyClasses t-tyClasses (RAllE _ _ t)   = tyClasses t-tyClasses (REx _ _ t)     = tyClasses t-tyClasses (RImpF _ _ t t' _) = tyClasses t ++ tyClasses t'-tyClasses (RFun _ _ t t' _) = tyClasses t ++ tyClasses t'-tyClasses (RAppTy t t' _) = tyClasses t ++ tyClasses t'-tyClasses (RApp c ts _ _)-  | Just cl <- tyConClass_maybe $ rtc_tc c-  = [(cl, ts)]-  | otherwise-  = []-tyClasses (RVar _ _)      = []-tyClasses (RRTy _ _ _ t)  = tyClasses t-tyClasses (RHole _)       = []-tyClasses t               = panic Nothing ("RefType.tyClasses cannot handle" ++ show t)-------------------------------------------------------------------------------------- TODO: Rewrite subsTyvars with Traversable-----------------------------------------------------------------------------------subsTyVarsMeet-  :: (Eq tv, Foldable t, Hashable tv, Reftable r, TyConable c,-      SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,-      SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,-      SubsTy tv (RType c tv ()) tv,-      SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))-  => t (tv, RType c tv (), RType c tv r) -> RType c tv r -> RType c tv r-subsTyVarsMeet        = subsTyVars True--subsTyVarsNoMeet-  :: (Eq tv, Foldable t, Hashable tv, Reftable r, TyConable c,-      SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,-      SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,-      SubsTy tv (RType c tv ()) tv,-      SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))-  => t (tv, RType c tv (), RType c tv r) -> RType c tv r -> RType c tv r-subsTyVarsNoMeet      = subsTyVars False--subsTyVarNoMeet-  :: (Eq tv, Hashable tv, Reftable r, TyConable c,-      SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,-      SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,-      SubsTy tv (RType c tv ()) tv,-      SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))-  => (tv, RType c tv (), RType c tv r) -> RType c tv r -> RType c tv r-subsTyVarNoMeet       = subsTyVar False--subsTyVarMeet-  :: (Eq tv, Hashable tv, Reftable r, TyConable c,-      SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,-      SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,-      SubsTy tv (RType c tv ()) tv,-      SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))-  => (tv, RType c tv (), RType c tv r) -> RType c tv r -> RType c tv r-subsTyVarMeet         = subsTyVar True--subsTyVarMeet'-  :: (Eq tv, Hashable tv, Reftable r, TyConable c,-      SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,-      SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,-      SubsTy tv (RType c tv ()) tv,-      SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))-  => (tv, RType c tv r) -> RType c tv r -> RType c tv r-subsTyVarMeet' (α, t) = subsTyVarMeet (α, toRSort t, t)--subsTyVars-  :: (Eq tv, Foldable t, Hashable tv, Reftable r, TyConable c,-      SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,-      SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,-      SubsTy tv (RType c tv ()) tv,-      SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))-  => Bool-  -> t (tv, RType c tv (), RType c tv r)-  -> RType c tv r-  -> RType c tv r-subsTyVars meet ats t = foldl' (flip (subsTyVar meet)) t ats--subsTyVar-  :: (Eq tv, Hashable tv, Reftable r, TyConable c,-      SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,-      SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,-      SubsTy tv (RType c tv ()) tv,-      SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))-  => Bool-  -> (tv, RType c tv (), RType c tv r)-  -> RType c tv r-  -> RType c tv r-subsTyVar meet        = subsFree meet S.empty--subsFree-  :: (Eq tv, Hashable tv, Reftable r, TyConable c,-      SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,-      SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,-      SubsTy tv (RType c tv ()) tv,-      SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))-  => Bool-  -> S.HashSet tv-  -> (tv, RType c tv (), RType c tv r)-  -> RType c tv r-  -> RType c tv r-subsFree m s z@(α, τ,_) (RAllP π t)-  = RAllP (subt (α, τ) π) (subsFree m s z t)-subsFree m s z@(a, τ, _) (RAllT α t r)-  -- subt inside the type variable instantiates the kind of the variable-  = RAllT (subt (a, τ) α) (subsFree m (ty_var_value α `S.insert` s) z t) (subt (a, τ) r)-subsFree m s z@(α, τ, _) (RImpF x i t t' r)-  = RImpF x i (subsFree m s z t) (subsFree m s z t') (subt (α, τ) r)-subsFree m s z@(α, τ, _) (RFun x i t t' r)-  = RFun x i (subsFree m s z t) (subsFree m s z t') (subt (α, τ) r)-subsFree m s z@(α, τ, _) (RApp c ts rs r)-  = RApp c' (subsFree m s z <$> ts) (subsFreeRef m s z <$> rs) (subt (α, τ) r)-    where z' = (α, τ) -- UNIFY: why instantiating INSIDE parameters?-          c' = if α `S.member` s then c else subt z' c-subsFree meet s (α', τ, t') (RVar α r)-  | α == α' && not (α `S.member` s)-  = if meet then t' `strengthen` subt (α, τ) r else t'-  | otherwise-  = RVar (subt (α', τ) α) r-subsFree m s z (RAllE x t t')-  = RAllE x (subsFree m s z t) (subsFree m s z t')-subsFree m s z (REx x t t')-  = REx x (subsFree m s z t) (subsFree m s z t')-subsFree m s z@(α, τ, _) (RAppTy t t' r)-  = subsFreeRAppTy m s (subsFree m s z t) (subsFree m s z t') (subt (α, τ) r)-subsFree _ _ _ t@(RExprArg _)-  = t-subsFree m s z@(α, τ, _) (RRTy e r o t)-  = RRTy (mapSnd (subsFree m s z) <$> e) (subt (α, τ) r) o (subsFree m s z t)-subsFree _ _ (α, τ, _) (RHole r)-  = RHole (subt (α, τ) r)--subsFrees-  :: (Eq tv, Hashable tv, Reftable r, TyConable c,-      SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,-      SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,-      SubsTy tv (RType c tv ()) tv,-      SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))-  => Bool-  -> S.HashSet tv-  -> [(tv, RType c tv (), RType c tv r)]-  -> RType c tv r-  -> RType c tv r-subsFrees m s zs t = foldl' (flip (subsFree m s)) t zs---- GHC INVARIANT: RApp is Type Application to something other than TYCon-subsFreeRAppTy-  :: (Eq tv, Hashable tv, Reftable r, TyConable c,-      SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,-      SubsTy tv (RType c tv ()) (RType c tv ()),-      FreeVar c tv,-      SubsTy tv (RType c tv ()) tv,-      SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))-  => Bool-  -> S.HashSet tv-  -> RType c tv r-  -> RType c tv r-  -> r-  -> RType c tv r-subsFreeRAppTy m s (RApp c ts rs r) t' r'-  = mkRApp m s c (ts ++ [t']) rs r r'-subsFreeRAppTy _ _ t t' r'-  = RAppTy t t' r'----- | @mkRApp@ is the refined variant of GHC's @mkTyConApp@ which ensures that ---    that applications of the "function" type constructor are normalized to ---    the special case @FunTy _@ representation. The extra `_rep1`, and `_rep2` ---    parameters come from the "levity polymorphism" changes in GHC 8.6 (?)---    See [NOTE:Levity-Polymorphism]--mkRApp :: (Eq tv, Hashable tv, Reftable r, TyConable c,-      SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,-      SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,-      SubsTy tv (RType c tv ()) tv,-      SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))-  => Bool-  -> S.HashSet tv-  -> c-  -> [RType c tv r]-  -> [RTProp c tv r]-  -> r-  -> r-  -> RType c tv r-mkRApp m s c ts rs r r'-  | isFun c, [_rep1, _rep2, t1, t2] <- ts-  = RFun dummySymbol defRFInfo t1 t2 (refAppTyToFun r')-  | otherwise-  = subsFrees m s zs (RApp c ts rs (r `meet` r'))-  where-    zs = [(tv, toRSort t, t) | (tv, t) <- zip (freeVars c) ts]--{-| [NOTE:Levity-Polymorphism] - -     Thanks to Joachim Brietner and Simon Peyton-Jones!-     With GHC's "levity polymorphism feature", see more here --         https://stackoverflow.com/questions/35318562/what-is-levity-polymorphism     --     The function type constructor actually has type--        (->) :: forall (r1::RuntimeRep) (r2::RuntimeRep).  TYPE r1 -> TYPE r2 -> TYPE LiftedRep--     so we have to be careful to follow GHC's @mkTyConApp@ -     -        https://hackage.haskell.org/package/ghc-8.6.4/docs/src/Type.html#mkTyConApp--     which normalizes applications of the `FunTyCon` constructor to use the special -     case `FunTy _` representation thus, so that we are not stuck with incompatible -     representations e.g. --        thing -> thing                                                  ... (using RFun)--     and --        (-> 'GHC.Types.LiftedRep 'GHC.Types.LiftedRep thing thing)      ... (using RApp)---     More details from Joachim Brietner:--     Now you might think that the function arrow has the following kind: `(->) :: * -> * -> *`.-     But that is not the full truth: You can have functions that accept or return things with -     different representations than just the usual lifted one.--     So the function arrow actually has kind `(->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> *`.-     And in `(-> 'GHC.Types.LiftedRep 'GHC.Types.LiftedRep thing thing)`  you see this spelled -     out explicitly. But it really is just `(thing -> thing)`, just printed with more low-level detail.--     Also see--       • https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#levity-polymorphism-       • and other links from https://stackoverflow.com/a/35320729/946226 (edited) - -}--refAppTyToFun :: Reftable r => r -> r-refAppTyToFun r-  | isTauto r = r-  | otherwise = panic Nothing "RefType.refAppTyToFun"--subsFreeRef-  :: (Eq tv, Hashable tv, Reftable r, TyConable c,-      SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,-      SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,-      SubsTy tv (RType c tv ()) tv,-      SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))-  => Bool-  -> S.HashSet tv-  -> (tv, RType c tv (), RType c tv r)-  -> RTProp c tv r-  -> RTProp c tv r-subsFreeRef _ _ (α', τ', _) (RProp ss (RHole r))-  = RProp (mapSnd (subt (α', τ')) <$> ss) (RHole r)-subsFreeRef m s (α', τ', t')  (RProp ss t)-  = RProp (mapSnd (subt (α', τ')) <$> ss) $ subsFree m s (α', τ', fmap top t') t-------------------------------------------------------------------------------------- | Type Substitutions -------------------------------------------------------------------------------------------------------------------------------------------subts :: (SubsTy tv ty c) => [(tv, ty)] -> c -> c-subts = flip (foldr subt)--instance SubsTy RTyVar (RType RTyCon RTyVar ()) RTyVar where-  subt (RTV x, t) (RTV z) | isTyVar z, tyVarKind z == TyVarTy x-    = RTV (setVarType z $ toType False t)-  subt _ v-    = v--instance SubsTy RTyVar (RType RTyCon RTyVar ()) (RTVar RTyVar (RType RTyCon RTyVar ())) where-  -- NV TODO: update kind-  subt su rty = rty { ty_var_value = subt su $ ty_var_value rty }---instance SubsTy BTyVar (RType c BTyVar ()) BTyVar where-  subt _ = id--instance SubsTy BTyVar (RType c BTyVar ()) (RTVar BTyVar (RType c BTyVar ())) where-  subt _ = id--instance SubsTy tv ty ()   where-  subt _ = id--instance SubsTy tv ty Symbol where-  subt _ = id----instance (SubsTy tv ty Expr) => SubsTy tv ty Reft where-  subt su (Reft (x, e)) = Reft (x, subt su e)--instance SubsTy Symbol Symbol (BRType r) where-  subt (x,y) (RVar v r)-    | BTV x == v = RVar (BTV y) r-    | otherwise  = RVar v r-  subt (x, y) (RAllT (RTVar v i) t r)-    | BTV x == v = RAllT (RTVar v i) t r-    | otherwise  = RAllT (RTVar v i) (subt (x,y) t) r-  subt su (RFun x i t1 t2 r)  = RFun x i (subt su t1) (subt su t2) r-  subt su (RImpF x i t1 t2 r) = RImpF x i (subt su t1) (subt su t2) r-  subt su (RAllP p t)       = RAllP p (subt su t)-  subt su (RApp c ts ps r)  = RApp c (subt su <$> ts) (subt su <$> ps) r-  subt su (RAllE x t1 t2)   = RAllE x (subt su t1) (subt su t2)-  subt su (REx x t1 t2)     = REx x (subt su t1) (subt su t2)-  subt _  (RExprArg e)      = RExprArg e-  subt su (RAppTy t1 t2 r)  = RAppTy (subt su t1) (subt su t2) r-  subt su (RRTy e r o t)    = RRTy [(x, subt su p) | (x,p) <- e] r o (subt su t)-  subt _ (RHole r)          = RHole r--instance SubsTy Symbol Symbol (RTProp BTyCon BTyVar r) where-  subt su (RProp e t) =  RProp [(x, subt su xt) | (x,xt) <- e] (subt su t)----instance (SubsTy tv ty Sort) => SubsTy tv ty Expr where-  subt su (ELam (x, s) e) = ELam (x, subt su s) $ subt su e-  subt su (EApp e1 e2)    = EApp (subt su e1) (subt su e2)-  subt su (ENeg e)        = ENeg (subt su e)-  subt su (PNot e)        = PNot (subt su e)-  subt su (EBin b e1 e2)  = EBin b (subt su e1) (subt su e2)-  subt su (EIte e e1 e2)  = EIte (subt su e) (subt su e1) (subt su e2)-  subt su (ECst e s)      = ECst (subt su e) (subt su s)-  subt su (ETApp e s)     = ETApp (subt su e) (subt su s)-  subt su (ETAbs e x)     = ETAbs (subt su e) x-  subt su (PAnd es)       = PAnd (subt su <$> es)-  subt su (POr  es)       = POr  (subt su <$> es)-  subt su (PImp e1 e2)    = PImp (subt su e1) (subt su e2)-  subt su (PIff e1 e2)    = PIff (subt su e1) (subt su e2)-  subt su (PAtom b e1 e2) = PAtom b (subt su e1) (subt su e2)-  subt su (PAll xes e)    = PAll (subt su <$> xes) (subt su e)-  subt su (PExist xes e)  = PExist (subt su <$> xes) (subt su e)-  subt _ e                = e--instance (SubsTy tv ty a, SubsTy tv ty b) => SubsTy tv ty (a, b) where-  subt su (x, y) = (subt su x, subt su y)--instance SubsTy BTyVar (RType BTyCon BTyVar ()) Sort where-  subt (v, RVar α _) (FObj s)-    | symbol v == s = FObj $ symbol α-    | otherwise     = FObj s-  subt _ s          = s---instance SubsTy Symbol RSort Sort where-  subt (v, RVar α _) (FObj s)-    | symbol v == s = FObj $ symbol {- rTyVarSymbol -} α-    | otherwise     = FObj s-  subt _ s          = s---instance SubsTy RTyVar RSort Sort where-  subt (v, sv) (FObj s)-    | symbol v == s = typeSort mempty (toType True sv)-    | otherwise     = FObj s-  subt _ s          = s--instance (SubsTy tv ty ty) => SubsTy tv ty (PVKind ty) where-  subt su (PVProp t) = PVProp (subt su t)-  subt _   PVHProp   = PVHProp--instance (SubsTy tv ty ty) => SubsTy tv ty (PVar ty) where-  subt su (PV n t v xts) = PV n (subt su t) v [(subt su t, x, y) | (t,x,y) <- xts]--instance SubsTy RTyVar RSort RTyCon where-   subt z c = RTyCon tc ps' i-     where-       tc   = rtc_tc c-       ps'  = subt z <$> rTyConPVs c-       i    = rtc_info c---- NOTE: This DOES NOT substitute at the binders-instance SubsTy RTyVar RSort PrType where-  subt (α, τ) = subsTyVarMeet (α, τ, ofRSort τ)--instance SubsTy RTyVar RSort SpecType where-  subt (α, τ) = subsTyVarMeet (α, τ, ofRSort τ)--instance SubsTy TyVar Type SpecType where-  subt (α, τ) = subsTyVarMeet (RTV α, ofType τ, ofType τ)--instance SubsTy RTyVar RTyVar SpecType where-  subt (α, a) = subt (α, RVar a () :: RSort)---instance SubsTy RTyVar RSort RSort where-  subt (α, τ) = subsTyVarMeet (α, τ, ofRSort τ)--instance SubsTy tv RSort Predicate where-  subt _ = id -- NV TODO--instance (SubsTy tv ty r) => SubsTy tv ty (UReft r) where-  subt su r = r {ur_reft = subt su $ ur_reft r}---- Here the "String" is a Bare-TyCon. TODO: wrap in newtype-instance SubsTy BTyVar BSort BTyCon where-  subt _ t = t--instance SubsTy BTyVar BSort BSort where-  subt (α, τ) = subsTyVarMeet (α, τ, ofRSort τ)--instance (SubsTy tv ty (UReft r), SubsTy tv ty (RType c tv ())) => SubsTy tv ty (RTProp c tv (UReft r))  where-  subt m (RProp ss (RHole p)) = RProp (mapSnd (subt m) <$> ss) $ RHole $ subt m p-  subt m (RProp ss t) = RProp (mapSnd (subt m) <$> ss) $ fmap (subt m) t--subvUReft     :: (UsedPVar -> UsedPVar) -> UReft Reft -> UReft Reft-subvUReft f (MkUReft r p) = MkUReft r (subvPredicate f p)--subvPredicate :: (UsedPVar -> UsedPVar) -> Predicate -> Predicate-subvPredicate f (Pr pvs) = Pr (f <$> pvs)-----------------------------------------------------------------------------------ofType :: Monoid r => Type -> RRType r----------------------------------------------------------------------------------ofType      = ofType_ $ TyConv-  { tcFVar  = rVar-  , tcFTVar = rTVar-  , tcFApp  = \c ts -> rApp c ts [] mempty-  , tcFLit  = ofLitType rApp-  }-----------------------------------------------------------------------------------bareOfType :: Monoid r => Type -> BRType r----------------------------------------------------------------------------------bareOfType  = ofType_ $ TyConv-  { tcFVar  = (`RVar` mempty) . BTV . symbol-  , tcFTVar = bTVar-  , tcFApp  = \c ts -> bApp c ts [] mempty-  , tcFLit  = ofLitType bApp-  }-----------------------------------------------------------------------------------ofType_ :: Monoid r => TyConv c tv r -> Type -> RType c tv r----------------------------------------------------------------------------------ofType_ tx = go . expandTypeSynonyms-  where-    go (TyVarTy α)-      = tcFVar tx α-    go (FunTy _ _ τ τ')-      = rFun dummySymbol (go τ) (go τ')-    go (ForAllTy (Bndr α _) τ)-      = RAllT (tcFTVar tx α) (go τ) mempty-    go (TyConApp c τs)-      | Just (αs, τ) <- Ghc.synTyConDefn_maybe c-      = go (substTyWith αs τs τ)-      | otherwise-      = tcFApp tx c (go <$> τs) -- [] mempty-    go (AppTy t1 t2)-      = RAppTy (go t1) (ofType_ tx t2) mempty-    go (LitTy x)-      = tcFLit tx x-    go (CastTy t _)-      = go t-    go (CoercionTy _)-      = errorstar "Coercion is currently not supported"--ofLitType :: (Monoid r) => (TyCon -> [RType c tv r] -> [p] -> r -> RType c tv r) -> TyLit -> RType c tv r-ofLitType rF (NumTyLit _)  = rF intTyCon [] [] mempty-ofLitType rF t@(StrTyLit _)-  | t == holeLit           = RHole mempty-  | otherwise              = rF listTyCon [rF charTyCon [] [] mempty] [] mempty--holeLit :: TyLit-holeLit = StrTyLit "$LH_RHOLE"--data TyConv c tv r = TyConv-  { tcFVar  :: TyVar -> RType c tv r-  , tcFTVar :: TyVar -> RTVar tv (RType c tv ())-  , tcFApp  :: TyCon -> [RType c tv r] -> RType c tv r-  , tcFLit  :: TyLit -> RType c tv r-  }------------------------------------------------------------------------------------- | Converting to Fixpoint ----------------------------------------------------------------------------------------------------------------------------------------instance Expression Var where-  expr   = eVar---- TODO: turn this into a map lookup?-dataConReft ::  DataCon -> [Symbol] -> Reft-dataConReft c []-  | c == trueDataCon-  = predReft $ eProp vv_-  | c == falseDataCon-  = predReft $ PNot $ eProp vv_--dataConReft c [x]-  | c == intDataCon-  = symbolReft x -- OLD (vv_, [RConc (PAtom Eq (EVar vv_) (EVar x))])-dataConReft c _-  | not $ isBaseDataCon c-  = mempty-dataConReft c xs-  = exprReft dcValue -- OLD Reft (vv_, [RConc (PAtom Eq (EVar vv_) dcValue)])-  where-    dcValue-      | null xs && null (dataConUnivTyVars c)-      = EVar $ symbol c-      | otherwise-      = mkEApp (dummyLoc $ symbol c) (eVar <$> xs)--isBaseDataCon :: DataCon -> Bool-isBaseDataCon c = and $ isBaseTy <$> map irrelevantMult (dataConOrigArgTys c ++ dataConRepArgTys c)--isBaseTy :: Type -> Bool-isBaseTy (TyVarTy _)      = True-isBaseTy (AppTy _ _)      = False-isBaseTy (TyConApp _ ts)  = and $ isBaseTy <$> ts-isBaseTy FunTy{}          = False-isBaseTy (ForAllTy _ _)   = False-isBaseTy (LitTy _)        = True-isBaseTy (CastTy _ _)     = False-isBaseTy (CoercionTy _)   = False---dataConMsReft :: Reftable r => RType c tv r -> [Symbol] -> Reft-dataConMsReft ty ys  = subst su (rTypeReft (ignoreOblig $ ty_res trep))-  where-    trep = toRTypeRep ty-    xs   = ty_binds trep-    ts   = ty_args  trep-    su   = mkSubst $ [(x, EVar y) | ((x, _), y) <- zip (zip xs ts) ys]------------------------------------------------------------------------------------- | Embedding RefTypes -------------------------------------------------------------------------------------------------------------------------------------------type ToTypeable r = (Reftable r, PPrint r, SubsTy RTyVar (RRType ()) r, Reftable (RTProp RTyCon RTyVar r))---- TODO: remove toType, generalize typeSort--- YL: really should take a type-level Bool-toType  :: (ToTypeable r) => Bool -> RRType r -> Type-toType useRFInfo (RImpF x i t t' r)- = toType useRFInfo (RFun x i t t' r)-toType useRFInfo (RFun _ RFInfo{permitTC = permitTC} t@(RApp c _ _ _) t' _)-  | useRFInfo && isErasable c  = toType useRFInfo t'-  | otherwise-  = FunTy VisArg Many (toType useRFInfo t) (toType useRFInfo t')-  where isErasable = if permitTC == Just True then isEmbeddedDict else isClass-toType useRFInfo (RFun _ _ t t' _)-  = FunTy VisArg Many (toType useRFInfo t) (toType useRFInfo t')-toType useRFInfo (RAllT a t _) | RTV α <- ty_var_value a-  = ForAllTy (Bndr α Required) (toType useRFInfo t)-toType useRFInfo (RAllP _ t)-  = toType useRFInfo t-toType _ (RVar (RTV α) _)-  = TyVarTy α-toType useRFInfo (RApp RTyCon{rtc_tc = c} ts _ _)-  = TyConApp c (toType useRFInfo <$> filter notExprArg ts)-  where-    notExprArg (RExprArg _) = False-    notExprArg _            = True-toType useRFInfo (RAllE _ _ t)-  = toType useRFInfo t-toType useRFInfo (REx _ _ t)-  = toType useRFInfo t-toType useRFInfo (RAppTy t (RExprArg _) _)-  = toType useRFInfo t-toType useRFInfo (RAppTy t t' _)-  = AppTy (toType useRFInfo t) (toType useRFInfo t')-toType _ t@(RExprArg _)-  = impossible Nothing $ "CANNOT HAPPEN: RefType.toType called with: " ++ show t-toType useRFInfo (RRTy _ _ _ t)-  = toType useRFInfo t-toType _ (RHole _)-  = LitTy holeLit--- toType t---  = {- impossible Nothing -} Prelude.error $ "RefType.toType cannot handle: " ++ show t--{- | [NOTE:Hole-Lit] --We use `toType` to convert RType to GHC.Type to expand any GHC -related type-aliases, e.g. in Bare.Resolve.expandRTypeSynonyms. -If the RType has a RHole then what to do?--We, encode `RHole` as `LitTy "LH_HOLE"` -- which is a bit of -a *hack*. The only saving grace is it is used *temporarily* -and then swiftly turned back into an `RHole` via `ofType` -(after GHC has done its business of expansion).--Of course, we hope this doesn't break any GHC invariants!-See issue #1476 and #1477 --The other option is to *not* use `toType` on things that have-holes in them, but this seems worse, e.g. because you may define -a plain GHC alias like:--    type ToNat a = a -> Nat --and then you might write refinement types like:--    {-@ foo :: ToNat {v:_ | 0 <= v} @-}--and we'd want to expand the above to--    {-@ foo :: {v:_ | 0 <= v} -> Nat @-}--and then resolve the hole using the (GHC) type of `foo`.---}------------------------------------------------------------------------------------- | Annotations and Solutions ------------------------------------------------------------------------------------------------------------------------------------rTypeSortedReft ::  (PPrint r, Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, Reftable (RTProp RTyCon RTyVar r))-                => TCEmb TyCon -> RRType r -> SortedReft-rTypeSortedReft emb t = RR (rTypeSort emb t) (rTypeReft t)--rTypeSort     ::  (PPrint r, Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, Reftable (RTProp RTyCon RTyVar r))-              => TCEmb TyCon -> RRType r -> Sort-rTypeSort tce = typeSort tce . toType True-----------------------------------------------------------------------------------applySolution :: (Functor f) => FixSolution -> f SpecType -> f SpecType----------------------------------------------------------------------------------applySolution = fmap . fmap . mapReft . appSolRefa-  where-    mapReft f (MkUReft (Reft (x, z)) p) = MkUReft (Reft (x, f z)) p--appSolRefa :: Visitable t-           => M.HashMap KVar Expr -> t -> t-appSolRefa s p = mapKVars f p-  where-    f k        = Just $ M.lookupDefault PTop k s------------------------------------------------------------------------------------- shiftVV :: Int -- SpecType -> Symbol -> SpecType-shiftVV :: (TyConable c, F.Reftable (f Reft), Functor f)-        => RType c tv (f Reft) -> Symbol -> RType c tv (f Reft)----------------------------------------------------------------------------------shiftVV t@(RApp _ ts rs r) vv'-  = t { rt_args  = subst1 ts (rTypeValueVar t, EVar vv') }-      { rt_pargs = subst1 rs (rTypeValueVar t, EVar vv') }-      { rt_reft  = (`F.shiftVV` vv') <$> r }--shiftVV t@(RImpF _ _ _ _ r) vv'-  = t { rt_reft = (`F.shiftVV` vv') <$> r }--shiftVV t@(RFun _ _ _ _ r) vv'-  = t { rt_reft = (`F.shiftVV` vv') <$> r }--shiftVV t@(RAppTy _ _ r) vv'-  = t { rt_reft = (`F.shiftVV` vv') <$> r }--shiftVV t@(RVar _ r) vv'-  = t { rt_reft = (`F.shiftVV` vv') <$> r }--shiftVV t _-  = t -- errorstar $ "shiftVV: cannot handle " ++ showpp t-------------------------------------------------------------------------------------- |Auxiliary Stuff Used Elsewhere ---------------------------------------------------------------------------------------------------------------------------------- MOVE TO TYPES-instance (Show tv, Show ty) => Show (RTAlias tv ty) where-  show (RTA n as xs t) =-    printf "type %s %s %s = %s" (symbolString n)-      (unwords (show <$> as))-      (unwords (show <$> xs))-      (show t)------------------------------------------------------------------------------------- | From Old Fixpoint -------------------------------------------------------------------------------------------------------------------------------------------typeSort :: TCEmb TyCon -> Type -> Sort-typeSort tce = go-  where-    go :: Type -> Sort-    go t@FunTy{}        = typeSortFun tce t-    go τ@(ForAllTy _ _) = typeSortForAll tce τ-    -- go (TyConApp c τs)  = fApp (tyConFTyCon tce c) (go <$> τs)-    go (TyConApp c τs)-      | isNewTyCon c-      , not (isRecursivenewTyCon c)-      = go (Ghc.newTyConInstRhs c τs)-      | otherwise-      = tyConFTyCon tce c (go <$> τs)-    go (AppTy t1 t2)    = fApp (go t1) [go t2]-    go (TyVarTy tv)     = tyVarSort tv-    go (CastTy t _)     = go t-    go τ                = FObj (typeUniqueSymbol τ)--tyConFTyCon :: TCEmb TyCon -> TyCon -> [Sort] -> Sort-tyConFTyCon tce c ts = case tceLookup c tce of-                         Just (t, WithArgs) -> t-                         Just (t, NoArgs)   -> fApp t ts-                         Nothing            -> fApp (fTyconSort niTc) ts-  where-    niTc             = symbolNumInfoFTyCon (dummyLoc $ tyConName c) (isNumCls c) (isFracCls c)-    -- oldRes           = F.notracepp _msg $ M.lookupDefault def c tce-    -- _msg             = "tyConFTyCon c = " ++ show c ++ "default " ++ show (def, Ghc.isFamInstTyCon c)--tyVarSort :: TyVar -> Sort-tyVarSort = FObj . symbol--typeUniqueSymbol :: Type -> Symbol-typeUniqueSymbol = symbol . GM.typeUniqueString--typeSortForAll :: TCEmb TyCon -> Type -> Sort-typeSortForAll tce τ  = F.notracepp ("typeSortForall " ++ showpp τ) $ genSort sbody-  where-    sbody             = typeSort tce tbody-    genSort t         = foldl' (flip FAbs) (sortSubst su t) [i..n+i-1]-    (as, tbody)       = F.notracepp ("splitForallTys" ++ GM.showPpr τ) (splitForAllTys τ)-    su                = M.fromList $ zip sas (FVar <$>  [i..])-    sas               = symbol <$> as-    n                 = length as-    i                 = sortAbs sbody + 1---- RJ: why not make this the Symbolic instance?-tyConName :: TyCon -> Symbol-tyConName c-  | listTyCon == c    = listConName-  | Ghc.isTupleTyCon c = tupConName-  | otherwise         = symbol c--typeSortFun :: TCEmb TyCon -> Type -> Sort-typeSortFun tce t = mkFFunc 0 sos-  where-    sos           = typeSort tce <$> τs-    τs            = grabArgs [] t--grabArgs :: [Type] -> Type -> [Type]-grabArgs τs (FunTy _ _ τ1 τ2)-  | Just a <- stringClassArg τ1-  = grabArgs τs (mapType (\t -> if t == a then stringTy else t) τ2)-  -- not ( F.notracepp ("isNonArg: " ++ GM.showPpr τ1) $ isNonValueTy τ1)-  | otherwise-  = grabArgs (τ1:τs) τ2-  -- otherwise-  -- = grabArgs τs τ2-  -- -- | otherwise-  -- -- = grabArgs τs τ2-grabArgs τs τ-  = reverse (τ:τs)---expandProductType :: (PPrint r, Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, Reftable (RTProp RTyCon RTyVar r))-                  => Var -> RType RTyCon RTyVar r -> RType RTyCon RTyVar r-expandProductType x t-  | isTrivial       = t-  | otherwise       = fromRTypeRep $ trep {ty_binds = xs', ty_info=is', ty_args = ts', ty_refts = rs'}-     where-      isTrivial     = ofType (varType x) == toRSort t-      τs            = map irrelevantMult $ fst $ splitFunTys $ snd $ splitForAllTys $ toType False t-      trep          = toRTypeRep t-      (xs',is',ts',rs') = unzip4 $ concatMap mkProductTy $ zip5 τs (ty_binds trep) (ty_info trep) (ty_args trep) (ty_refts trep)---- splitFunTys :: Type -> ([Type], Type)---mkProductTy :: forall t r. (Monoid t, Monoid r)-            => (Type, Symbol, RFInfo, RType RTyCon RTyVar r, t)-            -> [(Symbol, RFInfo, RType RTyCon RTyVar r, t)]-mkProductTy (τ, x, i, t, r) = maybe [(x, i, t, r)] f $ do-  DataConAppContext{..} <- deepSplitProductType_maybe menv τ-  pure (dcac_dc, dcac_tys, map (first irrelevantMult) dcac_arg_tys, dcac_co)-  where-    f    :: (DataCon, [Type], [(Type, StrictnessMark)], Coercion) -> [(Symbol, RFInfo, RType RTyCon RTyVar r, t)]-    f    = map ((dummySymbol, defRFInfo, , mempty) . ofType . fst) . third4-    menv = (emptyFamInstEnv, emptyFamInstEnv)---------------------------------------------------------------------------------------------- | Binders generated by class predicates, typically for constraining tyvars (e.g. FNum)-------------------------------------------------------------------------------------------classBinds :: TCEmb TyCon -> SpecType -> [(Symbol, SortedReft)]-classBinds _ (RApp c ts _ _)-  | isFracCls c-  = [(symbol a, trueSortedReft FFrac) | (RVar a _) <- ts]-  | isNumCls c-  = [(symbol a, trueSortedReft FNum) | (RVar a _) <- ts]-classBinds emb (RApp c [_, _, RVar a _, t] _ _)-  | isEqual c-  = [(symbol a, rTypeSortedReft emb t)]-classBinds  emb ty@(RApp c [_, RVar a _, t] _ _)-  | isEqualityConstr ty-  = [(symbol a, rTypeSortedReft emb t)]-  | otherwise-  = notracepp ("CLASSBINDS-0: " ++ showpp c) []-classBinds _ t-  = notracepp ("CLASSBINDS-1: " ++ showpp (toType False t, isEqualityConstr t)) []--isEqualityConstr :: SpecType -> Bool-isEqualityConstr (toType False -> ty) = Ghc.isEqPred ty || Ghc.isEqPrimPred ty------------------------------------------------------------------------------------- | Termination Predicates ---------------------------------------------------------------------------------------------------------------------------------------makeNumEnv :: (Foldable t, TyConable c) => t (RType c b t1) -> [b]-makeNumEnv = concatMap go-  where-    go (RApp c ts _ _) | isNumCls c || isFracCls c = [ a | (RVar a _) <- ts]-    go _ = []--isDecreasing :: S.HashSet TyCon -> [RTyVar] -> SpecType -> Bool-isDecreasing autoenv  _ (RApp c _ _ _)-  =  isJust (sizeFunction (rtc_info c)) -- user specified size or-  || isSizeable autoenv tc-  where tc = rtc_tc c-isDecreasing _ cenv (RVar v _)-  = v `elem` cenv-isDecreasing _ _ _-  = False--makeDecrType :: Symbolic a-             => S.HashSet TyCon-             -> [(a, (Symbol, RType RTyCon t (UReft Reft)))]-             -> Either (Symbol, RType RTyCon t (UReft Reft)) String-makeDecrType autoenv = mkDType autoenv [] []--mkDType :: Symbolic a-        => S.HashSet TyCon-        -> [(Symbol, Symbol, Symbol -> Expr)]-        -> [Expr]-        -> [(a, (Symbol, RType RTyCon t (UReft Reft)))]-        -> Either (Symbol, RType RTyCon t (UReft Reft)) String-mkDType autoenv xvs acc [(v, (x, t))]-  = Left ((x, ) $ t `strengthen` tr)-  where-    tr = uTop $ Reft (vv, pOr (r:acc))-    r  = cmpLexRef xvs (v', vv, f)-    v' = symbol v-    f  = mkDecrFun autoenv  t-    vv = "vvRec"--mkDType autoenv xvs acc ((v, (x, t)):vxts)-  = mkDType autoenv ((v', x, f):xvs) (r:acc) vxts-  where-    r  = cmpLexRef xvs  (v', x, f)-    v' = symbol v-    f  = mkDecrFun autoenv t---mkDType _ _ _ _-  = Right "RefType.mkDType called on invalid input"--isSizeable  :: S.HashSet TyCon -> TyCon -> Bool-isSizeable autoenv tc = S.member tc autoenv --   Ghc.isAlgTyCon tc -- && Ghc.isRecursiveTyCon tc--mkDecrFun :: S.HashSet TyCon -> RType RTyCon t t1 -> Symbol -> Expr-mkDecrFun autoenv (RApp c _ _ _)-  | Just f <- szFun <$> sizeFunction (rtc_info c)-  = f-  | isSizeable autoenv $ rtc_tc c-  = \v -> F.mkEApp lenLocSymbol [F.EVar v]-mkDecrFun _ (RVar _ _)-  = EVar-mkDecrFun _ _-  = panic Nothing "RefType.mkDecrFun called on invalid input"---- | [NOTE]: THIS IS WHERE THE TERMINATION METRIC REFINEMENTS ARE CREATED.-cmpLexRef :: [(t1, t1, t1 -> Expr)] -> (t, t, t -> Expr) -> Expr-cmpLexRef vxs (v, x, g)-  = pAnd $   PAtom Lt (g x) (g v)-         :   PAtom Ge (g x) zero-         :  [PAtom Eq (f y) (f z) | (y, z, f) <- vxs]-         ++ [PAtom Ge (f y) zero  | (y, _, f) <- vxs]-  where zero = ECon $ I 0--makeLexRefa :: [Located Expr] -> [Located Expr] -> UReft Reft-makeLexRefa es' es = uTop $ Reft (vv, PIff (EVar vv) $ pOr rs)-  where-    rs = makeLexReft [] [] (val <$> es) (val <$> es')-    vv = "vvRec"--makeLexReft :: [(Expr, Expr)] -> [Expr] -> [Expr] -> [Expr] -> [Expr]-makeLexReft _ acc [] []-  = acc-makeLexReft old acc (e:es) (e':es')-  = makeLexReft ((e,e'):old) (r:acc) es es'-  where-    r    = pAnd $   PAtom Lt e' e-                :   PAtom Ge e' zero-                :  [PAtom Eq o' o    | (o,o') <- old]-                ++ [PAtom Ge o' zero | (_,o') <- old]-    zero = ECon $ I 0-makeLexReft _ _ _ _-  = panic Nothing "RefType.makeLexReft on invalid input"-----------------------------------------------------------------------------------mkTyConInfo :: TyCon -> VarianceInfo -> VarianceInfo -> Maybe SizeFun -> TyConInfo-mkTyConInfo c userTv userPv f = TyConInfo tcTv userPv f-  where-    tcTv                      = if null userTv then defTv else userTv-    defTv                     = makeTyConVariance c-------------------------------------------------------------------------------------- | Printing Refinement Types ------------------------------------------------------------------------------------------------------------------------------------instance Show RTyVar where-  show = showpp--instance PPrint (UReft r) => Show (UReft r) where-  show = showpp--instance PPrint DataDecl where-  pprintTidy k dd =-    let-      prefix = "data" <+> pprint (tycName dd) <+> ppMbSizeFun (tycSFun dd) <+> pprint (tycTyVars dd)-    in-      case tycDCons dd of-        Nothing   -> prefix-        Just cons -> prefix <+> "=" $+$ nest 4 (vcat $ [ "|" <+> pprintTidy k c | c <- cons ])--instance PPrint DataCtor where-  -- pprintTidy k (DataCtor c as _   xts Nothing)  = pprintTidy k c <+> dcolon ppVars as <+> braces (ppFields k ", " xts)-  -- pprintTidy k (DataCtor c as ths xts (Just t)) = pprintTidy k c <+> dcolon <+> ppVars as <+> ppThetas ths <+> (ppFields k " ->" xts) <+> "->" <+> pprintTidy k t-  pprintTidy k (DataCtor c as ths xts t) = pprintTidy k c <+> dcolon <+> ppVars k as <+> ppThetas ths <+> ppFields k " ->" xts <+> "->" <+> res-    where-      res         = maybe "*" (pprintTidy k) t-      ppThetas [] = empty-      ppThetas ts = parens (hcat $ punctuate ", " (pprintTidy k <$> ts)) <+> "=>"---ppVars :: (PPrint a) => Tidy -> [a] -> Doc-ppVars k as = "forall" <+> hcat (punctuate " " (F.pprintTidy k <$> as)) <+> "."--ppFields :: (PPrint k, PPrint v) => Tidy -> Doc -> [(k, v)] -> Doc-ppFields k sep kvs = hcat $ punctuate sep (F.pprintTidy k <$> kvs)--ppMbSizeFun :: Maybe SizeFun -> Doc-ppMbSizeFun Nothing  = ""-ppMbSizeFun (Just z) = F.pprint z---- instance PPrint DataCtor where-  -- pprintTidy k (DataCtor c xts t) =-    -- pprintTidy k c <+> text "::" <+> (hsep $ punctuate (text "->")-                                          -- ((pprintTidy k <$> xts) ++ [pprintTidy k t]))---- ppHack :: (?callStack :: CallStack) => a -> b--- ppHack _ = errorstar "OOPS"--instance PPrint (RType c tv r) => Show (RType c tv r) where-  show = showpp--instance PPrint (RTProp c tv r) => Show (RTProp c tv r) where-  show = showpp------------------------------------------------------------------------------------- | tyVarsPosition t returns the type variables appearing --- | (in positive positions, in negative positions, in undetermined positions)--- | undetermined positions are due to type constructors and type application---------------------------------------------------------------------------------tyVarsPosition :: RType RTyCon tv r -> Positions tv-tyVarsPosition = go (Just True)-  where-    go p (RVar t _)        = report p t-    go p (RFun _ _ t1 t2 _)  = go (flip p) t1 <> go p t2-    go p (RImpF _ _ t1 t2 _) = go (flip p) t1 <> go p t2-    go p (RAllT _ t _)     = go p t-    go p (RAllP _ t)       = go p t-    go p (RApp c ts _ _)   = mconcat (zipWith go (getPosition p <$> varianceTyArgs (rtc_info c)) ts)-    go p (RAllE _ t1 t2)   = go p t1 <> go p t2-    go p (REx _ t1 t2)     = go p t1 <> go p t2-    go _ (RExprArg _)      = mempty-    go p (RAppTy t1 t2 _)  = go p t1 <> go p t2-    go p (RRTy _ _ _ t)    = go p t-    go _ (RHole _)         = mempty--    getPosition :: Maybe Bool -> Variance -> Maybe Bool-    getPosition b Contravariant = not <$> b-    getPosition b _             = b--    report Nothing v      = Pos [] [] [v]-    report (Just True) v  = Pos [v] [] []-    report (Just False) v = Pos [] [v] []-    flip = fmap not--data Positions a = Pos {ppos :: [a], pneg ::  [a], punknown :: [a]}--instance Monoid (Positions a) where-  mempty = Pos [] [] []-instance Semigroup (Positions a) where-  (Pos x1 x2 x3) <> (Pos y1 y2 y3) = Pos (x1 ++ y1) (x2 ++ y2) (x3 ++ y3)
− src/Language/Haskell/Liquid/Types/Specs.hs 
@@ -1,887 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}--- | This module contains the top-level structures that hold ---   information about specifications.--{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE DerivingVia                #-}--{-# OPTIONS_GHC -Wno-orphans #-}--module Language.Haskell.Liquid.Types.Specs (-  -- * Different types of specifications-  -- $differentSpecTypes-  -- * TargetInfo-  -- $targetInfo-    TargetInfo(..)-  -- * Gathering information about a module-  , TargetSrc(..)-  -- * TargetSpec-  -- $targetSpec-  , TargetSpec(..)-  -- * BareSpec-  -- $bareSpec-  , BareSpec(..)-  -- * LiftedSpec-  -- $liftedSpec-  , LiftedSpec(..)-  -- * Tracking dependencies-  -- $trackingDeps-  , TargetDependencies(..)-  , dropDependency-  -- * Predicates on spec types-  -- $predicates-  , isPLEVar-  , isExportedVar-  -- * Other types-  , QImports(..)-  , Spec(..)-  , GhcSpecVars(..)-  , GhcSpecSig(..)-  , GhcSpecNames(..)-  , GhcSpecTerm(..)-  , GhcSpecRefl(..)-  , GhcSpecLaws(..)-  , GhcSpecData(..)-  , GhcSpecQual(..)-  , BareDef-  , BareMeasure-  , SpecMeasure-  , VarOrLocSymbol-  , LawInstance(..)-  -- * Legacy data structures-  -- $legacyDataStructures-  , GhcSrc(..)-  , GhcSpec(..)-  -- * Provisional compatibility exports & optics-  -- $provisionalBackCompat-  , targetSrcIso-  , targetSpecGetter-  , bareSpecIso-  , liftedSpecGetter-  , unsafeFromLiftedSpec-  , emptyLiftedSpec-  ) where--import           Optics-import           GHC.Generics            hiding (to, moduleName)-import           Data.Binary-import qualified Language.Fixpoint.Types as F-import           Language.Fixpoint.Misc (sortNub)-import           Data.Hashable-import qualified Data.HashSet            as S-import           Data.HashSet            (HashSet)-import qualified Data.HashMap.Strict     as M-import           Data.HashMap.Strict     (HashMap)-import           Language.Haskell.Liquid.Types.Types -import           Language.Haskell.Liquid.Types.Generics-import           Language.Haskell.Liquid.Types.Variance-import           Language.Haskell.Liquid.Types.Bounds -import           Liquid.GHC.API hiding (text, (<+>))-import           Liquid.GHC.Types-import           Text.PrettyPrint.HughesPJ              (text, (<+>))---{- $differentSpecTypes--There are different types or \"flavours\" for a specification, depending on its lifecycle. The main goal-is always the same, i.e. refining the Haskell types and produce a final statement (i.e. safe or unsafe)-about the input program. In order to do so, a /specification/ is transformed in the way described by this-picture:--@-    +---------------+                                +-------------------+-    |   BareSpec    |                                |                   |  checked by liquid/liquidOne-    |               |                    ------------|    TargetSpec     |----------------------------- ..-    |(input module) |                   /            |                   |-    +---------------+  makeTargetSpec  /             +-------------------+-           +         -----------------/-    +---------------+                 \\              +-------------------+-    | {LiftedSpec}  |                  \\             |                   |    serialised on disk-    |               |                   -------------|    LiftedSpec     |----------------------------- ..-    |(dependencies) |                                |                   |-    +---------------+                                +-------------------+-          ^                                                    |-          |                   used-as                          |-          +----------------------------------------------------+-@--More specifically, we distinguish:--* 'BareSpec' - is the specification obtained by parsing the Liquid annotations of the input Haskell file.-  It typically contains information about the associated input Haskell module, with the exceptions of-  /assumptions/ that can refer to functions defined in other modules.--* 'LiftedSpec' - is the specification we obtain by \"lifting\" the 'BareSpec'. Most importantly, a-  'LiftedSpec' gets serialised on disk and becomes a /dependency/ for the verification of other 'BareSpec's.--   Lifting in this context consist of:--    1. Perform name-resolution (e.g. make all the relevant GHC's 'Var's qualified, resolve GHC's 'Name's, etc);-    2. Strip the final 'LiftedSpec' with information which are relevant (read: local) to just the input-       'BareSpec'. An example would be /local signatures/, used to annotate internal, auxiliary functions-       within a 'Module';-    3. Strip termination checks, which are /required/ (if specified) for a 'BareSpec' but not for the-       'LiftedSpec'.--* 'TargetSpec' - is the specification we /actually use for refinement/, and is conceptually an-  \"augmented\" 'BareSpec'. You can create a 'TargetSpec' by calling 'makeTargetSpec'.--In order to produce these spec types we have to gather information about the module being compiled by using-the GHC API and retain enough context of the compiled 'Module' in order to be able to construct the types-introduced aboves. The rest of this module introduced also these intermediate structures.--}---- $targetInfo --- The following is the overall type for /specifications/ obtained from--- parsing the target source and dependent libraries. --- /IMPORTANT/: A 'TargetInfo' is what is /checked/ by LH itself and it /NEVER/ contains the 'LiftedSpec', --- because the checking happens only on the 'BareSpec' of the target module.-data TargetInfo = TargetInfo-  { giSrc  :: !TargetSrc-    -- ^ The 'TargetSrc' of the module being checked.-  , giSpec :: !TargetSpec -    -- ^ The 'TargetSpec' of the module being checked.-  }--instance HasConfig TargetInfo where-  getConfig = getConfig . giSpec---- | The 'TargetSrc' type is a collection of all the things we know about a module being currently--- checked. It include things like the name of the module, the list of 'CoreBind's,--- the 'TyCon's declared in this module (that includes 'TyCon's for classes), typeclass instances--- and so and so forth. It might be consider a sort of 'ModGuts' embellished with LH-specific--- information (for example, 'giDefVars' are populated with datacons from the module plus the--- let vars derived from the A-normalisation).-data TargetSrc = TargetSrc-  { giIncDir    :: !FilePath              -- ^ Path for LH include/prelude directory-  , giTarget    :: !FilePath              -- ^ Source file for module-  , giTargetMod :: !ModName               -- ^ Name for module-  , giCbs       :: ![CoreBind]            -- ^ Source Code-  , gsTcs       :: ![TyCon]               -- ^ All used Type constructors-  , gsCls       :: !(Maybe [ClsInst])     -- ^ Class instances?-  , giDerVars   :: !(HashSet Var)         -- ^ Binders created by GHC eg dictionaries-  , giImpVars   :: ![Var]                 -- ^ Binders that are _read_ in module (but not defined?)-  , giDefVars   :: ![Var]                 -- ^ (Top-level) binders that are _defined_ in module-  , giUseVars   :: ![Var]                 -- ^ Binders that are _read_ in module-  , gsExports   :: !(HashSet StableName)  -- ^ `Name`s exported by the module being verified-  , gsFiTcs     :: ![TyCon]               -- ^ Family instance TyCons -  , gsFiDcs     :: ![(F.Symbol, DataCon)] -- ^ Family instance DataCons -  , gsPrimTcs   :: ![TyCon]               -- ^ Primitive GHC TyCons (from TysPrim.primTyCons)-  , gsQualImps  :: !QImports              -- ^ Map of qualified imports-  , gsAllImps   :: !(HashSet F.Symbol)    -- ^ Set of _all_ imported modules-  , gsTyThings  :: ![TyThing]             -- ^ All the @TyThing@s known to GHC-  }---- | 'QImports' is a map of qualified imports.-data QImports = QImports -  { qiModules :: !(S.HashSet F.Symbol)            -- ^ All the modules that are imported qualified-  , qiNames   :: !(M.HashMap F.Symbol [F.Symbol]) -- ^ Map from qualification to full module name-  } deriving Show---- $targetSpec---- | A 'TargetSpec' is what we /actually check via LiquidHaskell/. It is created as part of 'mkTargetSpec' --- alongside the 'LiftedSpec'. It shares a similar structure with a 'BareSpec', but manipulates and--- transforms the data in preparation to the checking process.-data TargetSpec = TargetSpec-  { gsSig    :: !GhcSpecSig-  , gsQual   :: !GhcSpecQual-  , gsData   :: !GhcSpecData-  , gsName   :: !GhcSpecNames-  , gsVars   :: !GhcSpecVars-  , gsTerm   :: !GhcSpecTerm-  , gsRefl   :: !GhcSpecRefl-  , gsLaws   :: !GhcSpecLaws-  , gsImps   :: ![(F.Symbol, F.Sort)]  -- ^ Imported Environment-  , gsConfig :: !Config-  }--instance HasConfig TargetSpec where-  getConfig = gsConfig---- | The collection of GHC 'Var's that a 'TargetSpec' needs to verify (or skip).-data GhcSpecVars = SpVar -  { gsTgtVars    :: ![Var]                        -- ^ Top-level Binders To Verify (empty means ALL binders)-  , gsIgnoreVars :: !(S.HashSet Var)              -- ^ Top-level Binders To NOT Verify (empty means ALL binders)-  , gsLvars      :: !(S.HashSet Var)              -- ^ Variables that should be checked "lazily" in the environment they are used-  , gsCMethods   :: ![Var]                        -- ^ Refined Class methods -  }--instance Semigroup GhcSpecVars where-  sv1 <> sv2 = SpVar -    { gsTgtVars    = gsTgtVars    sv1 <> gsTgtVars    sv2-    , gsIgnoreVars = gsIgnoreVars sv1 <> gsIgnoreVars sv2-    , gsLvars      = gsLvars      sv1 <> gsLvars      sv2-    , gsCMethods   = gsCMethods   sv1 <> gsCMethods   sv2-    }--instance Monoid GhcSpecVars where-  mempty = SpVar mempty mempty mempty mempty--data GhcSpecQual = SpQual -  { gsQualifiers :: ![F.Qualifier]                -- ^ Qualifiers in Source/Spec files e.g tests/pos/qualTest.hs-  , gsRTAliases  :: ![F.Located SpecRTAlias]      -- ^ Refinement type aliases (only used for qualifiers)-  }--data GhcSpecSig = SpSig -  { gsTySigs   :: ![(Var, LocSpecType)]           -- ^ Asserted Reftypes-  , gsAsmSigs  :: ![(Var, LocSpecType)]           -- ^ Assumed Reftypes-  , gsRefSigs  :: ![(Var, LocSpecType)]           -- ^ Reflected Reftypes -  , gsInSigs   :: ![(Var, LocSpecType)]           -- ^ Auto generated Signatures-  , gsNewTypes :: ![(TyCon, LocSpecType)]         -- ^ Mapping of 'newtype' type constructors with their refined types.-  , gsDicts    :: !(DEnv Var LocSpecType)            -- ^ Refined Classes from Instances -  , gsMethods  :: ![(Var, MethodType LocSpecType)]   -- ^ Refined Classes from Classes -  , gsTexprs   :: ![(Var, LocSpecType, [F.Located F.Expr])]  -- ^ Lexicographically ordered expressions for termination-  , gsRelation :: ![(Var, Var, LocSpecType, LocSpecType, RelExpr, RelExpr)]-  , gsAsmRel   :: ![(Var, Var, LocSpecType, LocSpecType, RelExpr, RelExpr)]-  }--instance Semigroup GhcSpecSig where-  x <> y = SpSig -    { gsTySigs   = gsTySigs x   <> gsTySigs y   -    , gsAsmSigs  = gsAsmSigs x  <> gsAsmSigs y   -    , gsRefSigs  = gsRefSigs x  <> gsRefSigs y   -    , gsInSigs   = gsInSigs x   <> gsInSigs y   -    , gsNewTypes = gsNewTypes x <> gsNewTypes y   -    , gsDicts    = gsDicts x    <> gsDicts y   -    , gsMethods  = gsMethods x  <> gsMethods y   -    , gsTexprs   = gsTexprs x   <> gsTexprs y   -    , gsRelation = gsRelation x <> gsRelation y-    , gsAsmRel   = gsAsmRel x   <> gsAsmRel y-    }--------instance Monoid GhcSpecSig where-  mempty = SpSig mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty  --data GhcSpecData = SpData -  { gsCtors      :: ![(Var, LocSpecType)]         -- ^ Data Constructor Measure Sigs-  , gsMeas       :: ![(F.Symbol, LocSpecType)]    -- ^ Measure Types eg.  len :: [a] -> Int-  , gsInvariants :: ![(Maybe Var, LocSpecType)]   -- ^ Data type invariants from measure definitions, e.g forall a. {v: [a] | len(v) >= 0}-  , gsIaliases   :: ![(LocSpecType, LocSpecType)] -- ^ Data type invariant aliases -  , gsMeasures   :: ![Measure SpecType DataCon]   -- ^ Measure definitions-  , gsUnsorted   :: ![UnSortedExpr]-  }-data GhcSpecNames = SpNames -  { gsFreeSyms   :: ![(F.Symbol, Var)]            -- ^ List of `Symbol` free in spec and corresponding GHC var, eg. (Cons, Cons#7uz) from tests/pos/ex1.hs-  , gsDconsP     :: ![F.Located DataCon]          -- ^ Predicated Data-Constructors, e.g. see tests/pos/Map.hs-  , gsTconsP     :: ![TyConP]                     -- ^ Predicated Type-Constructors, e.g. see tests/pos/Map.hs-  , gsTcEmbeds   :: !(F.TCEmb TyCon)              -- ^ Embedding GHC Tycons into fixpoint sorts e.g. "embed Set as Set_set" from include/Data/Set.spec-  , gsADTs       :: ![F.DataDecl]                 -- ^ ADTs extracted from Haskell 'data' definitions-  , gsTyconEnv   :: !TyConMap-  }--data GhcSpecTerm = SpTerm -  { gsStTerm     :: !(S.HashSet Var)              -- ^ Binders to CHECK by structural termination-  , gsAutosize   :: !(S.HashSet TyCon)            -- ^ Binders to IGNORE during termination checking-  , gsLazy       :: !(S.HashSet Var)              -- ^ Binders to IGNORE during termination checking-  , gsFail       :: !(S.HashSet (F.Located Var))    -- ^ Binders to fail type checking-  , gsDecr       :: ![(Var, [Int])]               -- ^ Lexicographic order of decreasing args (DEPRECATED) -  , gsNonStTerm  :: !(S.HashSet Var)              -- ^ Binders to CHECK using REFINEMENT-TYPES/termination metrics -  }--instance Semigroup GhcSpecTerm where-  t1 <> t2 = SpTerm-    { gsStTerm    = gsStTerm t1    <> gsStTerm t2-    , gsAutosize  = gsAutosize t1  <> gsAutosize t2-    , gsLazy      = gsLazy t1      <> gsLazy t2-    , gsFail      = gsFail t1      <> gsFail t2-    , gsDecr      = gsDecr t1      <> gsDecr t2-    , gsNonStTerm = gsNonStTerm t1 <> gsNonStTerm t2-    }--instance Monoid GhcSpecTerm where-  mempty = SpTerm mempty mempty mempty mempty mempty mempty-data GhcSpecRefl = SpRefl -  { gsAutoInst     :: !(M.HashMap Var (Maybe Int))      -- ^ Binders to USE PLE -  , gsHAxioms      :: ![(Var, LocSpecType, F.Equation)] -- ^ Lifted definitions -  , gsImpAxioms    :: ![F.Equation]                     -- ^ Axioms from imported reflected functions-  , gsMyAxioms     :: ![F.Equation]                     -- ^ Axioms from my reflected functions-  , gsReflects     :: ![Var]                            -- ^ Binders for reflected functions-  , gsLogicMap     :: !LogicMap-  , gsWiredReft    :: ![Var]-  , gsRewrites     :: S.HashSet (F.Located Var)-  , gsRewritesWith :: M.HashMap Var [Var]-  }--instance Semigroup GhcSpecRefl where-  x <> y = SpRefl -    { gsAutoInst = gsAutoInst x <> gsAutoInst y -    , gsHAxioms  = gsHAxioms x <> gsHAxioms y-    , gsImpAxioms = gsImpAxioms x <> gsImpAxioms y-    , gsMyAxioms = gsMyAxioms x <> gsMyAxioms y-    , gsReflects = gsReflects x <> gsReflects y-    , gsLogicMap = gsLogicMap x <> gsLogicMap y-    , gsWiredReft = gsWiredReft x <> gsWiredReft y-    , gsRewrites = gsRewrites x <> gsRewrites y-    , gsRewritesWith = gsRewritesWith x <> gsRewritesWith y-    } --instance Monoid GhcSpecRefl where-  mempty = SpRefl mempty mempty mempty-                  mempty mempty mempty-                  mempty mempty mempty-data GhcSpecLaws = SpLaws -  { gsLawDefs :: ![(Class, [(Var, LocSpecType)])]-  , gsLawInst :: ![LawInstance]-  }--data LawInstance = LawInstance-  { lilName   :: Class-  , liSupers  :: [LocSpecType]-  , lilTyArgs :: [LocSpecType]-  , lilEqus   :: [(VarOrLocSymbol, (VarOrLocSymbol, Maybe LocSpecType))]-  , lilPos    :: SrcSpan-  }  --type VarOrLocSymbol = Either Var LocSymbol-type BareMeasure   = Measure LocBareType F.LocSymbol-type BareDef       = Def     LocBareType F.LocSymbol-type SpecMeasure   = Measure LocSpecType DataCon---- $bareSpec---- | A 'BareSpec' is the spec we derive by parsing the Liquid Haskell annotations of a single file. As--- such, it contains things which are relevant for validation and lifting; it contains things like--- the pragmas the user defined, the termination condition (if termination-checking is enabled) and so--- on and so forth. /Crucially/, as a 'BareSpec' is still subject to \"preflight checks\", it may contain--- duplicates (e.g. duplicate measures, duplicate type declarations etc.) and therefore most of the fields--- for a 'BareSpec' are lists, so that we can report these errors to the end user: it would be an error--- to silently ignore the duplication and leave the duplicate resolution to whichever 'Eq' instance is--- implemented for the relevant field.------ Also, a 'BareSpec' has not yet been subject to name resolution, so it may refer--- to undefined or out-of-scope entities.-newtype BareSpec =-  MkBareSpec { getBareSpec :: Spec LocBareType F.LocSymbol }-  deriving (Generic, Show, Binary)--instance Semigroup BareSpec where-  x <> y = MkBareSpec { getBareSpec = getBareSpec x <> getBareSpec y }--instance Monoid BareSpec where-  mempty = MkBareSpec { getBareSpec = mempty } ----- instance Semigroup (Spec ty bndr) where---- | A generic 'Spec' type, polymorphic over the inner choice of type and binder.-data Spec ty bndr  = Spec-  { measures   :: ![Measure ty bndr]              -- ^ User-defined properties for ADTs-  , impSigs    :: ![(F.Symbol, F.Sort)]           -- ^ Imported variables types-  , expSigs    :: ![(F.Symbol, F.Sort)]           -- ^ Exported variables types-  , asmSigs    :: ![(F.LocSymbol, ty)]            -- ^ Assumed (unchecked) types; including reflected signatures-  , sigs       :: ![(F.LocSymbol, ty)]            -- ^ Imported functions and types-  , localSigs  :: ![(F.LocSymbol, ty)]            -- ^ Local type signatures-  , reflSigs   :: ![(F.LocSymbol, ty)]            -- ^ Reflected type signatures-  , invariants :: ![(Maybe F.LocSymbol, ty)]      -- ^ Data type invariants; the Maybe is the generating measure-  , ialiases   :: ![(ty, ty)]                     -- ^ Data type invariants to be checked-  , imports    :: ![F.Symbol]                     -- ^ Loaded spec module names-  , dataDecls  :: ![DataDecl]                     -- ^ Predicated data definitions-  , newtyDecls :: ![DataDecl]                     -- ^ Predicated new type definitions-  , includes   :: ![FilePath]                     -- ^ Included qualifier files-  , aliases    :: ![F.Located (RTAlias F.Symbol BareType)] -- ^ RefType aliases-  , ealiases   :: ![F.Located (RTAlias F.Symbol F.Expr)]   -- ^ Expression aliases-  , embeds     :: !(F.TCEmb F.LocSymbol)                   -- ^ GHC-Tycon-to-fixpoint Tycon map-  , qualifiers :: ![F.Qualifier]                           -- ^ Qualifiers in source/spec files-  , decr       :: ![(F.LocSymbol, [Int])]         -- ^ Information on decreasing arguments-  , lvars      :: !(S.HashSet F.LocSymbol)        -- ^ Variables that should be checked in the environment they are used-  , lazy       :: !(S.HashSet F.LocSymbol)        -- ^ Ignore Termination Check in these Functions-  , rewrites    :: !(S.HashSet F.LocSymbol)        -- ^ Theorems turned into rewrite rules -  , rewriteWith :: !(M.HashMap F.LocSymbol [F.LocSymbol]) -- ^ Definitions using rewrite rules-  , fails      :: !(S.HashSet F.LocSymbol)        -- ^ These Functions should be unsafe-  , reflects   :: !(S.HashSet F.LocSymbol)        -- ^ Binders to reflect-  , autois     :: !(M.HashMap F.LocSymbol (Maybe Int))  -- ^ Automatically instantiate axioms in these Functions with maybe specified fuel-  , hmeas      :: !(S.HashSet F.LocSymbol)        -- ^ Binders to turn into measures using haskell definitions-  , hbounds    :: !(S.HashSet F.LocSymbol)        -- ^ Binders to turn into bounds using haskell definitions-  , inlines    :: !(S.HashSet F.LocSymbol)        -- ^ Binders to turn into logic inline using haskell definitions-  , ignores    :: !(S.HashSet F.LocSymbol)        -- ^ Binders to ignore during checking; that is DON't check the corebind. -  , autosize   :: !(S.HashSet F.LocSymbol)        -- ^ Type Constructors that get automatically sizing info-  , pragmas    :: ![F.Located String]             -- ^ Command-line configurations passed in through source-  , cmeasures  :: ![Measure ty ()]                -- ^ Measures attached to a type-class-  , imeasures  :: ![Measure ty bndr]              -- ^ Mappings from (measure,type) -> measure-  , classes    :: ![RClass ty]                    -- ^ Refined Type-Classes-  , claws      :: ![RClass ty]                    -- ^ Refined Type-Classe Laws-  , relational :: ![(LocSymbol, LocSymbol, ty, ty, RelExpr, RelExpr)] -- ^ Relational types-  , asmRel     :: ![(LocSymbol, LocSymbol, ty, ty, RelExpr, RelExpr)] -- ^ Assumed relational types-  , termexprs  :: ![(F.LocSymbol, [F.Located F.Expr])] -- ^ Terminating Conditions for functions-  , rinstance  :: ![RInstance ty]-  , ilaws      :: ![RILaws ty]-  , dvariance  :: ![(F.LocSymbol, [Variance])]         -- ^ ? Where do these come from ?!-  , dsize      :: ![([ty], F.LocSymbol)]      -- ^ Size measure to enforce fancy termination -  , bounds     :: !(RRBEnv ty)-  , defs       :: !(M.HashMap F.LocSymbol F.Symbol)    -- ^ Temporary (?) hack to deal with dictionaries in specifications-                                                       --   see tests/pos/NatClass.hs-  , axeqs      :: ![F.Equation]                        -- ^ Equalities used for Proof-By-Evaluation-  } deriving (Generic, Show)--instance Binary (Spec LocBareType F.LocSymbol)--instance (Show ty, Show bndr, F.PPrint ty, F.PPrint bndr) => F.PPrint (Spec ty bndr) where-    pprintTidy k sp = text "dataDecls = " <+> pprintTidy k  (dataDecls sp)---- /NOTA BENE/: These instances below are considered legacy, because merging two 'Spec's together doesn't--- really make sense, and we provide this only for legacy purposes.-instance Semigroup (Spec ty bndr) where-  s1 <> s2-    = Spec { measures   =           measures   s1 ++ measures   s2-           , impSigs    =           impSigs    s1 ++ impSigs    s2-           , expSigs    =           expSigs    s1 ++ expSigs    s2 -           , asmSigs    =           asmSigs    s1 ++ asmSigs    s2-           , sigs       =           sigs       s1 ++ sigs       s2-           , localSigs  =           localSigs  s1 ++ localSigs  s2-           , reflSigs   =           reflSigs   s1 ++ reflSigs   s2-           , invariants =           invariants s1 ++ invariants s2-           , ialiases   =           ialiases   s1 ++ ialiases   s2-           , imports    = sortNub $ imports    s1 ++ imports    s2-           , dataDecls  =           dataDecls  s1 ++ dataDecls  s2-           , newtyDecls =           newtyDecls s1 ++ newtyDecls s2-           , includes   = sortNub $ includes   s1 ++ includes   s2-           , aliases    =           aliases    s1 ++ aliases    s2-           , ealiases   =           ealiases   s1 ++ ealiases   s2-           , qualifiers =           qualifiers s1 ++ qualifiers s2-           , decr       =           decr       s1 ++ decr       s2-           , pragmas    =           pragmas    s1 ++ pragmas    s2-           , cmeasures  =           cmeasures  s1 ++ cmeasures  s2-           , imeasures  =           imeasures  s1 ++ imeasures  s2-           , classes    =           classes    s1 ++ classes    s2-           , claws      =           claws      s1 ++ claws      s2-           , relational =           relational s1 ++ relational s2 -           , asmRel     =           asmRel     s1 ++ asmRel     s2 -           , termexprs  =           termexprs  s1 ++ termexprs  s2-           , rinstance  =           rinstance  s1 ++ rinstance  s2-           , ilaws      =               ilaws  s1 ++ ilaws      s2 -           , dvariance  =           dvariance  s1 ++ dvariance  s2-           , dsize      =               dsize  s1 ++ dsize      s2-           , axeqs      =           axeqs s1      ++ axeqs s2-           , embeds     = mappend   (embeds   s1)  (embeds   s2)-           , lvars      = S.union   (lvars    s1)  (lvars    s2)-           , lazy       = S.union   (lazy     s1)  (lazy     s2)-           , rewrites   = S.union   (rewrites    s1)  (rewrites    s2)-           , rewriteWith = M.union  (rewriteWith s1)  (rewriteWith s2)-           , fails      = S.union   (fails    s1)  (fails    s2)-           , reflects   = S.union   (reflects s1)  (reflects s2)-           , hmeas      = S.union   (hmeas    s1)  (hmeas    s2)-           , hbounds    = S.union   (hbounds  s1)  (hbounds  s2)-           , inlines    = S.union   (inlines  s1)  (inlines  s2)-           , ignores    = S.union   (ignores  s1)  (ignores  s2)-           , autosize   = S.union   (autosize s1)  (autosize s2)-           , bounds     = M.union   (bounds   s1)  (bounds   s2)-           , defs       = M.union   (defs     s1)  (defs     s2)-           , autois     = M.union   (autois s1)      (autois s2)-           }--instance Monoid (Spec ty bndr) where-  mappend = (<>)-  mempty-    = Spec { measures   = []-           , impSigs    = [] -           , expSigs    = [] -           , asmSigs    = []-           , sigs       = []-           , localSigs  = []-           , reflSigs   = []-           , invariants = []-           , ialiases   = []-           , imports    = []-           , dataDecls  = []-           , newtyDecls = []-           , includes   = []-           , aliases    = []-           , ealiases   = []-           , embeds     = mempty-           , qualifiers = []-           , decr       = []-           , lvars      = S.empty -           , lazy       = S.empty-           , rewrites   = S.empty-           , rewriteWith = M.empty-           , fails      = S.empty-           , autois     = M.empty-           , hmeas      = S.empty-           , reflects   = S.empty-           , hbounds    = S.empty-           , inlines    = S.empty-           , ignores    = S.empty-           , autosize   = S.empty-           , pragmas    = []-           , cmeasures  = []-           , imeasures  = []-           , classes    = []-           , claws      = []-           , relational = []  -           , asmRel     = []  -           , termexprs  = []-           , rinstance  = []-           , ilaws      = [] -           , dvariance  = []-           , dsize      = []-           , axeqs      = []-           , bounds     = M.empty-           , defs       = M.empty-           }---- $liftedSpec---- | A 'LiftedSpec' is derived from an input 'BareSpec' and a set of its dependencies.--- The general motivations for lifting a spec are (a) name resolution, (b) the fact that some info is--- only relevant for checking the body of functions but does not need to be exported, e.g. --- termination measures, or the fact that a type signature was assumed.--- A 'LiftedSpec' is /what we serialise on disk and what the clients should will be using/.------ What we /do not/ have compared to a 'BareSpec':------ * The 'localSigs', as it's not necessary/visible to clients;--- * The 'includes', as they are probably not reachable for clients anyway;--- * The 'reflSigs', they are now just \"normal\" signatures;--- * The 'lazy', we don't do termination checking in lifted specs;--- * The 'reflects', the reflection has already happened at this point;--- * The 'hmeas', we have /already/ turned these into measures at this point;--- * The 'hbounds', ditto as 'hmeas';--- * The 'inlines', ditto as 'hmeas';--- * The 'ignores', ditto as 'hmeas';--- * The 'pragmas', we can't make any use of this information for lifted specs;--- * The 'termexprs', we don't do termination checking in lifted specs;------ Apart from less fields, a 'LiftedSpec' /replaces all instances of lists with sets/, to enforce--- duplicate detection and removal on what we serialise on disk.-data LiftedSpec = LiftedSpec-  { liftedMeasures   :: HashSet (Measure LocBareType F.LocSymbol)-    -- ^ User-defined properties for ADTs-  , liftedImpSigs    :: HashSet (F.Symbol, F.Sort)-    -- ^ Imported variables types-  , liftedExpSigs    :: HashSet (F.Symbol, F.Sort)-    -- ^ Exported variables types-  , liftedAsmSigs    :: HashSet (F.LocSymbol, LocBareType)-    -- ^ Assumed (unchecked) types; including reflected signatures-  , liftedSigs       :: HashSet (F.LocSymbol, LocBareType)-    -- ^ Imported functions and types-  , liftedInvariants :: HashSet (Maybe F.LocSymbol, LocBareType)-    -- ^ Data type invariants; the Maybe is the generating measure-  , liftedIaliases   :: HashSet (LocBareType, LocBareType)-    -- ^ Data type invariants to be checked-  , liftedImports    :: HashSet F.Symbol-    -- ^ Loaded spec module names-  , liftedDataDecls  :: HashSet DataDecl-    -- ^ Predicated data definitions-  , liftedNewtyDecls :: HashSet DataDecl-    -- ^ Predicated new type definitions-  , liftedAliases    :: HashSet (F.Located (RTAlias F.Symbol BareType))-    -- ^ RefType aliases-  , liftedEaliases   :: HashSet (F.Located (RTAlias F.Symbol F.Expr))-    -- ^ Expression aliases-  , liftedEmbeds     :: F.TCEmb F.LocSymbol-    -- ^ GHC-Tycon-to-fixpoint Tycon map-  , liftedQualifiers :: HashSet F.Qualifier-    -- ^ Qualifiers in source/spec files-  , liftedDecr       :: HashSet (F.LocSymbol, [Int])-    -- ^ Information on decreasing arguments-  , liftedLvars      :: HashSet F.LocSymbol-    -- ^ Variables that should be checked in the environment they are used-  , liftedAutois     :: M.HashMap F.LocSymbol (Maybe Int)-    -- ^ Automatically instantiate axioms in these Functions with maybe specified fuel-  , liftedAutosize   :: HashSet F.LocSymbol-    -- ^ Type Constructors that get automatically sizing info-  , liftedCmeasures  :: HashSet (Measure LocBareType ())-    -- ^ Measures attached to a type-class-  , liftedImeasures  :: HashSet (Measure LocBareType F.LocSymbol)-    -- ^ Mappings from (measure,type) -> measure-  , liftedClasses    :: HashSet (RClass LocBareType)-    -- ^ Refined Type-Classes-  , liftedClaws      :: HashSet (RClass LocBareType)-    -- ^ Refined Type-Classe Laws-  , liftedRinstance  :: HashSet (RInstance LocBareType)-  , liftedIlaws      :: HashSet (RILaws LocBareType)-  , liftedDsize      :: [([LocBareType], F.LocSymbol)]-  , liftedDvariance  :: HashSet (F.LocSymbol, [Variance])-    -- ^ ? Where do these come from ?!-  , liftedBounds     :: RRBEnv LocBareType-  , liftedDefs       :: M.HashMap F.LocSymbol F.Symbol-    -- ^ Temporary (?) hack to deal with dictionaries in specifications-    --   see tests/pos/NatClass.hs-  , liftedAxeqs      :: HashSet F.Equation-    -- ^ Equalities used for Proof-By-Evaluation-  } deriving (Eq, Generic, Show)-    deriving Hashable via Generically LiftedSpec -    deriving Binary   via Generically LiftedSpec --instance Binary F.Equation --emptyLiftedSpec :: LiftedSpec-emptyLiftedSpec = LiftedSpec-  { liftedMeasures = mempty -  , liftedImpSigs  = mempty-  , liftedExpSigs  = mempty-  , liftedAsmSigs  = mempty-  , liftedSigs     = mempty-  , liftedInvariants = mempty-  , liftedIaliases   = mempty-  , liftedImports    = mempty-  , liftedDataDecls  = mempty-  , liftedNewtyDecls = mempty-  , liftedAliases    = mempty-  , liftedEaliases   = mempty-  , liftedEmbeds     = mempty-  , liftedQualifiers = mempty-  , liftedDecr       = mempty-  , liftedLvars      = mempty-  , liftedAutois     = mempty-  , liftedAutosize   = mempty-  , liftedCmeasures  = mempty-  , liftedImeasures  = mempty-  , liftedClasses    = mempty-  , liftedClaws      = mempty-  , liftedRinstance  = mempty-  , liftedIlaws      = mempty-  , liftedDvariance  = mempty-  , liftedDsize      = mempty-  , liftedBounds     = mempty-  , liftedDefs       = mempty-  , liftedAxeqs      = mempty-  }---- $trackingDeps---- | The /target/ dependencies that concur to the creation of a 'TargetSpec' and a 'LiftedSpec'.-newtype TargetDependencies =-  TargetDependencies { getDependencies :: HashMap StableModule LiftedSpec }-  deriving (Eq, Show, Generic)-  deriving Binary via Generically TargetDependencies---- instance S.Store TargetDependencies--instance Semigroup TargetDependencies where-  x <> y = TargetDependencies -             { getDependencies = getDependencies x <> getDependencies y -             }---instance Monoid TargetDependencies where-  mempty = TargetDependencies mempty---- | Drop the given 'StableModule' from the dependencies.-dropDependency :: StableModule -> TargetDependencies -> TargetDependencies-dropDependency sm (TargetDependencies deps) = TargetDependencies (M.delete sm deps)---- $predicates---- | Returns 'True' if the input 'Var' is a /PLE/ one.-isPLEVar :: TargetSpec -> Var -> Bool -isPLEVar sp x = M.member x (gsAutoInst (gsRefl sp)) ---- | Returns 'True' if the input 'Var' was exported in the module the input 'TargetSrc' represents.-isExportedVar :: TargetSrc -> Var -> Bool-isExportedVar src v = mkStableName n `S.member` ns-  where-    n                = getName v-    ns               = gsExports src------- $legacyDataStructures----{- -data GhcInfo = GI-  { _giSrc       :: !GhcSrc  -  , _giSpec      :: !GhcSpec               -- ^ All specification information for module-  }--}--data GhcSrc = Src -  { _giIncDir    :: !FilePath              -- ^ Path for LH include/prelude directory-  , _giTarget    :: !FilePath              -- ^ Source file for module-  , _giTargetMod :: !ModName               -- ^ Name for module-  , _giCbs       :: ![CoreBind]            -- ^ Source Code-  , _gsTcs       :: ![TyCon]               -- ^ All used Type constructors-  , _gsCls       :: !(Maybe [ClsInst])     -- ^ Class instances?-  , _giDerVars   :: !(S.HashSet Var)       -- ^ Binders created by GHC eg dictionaries-  , _giImpVars   :: ![Var]                 -- ^ Binders that are _read_ in module (but not defined?)-  , _giDefVars   :: ![Var]                 -- ^ (Top-level) binders that are _defined_ in module-  , _giUseVars   :: ![Var]                 -- ^ Binders that are _read_ in module-  , _gsExports   :: !(HashSet StableName)  -- ^ `Name`s exported by the module being verified-  , _gsFiTcs     :: ![TyCon]               -- ^ Family instance TyCons -  , _gsFiDcs     :: ![(F.Symbol, DataCon)] -- ^ Family instance DataCons -  , _gsPrimTcs   :: ![TyCon]               -- ^ Primitive GHC TyCons (from TysPrim.primTyCons)-  , _gsQualImps  :: !QImports              -- ^ Map of qualified imports-  , _gsAllImps   :: !(S.HashSet F.Symbol)  -- ^ Set of _all_ imported modules-  , _gsTyThings  :: ![TyThing]             -- ^ All the @TyThing@s known to GHC-  }--data GhcSpec = SP -  { _gsSig    :: !GhcSpecSig  -  , _gsQual   :: !GhcSpecQual -  , _gsData   :: !GhcSpecData -  , _gsName   :: !GhcSpecNames -  , _gsVars   :: !GhcSpecVars -  , _gsTerm   :: !GhcSpecTerm -  , _gsRefl   :: !GhcSpecRefl   -  , _gsLaws   :: !GhcSpecLaws -  , _gsImps   :: ![(F.Symbol, F.Sort)]  -- ^ Imported Environment-  , _gsConfig :: !Config-  , _gsLSpec  :: !(Spec LocBareType F.LocSymbol) -- ^ Lifted specification for the target module-  }--instance HasConfig GhcSpec where-  getConfig = _gsConfig---{- $provisionalBackCompat--In order to smooth out the migration process to this API, here we provide some /compat/ 'Iso' and 'Prism'-to convert from/to the old data structures, so that migration can be done organically over time.--}--targetSrcIso :: Iso' GhcSrc TargetSrc-targetSrcIso = iso toTargetSrc fromTargetSrc-  where-    toTargetSrc a = TargetSrc-      { giIncDir    = _giIncDir a-      , giTarget    = _giTarget a-      , giTargetMod = _giTargetMod a-      , giCbs       = _giCbs a-      , gsTcs       = _gsTcs a-      , gsCls       = _gsCls a-      , giDerVars   = _giDerVars a-      , giImpVars   = _giImpVars a-      , giDefVars   = _giDefVars a-      , giUseVars   = _giUseVars a-      , gsExports   = _gsExports a-      , gsFiTcs     = _gsFiTcs a-      , gsFiDcs     = _gsFiDcs a-      , gsPrimTcs   = _gsPrimTcs a-      , gsQualImps  = _gsQualImps a-      , gsAllImps   = _gsAllImps a-      , gsTyThings  = _gsTyThings a-      }--    fromTargetSrc a = Src-      { _giIncDir    = giIncDir a-      , _giTarget    = giTarget a-      , _giTargetMod = giTargetMod a-      , _giCbs       = giCbs a-      , _gsTcs       = gsTcs a-      , _gsCls       = gsCls a-      , _giDerVars   = giDerVars a-      , _giImpVars   = giImpVars a-      , _giDefVars   = giDefVars a-      , _giUseVars   = giUseVars a-      , _gsExports   = gsExports a-      , _gsFiTcs     = gsFiTcs a-      , _gsFiDcs     = gsFiDcs a-      , _gsPrimTcs   = gsPrimTcs a-      , _gsQualImps  = gsQualImps a-      , _gsAllImps   = gsAllImps a-      , _gsTyThings  = gsTyThings a-      }--targetSpecGetter :: Getter GhcSpec (TargetSpec, LiftedSpec)-targetSpecGetter = -  to (\ghcSpec -> (toTargetSpec ghcSpec, view (to _gsLSpec % liftedSpecGetter) ghcSpec))-  where-    toTargetSpec a = TargetSpec-      { gsSig    = _gsSig a-      , gsQual   = _gsQual a-      , gsData   = _gsData a-      , gsName   = _gsName a-      , gsVars   = _gsVars a-      , gsTerm   = _gsTerm a-      , gsRefl   = _gsRefl a-      , gsLaws   = _gsLaws a-      , gsImps   = _gsImps a-      , gsConfig = _gsConfig a-      }--bareSpecIso :: Iso' (Spec LocBareType F.LocSymbol) BareSpec-bareSpecIso = iso MkBareSpec getBareSpec--liftedSpecGetter :: Getter (Spec LocBareType F.LocSymbol) LiftedSpec-liftedSpecGetter = to toLiftedSpec-  where-    toLiftedSpec a = LiftedSpec -      { liftedMeasures   = S.fromList . measures $ a-      , liftedImpSigs    = S.fromList . impSigs  $ a-      , liftedExpSigs    = S.fromList . expSigs  $ a-      , liftedAsmSigs    = S.fromList . asmSigs  $ a-      , liftedSigs       = S.fromList . sigs     $ a-      , liftedInvariants = S.fromList . invariants $ a-      , liftedIaliases   = S.fromList . ialiases $ a-      , liftedImports    = S.fromList . imports $ a-      , liftedDataDecls  = S.fromList . dataDecls $ a-      , liftedNewtyDecls = S.fromList . newtyDecls $ a-      , liftedAliases    = S.fromList . aliases $ a-      , liftedEaliases   = S.fromList . ealiases $ a-      , liftedEmbeds     = embeds a-      , liftedQualifiers = S.fromList . qualifiers $ a-      , liftedDecr       = S.fromList . decr $ a-      , liftedLvars      = lvars a-      , liftedAutois     = autois a-      , liftedAutosize   = autosize a-      , liftedCmeasures  = S.fromList . cmeasures $ a-      , liftedImeasures  = S.fromList . imeasures $ a-      , liftedClasses    = S.fromList . classes $ a-      , liftedClaws      = S.fromList . claws $ a-      , liftedRinstance  = S.fromList . rinstance $ a-      , liftedIlaws      = S.fromList . ilaws $ a-      , liftedDvariance  = S.fromList . dvariance $ a-      , liftedDsize      = dsize a -      , liftedBounds     = bounds a-      , liftedDefs       = defs a-      , liftedAxeqs      = S.fromList . axeqs $ a-      }---- This is a temporary internal function that we use to convert the input dependencies into a format--- suitable for 'makeGhcSpec'.-unsafeFromLiftedSpec :: LiftedSpec -> Spec LocBareType F.LocSymbol-unsafeFromLiftedSpec a = Spec-  { measures   = S.toList . liftedMeasures $ a-  , impSigs    = S.toList . liftedImpSigs $ a-  , expSigs    = S.toList . liftedExpSigs $ a-  , asmSigs    = S.toList . liftedAsmSigs $ a-  , sigs       = S.toList . liftedSigs $ a-  , localSigs  = mempty-  , reflSigs   = mempty-  , relational = mempty -  , asmRel     = mempty -  , invariants = S.toList . liftedInvariants $ a-  , ialiases   = S.toList . liftedIaliases $ a-  , imports    = S.toList . liftedImports $ a-  , dataDecls  = S.toList . liftedDataDecls $ a-  , newtyDecls = S.toList . liftedNewtyDecls $ a-  , includes   = mempty-  , aliases    = S.toList . liftedAliases $ a-  , ealiases   = S.toList . liftedEaliases $ a-  , embeds     = liftedEmbeds a-  , qualifiers = S.toList . liftedQualifiers $ a-  , decr       = S.toList . liftedDecr $ a-  , lvars      = liftedLvars a-  , lazy       = mempty-  , fails      = mempty-  , rewrites   = mempty-  , rewriteWith = mempty-  , reflects   = mempty-  , autois     = liftedAutois a-  , hmeas      = mempty-  , hbounds    = mempty-  , inlines    = mempty-  , ignores    = mempty-  , autosize   = liftedAutosize a-  , pragmas    = mempty-  , cmeasures  = S.toList . liftedCmeasures $ a-  , imeasures  = S.toList . liftedImeasures $ a-  , classes    = S.toList . liftedClasses $ a-  , claws      = S.toList . liftedClaws $ a-  , termexprs  = mempty-  , rinstance  = S.toList . liftedRinstance $ a-  , ilaws      = S.toList . liftedIlaws $ a-  , dvariance  = S.toList . liftedDvariance $ a-  , dsize      = liftedDsize  a-  , bounds     = liftedBounds a-  , defs       = liftedDefs a-  , axeqs      = S.toList . liftedAxeqs $ a-  }
− src/Language/Haskell/Liquid/Types/Types.hs 
@@ -1,2589 +0,0 @@-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE DeriveTraversable          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE UndecidableInstances       #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE RecordWildCards            #-}-{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DerivingVia                #-}--{-# OPTIONS_GHC -Wno-orphans #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-}---- | This module should contain all the global type definitions and basic instances.--module Language.Haskell.Liquid.Types.Types (--  -- * Options-    module Language.Haskell.Liquid.UX.Config--  -- * Ghc Information-  , TargetVars   (..)-  , TyConMap     (..)--  -- * F.Located Things-  , F.Located (..)-  , F.dummyLoc--  -- * Symbols-  , F.LocSymbol-  , F.LocText--  -- * Default unknown name-  , F.dummyName-  , F.isDummy--  -- * Bare Type Constructors and Variables-  , BTyCon(..)-  , mkBTyCon-  -- , mkClassBTyCon, mkPromotedBTyCon-  , isClassBTyCon-  , BTyVar(..)--  -- * Refined Type Constructors-  , RTyCon (RTyCon, rtc_tc, rtc_info)-  , TyConInfo(..), defaultTyConInfo-  , rTyConPVs-  , rTyConPropVs-  -- , isClassRTyCon-  , isClassType, isEqType, isRVar, isBool, isEmbeddedClass--  -- * Refinement Types-  , RType (..), Ref(..), RTProp, rPropP-  , RTyVar (..)-  , RTAlias (..)-  , OkRT-  , lmapEAlias-  , dropImplicits--  -- * Worlds-  , HSeg (..)-  , World (..)--  -- * Classes describing operations on `RTypes`-  , TyConable (..)-  , SubsTy (..)--  -- * Type Variables-  , RTVar (..), RTVInfo (..)-  , makeRTVar, mapTyVarValue-  , dropTyVarInfo, rTVarToBind-  , setRtvPol--  -- * Predicate Variables-  , PVar (PV, pname, parg, ptype, pargs), isPropPV, pvType-  , PVKind (..)-  , Predicate (..)--  -- * Refinements-  , UReft(..)--  -- * Relational predicates-  , RelExpr (..)--  -- * Parse-time entities describing refined data types-  , SizeFun  (..), szFun-  , DataDecl (..)-  , DataName (..), dataNameSymbol-  , DataCtor (..)-  , DataConP (..)-  , HasDataDecl (..), hasDecl-  , DataDeclKind (..)-  , TyConP   (..)--  -- * Pre-instantiated RType-  , RRType, RRProp-  , BRType, BRProp-  , BSort, BPVar-  , RTVU, PVU--  -- * Instantiated RType-  , BareType, PrType-  , SpecType, SpecProp, SpecRTVar-  , SpecRep-  , LocBareType, LocSpecType-  , RSort-  , UsedPVar, RPVar, RReft-  , REnv-  , AREnv (..)--  -- * Constructing & Destructing RTypes-  , RTypeRep(..), fromRTypeRep, toRTypeRep-  , mkArrow, bkArrowDeep, bkArrow, safeBkArrow-  , mkUnivs, bkUniv, bkClass, bkUnivClass, bkUnivClass'-  , rImpF, rFun, rFun', rCls, rRCls, rFunDebug--  -- * Manipulating `Predicates`-  , pvars, pappSym, pApp--  -- * Some tests on RTypes-  , isBase-  , isFunTy-  , isTrivial-  , hasHole--  -- * Traversing `RType`-  , efoldReft, foldReft, foldReft'-  , emapReft, mapReft, mapReftM, mapPropM-  , mapExprReft-  , mapBot, mapBind, mapRFInfo-  , foldRType---  -- * ???-  , Oblig(..)-  , ignoreOblig-  , addInvCond--  -- * Inferred Annotations-  , AnnInfo (..)-  , Annot (..)--  -- * Hole Information-  , HoleInfo(..)--  -- * Overall Output-  , Output (..)--  -- * Refinement Hole-  , hole, isHole, hasHoleTy--  -- * Converting To and From Sort-  , ofRSort, toRSort-  , rTypeValueVar-  , rTypeReft-  , stripRTypeBase-  , topRTypeBase--  -- * Class for values that can be pretty printed-  , F.PPrint (..)-  , F.pprint-  , F.showpp--  -- * Printer Configuration-  , PPEnv (..)-  , ppEnv-  , ppEnvShort--  -- * Modules and Imports-  , ModName (..), ModType (..)-  , isSrcImport, isSpecImport, isTarget-  , getModName, getModString, qualifyModName--  -- * Refinement Type Aliases-  , RTEnv (..), BareRTEnv, SpecRTEnv, BareRTAlias, SpecRTAlias-  -- , mapRT, mapRE--  -- * Diagnostics, Warnings, Errors and Error Messages-  , module Language.Haskell.Liquid.Types.Errors-  , Error-  , ErrorResult-  , Warning-  , mkWarning-  , Diagnostics-  , mkDiagnostics-  , emptyDiagnostics-  , noErrors-  , allWarnings-  , allErrors-  , printWarning--  -- * Source information (associated with constraints)-  , Cinfo (..)--  -- * Measures-  , Measure (..)-  , UnSortedExprs, UnSortedExpr-  , MeasureKind (..)-  , CMeasure (..)-  , Def (..)-  , Body (..)-  , MSpec (..)--  -- * Scoping Info-  , BScope--  -- * Type Classes-  , RClass (..)--  -- * KV Profiling-  , KVKind (..)   -- types of kvars-  , KVProf        -- profile table-  , emptyKVProf   -- empty profile-  , updKVProf     -- extend profile--  -- * Misc-  , mapRTAVars-  , insertsSEnv--  -- * CoreToLogic-  , LogicMap(..), toLogicMap, eAppWithMap, LMap(..)--  -- * Refined Instances-  , RDEnv, DEnv(..), RInstance(..), RISig(..), RILaws(..)-  , MethodType(..), getMethodType--  -- * Ureftable Instances-  , UReftable(..)--  -- * String Literals-  , liquidBegin, liquidEnd--  , Axiom(..), HAxiom--  -- , rtyVarUniqueSymbol, tyVarUniqueSymbol-  , rtyVarType, tyVarVar--  -- * Refined Function Info-  , RFInfo(..), defRFInfo, mkRFInfo, classRFInfo, classRFInfoType--  , ordSrcSpan-  )-  where--import           Liquid.GHC.API as Ghc hiding ( Expr-                                                               , Target-                                                               , isFunTy-                                                               , LM-                                                               , ($+$)-                                                               , nest-                                                               , text-                                                               , blankLine-                                                               , (<+>)-                                                               , vcat-                                                               , hsep-                                                               , comma-                                                               , colon-                                                               , parens-                                                               , empty-                                                               , char-                                                               , panic-                                                               , int-                                                               , hcat-                                                               , showPpr-                                                               , punctuate-                                                               , mapSndM-                                                               , ($$)-                                                               , braces-                                                               , angleBrackets-                                                               , brackets-                                                               )-import           Data.String-import           GHC.Generics-import           Prelude                          hiding  (error)-import qualified Prelude--import           Control.Monad                          (liftM2, liftM3, liftM4, void)-import           Control.DeepSeq-import           Data.Bifunctor-import           Data.Typeable                          (Typeable)-import           Data.Generics                          (Data)-import qualified Data.Binary                            as B-import qualified Data.Foldable                          as F-import           Data.Hashable-import qualified Data.HashMap.Strict                    as M-import qualified Data.HashSet                           as S-import qualified Data.List                              as L-import           Data.Maybe                             (mapMaybe)-import           Data.Function                          (on)-import           Data.List                              as L (foldl', nub, null)-import           Data.Text                              (Text)-import           Text.PrettyPrint.HughesPJ              hiding (first, (<>))-import           Text.Printf-import           Language.Fixpoint.Misc--import qualified Language.Fixpoint.Types as F--import           Language.Haskell.Liquid.Types.Generics-import           Liquid.GHC.Misc-import           Liquid.GHC.Logging as GHC-import           Language.Haskell.Liquid.Types.Variance-import           Language.Haskell.Liquid.Types.Errors-import           Language.Haskell.Liquid.Misc-import           Language.Haskell.Liquid.UX.Config-import           Data.Default----------------------------------------------------------------------------------- | Information about scope Binders Scope in-------------------------------------------------------------------------------{- In types with base refinement, e.g., {out:T {inner:a | ri} | ro }-If BScope = True , then the outer binder out is     in scope on ri-If BScope = False, then the outer binder out is not in scope on ri--}--type BScope = Bool--------------------------------------------------------------------------------- | Information about Type Constructors-------------------------------------------------------------------------------data TyConMap = TyConMap-  { tcmTyRTy    :: M.HashMap TyCon             RTyCon  -- ^ Map from GHC TyCon to RTyCon-  , tcmFIRTy    :: M.HashMap (TyCon, [F.Sort]) RTyCon  -- ^ Map from GHC Family-Instances to RTyCon-  , tcmFtcArity :: M.HashMap TyCon             Int     -- ^ Arity of each Family-Tycon-  }---newtype RFInfo = RFInfo {permitTC :: Maybe Bool }-  deriving (Generic, Data, Typeable, Show, Eq)--defRFInfo :: RFInfo-defRFInfo = RFInfo Nothing--classRFInfo :: Bool -> RFInfo-classRFInfo b = RFInfo (Just b)--classRFInfoType :: Bool -> RType c tv r -> RType c tv r-classRFInfoType b = fromRTypeRep .-                    (\trep@RTypeRep{..} -> trep{ty_info = map (\i -> i{permitTC = pure b}) ty_info}) .-                    toRTypeRep--mkRFInfo :: Config  -> RFInfo-mkRFInfo cfg = RFInfo $ Just (typeclass cfg)--instance Hashable RFInfo-instance NFData RFInfo-instance B.Binary RFInfo---------------------------------------------------------------------------------- | Printer ------------------------------------------------------------------------------------------------------------------------------------------------data PPEnv = PP-  { ppPs    :: Bool -- ^ print abstract-predicates-  , ppTyVar :: Bool -- ^ print the unique suffix for each tyvar-  , ppShort :: Bool -- ^ print the tycons without qualification-  , ppDebug :: Bool -- ^ gross with full info-  }-  deriving (Show)--ppEnv :: PPEnv-ppEnv = ppEnvDef-          { ppPs    = True }-          { ppDebug = True }   -- RJ: needed for resolution, because pp is used for serialization?--{- | [NOTE:ppEnv] For some mysterious reason, `ppDebug` must equal `True`-     or various tests fail e.g. tests/classes/pos/TypeEquality0{0,1}.hs-     Yikes. Find out why!- -}--ppEnvDef :: PPEnv-ppEnvDef = PP False False False False--ppEnvShort :: PPEnv -> PPEnv-ppEnvShort pp = pp { ppShort = True }----------------------------------------------------------------------- Huh?--------------------------------------------------------------------type Expr      = F.Expr-type Symbol    = F.Symbol----- [NOTE:LIFTED-VAR-SYMBOLS]: Following NOTE:REFLECT-IMPORTS, by default--- each (lifted) `Var` is mapped to its `Symbol` via the `Symbolic Var`--- instance. For _generated_ vars, we may want a custom name e.g. see---   tests/pos/NatClass.hs--- and we maintain that map in `lmVarSyms` with the `Just s` case.--- Ideally, this bandaid should be replaced so we don't have these--- hacky corner cases.--data LogicMap = LM-  { lmSymDefs  :: M.HashMap Symbol LMap        -- ^ Map from symbols to equations they define-  , lmVarSyms  :: M.HashMap Var (Maybe Symbol) -- ^ Map from (lifted) Vars to `Symbol`; see:-                                              --   NOTE:LIFTED-VAR-SYMBOLS and NOTE:REFLECT-IMPORTs-  } deriving (Show)--instance Monoid LogicMap where-  mempty  = LM M.empty M.empty-  mappend = (<>)--instance Semigroup LogicMap where-  LM x1 x2 <> LM y1 y2 = LM (M.union x1 y1) (M.union x2 y2)--data LMap = LMap-  { lmVar  :: F.LocSymbol-  , lmArgs :: [Symbol]-  , lmExpr :: Expr-  }--instance Show LMap where-  show (LMap x xs e) = show x ++ " " ++ show xs ++ "\t |-> \t" ++ show e--toLogicMap :: [(F.LocSymbol, [Symbol], Expr)] -> LogicMap-toLogicMap ls = mempty {lmSymDefs = M.fromList $ map toLMap ls}-  where-    toLMap (x, ys, e) = (F.val x, LMap {lmVar = x, lmArgs = ys, lmExpr = e})--eAppWithMap :: LogicMap -> F.Located Symbol -> [Expr] -> Expr -> Expr-eAppWithMap lmap f es def-  | Just (LMap _ xs e) <- M.lookup (F.val f) (lmSymDefs lmap)-  , length xs == length es-  = F.subst (F.mkSubst $ zip xs es) e-  | Just (LMap _ xs e) <- M.lookup (F.val f) (lmSymDefs lmap)-  , isApp e-  = F.subst (F.mkSubst $ zip xs es) $ dropApp e (length xs - length es)-  | otherwise-  = def--dropApp :: Expr -> Int -> Expr-dropApp e i | i <= 0 = e-dropApp (F.EApp e _) i = dropApp e (i-1)-dropApp _ _          = errorstar "impossible"--isApp :: Expr -> Bool-isApp (F.EApp (F.EVar _) (F.EVar _)) = True-isApp (F.EApp e (F.EVar _))          = isApp e-isApp _                              = False--data TyConP = TyConP-  { tcpLoc          :: !F.SourcePos-  , tcpCon          :: !TyCon-  , tcpFreeTyVarsTy :: ![RTyVar]-  , tcpFreePredTy   :: ![PVar RSort]-  , tcpVarianceTs   :: !VarianceInfo-  , tcpVariancePs   :: !VarianceInfo-  , tcpSizeFun      :: !(Maybe SizeFun)-  } deriving (Generic, Data, Typeable)--instance F.Loc TyConP where-  srcSpan tc = F.SS (tcpLoc tc) (tcpLoc tc)----- TODO: just use Located instead of dc_loc, dc_locE-data DataConP = DataConP-  { dcpLoc        :: !F.SourcePos-  , dcpCon        :: !DataCon                -- ^ Corresponding GHC DataCon-  , dcpFreeTyVars :: ![RTyVar]               -- ^ Type parameters-  , dcpFreePred   :: ![PVar RSort]           -- ^ Abstract Refinement parameters-  , dcpTyConstrs  :: ![SpecType]             -- ^ ? Class constraints (via `dataConStupidTheta`)-  , dcpTyArgs     :: ![(Symbol, SpecType)]   -- ^ Value parameters-  , dcpTyRes      :: !SpecType               -- ^ Result type-  , dcpIsGadt     :: !Bool                   -- ^ Was this specified in GADT style (if so, DONT use function names as fields)-  , dcpModule     :: !F.Symbol               -- ^ Which module was this defined in-  , dcpLocE       :: !F.SourcePos-  } deriving (Generic, Data, Typeable)---- | [NOTE:DataCon-Data] for each 'DataConP' we also---   store the type of the constructed data. This is---   *the same as* 'tyRes' for *vanilla* ADTs---   (e.g. List, Maybe etc.) but may differ for GADTs.---   For example,------      data Thing a where---        X  :: Thing Int---        Y  :: Thing Bool------   Here the 'DataConP' associated with 'X' (resp. 'Y')---   has 'tyRes' corresponding to 'Thing Int' (resp. 'Thing Bool'),---   but in both cases, the 'tyData' should be 'Thing a'.-----instance F.Loc DataConP where-  srcSpan d = F.SS (dcpLoc d) (dcpLocE d)---- | Which Top-Level Binders Should be Verified-data TargetVars = AllVars | Only ![Var]-------------------------------------------------------------------------- | Abstract Predicate Variables ---------------------------------------------------------------------------------------------------------data PVar t = PV-  { pname :: !Symbol-  , ptype :: !(PVKind t)-  , parg  :: !Symbol-  , pargs :: ![(t, Symbol, Expr)]-  } deriving (Generic, Data, Typeable, Show, Functor)--instance Eq (PVar t) where-  pv == pv' = pname pv == pname pv' {- UNIFY: What about: && eqArgs pv pv' -}--instance Ord (PVar t) where-  compare (PV n _ _ _)  (PV n' _ _ _) = compare n n'--instance B.Binary t => B.Binary (PVar t)-instance NFData t   => NFData   (PVar t)--instance Hashable (PVar a) where-  hashWithSalt i (PV n _ _ _) = hashWithSalt i n--pvType :: PVar t -> t-pvType p = case ptype p of-             PVProp t -> t-             PVHProp  -> panic Nothing "pvType on HProp-PVar"--data PVKind t-  = PVProp t-  | PVHProp-  deriving (Generic, Data, Typeable, Functor, F.Foldable, Traversable, Show)--instance B.Binary a => B.Binary (PVKind a)-instance NFData a   => NFData   (PVKind a)-------------------------------------------------------------------------------------- | Predicates ---------------------------------------------------------------------------------------------------------------------------------------------------type UsedPVar      = PVar ()--newtype Predicate  = Pr [UsedPVar]-  deriving (Generic, Data, Typeable)-  deriving Hashable via Generically Predicate--instance Eq Predicate where-  (Pr vs) == (Pr ws)-      = and $ (length vs' == length ws') : [v == w | (v, w) <- zip vs' ws']-        where-          vs' = L.sort vs-          ws' = L.sort ws----instance B.Binary Predicate--instance NFData Predicate where-  rnf _ = ()--instance Monoid Predicate where-  mempty  = pdTrue-  mappend = (<>)--instance Semigroup Predicate where-  p <> p' = pdAnd [p, p']--instance Semigroup a => Semigroup (UReft a) where-  MkUReft x y <> MkUReft x' y' = MkUReft (x <> x') (y <> y')--instance (Monoid a) => Monoid (UReft a) where-  mempty  = MkUReft mempty mempty-  mappend = (<>)---pdTrue :: Predicate-pdTrue         = Pr []--pdAnd :: Foldable t => t Predicate -> Predicate-pdAnd ps       = Pr (nub $ concatMap pvars ps)--pvars :: Predicate -> [UsedPVar]-pvars (Pr pvs) = pvs--instance F.Subable UsedPVar where-  syms pv         = [ y | (_, x, F.EVar y) <- pargs pv, x /= y ]-  subst s pv      = pv { pargs = mapThd3 (F.subst s)  <$> pargs pv }-  substf f pv     = pv { pargs = mapThd3 (F.substf f) <$> pargs pv }-  substa f pv     = pv { pargs = mapThd3 (F.substa f) <$> pargs pv }---instance F.Subable Predicate where-  syms     (Pr pvs) = concatMap F.syms   pvs-  subst  s (Pr pvs) = Pr (F.subst s  <$> pvs)-  substf f (Pr pvs) = Pr (F.substf f <$> pvs)-  substa f (Pr pvs) = Pr (F.substa f <$> pvs)--instance NFData r => NFData (UReft r)--data RelExpr = ERBasic F.Expr | ERChecked Expr RelExpr | ERUnChecked Expr RelExpr-  deriving (Eq, Show, Data, Generic)--instance B.Binary RelExpr--instance F.PPrint RelExpr where-  pprintTidy k (ERBasic e)       = F.pprintTidy k e-  pprintTidy k (ERChecked e r)   = F.pprintTidy k e <+> "!=>" <+> F.pprintTidy k r-  pprintTidy k (ERUnChecked e r) = F.pprintTidy k e <+> ":=>" <+> F.pprintTidy k r--newtype BTyVar = BTV Symbol deriving (Show, Generic, Data, Typeable)--newtype RTyVar = RTV TyVar deriving (Generic, Data, Typeable)--instance Eq BTyVar where-  (BTV x) == (BTV y) = x == y--instance Ord BTyVar where-  compare (BTV x) (BTV y) = compare x y--instance IsString BTyVar where-  fromString = BTV . fromString--instance B.Binary BTyVar-instance Hashable BTyVar-instance NFData   BTyVar-instance NFData   RTyVar--instance F.Symbolic BTyVar where-  symbol (BTV tv) = tv--instance F.Symbolic RTyVar where-  symbol (RTV tv) = F.symbol tv -- tyVarUniqueSymbol tv---- instance F.Symbolic RTyVar where-  -- symbol (RTV tv) = F.symbol . getName $ tv--- rtyVarUniqueSymbol  :: RTyVar -> Symbol--- rtyVarUniqueSymbol (RTV tv) = tyVarUniqueSymbol tv--- tyVarUniqueSymbol :: TyVar -> Symbol--- tyVarUniqueSymbol tv = F.symbol $ show (getName tv) ++ "_" ++ show (varUnique tv)--data BTyCon = BTyCon-  { btc_tc    :: !F.LocSymbol    -- ^ TyCon name with location information-  , btc_class :: !Bool           -- ^ Is this a class type constructor?-  , btc_prom  :: !Bool           -- ^ Is Promoted Data Con?-  }-  deriving (Generic, Data, Typeable)-  deriving Hashable via Generically BTyCon--instance B.Binary BTyCon--data RTyCon = RTyCon-  { rtc_tc    :: TyCon         -- ^ GHC Type Constructor-  , rtc_pvars :: ![RPVar]      -- ^ Predicate Parameters-  , rtc_info  :: !TyConInfo    -- ^ TyConInfo-  }-  deriving (Generic, Data, Typeable)--instance F.Symbolic RTyCon where-  symbol = F.symbol . rtc_tc--instance F.Symbolic BTyCon where-  symbol = F.val . btc_tc--instance NFData BTyCon--instance NFData RTyCon--rtyVarType :: RTyVar -> Type-rtyVarType (RTV v) = TyVarTy v--tyVarVar :: RTVar RTyVar c -> Var-tyVarVar (RTVar (RTV v) _) = v----mkBTyCon :: F.LocSymbol -> BTyCon-mkBTyCon x = BTyCon x False False----- | Accessors for @RTyCon@--isBool :: RType RTyCon t t1 -> Bool-isBool (RApp RTyCon{rtc_tc = c} _ _ _) = c == boolTyCon-isBool _                                 = False--isRVar :: RType c tv r -> Bool-isRVar (RVar _ _) = True-isRVar _          = False--isClassBTyCon :: BTyCon -> Bool-isClassBTyCon = btc_class---- isClassRTyCon :: RTyCon -> Bool--- isClassRTyCon x = (isClassTyCon $ rtc_tc x) || (rtc_tc x == eqPrimTyCon)--rTyConPVs :: RTyCon -> [RPVar]-rTyConPVs     = rtc_pvars--rTyConPropVs :: RTyCon -> [PVar RSort]-rTyConPropVs  = filter isPropPV . rtc_pvars--isPropPV :: PVar t -> Bool-isPropPV      = isProp . ptype--isEqType :: TyConable c => RType c t t1 -> Bool-isEqType (RApp c _ _ _) = isEqual c-isEqType _              = False---isClassType :: TyConable c => RType c t t1 -> Bool-isClassType (RApp c _ _ _) = isClass c-isClassType _              = False--isEmbeddedClass :: TyConable c => RType c t t1 -> Bool-isEmbeddedClass (RApp c _ _ _) = isEmbeddedDict c-isEmbeddedClass _              = False---- rTyConPVHPs = filter isHPropPV . rtc_pvars--- isHPropPV   = not . isPropPV--isProp :: PVKind t -> Bool-isProp (PVProp _) = True-isProp _          = False---defaultTyConInfo :: TyConInfo-defaultTyConInfo = TyConInfo [] [] Nothing--instance Default TyConInfo where-  def = defaultTyConInfo----------------------------------------------------------------------------- | Co- and Contra-variance for TyCon ------------------------------------------------------------------------------------------------------------ | Indexes start from 0 and type or predicate arguments can be both---   covariant and contravaariant e.g., for the below Foo dataType------     data Foo a b c d <p :: b -> Prop, q :: Int -> Prop, r :: a -> Prop>---       = F (a<r> -> b<p>) | Q (c -> a) | G (Int<q> -> a<r>)------  there will be:------    varianceTyArgs     = [Bivariant , Covariant, Contravatiant, Invariant]---    variancePsArgs     = [Covariant, Contravatiant, Bivariant]-----data TyConInfo = TyConInfo-  { varianceTyArgs  :: !VarianceInfo      -- ^ variance info for type variables-  , variancePsArgs  :: !VarianceInfo      -- ^ variance info for predicate variables-  , sizeFunction    :: !(Maybe SizeFun)   -- ^ logical UNARY function that computes the size of the structure-  } deriving (Generic, Data, Typeable)--instance NFData TyConInfo--instance Show TyConInfo where-  show (TyConInfo x y _) = show x ++ "\n" ++ show y------------------------------------------------------------------------------------- | Unified Representation of Refinement Types -------------------------------------------------------------------------------------------------------------------type RTVU c tv = RTVar tv (RType c tv ())-type PVU  c tv = PVar     (RType c tv ())--instance Show tv => Show (RTVU c tv) where-  show (RTVar t _) = show t--data RType c tv r-  = RVar {-      rt_var    :: !tv-    , rt_reft   :: !r-    }--  | RFun  {-      rt_bind   :: !Symbol-    , rt_rinfo  :: !RFInfo-    , rt_in     :: !(RType c tv r)-    , rt_out    :: !(RType c tv r)-    , rt_reft   :: !r-    }--  | RImpF  {-      rt_bind   :: !Symbol-    , rt_rinfo  :: !RFInfo -- NNV TODO merge with RFun-    , rt_in     :: !(RType c tv r)-    , rt_out    :: !(RType c tv r)-    , rt_reft   :: !r-    }--  | RAllT {-      rt_tvbind :: !(RTVU c tv) -- RTVar tv (RType c tv ()))-    , rt_ty     :: !(RType c tv r)-    , rt_ref    :: !r-    }--  -- | "forall x y <z :: Nat, w :: Int> . TYPE"-  --               ^^^^^^^^^^^^^^^^^^^ (rt_pvbind)-  | RAllP {-      rt_pvbind :: !(PVU c tv)-    , rt_ty     :: !(RType c tv r)-    }--  -- | For example, in [a]<{\h -> v > h}>, we apply (via `RApp`)-  --   * the `RProp`  denoted by `{\h -> v > h}` to-  --   * the `RTyCon` denoted by `[]`.-  | RApp  {-      rt_tycon  :: !c-    , rt_args   :: ![RType  c tv r]-    , rt_pargs  :: ![RTProp c tv r]-    , rt_reft   :: !r-    }--  | RAllE {-      rt_bind   :: !Symbol-    , rt_allarg :: !(RType c tv r)-    , rt_ty     :: !(RType c tv r)-    }--  | REx {-      rt_bind   :: !Symbol-    , rt_exarg  :: !(RType c tv r)-    , rt_ty     :: !(RType c tv r)-    }--  | RExprArg (F.Located Expr)                   -- ^ For expression arguments to type aliases-                                                --   see tests/pos/vector2.hs-  | RAppTy{-      rt_arg   :: !(RType c tv r)-    , rt_res   :: !(RType c tv r)-    , rt_reft  :: !r-    }--  | RRTy  {-      rt_env   :: ![(Symbol, RType c tv r)]-    , rt_ref   :: !r-    , rt_obl   :: !Oblig-    , rt_ty    :: !(RType c tv r)-    }--  | RHole r -- ^ let LH match against the Haskell type and add k-vars, e.g. `x:_`-            --   see tests/pos/Holes.hs-  deriving (Eq, Generic, Data, Typeable, Functor)-  deriving Hashable via Generically (RType c tv r)--instance (B.Binary c, B.Binary tv, B.Binary r) => B.Binary (RType c tv r)-instance (NFData c, NFData tv, NFData r)       => NFData (RType c tv r)--ignoreOblig :: RType t t1 t2 -> RType t t1 t2-ignoreOblig (RRTy _ _ _ t) = t-ignoreOblig t              = t--dropImplicits :: RType c tv r -> RType c tv r-dropImplicits (RImpF _ _ _ o _) = dropImplicits o-dropImplicits (RFun x ii i o r) = RFun x ii (dropImplicits i) (dropImplicits o) r-dropImplicits (RAllP p t) = RAllP p (dropImplicits t)-dropImplicits (RAllT p t r) = RAllT p (dropImplicits t) r-dropImplicits (RApp c as ps r) = RApp c (dropImplicits <$> as) (dropImplicitsRP <$> ps) r-dropImplicits (RAllE p t t') = RAllE p (dropImplicits t) (dropImplicits t')-dropImplicits (REx s t t')   = REx   s (dropImplicits t) (dropImplicits t')-dropImplicits (RAppTy t t' r)   = RAppTy (dropImplicits t) (dropImplicits t') r-dropImplicits (RRTy e r o t) = RRTy (second dropImplicits <$> e) r o (dropImplicits t)-dropImplicits t = t--dropImplicitsRP :: RTProp c tv r -> RTProp c tv r-dropImplicitsRP (RProp as b) = RProp (second dropImplicits <$> as) (dropImplicits b)---makeRTVar :: tv -> RTVar tv s-makeRTVar a = RTVar a (RTVNoInfo True)--instance (Eq tv) => Eq (RTVar tv s) where-  t1 == t2 = ty_var_value t1 == ty_var_value t2--data RTVar tv s = RTVar-  { ty_var_value :: tv-  , ty_var_info  :: RTVInfo s-  } deriving (Generic, Data, Typeable)-    deriving Hashable via Generically (RTVar tv s)--mapTyVarValue :: (tv1 -> tv2) -> RTVar tv1 s -> RTVar tv2 s-mapTyVarValue f v = v {ty_var_value = f $ ty_var_value v}--dropTyVarInfo :: RTVar tv s1 -> RTVar tv s2-dropTyVarInfo v = v{ty_var_info = RTVNoInfo True }--data RTVInfo s-  = RTVNoInfo { rtv_is_pol :: Bool }-  | RTVInfo { rtv_name   :: Symbol-            , rtv_kind   :: s-            , rtv_is_val :: Bool-            , rtv_is_pol :: Bool -- true iff the type variable gets instantiated with-                                 -- any refinement (ie is polymorphic on refinements),-                                 -- false iff instantiation is with true refinement-            } deriving (Generic, Data, Typeable, Functor)-              deriving Hashable via Generically (RTVInfo s)---setRtvPol :: RTVar tv a -> Bool -> RTVar tv a-setRtvPol (RTVar a i) b = RTVar a (i{rtv_is_pol = b})--rTVarToBind :: RTVar RTyVar s  -> Maybe (Symbol, s)-rTVarToBind = go . ty_var_info-  where-    go RTVInfo{..} | rtv_is_val = Just (rtv_name, rtv_kind)-    go _                        = Nothing--tyVarIsVal :: RTVar tv s -> Bool-tyVarIsVal = rtvinfoIsVal . ty_var_info--rtvinfoIsVal :: RTVInfo s -> Bool-rtvinfoIsVal RTVNoInfo{} = False-rtvinfoIsVal RTVInfo{..} = rtv_is_val--instance (B.Binary tv, B.Binary s) => B.Binary (RTVar tv s)-instance (NFData tv, NFData s)     => NFData   (RTVar tv s)-instance (NFData s)                => NFData   (RTVInfo s)-instance (B.Binary s)              => B.Binary (RTVInfo s)---- | @Ref@ describes `Prop τ` and `HProp` arguments applied to type constructors.---   For example, in [a]<{\h -> v > h}>, we apply (via `RApp`)---   * the `RProp`  denoted by `{\h -> v > h}` to---   * the `RTyCon` denoted by `[]`.---   Thus, @Ref@ is used for abstract-predicate (arguments) that are associated---   with _type constructors_ i.e. whose semantics are _dependent upon_ the data-type.---   In contrast, the `Predicate` argument in `ur_pred` in the @UReft@ applies---   directly to any type and has semantics _independent of_ the data-type.--data Ref τ t = RProp-  { rf_args :: [(Symbol, τ)]-  , rf_body :: t -- ^ Abstract refinement associated with `RTyCon`-  } deriving (Eq, Generic, Data, Typeable, Functor)-    deriving Hashable via Generically (Ref τ t)--instance (B.Binary τ, B.Binary t) => B.Binary (Ref τ t)-instance (NFData τ,   NFData t)   => NFData   (Ref τ t)--rPropP :: [(Symbol, τ)] -> r -> Ref τ (RType c tv r)-rPropP τ r = RProp τ (RHole r)---- | @RTProp@ is a convenient alias for @Ref@ that will save a bunch of typing.---   In general, perhaps we need not expose @Ref@ directly at all.-type RTProp c tv r = Ref (RType c tv ()) (RType c tv r)----- | A @World@ is a Separation Logic predicate that is essentially a sequence of binders---   that satisfies two invariants (TODO:LIQUID):---   1. Each `hs_addr :: Symbol` appears at most once,---   2. There is at most one `HVar` in a list.--newtype World t = World [HSeg t]-                deriving (Generic, Data, Typeable)--data    HSeg  t = HBind {hs_addr :: !Symbol, hs_val :: t}-                | HVar UsedPVar-                deriving (Generic, Data, Typeable)--data UReft r = MkUReft-  { ur_reft   :: !r-  , ur_pred   :: !Predicate-  }-  deriving (Eq, Generic, Data, Typeable, Functor, Foldable, Traversable)-  deriving Hashable via Generically (UReft r)--instance B.Binary r => B.Binary (UReft r)--type BRType      = RType BTyCon BTyVar       -- ^ "Bare" parsed version-type RRType      = RType RTyCon RTyVar       -- ^ "Resolved" version-type RRep        = RTypeRep RTyCon RTyVar-type BSort       = BRType    ()-type RSort       = RRType    ()-type BPVar       = PVar      BSort-type RPVar       = PVar      RSort-type RReft       = UReft     F.Reft-type PrType      = RRType    Predicate-type BareType    = BRType    RReft-type SpecType    = RRType    RReft-type SpecRep     = RRep      RReft-type SpecProp    = RRProp    RReft-type RRProp r    = Ref       RSort (RRType r)-type BRProp r    = Ref       BSort (BRType r)-type SpecRTVar   = RTVar     RTyVar RSort----type LocBareType = F.Located BareType-type LocSpecType = F.Located SpecType--type SpecRTEnv   = RTEnv RTyVar SpecType-type BareRTEnv   = RTEnv Symbol BareType-type BareRTAlias = RTAlias Symbol BareType-type SpecRTAlias = RTAlias RTyVar SpecType---class SubsTy tv ty a where-  subt :: (tv, ty) -> a -> a--class (Eq c) => TyConable c where-  isFun    :: c -> Bool-  isList   :: c -> Bool-  isTuple  :: c -> Bool-  ppTycon  :: c -> Doc-  isClass  :: c -> Bool-  isEmbeddedDict :: c -> Bool-  isEqual  :: c -> Bool-  isOrdCls  :: c -> Bool-  isEqCls   :: c -> Bool--  isNumCls  :: c -> Bool-  isFracCls :: c -> Bool--  isClass   = const False-  isEmbeddedDict c = isNumCls c || isEqual c || isOrdCls c || isEqCls c-  isOrdCls  = const False-  isEqCls   = const False-  isEqual   = const False-  isNumCls  = const False-  isFracCls = const False----- Should just make this a @Pretty@ instance but its too damn tedious--- to figure out all the constraints.--type OkRT c tv r = ( TyConable c-                   , F.PPrint tv, F.PPrint c, F.PPrint r-                   , F.Reftable r, F.Reftable (RTProp c tv ()), F.Reftable (RTProp c tv r)-                   , Eq c, Eq tv-                   , Hashable tv-                   )------------------------------------------------------------------------------------ | TyConable Instances -----------------------------------------------------------------------------------------------------------------------------------------instance TyConable RTyCon where-  isFun      = isFunTyCon . rtc_tc-  isList     = (listTyCon ==) . rtc_tc-  isTuple    = Ghc.isTupleTyCon   . rtc_tc-  isClass    = isClass . rtc_tc -- isClassRTyCon-  isEqual    = isEqual . rtc_tc-  ppTycon    = F.toFix--  isNumCls c  = maybe False (isClassOrSubClass isNumericClass)-                (tyConClass_maybe $ rtc_tc c)-  isFracCls c = maybe False (isClassOrSubClass isFractionalClass)-                (tyConClass_maybe $ rtc_tc c)-  isOrdCls  c = maybe False isOrdClass (tyConClass_maybe $ rtc_tc c)-  isEqCls   c = isEqCls (rtc_tc c)---instance TyConable TyCon where-  isFun      = isFunTyCon-  isList     = (listTyCon ==)-  isTuple    = Ghc.isTupleTyCon-  isClass c  = isClassTyCon c   || isEqual c -- c == eqPrimTyCon-  isEqual c  = c == eqPrimTyCon || c == eqReprPrimTyCon-  ppTycon    = text . showPpr--  isNumCls c  = maybe False (isClassOrSubClass isNumericClass)-                (tyConClass_maybe c)-  isFracCls c = maybe False (isClassOrSubClass isFractionalClass)-                (tyConClass_maybe c)-  isOrdCls c  = maybe False isOrdClass-                (tyConClass_maybe c)-  isEqCls  c  = isPrelEqTyCon c--isClassOrSubClass :: (Class -> Bool) -> Class -> Bool-isClassOrSubClass p cls-  = p cls || any (isClassOrSubClass p . fst)-                 (mapMaybe getClassPredTys_maybe (classSCTheta cls))---- MOVE TO TYPES-instance TyConable Symbol where-  isFun   s = F.funConName == s-  isList  s = F.listConName == s-  isTuple s = F.tupConName == s-  ppTycon   = text . F.symbolString--instance TyConable F.LocSymbol where-  isFun   = isFun   . F.val-  isList  = isList  . F.val-  isTuple = isTuple . F.val-  ppTycon = ppTycon . F.val--instance TyConable BTyCon where-  isFun   = isFun . btc_tc-  isList  = isList . btc_tc-  isTuple = isTuple . btc_tc-  isClass = isClassBTyCon-  ppTycon = ppTycon . btc_tc---instance Eq RTyCon where-  x == y = rtc_tc x == rtc_tc y--instance Eq BTyCon where-  x == y = btc_tc x == btc_tc y--instance Ord BTyCon where-  compare x y = compare (btc_tc x) (btc_tc y)--instance F.Fixpoint RTyCon where-  toFix (RTyCon c _ _) = text $ showPpr c--instance F.Fixpoint BTyCon where-  toFix = text . F.symbolString . F.val . btc_tc--instance F.Fixpoint Cinfo where-  toFix = text . showPpr . ci_loc--instance Show Cinfo where-  show = show . F.toFix--instance F.PPrint RTyCon where-  pprintTidy k c-    | ppDebug ppEnv = F.pprintTidy k tc  <-> angleBrackets (F.pprintTidy k pvs)-    | otherwise     = text . showPpr . rtc_tc $ c-    where-      tc            = F.symbol (rtc_tc c)-      pvs           = rtc_pvars c--instance F.PPrint BTyCon where-  pprintTidy _ = text . F.symbolString . F.val . btc_tc--instance F.PPrint v => F.PPrint (RTVar v s) where-  pprintTidy k (RTVar x _) = F.pprintTidy k x--instance Show RTyCon where-  show = F.showpp--instance Show BTyCon where-  show = F.showpp--instance F.Loc BTyCon where-  srcSpan = F.srcSpan . btc_tc------------------------------------------------------------------------------------- | Refined Instances --------------------------------------------------------------------------------------------------------------------------------------------data RInstance t = RI-  { riclass :: BTyCon-  , ritype  :: [t]-  , risigs  :: [(F.LocSymbol, RISig t)]-  } deriving (Eq, Generic, Functor, Data, Typeable, Show)-    deriving Hashable via Generically (RInstance t)--data RILaws ty = RIL-  { rilName    :: BTyCon-  , rilSupers  :: [ty]-  , rilTyArgs  :: [ty]-  , rilEqus    :: [(F.LocSymbol, F.LocSymbol)]-  , rilPos     :: F.Located ()-  } deriving (Eq, Show, Functor, Data, Typeable, Generic)-    deriving Hashable via Generically (RILaws ty)--data RISig t = RIAssumed t | RISig t-  deriving (Eq, Generic, Functor, Data, Typeable, Show)-  deriving Hashable via Generically (RISig t)--instance F.PPrint t => F.PPrint (RISig t) where-  pprintTidy k = ppRISig k (empty :: Doc)--ppRISig :: (F.PPrint k, F.PPrint t) => F.Tidy -> k -> RISig t -> Doc-ppRISig k x (RIAssumed t) = "assume" <+> F.pprintTidy k x <+> "::" <+> F.pprintTidy k t-ppRISig k x (RISig t)     =              F.pprintTidy k x <+> "::" <+> F.pprintTidy k t--instance F.PPrint t => F.PPrint (RInstance t) where-  pprintTidy k (RI n ts mts) = ppMethods k "instance" n ts mts---instance (B.Binary t) => B.Binary (RInstance t)-instance (B.Binary t) => B.Binary (RISig t)-instance (B.Binary t) => B.Binary (RILaws t)--newtype DEnv x ty = DEnv (M.HashMap x (M.HashMap Symbol (RISig ty)))-                    deriving (Semigroup, Monoid, Show, Functor)--type RDEnv = DEnv Var SpecType--data MethodType t = MT {tyInstance :: !(Maybe t), tyClass :: !(Maybe t) }-  deriving (Show)--getMethodType :: MethodType t -> Maybe t-getMethodType (MT (Just t) _ ) = Just t-getMethodType (MT _ t) = t------------------------------------------------------------------------------- | Values Related to Specifications -----------------------------------------------------------------------------------------------------------------data Axiom b s e = Axiom-  { aname  :: (Var, Maybe DataCon)-  , rname  :: Maybe b-  , abinds :: [b]-  , atypes :: [s]-  , alhs   :: e-  , arhs   :: e-  }--type HAxiom = Axiom Var    Type CoreExpr---- type AxiomEq = F.Equation--instance Show (Axiom Var Type CoreExpr) where-  show (Axiom (n, c) v bs _ts lhs rhs) = "Axiom : " ++-                                         "\nFun Name: " ++ showPpr n ++-                                         "\nReal Name: " ++ showPpr v ++-                                         "\nData Con: " ++ showPpr c ++-                                         "\nArguments:" ++ showPpr bs  ++-                                         -- "\nTypes    :" ++ (showPpr ts)  ++-                                         "\nLHS      :" ++ showPpr lhs ++-                                         "\nRHS      :" ++ showPpr rhs------------------------------------------------------------------------------------- | Data type refinements----------------------------------------------------------------------------------data DataDecl   = DataDecl-  { tycName   :: DataName              -- ^ Type  Constructor Name-  , tycTyVars :: [Symbol]              -- ^ Tyvar Parameters-  , tycPVars  :: [PVar BSort]          -- ^ PVar  Parameters-  , tycDCons  :: Maybe [DataCtor]      -- ^ Data Constructors (Nothing is reserved for non-GADT style empty data declarations)-  , tycSrcPos :: !F.SourcePos          -- ^ Source Position-  , tycSFun   :: Maybe SizeFun         -- ^ Default termination measure-  , tycPropTy :: Maybe BareType        -- ^ Type of Ind-Prop-  , tycKind   :: !DataDeclKind         -- ^ User-defined or Auto-lifted-  } deriving (Data, Typeable, Generic)-    deriving Hashable via Generically DataDecl---- | The name of the `TyCon` corresponding to a `DataDecl`-data DataName-  = DnName !F.LocSymbol                -- ^ for 'isVanillyAlgTyCon' we can directly use the `TyCon` name-  | DnCon  !F.LocSymbol                -- ^ for 'FamInst' TyCon we save some `DataCon` name-  deriving (Eq, Ord, Data, Typeable, Generic)---- | Data Constructor-data DataCtor = DataCtor-  { dcName   :: F.LocSymbol            -- ^ DataCon name-  , dcTyVars :: [F.Symbol]             -- ^ Type parameters-  , dcTheta  :: [BareType]             -- ^ The GHC ThetaType corresponding to DataCon.dataConSig-  , dcFields :: [(Symbol, BareType)]   -- ^ field-name and field-Type pairs-  , dcResult :: Maybe BareType         -- ^ Possible output (if in GADT form)-  } deriving (Data, Typeable, Generic)-    deriving Hashable via Generically DataCtor---- | Termination expressions-data SizeFun-  = IdSizeFun              -- ^ \x -> F.EVar x-  | SymSizeFun F.LocSymbol -- ^ \x -> f x-  deriving (Data, Typeable, Generic)-  deriving Hashable via Generically SizeFun---- | What kind of `DataDecl` is it?-data DataDeclKind-  = DataUser           -- ^ User defined data-definitions         (should have refined fields)-  | DataReflected      -- ^ Automatically lifted data-definitions (do not have refined fields)-  deriving (Eq, Data, Typeable, Generic, Show)-  deriving Hashable via Generically DataDeclKind--instance Show SizeFun where-  show IdSizeFun      = "IdSizeFun"-  show (SymSizeFun x) = "SymSizeFun " ++ show (F.val x)--szFun :: SizeFun -> Symbol -> Expr-szFun IdSizeFun      = F.EVar-szFun (SymSizeFun f) = \x -> F.mkEApp (F.symbol <$> f) [F.EVar x]--data HasDataDecl-  = NoDecl  (Maybe SizeFun)-  | HasDecl-  deriving (Show)--instance F.PPrint HasDataDecl where-  pprintTidy _ HasDecl    = text "HasDecl"-  pprintTidy k (NoDecl z) = text "NoDecl" <+> parens (F.pprintTidy k z)--hasDecl :: DataDecl -> HasDataDecl-hasDecl d-  | null (tycDCons d)-  = NoDecl (tycSFun d)-  -- // | Just s <- tycSFun d, null (tycDCons d)-  -- // = NoDecl (Just s)-  | otherwise-  = HasDecl--instance Hashable DataName where-  hashWithSalt i = hashWithSalt i . F.symbol---instance NFData   SizeFun-instance B.Binary SizeFun-instance NFData   DataDeclKind-instance B.Binary DataDeclKind-instance B.Binary DataName-instance B.Binary DataCtor-instance B.Binary DataDecl--instance Eq DataDecl where-  d1 == d2 = tycName d1 == tycName d2--instance Ord DataDecl where-  compare d1 d2 = compare (tycName d1) (tycName d2)--instance F.Loc DataCtor where-  srcSpan = F.srcSpan . dcName--instance F.Loc DataDecl where-  srcSpan = srcSpanFSrcSpan . sourcePosSrcSpan . tycSrcPos--instance F.Loc DataName where-  srcSpan (DnName z) = F.srcSpan z-  srcSpan (DnCon  z) = F.srcSpan z----- | For debugging.-instance Show DataDecl where-  show dd = printf "DataDecl: data = %s, tyvars = %s, sizeFun = %s, kind = %s" -- [at: %s]"-              (show $ tycName   dd)-              (show $ tycTyVars dd)-              (show $ tycSFun   dd)-              (show $ tycKind   dd)---instance Show DataName where-  show (DnName n) =               show (F.val n)-  show (DnCon  c) = "datacon:" ++ show (F.val c)--instance F.PPrint SizeFun where-  pprintTidy _ IdSizeFun      = "[id]"-  pprintTidy _ (SymSizeFun x) = brackets (F.pprint (F.val x))--instance F.Symbolic DataName where-  symbol = F.val . dataNameSymbol--instance F.Symbolic DataDecl where-  symbol = F.symbol . tycName--instance F.PPrint DataName where-  pprintTidy k (DnName n) = F.pprintTidy k (F.val n)-  pprintTidy k (DnCon  n) = F.pprintTidy k (F.val n)--  -- symbol (DnName z) = F.suffixSymbol "DnName" (F.val z)-  -- symbol (DnCon  z) = F.suffixSymbol "DnCon"  (F.val z)--dataNameSymbol :: DataName -> F.LocSymbol-dataNameSymbol (DnName z) = z-dataNameSymbol (DnCon  z) = z------------------------------------------------------------------------------------- | Refinement Type Aliases----------------------------------------------------------------------------------data RTAlias x a = RTA-  { rtName  :: Symbol             -- ^ name of the alias-  , rtTArgs :: [x]                -- ^ type parameters-  , rtVArgs :: [Symbol]           -- ^ value parameters-  , rtBody  :: a                  -- ^ what the alias expands to-  -- , rtMod   :: !ModName           -- ^ module where alias was defined-  } deriving (Eq, Data, Typeable, Generic, Functor)-    deriving Hashable via Generically (RTAlias x a)--- TODO support ghosts in aliases?--instance (B.Binary x, B.Binary a) => B.Binary (RTAlias x a)--mapRTAVars :: (a -> b) -> RTAlias a ty -> RTAlias b ty-mapRTAVars f rt = rt { rtTArgs = f <$> rtTArgs rt }--lmapEAlias :: LMap -> F.Located (RTAlias Symbol Expr)-lmapEAlias (LMap v ys e) = F.atLoc v (RTA (F.val v) [] ys e) -- (F.loc v) (F.loc v)-------------------------------------------------------------------------------------- | Constructor and Destructors for RTypes ----------------------------------------------------------------------------------------------------------------------data RTypeRep c tv r = RTypeRep-  { ty_vars   :: [(RTVar tv (RType c tv ()), r)]-  , ty_preds  :: [PVar (RType c tv ())]-  , ty_ebinds :: [Symbol]-  , ty_einfo  :: [RFInfo]-  , ty_erefts :: [r]-  , ty_eargs  :: [RType c tv r]-  , ty_binds  :: [Symbol]-  , ty_info   :: [RFInfo]-  , ty_refts  :: [r]-  , ty_args   :: [RType c tv r]-  , ty_res    :: RType c tv r-  }--fromRTypeRep :: RTypeRep c tv r -> RType c tv r-fromRTypeRep RTypeRep{..}-  = mkArrow ty_vars ty_preds earrs arrs ty_res-  where-    arrs  = safeZip4WithError ("fromRTypeRep: " ++ show (length ty_binds, length ty_info, length ty_args, length ty_refts)) ty_binds ty_info ty_args ty_refts-    earrs = safeZip4WithError ("fromRTypeRep: " ++ show (length ty_ebinds, length ty_einfo, length ty_eargs, length ty_erefts)) ty_ebinds ty_einfo ty_eargs ty_erefts-----------------------------------------------------------------------------------toRTypeRep           :: RType c tv r -> RTypeRep c tv r----------------------------------------------------------------------------------toRTypeRep t         = RTypeRep αs πs xs' is' rs' ts' xs is rs ts t''-  where-    (αs, πs, t')  = bkUniv  t-    ((xs',is', ts',rs'),(xs, is, ts, rs), t'') = bkArrow t'--mkArrow :: [(RTVar tv (RType c tv ()), r)]-        -> [PVar (RType c tv ())]-        -> [(Symbol, RFInfo, RType c tv r, r)]-        -> [(Symbol, RFInfo, RType c tv r, r)]-        -> RType c tv r-        -> RType c tv r-mkArrow αs πs yts xts = mkUnivs αs πs . mkArrs RImpF yts. mkArrs RFun xts-  where-    mkArrs f xts t  = foldr (\(b,i,t1,r) t2 -> f b i t1 t2 r) t xts---- Do I need to keep track of implicits here too?-bkArrowDeep :: RType t t1 a -> ([Symbol], [RFInfo], [RType t t1 a], [a], RType t t1 a)-bkArrowDeep (RAllT _ t _)   = bkArrowDeep t-bkArrowDeep (RAllP _ t)     = bkArrowDeep t-bkArrowDeep (RImpF x i t t' r)= bkArrowDeep (RFun x i t t' r)-bkArrowDeep (RFun x i t t' r) = let (xs, is, ts, rs, t'') = bkArrowDeep t'  in (x:xs, i:is, t:ts, r:rs, t'')-bkArrowDeep t               = ([], [], [], [], t)--bkArrow :: RType t t1 a -> ( ([Symbol], [RFInfo], [RType t t1 a], [a])-                           , ([Symbol], [RFInfo], [RType t t1 a], [a])-                           , RType t t1 a )-bkArrow t                = ((xs,is,ts,rs),(xs',is',ts',rs'),t'')-  where-    (xs, is, ts, rs, t')     = bkImp t-    (xs', is', ts', rs', t'') = bkFun t'---bkFun :: RType t t1 a -> ([Symbol], [RFInfo], [RType t t1 a], [a], RType t t1 a)-bkFun (RFun x i t t' r) = let (xs, is, ts, rs, t'') = bkFun t'  in (x:xs, i:is, t:ts, r:rs, t'')-bkFun t                 = ([], [], [], [], t)--bkImp :: RType t t1 a -> ([Symbol], [RFInfo], [RType t t1 a], [a], RType t t1 a)-bkImp (RImpF x i t t' r) = let (xs, is, ts, rs, t'') = bkImp t'  in (x:xs, i:is, t:ts, r:rs, t'')-bkImp t                  = ([], [], [], [], t)--safeBkArrow ::(F.PPrint (RType t t1 a))-            => RType t t1 a -> ( ([Symbol], [RFInfo], [RType t t1 a], [a])-                               , ([Symbol], [RFInfo], [RType t t1 a], [a])-                               , RType t t1 a )-safeBkArrow t@RAllT {} = Prelude.error {- panic Nothing -} $ "safeBkArrow on RAllT" ++ F.showpp t-safeBkArrow (RAllP _ _)     = Prelude.error {- panic Nothing -} "safeBkArrow on RAllP"-safeBkArrow t               = bkArrow t--mkUnivs :: (Foldable t, Foldable t1)-        => t  (RTVar tv (RType c tv ()), r)-        -> t1 (PVar (RType c tv ()))-        -> RType c tv r-        -> RType c tv r-mkUnivs αs πs t = foldr (\(a,r) t -> RAllT a t r) (foldr RAllP t πs) αs--bkUnivClass :: SpecType -> ([(SpecRTVar, RReft)],[PVar RSort], [(RTyCon, [SpecType])], SpecType )-bkUnivClass t        = (as, ps, cs, t2)-  where-    (as, ps, t1) = bkUniv  t-    (cs, t2)     = bkClass t1---bkUniv :: RType tv c r -> ([(RTVar c (RType tv c ()), r)], [PVar (RType tv c ())], RType tv c r)-bkUniv (RAllT α t r) = let (αs, πs, t') = bkUniv t in ((α, r):αs, πs, t')-bkUniv (RAllP π t)   = let (αs, πs, t') = bkUniv t in (αs, π:πs, t')-bkUniv t             = ([], [], t)----- bkFun :: RType t t1 a -> ([Symbol], [RType t t1 a], [a], RType t t1 a)--- bkFun (RFun x t t' r) = let (xs, ts, rs, t'') = bkFun t'  in (x:xs, t:ts, r:rs, t'')--- bkFun t               = ([], [], [], t)--bkUnivClass' :: SpecType ->-  ([(SpecRTVar, RReft)], [PVar RSort], [(Symbol, SpecType, RReft)], SpecType)-bkUnivClass' t = (as, ps, zip3 bs ts rs, t2)-  where-    (as, ps, t1) = bkUniv  t-    (bs, ts, rs, t2)     = bkClass' t1--bkClass' :: TyConable t => RType t t1 a -> ([Symbol], [RType t t1 a], [a], RType t t1 a)-bkClass' (RImpF x _ t@(RApp c _ _ _) t' r)-  | isClass c-  = let (xs, ts, rs, t'') = bkClass' t' in (x:xs, t:ts, r:rs, t'')-bkClass' (RFun x _ t@(RApp c _ _ _) t' r)-  | isClass c-  = let (xs, ts, rs, t'') = bkClass' t' in (x:xs, t:ts, r:rs, t'')-bkClass' (RRTy e r o t)-  = let (xs, ts, rs, t'') = bkClass' t in (xs, ts, rs, RRTy e r o t'')-bkClass' t-  = ([], [],[],t)--bkClass :: (F.PPrint c, TyConable c) => RType c tv r -> ([(c, [RType c tv r])], RType c tv r)-bkClass (RImpF _ _ (RApp c t _ _) t' _)-  | isClass c-  = let (cs, t'') = bkClass t' in ((c, t):cs, t'')-bkClass (RFun _ _ (RApp c t _ _) t' _)-  | F.notracepp ("IS-CLASS: " ++ F.showpp c) $ isClass c-  = let (cs, t'') = bkClass t' in ((c, t):cs, t'')-bkClass (RRTy e r o t)-  = let (cs, t') = bkClass t in (cs, RRTy e r o t')-bkClass t-  = ([], t)--rImpF :: Monoid r => Symbol -> RType c tv r -> RType c tv r -> RType c tv r-rImpF b t t' = RImpF b defRFInfo t t' mempty--rFun :: Monoid r => Symbol -> RType c tv r -> RType c tv r -> RType c tv r-rFun b t t' = RFun b defRFInfo t t' mempty--rFun' :: Monoid r => RFInfo -> Symbol -> RType c tv r -> RType c tv r -> RType c tv r-rFun' i b t t' = RFun b i t t' mempty--rFunDebug :: Monoid r => Symbol -> RType c tv r -> RType c tv r -> RType c tv r-rFunDebug b t t' = RFun b (classRFInfo True) t t' mempty--rCls :: Monoid r => TyCon -> [RType RTyCon tv r] -> RType RTyCon tv r-rCls c ts   = RApp (RTyCon c [] defaultTyConInfo) ts [] mempty--rRCls :: Monoid r => c -> [RType c tv r] -> RType c tv r-rRCls rc ts = RApp rc ts [] mempty--addInvCond :: SpecType -> RReft -> SpecType-addInvCond t r'-  | F.isTauto $ ur_reft r' -- null rv-  = t-  | otherwise-  = fromRTypeRep $ trep {ty_res = RRTy [(x', tbd)] r OInv tbd}-  where-    trep = toRTypeRep t-    tbd  = ty_res trep-    r    = r' {ur_reft = F.Reft (v, rx)}-    su   = (v, F.EVar x')-    x'   = "xInv"-    rx   = F.PIff (F.EVar v) $ F.subst1 rv su-    F.Reft(v, rv) = ur_reft r'-----------------------------------------------class F.Reftable r => UReftable r where-  ofUReft :: UReft F.Reft -> r-  ofUReft (MkUReft r _) = F.ofReft r---instance UReftable (UReft F.Reft) where-   ofUReft r = r--instance UReftable () where-   ofUReft _ = mempty--instance (F.PPrint r, F.Reftable r) => F.Reftable (UReft r) where-  isTauto               = isTautoUreft-  ppTy                  = ppTyUreft-  toReft (MkUReft r ps) = F.toReft r `F.meet` F.toReft ps-  params (MkUReft r _)  = F.params r-  bot (MkUReft r _)     = MkUReft (F.bot r) (Pr [])-  top (MkUReft r p)     = MkUReft (F.top r) (F.top p)-  ofReft r              = MkUReft (F.ofReft r) mempty--instance F.Expression (UReft ()) where-  expr = F.expr . F.toReft----isTautoUreft :: F.Reftable r => UReft r -> Bool-isTautoUreft u = F.isTauto (ur_reft u) && F.isTauto (ur_pred u)--ppTyUreft :: F.Reftable r => UReft r -> Doc -> Doc-ppTyUreft u@(MkUReft r p) d-  | isTautoUreft u = d-  | otherwise      = pprReft r (F.ppTy p d)--pprReft :: (F.Reftable r) => r -> Doc -> Doc-pprReft r d = braces (F.pprint v <+> colon <+> d <+> text "|" <+> F.pprint r')-  where-    r'@(F.Reft (v, _)) = F.toReft r--instance F.Subable r => F.Subable (UReft r) where-  syms (MkUReft r p)     = F.syms r ++ F.syms p-  subst s (MkUReft r z)  = MkUReft (F.subst s r)  (F.subst s z)-  substf f (MkUReft r z) = MkUReft (F.substf f r) (F.substf f z)-  substa f (MkUReft r z) = MkUReft (F.substa f r) (F.substa f z)--instance (F.Reftable r, TyConable c) => F.Subable (RTProp c tv r) where-  syms (RProp  ss r)     = (fst <$> ss) ++ F.syms r--  subst su (RProp ss (RHole r)) = RProp ss (RHole (F.subst su r))-  subst su (RProp  ss t) = RProp ss (F.subst su <$> t)--  substf f (RProp ss (RHole r)) = RProp ss (RHole (F.substf f r))-  substf f (RProp  ss t) = RProp ss (F.substf f <$> t)--  substa f (RProp ss (RHole r)) = RProp ss (RHole (F.substa f r))-  substa f (RProp  ss t) = RProp ss (F.substa f <$> t)---instance (F.Subable r, F.Reftable r, TyConable c) => F.Subable (RType c tv r) where-  syms        = foldReft False (\_ r acc -> F.syms r ++ acc) []-  -- 'substa' will substitute bound vars-  substa f    = emapExprArg (\_ -> F.substa f) []      . mapReft  (F.substa f)-  -- 'substf' will NOT substitute bound vars-  substf f    = emapExprArg (\_ -> F.substf f) []      . emapReft (F.substf . F.substfExcept f) []-  subst su    = emapExprArg (\_ -> F.subst su) []      . emapReft (F.subst  . F.substExcept su) []-  subst1 t su = emapExprArg (\_ e -> F.subst1 e su) [] $ emapReft (\xs r -> F.subst1Except xs r su) [] t---instance F.Reftable Predicate where-  isTauto (Pr ps)      = null ps--  bot (Pr _)           = panic Nothing "No BOT instance for Predicate"-  ppTy r d | F.isTauto r      = d-           | not (ppPs ppEnv) = d-           | otherwise        = d <-> angleBrackets (F.pprint r)--  toReft (Pr ps@(p:_))        = F.Reft (parg p, F.pAnd $ pToRef <$> ps)-  toReft _                    = mempty-  params                      = todo Nothing "TODO: instance of params for Predicate"--  ofReft = todo Nothing "TODO: Predicate.ofReft"--pToRef :: PVar a -> F.Expr-pToRef p = pApp (pname p) $ F.EVar (parg p) : (thd3 <$> pargs p)--pApp      :: Symbol -> [Expr] -> Expr-pApp p es = F.mkEApp fn (F.EVar p:es)-  where-    fn    = F.dummyLoc (pappSym n)-    n     = length es--pappSym :: Show a => a -> Symbol-pappSym n  = F.symbol $ "papp" ++ show n------------------------------------------------------------------------------------- | Visitors ----------------------------------------------------------------------------------------------------------------------------------------------------mapExprReft :: (Symbol -> Expr -> Expr) -> RType c tv RReft -> RType c tv RReft-mapExprReft f = mapReft g-  where-    g (MkUReft (F.Reft (x, e)) p) = MkUReft (F.Reft (x, f x e)) p---- const False (not dropping dict) is probably fine since there will not be refinement on--- dictionaries-isTrivial :: (F.Reftable r, TyConable c) => RType c tv r -> Bool-isTrivial = foldReft False (\_ r b -> F.isTauto r && b) True--mapReft ::  (r1 -> r2) -> RType c tv r1 -> RType c tv r2-mapReft f = emapReft (const f) []--emapReft ::  ([Symbol] -> r1 -> r2) -> [Symbol] -> RType c tv r1 -> RType c tv r2-emapReft f γ (RVar α r)          = RVar  α (f γ r)-emapReft f γ (RAllT α t r)       = RAllT α (emapReft f γ t) (f γ r)-emapReft f γ (RAllP π t)         = RAllP π (emapReft f γ t)-emapReft f γ (RImpF x i t t' r)  = RImpF x i (emapReft f γ t) (emapReft f (x:γ) t') (f (x:γ) r)-emapReft f γ (RFun x i t t' r)   = RFun  x i (emapReft f γ t) (emapReft f (x:γ) t') (f (x:γ) r)-emapReft f γ (RApp c ts rs r)    = RApp  c (emapReft f γ <$> ts) (emapRef f γ <$> rs) (f γ r)-emapReft f γ (RAllE z t t')      = RAllE z (emapReft f γ t) (emapReft f γ t')-emapReft f γ (REx z t t')        = REx   z (emapReft f γ t) (emapReft f γ t')-emapReft _ _ (RExprArg e)        = RExprArg e-emapReft f γ (RAppTy t t' r)     = RAppTy (emapReft f γ t) (emapReft f γ t') (f γ r)-emapReft f γ (RRTy e r o t)      = RRTy  (mapSnd (emapReft f γ) <$> e) (f γ r) o (emapReft f γ t)-emapReft f γ (RHole r)           = RHole (f γ r)--emapRef :: ([Symbol] -> t -> s) ->  [Symbol] -> RTProp c tv t -> RTProp c tv s-emapRef  f γ (RProp s (RHole r))  = RProp s $ RHole (f γ r)-emapRef  f γ (RProp s t)         = RProp s $ emapReft f γ t--emapExprArg :: ([Symbol] -> Expr -> Expr) -> [Symbol] -> RType c tv r -> RType c tv r-emapExprArg f = go-  where-    go _ t@RVar{}           = t-    go _ t@RHole{}          = t-    go γ (RAllT α t r)      = RAllT α (go γ t) r-    go γ (RAllP π t)        = RAllP π (go γ t)-    go γ (RImpF x i t t' r) = RImpF x i (go γ t) (go (x:γ) t') r-    go γ (RFun x i t t' r)  = RFun  x i (go γ t) (go (x:γ) t') r-    go γ (RApp c ts rs r)   = RApp  c (go γ <$> ts) (mo γ <$> rs) r-    go γ (RAllE z t t')     = RAllE z (go γ t) (go γ t')-    go γ (REx z t t')       = REx   z (go γ t) (go γ t')-    go γ (RExprArg e)       = RExprArg (f γ <$> F.notracepp "RExprArg" e) -- <---- actual substitution-    go γ (RAppTy t t' r)    = RAppTy (go γ t) (go γ t') r-    go γ (RRTy e r o t)     = RRTy  (mapSnd (go γ) <$> e) r o (go γ t)-    mo _ t@(RProp _ RHole{}) = t-    mo γ (RProp s t)        = RProp s (go γ t)--foldRType :: (acc -> RType c tv r -> acc) -> acc -> RType c tv r -> acc-foldRType f = go-  where-    step a t                = go (f a t) t-    prep a (RProp _ RHole{}) = a-    prep a (RProp _ t)      = step a t-    go a RVar{}             = a-    go a RHole{}            = a-    go a RExprArg{}         = a-    go a (RAllT _ t _)      = step a t-    go a (RAllP _ t)        = step a t-    go a (RImpF _ _ t t' _) = foldl' step a [t, t']-    go a (RFun _ _ t t' _)  = foldl' step a [t, t']-    go a (RAllE _ t t')     = foldl' step a [t, t']-    go a (REx _ t t')       = foldl' step a [t, t']-    go a (RAppTy t t' _)    = foldl' step a [t, t']-    go a (RApp _ ts rs _)   = foldl' prep (foldl' step a ts) rs-    go a (RRTy e _ _ t)     = foldl' step a (t : (snd <$> e))----------------------------------------------------------------------------------------------------------- isBase' x t = traceShow ("isBase: " ++ showpp x) $ isBase t--- same as GhcMisc isBaseType---- isBase :: RType a -> Bool---- set all types to basic types, haskell `tx -> t` is translated to Arrow tx t--- isBase _ = True--isBase :: RType t t1 t2 -> Bool-isBase (RAllT _ t _)    = isBase t-isBase (RAllP _ t)      = isBase t-isBase (RVar _ _)       = True-isBase (RApp _ ts _ _)  = all isBase ts-isBase RImpF{}          = False-isBase RFun{}           = False-isBase (RAppTy t1 t2 _) = isBase t1 && isBase t2-isBase (RRTy _ _ _ t)   = isBase t-isBase (RAllE _ _ t)    = isBase t-isBase (REx _ _ t)      = isBase t-isBase _                = False--hasHoleTy :: RType t t1 t2 -> Bool-hasHoleTy (RVar _ _)       = False-hasHoleTy (RAllT _ t _)    = hasHoleTy t-hasHoleTy (RAllP _ t)      = hasHoleTy t-hasHoleTy (RImpF _ _ t t' _) = hasHoleTy t || hasHoleTy t'-hasHoleTy (RFun _ _ t t' _)  = hasHoleTy t || hasHoleTy t'-hasHoleTy (RApp _ ts _ _)  = any hasHoleTy ts-hasHoleTy (RAllE _ t t')   = hasHoleTy t || hasHoleTy t'-hasHoleTy (REx _ t t')     = hasHoleTy t || hasHoleTy t'-hasHoleTy (RExprArg _)     = False-hasHoleTy (RAppTy t t' _)  = hasHoleTy t || hasHoleTy t'-hasHoleTy (RHole _)        = True-hasHoleTy (RRTy xts _ _ t) = hasHoleTy t || any hasHoleTy (snd <$> xts)----isFunTy :: RType t t1 t2 -> Bool-isFunTy (RAllE _ _ t)    = isFunTy t-isFunTy (RAllT _ t _)    = isFunTy t-isFunTy (RAllP _ t)      = isFunTy t-isFunTy RImpF{}          = True-isFunTy RFun{}           = True-isFunTy _                = False---mapReftM :: (Monad m) => (r1 -> m r2) -> RType c tv r1 -> m (RType c tv r2)-mapReftM f (RVar α r)         = fmap    (RVar  α)   (f r)-mapReftM f (RAllT α t r)      = liftM2  (RAllT α)   (mapReftM f t)          (f r)-mapReftM f (RAllP π t)        = fmap    (RAllP π)   (mapReftM f t)-mapReftM f (RImpF x i t t' r) = liftM3  (RImpF x i) (mapReftM f t)          (mapReftM f t')       (f r)-mapReftM f (RFun x i t t' r)  = liftM3  (RFun x i)  (mapReftM f t)          (mapReftM f t')       (f r)-mapReftM f (RApp c ts rs r)   = liftM3  (RApp  c)   (mapM (mapReftM f) ts)  (mapM (mapRefM f) rs) (f r)-mapReftM f (RAllE z t t')     = liftM2  (RAllE z)   (mapReftM f t)          (mapReftM f t')-mapReftM f (REx z t t')       = liftM2  (REx z)     (mapReftM f t)          (mapReftM f t')-mapReftM _ (RExprArg e)       = return  $ RExprArg e-mapReftM f (RAppTy t t' r)    = liftM3  RAppTy (mapReftM f t) (mapReftM f t') (f r)-mapReftM f (RHole r)          = fmap    RHole       (f r)-mapReftM f (RRTy xts r o t)   = liftM4  RRTy (mapM (mapSndM (mapReftM f)) xts) (f r) (return o) (mapReftM f t)--mapRefM  :: (Monad m) => (t -> m s) -> RTProp c tv t -> m (RTProp c tv s)-mapRefM  f (RProp s t)        = fmap    (RProp s)      (mapReftM f t)--mapPropM :: (Monad m) => (RTProp c tv r -> m (RTProp c tv r)) -> RType c tv r -> m (RType c tv r)-mapPropM _ (RVar α r)         = return $ RVar  α r-mapPropM f (RAllT α t r)      = liftM2  (RAllT α)   (mapPropM f t)          (return r)-mapPropM f (RAllP π t)        = fmap    (RAllP π)   (mapPropM f t)-mapPropM f (RImpF x i t t' r) = liftM3  (RImpF x i)    (mapPropM f t)         (mapPropM f t') (return r)-mapPropM f (RFun x i t t' r)  = liftM3  (RFun x i)    (mapPropM f t)          (mapPropM f t') (return r)-mapPropM f (RApp c ts rs r)   = liftM3  (RApp  c)   (mapM (mapPropM f) ts)  (mapM f rs)     (return r)-mapPropM f (RAllE z t t')     = liftM2  (RAllE z)   (mapPropM f t)          (mapPropM f t')-mapPropM f (REx z t t')       = liftM2  (REx z)     (mapPropM f t)          (mapPropM f t')-mapPropM _ (RExprArg e)       = return  $ RExprArg e-mapPropM f (RAppTy t t' r)    = liftM3  RAppTy (mapPropM f t) (mapPropM f t') (return r)-mapPropM _ (RHole r)          = return $ RHole r-mapPropM f (RRTy xts r o t)   = liftM4  RRTy (mapM (mapSndM (mapPropM f)) xts) (return r) (return o) (mapPropM f t)-------------------------------------------------------------------------------------- foldReft :: (F.Reftable r, TyConable c) => (r -> a -> a) -> a -> RType c tv r -> a------------------------------------------------------------------------------------ foldReft f = efoldReft (\_ _ -> []) (\_ -> ()) (\_ _ -> f) (\_ γ -> γ) emptyF.SEnv-----------------------------------------------------------------------------------foldReft :: (F.Reftable r, TyConable c) => BScope -> (F.SEnv (RType c tv r) -> r -> a -> a) -> a -> RType c tv r -> a----------------------------------------------------------------------------------foldReft bsc f = foldReft'  (\_ _ -> False) bsc id (\γ _ -> f γ)-----------------------------------------------------------------------------------foldReft' :: (F.Reftable r, TyConable c)-          => (Symbol -> RType c tv r -> Bool)-          -> BScope-          -> (RType c tv r -> b)-          -> (F.SEnv b -> Maybe (RType c tv r) -> r -> a -> a)-          -> a -> RType c tv r -> a----------------------------------------------------------------------------------foldReft' logicBind bsc g f-  = efoldReft logicBind bsc-              (\_ _ -> [])-              (const [])-              g-              (\γ t r z -> f γ t r z)-              (\_ γ -> γ)-              F.emptySEnv------ efoldReft :: F.Reftable r =>(p -> [RType c tv r] -> [(Symbol, a)])-> (RType c tv r -> a)-> (SEnv a -> Maybe (RType c tv r) -> r -> c1 -> c1)-> SEnv a-> c1-> RType c tv r-> c1-efoldReft :: (F.Reftable r, TyConable c)-          => (Symbol -> RType c tv r -> Bool)-          -> BScope-          -> (c  -> [RType c tv r] -> [(Symbol, a)])-          -> (RTVar tv (RType c tv ()) -> [(Symbol, a)])-          -> (RType c tv r -> a)-          -> (F.SEnv a -> Maybe (RType c tv r) -> r -> b -> b)-          -> (PVar (RType c tv ()) -> F.SEnv a -> F.SEnv a)-          -> F.SEnv a-          -> b-          -> RType c tv r-          -> b-efoldReft logicBind bsc cb dty g f fp = go-  where-    -- folding over RType-    go γ z me@(RVar _ r)                = f γ (Just me) r z-    go γ z me@(RAllT a t r)-       | tyVarIsVal a                   = f γ (Just me) r (go (insertsSEnv γ (dty a)) z t)-       | otherwise                      = f γ (Just me) r (go γ z t)-    go γ z (RAllP p t)                  = go (fp p γ) z t-    go γ z (RImpF x i t t' r)           = go γ z (RFun x i t t' r)-    go γ z me@(RFun _ RFInfo{permitTC = permitTC} (RApp c ts _ _) t' r)-       | (if permitTC == Just True then isEmbeddedDict else isClass)-         c  = f γ (Just me) r (go (insertsSEnv γ (cb c ts)) (go' γ z ts) t')-    go γ z me@(RFun x _ t t' r)-       | logicBind x t                  = f γ (Just me) r (go γ' (go γ z t) t')-       | otherwise                      = f γ (Just me) r (go γ  (go γ z t) t')-       where-         γ'                             = insertSEnv x (g t) γ-    go γ z me@(RApp _ ts rs r)          = f γ (Just me) r (ho' γ (go' γ' z ts) rs)-       where γ' = if bsc then insertSEnv (rTypeValueVar me) (g me) γ else γ--    go γ z (RAllE x t t')               = go (insertSEnv x (g t) γ) (go γ z t) t'-    go γ z (REx x t t')                 = go (insertSEnv x (g t) γ) (go γ z t) t'-    go γ z me@(RRTy [] r _ t)           = f γ (Just me) r (go γ z t)-    go γ z me@(RRTy xts r _ t)          = f γ (Just me) r (go γ (go γ z (envtoType xts)) t)-    go γ z me@(RAppTy t t' r)           = f γ (Just me) r (go γ (go γ z t) t')-    go _ z (RExprArg _)                 = z-    go γ z me@(RHole r)                 = f γ (Just me) r z--    -- folding over Ref-    ho  γ z (RProp ss (RHole r))       = f (insertsSEnv γ (mapSnd (g . ofRSort) <$> ss)) Nothing r z-    ho  γ z (RProp ss t)               = go (insertsSEnv γ (mapSnd (g . ofRSort) <$> ss)) z t--    -- folding over [RType]-    go' γ z ts                 = foldr (flip $ go γ) z ts--    -- folding over [Ref]-    ho' γ z rs                 = foldr (flip $ ho γ) z rs--    envtoType xts = foldr (\(x,t1) t2 -> rFun x t1 t2) (snd $ last xts) (init xts)--mapRFInfo :: (RFInfo -> RFInfo) -> RType c tv r -> RType c tv r-mapRFInfo f (RAllT α t r)     = RAllT α (mapRFInfo f t) r-mapRFInfo f (RAllP π t)       = RAllP π (mapRFInfo f t)-mapRFInfo f (RImpF x i t t' r) = RImpF x (f i) (mapRFInfo f t) (mapRFInfo f t') r-mapRFInfo f (RFun x i t t' r)  = RFun x (f i) (mapRFInfo f t) (mapRFInfo f t') r-mapRFInfo f (RAppTy t t' r)   = RAppTy (mapRFInfo f t) (mapRFInfo f t') r-mapRFInfo f (RApp c ts rs r)  = RApp c (mapRFInfo f <$> ts) (mapRFInfoRef f <$> rs) r-mapRFInfo f (REx b t1 t2)     = REx b  (mapRFInfo f t1) (mapRFInfo f t2)-mapRFInfo f (RAllE b t1 t2)   = RAllE b  (mapRFInfo f t1) (mapRFInfo f t2)-mapRFInfo f (RRTy e r o t)    = RRTy (mapSnd (mapRFInfo f) <$> e) r o (mapRFInfo f t)-mapRFInfo _ t'                = t'--mapRFInfoRef :: (RFInfo -> RFInfo)-          -> Ref τ (RType c tv r) -> Ref τ (RType c tv r)-mapRFInfoRef _ (RProp s (RHole r)) = RProp s $ RHole r-mapRFInfoRef f (RProp s t)    = RProp  s $ mapRFInfo f t--mapBot :: (RType c tv r -> RType c tv r) -> RType c tv r -> RType c tv r-mapBot f (RAllT α t r)     = RAllT α (mapBot f t) r-mapBot f (RAllP π t)       = RAllP π (mapBot f t)-mapBot f (RImpF x i t t' r) = RImpF x i (mapBot f t) (mapBot f t') r-mapBot f (RFun x i t t' r)  = RFun x i (mapBot f t) (mapBot f t') r-mapBot f (RAppTy t t' r)   = RAppTy (mapBot f t) (mapBot f t') r-mapBot f (RApp c ts rs r)  = f $ RApp c (mapBot f <$> ts) (mapBotRef f <$> rs) r-mapBot f (REx b t1 t2)     = REx b  (mapBot f t1) (mapBot f t2)-mapBot f (RAllE b t1 t2)   = RAllE b  (mapBot f t1) (mapBot f t2)-mapBot f (RRTy e r o t)    = RRTy (mapSnd (mapBot f) <$> e) r o (mapBot f t)-mapBot f t'                = f t'--mapBotRef :: (RType c tv r -> RType c tv r)-          -> Ref τ (RType c tv r) -> Ref τ (RType c tv r)-mapBotRef _ (RProp s (RHole r)) = RProp s $ RHole r-mapBotRef f (RProp s t)    = RProp  s $ mapBot f t--mapBind :: (Symbol -> Symbol) -> RType c tv r -> RType c tv r-mapBind f (RAllT α t r)    = RAllT α (mapBind f t) r-mapBind f (RAllP π t)      = RAllP π (mapBind f t)-mapBind f (RImpF b i t1 t2 r)= RImpF (f b) i (mapBind f t1) (mapBind f t2) r-mapBind f (RFun b i t1 t2 r) = RFun (f b) i (mapBind f t1) (mapBind f t2) r-mapBind f (RApp c ts rs r) = RApp c (mapBind f <$> ts) (mapBindRef f <$> rs) r-mapBind f (RAllE b t1 t2)  = RAllE  (f b) (mapBind f t1) (mapBind f t2)-mapBind f (REx b t1 t2)    = REx    (f b) (mapBind f t1) (mapBind f t2)-mapBind _ (RVar α r)       = RVar α r-mapBind _ (RHole r)        = RHole r-mapBind f (RRTy e r o t)   = RRTy e r o (mapBind f t)-mapBind _ (RExprArg e)     = RExprArg e-mapBind f (RAppTy t t' r)  = RAppTy (mapBind f t) (mapBind f t') r--mapBindRef :: (Symbol -> Symbol)-           -> Ref τ (RType c tv r) -> Ref τ (RType c tv r)-mapBindRef f (RProp s (RHole r)) = RProp (mapFst f <$> s) (RHole r)-mapBindRef f (RProp s t)         = RProp (mapFst f <$> s) $ mapBind f t------------------------------------------------------ofRSort ::  F.Reftable r => RType c tv () -> RType c tv r-ofRSort = fmap mempty--toRSort :: RType c tv r -> RType c tv ()-toRSort = stripAnnotations . mapBind (const F.dummySymbol) . void--stripAnnotations :: RType c tv r -> RType c tv r-stripAnnotations (RAllT α t r)    = RAllT α (stripAnnotations t) r-stripAnnotations (RAllP _ t)      = stripAnnotations t-stripAnnotations (RAllE _ _ t)    = stripAnnotations t-stripAnnotations (REx _ _ t)      = stripAnnotations t-stripAnnotations (RImpF x i t t' r) = RImpF x i (stripAnnotations t) (stripAnnotations t') r-stripAnnotations (RFun x i t t' r)  = RFun x i (stripAnnotations t) (stripAnnotations t') r-stripAnnotations (RAppTy t t' r)  = RAppTy (stripAnnotations t) (stripAnnotations t') r-stripAnnotations (RApp c ts rs r) = RApp c (stripAnnotations <$> ts) (stripAnnotationsRef <$> rs) r-stripAnnotations (RRTy _ _ _ t)   = stripAnnotations t-stripAnnotations t                = t--stripAnnotationsRef :: Ref τ (RType c tv r) -> Ref τ (RType c tv r)-stripAnnotationsRef (RProp s (RHole r)) = RProp s (RHole r)-stripAnnotationsRef (RProp s t)         = RProp s $ stripAnnotations t--insertSEnv :: F.Symbol -> a -> F.SEnv a -> F.SEnv a-insertSEnv = F.insertSEnv--insertsSEnv :: F.SEnv a -> [(Symbol, a)] -> F.SEnv a-insertsSEnv  = foldr (\(x, t) γ -> insertSEnv x t γ)--rTypeValueVar :: (F.Reftable r) => RType c tv r -> Symbol-rTypeValueVar t = vv where F.Reft (vv,_) =  rTypeReft t--rTypeReft :: (F.Reftable r) => RType c tv r -> F.Reft-rTypeReft = maybe F.trueReft F.toReft . stripRTypeBase---- stripRTypeBase ::  RType a -> Maybe a-stripRTypeBase :: RType c tv r -> Maybe r-stripRTypeBase (RApp _ _ _ x)-  = Just x-stripRTypeBase (RVar _ x)-  = Just x-stripRTypeBase (RImpF _ _ _ _ x)-  = Just x-stripRTypeBase (RFun _ _ _ _ x)-  = Just x-stripRTypeBase (RAppTy _ _ x)-  = Just x-stripRTypeBase (RAllT _ _ x)-  = Just x-stripRTypeBase _-  = Nothing--topRTypeBase :: (F.Reftable r) => RType c tv r -> RType c tv r-topRTypeBase = mapRBase F.top--mapRBase :: (r -> r) -> RType c tv r -> RType c tv r-mapRBase f (RApp c ts rs r) = RApp c ts rs $ f r-mapRBase f (RVar a r)       = RVar a $ f r-mapRBase f (RImpF x i t1 t2 r)= RImpF x i t1 t2 $ f r-mapRBase f (RFun x i t1 t2 r) = RFun x i t1 t2 $ f r-mapRBase f (RAppTy t1 t2 r) = RAppTy t1 t2 $ f r-mapRBase _ t                = t---------------------------------------------------------------------------------- | F.PPrint -------------------------------------------------------------------------------------------------------------------------------------------------instance F.PPrint (PVar a) where-  pprintTidy _ = pprPvar--pprPvar :: PVar a -> Doc-pprPvar (PV s _ _ xts) = F.pprint s <+> hsep (F.pprint <$> dargs xts)-  where-    dargs              = map thd3 . takeWhile (\(_, x, y) -> F.EVar x /= y)---instance F.PPrint Predicate where-  pprintTidy _ (Pr [])  = text "True"-  pprintTidy k (Pr pvs) = hsep $ punctuate (text "&") (F.pprintTidy k <$> pvs)----- | The type used during constraint generation, used---   also to define contexts for errors, hence in this---   file, and NOT in elsewhere. **DO NOT ATTEMPT TO MOVE**---   Am splitting into---   + global : many bindings, shared across all constraints---   + local  : few bindings, relevant to particular constraints--type REnv = AREnv SpecType--data AREnv t = REnv-  { reGlobal :: M.HashMap Symbol t -- ^ the "global" names for module-  , reLocal  :: M.HashMap Symbol t -- ^ the "local" names for sub-exprs-  }--instance Functor AREnv where-  fmap f (REnv g l) = REnv (fmap f g) (fmap f l)--instance (F.PPrint t) => F.PPrint (AREnv t) where-  pprintTidy k re =-    "RENV LOCAL"-    $+$-    ""-    $+$-    F.pprintTidy k (reLocal re)-    $+$-    ""-    $+$-    "RENV GLOBAL"-    $+$-    ""-    $+$-    F.pprintTidy k (reGlobal re)--instance Semigroup REnv where-  REnv g1 l1 <> REnv g2 l2 = REnv (g1 <> g2) (l1 <> l2)--instance Monoid REnv where-  mempty = REnv mempty mempty--instance NFData REnv where-  rnf REnv{} = ()------------------------------------------------------------------------------------- | Diagnostic info ----------------------------------------------------------------------------------------------------------------------------------------------data Warning = Warning {-    warnSpan :: SrcSpan-  , warnDoc  :: Doc-  } deriving (Eq, Show)--mkWarning :: SrcSpan -> Doc -> Warning-mkWarning = Warning--data Diagnostics = Diagnostics {-    dWarnings :: [Warning]-  , dErrors   :: [Error]-  } deriving Eq--instance Semigroup Diagnostics where-  (Diagnostics w1 e1) <> (Diagnostics w2 e2) = Diagnostics (w1 <> w2) (e1 <> e2)--instance Monoid Diagnostics where-  mempty  = emptyDiagnostics-  mappend = (<>)--mkDiagnostics :: [Warning] -> [Error] -> Diagnostics-mkDiagnostics = Diagnostics--emptyDiagnostics :: Diagnostics-emptyDiagnostics = Diagnostics mempty mempty--noErrors :: Diagnostics -> Bool-noErrors = L.null . dErrors--allWarnings :: Diagnostics -> [Warning]-allWarnings = dWarnings--allErrors :: Diagnostics -> [Error]-allErrors = dErrors------------------------------------------------------------------------------------- | Printing Warnings --------------------------------------------------------------------------------------------------------------------------------------------printWarning :: DynFlags -> Warning -> IO ()-printWarning dyn (Warning span doc) = GHC.putWarnMsg dyn span doc------------------------------------------------------------------------------------- | Error Data Type ----------------------------------------------------------------------------------------------------------------------------------------------type ErrorResult    = F.FixResult UserError-type Error          = TError SpecType---instance NFData a => NFData (TError a)------------------------------------------------------------------------------------- | Source Information Associated With Constraints ---------------------------------------------------------------------------------------------------------------data Cinfo    = Ci-  { ci_loc :: !SrcSpan-  , ci_err :: !(Maybe Error)-  , ci_var :: !(Maybe Var)-  }-  deriving (Eq, Generic)--instance F.Loc Cinfo where-  srcSpan = srcSpanFSrcSpan . ci_loc--instance NFData Cinfo------------------------------------------------------------------------------------- | Module Names -------------------------------------------------------------------------------------------------------------------------------------------------data ModName = ModName !ModType !ModuleName-  deriving (Eq, Ord, Show, Generic, Data, Typeable)--data ModType = Target | SrcImport | SpecImport-  deriving (Eq, Ord, Show, Generic, Data, Typeable)---- instance B.Binary ModType--- instance B.Binary ModName--instance Hashable ModType--instance Hashable ModName where-  hashWithSalt i (ModName t n) = hashWithSalt i (t, show n)--instance F.PPrint ModName where-  pprintTidy _ = text . show--instance F.Symbolic ModName where-  symbol (ModName _ m) = F.symbol m--instance F.Symbolic ModuleName where-  symbol = F.symbol . moduleNameFS---isTarget :: ModName -> Bool-isTarget (ModName Target _) = True-isTarget _                  = False--isSrcImport :: ModName -> Bool-isSrcImport (ModName SrcImport _) = True-isSrcImport _                     = False--isSpecImport :: ModName -> Bool-isSpecImport (ModName SpecImport _) = True-isSpecImport _                      = False--getModName :: ModName -> ModuleName-getModName (ModName _ m) = m--getModString :: ModName -> String-getModString = moduleNameString . getModName--qualifyModName :: ModName -> Symbol -> Symbol-qualifyModName n = qualifySymbol nSym-  where-    nSym         = F.symbol n------------------------------------------------------------------------------------- | Refinement Type Aliases -------------------------------------------------------------------------------------------------------------------------------------data RTEnv tv t = RTE-  { typeAliases :: M.HashMap Symbol (F.Located (RTAlias tv t))-  , exprAliases :: M.HashMap Symbol (F.Located (RTAlias Symbol Expr))-  }---instance Monoid (RTEnv tv t) where-  mempty  = RTE M.empty M.empty-  mappend = (<>)--instance Semigroup (RTEnv tv t) where-  RTE x y <> RTE x' y' = RTE (x `M.union` x') (y `M.union` y')---- mapRT :: (M.HashMap Symbol (RTAlias tv t) -> M.HashMap Symbol (RTAlias tv t))---      -> RTEnv tv t -> RTEnv tv t--- mapRT f e = e { typeAliases = f (typeAliases e) }---- mapRE :: (M.HashMap Symbol (RTAlias Symbol Expr)---       -> M.HashMap Symbol (RTAlias Symbol Expr))---      -> RTEnv tv t -> RTEnv tv t--- mapRE f e = e { exprAliases = f $ exprAliases e }-------------------------------------------------------------------------------------- | Measures----------------------------------------------------------------------------------data Body-  = E Expr          -- ^ Measure Refinement: {v | v = e }-  | P Expr          -- ^ Measure Refinement: {v | (? v) <=> p }-  | R Symbol Expr   -- ^ Measure Refinement: {v | p}-  deriving (Show, Data, Typeable, Generic, Eq)-  deriving Hashable via Generically Body--data Def ty ctor = Def-  { measure :: F.LocSymbol-  , ctor    :: ctor-  , dsort   :: Maybe ty-  , binds   :: [(Symbol, Maybe ty)]    -- measure binders: the ADT argument fields-  , body    :: Body-  } deriving (Show, Data, Typeable, Generic, Eq, Functor)-    deriving Hashable via Generically (Def ty ctor)--data Measure ty ctor = M-  { msName :: F.LocSymbol-  , msSort :: ty-  , msEqns :: [Def ty ctor]-  , msKind :: !MeasureKind-  , msUnSorted :: !UnSortedExprs -- potential unsorted expressions used at measure denifinitions-  } deriving (Eq, Data, Typeable, Generic, Functor)-    deriving Hashable via Generically (Measure ty ctor)--type UnSortedExprs = [UnSortedExpr] -- mempty = []-type UnSortedExpr  = ([F.Symbol], F.Expr)--data MeasureKind-  = MsReflect     -- ^ due to `reflect foo`-  | MsMeasure     -- ^ due to `measure foo` with old-style (non-haskell) equations-  | MsLifted      -- ^ due to `measure foo` with new-style haskell equations-  | MsClass       -- ^ due to `class measure` definition-  | MsAbsMeasure  -- ^ due to `measure foo` without equations c.f. tests/pos/T1223.hs-  | MsSelector    -- ^ due to selector-fields e.g. `data Foo = Foo { fld :: Int }`-  | MsChecker     -- ^ due to checkers  e.g. `is-F` for `data Foo = F ... | G ...`-  deriving (Eq, Ord, Show, Data, Typeable, Generic)-  deriving Hashable via Generically MeasureKind--instance F.Loc (Measure a b) where-  srcSpan = F.srcSpan . msName--instance Bifunctor Def where-  -- first f  (Def m ps c s bs b) = Def m (second f <$> ps) c (f <$> s) ((second (fmap f)) <$> bs) b-  -- second f (Def m ps c s bs b) = Def m ps (f c) s bs b-  first f  (Def m c s bs b) = Def m c (f <$> s) (second (fmap f) <$> bs) b-  second f (Def m c s bs b) = Def m (f c) s bs b---instance Bifunctor Measure where-  first  f (M n s es k u) = M n (f s) (first f <$> es) k u-  second f (M n s es k u) = M n s (second f <$> es)    k u--instance                             B.Binary MeasureKind-instance                             B.Binary Body-instance (B.Binary t, B.Binary c) => B.Binary (Def     t c)-instance (B.Binary t, B.Binary c) => B.Binary (Measure t c)---- NOTE: don't use the TH versions since they seem to cause issues--- building on windows :(--- deriveBifunctor ''Def--- deriveBifunctor ''Measure--data CMeasure ty = CM-  { cName :: F.LocSymbol-  , cSort :: ty-  } deriving (Data, Typeable, Generic, Functor)--instance F.PPrint Body where-  pprintTidy k (E e)   = F.pprintTidy k e-  pprintTidy k (P p)   = F.pprintTidy k p-  pprintTidy k (R v p) = braces (F.pprintTidy k v <+> "|" <+> F.pprintTidy k p)--instance F.PPrint a => F.PPrint (Def t a) where-  pprintTidy k (Def m c _ bs body)-           = F.pprintTidy k m <+> cbsd <+> "=" <+> F.pprintTidy k body-    where-      cbsd = parens (F.pprintTidy k c <-> hsep (F.pprintTidy k `fmap` (fst <$> bs)))--instance (F.PPrint t, F.PPrint a) => F.PPrint (Measure t a) where-  pprintTidy k (M n s eqs _ _) =  F.pprintTidy k n <+> {- parens (pprintTidy k (loc n)) <+> -} "::" <+> F.pprintTidy k s-                                  $$ vcat (F.pprintTidy k `fmap` eqs)---instance F.PPrint (Measure t a) => Show (Measure t a) where-  show = F.showpp--instance F.PPrint t => F.PPrint (CMeasure t) where-  pprintTidy k (CM n s) =  F.pprintTidy k n <+> "::" <+> F.pprintTidy k s--instance F.PPrint (CMeasure t) => Show (CMeasure t) where-  show = F.showpp---instance F.Subable (Measure ty ctor) where-  syms  m     = concatMap F.syms (msEqns m)-  substa f m  = m { msEqns = F.substa f  <$> msEqns m }-  substf f m  = m { msEqns = F.substf f  <$> msEqns m }-  subst  su m = m { msEqns = F.subst  su <$> msEqns m }-  -- substa f  (M n s es _) = M n s (F.substa f  <$> es) k-  -- substf f  (M n s es _) = M n s $ F.substf f  <$> es-  -- subst  su (M n s es _) = M n s $ F.subst  su <$> es--instance F.Subable (Def ty ctor) where-  syms (Def _ _ _ sb bd)  = (fst <$> sb) ++ F.syms bd-  substa f  (Def m c t b bd) = Def m c t b $ F.substa f  bd-  substf f  (Def m c t b bd) = Def m c t b $ F.substf f  bd-  subst  su (Def m c t b bd) = Def m c t b $ F.subst  su bd--instance F.Subable Body where-  syms (E e)       = F.syms e-  syms (P e)       = F.syms e-  syms (R s e)     = s : F.syms e--  substa f (E e)   = E   (F.substa f e)-  substa f (P e)   = P   (F.substa f e)-  substa f (R s e) = R s (F.substa f e)--  substf f (E e)   = E   (F.substf f e)-  substf f (P e)   = P   (F.substf f e)-  substf f (R s e) = R s (F.substf f e)--  subst su (E e)   = E   (F.subst su e)-  subst su (P e)   = P   (F.subst su e)-  subst su (R s e) = R s (F.subst su e)--instance F.Subable t => F.Subable (WithModel t) where-  syms (NoModel t)     = F.syms t-  syms (WithModel _ t) = F.syms t-  substa f             = fmap (F.substa f)-  substf f             = fmap (F.substf f)-  subst su             = fmap (F.subst su)--data RClass ty = RClass-  { rcName    :: BTyCon-  , rcSupers  :: [ty]-  , rcTyVars  :: [BTyVar]-  , rcMethods :: [(F.LocSymbol, ty)]-  } deriving (Eq, Show, Functor, Data, Typeable, Generic)-    deriving Hashable via Generically (RClass ty)---instance F.PPrint t => F.PPrint (RClass t) where-  pprintTidy k (RClass n ts as mts)-                = ppMethods k ("class" <+> supers ts) n as [(m, RISig t) | (m, t) <- mts]-    where-      supers [] = ""-      supers ts = tuplify (F.pprintTidy k   <$> ts) <+> "=>"-      tuplify   = parens . hcat . punctuate ", "---instance F.PPrint t => F.PPrint (RILaws t) where-  pprintTidy k (RIL n ss ts mts _) = ppEqs k ("instance laws" <+> supers ss) n ts mts-   where-    supers [] = ""-    supers ts = tuplify (F.pprintTidy k   <$> ts) <+> "=>"-    tuplify   = parens . hcat . punctuate ", "---ppEqs :: (F.PPrint x, F.PPrint t, F.PPrint a, F.PPrint n)-          => F.Tidy -> Doc -> n -> [a] -> [(x, t)] -> Doc-ppEqs k hdr name args mts-  = vcat $ hdr <+> dName <+> "where"-         : [ nest 4 (bind m t) | (m, t) <- mts ]-    where-      dName    = parens  (F.pprintTidy k name <+> dArgs)-      dArgs    = gaps    (F.pprintTidy k      <$> args)-      gaps     = hcat . punctuate " "-      bind m t = F.pprintTidy k m <+> "=" <+> F.pprintTidy k t--ppMethods :: (F.PPrint x, F.PPrint t, F.PPrint a, F.PPrint n)-          => F.Tidy -> Doc -> n -> [a] -> [(x, RISig t)] -> Doc-ppMethods k hdr name args mts-  = vcat $ hdr <+> dName <+> "where"-         : [ nest 4 (bind m t) | (m, t) <- mts ]-    where-      dName    = parens  (F.pprintTidy k name <+> dArgs)-      dArgs    = gaps    (F.pprintTidy k      <$> args)-      gaps     = hcat . punctuate " "-      bind m t = ppRISig k m t -- F.pprintTidy k m <+> "::" <+> F.pprintTidy k t--instance B.Binary ty => B.Binary (RClass ty)------------------------------------------------------------------------------ | Var Hole Info --------------------------------------------------------------------------------------------------------------------------------data HoleInfo i t = HoleInfo {htype :: t, hloc :: SrcSpan, henv :: AREnv t, info :: i }--instance Functor (HoleInfo i) where-  fmap f hinfo = hinfo{htype = f (htype hinfo), henv = fmap f (henv hinfo)}--instance (F.PPrint t) => F.PPrint (HoleInfo  i t) where-  pprintTidy k hinfo = text "type:" <+> F.pprintTidy k (htype hinfo)-                       <+> text "\n loc:" <+> F.pprintTidy k (hloc hinfo)-  -- to print the hole environment uncomment the following-  --                     <+> text "\n env:" <+> F.pprintTidy k (henv hinfo)----------------------------------------------------------------------------- | Annotations ----------------------------------------------------------------------------------------------------------------------------------newtype AnnInfo a = AI (M.HashMap SrcSpan [(Maybe Text, a)])-                    deriving (Data, Typeable, Generic, Functor)--data Annot t-  = AnnUse t-  | AnnDef t-  | AnnRDf t-  | AnnLoc SrcSpan-  deriving (Data, Typeable, Generic, Functor)--instance Monoid (AnnInfo a) where-  mempty  = AI M.empty-  mappend = (<>)--instance Semigroup (AnnInfo a) where-  AI m1 <> AI m2 = AI $ M.unionWith (++) m1 m2--instance NFData a => NFData (AnnInfo a)--instance NFData a => NFData (Annot a)------------------------------------------------------------------------------------- | Output -------------------------------------------------------------------------------------------------------------------------------------------------------data Output a = O-  { o_vars   :: Maybe [String]-  , o_types  :: !(AnnInfo a)-  , o_templs :: !(AnnInfo a)-  , o_bots   :: ![SrcSpan]-  , o_result :: ErrorResult-  } deriving (Typeable, Generic, Functor)--instance (F.PPrint a) => F.PPrint (Output a) where-  pprintTidy _ out = F.resultDoc (F.pprint <$> o_result out)--emptyOutput :: Output a-emptyOutput = O Nothing mempty mempty [] mempty--instance Monoid (Output a) where-  mempty  = emptyOutput-  mappend = (<>)--instance Semigroup (Output a) where-  o1 <> o2 = O { o_vars   =            sortNub <$> mappend (o_vars   o1) (o_vars   o2)-               , o_types  =                        mappend (o_types  o1) (o_types  o2)-               , o_templs =                        mappend (o_templs o1) (o_templs o2)-               , o_bots   = sortNubBy ordSrcSpan $ mappend (o_bots o1)   (o_bots   o2)-               , o_result =                        mappend (o_result o1) (o_result o2)-               }---- Ord a 'SrcSpan' if it's meaningful to do so (i.e. we have a 'RealSrcSpan'). Otherwise we default to EQ.-ordSrcSpan :: SrcSpan -> SrcSpan -> Ordering-ordSrcSpan (RealSrcSpan r1 _) (RealSrcSpan r2 _) = r1 `compare` r2-ordSrcSpan (RealSrcSpan _ _ ) _                  = GT-ordSrcSpan _                  (RealSrcSpan _ _ ) = LT-ordSrcSpan _                  _                  = EQ-------------------------------------------------------------------------------------- | KVar Profile -------------------------------------------------------------------------------------------------------------------------------------------------data KVKind-  = RecBindE    Var -- ^ Recursive binder      @letrec x = ...@-  | NonRecBindE Var -- ^ Non recursive binder  @let x = ...@-  | TypeInstE-  | PredInstE-  | LamE-  | CaseE       Int -- ^ Int is the number of cases-  | LetE-  | ImplictE-  | ProjectE        -- ^ Projecting out field of-  deriving (Generic, Eq, Ord, Show, Data, Typeable)--instance Hashable KVKind--newtype KVProf = KVP (M.HashMap KVKind Int) deriving (Generic)--emptyKVProf :: KVProf-emptyKVProf = KVP M.empty--updKVProf :: KVKind -> F.Kuts -> KVProf -> KVProf-updKVProf k kvs (KVP m) = KVP $ M.insert k (kn + n) m-  where-    kn                  = M.lookupDefault 0 k m-    n                   = S.size (F.ksVars kvs)--instance NFData KVKind--instance F.PPrint KVKind where-  pprintTidy _ = text . show--instance F.PPrint KVProf where-  pprintTidy k (KVP m) = F.pprintTidy k (M.toList m)--instance NFData KVProf--hole :: Expr-hole = F.PKVar "HOLE" mempty--isHole :: Expr -> Bool-isHole (F.PKVar "HOLE" _) = True-isHole _                  = False--hasHole :: F.Reftable r => r -> Bool-hasHole = any isHole . F.conjuncts . F.reftPred . F.toReft--instance F.Symbolic DataCon where-  symbol = F.symbol . dataConWorkId--instance F.PPrint DataCon where-  pprintTidy _ = text . showPpr--instance Ord TyCon where-  compare = compare `on` F.symbol--instance Ord DataCon where-  compare = compare `on` F.symbol--instance F.PPrint TyThing where-  pprintTidy _ = text . showPpr--instance Show DataCon where-  show = F.showpp---- instance F.Symbolic TyThing where---  symbol = tyThingSymbol--liquidBegin :: String-liquidBegin = ['{', '-', '@']--liquidEnd :: String-liquidEnd = ['@', '-', '}']--data MSpec ty ctor = MSpec-  { ctorMap  :: M.HashMap Symbol [Def ty ctor]-  , measMap  :: M.HashMap F.LocSymbol (Measure ty ctor)-  , cmeasMap :: M.HashMap F.LocSymbol (Measure ty ())-  , imeas    :: ![Measure ty ctor]-  } deriving (Data, Typeable, Generic, Functor)--instance Bifunctor MSpec   where-  first f (MSpec c m cm im) = MSpec (fmap (fmap (first f)) c)-                                    (fmap (first f) m)-                                    (fmap (first f) cm)-                                    (fmap (first f) im)-  second                    = fmap--instance (F.PPrint t, F.PPrint a) => F.PPrint (MSpec t a) where-  pprintTidy k =  vcat . fmap (F.pprintTidy k . snd) . M.toList . measMap--instance (Show ty, Show ctor, F.PPrint ctor, F.PPrint ty) => Show (MSpec ty ctor) where-  show (MSpec ct m cm im)-    = "\nMSpec:\n" ++-      "\nctorMap:\t "  ++ show ct ++-      "\nmeasMap:\t "  ++ show m  ++-      "\ncmeasMap:\t " ++ show cm ++-      "\nimeas:\t "    ++ show im ++-      "\n"--instance Eq ctor => Semigroup (MSpec ty ctor) where-  MSpec c1 m1 cm1 im1 <> MSpec c2 m2 cm2 im2-    | (k1, k2) : _ <- dups-      -- = panic Nothing $ err (head dups)-    = uError $ err k1 k2-    | otherwise-    = MSpec (M.unionWith (++) c1 c2) (m1 `M.union` m2) (cm1 `M.union` cm2) (im1 ++ im2)-    where-      dups = [(k1, k2) | k1 <- M.keys m1 , k2 <- M.keys m2, F.val k1 == F.val k2]-      err k1 k2 = ErrDupMeas (fSrcSpan k1) (F.pprint (F.val k1)) (fSrcSpan <$> [k1, k2])---instance Eq ctor => Monoid (MSpec ty ctor) where-  mempty = MSpec M.empty M.empty M.empty []-  mappend = (<>)--------------------------------------------------------------------------------------- Nasty PP stuff-----------------------------------------------------------------------------------instance F.PPrint BTyVar where-  pprintTidy _ (BTV α) = text (F.symbolString α)--instance F.PPrint RTyVar where-  pprintTidy k (RTV α)-   | ppTyVar ppEnv  = F.pprintTidy k (F.symbol α) -- shows full tyvar-   | otherwise      = ppr_tyvar_short α           -- drops the unique-suffix-   where-     ppr_tyvar_short :: TyVar -> Doc-     ppr_tyvar_short = text . showPpr--instance (F.PPrint r, F.Reftable r, F.PPrint t, F.PPrint (RType c tv r)) => F.PPrint (Ref t (RType c tv r)) where-  pprintTidy k (RProp ss s) = ppRefArgs k (fst <$> ss) <+> F.pprintTidy k s--ppRefArgs :: F.Tidy -> [Symbol] -> Doc-ppRefArgs _ [] = empty-ppRefArgs k ss = text "\\" <-> hsep (ppRefSym k <$> ss ++ [F.vv Nothing]) <+> "->"--ppRefSym :: (Eq a, IsString a, F.PPrint a) => F.Tidy -> a -> Doc-ppRefSym _ "" = text "_"-ppRefSym k s  = F.pprintTidy k s
− src/Language/Haskell/Liquid/Types/Variance.hs 
@@ -1,123 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-{-# LANGUAGE DerivingVia        #-}--{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- TODO(#1918): Only needed for GHC <9.0.1.-{-# OPTIONS_GHC -Wno-orphans #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-}--module Language.Haskell.Liquid.Types.Variance (-  Variance(..), VarianceInfo, makeTyConVariance, flipVariance-  ) where--import Prelude hiding (error)-import Control.DeepSeq-import Data.Typeable hiding (TyCon)-import Data.Data     hiding (TyCon)-import GHC.Generics-import Data.Binary-import Data.Hashable-import Text.PrettyPrint.HughesPJ--import           Data.Maybe                (fromJust)-import qualified Data.List               as L-import qualified Data.HashSet            as S--import qualified Language.Fixpoint.Types as F--import           Language.Haskell.Liquid.Types.Generics-import qualified Liquid.GHC.Misc as GM-import           Liquid.GHC.API        as Ghc hiding (text)--type VarianceInfo = [Variance]--data Variance = Invariant | Bivariant | Contravariant | Covariant-              deriving (Eq, Data, Typeable, Show, Generic)-              deriving Hashable via Generically Variance--flipVariance :: Variance -> Variance-flipVariance Invariant     = Invariant-flipVariance Bivariant     = Bivariant-flipVariance Contravariant = Covariant-flipVariance Covariant     = Contravariant--instance Semigroup Variance where-  Bivariant     <> _         = Bivariant-  _             <> Bivariant = Bivariant-  Invariant     <> v         = v-  v             <> Invariant = v-  Covariant     <> v         = v-  Contravariant <> v         = flipVariance v--instance Monoid Variance where-  mempty = Bivariant--instance Binary Variance-instance NFData Variance-instance F.PPrint Variance where-  pprintTidy _ = text . show----makeTyConVariance :: TyCon -> VarianceInfo-makeTyConVariance c = varSignToVariance <$> tvs-  where-    tvs = GM.tyConTyVarsDef c--    varsigns = if Ghc.isTypeSynonymTyCon c-                  then go True (fromJust $ Ghc.synTyConRhs_maybe c)-                  else L.nub $ concatMap goDCon $ Ghc.tyConDataCons c--    varSignToVariance v = case filter (\p -> GM.showPpr (fst p) == GM.showPpr v) varsigns of-                            []       -> Invariant-                            [(_, b)] -> if b then Covariant else Contravariant-                            _        -> Bivariant---    goDCon dc = concatMap (go True . irrelevantMult) (Ghc.dataConOrigArgTys dc)--    go pos (FunTy _ _ t1 t2) = go (not pos) t1 ++ go pos t2-    go pos (ForAllTy _ t)    = go pos t-    go pos (TyVarTy v)       = [(v, pos)]-    go pos (AppTy t1 t2)     = go pos t1 ++ go pos t2-    go pos (TyConApp c' ts)-       | c == c'-       = []---- NV fix that: what happens if we have mutually recursive data types?--- now just provide "default" Bivariant for mutually rec types.--- but there should be a finer solution-       | mutuallyRecursive c c'-       = concatMap (goTyConApp pos Bivariant) ts-       | otherwise-       = concat $ zipWith (goTyConApp pos) (makeTyConVariance c') ts--    go _   (LitTy _)       = []-    go _   (CoercionTy _)  = []-    go pos (CastTy t _)    = go pos t--    goTyConApp _   Invariant     _ = []-    goTyConApp pos Bivariant     t = goTyConApp pos Contravariant t ++ goTyConApp pos Covariant t-    goTyConApp pos Covariant     t = go pos       t-    goTyConApp pos Contravariant t = go (not pos) t--    mutuallyRecursive c c' = c `S.member` dataConsOfTyCon c'---dataConsOfTyCon :: TyCon -> S.HashSet TyCon-dataConsOfTyCon = dcs S.empty-  where-    dcs vis c                 = mconcat $ go vis <$> [irrelevantMult t | dc <- Ghc.tyConDataCons c, t <- Ghc.dataConOrigArgTys dc]-    go  vis (FunTy _ _ t1 t2) = go vis t1 `S.union` go vis t2-    go  vis (ForAllTy _ t)    = go vis t-    go  _   (TyVarTy _)       = S.empty-    go  vis (AppTy t1 t2)     = go vis t1 `S.union` go vis t2-    go  vis (TyConApp c ts)-      | c `S.member` vis-      = S.empty-      | otherwise-      = S.insert c (mconcat $ go vis <$> ts) `S.union` dcs (S.insert c vis) c-    go  _   (LitTy _)       = S.empty-    go  _   (CoercionTy _)  = S.empty-    go  vis (CastTy t _)    = go vis t-
− src/Language/Haskell/Liquid/Types/Visitors.hs 
@@ -1,195 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-}--module Language.Haskell.Liquid.Types.Visitors (--  CBVisitable (..)--  -- * visitors-  , coreVisitor-  , CoreVisitor (..)--  ) where--import           Data.Hashable--import           Data.List                        (foldl', (\\), delete)-import qualified Data.HashSet                     as S-import           Prelude                          hiding (error)-import           Language.Fixpoint.Misc-import           Liquid.GHC.API-import           Liquid.GHC.Misc ()------------------------------------------------------------------------------------------------------------------ A CoreBind Visitor ------------------------------------------------------------------------------------------------------------- TODO: syb-shrinkage--class CBVisitable a where-  freeVars :: S.HashSet Var -> a -> [Var]-  readVars :: a -> [Var]-  letVars  :: a -> [Var]-  literals :: a -> [Literal]--instance CBVisitable [CoreBind] where-  freeVars env cbs = sortNub xs \\ ys-    where xs = concatMap (freeVars env) cbs-          ys = concatMap bindings cbs--  readVars = concatMap readVars-  letVars  = concatMap letVars-  literals = concatMap literals--instance CBVisitable CoreBind where-  freeVars env (NonRec x e) = freeVars (extendEnv env [x]) e-  freeVars env (Rec xes)    = concatMap (freeVars env') es-                              where (xs,es) = unzip xes-                                    env'    = extendEnv env xs--  readVars (NonRec _ e)     = readVars e-  readVars (Rec xes)        = concat [x `delete` nubReadVars e |(x, e) <- xes]-    where nubReadVars = sortNub . readVars--  letVars (NonRec x e)      = x : letVars e-  letVars (Rec xes)         = xs ++ concatMap letVars es-    where-      (xs, es)              = unzip xes--  literals (NonRec _ e)      = literals e-  literals (Rec xes)         = concatMap (literals . snd) xes--instance CBVisitable (Expr Var) where-  freeVars = exprFreeVars-  readVars = exprReadVars-  letVars  = exprLetVars-  literals = exprLiterals--exprFreeVars :: S.HashSet Id -> Expr Id -> [Id]-exprFreeVars = go-  where-    go env (Var x)         = [x | not (x `S.member` env)]-    go env (App e a)       = go env e ++ go env a-    go env (Lam x e)       = go (extendEnv env [x]) e-    go env (Let b e)       = freeVars env b ++ go (extendEnv env (bindings b)) e-    go env (Tick _ e)      = go env e-    go env (Cast e _)      = go env e-    go env (Case e x _ cs) = go env e ++ concatMap (freeVars (extendEnv env [x])) cs-    go _   _               = []--exprReadVars :: (CBVisitable (Alt t), CBVisitable (Bind t)) => Expr t -> [Id]-exprReadVars = go-  where-    go (Var x)             = [x]-    go (App e a)           = concatMap go [e, a]-    go (Lam _ e)           = go e-    go (Let b e)           = readVars b ++ go e-    go (Tick _ e)          = go e-    go (Cast e _)          = go e-    go (Case e _ _ cs)     = go e ++ concatMap readVars cs-    go _                   = []--exprLetVars :: Expr Var -> [Var]-exprLetVars = go-  where-    go (Var _)             = []-    go (App e a)           = concatMap go [e, a]-    go (Lam x e)           = x : go e-    go (Let b e)           = letVars b ++ go e-    go (Tick _ e)          = go e-    go (Cast e _)          = go e-    go (Case e x _ cs)     = x : go e ++ concatMap letVars cs-    go _                   = []--exprLiterals :: (CBVisitable (Alt t), CBVisitable (Bind t))-             => Expr t -> [Literal]-exprLiterals = go-  where-    go (Lit l)             = [l]-    go (App e a)           = concatMap go [e, a]-    go (Let b e)           = literals b ++ go e-    go (Lam _ e)           = go e-    go (Tick _ e)          = go e-    go (Cast e _)          = go e-    go (Case e _ _ cs)     = go e ++ concatMap literals cs-    go (Type t)            = go' t-    go _                   = []--    go' (LitTy tl)         = [tyLitToLit tl]-    go' _                  = []---    tyLitToLit (StrTyLit fs) = LitString (bytesFS fs)-    tyLitToLit (NumTyLit i)  = LitNumber LitNumInt (fromIntegral i) intPrimTy----instance CBVisitable (Alt Var) where-  freeVars env (a, xs, e) = freeVars env a ++ freeVars (extendEnv env xs) e-  readVars (_,_, e)       = readVars e-  letVars  (_,xs,e)       = xs ++ letVars e-  literals (c,_, e)       = literals c ++ literals e--instance CBVisitable AltCon where-  freeVars _ (DataAlt dc) = [ x | AnId x <- dataConImplicitTyThings dc]-  freeVars _ _            = []-  readVars _              = []-  letVars  _              = []-  literals (LitAlt l)     = [l]-  literals _              = []--extendEnv :: (Eq a, Hashable a) => S.HashSet a -> [a] -> S.HashSet a-extendEnv = foldl' (flip S.insert)--bindings :: Bind t -> [t]-bindings (NonRec x _) = [x]-bindings (Rec  xes  ) = map fst xes--------------------------------------------------------------------------------------------- | @BindVisitor@ allows for generic, context sensitive traversals over the @CoreBinds@ ------------------------------------------------------------------------------------------data CoreVisitor env acc = CoreVisitor-  { envF  :: env -> Var             -> env-  , bindF :: env -> acc -> Var      -> acc-  , exprF :: env -> acc -> CoreExpr -> acc-  }--coreVisitor :: CoreVisitor env acc -> env -> acc -> [CoreBind] -> acc-coreVisitor vis env acc cbs   = snd (foldl' step (env, acc) cbs)-  where-    stepXE (env, acc) (x,e)   = (env', stepE env' acc'   e)-      where-        env'                  = envF  vis env     x-        acc'                  = bindF vis env acc x--    step ea (NonRec x e)      = stepXE ea (x, e)-    step ea (Rec    xes)      = foldl' stepXE ea xes--    -- step (env, acc) (NonRec x e) = stepXE env acc x e -    -- step (env, acc) (Rec    xes) = (env', foldl' (stepE env') acc' es) -      -- where -        -- acc'                     = foldl' (bindF vis env') acc xs-        -- env'                     = foldl' (envF  vis)      env xs -        -- xs                       = fst <$> xes -        -- es                       = snd <$> xes-        -- foldl' (\(env, acc) (x, e) ->  )--    stepE env acc e              = goE env (exprF vis env acc e) e--    goE _   acc (Var _)          = acc-    goE env acc (App e1 e2)      = stepE  env (stepE env acc e1) e2-    goE env acc (Tick _ e)       = stepE  env acc e-    goE env acc (Cast e _)       = stepE  env acc e-    goE env acc (Lam x e)        = snd (stepXE (env, acc) (x, e))-    goE env acc (Let b e)        = stepE env' acc' e where (env', acc') = step (env, acc) b-    goE env acc (Case e _ _ cs)  = foldl' (goC env) (stepE env acc e) cs-    goE _   acc _                = acc--    goC env acc (_, xs, e)       = stepE  env' acc' e-      where-        env'                     = foldl' (envF  vis)     env xs-        acc'                     = foldl' (bindF vis env) acc xs
− src/Language/Haskell/Liquid/UX/ACSS.hs 
@@ -1,299 +0,0 @@-{-# OPTIONS_GHC -Wno-name-shadowing #-}---- | Formats Haskell source code as HTML with CSS and Mouseover Type Annotations-module Language.Haskell.Liquid.UX.ACSS (-    hscolour-  , hsannot-  , AnnMap (..)-  , breakS-  , srcModuleName-  , Status (..)-  , tokeniseWithLoc-  ) where--import Prelude hiding (error)-import qualified Liquid.GHC.API as SrcLoc--import Language.Haskell.HsColour.Anchors-import Language.Haskell.HsColour.Classify as Classify-import Language.Haskell.HsColour.HTML (renderAnchors, escape)-import qualified Language.Haskell.HsColour.CSS as CSS--import Data.Either (partitionEithers)-import Data.Maybe  (fromMaybe)-import qualified Data.HashMap.Strict as M-import Data.List   (find, isPrefixOf, findIndex, elemIndices, intercalate, elemIndex)-import Data.Char   (isSpace)-import Text.Printf-import Liquid.GHC.Misc-import Language.Haskell.Liquid.Types.Errors (panic, impossible)--data AnnMap  = Ann-  { types   :: M.HashMap Loc (String, String) -- ^ Loc -> (Var, Type)-  , errors  :: [(Loc, Loc, String)]           -- ^ List of error intervals-  , status  :: !Status-  , sptypes :: ![(SrcLoc.RealSrcSpan, (String, String)) ]-- ^ Type information with spans-  }--data Status = Safe | Unsafe | Error | Crash-              deriving (Eq, Ord, Show)--data Annotation = A {-    typ :: Maybe String         -- ^ type  string-  , err :: Maybe String         -- ^ error string-  , lin :: Maybe (Int, Int)     -- ^ line number, total width of lines i.e. max (length (show lineNum))-  } deriving (Show)----- | Formats Haskell source code using HTML and mouse-over annotations-hscolour :: Bool     -- ^ Whether to include anchors.-         -> Bool     -- ^ Whether input document is literate haskell or not-         -> String   -- ^ Haskell source code, Annotations as comments at end-         -> String   -- ^ Coloured Haskell source code.--hscolour anchor lhs = hsannot anchor Nothing lhs . splitSrcAndAnns--type CommentTransform = Maybe (String -> [(TokenType, String)])---- | Formats Haskell source code using HTML and mouse-over annotations-hsannot  :: Bool             -- ^ Whether to include anchors.-         -> CommentTransform -- ^ Function to refine comment tokens-         -> Bool             -- ^ Whether input document is literate haskell or not-         -> (String, AnnMap) -- ^ Haskell Source, Annotations-         -> String           -- ^ Coloured Haskell source code.--hsannot anchor tx False z     = hsannot' Nothing anchor tx z-hsannot anchor tx True (s, m) = concatMap chunk $ litSpans $ joinL $ classify $ inlines s-  where chunk (Code c, l)     = hsannot' (Just l) anchor tx (c, m)-        chunk (Lit c , _)     = c--litSpans :: [Lit] -> [(Lit, Loc)]-litSpans lits = zip lits $ spans lits-  where spans = tokenSpans Nothing . map unL--hsannot' :: Maybe Loc-         -> Bool -> CommentTransform -> (String, AnnMap) -> String-hsannot' baseLoc anchor tx =-    CSS.pre-    . (if anchor then concatMap (renderAnchors renderAnnotToken)-                      . insertAnnotAnchors-                 else concatMap renderAnnotToken)-    . annotTokenise baseLoc tx--tokeniseWithLoc :: CommentTransform -> String -> [(TokenType, String, Loc)]-tokeniseWithLoc tx str = zipWith (\(x,y) z -> (x, y, z)) toks spans-  where-    toks       = tokeniseWithCommentTransform tx str-    spans      = tokenSpans Nothing $ map snd toks---- | annotTokenise is absurdly slow: O(#tokens x #errors)--annotTokenise :: Maybe Loc -> CommentTransform -> (String, AnnMap) -> [(TokenType, String, Annotation)]-annotTokenise baseLoc tx (src, annm) = zipWith (\(x,y) z -> (x,y,z)) toks annots-  where-    toks       = tokeniseWithCommentTransform tx src-    spans      = tokenSpans baseLoc $ map snd toks-    annots     = fmap (spanAnnot linWidth annm) spans-    linWidth   = length $ show $ length $ lines src--spanAnnot :: Int -> AnnMap -> Loc -> Annotation-spanAnnot w (Ann ts es _ _) span = A t e b-  where-    t = fmap snd (M.lookup span ts)-    e = "ERROR" <$ find (span `inRange`) [(x,y) | (x,y,_) <- es]-    b = spanLine w span--spanLine :: t -> Loc -> Maybe (Int, t)-spanLine w (L (l, c))-  | c == 1    = Just (l, w)-  | otherwise = Nothing--inRange :: Loc -> (Loc, Loc) -> Bool-inRange (L (l0, c0)) (L (l, c), L (l', c'))-  = l <= l0 && c <= c0 && l0 <= l' && c0 < c'--tokeniseWithCommentTransform :: Maybe (String -> [(TokenType, String)]) -> String -> [(TokenType, String)]-tokeniseWithCommentTransform Nothing  = tokenise-tokeniseWithCommentTransform (Just f) = concatMap (expand f) . tokenise-  where expand f (Comment, s) = f s-        expand _ z            = [z]--tokenSpans :: Maybe Loc -> [String] -> [Loc]-tokenSpans = scanl plusLoc . fromMaybe (L (1, 1))--plusLoc :: Loc -> String -> Loc-plusLoc (L (l, c)) s-  = case '\n' `elemIndices` s of-      [] -> L (l, c + n)-      is -> L (l + length is, n - maximum is)-    where n = length s--renderAnnotToken :: (TokenType, String, Annotation) -> String-renderAnnotToken (x, y, a)  = renderLinAnnot (lin a)-                            $ renderErrAnnot (err a)-                            $ renderTypAnnot (typ a)-                            $ CSS.renderToken (x, y)----renderTypAnnot :: (PrintfArg t, PrintfType t) => Maybe String -> t -> t-renderTypAnnot (Just ann) s = printf "<a class=annot href=\"#\"><span class=annottext>%s</span>%s</a>" (escape ann) s-renderTypAnnot Nothing    s = s--renderErrAnnot :: (PrintfArg t1, PrintfType t1) => Maybe t -> t1 -> t1-renderErrAnnot (Just _) s   = printf "<span class=hs-error>%s</span>" s-renderErrAnnot Nothing  s   = s--renderLinAnnot :: (Show t, PrintfArg t1, PrintfType t1)-               => Maybe (t, Int) -> t1 -> t1-renderLinAnnot (Just d) s   = printf "<span class=hs-linenum>%s: </span>%s" (lineString d) s-renderLinAnnot Nothing  s   = s--lineString :: Show t => (t, Int) -> [Char]-lineString (i, w) = replicate (w - length is) ' ' ++ is-  where is        = show i--{- Example Annotation:-<a class=annot href="#"><span class=annottext>x#agV:Int -&gt; {VV_int:Int | (0 &lt;= VV_int),(x#agV &lt;= VV_int)}</span>-<span class='hs-definition'>NOWTRYTHIS</span></a>--}---insertAnnotAnchors :: [(TokenType, String, a)] -> [Either String (TokenType, String, a)]-insertAnnotAnchors toks-  = stitch (zip toks' toks) $ insertAnchors toks'-  where toks' = [(x,y) | (x,y,_) <- toks]--stitch ::  Eq b => [(b, c)] -> [Either a b] -> [Either a c]-stitch xys ((Left a) : rest)-  = Left a : stitch xys rest-stitch ((x,y):xys) ((Right x'):rest)-  | x == x'-  = Right y : stitch xys rest-  | otherwise-  = panic Nothing "stitch"-stitch _ []-  = []-stitch _ _-  = impossible Nothing "stitch: cannot happen"--splitSrcAndAnns ::  String -> (String, AnnMap)-splitSrcAndAnns s =-  let ls = lines s in-  case elemIndex breakS ls of-    Nothing -> (s, Ann M.empty [] Safe mempty)-    Just i  -> (src, ann)-               where (codes, _:mname:annots) = splitAt i ls-                     ann   = annotParse mname $ dropWhile isSpace $ unlines annots-                     src   = unlines codes--srcModuleName :: String -> String-srcModuleName = fromMaybe "Main" . tokenModule . tokenise--tokenModule :: [(TokenType, [Char])] -> Maybe [Char]-tokenModule toks-  = do i <- elemIndex (Keyword, "module") toks-       let (_, toks')  = splitAt (i+2) toks-       j <- findIndex ((Space ==) . fst) toks'-       let (toks'', _) = splitAt j toks'-       return $ concatMap snd toks''--breakS :: [Char]-breakS = "MOUSEOVER ANNOTATIONS"--annotParse :: String -> String -> AnnMap-annotParse mname s = Ann (M.fromList ts) [(x,y,"") | (x,y) <- es] Safe mempty-  where-    (ts, es)       = partitionEithers $ parseLines mname 0 $ lines s---parseLines :: [Char]-           -> Int-           -> [[Char]]-           -> [Either (Loc, ([Char], [Char])) (Loc, Loc)]-parseLines _ _ []-  = []--parseLines mname i ("":ls)-  = parseLines mname (i+1) ls--parseLines mname i (_:_:l:c:"0":l':c':rest')-  = Right (L (line, col), L (line', col')) : parseLines mname (i + 7) rest'-    where line  = read l  :: Int-          col   = read c  :: Int-          line' = read l' :: Int-          col'  = read c' :: Int--parseLines mname i (x:f:l:c:n:rest)-  | f /= mname-  = parseLines mname (i + 5 + num) rest'-  | otherwise-  = Left (L (line, col), (x, anns)) : parseLines mname (i + 5 + num) rest'-    where line  = read l :: Int-          col   = read c :: Int-          num   = read n :: Int-          anns  = intercalate "\n" $ take num rest-          rest' = drop num rest--parseLines _ i _-  = panic Nothing $ "Error Parsing Annot Input on Line: " ++ show i--instance Show AnnMap where-  show (Ann ts es _ _) =  "\n\n"-                      ++ concatMap ppAnnotTyp (M.toList ts)-                      ++ concatMap ppAnnotErr [(x,y) | (x,y,_) <- es]--ppAnnotTyp :: (PrintfArg t, PrintfType t1) => (Loc, (t, String)) -> t1-ppAnnotTyp (L (l, c), (x, s))     = printf "%s\n%d\n%d\n%d\n%s\n\n\n" x l c (length $ lines s) s--ppAnnotErr :: PrintfType t => (Loc, Loc) -> t-ppAnnotErr (L (l, c), L (l', c')) = printf " \n%d\n%d\n0\n%d\n%d\n\n\n\n" l c l' c'----------------------------------------------------------------------------------------- Code for Dealing With LHS, stolen from Language.Haskell.HsColour.HsColour ---------------------------------------------------------------------------------------- | Separating literate files into code\/comment chunks.-data Lit = Code {unL :: String} | Lit {unL :: String} deriving (Show)---- Re-implementation of 'lines', for better efficiency (but decreased laziness).--- Also, importantly, accepts non-standard DOS and Mac line ending characters.--- And retains the trailing '\n' character in each resultant string.-inlines :: String -> [String]-inlines s = lines' s id-  where-  lines' []             acc = [acc []]-  lines' ('\^M':'\n':s) acc = acc ['\n'] : lines' s id  -- DOS-  lines' ('\n':s)       acc = acc ['\n'] : lines' s id  -- Unix-  lines' (c:s)          acc = lines' s (acc . (c:))----- | The code for classify is largely stolen from Language.Preprocessor.Unlit.-classify ::  [String] -> [Lit]-classify []             = []-classify (x:xs) | "\\begin{code}"`isPrefixOf`x-                        = Lit x: allProg "code" xs-classify (x:xs) | "\\begin{spec}"`isPrefixOf`x-                        = Lit x: allProg "spec" xs-classify (('>':x):xs)   = Code ('>':x) : classify xs-classify (x:xs)         = Lit x: classify xs---allProg :: [Char] -> [[Char]] -> [Lit]-allProg name  = go-  where-    end       = "\\end{" ++ name ++ "}"-    go []     = []  -- Should give an error message,-                    -- but I have no good position information.-    go (x:xs) | end `isPrefixOf `x-              = Lit x: classify xs-    go (x:xs) = Code x: go xs----- | Join up chunks of code\/comment that are next to each other.-joinL :: [Lit] -> [Lit]-joinL []                  = []-joinL (Code c:Code c2:xs) = joinL (Code (c++c2):xs)-joinL (Lit c :Lit c2 :xs) = joinL (Lit  (c++c2):xs)-joinL (any:xs)            = any: joinL xs
− src/Language/Haskell/Liquid/UX/Annotate.hs 
@@ -1,523 +0,0 @@-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE NoMonomorphismRestriction  #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE FlexibleInstances          #-}--{-# OPTIONS_GHC -Wno-orphans #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-}-------------------------------------------------------------------------------- | This module contains the code that uses the inferred types to generate--- 1. HTMLized source with Inferred Types in mouseover annotations.--- 2. Annotations files (e.g. for vim/emacs)--- 3. JSON files for the web-demo etc.------------------------------------------------------------------------------module Language.Haskell.Liquid.UX.Annotate-  ( mkOutput-  , annotate-  , tokeniseWithLoc-  , annErrors-  ) where--import           Data.Hashable-import           Data.String-import           GHC                                          ( SrcSpan (..)-                                          , srcSpanStartCol-                                          , srcSpanEndCol-                                          , srcSpanStartLine-                                          , srcSpanEndLine)-import           GHC.Exts                                     (groupWith, sortWith)-import           Prelude                                      hiding (error)-import           Text.PrettyPrint.HughesPJ                    hiding (first)-import           Text.Printf--import           Data.Char                                    (isSpace)-import           Data.Function                                (on)-import           Data.List                                    (sortBy)-import           Data.Maybe                                   (mapMaybe)--import           Data.Aeson-import           Control.Arrow                                hiding ((<+>))--- import           Control.Applicative      ((<$>))-import           Control.Monad                                (when, forM_)--import           System.Exit                                  (ExitCode (..))-import           System.FilePath                              (takeFileName, dropFileName, (</>))-import           System.Directory                             (findExecutable)-import qualified System.Directory                             as Dir-import qualified Data.List                                    as L-import qualified Data.Vector                                  as V-import qualified Data.ByteString.Lazy                         as B-import qualified Data.Text                                    as T-import qualified Data.HashMap.Strict                          as M-import qualified Language.Haskell.Liquid.Misc                 as Misc-import qualified Language.Haskell.Liquid.UX.ACSS              as ACSS-import           Language.Haskell.HsColour.Classify-import           Language.Fixpoint.Utils.Files-import           Language.Fixpoint.Misc-import           Liquid.GHC.Misc-import qualified Liquid.GHC.API              as SrcLoc-import           Language.Fixpoint.Types                      hiding (panic, Error, Loc, Constant (..), Located (..))-import           Language.Haskell.Liquid.Misc-import           Language.Haskell.Liquid.Types.PrettyPrint-import           Language.Haskell.Liquid.Types.RefType--import           Language.Haskell.Liquid.UX.Tidy-import           Language.Haskell.Liquid.Types                hiding (Located(..), Def(..))--- import           Language.Haskell.Liquid.Types.Specifications----- | @output@ creates the pretty printed output----------------------------------------------------------------------------------------------mkOutput :: Config -> ErrorResult -> FixSolution -> AnnInfo (Annot SpecType) -> Output Doc----------------------------------------------------------------------------------------------mkOutput cfg res sol anna-  = O { o_vars   = Nothing-      -- , o_errors = []-      , o_types  = toDoc <$> annTy-      , o_templs = toDoc <$> annTmpl-      , o_bots   = mkBots    annTy-      , o_result = res-      }-  where-    annTmpl      = closeAnnots anna-    annTy        = tidySpecType Lossy <$> applySolution sol annTmpl-    toDoc        = rtypeDoc tidy-    tidy         = if shortNames cfg then Lossy else Full---- | @annotate@ actually renders the output to files---------------------------------------------------------------------annotate :: Config -> [FilePath] -> Output Doc -> IO ACSS.AnnMap---------------------------------------------------------------------annotate cfg srcFs out-  -- TODO(matt.walker): Make this obey json!-  = do when showWarns  $ forM_ bots (printf "WARNING: Found false in %s\n" . showPpr)-       when doAnnotate $ mapM_ (doGenerate cfg tplAnnMap typAnnMap annTyp) srcFs-       return typAnnMap-    where-       tplAnnMap  = mkAnnMap cfg res annTpl-       typAnnMap  = mkAnnMap cfg res annTyp-       annTpl     = o_templs out-       annTyp     = o_types  out-       res        = o_result out-       bots       = o_bots   out-       showWarns  = not $ nowarnings    cfg-       doAnnotate = not $ noannotations cfg--doGenerate :: Config -> ACSS.AnnMap -> ACSS.AnnMap -> AnnInfo Doc -> FilePath -> IO ()-doGenerate cfg tplAnnMap typAnnMap annTyp srcF-  = do generateHtml pandocF srcF tpHtmlF tplAnnMap-       generateHtml pandocF srcF tyHtmlF typAnnMap-       writeFile         vimF  $ vimAnnot cfg annTyp-       B.writeFile       jsonF $ encode typAnnMap-    where-       pandocF    = pandocHtml cfg-       tyHtmlF    = extFileName Html                   srcF-       tpHtmlF    = extFileName Html $ extFileName Cst srcF-       _annF      = extFileName Annot srcF-       jsonF      = extFileName Json  srcF-       vimF       = extFileName Vim   srcF--mkBots :: Reftable r => AnnInfo (RType c tv r) -> [GHC.SrcSpan]-mkBots (AI m) = [ src | (src, (Just _, t) : _) <- sortBy (ordSrcSpan `on` fst) $ M.toList m-                      , isFalse (rTypeReft t) ]---- | Like 'copyFile' from 'System.Directory', but ensure that the parent /temporary/ directory--- (i.e. \".liquid\") exists on disk, creating it if necessary.-copyFileCreateParentDirIfMissing :: FilePath -> FilePath -> IO ()-copyFileCreateParentDirIfMissing src tgt = do-  Dir.createDirectoryIfMissing False $ tempDirectory tgt-  Dir.copyFile src tgt--writeFilesOrStrings :: FilePath -> [Either FilePath String] -> IO ()-writeFilesOrStrings tgtFile = mapM_ $ either (`copyFileCreateParentDirIfMissing` tgtFile) (tgtFile `appendFile`)--generateHtml :: Bool -> FilePath -> FilePath -> ACSS.AnnMap -> IO ()-generateHtml pandocF srcF htmlF annm = do-  src     <- Misc.sayReadFile srcF-  let lhs  = isExtFile LHs srcF-  let body      = {-# SCC "hsannot" #-} ACSS.hsannot False (Just tokAnnot) lhs (src, annm)-  cssFile <- getCssPath-  copyFileCreateParentDirIfMissing cssFile (dropFileName htmlF </> takeFileName cssFile)-  renderHtml (pandocF && lhs) htmlF srcF (takeFileName cssFile) body--renderHtml :: Bool -> FilePath -> String -> String -> String -> IO ()-renderHtml True  = renderPandoc-renderHtml False = renderDirect------------------------------------------------------------------------------ | Pandoc HTML Rendering (for lhs + markdown source) ---------------------------------------------------------------------------------------------renderPandoc :: FilePath -> String -> String -> String -> IO ()-renderPandoc htmlFile srcFile css body = do-  renderFn <- maybe renderDirect renderPandoc' <$> findExecutable "pandoc"-  renderFn htmlFile srcFile css body--renderPandoc' :: FilePath -> FilePath -> FilePath -> String -> String -> IO ()-renderPandoc' pandocPath htmlFile srcFile css body = do-  _  <- writeFile mdFile $ pandocPreProc body-  ec <- executeShellCommand "pandoc" cmd-  writeFilesOrStrings htmlFile [Right (cssHTML css)]-  checkExitCode cmd ec-  where-    mdFile = extFileName Mkdn srcFile-    cmd    = pandocCmd pandocPath mdFile htmlFile--checkExitCode :: Monad m => String -> ExitCode -> m ()-checkExitCode _    ExitSuccess    = return ()-checkExitCode cmd (ExitFailure n) = panic Nothing $ "cmd: " ++ cmd ++ " failure code " ++ show n--pandocCmd :: FilePath -> FilePath -> FilePath -> String-pandocCmd -- pandocPath mdFile htmlFile-  = printf "%s -f markdown -t html %s > %s" -- pandocPath mdFile htmlFile--pandocPreProc :: String -> String-pandocPreProc  = T.unpack-               . strip beg code-               . strip end code-               . strip beg spec-               . strip end spec-               . T.pack-  where-    beg, end, code, spec :: String-    beg        = "begin"-    end        = "end"-    code       = "code"-    spec       = "spec"-    strip x y  = T.replace (T.pack $ printf "\\%s{%s}" x y) T.empty------------------------------------------------------------------------------- | Direct HTML Rendering (for non-lhs/markdown source) ---------------------------------------------------------------------------------------------- More or less taken from hscolour--renderDirect :: FilePath -> String -> String -> String -> IO ()-renderDirect htmlFile srcFile css body-  = writeFile htmlFile $! (topAndTail full srcFile css $! body)-    where full = True -- False  -- TODO: command-line-option---- | @topAndTail True@ is used for standalone HTML; @topAndTail False@ for embedded HTML-topAndTail :: Bool -> String -> String -> String -> String-topAndTail True  title css = (htmlHeader title css ++) . (++ htmlClose)-topAndTail False _    _    = id---- Use this for standalone HTML-htmlHeader :: String -> String -> String-htmlHeader title css = unlines-  [ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">"-  , "<html>"-  , "<head>"-  , "<title>" ++ title ++ "</title>"-  , "</head>"-  , cssHTML css-  , "<body>"-  , "<hr>"-  , "Put mouse over identifiers to see inferred types"-  ]--htmlClose :: IsString a => a-htmlClose  = "\n</body>\n</html>"--cssHTML :: String -> String-cssHTML css = unlines-  [ "<head>"-  , "<link type='text/css' rel='stylesheet' href='"++ css ++ "' />"-  , "</head>"-  ]----------------------------------------------------------------------------------- | Building Annotation Maps ----------------------------------------------------------------------------------------------------------------------------------- | This function converts our annotation information into that which---   is required by `Language.Haskell.Liquid.ACSS` to generate mouseover---   annotations.--mkAnnMap :: Config -> ErrorResult -> AnnInfo Doc -> ACSS.AnnMap-mkAnnMap cfg res ann     = ACSS.Ann-                             { ACSS.types   = mkAnnMapTyp cfg ann-                             , ACSS.errors  = mkAnnMapErr res-                             , ACSS.status  = mkStatus res-                             , ACSS.sptypes = mkAnnMapBinders cfg ann-                             }--mkStatus :: FixResult t -> ACSS.Status-mkStatus (Safe _)        = ACSS.Safe-mkStatus (Unsafe _ _)    = ACSS.Unsafe-mkStatus (Crash _ _)     = ACSS.Error----mkAnnMapErr :: PPrint (TError t)-            => FixResult (TError t) -> [(Loc, Loc, String)]-mkAnnMapErr (Unsafe _ ls) = mapMaybe cinfoErr ls-mkAnnMapErr (Crash ls _)  = mapMaybe (cinfoErr . fst) ls-mkAnnMapErr _             = []--cinfoErr :: PPrint (TError t) => TError t -> Maybe (Loc, Loc, String)-cinfoErr e = case pos e of-               SrcLoc.RealSrcSpan l _ -> Just (srcSpanStartLoc l, srcSpanEndLoc l, showpp e)-               _                      -> Nothing----- mkAnnMapTyp :: (RefTypable a c tv r, RefTypable a c tv (), PPrint tv, PPrint a) =>Config-> AnnInfo (RType a c tv r) -> M.HashMap Loc (String, String)-mkAnnMapTyp :: Config -> AnnInfo Doc -> M.HashMap Loc (String, String)-mkAnnMapTyp cfg z = M.fromList $ map (first srcSpanStartLoc) $ mkAnnMapBinders cfg z--mkAnnMapBinders :: Config -> AnnInfo Doc -> [(SrcLoc.RealSrcSpan, (String, String))]-mkAnnMapBinders cfg (AI m)-  = map (second bindStr . head . sortWith (srcSpanEndCol . fst))-  $ groupWith (lineCol . fst) locBinds-  where-    locBinds       = [ (l, x) | (SrcLoc.RealSrcSpan l _, x:_) <- M.toList m, oneLine l]-    bindStr (x, v) = (maybe "_" (symbolString . shorten . symbol) x, render v)-    shorten        = if shortNames cfg then dropModuleNames else id--closeAnnots :: AnnInfo (Annot SpecType) -> AnnInfo SpecType-closeAnnots = closeA . filterA . collapseA--closeA :: AnnInfo (Annot b) -> AnnInfo b-closeA a@(AI m)   = cf <$> a-  where-    cf (AnnLoc l)  = case m `mlookup` l of-                      [(_, AnnUse t)] -> t-                      [(_, AnnDef t)] -> t-                      [(_, AnnRDf t)] -> t-                      _               -> panic Nothing $ "malformed AnnInfo: " ++ showPpr l-    cf (AnnUse t) = t-    cf (AnnDef t) = t-    cf (AnnRDf t) = t--filterA :: AnnInfo (Annot t) -> AnnInfo (Annot t)-filterA (AI m) = AI (M.filter ff m)-  where-    ff [(_, AnnLoc l)] = l `M.member` m-    ff _               = True--collapseA :: AnnInfo (Annot t) -> AnnInfo (Annot t)-collapseA (AI m) = AI (fmap pickOneA m)--pickOneA :: [(t, Annot t1)] -> [(t, Annot t1)]-pickOneA xas = case (rs, ds, ls, us) of-                 (x:_, _, _, _) -> [x]-                 (_, x:_, _, _) -> [x]-                 (_, _, x:_, _) -> [x]-                 (_, _, _, x:_) -> [x]-                 (_, _, _, _  ) -> [ ]-  where-    rs = [x | x@(_, AnnRDf _) <- xas]-    ds = [x | x@(_, AnnDef _) <- xas]-    ls = [x | x@(_, AnnLoc _) <- xas]-    us = [x | x@(_, AnnUse _) <- xas]----------------------------------------------------------------------------------- | Tokenizing Refinement Type Annotations in @-blocks --------------------------------------------------------------------------------------------------------- | The token used for refinement symbols inside the highlighted types in @-blocks.-refToken :: TokenType-refToken = Keyword---- | The top-level function for tokenizing @-block annotations. Used to--- tokenize comments by ACSS.-tokAnnot :: String -> [(TokenType, String)]-tokAnnot s-  = case trimLiquidAnnot s of-      Just (l, body, r) -> [(refToken, l)] ++ tokBody body ++ [(refToken, r)]-      Nothing           -> [(Comment, s)]--trimLiquidAnnot :: String -> Maybe (String, String, String)-trimLiquidAnnot ('{':'-':'@':ss)-  | drop (length ss - 3) ss == "@-}"-  = Just (liquidBegin, take (length ss - 3) ss, liquidEnd)-trimLiquidAnnot _-  = Nothing--tokBody :: String -> [(TokenType, String)]-tokBody s-  | isData s  = tokenise s-  | isType s  = tokenise s-  | isIncl s  = tokenise s-  | isMeas s  = tokenise s-  | otherwise = tokeniseSpec s--isMeas :: String -> Bool-isMeas = spacePrefix "measure"--isData :: String -> Bool-isData = spacePrefix "data"--isType :: String -> Bool-isType = spacePrefix "type"--isIncl :: String -> Bool-isIncl = spacePrefix "include"--{-@ spacePrefix :: String -> s:String -> Bool / [len s] @-}-spacePrefix :: String -> String -> Bool-spacePrefix str s@(c:cs)-  | isSpace c   = spacePrefix str cs-  | otherwise   = take (length str) s == str-spacePrefix _ _ = False---tokeniseSpec :: String -> [(TokenType, String)]-tokeniseSpec       = tokAlt . chopAltDBG-  where-    tokAlt (s:ss)  = tokenise s ++ tokAlt' ss-    tokAlt _       = []-    tokAlt' (s:ss) = (refToken, s) : tokAlt ss-    tokAlt' _      = []--chopAltDBG :: String -> [String]-chopAltDBG y = filter (/= "")-             $ concatMap (chopAlts [("{", ":"), ("|", "}")])-             $ chopAlts [("<{", "}>"), ("{", "}")] y------------------------------------------------------------------------------ | JSON: Annotation Data Types ------------------------------------------------------------------------------------------------------------------newtype Assoc k a = Asc (M.HashMap k a)-type AnnTypes     = Assoc Int (Assoc Int Annot1)-newtype AnnErrors = AnnErrors [(Loc, Loc, String)]-data Annot1       = A1  { ident :: String-                        , ann   :: String-                        , row   :: Int-                        , col   :: Int-                        }----------------------------------------------------------------------------- | Creating Vim Annotations --------------------------------------------------------------------------------------------------------------------vimAnnot     :: Config -> AnnInfo Doc -> String-vimAnnot cfg = L.intercalate "\n" . map vimBind . mkAnnMapBinders cfg--vimBind :: (Show a, PrintfType t) => (SrcLoc.RealSrcSpan, (String, a)) -> t-vimBind (sp, (v, ann)) = printf "%d:%d-%d:%d::%s" l1 c1 l2 c2 (v ++ " :: " ++ show ann)-  where-    l1  = srcSpanStartLine sp-    c1  = srcSpanStartCol  sp-    l2  = srcSpanEndLine   sp-    c2  = srcSpanEndCol    sp----------------------------------------------------------------------------- | JSON Instances -------------------------------------------------------------------------------------------------------------------------------instance ToJSON ACSS.Status where-  toJSON ACSS.Safe   = "safe"-  toJSON ACSS.Unsafe = "unsafe"-  toJSON ACSS.Error  = "error"-  toJSON ACSS.Crash  = "crash"--instance ToJSON Annot1 where-  toJSON (A1 i a r c) = object [ "ident" .= i-                               , "ann"   .= a-                               , "row"   .= r-                               , "col"   .= c-                               ]--instance ToJSON Loc where-  toJSON (L (l, c)) = object [ "line"     .= toJSON l-                             , "column"   .= toJSON c ]--instance ToJSON AnnErrors where-  toJSON (AnnErrors errs) = Array $ V.fromList (toJ <$> errs)-    where-      toJ (l,l',s)        = object [ "start"   .= toJSON l-                                   , "stop"    .= toJSON l'-                                   , "message" .= toJSON (dropErrorLoc s)-                                   ]-----dropErrorLoc :: String -> String-dropErrorLoc msg-  | null msg' = msg-  | otherwise = tail msg'-  where-    (_, msg') = break (' ' ==) msg--instance (Show k, ToJSON a) => ToJSON (Assoc k a) where-  toJSON (Asc kas) = object [ tshow k .= toJSON a | (k, a) <- M.toList kas ]-    where-      tshow        = fromString . show--instance ToJSON ACSS.AnnMap where-  toJSON a = object [ "types"   .= toJSON (annTypes     a)-                    , "errors"  .= toJSON (annErrors    a)-                    , "status"  .= toJSON (ACSS.status  a)-                    , "sptypes" .= (toJ <$> ACSS.sptypes a)-                    ]-    where-      toJ (sp, (x,t)) = object [ "start" .= toJSON (srcSpanStartLoc sp)-                               , "stop"  .= toJSON (srcSpanEndLoc   sp)-                               , "ident" .= toJSON x-                               , "ann"  .= toJSON t-                               ]--annErrors :: ACSS.AnnMap -> AnnErrors-annErrors = AnnErrors . ACSS.errors--annTypes         :: ACSS.AnnMap -> AnnTypes-annTypes a       = grp [(l, c, ann1 l c x s) | (l, c, x, s) <- binders]-  where-    ann1 l c x s = A1 x s l c-    grp          = L.foldl' (\m (r,c,x) -> ins r c x m) (Asc M.empty)-    binders      = [(l, c, x, s) | (L (l, c), (x, s)) <- M.toList $ ACSS.types a]--ins :: (Eq k, Eq k1, Hashable k, Hashable k1)-    => k -> k1 -> a -> Assoc k (Assoc k1 a) -> Assoc k (Assoc k1 a)-ins r c x (Asc m)  = Asc (M.insert r (Asc (M.insert c x rm)) m)-  where-    Asc rm         = M.lookupDefault (Asc M.empty) r m--tokeniseWithLoc :: String -> [(TokenType, String, Loc)]-tokeniseWithLoc = ACSS.tokeniseWithLoc (Just tokAnnot)------------------------------------------------------------------------------------- | LH Related Stuff ---------------------------------------------------------------------------------------------------------------------------------------------{-@ LIQUID "--diffcheck" @-}--{-@ type ListNE a    = {v:[a] | 0 < len v}  @-}-{-@ type ListN  a N  = {v:[a] | len v == N} @-}-{-@ type ListXs a Xs = ListN a {len Xs}     @-}--{-@ assume GHC.Exts.sortWith :: Ord b => (a -> b) -> xs:[a] -> ListXs a xs @-}-{-@ assume GHC.Exts.groupWith :: Ord b => (a -> b) -> [a] -> [ListNE a] @-}------------------------------------------------------------------------------------- | A Little Unit Test -------------------------------------------------------------------------------------------------------------------------------------------_anns :: AnnTypes-_anns = i [(5,   i [( 14, A1 { ident = "foo"-                             , ann   = "int -> int"-                             , row   = 5-                             , col   = 14-                             })-                  ]-          )-         ,(9,   i [( 22, A1 { ident = "map"-                            , ann   = "(a -> b) -> [a] -> [b]"-                            , row   = 9-                            , col   = 22-                            })-                  ,( 28, A1 { ident = "xs"-                            , ann   = "[b]"-                            , row   = 9-                            , col   = 28-                            })-                  ])-         ]--i :: (Eq k, Hashable k) => [(k, a)] -> Assoc k a-i = Asc . M.fromList
− src/Language/Haskell/Liquid/UX/CTags.hs 
@@ -1,76 +0,0 @@--- | This module contains the code for generating "tags" for constraints---   based on their source, i.e. the top-level binders under which the---   constraint was generated. These tags are used by fixpoint to---   prioritize constraints by the "source-level" function.--{-# LANGUAGE TupleSections #-}--module Language.Haskell.Liquid.UX.CTags (-    -- * Type for constraint tags-    TagKey, TagEnv--    -- * Default tag value-  , defaultTag--    -- * Constructing @TagEnv@-  , makeTagEnv--    -- * Accessing @TagEnv@-  , getTag-  , memTagEnv--) where--import Prelude hiding (error)--import qualified Data.HashSet           as S-import qualified Data.HashMap.Strict    as M-import qualified Data.Graph             as G--import Language.Fixpoint.Types          (Tag)-import Liquid.GHC.API-import Language.Haskell.Liquid.Types.Visitors (freeVars)-import Language.Haskell.Liquid.Types.PrettyPrint ()-import Language.Fixpoint.Misc     (mapSnd)---- | The @TagKey@ is the top-level binder, and @Tag@ is a singleton Int list--type TagKey = Var-type TagEnv = M.HashMap TagKey Tag---- TODO: use the "callgraph" SCC to do this numbering.--defaultTag :: Tag-defaultTag = [0]--memTagEnv :: TagKey -> TagEnv -> Bool-memTagEnv = M.member--makeTagEnv :: [CoreBind] -> TagEnv-makeTagEnv = {- tracepp "TAGENV" . -} M.map (:[]) . callGraphRanks . makeCallGraph---- makeTagEnv = M.fromList . (`zip` (map (:[]) [1..])). L.sort . map fst . concatMap bindEqns--getTag :: TagKey -> TagEnv -> Tag-getTag = M.lookupDefault defaultTag----------------------------------------------------------------------------------------------------------type CallGraph = [(Var, [Var])] -- caller-callee pairs--callGraphRanks :: CallGraph -> M.HashMap Var Int--- callGraphRanks cg = traceShow ("CallGraph Ranks: " ++ show cg) $ callGraphRanks' cg--callGraphRanks  = M.fromList . concat . index . mkScc-  where mkScc cg = G.stronglyConnComp [(u, u, vs) | (u, vs) <- cg]-        index    = zipWith (\i -> map (, i) . G.flattenSCC) [1..]--makeCallGraph :: [CoreBind] -> CallGraph-makeCallGraph cbs = mapSnd calls `fmap` xes-  where xes       = concatMap bindEqns cbs-        xs        = S.fromList $ map fst xes-        calls     = filter (`S.member` xs) . freeVars S.empty--bindEqns :: Bind t -> [(t, Expr t)]-bindEqns (NonRec x e) = [(x, e)]-bindEqns (Rec xes)    = xes
− src/Language/Haskell/Liquid/UX/CmdLine.hs 
@@ -1,886 +0,0 @@-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE TemplateHaskell           #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE NamedFieldPuns            #-}-{-# LANGUAGE ViewPatterns              #-}--{-# OPTIONS_GHC -Wno-orphans #-}-{-# OPTIONS_GHC -Wwarn=deprecations #-}-{-# OPTIONS_GHC -fno-cse #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-}-{-# LANGUAGE FlexibleContexts #-}---- | This module contains all the code needed to output the result which---   is either: `SAFE` or `WARNING` with some reasonable error message when---   something goes wrong. All forms of errors/exceptions should go through---   here. The idea should be to report the error, the source position that---   causes it, generate a suitable .json file and then exit.--module Language.Haskell.Liquid.UX.CmdLine (-   -- * Get Command Line Configuration-     getOpts, mkOpts, defConfig, config--   -- * Update Configuration With Pragma-   , withPragmas--   -- * Canonicalize Paths in Config-   , canonicalizePaths--   -- * Exit Function-   , exitWithResult-   , addErrors--   -- * Reporting the output of the checking-   , OutputResult(..)-   , reportResult--   -- * Diff check mode-   , diffcheck--   -- * Show info about this version of LiquidHaskell-   , printLiquidHaskellBanner--) where--import Prelude hiding (error)---import Control.Monad-import Control.Monad.IO.Class-import Data.Maybe-import Data.Functor ((<&>))-import Data.Aeson (encode)-import qualified Data.ByteString.Lazy.Char8 as B-import Development.GitRev (gitCommitCount)-import qualified Paths_liquidhaskell as Meta-import System.Directory-import System.Exit-import System.Environment-import System.Console.CmdArgs.Explicit-import System.Console.CmdArgs.Implicit     hiding (Loud)-import qualified System.Console.CmdArgs.Verbosity as CmdArgs-import System.Console.CmdArgs.Text-import GitHash--import Data.List                           (nub)---import System.FilePath                     (isAbsolute, takeDirectory, (</>))--import qualified Language.Fixpoint.Types.Config as FC-import Language.Fixpoint.Misc-import Language.Fixpoint.Types.Names-import Language.Fixpoint.Types             hiding (panic, Error, Result, saveQuery)-import qualified Language.Fixpoint.Types as F-import Language.Fixpoint.Solver.Stats as Solver-import Language.Haskell.Liquid.UX.Annotate-import Language.Haskell.Liquid.UX.Config-import Language.Haskell.Liquid.UX.SimpleVersion (simpleVersion)-import Liquid.GHC.Misc-import Language.Haskell.Liquid.Misc-import Language.Haskell.Liquid.Types.PrettyPrint ()-import Language.Haskell.Liquid.Types       hiding (typ)-import qualified Language.Haskell.Liquid.UX.ACSS as ACSS--import qualified Liquid.GHC.API as GHC-import           Language.Haskell.TH.Syntax.Compat (fromCode, toCode)--import Text.PrettyPrint.HughesPJ           hiding (Mode, (<>))---------------------------------------------------------------------------------------- Config Magic Numbers----------------------------------------------------------------------------------------------------------------------------------------------defaultMaxParams :: Int-defaultMaxParams = 2-------------------------------------------------------------------------------------- Parsing Command Line---------------------------------------------------------------------------------------------------------------------------------------------config :: Mode (CmdArgs Config)-config = cmdArgsMode $ Config {-  loggingVerbosity-    = enum [ Quiet        &= name "quiet"   &= help "Minimal logging verbosity"-           , Normal       &= name "normal"  &= help "Normal logging verbosity"-           , CmdArgs.Loud &= name "verbose" &= help "Verbose logging"-           ]-- , files-    = def &= typ "TARGET"-          &= args-          &= typFile-- , idirs-    = def &= typDir-          &= help "Paths to Spec Include Directory "-- , fullcheck-     = def-           &= help "Full Checking: check all binders (DEFAULT)"-- , diffcheck-    = def-          &= help "Incremental Checking: only check changed binders"-- , higherorder-    = def-          &= help "Allow higher order binders into the logic"-- , smtTimeout-    = def-          &= help "Timeout of smt queries in msec"-- , higherorderqs-    = def-          &= help "Allow higher order qualifiers to get automatically instantiated"-- , linear-    = def-          &= help "Use uninterpreted integer multiplication and division"-- , stringTheory-    = def-          &= help "Interpretation of Strings by z3"-- , saveQuery-    = def &= help "Save fixpoint query to file (slow)"-- , checks-    = def &= help "Check a specific (top-level) binder"-          &= name "check-var"-- , pruneUnsorted-    = def &= help "Disable prunning unsorted Predicates"-          &= name "prune-unsorted"-- , notermination-    = def-          &= help "Disable Termination Check"-          &= name "no-termination-check"-- , nopositivity-    = def-          &= help "Disable Data Type Positivity Check"-          &= name "no-positivity-check"-- , rankNTypes-    = def &= help "Adds precise reasoning on presence of rankNTypes"-          &= name "rankNTypes"-- , noclasscheck-    = def-          &= help "Disable Class Instance Check"-          &= name "no-class-check"-- , nostructuralterm-    = def &= name "no-structural-termination"-          &= help "Disable structural termination check"-- , gradual-    = def &= help "Enable gradual refinement type checking"-          &= name "gradual"-- , bscope-    = def &= help "scope of the outer binders on the inner refinements"-          &= name "bscope"-- , gdepth-    = 1-    &= help "Size of gradual conretizations, 1 by default"-    &= name "gradual-depth"-- , ginteractive-    = def &= help "Interactive Gradual Solving"-          &= name "ginteractive"-- , totalHaskell-    = def &= help "Check for termination and totality; overrides no-termination flags"-          &= name "total-Haskell"-- , nowarnings-    = def &= help "Don't display warnings, only show errors"-          &= name "no-warnings"-- , noannotations-    = def &= help "Don't create intermediate annotation files"-          &= name "no-annotations"-- , checkDerived-    = def &= help "Check GHC generated binders (e.g. Read, Show instances)"-          &= name "check-derived"-- , caseExpandDepth-    = 2   &= help "Maximum depth at which to expand DEFAULT in case-of (default=2)"-          &= name "max-case-expand"-- , notruetypes-    = def &= help "Disable Trueing Top Level Types"-          &= name "no-true-types"-- , nototality-    = def &= help "Disable totality check"-          &= name "no-totality"-- , cores-    = def &= help "Use m cores to solve logical constraints"-- , minPartSize-    = FC.defaultMinPartSize-    &= help "If solving on multiple cores, ensure that partitions are of at least m size"-- , maxPartSize-    = FC.defaultMaxPartSize-    &= help ("If solving on multiple cores, once there are as many partitions " ++-             "as there are cores, don't merge partitions if they will exceed this " ++-             "size. Overrides the minpartsize option.")-- , smtsolver-    = def &= help "Name of SMT-Solver"-- , noCheckUnknown-    = def &= explicit-          &= name "no-check-unknown"-          &= help "Don't complain about specifications for unexported and unused values "-- , maxParams-    = defaultMaxParams &= help "Restrict qualifier mining to those taking at most `m' parameters (2 by default)"-- , shortNames-    = def &= name "short-names"-          &= help "Print shortened names, i.e. drop all module qualifiers."-- , shortErrors-    = def &= name "short-errors"-          &= help "Don't show long error messages, just line numbers."-- , cabalDir-    = def &= name "cabal-dir"-          &= help "Find and use .cabal to add paths to sources for imported files"-- , ghcOptions-    = def &= name "ghc-option"-          &= typ "OPTION"-          &= help "Pass this option to GHC"-- , cFiles-    = def &= name "c-files"-          &= typ "OPTION"-          &= help "Tell GHC to compile and link against these files"-- , port-     = defaultPort-          &= name "port"-          &= help "Port at which lhi should listen"-- , exactDC-    = def &= help "Exact Type for Data Constructors"-          &= name "exact-data-cons"-- , noADT-    = def &= help "Do not generate ADT representations in refinement logic"-          &= name "no-adt"-- , expectErrorContaining-    = def &= help "Expect an error which containing the provided string from verification (can be provided more than once)"-          &= name "expect-error-containing"-- , expectAnyError-    = def &= help "Expect an error, no matter which kind or what it contains"-          &= name "expect-any-error"-- , scrapeImports-    = False &= help "Scrape qualifiers from imported specifications"-            &= name "scrape-imports"-            &= explicit-- , scrapeInternals-    = False &= help "Scrape qualifiers from auto generated specifications"-            &= name "scrape-internals"-            &= explicit-- , scrapeUsedImports-    = False &= help "Scrape qualifiers from used, imported specifications"-            &= name "scrape-used-imports"-            &= explicit-- , elimStats-    = False &= name "elimStats"-            &= help "Print eliminate stats"-- , elimBound-    = Nothing-            &= name "elimBound"-            &= help "Maximum chain length for eliminating KVars"-- , noslice-    = False-            &= name "noSlice"-            &= help "Disable non-concrete KVar slicing"-- , noLiftedImport-    = False-            &= name "no-lifted-imports"-            &= help "Disable loading lifted specifications (for legacy libs)"-- , json-    = False &= name "json"-            &= help "Print results in JSON (for editor integration)"-- , counterExamples-    = False &= name "counter-examples"-            &= help "Attempt to generate counter-examples to type errors (experimental!)"-- , timeBinds-    = False &= name "time-binds"-            &= help "Solve each (top-level) asserted type signature separately & time solving."--  , untidyCore-    = False &= name "untidy-core"-            &= help "Print fully qualified identifier names in verbose mode"--  , eliminate-    = FC.Some-            &= name "eliminate"-            &= help "Use elimination for 'all' (use TRUE for cut-kvars), 'some' (use quals for cut-kvars) or 'none' (use quals for all kvars)."--  , noPatternInline-    = False &= name "no-pattern-inline"-            &= help "Don't inline special patterns (e.g. `>>=` and `return`) during constraint generation."--  , noSimplifyCore-    = False &= name "no-simplify-core"-            &= help "Don't simplify GHC core before constraint generation"--  -- PLE-OPT , autoInstantiate-    -- PLE-OPT = def-          -- PLE-OPT &= help "How to instantiate axiomatized functions `smtinstances` for SMT instantiation, `liquidinstances` for terminating instantiation"-          -- PLE-OPT &= name "automatic-instances"--  , proofLogicEval-    = def-        &= help "Enable Proof-by-Logical-Evaluation"-        &= name "ple"--  , pleWithUndecidedGuards-    = def-        &= help "Unfold invocations with undecided guards in PLE"-        &= name "ple-with-undecided-guards"-        &= explicit--  , oldPLE-    = def-        &= help "Enable Proof-by-Logical-Evaluation"-        &= name "oldple"--  , interpreter-    = def-        &= help "Use an interpreter to assist PLE in solving constraints"-        &= name "interpreter"--  , proofLogicEvalLocal-    = def-        &= help "Enable Proof-by-Logical-Evaluation locally, per function"-        &= name "ple-local"--  , extensionality-    = def-        &= help "Enable extensional interpretation of function equality"-        &= name "extensionality"--  , nopolyinfer-    = def-        &= help "No inference of polymorphic type application. Gives imprecision, but speedup."-        &= name "fast"--  , reflection-    = def-        &= help "Enable reflection of Haskell functions and theorem proving"-        &= name "reflection"--  , compileSpec-    = def-        &= name "compile-spec"-        &= help "Only compile specifications (into .bspec file); skip verification"--  , noCheckImports-    = def-        &= name "no-check-imports"-        &= help "Do not check the transitive imports; only check the target files."--  , typedHoles-    = def-        &= name "typed-holes"-        &= help "Use (refinement) typed-holes [currently warns on '_x' variables]"-  , typeclass-    = def-        &= help "Enable Typeclass"-        &= name "typeclass"-  , auxInline-    = def-        &= help "Enable inlining of class methods"-        &= name "aux-inline"-  , maxMatchDepth-    = def-        &= name "max-match-depth"-        &= help "Define the number of expressions to pattern match on (typed-holes must be on to use this flag)."-  , maxAppDepth-    = def-        &= name "max-app-depth"-  , maxArgsDepth-    = def-        &= name "max-args-depth"-  ,-    rwTerminationCheck-    = def-        &= name "rw-termination-check"-        &= help (   "Enable the rewrite divergence checker. "-                 ++ "Can speed up verification if rewriting terminates, but can also cause divergence."-                )-  ,-    skipModule-    = def-        &= name "skip-module"-        &= help "Completely skip this module, don't even compile any specifications in it."-  ,-    noLazyPLE-    = def-        &= name "no-lazy-ple"-        &= help "Don't use Lazy PLE"--  , fuel-    = Nothing-        &= help "Maximum fuel (per-function unfoldings) for PLE"--  , environmentReduction-    = def-        &= explicit-        &= name "environment-reduction"-        &= help "perform environment reduction (disabled by default)"-  , noEnvironmentReduction-    = def-        &= explicit-        &= name "no-environment-reduction"-        &= help "Don't perform environment reduction"-  , inlineANFBindings-    = False-        &= explicit-        &= name "inline-anf-bindings"-        &= help (unwords-          [ "Inline ANF bindings."-          , "Sometimes improves performance and sometimes worsens it."-          , "Disabled by --no-environment-reduction"-          ])-  , pandocHtml-    = False-      &= name "pandoc-html"-      &= help "Use pandoc to generate html."-  } &= program "liquid"-    &= help    "Refinement Types for Haskell"-    &= summary copyright-    &= details [ "LiquidHaskell is a Refinement Type based verifier for Haskell"-               , ""-               , "To check a Haskell file foo.hs, type:"-               , "  liquid foo.hs "-               ]--defaultPort :: Int-defaultPort = 3000--getOpts :: [String] -> IO Config-getOpts as = do-  cfg0   <- envCfg-  cfg1   <- mkOpts =<< cmdArgsRun'-                         config { modeValue = (modeValue config)-                                                { cmdArgsValue   = cfg0-                                                }-                                }-                         as-  cfg    <- fixConfig cfg1-  setVerbosity (loggingVerbosity cfg)-  when (json cfg) $ setVerbosity Quiet-  withSmtSolver cfg---- | Shows the LiquidHaskell banner, that includes things like the copyright, the--- git commit and the version.-printLiquidHaskellBanner :: IO ()-printLiquidHaskellBanner = whenNormal $ putStrLn copyright--cmdArgsRun' :: Mode (CmdArgs a) -> [String] -> IO a-cmdArgsRun' md as-  = case parseResult of-      Left e  -> putStrLn (helpMsg e) >> exitFailure-      Right a -> cmdArgsApply a-    where-      helpMsg e = showText defaultWrap $ helpText [e] HelpFormatDefault md-      parseResult = process md (wideHelp as)-      wideHelp = map (\a -> if a == "--help" || a == "-help" then "--help=120" else a)------------------------------------------------------------------------------------withSmtSolver :: Config -> IO Config----------------------------------------------------------------------------------withSmtSolver cfg =-  case smtsolver cfg of-    Just smt -> do found <- findSmtSolver smt-                   case found of-                     Just _ -> return cfg-                     Nothing -> panic Nothing (missingSmtError smt)-    Nothing  -> do smts <- mapM findSmtSolver [FC.Z3, FC.Cvc4, FC.Mathsat]-                   case catMaybes smts of-                     (s:_) -> return (cfg {smtsolver = Just s})-                     _     -> panic Nothing noSmtError-  where-    noSmtError = "LiquidHaskell requires an SMT Solver, i.e. z3, cvc4, or mathsat to be installed."-    missingSmtError smt = "Could not find SMT solver '" ++ show smt ++ "'. Is it on your PATH?"--findSmtSolver :: FC.SMTSolver -> IO (Maybe FC.SMTSolver)-findSmtSolver smt = maybe Nothing (const $ Just smt) <$> findExecutable (show smt)--fixConfig :: Config -> IO Config-fixConfig cfg = do-  pwd <- getCurrentDirectory-  cfg <- canonicalizePaths pwd cfg-  return $ canonConfig cfg---- | Attempt to canonicalize all `FilePath's in the `Config' so we don't have---   to worry about relative paths.-canonicalizePaths :: FilePath -> Config -> IO Config-canonicalizePaths pwd cfg = do-  tgt   <- canonicalizePath pwd-  isdir <- doesDirectoryExist tgt-  is    <- mapM (canonicalize tgt isdir) $ idirs cfg-  cs    <- mapM (canonicalize tgt isdir) $ cFiles cfg-  return $ cfg { idirs = is, cFiles = cs }--canonicalize :: FilePath -> Bool -> FilePath -> IO FilePath-canonicalize tgt isdir f-  | isAbsolute f = return f-  | isdir        = canonicalizePath (tgt </> f)-  | otherwise    = canonicalizePath (takeDirectory tgt </> f)--envCfg :: IO Config-envCfg = do-  so <- lookupEnv "LIQUIDHASKELL_OPTS"-  case so of-    Nothing -> return defConfig-    Just s  -> parsePragma $ envLoc s-  where-    envLoc  = Loc l l-    l       = safeSourcePos "ENVIRONMENT" 1 1--copyright :: String-copyright = concat $ concat-  [ ["LiquidHaskell "]-  , [$(simpleVersion Meta.version)]-  , [gitInfo]-  -- , [" (" ++ _commitCount ++ " commits)" | _commitCount /= ("1"::String) &&-  --                                          _commitCount /= ("UNKNOWN" :: String)]-  , ["\nCopyright 2013-19 Regents of the University of California. All Rights Reserved.\n"]-  ]-  where-    _commitCount = $gitCommitCount--gitInfo :: String-gitInfo  = msg-  where-    giTry :: Either String GitInfo-    giTry  = $$(fromCode (toCode tGitInfoCwdTry))-    msg    = case giTry of-               Left _   -> " no git information"-               Right gi -> gitMsg gi--gitMsg :: GitInfo -> String-gitMsg gi = concat-  [ " [", giBranch gi, "@", giHash gi-  , " (", giCommitDate gi, ")"-  -- , " (", show (giCommitCount gi), " commits in HEAD)"-  , "] "-  ]----- [NOTE:searchpath]--- 1. we used to add the directory containing the file to the searchpath,---    but this is bad because GHC does NOT do this, and it causes spurious---    "duplicate module" errors in the following scenario---      > tree---      .---      ├── Bar.hs---      └── Foo---          ├── Bar.hs---          └── Goo.hs---    If we run `liquid Foo/Goo.hs` and that imports Bar, GHC will not know---    whether we mean to import Bar.hs or Foo/Bar.hs--- 2. tests fail if you flip order of idirs'--mkOpts :: Config -> IO Config-mkOpts cfg = do-  let files' = sortNub $ files cfg-  id0       <- getIncludeDir-  return     $ cfg { files       = files'-                                   -- See NOTE [searchpath]-                   , idirs       = [id0 </> gHC_VERSION, id0]-                                ++ idirs cfg-                   }------------------------------------------------------------------------------------- | Updating options----------------------------------------------------------------------------------canonConfig :: Config -> Config-canonConfig cfg = cfg-  { diffcheck   = diffcheck cfg && not (fullcheck cfg)-  -- , eliminate   = if higherOrderFlag cfg then FC.All else eliminate cfg-  }-----------------------------------------------------------------------------------withPragmas :: MonadIO m => Config -> FilePath -> [Located String] -> (Config -> m a) -> m a----------------------------------------------------------------------------------withPragmas cfg fp ps action-  = do cfg' <- liftIO $ (processPragmas cfg ps >>= canonicalizePaths fp) <&> canonConfig-       -- As the verbosity is set /globally/ via the cmdargs lib, re-set it.-       liftIO $ setVerbosity (loggingVerbosity cfg')-       res <- action cfg'-       liftIO $ setVerbosity (loggingVerbosity cfg) -- restore the original verbosity.-       pure res-  where-    processPragmas :: Config -> [Located String] -> IO Config-    processPragmas c pragmas =-      withArgs (val <$> pragmas) $-        cmdArgsRun config { modeValue = (modeValue config) { cmdArgsValue = c } }---- | Note that this function doesn't process list arguments properly, like--- 'cFiles' or 'expectErrorContaining'--- TODO: This is only used to parse the contents of the env var LIQUIDHASKELL_OPTS--- so it should be able to parse multiple arguments instead. See issue #1990.-withPragma :: Config -> Located String -> IO Config-withPragma c s = withArgs [val s] $ cmdArgsRun-                   config { modeValue = (modeValue config) { cmdArgsValue = c } }--parsePragma :: Located String -> IO Config-parsePragma = withPragma defConfig--defConfig :: Config-defConfig = Config-  { loggingVerbosity         = Quiet-  , files                    = def-  , idirs                    = def-  , fullcheck                = def-  , linear                   = def-  , stringTheory             = def-  , higherorder              = def-  , smtTimeout               = def-  , higherorderqs            = def-  , diffcheck                = def-  , saveQuery                = def-  , checks                   = def-  , nostructuralterm         = def-  , noCheckUnknown           = def-  , notermination            = False-  , nopositivity             = False-  , rankNTypes               = False-  , noclasscheck             = False-  , gradual                  = False-  , bscope                   = False-  , gdepth                   = 1-  , ginteractive             = False-  , totalHaskell             = def -- True-  , nowarnings               = def-  , noannotations            = def-  , checkDerived             = False-  , caseExpandDepth          = 2-  , notruetypes              = def-  , nototality               = False-  , pruneUnsorted            = def-  , exactDC                  = def-  , noADT                    = def-  , expectErrorContaining    = def-  , expectAnyError           = False-  , cores                    = def-  , minPartSize              = FC.defaultMinPartSize-  , maxPartSize              = FC.defaultMaxPartSize-  , maxParams                = defaultMaxParams-  , smtsolver                = def-  , shortNames               = def-  , shortErrors              = def-  , cabalDir                 = def-  , ghcOptions               = def-  , cFiles                   = def-  , port                     = defaultPort-  , scrapeInternals          = False-  , scrapeImports            = False-  , scrapeUsedImports        = False-  , elimStats                = False-  , elimBound                = Nothing-  , json                     = False-  , counterExamples          = False-  , timeBinds                = False-  , untidyCore               = False-  , eliminate                = FC.Some-  , noPatternInline          = False-  , noSimplifyCore           = False-  -- PLE-OPT , autoInstantiate   = def-  , noslice                  = False-  , noLiftedImport           = False-  , proofLogicEval           = False-  , pleWithUndecidedGuards   = False-  , oldPLE                   = False-  , interpreter              = False-  , proofLogicEvalLocal      = False-  , reflection               = False-  , extensionality           = False-  , nopolyinfer              = False-  , compileSpec              = False-  , noCheckImports           = False-  , typedHoles               = False-  , typeclass                = False-  , auxInline                = False-  , maxMatchDepth            = 4-  , maxAppDepth              = 2-  , maxArgsDepth             = 1-  , rwTerminationCheck       = False-  , skipModule               = False-  , noLazyPLE                = False-  , fuel                     = Nothing-  , environmentReduction     = False-  , noEnvironmentReduction   = False-  , inlineANFBindings        = False-  , pandocHtml               = False-  }---- | Write the annotations (i.e. the files in the \".liquid\" hidden folder) and--- report the result of the checking using a supplied function, or using an--- implicit JSON function, if @json@ flag is set.-reportResult :: MonadIO m-             => (OutputResult -> m ())-             -> Config-             -> [FilePath]-             -> Output Doc-             -> m ()-reportResult logResultFull cfg targets out = do-  annm <- {-# SCC "annotate" #-} liftIO $ annotate cfg targets out-  liftIO $ whenNormal $ donePhase Loud "annotate"-  if json cfg then-    liftIO $ reportResultJson annm-   else do-         let r = o_result out-         liftIO $ writeCheckVars $ o_vars out-         cr <- liftIO $ resultWithContext r-         let outputResult = resDocs tidy cr-         -- For now, always print the \"header\" with colours, irrespective to the logger-         -- passed as input.-         liftIO $ printHeader (colorResult r) (orHeader outputResult)-         logResultFull outputResult-  where-    tidy :: F.Tidy-    tidy = if shortErrors cfg then F.Lossy else F.Full--    printHeader :: Moods -> Doc -> IO ()-    printHeader mood d = colorPhaseLn mood "" (render d)---------------------------------------------------------------------------exitWithResult :: Config -> [FilePath] -> Output Doc -> IO ()--------------------------------------------------------------------------exitWithResult cfg targets out = void $ reportResult writeResultStdout cfg targets out--reportResultJson :: ACSS.AnnMap -> IO ()-reportResultJson annm = do-  putStrLn "LIQUID"-  B.putStrLn . encode . annErrors $ annm--resultWithContext :: F.FixResult UserError -> IO (FixResult CError)-resultWithContext (F.Unsafe s es)  = F.Unsafe s    <$> errorsWithContext es-resultWithContext (F.Safe   stats) = return (F.Safe stats)-resultWithContext (F.Crash  es s)  = do-  let (errs, msgs) = unzip es-  errs' <- errorsWithContext errs-  return (F.Crash (zip errs' msgs) s)-----instance Show (CtxError Doc) where-  show = showpp--writeCheckVars :: Symbolic a => Maybe [a] -> IO ()-writeCheckVars Nothing    = return ()-writeCheckVars (Just [])   = colorPhaseLn Loud "Checked Binders: None" ""-writeCheckVars (Just ns)   = colorPhaseLn Loud "Checked Binders:" ""-                          >> forM_ ns (putStrLn . symbolString . dropModuleNames . symbol)--type CError = CtxError Doc--data OutputResult = OutputResult {-    orHeader :: Doc-    -- ^ The \"header\" like \"LIQUID: SAFE\", or \"LIQUID: UNSAFE\".-  , orMessages :: [(GHC.SrcSpan, Doc)]-    -- ^ The list of pretty-printable messages (typically errors) together with their-    -- source locations.-  }---- | Writes the result of this LiquidHaskell run to /stdout/.-writeResultStdout :: OutputResult -> IO ()-writeResultStdout (orMessages -> messages) = do-  forM_ messages $ \(sSpan, doc) -> putStrLn (render $ mkErrorDoc sSpan doc {- pprint sSpan <> (text ": error: " <+> doc)-})--mkErrorDoc :: PPrint a => a -> Doc -> Doc-mkErrorDoc sSpan doc =-  -- Gross on screen, nice for Ghcid-  -- pprint sSpan <> (text ": error: " <+> doc)--  -- Nice on screen, invisible in Ghcid ...-  (pprint sSpan <> text ": error: ") $+$ nest 4 doc----- | Given a 'FixResult' parameterised over a 'CError', this function returns the \"header\" to show to--- the user (i.e. \"SAFE\" or \"UNSAFE\") plus a list of 'Doc's together with the 'SrcSpan' they refer to.-resDocs :: F.Tidy -> F.FixResult CError -> OutputResult-resDocs _ (F.Safe  stats) =-  OutputResult {-    orHeader   = text $ "LIQUID: SAFE (" <> show (Solver.numChck stats) <> " constraints checked)"-  , orMessages = mempty-  }-resDocs _k (F.Crash [] s)  =-  OutputResult {-    orHeader = text "LIQUID: ERROR"-  , orMessages = [(GHC.noSrcSpan, text s)]-  }-resDocs k (F.Crash xs s)  =-  OutputResult {-    orHeader = text "LIQUID: ERROR:" <+> text s-  , orMessages = map (cErrToSpanned k . errToFCrash) xs-  }-resDocs k (F.Unsafe _ xs)   =-  OutputResult {-    orHeader   = text "LIQUID: UNSAFE"-  , orMessages = map (cErrToSpanned k) (nub xs)-  }---- | Renders a 'CError' into a 'Doc' and its associated 'SrcSpan'.-cErrToSpanned :: F.Tidy -> CError -> (GHC.SrcSpan, Doc)-cErrToSpanned k CtxError{ctErr} = (pos ctErr, pprintTidy k ctErr)--errToFCrash :: (CError, Maybe String) -> CError-errToFCrash (ce, Just msg) = ce { ctErr = ErrOther (pos (ctErr ce)) (fixMessageDoc msg) }-errToFCrash (ce, Nothing)  = ce { ctErr = tx $ ctErr ce}-  where-    tx (ErrSubType l m _ g t t') = ErrFCrash l m g t t'-    tx e                         = F.notracepp "errToFCrash?" e--fixMessageDoc :: String -> Doc-fixMessageDoc msg = vcat (text <$> lines msg)--{--   TODO: Never used, do I need to exist?-reportUrl = text "Please submit a bug report at: https://github.com/ucsd-progsys/liquidhaskell" -}--addErrors :: FixResult a -> [a] -> FixResult a-addErrors r []               = r-addErrors (Safe s) errs      = Unsafe s errs-addErrors (Unsafe s xs) errs = Unsafe s (xs ++ errs)-addErrors r  _               = r--instance Fixpoint (F.FixResult CError) where-  toFix = vcat . map snd . orMessages . resDocs F.Full
− src/Language/Haskell/Liquid/UX/Config.hs 
@@ -1,168 +0,0 @@--- | Command Line Configuration Options ------------------------------------------{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveGeneric #-}--module Language.Haskell.Liquid.UX.Config (-     Config (..)-   , HasConfig (..)-   , allowPLE, allowLocalPLE, allowGlobalPLE-   , patternFlag-   , higherOrderFlag-   , pruneFlag-   , maxCaseExpand-   , exactDCFlag-   , hasOpt-   , totalityCheck-   , terminationCheck-   , structuralTerm-   ) where--import Prelude hiding (error)-import Language.Fixpoint.Types.Config hiding (Config)-import GHC.Generics-import System.Console.CmdArgs---- NOTE: adding strictness annotations breaks the help message-data Config = Config-  { loggingVerbosity         :: Verbosity  -- ^ the logging verbosity to use (defaults to 'Quiet')-  , files                    :: [FilePath] -- ^ source files to check-  , idirs                    :: [FilePath] -- ^ path to directory for including specs-  , diffcheck                :: Bool       -- ^ check subset of binders modified (+ dependencies) since last check-  , linear                   :: Bool       -- ^ uninterpreted integer multiplication and division-  , stringTheory             :: Bool       -- ^ interpretation of string theory in the logic-  , higherorder              :: Bool       -- ^ allow higher order binders into the logic-  , higherorderqs            :: Bool       -- ^ allow higher order qualifiers-  , smtTimeout               :: Maybe Int  -- ^ smt timeout-  , fullcheck                :: Bool       -- ^ check all binders (overrides diffcheck)-  , saveQuery                :: Bool       -- ^ save fixpoint query-  , checks                   :: [String]   -- ^ set of binders to check-  , noCheckUnknown           :: Bool       -- ^ whether to complain about specifications for unexported and unused values-  , notermination            :: Bool       -- ^ disable termination check-  , nopositivity             :: Bool       -- ^ disable positivity check-  , rankNTypes               :: Bool       -- ^ Adds precise reasoning on presence of rankNTypes-  , noclasscheck             :: Bool       -- ^ disable checking class instances-  -- , structuralTerm        :: Bool       -- ^ use structural termination checker-  , nostructuralterm         :: Bool       -- ^ disable structural termination check-  , gradual                  :: Bool       -- ^ enable gradual type checking-  , bscope                   :: Bool       -- ^ scope of the outer binders on the inner refinements-  , gdepth                   :: Int        -- ^ depth of gradual concretization-  , ginteractive             :: Bool       -- ^ interactive gradual solving-  , totalHaskell             :: Bool       -- ^ Check for termination and totality, Overrides no-termination flags-  , nowarnings               :: Bool       -- ^ disable warnings output (only show errors)-  , noannotations            :: Bool       -- ^ disable creation of intermediate annotation files-  , checkDerived             :: Bool       -- ^ check internal (GHC-derived) binders-  , caseExpandDepth          :: Int        -- ^ maximum case expand nesting depth.-  , notruetypes              :: Bool       -- ^ disable truing top level types-  , nototality               :: Bool       -- ^ disable totality check in definitions-  , pruneUnsorted            :: Bool       -- ^ enable prunning unsorted Refinements-  , cores                    :: Maybe Int  -- ^ number of cores used to solve constraints-  , minPartSize              :: Int        -- ^ Minimum size of a partition-  , maxPartSize              :: Int        -- ^ Maximum size of a partition. Overrides minPartSize-  , maxParams                :: Int        -- ^ the maximum number of parameters to accept when mining qualifiers-  , smtsolver                :: Maybe SMTSolver  -- ^ name of smtsolver to use [default: try z3, cvc4, mathsat in order]-  , shortNames               :: Bool       -- ^ drop module qualifers from pretty-printed names.-  , shortErrors              :: Bool       -- ^ don't show subtyping errors and contexts.-  , cabalDir                 :: Bool       -- ^ find and use .cabal file to include paths to sources for imported modules-  , ghcOptions               :: [String]   -- ^ command-line options to pass to GHC-  , cFiles                   :: [String]   -- ^ .c files to compile and link against (for GHC)-  , eliminate                :: Eliminate  -- ^ eliminate (i.e. don't use qualifs for) for "none", "cuts" or "all" kvars-  , port                     :: Int        -- ^ port at which lhi should listen-  , exactDC                  :: Bool       -- ^ Automatically generate singleton types for data constructors-  , noADT                    :: Bool       -- ^ Disable ADTs (only used with exactDC)-  , expectErrorContaining    :: [String]   -- ^ expect failure from Liquid with at least one of the following messages-  , expectAnyError           :: Bool       -- ^ expect failure from Liquid with any message-  , scrapeImports            :: Bool       -- ^ scrape qualifiers from imported specifications-  , scrapeInternals          :: Bool       -- ^ scrape qualifiers from auto specifications-  , scrapeUsedImports        :: Bool       -- ^ scrape qualifiers from used, imported specifications-  , elimStats                :: Bool       -- ^ print eliminate stats-  , elimBound                :: Maybe Int  -- ^ eliminate upto given depth of KVar chains-  , json                     :: Bool       -- ^ print results (safe/errors) as JSON-  , counterExamples          :: Bool       -- ^ attempt to generate counter-examples to type errors-  , timeBinds                :: Bool       -- ^ check and time each (asserted) type-sig separately-  , noPatternInline          :: Bool       -- ^ treat code patterns (e.g. e1 >>= \x -> e2) specially for inference-  , untidyCore               :: Bool       -- ^ print full blown core (with untidy names) in verbose mode-  , noSimplifyCore           :: Bool       -- ^ simplify GHC core before constraint-generation-  -- PLE-OPT , autoInst      ntiate :: Instantiate -- ^ How to instantiate axioms-  , noslice                  :: Bool       -- ^ Disable non-concrete KVar slicing-  , noLiftedImport           :: Bool       -- ^ Disable loading lifted specifications (for "legacy" libs)-  , proofLogicEval           :: Bool       -- ^ Enable proof-by-logical-evaluation-  , pleWithUndecidedGuards   :: Bool       -- ^ Unfold invocations with undecided guards in PLE-  , oldPLE                   :: Bool       -- ^ Enable proof-by-logical-evaluation-  , interpreter              :: Bool       -- ^ Use an interpreter to assist PLE-  , proofLogicEvalLocal      :: Bool       -- ^ Enable proof-by-logical-evaluation locally, per function-  , extensionality           :: Bool       -- ^ Enable extensional interpretation of function equality-  , nopolyinfer              :: Bool       -- ^ No inference of polymorphic type application.-  , reflection               :: Bool       -- ^ Allow "reflection"; switches on "--higherorder" and "--exactdc"-  , compileSpec              :: Bool       -- ^ Only "compile" the spec -- into .bspec file -- don't do any checking.-  , noCheckImports           :: Bool       -- ^ Do not check the transitive imports-  , typedHoles               :: Bool       -- ^ Warn about "typed-holes"-  , typeclass                :: Bool        -- ^ enable typeclass support.-  , auxInline                :: Bool        -- ^ -  , maxMatchDepth            :: Int-  , maxAppDepth              :: Int-  , maxArgsDepth             :: Int-  , rwTerminationCheck       :: Bool       -- ^ Enable termination checking for rewriting-  , skipModule               :: Bool       -- ^ Skip this module entirely (don't even compile any specs in it)-  , noLazyPLE                :: Bool-  , fuel                     :: Maybe Int  -- ^ Maximum PLE "fuel" (unfold depth) (default=infinite) -  , environmentReduction     :: Bool       -- ^ Perform environment reduction-  , noEnvironmentReduction   :: Bool       -- ^ Don't perform environment reduction-  , inlineANFBindings        :: Bool       -- ^ Inline ANF bindings.-                                           -- Sometimes improves performance and sometimes worsens it.-  , pandocHtml               :: Bool       -- ^ Use pandoc to generate html-  } deriving (Generic, Data, Typeable, Show, Eq)--allowPLE :: Config -> Bool-allowPLE cfg-  =  allowGlobalPLE cfg-  || allowLocalPLE cfg--allowGlobalPLE :: Config -> Bool-allowGlobalPLE cfg = proofLogicEval  cfg--allowLocalPLE :: Config -> Bool-allowLocalPLE cfg = proofLogicEvalLocal  cfg--instance HasConfig  Config where-  getConfig x = x--class HasConfig t where-  getConfig :: t -> Config--patternFlag :: (HasConfig t) => t -> Bool-patternFlag = not . noPatternInline . getConfig--higherOrderFlag :: (HasConfig t) => t -> Bool-higherOrderFlag x = higherorder cfg || reflection cfg-  where-    cfg           = getConfig x--exactDCFlag :: (HasConfig t) => t -> Bool-exactDCFlag x = exactDC cfg || reflection cfg-  where-    cfg       = getConfig x--pruneFlag :: (HasConfig t) => t -> Bool-pruneFlag = pruneUnsorted . getConfig--maxCaseExpand :: (HasConfig t) => t -> Int-maxCaseExpand = caseExpandDepth . getConfig--hasOpt :: (HasConfig t) => t -> (Config -> Bool) -> Bool-hasOpt t f = f (getConfig t)--totalityCheck :: (HasConfig t) => t -> Bool-totalityCheck = totalityCheck' . getConfig--terminationCheck :: (HasConfig t) => t -> Bool-terminationCheck = terminationCheck' . getConfig--totalityCheck' :: Config -> Bool-totalityCheck' cfg = not (nototality cfg) || totalHaskell cfg--terminationCheck' :: Config -> Bool-terminationCheck' cfg = totalHaskell cfg || not (notermination cfg)--structuralTerm :: (HasConfig a) => a -> Bool-structuralTerm = not . nostructuralterm . getConfig
− src/Language/Haskell/Liquid/UX/DiffCheck.hs 
@@ -1,618 +0,0 @@--- | This module contains the code for Incremental checking, which finds the---   part of a target file (the subset of the @[CoreBind]@ that have been---   modified since it was last checked, as determined by a diff against---   a saved version of the file.--{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE FlexibleInstances #-}--{-# OPTIONS_GHC -Wno-orphans #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-}-{-# LANGUAGE TupleSections #-}--module Language.Haskell.Liquid.UX.DiffCheck (--   -- * Changed binders + Unchanged Errors-     DiffCheck (..)--   -- * Use previously saved info to generate DiffCheck target-   , slice--   -- * Use target binders to generate DiffCheck target-   , thin -- , ThinDeps (..)--   -- * Save current information for next time-   , saveResult--   -- * Names of top-level binders that are rechecked-   , checkedVars--   -- * CoreBinds defining given set of Var-   , filterBinds-   , coreDeps-   , dependsOn-   , Def(..)-   , coreDefs-   )-   where---import           Prelude                                hiding (error)-import           Data.Aeson-import qualified Data.Text                              as T-import           Data.Algorithm.Diff-import           Data.Maybe                             (maybeToList, listToMaybe, mapMaybe, fromMaybe)-import qualified Data.IntervalMap.FingerTree            as IM-import qualified Data.HashSet                           as S-import qualified Data.HashMap.Strict                    as M-import qualified Data.List                              as L-import           System.Directory                       (copyFile, doesFileExist)-import           Language.Fixpoint.Types                (atLoc, FixResult (..), SourcePos(..), safeSourcePos, unPos)--- import qualified Language.Fixpoint.Misc                 as Misc-import           Language.Fixpoint.Utils.Files-import           Language.Fixpoint.Solver.Stats ()-import           Language.Haskell.Liquid.Misc           (mkGraph)-import           Liquid.GHC.Misc-import           Liquid.GHC.API        as Ghc hiding ( Located-                                                                      , sourceName-                                                                      , text-                                                                      , panic-                                                                      , showPpr-                                                                      )-import           Text.PrettyPrint.HughesPJ              (text, render, Doc)-import qualified Data.ByteString                        as B-import qualified Data.ByteString.Lazy                   as LB--import           Language.Haskell.Liquid.Types          hiding (Def, LMap)------------------------------------------------------------------------------------- | Data Types ----------------------------------------------------------------------------------------------------------------------------------------------------- | Main type of value returned for diff-check.-data DiffCheck = DC-  { newBinds  :: [CoreBind]-  , oldOutput :: !(Output Doc)-  , newSpec   :: !TargetSpec-  }--instance PPrint DiffCheck where-  pprintTidy k dc = pprintTidy k (checkedVars dc) <> pprintTidy k (oldOutput dc)----- | Variable definitions-data Def  = D-  { start  :: Int -- ^ line at which binder definition starts-  , end    :: Int -- ^ line at which binder definition ends-  , binder :: Var -- ^ name of binder-  }-  deriving (Eq, Ord)---- | Variable dependencies "call-graph"-type Deps = M.HashMap Var (S.HashSet Var)---- | Map from saved-line-num ---> current-line-num-type LMap   = IM.IntervalMap Int Int---- | Intervals of line numbers that have been re-checked-type ChkItv = IM.IntervalMap Int ()--instance Show Def where-  show (D i j x) = showPpr x ++ " start: " ++ show i ++ " end: " ++ show j------------------------------------------------------------------------------------- | `checkedNames` returns the names of the top-level binders that will be checked----------------------------------------------------------------------------------checkedVars              ::  DiffCheck -> [Var]-checkedVars              = concatMap names . newBinds-   where-     names (NonRec v _ ) = [v]-     names (Rec xs)      = fst <$> xs------------------------------------------------------------------------------------- | `slice` returns a subset of the @[CoreBind]@ of the input `target`---    file which correspond to top-level binders whose code has changed---    and their transitive dependencies.----------------------------------------------------------------------------------slice :: FilePath -> [CoreBind] -> TargetSpec -> IO (Maybe DiffCheck)----------------------------------------------------------------------------------slice target cbs sp = do-  ex <- doesFileExist savedFile-  if ex-    then doDiffCheck-    else return Nothing-  where-    savedFile       = extFileName Saved target-    doDiffCheck     = sliceSaved target savedFile cbs sp--sliceSaved :: FilePath -> FilePath -> [CoreBind] -> TargetSpec -> IO (Maybe DiffCheck)-sliceSaved target savedFile coreBinds spec = do-  (is, lm) <- lineDiff target savedFile-  result   <- loadResult target-  return    $ sliceSaved' target is lm (DC coreBinds result spec)--sliceSaved' :: FilePath -> [Int] -> LMap -> DiffCheck -> Maybe DiffCheck-sliceSaved' srcF is lm (DC coreBinds result spec)-  | gDiff     = Nothing-  | otherwise = Just $ DC cbs' res' sp'-  where-    gDiff     = globalDiff srcF is spec-    sp'       = assumeSpec sigm spec-    res'      = adjustOutput lm cm result-    cm        = checkedItv (coreDefs cbs')-    cbs'      = thinWith sigs coreBinds (diffVars is defs)-    defs      = coreDefs coreBinds ++ specDefs srcF spec-    sigs      = S.fromList $ M.keys sigm-    sigm      = sigVars srcF is spec---- | Add the specified signatures for vars-with-preserved-sigs,---   whose bodies have been pruned from [CoreBind] into the "assumes"--assumeSpec :: M.HashMap Var LocSpecType -> TargetSpec -> TargetSpec-assumeSpec sigm sp = sp { gsSig = gsig { gsAsmSigs = M.toList $ M.union sigm assm } }-  where-    assm           = M.fromList (gsAsmSigs gsig)-    gsig           = gsSig sp--diffVars :: [Int] -> [Def] -> [Var]-diffVars ls defs'    = -- tracePpr ("INCCHECK: diffVars lines = " ++ show ls ++ " defs= " ++ show defs) $-                         go (L.sort ls) defs-  where-    defs             = L.sort defs'-    go _      []     = []-    go []     _      = []-    go (i:is) (d:ds)-      | i < start d  = go is (d:ds)-      | i > end d    = go (i:is) ds-      | otherwise    = binder d : go (i:is) ds--sigVars :: FilePath -> [Int] -> TargetSpec -> M.HashMap Var LocSpecType-sigVars srcF ls sp = M.fromList $ filter (ok . snd) $ specSigs sp-  where-    ok             = not . isDiff srcF ls--globalDiff :: FilePath -> [Int] -> TargetSpec -> Bool-globalDiff srcF ls gspec = measDiff || invsDiff || dconsDiff-  where-    measDiff  = any (isDiff srcF ls) (snd <$> gsMeas spec)-    invsDiff  = any (isDiff srcF ls) (snd <$> gsInvariants spec)-    dconsDiff = any (isDiff srcF ls) [ atLoc ldc () | ldc <- gsDconsP (gsName gspec) ]-    spec      = gsData gspec--isDiff :: FilePath -> [Int] -> Located a -> Bool-isDiff srcF ls x = file x == srcF && any hits ls-  where-    hits i       = line x <= i && i <= lineE x------------------------------------------------------------------------------------- | @thin cbs sp vs@ returns a subset of the @cbs :: [CoreBind]@ which---   correspond to the definitions of @vs@ and the functions transitively---   called therein for which there are *no* type signatures. Callees with---   type signatures are assumed to satisfy those signatures.-----------------------------------------------------------------------------------{- data ThinDeps = Trans [Var] -- ^ Check all transitive dependencies-              | None   Var  -- ^ Check only the given binders- -}-----------------------------------------------------------------------------------thin :: [CoreBind] -> TargetSpec -> [Var] -> DiffCheck------------------------------------------------------------------------------------ thin cbs sp (Trans vs) = DC (thinWith S.empty cbs vs ) mempty sp-thin cbs sp vs = DC (filterBinds      cbs vs') mempty sp'-  where-    vs'        = txClosure (coreDeps cbs) xs (S.fromList vs)-    sp'        = assumeSpec sigs' sp-    sigs'      = foldr M.delete (M.fromList xts) vs-    xts        = specSigs sp-    xs         = S.fromList $ fst <$> xts--thinWith :: S.HashSet Var -> [CoreBind] -> [Var] -> [CoreBind]-thinWith sigs cbs xs = filterBinds cbs calls-  where-    calls    = txClosure cbDeps sigs (S.fromList xs)-    cbDeps   = coreDeps cbs--coreDeps    :: [CoreBind] -> Deps-coreDeps bs = mkGraph $ calls ++ calls'-  where-    calls   = concatMap deps bs-    calls'  = [(y, x) | (x, y) <- calls]-    deps b  = [(x, y) | x <- bindersOf b-                      , y <- freeVars S.empty b-                      , S.member y defVars-              ]-    defVars = S.fromList (letVars bs)---- | Given a call graph, and a list of vars, `dependsOn`---   checks all functions to see if they call any of the---   functions in the vars list.---   If any do, then they must also be rechecked.--dependsOn :: Deps -> [Var] -> S.HashSet Var-dependsOn cg vars  = S.fromList results-  where-    preds          = map S.member vars-    filteredMaps   = M.filter <$> preds <*> pure cg-    results        = map fst $ M.toList $ M.unions filteredMaps--txClosure :: Deps -> S.HashSet Var -> S.HashSet Var -> S.HashSet Var-txClosure d sigs    = go S.empty-  where-    next            = S.unions . fmap deps . S.toList-    deps x          = M.lookupDefault S.empty x d-    go seen new-      | S.null new  = seen-      | otherwise   = let seen' = S.union seen new-                          new'  = next new `S.difference` seen'-                          new'' = new'     `S.difference` sigs-                      in go seen' new''-------------------------------------------------------------------------------------filterBinds        :: [CoreBind] -> S.HashSet Var -> [CoreBind]----------------------------------------------------------------------------------filterBinds cbs ys = filter f cbs-  where-    f (NonRec x _) = x `S.member` ys-    f (Rec xes)    = any (`S.member` ys) $ fst <$> xes------------------------------------------------------------------------------------specDefs :: FilePath -> TargetSpec -> [Def]----------------------------------------------------------------------------------specDefs srcF  = map def . filter sameFile . specSigs-  where-    def (x, t) = D (line t) (lineE t) x-    sameFile   = (srcF ==) . file . snd--specSigs :: TargetSpec -> [(Var, LocSpecType)]-specSigs sp = gsTySigs  (gsSig  sp)-           ++ gsAsmSigs (gsSig  sp)-           ++ gsCtors   (gsData sp)--instance PPrint Def where-  pprintTidy _ d = text (show d)------------------------------------------------------------------------------------coreDefs     :: [CoreBind] -> [Def]----------------------------------------------------------------------------------coreDefs cbs = coreExprDefs xm xes-  where-    xes      = coreVarExprs cbs-    xm       = varBounds xes--coreExprDefs :: M.HashMap Var (Int, Int) -> [(Var, CoreExpr)]-> [Def]-coreExprDefs xm xes =-  L.sort-    [ D l l' x-      | (x, e) <- xes-      , (l, l') <- maybeToList $ coreExprDef xm (x, e)-    ]--coreExprDef :: M.HashMap Var (Int, Int) -> (Var, CoreExpr) -> Maybe (Int, Int)-coreExprDef m (x, e) = meetSpans eSp vSp-  where-    eSp              = lineSpan x $ catSpans x $ exprSpans e-    vSp              = M.lookup x m-    -- vSp   = lineSpan x (getSrcSpan x)--coreVarExprs :: [CoreBind] -> [(Var, CoreExpr)]-coreVarExprs = filter ok . concatMap varExprs-  where-    ok       = isGoodSrcSpan . getSrcSpan . fst--varExprs :: Bind a -> [(a, Expr a)]-varExprs (NonRec x e) = [(x, e)]-varExprs (Rec xes)    = xes---- | varBounds computes upper and lower bounds on where each top-level binder's---   definition can be by using ONLY the lines where the binder is defined.-varBounds :: [(Var, CoreExpr)] -> M.HashMap Var (Int, Int)-varBounds = M.fromList . defBounds . varDefs--varDefs :: [(Var, CoreExpr)] -> [(Int, Var)]-varDefs xes =-  L.sort [ (l, x) | (x,_) <- xes, let Just (l, _) = lineSpan x (getSrcSpan x) ]--defBounds :: [(Int, Var)] -> [(Var, (Int, Int) )]-defBounds ((l, x) : lxs@((l', _) : _ )) = (x, (l, l' - 1)) : defBounds lxs-defBounds _                             = []--{-----------------------------------------------------------------------------------coreDefs     :: [CoreBind] -> [Def]----------------------------------------------------------------------------------coreDefs cbs = tracepp "coreDefs" $-               L.sort [D l l' x | b <- cbs-                                , x <- bindersOf b-                                , isGoodSrcSpan (getSrcSpan x)-                                , (l, l') <- coreDef b]--coreDef :: CoreBind -> [(Int, Int)]-coreDef b-  | True  = tracepp ("coreDef: " ++ showpp (vs, vSp)) $ maybeToList vSp-  | False = tracepp ("coreDef: " ++ showpp (b, eSp, vSp)) $ meetSpans b eSp vSp-  where-    eSp   = lineSpan b $ catSpans b $ bindSpans b-    vSp   = lineSpan b $ catSpans b $ getSrcSpan <$> vs-    vs    = bindersOf b--meetSpans :: Maybe (Int, Int) -> Maybe (Int, Int) -> Maybe (Int, Int)-meetSpans Nothing       _-  = Nothing-meetSpans (Just (l,l')) Nothing-  = Just (l, l')-meetSpans (Just (l,l')) (Just (m,_))-  = Just (max l m, l')--}------------------------------------------------------------------------------------ | `meetSpans` cuts off the start-line to be no less than the line at which---   the binder is defined. Without this, i.e. if we ONLY use the ticks and---   spans appearing inside the definition of the binder (i.e. just `eSp`)---   then the generated span can be WAY before the actual definition binder,---   possibly due to GHC INLINE pragmas or dictionaries OR ...---   for an example: see the "INCCHECK: Def" generated by---      liquid -d benchmarks/bytestring-0.9.2.1/Data/ByteString.hs---   where `spanEnd` is a single line function around 1092 but where---   the generated span starts mysteriously at 222 where Data.List is imported.--meetSpans :: Maybe (Int, Int) -> Maybe (Int, Int) -> Maybe (Int, Int)-meetSpans Nothing       _-  = Nothing-meetSpans (Just (l,l')) Nothing-  = Just (l, l')-meetSpans (Just (l,l')) (Just (m, m'))-  = Just (max l m, min l' m')---- spanLower :: Maybe (Int, Int) -> Maybe Int -> Maybe (Int, Int)--- spanLower Nothing        _        = Nothing--- spanLower sp             Nothing  = sp--- spanLower (Just (l, l')) (Just m) = Just (max l m, l')---- spanUpper :: Maybe (Int, Int) -> Maybe Int -> Maybe (Int, Int)--- spanUpper Nothing        _        = Nothing--- spanUpper sp             Nothing  = sp--- spanUpper (Just (l, l')) (Just m) = Just (l, min l' m)----lineSpan :: t -> SrcSpan -> Maybe (Int, Int)-lineSpan _ (RealSrcSpan sp _) = Just (srcSpanStartLine sp, srcSpanEndLine sp)-lineSpan _ _                  = Nothing--catSpans :: Var -> [SrcSpan] -> SrcSpan-catSpans b []               = panic Nothing $ "DIFFCHECK: catSpans: no spans found for " ++ showPpr b-catSpans b xs               = foldr combineSrcSpans noSrcSpan [x | x@(RealSrcSpan z _) <- xs, varFile b == srcSpanFile z]---- bindFile---   :: (Outputable r, NamedThing r) =>---      Bind r -> FastString--- bindFile (NonRec x _) = varFile x--- bindFile (Rec xes)    = varFile $ fst $ head xes--varFile :: (Outputable a, NamedThing a) => a -> FastString-varFile b = case getSrcSpan b of-              RealSrcSpan z _ -> srcSpanFile z-              _               -> panic Nothing $ "DIFFCHECK: getFile: no file found for: " ++ showPpr b---bindSpans :: NamedThing a => Bind a -> [SrcSpan]-bindSpans (NonRec x e)    = getSrcSpan x : exprSpans e-bindSpans (Rec    xes)    = map getSrcSpan xs ++ concatMap exprSpans es-  where-    (xs, es)              = unzip xes--exprSpans :: NamedThing a => Expr a -> [SrcSpan]-exprSpans (Tick t e)-  | isJunkSpan sp         = exprSpans e-  | otherwise             = [sp]-  where-    sp                    = tickSrcSpan t--exprSpans (Var x)         = [getSrcSpan x]-exprSpans (Lam x e)       = getSrcSpan x : exprSpans e-exprSpans (App e a)       = exprSpans e ++ exprSpans a-exprSpans (Let b e)       = bindSpans b ++ exprSpans e-exprSpans (Cast e _)      = exprSpans e-exprSpans (Case e x _ cs) = getSrcSpan x : exprSpans e ++ concatMap altSpans cs-exprSpans _               = []--altSpans :: (NamedThing a, NamedThing a1) => (t, [a], Expr a1) -> [SrcSpan]-altSpans (_, xs, e)       = map getSrcSpan xs ++ exprSpans e--isJunkSpan :: SrcSpan -> Bool-isJunkSpan RealSrcSpan{} = False-isJunkSpan _             = True------------------------------------------------------------------------------------- | Diff Interface ------------------------------------------------------------------------------------------------------------------------------------------------ | `lineDiff new old` compares the contents of `src` with `dst`---   and returns the lines of `src` that are different.----------------------------------------------------------------------------------lineDiff :: FilePath -> FilePath -> IO ([Int], LMap)----------------------------------------------------------------------------------lineDiff new old  = lineDiff' <$> getLines new <*> getLines old-  where-    getLines      = fmap lines . readFile--lineDiff' :: [String] -> [String] -> ([Int], LMap)-lineDiff' new old = (changedLines, lm)-  where-    changedLines  = diffLines 1 diffLineCount-    lm            = foldr setShift IM.empty $ diffShifts diffLineCount-    diffLineCount = diffMap length <$> getGroupedDiff new old--diffMap :: (a -> b) -> Diff a -> Diff b-diffMap f (First x)  = First (f x)-diffMap f (Second x) = Second (f x)-diffMap f (Both x y) = Both (f x) (f y)---- | Identifies lines that have changed-diffLines :: Int        -- ^ Starting line-          -> [Diff Int] -- ^ List of lengths of diffs-          -> [Int]      -- ^ List of changed line numbers-diffLines _ []                        = []-diffLines curr (Both lnsUnchgd _ : d) = diffLines toSkip d-   where toSkip = curr + lnsUnchgd-diffLines curr (First lnsChgd : d)    = [curr..(toTake-1)] ++ diffLines toTake d-   where toTake = curr + lnsChgd-diffLines curr (_ : d)                = diffLines curr d--diffShifts :: [Diff Int] -> [(Int, Int, Int)]-diffShifts = go 1 1-  where-    go old new (Both n _ : d) = (old, old + n - 1, new - old) : go (old + n)-                                                                   (new + n)-                                                                   d-    go old new (Second n : d) = go (old + n) new d-    go old new (First n  : d) = go old (new + n) d-    go _   _   []             = []----- | @save@ creates an .saved version of the @target@ file, which will be---    used to find what has changed the /next time/ @target@ is checked.----------------------------------------------------------------------------------saveResult :: FilePath -> Output Doc -> IO ()----------------------------------------------------------------------------------saveResult target res = do-  copyFile target saveF-  B.writeFile errF $ LB.toStrict $ encode res-  where-    saveF = extFileName Saved  target-    errF  = extFileName Cache  target-----------------------------------------------------------------------------------loadResult   :: FilePath -> IO (Output Doc)----------------------------------------------------------------------------------loadResult f = do-  ex <- doesFileExist jsonF-  if ex-    then convert <$> B.readFile jsonF-    else return mempty-  where-    convert  = fromMaybe mempty . decode . LB.fromStrict-    jsonF    = extFileName Cache f-----------------------------------------------------------------------------------adjustOutput :: LMap -> ChkItv -> Output Doc -> Output Doc----------------------------------------------------------------------------------adjustOutput lm cm o  = mempty { o_types  = adjustTypes  lm cm (o_types  o) }-                               { o_result = adjustResult lm cm (o_result o) }--adjustTypes :: LMap -> ChkItv -> AnnInfo a -> AnnInfo a-adjustTypes lm cm (AI m)          = AI $ if True then mempty else M.fromList -- FIXME PLEASE-                                    [(sp', v) | (sp, v)  <- M.toList m-                                              , Just sp' <- [adjustSrcSpan lm cm sp]]--adjustResult :: LMap -> ChkItv -> ErrorResult -> ErrorResult-adjustResult lm cm (Unsafe s es)  = errorsResult (Unsafe s)  $ mapMaybe (adjustError  lm cm) es-adjustResult lm cm (Crash es z)   = errorsResult (`Crash` z) $ (, Nothing) <$>mapMaybe (adjustError lm cm . fst) es-adjustResult _  _  r              = r--errorsResult :: ([a] -> FixResult b) -> [a] -> FixResult b-errorsResult _ []                 = Safe mempty-errorsResult f es                 = f es--adjustError :: (PPrint (TError a)) => LMap -> ChkItv -> TError a -> Maybe (TError a)-adjustError lm cm e = case adjustSrcSpan lm cm (pos e) of-  Just sp' -> Just (e {pos = sp'})-  Nothing  -> Nothing-----------------------------------------------------------------------------------adjustSrcSpan :: LMap -> ChkItv -> SrcSpan -> Maybe SrcSpan----------------------------------------------------------------------------------adjustSrcSpan lm cm sp-  = do sp' <- adjustSpan lm sp-       if isCheckedSpan cm sp'-         then Nothing-         else Just sp'--isCheckedSpan :: IM.IntervalMap Int a -> SrcSpan -> Bool-isCheckedSpan cm (RealSrcSpan sp _) = isCheckedRealSpan cm sp-isCheckedSpan _  _                  = False--isCheckedRealSpan :: IM.IntervalMap Int a -> RealSrcSpan -> Bool-isCheckedRealSpan cm              = not . null . (`IM.search` cm) . srcSpanStartLine--adjustSpan :: LMap -> SrcSpan -> Maybe SrcSpan-adjustSpan lm (RealSrcSpan rsp _) = RealSrcSpan <$> adjustReal lm rsp <*> pure Nothing-adjustSpan _  sp                  = Just sp--adjustReal :: LMap -> RealSrcSpan -> Maybe RealSrcSpan-adjustReal lm rsp-  | Just δ <- sh                  = Just $ realSrcSpan f (l1 + δ) c1 (l2 + δ) c2-  | otherwise                     = Nothing-  where-    (f, l1, c1, l2, c2)           = unpackRealSrcSpan rsp-    sh                            = getShift l1 lm----- | @getShift lm old@ returns @Just δ@ if the line number @old@ shifts by @δ@--- in the diff and returns @Nothing@ otherwise.-getShift     :: Int -> LMap -> Maybe Int-getShift old = fmap snd . listToMaybe . IM.search old---- | @setShift (lo, hi, δ) lm@ updates the interval map @lm@ appropriately-setShift             :: (Int, Int, Int) -> LMap -> LMap-setShift (l1, l2, δ) = IM.insert (IM.Interval l1 l2) δ---checkedItv :: [Def] -> ChkItv-checkedItv chDefs = foldr (`IM.insert` ()) IM.empty is-  where-    is            = [IM.Interval l1 l2 | D l1 l2 _ <- chDefs]-------------------------------------------------------------------------------------- | Aeson instances ----------------------------------------------------------------------------------------------------------------------------------------------instance ToJSON SourcePos where-  toJSON p = object [   "sourceName"   .= f-                      , "sourceLine"   .= unPos l-                      , "sourceColumn" .= unPos c-                      ]-             where-               f    = sourceName   p-               l    = sourceLine   p-               c    = sourceColumn p--instance FromJSON SourcePos where-  parseJSON (Object v) = safeSourcePos <$> v .: "sourceName"-                                <*> v .: "sourceLine"-                                <*> v .: "sourceColumn"-  parseJSON _          = mempty--instance FromJSON ErrorResult--instance ToJSON Doc where-  toJSON = String . T.pack . render--instance FromJSON Doc where-  parseJSON (String s) = return $ text $ T.unpack s-  parseJSON _          = mempty--instance ToJSON a => ToJSON (AnnInfo a) where-  toJSON = genericToJSON defaultOptions-  toEncoding = genericToEncoding defaultOptions-instance FromJSON a => FromJSON (AnnInfo a)--instance ToJSON (Output Doc) where-  toJSON = genericToJSON defaultOptions-  toEncoding = genericToEncoding defaultOptions-instance FromJSON (Output Doc) where-  parseJSON = genericParseJSON defaultOptions--file :: Located a -> FilePath-file = sourceName . loc--line :: Located a -> Int-line  = unPos . sourceLine . loc--lineE :: Located a -> Int-lineE = unPos . sourceLine . locE
− src/Language/Haskell/Liquid/UX/Errors.hs 
@@ -1,179 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections     #-}-{-# LANGUAGE BangPatterns      #-}--{-# OPTIONS_GHC -Wno-name-shadowing #-}---- | This module contains the functions related to @Error@ type,--- in particular, to @tidyError@ using a solution, and @pprint@ errors.--module Language.Haskell.Liquid.UX.Errors ( tidyError ) where--import           Control.Arrow                       (second)-import qualified Data.HashMap.Strict                 as M-import qualified Data.HashSet                        as S-import qualified Data.List                           as L-import           Data.Hashable-import           Data.Maybe                          (maybeToList)-import qualified Language.Fixpoint.Types             as F-import           Language.Haskell.Liquid.Types.RefType-import           Language.Haskell.Liquid.Transforms.Simplify-import           Language.Haskell.Liquid.UX.Tidy-import           Language.Haskell.Liquid.Types-import qualified Liquid.GHC.Misc    as GM-import qualified Language.Haskell.Liquid.Misc        as Misc-import qualified Language.Fixpoint.Misc              as Misc---- import Debug.Trace--type Ctx  = M.HashMap F.Symbol SpecType-type CtxM = M.HashMap F.Symbol (WithModel SpecType)---------------------------------------------------------------------------tidyError :: Config -> F.FixSolution -> Error -> Error--------------------------------------------------------------------------tidyError cfg sol-  = fmap (tidySpecType tidy)-  . tidyErrContext tidy sol-  where-    tidy = configTidy cfg--configTidy :: Config -> F.Tidy-configTidy cfg-  | shortNames cfg = F.Lossy-  | otherwise      = F.Full--tidyErrContext :: F.Tidy -> F.FixSolution -> Error -> Error-tidyErrContext k _ e@(ErrSubType {})-  = e { ctx = c', tact = F.subst θ tA, texp = F.subst θ tE }-    where-      (θ, c') = tidyCtx k xs (ctx e)-      xs      = F.syms tA ++ F.syms tE-      tA      = tact e-      tE      = texp e--tidyErrContext _ _ e@(ErrSubTypeModel {})-  = e { ctxM = c', tactM = fmap (F.subst θ) tA, texp = fmap (F.subst θ) tE }-    where-      (θ, c') = tidyCtxM xs $ ctxM e-      xs      = F.syms tA ++ F.syms tE-      tA      = tactM e-      tE      = texp e--tidyErrContext k _ e@(ErrAssType {})-  = e { ctx = c', cond = F.subst θ p }-    where-      m       = ctx e-      (θ, c') = tidyCtx k xs m-      xs      = F.syms p-      p       = cond e--tidyErrContext _ _ e-  = e-----------------------------------------------------------------------------------tidyCtx       :: F.Tidy -> [F.Symbol] -> Ctx -> (F.Subst, Ctx)----------------------------------------------------------------------------------tidyCtx k xs m = (θ1 `mappend` θ2, M.fromList yts)-  where-    yts        = [tBind x (tidySpecType k t) | (x, t) <- xt2s]-    (θ2, xt2s) = tidyREnv xt1s-    (θ1, xt1s) = tidyTemps xts-    xts        = sliceREnv xs m-    tBind x t  = (x', shiftVV t x') where x' = F.tidySymbol x--tidyCtxM       :: [F.Symbol] -> CtxM -> (F.Subst, CtxM)-tidyCtxM xs m  = (θ, M.fromList yts)-  where-    yts       = [tBind x t | (x, t) <- xts]-    (θ, xts)  = tidyTemps $ second (fmap stripReft) <$> tidyREnvM xs m-    tBind x t = (x', fmap (`shiftVV` x') t) where x' = F.tidySymbol x--tidyREnv :: [(F.Symbol, SpecType)] -> (F.Subst, [(F.Symbol, SpecType)])-tidyREnv xts    = (θ, second (F.subst θ) <$> zts)-  where-    θ           = expandVarDefs yes-    (yes, zts)  = Misc.mapEither isInline xts---- | 'expandVarDefs [(x1, e1), ... ,(xn, en)] returns a `Subst` that  ---   contains the fully substituted definitions for each `xi`. For example, ---      expandVarDefs [(x1, 'x2 + x3'), (x5, 'x1 + 1')] ---   should return ---     [x1 := 'x2 + x3, x5 := (x2 + x3) + 1]--expandVarDefs :: [(F.Symbol, F.Expr)] -> F.Subst-expandVarDefs      = go mempty-  where-    go !su xes-      | null yes   = su `mappend` F.mkSubst xes-      | otherwise  = go (su `mappend` su') xes''-      where-       xes''       = [(z, F.subst su' e) | (z, e) <- zes]-       xs          = S.fromList [x | (x, _) <- xes]-       su'         = F.mkSubst yes-       (yes, zes)  = L.partition (isDef xs . snd) xes-    isDef xs e     = not (any (`S.member` xs) (F.syms e))--isInline :: (a, SpecType) -> Either (a, F.Expr) (a, SpecType)-isInline (x, t) = either (Left . (x,)) (Right . (x,)) (isInline' t)--isInline' :: SpecType -> Either F.Expr SpecType-isInline' t = case ro of-                Nothing -> Right t'-                Just rr -> case F.isSingletonReft (ur_reft rr) of-                             Just e  -> Left e-                             Nothing -> Right (strengthen t' rr)-              where-                  (t', ro) = stripRType t--stripReft     :: SpecType -> SpecType-stripReft t   = maybe t' (strengthen t') ro-  where-    (t', ro)  = stripRType t--stripRType    :: SpecType -> (SpecType, Maybe RReft)-stripRType st = (t', ro)-  where-    t'        = fmap (const (uTop mempty)) t-    ro        = stripRTypeBase  t-    t         = simplifyBounds st--sliceREnv :: [F.Symbol] -> Ctx -> [(F.Symbol, SpecType)]-sliceREnv xs m = [(x, t) | x <- xs', t <- maybeToList (M.lookup x m), ok t]-  where-    xs'       = expandFix deps xs-    deps y    = maybe [] (F.syms . rTypeReft) (M.lookup y m)-    ok        = not . isFunTy--tidyREnvM      :: [F.Symbol] -> CtxM -> [(F.Symbol, WithModel SpecType)]-tidyREnvM xs m = [(x, t) | x <- xs', t <- maybeToList (M.lookup x m), ok t]-  where-    xs'       = expandFix deps xs-    deps y    = maybe [] (F.syms . rTypeReft . dropModel) (M.lookup y m)-    ok        = not . isFunTy . dropModel--expandFix :: (Eq a, Hashable a) => (a -> [a]) -> [a] -> [a]-expandFix f               = S.toList . go S.empty-  where-    go seen []            = seen-    go seen (x:xs)-      | x `S.member` seen = go seen xs-      | otherwise         = go (S.insert x seen) (f x ++ xs)--tidyTemps     :: (F.Subable t) => [(F.Symbol, t)] -> (F.Subst, [(F.Symbol, t)])-tidyTemps xts = (θ, [(txB x, txTy t) | (x, t) <- xts])-  where-    txB  x    = M.lookupDefault x x m-    txTy      = F.subst θ-    m         = M.fromList yzs-    θ         = F.mkSubst [(y, F.EVar z) | (y, z) <- yzs]-    yzs       = zip ys niceTemps-    ys        = [ x | (x,_) <- xts, GM.isTmpSymbol x]--niceTemps     :: [F.Symbol]-niceTemps     = mkSymbol <$> xs ++ ys-  where-    mkSymbol  = F.symbol . ('?' :)-    xs        = Misc.single <$> ['a' .. 'z']-    ys        = ("a" ++) <$> [show n | n <- [(0::Int) ..]]
− src/Language/Haskell/Liquid/UX/QuasiQuoter.hs 
@@ -1,213 +0,0 @@-{-# LANGUAGE DeriveDataTypeable    #-}-{-# LANGUAGE DeriveFunctor         #-}-{-# LANGUAGE TemplateHaskellQuotes #-}-{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE OverloadedStrings     #-}--{-# OPTIONS_GHC -Wno-name-shadowing #-}--module Language.Haskell.Liquid.UX.QuasiQuoter--- (---     -- * LiquidHaskell Specification QuasiQuoter---     lq----     -- * QuasiQuoter Annotations---   , LiquidQuote(..)---   ) -  where--import Data.Data-import Data.List--import qualified Data.Text as T--import Language.Haskell.TH.Lib-import Language.Haskell.TH.Syntax-import Language.Haskell.TH.Quote--import Language.Fixpoint.Types hiding (Error, Loc, SrcSpan)-import qualified Language.Fixpoint.Types as F--import Liquid.GHC.Misc (fSrcSpan)-import Liquid.GHC.API  (SrcSpan)-import Language.Haskell.Liquid.Parse-import Language.Haskell.Liquid.Types--import System.IO-import Text.Megaparsec.Error------------------------------------------------------------------------------------- LiquidHaskell Specification QuasiQuoter ------------------------------------------------------------------------------------------------------------------------lq :: QuasiQuoter-lq = QuasiQuoter-  { quoteExp  = bad-  , quotePat  = bad-  , quoteType = bad-  , quoteDec  = lqDec-  }-  where-    -- FIME(adinapoli) Should we preserve 'fail' here?-    bad = error "`lq` quasiquoter can only be used as a top-level declaration"--lqDec :: String -> Q [Dec]-lqDec src = do-  pos <- locSourcePos <$> location-  case singleSpecP pos src of-    Left peb -> do-      runIO (hPutStrLn stderr (errorBundlePretty peb))-      fail "LH quasiquoter parse error"-    Right spec -> do-      prg <- pragAnnD ModuleAnnotation $-               conE 'LiquidQuote `appE` dataToExpQ' spec-      case mkSpecDecs spec of-        Left err ->-          throwErrorInQ err-        Right decs ->-          return $ prg : decs--throwErrorInQ :: UserError -> Q a-throwErrorInQ err =-  fail . showpp =<< runIO (errorsWithContext [err])------------------------------------------------------------------------------------- Liquid Haskell to Template Haskell ------------------------------------------------------------------------------------------------------------------------------- Spec to Dec -------------------------------------------------------------------mkSpecDecs :: BPspec -> Either UserError [Dec]-mkSpecDecs (Asrt (name, ty)) =-  return . SigD (symbolName name)-    <$> simplifyBareType name (quantifyFreeRTy $ val ty)-mkSpecDecs (LAsrt (name, ty)) =-  return . SigD (symbolName name)-    <$> simplifyBareType name (quantifyFreeRTy $ val ty)-mkSpecDecs (Asrts (names, (ty, _))) =-  (\t -> (`SigD` t) . symbolName <$> names)-    <$> simplifyBareType (head names) (quantifyFreeRTy $ val ty)-mkSpecDecs (Alias rta) =-  return . TySynD name tvs <$> simplifyBareType lsym (rtBody (val rta))-  where-    lsym = F.atLoc rta n-    name = symbolName n-    n    = rtName (val rta)-    tvs  = (\a -> PlainTV (symbolName a) ()) <$> rtTArgs (val rta)-mkSpecDecs _ =-  Right []---- Symbol to TH Name -------------------------------------------------------------symbolName :: Symbolic s => s -> Name-symbolName = mkName . symbolString . symbol---- BareType to TH Type -----------------------------------------------------------simplifyBareType :: LocSymbol -> BareType -> Either UserError Type-simplifyBareType s t = case simplifyBareType' t of-  Simplified t' ->-    Right t'-  FoundExprArg l ->-    Left $ ErrTySpec l Nothing (pprint $ val s) (pprint t)-      "Found expression argument in bad location in type"-  FoundHole ->-    Left $ ErrTySpec (fSrcSpan s) Nothing (pprint $ val s) (pprint t)-      "Can't write LiquidHaskell type with hole in a quasiquoter"--simplifyBareType' :: BareType -> Simpl Type-simplifyBareType' = simplifyBareType'' ([], [])--simplifyBareType'' :: ([BTyVar], [BareType]) -> BareType -> Simpl Type--simplifyBareType'' ([], []) (RVar v _) =-  return $ VarT $ symbolName v-simplifyBareType'' ([], []) (RAppTy t1 t2 _) =-  AppT <$> simplifyBareType' t1 <*> simplifyBareType' t2-simplifyBareType'' ([], []) (RFun _ _ i o _) =-  (\x y -> ArrowT `AppT` x `AppT` y)-    <$> simplifyBareType' i <*> simplifyBareType' o-simplifyBareType'' ([], []) (RApp cc as _ _) =-  let c  = btc_tc cc-      c' | isFun   c = ArrowT-         | isTuple c = TupleT (length as)-         | isList  c = ListT-         | otherwise = ConT $ symbolName c-  in  foldl' AppT c' <$> sequenceA (filterExprArgs $ simplifyBareType' <$> as)--simplifyBareType'' _ (RExprArg e) =-  FoundExprArg $ fSrcSpan e-simplifyBareType'' _ (RHole _) =-  FoundHole--simplifyBareType'' s(RAllP _ t) =-  simplifyBareType'' s t-simplifyBareType'' s (RAllE _ _ t) =-  simplifyBareType'' s t-simplifyBareType'' s (REx _ _ t) =-  simplifyBareType'' s t-simplifyBareType'' s (RRTy _ _ _ t) =-  simplifyBareType'' s t--simplifyBareType'' (tvs, cls) (RFun _ _ i o _)-  | isClassType i = simplifyBareType'' (tvs, i : cls) o-simplifyBareType'' (tvs, cls) (RAllT tv t _) =-  simplifyBareType'' (ty_var_value tv : tvs, cls) t--simplifyBareType'' (tvs, cls) t =-  ForallT ((\t -> PlainTV (symbolName t) SpecifiedSpec) <$> reverse tvs)-    <$> mapM simplifyBareType' (reverse cls)-    <*> simplifyBareType' t---data Simpl a = Simplified a-             | FoundExprArg SrcSpan-             | FoundHole-               deriving (Functor)--instance Applicative Simpl where-  pure = Simplified--  Simplified   f <*> Simplified   x = Simplified $ f x-  _              <*> FoundExprArg l = FoundExprArg l-  _              <*> FoundHole      = FoundHole-  FoundExprArg l <*> _              = FoundExprArg l-  FoundHole      <*> _              = FoundHole--instance Monad Simpl where-  return = Simplified--  Simplified   x >>= f = f x-  FoundExprArg l >>= _ = FoundExprArg l-  FoundHole      >>= _ = FoundHole--filterExprArgs :: [Simpl a] -> [Simpl a]-filterExprArgs = filter check-  where-    check (FoundExprArg _) = False-    check _ = True------------------------------------------------------------------------------------- QuasiQuoter Annotations ----------------------------------------------------------------------------------------------------------------------------------------newtype LiquidQuote = LiquidQuote { liquidQuoteSpec :: BPspec }-                      deriving (Data, Typeable)------------------------------------------------------------------------------------- Template Haskell Utility Functions -----------------------------------------------------------------------------------------------------------------------------locSourcePos :: Loc -> SourcePos-locSourcePos loc =-  uncurry (safeSourcePos (loc_filename loc)) (loc_start loc)--dataToExpQ' :: Data a => a -> Q Exp-dataToExpQ' = dataToExpQ (const Nothing `extQ` textToExpQ)--textToExpQ :: T.Text -> Maybe ExpQ-textToExpQ text = Just $ varE 'T.pack `appE` stringE (T.unpack text)--extQ :: (Typeable a, Typeable b) => (a -> q) -> (b -> q) -> a -> q-extQ f g a = maybe (f a) g (cast a)-
− src/Language/Haskell/Liquid/UX/SimpleVersion.hs 
@@ -1,31 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Language.Haskell.Liquid.UX.SimpleVersion (simpleVersion) where--import Data.Version (Version, showVersion)-import GitHash (GitInfo, giDirty, giHash, tGitInfoCwdTry)-import Language.Haskell.TH (Exp, Q)-import qualified Language.Haskell.TH.Syntax as TH.Syntax-import qualified Language.Haskell.TH.Syntax.Compat as TH.Syntax.Compat---- | Generate a string like @Version 1.2, Git revision 1234@.------ @$(simpleVersion …)@ @::@ 'String'--- Taken from <https://hackage.haskell.org/package/optparse-simple-0.1.1.4/docs/Options-Applicative-Simple.html#v:simpleVersion>--- so we can drop the dependency on optparse-simple.-simpleVersion :: Version -> Q Exp-simpleVersion version =-  [|-    concat-      ( [ "Version ",-          $(TH.Syntax.lift $ showVersion version)-        ]-          ++ case $(TH.Syntax.Compat.unTypeSplice tGitInfoCwdTry) :: Either String GitInfo of-            Left _ -> []-            Right gi ->-              [ ", Git revision ",-                giHash gi,-                if giDirty gi then " (dirty)" else ""-              ]-      )-    |]
− src/Language/Haskell/Liquid/UX/Tidy.hs 
@@ -1,249 +0,0 @@-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}--{-# OPTIONS_GHC -Wno-orphans #-}-------------------------------------------------------------------------- | This module contains functions for cleaning up types before---   they are rendered, e.g. in error messages or annoations,---   and also some PPrint instances that rely upon tidying.------------------------------------------------------------------------module Language.Haskell.Liquid.UX.Tidy (--    -- * Tidying functions-    tidySpecType-  , tidySymbol--    -- * Panic and Exit-  , panicError--    -- * Final result-  , Result (..)--    -- * Error to UserError-  , errorToUserError--    -- * MOVE TO TYPES-  , cinfoError-  ) where--import           Data.Hashable-import           Prelude                                   hiding (error)-import qualified Data.HashMap.Strict                       as M-import qualified Data.HashSet                              as S-import qualified Data.List                                 as L-import qualified Data.Text                                 as T-import qualified Control.Exception                         as Ex-import qualified Liquid.GHC.Misc          as GM--- (dropModuleNames, showPpr, stringTyVar)-import           Language.Fixpoint.Types                   hiding (Result, SrcSpan, Error)-import           Language.Haskell.Liquid.Types.Types-import           Language.Haskell.Liquid.Types.RefType     (rVar, subsTyVarsMeet, FreeVar)-import           Language.Haskell.Liquid.Types.PrettyPrint-import           Data.Generics                             (everywhere, mkT)-import           Text.PrettyPrint.HughesPJ------------------------------------------------------------------------------ | Converting Results To Answers ----------------------------------------------------------------------------------------------------------------class Result a where-  result :: a -> FixResult UserError--instance Result UserError where-  result e = Crash [(e, Nothing)] ""--instance Result [Error] where-  result es = Crash ([ (errorToUserError e, Nothing) | e <- es]) ""--instance Result Error where-  result e  = result [e] --  Crash [pprint e] ""--instance Result (FixResult Cinfo) where-  result = fmap (errorToUserError . cinfoError)--errorToUserError :: Error -> UserError-errorToUserError = fmap ppSpecTypeErr---- TODO: move to Types.hs-cinfoError :: Cinfo -> Error-cinfoError (Ci _ (Just e) _) = e-cinfoError (Ci l _ _)        = ErrOther l (text $ "Cinfo: " ++ GM.showPpr l)----------------------------------------------------------------------------tidySpecType :: Tidy -> SpecType -> SpecType---------------------------------------------------------------------------tidySpecType k-  = tidyEqual-  . tidyValueVars-  . tidyDSymbols-  . tidySymbols k-  . tidyInternalRefas-  . tidyLocalRefas k-  . tidyFunBinds-  . tidyTyVars--tidyValueVars :: SpecType -> SpecType-tidyValueVars = mapReft $ \u -> u { ur_reft = tidyVV $ ur_reft u }--tidyVV :: Reft -> Reft-tidyVV r@(Reft (va,_))-  | isJunk va = shiftVV r v'-  | otherwise = r-  where-    v'        = if v `elem` xs then symbol ("v'" :: T.Text) else v-    v         = symbol ("v" :: T.Text)-    xs        = syms r-    isJunk    = isPrefixOfSym "x"--tidySymbols :: Tidy -> SpecType -> SpecType-tidySymbols k t = substa (shortSymbol k . tidySymbol) $ mapBind dropBind t-  where-    xs          = S.fromList (syms t)-    dropBind x  = if x `S.member` xs then tidySymbol x else nonSymbol--shortSymbol :: Tidy -> Symbol -> Symbol-shortSymbol Lossy = GM.dropModuleNames-shortSymbol _     = id--tidyLocalRefas   :: Tidy -> SpecType -> SpecType-tidyLocalRefas k = mapReft (txReft' k)-  where-    txReft' Full                  = id-    txReft' Lossy                 = txReft-    txReft u                      = u { ur_reft = mapPredReft dropLocals $ ur_reft u }-    dropLocals                    = pAnd . filter (not . any isTmp . syms) . conjuncts-    isTmp x                       = any (`isPrefixOfSym` x) [anfPrefix, "ds_"]--tidyEqual :: SpecType -> SpecType-tidyEqual = mapReft txReft-  where-    txReft u                      = u { ur_reft = mapPredReft dropInternals $ ur_reft u }-    dropInternals                 = pAnd . L.nub . conjuncts--tidyInternalRefas   :: SpecType -> SpecType-tidyInternalRefas = mapReft txReft-  where-    txReft u                      = u { ur_reft = mapPredReft dropInternals $ ur_reft u }-    dropInternals                 = pAnd . filter (not . any isIntern . syms) . conjuncts-    isIntern x                    = "is$" `isPrefixOfSym` x || "$select" `isSuffixOfSym` x---tidyDSymbols :: SpecType -> SpecType-tidyDSymbols t = mapBind tx $ substa tx t-  where-    tx         = bindersTx [x | x <- syms t, isTmp x]-    isTmp      = (tempPrefix `isPrefixOfSym`)--tidyFunBinds :: SpecType -> SpecType-tidyFunBinds t = mapBind tx $ substa tx t-  where-    tx         = bindersTx $ filter GM.isTmpSymbol $ funBinds t--tidyTyVars :: SpecType -> SpecType-tidyTyVars t = subsTyVarsAll αβs t-  where-    αβs  = zipWith (\α β -> (α, toRSort β, β)) αs βs-    αs   = L.nub (tyVars t)-    βs   = map (rVar . GM.stringTyVar) pool-    pool = [[c] | c <- ['a'..'z']] ++ [ "t" ++ show i | i <- [(1::Int)..]]---bindersTx :: [Symbol] -> Symbol -> Symbol-bindersTx ds   = \y -> M.lookupDefault y y m-  where-    m          = M.fromList $ zip ds $ var <$> [(1::Int)..]-    var        = symbol . ('x' :) . show---tyVars :: RType c tv r -> [tv]-tyVars (RAllP _ t)     = tyVars t-tyVars (RAllT α t _)   = ty_var_value α : tyVars t-tyVars (RImpF _ _ t t' _) = tyVars t ++ tyVars t'-tyVars (RFun _ _ t t' _) = tyVars t ++ tyVars t'-tyVars (RAppTy t t' _) = tyVars t ++ tyVars t'-tyVars (RApp _ ts _ _) = concatMap tyVars ts-tyVars (RVar α _)      = [α]-tyVars (RAllE _ _ t)   = tyVars t-tyVars (REx _ _ t)     = tyVars t-tyVars (RExprArg _)    = []-tyVars (RRTy _ _ _ t)  = tyVars t-tyVars (RHole _)       = []--subsTyVarsAll-  :: (Eq k, Hashable k,-      Reftable r, TyConable c, SubsTy k (RType c k ()) c,-      SubsTy k (RType c k ()) r,-      SubsTy k (RType c k ()) k,-      SubsTy k (RType c k ()) (RType c k ()),-      SubsTy k (RType c k ()) (RTVar k (RType c k ())),-      FreeVar c k)-   => [(k, RType c k (), RType c k r)] -> RType c k r -> RType c k r-subsTyVarsAll ats = go-  where-    abm            = M.fromList [(a, b) | (a, _, RVar b _) <- ats]-    go (RAllT a t r) = RAllT (makeRTVar $ M.lookupDefault (ty_var_value a) (ty_var_value a) abm) (go t) r-    go t           = subsTyVarsMeet ats t---funBinds :: RType t t1 t2 -> [Symbol]-funBinds (RAllT _ t _)    = funBinds t-funBinds (RAllP _ t)      = funBinds t-funBinds (RImpF b _ t1 t2 _) = b : funBinds t1 ++ funBinds t2-funBinds (RFun b _ t1 t2 _) = b : funBinds t1 ++ funBinds t2-funBinds (RApp _ ts _ _)  = concatMap funBinds ts-funBinds (RAllE b t1 t2)  = b : funBinds t1 ++ funBinds t2-funBinds (REx b t1 t2)    = b : funBinds t1 ++ funBinds t2-funBinds (RVar _ _)       = []-funBinds (RRTy _ _ _ t)   = funBinds t-funBinds (RAppTy t1 t2 _) = funBinds t1 ++ funBinds t2-funBinds (RExprArg _)     = []-funBinds (RHole _)        = []-------------------------------------------------------------------------------------- | Show an Error, then crash----------------------------------------------------------------------------------panicError :: {-(?callStack :: CallStack) =>-} Error -> a----------------------------------------------------------------------------------panicError = Ex.throw---- ^ This function is put in this module as it depends on the Exception instance,---   which depends on the PPrint instance, which depends on tidySpecType.------------------------------------------------------------------------------------- | Pretty Printing Error Messages --------------------------------------------------------------------------------------------------------------------------------- | Need to put @PPrint Error@ instance here (instead of in Types),---   as it depends on @PPrint SpecTypes@, which lives in this module.---instance PPrint (CtxError Doc) where-  pprintTidy k ce = ppError k (ctCtx ce) $ ctErr ce--instance PPrint (CtxError SpecType) where-  pprintTidy k ce = ppError k (ctCtx ce) $ ppSpecTypeErr <$> ctErr ce--instance PPrint Error where-  pprintTidy k = ppError k empty . fmap ppSpecTypeErr--ppSpecTypeErr :: SpecType -> Doc-ppSpecTypeErr = ppSpecType Lossy--ppSpecType :: Tidy -> SpecType -> Doc-ppSpecType k = rtypeDoc     k-             . tidySpecType k-             . fmap (everywhere (mkT noCasts))-  where-    noCasts (ECst x _) = x-    noCasts e          = e--instance Show Error where-  show e = render (pprint (pos e) <+> pprint e)--instance Ex.Exception Error-instance Ex.Exception [Error]
− src/Language/Haskell/Liquid/WiredIn.hs 
@@ -1,218 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Language.Haskell.Liquid.WiredIn-       ( wiredTyCons-       , wiredDataCons-       , wiredSortedSyms--       , charDataCon--       -- * Constants for automatic proofs-       , dictionaryVar-       , dictionaryTyVar-       , dictionaryBind-       , proofTyConName-       , combineProofsName--       -- * Built in symbols-       , isWiredIn-       , isWiredInName-       , dcPrefix--       -- * Deriving classes -       , isDerivedInstance -       ) where--import Prelude                                hiding (error)---- import Language.Fixpoint.Misc           (mapSnd)-import Liquid.GHC.Misc-import qualified Liquid.GHC.API as Ghc-import Liquid.GHC.API (Var, Arity, TyVar, Bind(..), Boxity(..), Expr(..), ArgFlag(..))-import Language.Haskell.Liquid.Types.Types-import Language.Haskell.Liquid.Types.RefType-import Language.Haskell.Liquid.Types.Variance-import Language.Haskell.Liquid.Types.PredType-import Language.Haskell.Liquid.Types.Names (selfSymbol)---- import Language.Fixpoint.Types hiding (panic)-import qualified Language.Fixpoint.Types as F-import qualified Data.HashSet as S --import Liquid.GHC.TypeRep ()---- | Horrible hack to support hardwired symbols like---      `head`, `tail`, `fst`, `snd`---   and other LH generated symbols that---   *do not* correspond to GHC Vars and---   *should not* be resolved to GHC Vars.--isWiredIn :: F.LocSymbol -> Bool-isWiredIn x = isWiredInLoc x  || isWiredInName (val x) || isWiredInShape x--isWiredInLoc :: F.LocSymbol -> Bool-isWiredInLoc sym  = ln == ln' && ln == F.safePos 1 && c == c' && c' == F.safePos 1-  where-    (ln , c)  = spe (loc sym)-    (ln', c') = spe (locE sym)-    spe l    = (x, y) where (_, x, y) = F.sourcePosElts l--isWiredInName :: F.Symbol -> Bool-isWiredInName x = x `S.member` wiredInNames--wiredInNames :: S.HashSet F.Symbol-wiredInNames = S.fromList [ "head", "tail", "fst", "snd", "len"]--isWiredInShape :: F.LocSymbol -> Bool-isWiredInShape x = any (`F.isPrefixOfSym` val x) [F.anfPrefix, F.tempPrefix, dcPrefix]-  -- where s        = val x-        -- dcPrefix = "lqdc"--dcPrefix :: F.Symbol-dcPrefix = "lqdc"--wiredSortedSyms :: [(F.Symbol, F.Sort)]-wiredSortedSyms = (selfSymbol,selfSort):[(pappSym n, pappSort n) | n <- [1..pappArity]]-  where selfSort = F.FAbs 1 (F.FVar 0)------------------------------------------------------------------------------------ | LH Primitive TyCons ------------------------------------------------------------------------------------------------------------------------------------------dictionaryVar :: Var-dictionaryVar   = stringVar "tmp_dictionary_var" (Ghc.ForAllTy (Ghc.Bndr dictionaryTyVar Required) $ Ghc.TyVarTy dictionaryTyVar)--dictionaryTyVar :: TyVar-dictionaryTyVar = stringTyVar "da"--dictionaryBind :: Bind Var-dictionaryBind = Rec [(v, Lam a $ App (Var v) (Type $ Ghc.TyVarTy a))]-  where-   v = dictionaryVar-   a = dictionaryTyVar---------------------------------------------------------------------------- | LH Primitive TyCons -------------------------------------------------------------------------------------------------------------------------combineProofsName :: String-combineProofsName = "combineProofs"--proofTyConName :: F.Symbol-proofTyConName = "Proof"------------------------------------------------------------------------------------- | Predicate Types for WiredIns ---------------------------------------------------------------------------------------------------------------------------------maxArity :: Arity-maxArity = 7--wiredTyCons :: [TyConP]-wiredTyCons  = fst wiredTyDataCons--wiredDataCons :: [Located DataConP]-wiredDataCons = snd wiredTyDataCons--wiredTyDataCons :: ([TyConP] , [Located DataConP])-wiredTyDataCons = (concat tcs, dummyLoc <$> concat dcs)-  where-    (tcs, dcs)  = unzip $ listTyDataCons : map tupleTyDataCons [2..maxArity]--charDataCon :: Located DataConP-charDataCon = dummyLoc (DataConP l0 Ghc.charDataCon  [] [] [] [("charX",lt)] lt False wiredInName l0)-  where -    l0 = F.dummyPos "LH.Bare.charTyDataCons"-    c  = Ghc.charTyCon-    lt = rApp c [] [] mempty-    -listTyDataCons :: ([TyConP] , [DataConP])-listTyDataCons   = ( [TyConP l0 c [RTV tyv] [p] [Covariant] [Covariant] (Just fsize)]-                   , [DataConP l0 Ghc.nilDataCon  [RTV tyv] [p] [] []    lt False wiredInName l0-                   ,  DataConP l0 Ghc.consDataCon [RTV tyv] [p] [] cargs lt False wiredInName l0])-    where-      l0         = F.dummyPos "LH.Bare.listTyDataCons"-      c          = Ghc.listTyCon-      [tyv]      = tyConTyVarsDef c-      t          = rVar tyv :: RSort-      fld        = "fldList"-      xHead      = "head"-      xTail      = "tail"-      p          = PV "p" (PVProp t) (F.vv Nothing) [(t, fld, F.EVar fld)]-      px         = pdVarReft $ PV "p" (PVProp t) (F.vv Nothing) [(t, fld, F.EVar xHead)]-      lt         = rApp c [xt] [rPropP [] $ pdVarReft p] mempty-      xt         = rVar tyv-      xst        = rApp c [RVar (RTV tyv) px] [rPropP [] $ pdVarReft p] mempty-      cargs      = [(xTail, xst), (xHead, xt)]-      fsize      = SymSizeFun (dummyLoc "len")--wiredInName :: F.Symbol-wiredInName = "WiredIn"--tupleTyDataCons :: Int -> ([TyConP] , [DataConP])-tupleTyDataCons n = ( [TyConP   l0 c  (RTV <$> tyvs) ps tyvarinfo pdvarinfo Nothing]-                    , [DataConP l0 dc (RTV <$> tyvs) ps []  cargs  lt False wiredInName l0])-  where-    tyvarinfo     = replicate n     Covariant-    pdvarinfo     = replicate (n-1) Covariant-    l0            = F.dummyPos "LH.Bare.tupleTyDataCons"-    c             = Ghc.tupleTyCon   Boxed n-    dc            = Ghc.tupleDataCon Boxed n-    tyvs@(tv:tvs) = tyConTyVarsDef c-    (ta:ts)       = (rVar <$> tyvs) :: [RSort]-    flds          = mks "fld_Tuple"-    fld           = "fld_Tuple"-    x1:xs         = mks ("x_Tuple" ++ show n)-    ps            = mkps pnames (ta:ts) ((fld, F.EVar fld) : zip flds (F.EVar <$> flds))-    ups           = uPVar <$> ps-    pxs           = mkps pnames (ta:ts) ((fld, F.EVar x1) : zip flds (F.EVar <$> xs))-    lt            = rApp c (rVar <$> tyvs) (rPropP [] . pdVarReft <$> ups) mempty-    xts           = zipWith (\v p -> RVar (RTV v) (pdVarReft p)) tvs pxs-    cargs         = reverse $ (x1, rVar tv) : zip xs xts-    pnames        = mks_ "p"-    mks  x        = (\i -> F.symbol (x++ show i)) <$> [1..n]-    mks_ x        = (\i -> F.symbol (x++ show i)) <$> [2..n]---mkps :: [F.Symbol]-     -> [t] -> [(F.Symbol, F.Expr)] -> [PVar t]-mkps ns (t:ts) ((f,x):fxs) = reverse $ mkps_ ns ts fxs [(t, f, x)] []-mkps _  _      _           = panic Nothing "Bare : mkps"--mkps_ :: [F.Symbol]-      -> [t]-      -> [(F.Symbol, F.Expr)]-      -> [(t, F.Symbol, F.Expr)]-      -> [PVar t]-      -> [PVar t]-mkps_ []     _       _          _    ps = ps-mkps_ (n:ns) (t:ts) ((f, x):xs) args ps = mkps_ ns ts xs (a:args) (p:ps)-  where-    p                                   = PV n (PVProp t) (F.vv Nothing) args-    a                                   = (t, f, x)-mkps_ _     _       _          _    _ = panic Nothing "Bare : mkps_"------------------------------------------------------------------------------------isDerivedInstance :: Ghc.ClsInst -> Bool ----------------------------------------------------------------------------------isDerivedInstance i = F.notracepp ("IS-DERIVED: " ++ F.showpp classSym) -                    $ S.member classSym derivingClasses -  where -    classSym        = F.symbol . Ghc.is_cls $ i-  -derivingClasses :: S.HashSet F.Symbol -derivingClasses = S.fromList -  [ "GHC.Classes.Eq"-  , "GHC.Classes.Ord"-  , "GHC.Enum.Enum"-  , "GHC.Show.Show"-  , "GHC.Read.Read"-  , "GHC.Base.Monad"-  , "GHC.Base.Applicative"-  , "GHC.Base.Functor"-  , "Data.Foldable.Foldable"-  , "Data.Traversable.Traversable"-  -- , "GHC.Enum.Bounded"-  -- , "GHC.Base.Monoid"-  ]
+ src/Liquid/Prelude/Real_LHAssumptions.hs view
@@ -0,0 +1,7 @@+module Liquid.Prelude.Real_LHAssumptions where++import GHC.Num()++{-@+assume GHC.Num.* :: (GHC.Num.Num a) => x:a -> y:a -> {v:a | v = x * y} +@-}
+ src/Liquid/Prelude/Totality_LHAssumptions.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+module Liquid.Prelude.Totality_LHAssumptions where++import Control.Exception.Base++{-@+measure totalityError :: a -> Bool++assume Control.Exception.Base.patError :: {v:GHC.Prim.Addr# | totalityError "Pattern match(es) are non-exhaustive"} -> a++assume Control.Exception.Base.recSelError :: {v:GHC.Prim.Addr# | totalityError "Use of partial record field selector"} -> a++assume Control.Exception.Base.nonExhaustiveGuardsError :: {v:GHC.Prim.Addr# | totalityError "Guards are non-exhaustive"} -> a++assume Control.Exception.Base.noMethodBindingError :: {v:GHC.Prim.Addr# | totalityError "Missing method(s) on instance declaration"} -> a++assume Control.Exception.Base.recConError :: {v:GHC.Prim.Addr# | totalityError "Missing field in record construction"} -> a+@-}
src/LiquidHaskell.hs view
@@ -1,9 +1,4 @@-module LiquidHaskell (-    -- * LiquidHaskell Specification QuasiQuoter-    lq-    -- * LiquidHaskell as a compiler plugin-  , plugin-  ) where+{-# OPTIONS_GHC -Wno-missing-signatures #-}+module LiquidHaskell (plugin, lq) where -import Language.Haskell.Liquid.UX.QuasiQuoter-import Language.Haskell.Liquid.GHC.Plugin (plugin)+import LiquidHaskellBoot(plugin, lq)
+ src/Prelude_LHAssumptions.hs view
@@ -0,0 +1,63 @@+module Prelude_LHAssumptions where++import GHC.Base_LHAssumptions()+import GHC.Float_LHAssumptions()+import GHC.Maybe_LHAssumptions()+import GHC.Num_LHAssumptions()+import GHC.Real_LHAssumptions()+import Liquid.Prelude.Real_LHAssumptions()+import Liquid.Prelude.Totality_LHAssumptions()++{-@++assume GHC.Err.error :: {v:_ | false} -> a++// assume GHC.Integer.smallInteger :: x:GHC.Prim.Int# -> { v:GHC.Integer.Type | v = (x :: int) }++embed Integer           as int++predicate Max V X Y = if X > Y then V = X else V = Y+predicate Min V X Y = if X < Y then V = X else V = Y++type IncrListD a  = [a]<{\x y -> (x+D) <= y}>++// BOT: Do not delete EVER!++qualif Bot(v:@(0))    : (0 = 1)+qualif Bot(v:obj)     : (0 = 1)+qualif Bot(v:a)       : (0 = 1)+qualif Bot(v:bool)    : (0 = 1)+qualif Bot(v:int)     : (0 = 1)++qualif CmpZ(v:a)      : (v <  0)+qualif CmpZ(v:a)      : (v <= 0)+qualif CmpZ(v:a)      : (v >  0)+qualif CmpZ(v:a)      : (v >= 0)+qualif CmpZ(v:a)      : (v  = 0)+qualif CmpZ(v:a)      : (v != 0)++qualif Cmp(v:a, x:a)  : (v <  x)+qualif Cmp(v:a, x:a)  : (v <= x)+qualif Cmp(v:a, x:a)  : (v >  x)+qualif Cmp(v:a, x:a)  : (v >= x)+qualif Cmp(v:a, x:a)  : (v  = x)+qualif Cmp(v:a, x:a)  : (v != x)++qualif One(v:int)     : v = 1+qualif True1(v:GHC.Types.Bool)   : (v)+qualif False1(v:GHC.Types.Bool)  : (~ v)++//  REBARE constant papp1 : func(1, [Pred @(0); @(0); bool])+qualif Papp(v:a, p:Pred a) : (papp1 p v)++//  REBARE constant papp2 : func(4, [Pred @(0) @(1); @(2); @(3); bool])+qualif Papp2(v:a, x:b, p:Pred a b) : (papp2 p v x)++//  REBARE constant papp3 : func(6, [Pred @(0) @(1) @(2); @(3); @(4); @(5); bool])+qualif Papp3(v:a, x:b, y:c, p:Pred a b c) : (papp3 p v x y)++//  qualif Papp4(v:a,x:b, y:c, z:d, p:Pred a b c d) : papp4(p, v, x, y, z)+//  REBARE constant papp4 : func(8, [Pred @(0) @(1) @(2) @(6); @(3); @(4); @(5); @(7); bool])++//  REBARE constant runFun : func(2, [Arrow @(0) @(1); @(0); @(1)])+@-}
− syntax/liquid.css 
@@ -1,105 +0,0 @@-.hs-linenum {-  color: #B2B2B2; -  font-style: italic;-}--.hs-error {-  background-color: #FF8585 ;-}--.hs-keyglyph {-  color: #007020-}--.hs-keyword {-  color: #007020;-  // font-weight: bold;-}--.hs-comment, .hs-comment a {color: green;}--.hs-str, .hs-chr {color: teal;}--.hs-conid { -  color: #902000;   /* color: #00FFFF; color: #0E84B5; */-  //font-weight: bold;  -}--.hs-definition { -  color: #06287E -  /* font-weight: bold; */ -}--.hs-varid, .hs-varop, .hs-layout {-  color: black; -}--.hs-num {-  color: #40A070;-}--.hs-conop {-  color: #902000; -}--.hs-cpp {-  color: orange;-}--.hs-sel  {}--a.annot {-  position:relative; -  color:#000;-  text-decoration:none; -  white-space: pre; -}--a.annot:hover { -  z-index:25; -  background-color: #D8D8D8;-}--a.annot span.annottext{display: none}--a.annot:hover span.annottext{ -  -  border-radius: 5px 5px;-  -  -moz-border-radius: 5px; -  -webkit-border-radius: 5px; -  -  box-shadow: 5px 5px 5px rgba(0, 0, 0, 0.1); -  -webkit-box-shadow: 5px 5px rgba(0, 0, 0, 0.1);-  -moz-box-shadow: 5px 5px rgba(0, 0, 0, 0.1); --  white-space:pre;-  display:block;-  position: absolute; -  left: 1em; top: 2em; -  z-index: 99;-  margin-left: 5; -  background: #FFFFAA; -  border: 3px solid #FFAD33;-  padding: 0.8em 1em;-}--code {-   /* font-weight: bold; */-   background-color: rgb(250, 250, 250); -   border: 1px solid rgb(200, 200, 200);-   padding-left: 4px;-   padding-right: 4px;-}--pre {-  background-color: #f0f0f0;-  border-top: 1px solid #ccc;-  border-bottom: 1px solid #ccc;-  padding: 5px;-  // font-size: 120%;-  // font-family: Bitstream Vera Sans Mono,monospace;-  display: block;-  overflow: visible;-}-
− tests/Parser.hs 
@@ -1,619 +0,0 @@-{-# LANGUAGE DeriveDataTypeable  #-}-{-# LANGUAGE DoAndIfThenElse     #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}---- | Simple test suite to test the parser.------ Run as:------  $ stack test :liquidhaskell-parser--module Main where--import           Control.Monad (filterM, unless)-import           Data.Data-import           Data.Char (isSpace) -import           Data.Generics.Aliases-import           Data.Generics.Schemes--import           Language.Fixpoint.Types.Spans-import qualified Language.Haskell.Liquid.Parse as LH-import qualified Language.Fixpoint.Types       as F --import           System.Directory-import           System.FilePath--import           Text.Megaparsec.Error-import           Text.Megaparsec.Pos--import           Test.Tasty-import           Test.Tasty.HUnit-import           Test.Tasty.Runners.AntXML---- ------------------------------------------------------------------------- | Test suite entry point, returns exit failure if any test fails.-main :: IO ()--- main = do ---   print $ parseSingleSpec "type IncrListD a D = [a]<{\\x y -> (x+D) <= y}>"---   return ()-main = do-  testSpecFiles' <- testSpecFiles-  defaultMainWithIngredients (antXMLRunner:defaultIngredients) (tests testSpecFiles')--tests :: TestTree -> TestTree-tests extra =-  testGroup "ParserTests"-    ([ testSucceeds-    , testSpecP-    , testReservedAliases-    , testFails-    , testErrorReporting-    ] ++ [ extra ])---- ------------------------------------------------------------------------- | Test parsing of entire spec files.------ These are included in the normal parser tests, because they call the--- parser directly, rather than via an external invocation of the executable--- or the plugin.----testSpecFiles :: IO TestTree-testSpecFiles =-  testGroup "spec files" <$> do-    rawFiles <- listDirectory dir-    files <- filterM (doesFileExist . (dir </>)) (filter ((== ".spec") . takeExtension) rawFiles)-    pure ((\ f -> testCase f (go f)) <$> files)-  where-    dir = "tests/specfiles/pos"-    go :: FilePath -> Assertion-    go f = do-      txt <- readFile (dir </> f)-      let r = LH.specSpecificationP f txt-      case r of-        Left peb -> assertFailure (errorBundlePretty peb)-        Right _ -> pure ()---- Test that the top level production works, each of the sub-elements will be tested separately-testSpecP :: TestTree-testSpecP =-  testGroup "specP"-    [ testCase "assume" $-       parseSingleSpec "assume foo :: a -> a " @?==-          "assume foo :: lq_tmp$db##0:a -> a"--    , testCase "assert" $-       parseSingleSpec "assert myabs :: Int -> PosInt" @?==-          "assert myabs :: lq_tmp$db##0:Int -> PosInt"--    , testCase "autosize" $-       parseSingleSpec "autosize List" @?==-            "autosize List"--    , testCase "local" $-       parseSingleSpec "local foo :: Nat -> Nat" @?==-            "local assert foo :: lq_tmp$db##0:Nat -> Nat"--    , testCase "axiomatize" $-       parseSingleSpec "axiomatize fibA" @?==-            "reflect fibA"--    , testCase "reflect" $-       parseSingleSpec "reflect map" @?==-            "reflect map"--    , testCase "measure HMeas" $-       parseSingleSpec "measure isAbs" @?==-          "measure isAbs"--    , testCase "measure Meas" $-       parseSingleSpec "measure fv :: Expr -> (Set Bndr)" @?==-          "measure fv :: lq_tmp$db##0:Expr -> (Set Bndr)"--    , testCase "define" $-       parseSingleSpec "define $ceq = eqN" @?==-          "define $ceq = eqN"--    , testCase "infixl" $-       parseSingleSpec "infixl 9 +++" @?==-            "fixity"--    , testCase "infixr" $-       parseSingleSpec "infixr 9 +++" @?==-            "fixity"--    , testCase "infix" $-       parseSingleSpec "infix 9 +++" @?==-            "fixity"--    , testCase "inline" $-       parseSingleSpec "inline eqelems" @?==-            "inline eqelems"--    , testCase "bound PBound" $-       parseSingleSpec "bound Foo = true" @?==-          "bound Foo forall [] . [] =  true"--    , testCase "bound HBound" $-       parseSingleSpec "bound step" @?==-            "bound step"--    , testCase "class measure" $-       parseSingleSpec "class measure sz :: forall a. a -> Int" @?==-            "class measure sz :: forall a . lq_tmp$db##0:a -> Int"--    , testCase "instance measure" $-       parseSingleSpec "instance measure sz :: MList a -> Int" @?==-            "instance  measure sz :: lq_tmp$db##0:(MList a) -> Int"--    , testCase "instance" $-       parseSingleSpec "instance VerifiedNum Int where\n  - :: x:Int -> y:Int -> OkInt {x - y} " @?==-          "instance (VerifiedNum Int) where\n    - :: x:Int -> y:Int -> (OkInt {x - y})"--    , testCase "class" $-       parseSingleSpec "class Sized s where\n  size :: forall a. x:s a -> {v:Nat | v = sz x}" @?==-            "class  (Sized s) where\n    size :: forall a . x:s a -> {v : Nat | v == sz x}"--    , testCase "import" $-       parseSingleSpec "import Foo" @?==-          "import Foo"--    , testCase "data variance" $-       parseSingleSpec "data variance IO bivariant" @?==-          "data variance IO Bivariant"--    , testCase "data" $-       parseSingleSpec "data Bob = B {foo :: Int}" @?==-          "data Bob  [] =\n    | B :: forall . foo : Int -> *"--    , testCase "newtype" $-       parseSingleSpec "newtype Foo = Bar {x :: Nat}" @?==-          "newtype data Foo  [] =\n            | Bar :: forall . x : Nat -> *"--    , testCase "include" $-       parseSingleSpec "include <listSet.hquals>" @?==-            "include <listSet.hquals>"--    , testCase "invariant" $-       parseSingleSpec "invariant {v:Tree a | 0 <= ht v}" @?==-            "invariant {v : (Tree a) | 0 <= ht v}"--    , testCase "using" $-       parseSingleSpec "using (Tree a) as  {v:Tree a   | 0 <= height v}" @?==-            "using (Tree a) as {v : (Tree a) | 0 <= height v}"--    , testCase "type" $-       parseSingleSpec "type PosInt = {v: Int | v >= 0}" @?==-            "type PosInt  =  {v : Int | v >= 0}"--    , testCase "predicate" $-       parseSingleSpec "predicate Pos X  = X > 0" @?==-            "predicate Pos X  =  X > 0"--    , testCase "expression" $-       parseSingleSpec "expression Avg Xs = ((sumD Xs) / (lenD Xs))" @?==-          "predicate Avg Xs  =  sumD Xs / lenD Xs"--    , testCase "embed" $-       parseSingleSpec "embed Set as Set_Set" @?==-          "embed Set as Set_Set"--    , testCase "qualif" $-       parseSingleSpec "qualif Foo(v:Int): v < 0" @?==-          "qualif Foo defined at <test>:1:8"--    , testCase "decrease" $-       parseSingleSpec "decrease insert 3" @?==-          "decreasing insert [2]"--    , testCase "lazyvar" $-       parseSingleSpec "lazyvar z" @?==-          "lazyvar z"--    , testCase "lazy" $-       parseSingleSpec "lazy eval" @?==-          "lazy eval"--    , testCase "default parser (Asrts)" $-       parseSingleSpec " assumeIndices :: t:ByteStringNE -> s:BS.ByteString -> [OkPos t s]" @?==-            "assumeIndices :: t:ByteStringNE -> s:BS.ByteString -> [(OkPos t s)]"-    ]---- ------------------------------------------------------------------------- Test that haskell functions having the same name as liquidhaskell keywords are parsed correctly-testReservedAliases :: TestTree-testReservedAliases =-  testGroup "reserved aliases"-    [ testCase "assume" $-       parseSingleSpec "assume :: Int -> Bool " @?==-            "assume :: lq_tmp$db##0:Int -> Bool"--    , testCase "assert" $-       parseSingleSpec "assert :: Int -> Bool " @?==-            "assert :: lq_tmp$db##0:Int -> Bool"--    , testCase "autosize" $-       parseSingleSpec "autosize :: Int -> Bool " @?==-            "autosize :: lq_tmp$db##0:Int -> Bool"--    , testCase "axiomatize" $-       parseSingleSpec "axiomatize :: Int -> Bool " @?==-            "axiomatize :: lq_tmp$db##0:Int -> Bool"--    , testCase "reflect" $-       parseSingleSpec "reflect :: Int -> Bool " @?==-            "reflect :: lq_tmp$db##0:Int -> Bool"--    , testCase "measure" $-       parseSingleSpec "measure :: Int -> Bool " @?==-            "measure :: lq_tmp$db##0:Int -> Bool"--    , testCase "define 1" $-       parseSingleSpec "define :: Int -> Bool " @?==-            "define :: lq_tmp$db##0:Int -> Bool"--    , testCase "define 2" $-       parseSingleSpec "define GHC.Types.True = (true)" @?==-            "define GHC.Types.True = (true)"--    , testCase "defined" $-       parseSingleSpec "defined :: Int -> Bool " @?==-            "defined :: lq_tmp$db##0:Int -> Bool"--    , testCase "inline" $-       parseSingleSpec "inline :: Int -> Bool " @?==-            "inline :: lq_tmp$db##0:Int -> Bool"--    , testCase "bound" $-       parseSingleSpec "bound :: Int -> Bool " @?==-            "bound :: lq_tmp$db##0:Int -> Bool"--    , testCase "invariant" $-       parseSingleSpec "invariant :: Int -> Bool " @?==-            "invariant :: lq_tmp$db##0:Int -> Bool"--    , testCase "predicate" $-       parseSingleSpec "predicate :: Int -> Bool " @?==-            "predicate :: lq_tmp$db##0:Int -> Bool"--    , testCase "expression" $-       parseSingleSpec "expression :: Int -> Bool " @?==-            "expression :: lq_tmp$db##0:Int -> Bool"--    , testCase "embed" $-       parseSingleSpec "embed :: Int -> Bool " @?==-            "embed :: lq_tmp$db##0:Int -> Bool"--    , testCase "qualif" $-       parseSingleSpec "qualif :: Int -> Bool " @?==-            "qualif :: lq_tmp$db##0:Int -> Bool"-    ]---- -----------------------------------------------------------------------testSucceeds :: TestTree-testSucceeds =-  testGroup "Should succeed"-    [ testCase "x :: Int" $-       (parseSingleSpec "x :: Int") @?==-          "x :: Int" --    , testCase "x :: a" $-       (parseSingleSpec "x :: a") @?==-          "x :: a" --    , testCase "x :: a -> a" $-       (parseSingleSpec "x :: a -> a") @?==-          "x :: lq_tmp$db##0:a -> a"--    , testCase "x :: Int -> Int" $-       (parseSingleSpec "x :: Int -> Int") @?==-          "x :: lq_tmp$db##0:Int -> Int"--    , testCase "k:Int -> Int" $-       (parseSingleSpec "x :: k:Int -> Int") @?==-          "x :: k:Int -> Int"--    , testCase "type spec 1 " $-       parseSingleSpec "type IncrListD a D = [a]<{\\x y -> (x+D) <= y}>" @?==-          "type IncrListD a D  =  [a]<\\x##2 VV -> {y##3 : LIQUID$dummy | x##2 + D <= y##3}>"--    , testCase "type spec 2 " $-       parseSingleSpec "takeL :: Ord a => x:a -> [a] -> [{v:a|v<=x}]" @?==-          "takeL :: (Ord a) -> x:a -> lq_tmp$db##1:[a] -> [{v : a | v <= x}]"--    , testCase "type spec 3" $-       parseSingleSpec "bar :: t 'Nothing" @?==-          "bar :: t Nothing"--    , testCase "type spec 4" $-       parseSingleSpec "mapKeysWith :: (Ord k2) => (a -> a -> a) -> (k1->k2) -> OMap k1 a -> OMap k2 a" @?==-          "mapKeysWith :: (Ord k2) -> lq_tmp$db##2:(lq_tmp$db##3:a -> lq_tmp$db##4:a -> a) -> lq_tmp$db##6:(lq_tmp$db##7:k1 -> k2) -> lq_tmp$db##9:(OMap k1 a) -> (OMap k2 a)"--    , testCase "type spec 5 " $-       parseSingleSpec (unlines $-         [ "data Tree [ht] a = Nil"-         , "            | Tree { key :: a"-         , "                   , l   :: Tree {v:a | v < key }"-         , "                   , r   :: Tree {v:a | key < v }"-         , "                   }" ])-        @?==-    --      "data Tree [ht] [a] =\n    | Tree :: forall a . key : a ->l : (Tree {v : a | v < key}) ->r : (Tree {v : a | key < v}) -> *\n    | Nil :: forall a . -> *"-          "data Tree [ht] [a] = \ -           \     | Nil :: forall a . -> * \-           \     | Tree :: forall a . key : a ->l : (Tree {v : a | v < key}) ->r : (Tree {v : a | key < v}) -> *"    --    , testCase "type spec 6" $-       parseSingleSpec "type AVLL a X    = AVLTree {v:a | v < X}" @?==-         "type AVLL a X  =  (AVLTree {v : a | v < X})"--    , testCase "type spec 7" $-       parseSingleSpec "type AVLR a X    = AVLTree {v:a |X< v} " @?==-         "type AVLR a X  =  (AVLTree {v : a | X < v})"--    , testCase "type spec 8 " $-       parseSingleSpec (unlines $-      [ "assume (++) :: forall <p :: a -> Bool, q :: a -> Bool, r :: a -> Bool>."-      , "  {x::a<p> |- a<q> <: {v:a| x <= v}} "-      , "  {a<p> <: a<r>} "-      , "  {a<q> <: a<r>} "-      , "  Ord a => OList (a<p>) -> OList (a<q>) -> OList a<r> "])-        @?==-          -- "assume (++) :: forall <p :: a -> Bool, q :: a -> Bool, r :: a -> Bool> .\n               (Ord a) =>\n               {x :: {VV : a<p> | true} |- {VV : a<q> | true} <: {v : a | x <= v}} =>\n               {|- {VV : a<p> | true} <: {VV : a<r> | true}} =>\n               {|- {VV : a<q> | true} <: {VV : a<r> | true}} =>\n               lq_tmp$db##13:(OList {VV : a<p> | true}) -> lq_tmp$db##15:(OList {VV : a<q> | true}) -> (OList {VV : a<r> | true})"-         (unlines -           [ "assume (++) :: forall <p##1##23 :: a -> Bool, q##1##23 :: a -> Bool, r##1##23 :: a -> Bool>."-           , "               (Ord a) =>"-           , "               {x :: {VV : a<p##1##23> | true} |- {VV : a<q##1##23> | true} <: {v : a | x <= v}} =>"-           , "               {|- {VV : a<p##1##23> | true} <: {VV : a<r##1##23> | true}} =>"-           , "               {|- {VV : a<q##1##23> | true} <: {VV : a<r##1##23> | true}} =>"-           , "               lq_tmp$db##13:(OList {VV : a<p##1##23> | true}) -> lq_tmp$db##15:(OList {VV : a<q##1##23> | true}) -> (OList {VV : a<r##1##23> | true})"-         ])-    , testCase "type spec 9" $-       parseSingleSpec (unlines $-          [ "data AstF f <ix :: AstIndex -> Bool>"-          , "  = Lit Int    (i :: AstIndex<ix>)"-          , "  | Var String (i :: AstIndex<ix>)"-          , "  | App (fn :: f) (arg :: f)"-          , "  | Paren (ast :: f)" ])-          @?==-            unlines-              [ "data AstF [f] ="-              , "  | App :: forall f . fn : f ->arg : f -> *"-              , "  | Lit :: forall f . lq_tmp$db##2 : Int ->i : (AstIndex <{VV : _<ix> | true}>) -> *"-              , "  | Paren :: forall f . ast : f -> *"-              , "  | Var :: forall f . lq_tmp$db##4 : String ->i : (AstIndex <{VV : _<ix> | true}>) -> *"-              ]--    , testCase "type spec 10" $-       parseSingleSpec "assume     :: b:_ -> a -> {v:a | b} " @?==-          "assume :: b:{VV : _ | $HOLE} -> lq_tmp$db##0:a -> {v : a | b}"--    , testCase "type spec 11" $-       parseSingleSpec (unlines $-          [ "app :: forall <p :: Int -> Bool, q :: Int -> Bool>. "-          , "       {Int<q> <: Int<p>}"-          , "       {x::Int<q> |- {v:Int| v = x + 1} <: Int<q>}"-          , "       (Int<p> -> ()) -> x:Int<q> -> ()" ])-          @?==- --            "app :: forall <p :: Int -> Bool, q :: Int -> Bool> .\n       {|- (Int <{VV : _<q> | true}>) <: (Int <{VV : _<p> | true}>)} =>\n       {x :: (Int <{VV : _<q> | true}>) |- {v : Int | v == x + 1} <: (Int <{VV : _<q> | true}>)} =>\n       lq_tmp$db##8:(lq_tmp$db##9:(Int <{VV : _<p> | true}>) -> ()) -> x:(Int <{VV : _<q> | true}>) -> ()"-            (unlines -              [ "app :: forall <p##1##15 :: Int -> Bool, q##1##15 :: Int -> Bool>."-              , "       {|- (Int <{VV : _<q##1##15> | true}>) <: (Int <{VV : _<p##1##15> | true}>)} =>"-              , "       {x :: (Int <{VV : _<q##1##15> | true}>) |- {v : Int | v == x + 1} <: (Int <{VV : _<q##1##15> | true}>)} =>"-              , "       lq_tmp$db##8:(lq_tmp$db##9:(Int <{VV : _<p##1##15> | true}>) -> ()) -> x:(Int <{VV : _<q##1##15> | true}>) -> ()"-            ])--    , testCase "type spec 12" $-       parseSingleSpec (unlines $-          [ " ssum :: forall<p :: a -> Bool, q :: a -> Bool>. "-          , "         {{v:a | v == 0} <: a<q>}"-          , "         {x::a<p> |- {v:a | x <= v} <: a<q>}"-          , "         xs:[{v:a<p> | 0 <= v}] -> {v:a<q> | len xs >= 0 && 0 <= v } "])-          @?==-            -- "ssum :: forall <p :: a -> Bool, q :: a -> Bool> .\n        {|- {v : a | v == 0} <: {VV : a<q> | true}} =>\n        {x :: {VV : a<p> | true} |- {v : a | x <= v} <: {VV : a<q> | true}} =>\n        xs:[{v : a<p> | 0 <= v}] -> {v : a<q> | len xs >= 0\n                                                && 0 <= v}"-           (unlines -              [ "ssum :: forall <p##1##16 :: a -> Bool, q##1##16 :: a -> Bool>."-              , "        {|- {v : a | v == 0} <: {VV : a<q##1##16> | true}} =>"-              , "        {x :: {VV : a<p##1##16> | true} |- {v : a | x <= v} <: {VV : a<q##1##16> | true}} =>"-              , "        xs:[{v : a<p##1##16> | 0 <= v}] -> {v : a<q##1##16> | len xs >= 0"-              , "                                                              && 0 <= v}"-           ])-    , testCase "type spec 13" $-       -- removing duplicate conjuncts also affects the order in which the-       -- surviving conjuncts are returned-       parseSingleSpec (unlines $-          [ " predicate ValidChunk V XS N "-          , " = if len XS == 0 "-          , "     then (len V == 0) "-          , "     else (((1 < len XS && 1 < N) => (len V  < len XS)) "-          , "       && ((len XS <= N ) => len V == 1)) "])-          @?==-          unlines-          [ "predicate ValidChunk V  XS  N  = "-          , "  (not (len XS == 0) =>"-          , "     (1 < N && 1 < len XS => len V < len XS)"-          , "     && (len XS <= N => len V == 1)"-          , "  )"-          , "  && (len XS == 0 => len V == 0)"-          ]---    , testCase "type spec 14" $-       parseSingleSpec "assume (=*=.) :: Arg a => f:(a -> b) -> g:(a -> b) -> (r:a -> {f r == g r}) -> {v:(a -> b) | f == g}" @?==-            "assume (=*=.) :: (Arg a) -> f:(lq_tmp$db##1:a -> b) -> g:(lq_tmp$db##3:a -> b) -> lq_tmp$db##5:(r:a -> {VV : _ | f r == g r}) -> lq_tmp$db##6:a -> b"--    , testCase "type spec 15" $-       parseSingleSpec "sort :: (Ord a) => xs:[a] -> OListN a {len xs}" @?==-           "sort :: (Ord a) -> xs:[a] -> (OListN a {len xs})"--    , testCase "type spec 16" $-       parseSingleSpec " ==. :: x:a -> y:{a| x == y} -> {v:b | v ~~ x && v ~~ y } " @?==-            "==. :: x:a -> y:{y : a | x == y} -> {v : b | v ~~ x\n                                             && v ~~ y}"--    , testCase "type spec 17" $-       parseSingleSpec "measure snd :: (a,b) -> b" @?==-            "measure snd :: lq_tmp$db##0:(a, b) -> b"--    , testCase "type spec 18" $-       parseSingleSpec "returnST :: xState:a \n             -> ST <{\\xs xa v -> (xa = xState)}> a s " @?==-           "returnST :: xState:a -> (ST <\\xs##1 xa##2 VV -> {v##3 : LIQUID$dummy | xa##2 == xState}> a s)"--    , testCase "type spec 19" $-       parseSingleSpec "makeq :: l:_ -> r:{ _ | size r <= size l + 1} -> _ " @?==-           "makeq :: l:{VV : _ | $HOLE} -> r:{r : _ | size r <= size l + 1} -> {VV : _ | $HOLE}"--    , testCase "type spec 21" $-       parseSingleSpec "newRGRef :: forall <p :: a -> Bool, r :: a -> a -> Bool >.\n   e:a<p> ->\n  e2:a<r e> ->\n  f:(x:a<p> -> y:a<r x> -> {v:a<p> | (v = y)}) ->\n IO (RGRef <p, r> a)" @?==-            -- "newRGRef :: forall <p :: a -> Bool, r :: a a -> Bool> .\n            e:{VV : a<p> | true} -> e2:{VV : a<r e> | true} -> f:(x:{VV : a<p> | true} -> y:{VV : a<r x> | true} -> {v : a<p> | v == y}) -> (IO (RGRef <{VV : _<p> | true}, {VV : _<r> | true}> a))"-            (unlines [ "newRGRef :: forall <p##1##20 :: a -> Bool, r##1##20 :: a a -> Bool>."-                     , "            e:{VV : a<p##1##20> | true} -> e2:{VV : a<r##1##20 e> | true} -> f:(x:{VV : a<p##1##20> | true} -> y:{VV : a<r##1##20 x> | true} -> {v : a<p##1##20> | v == y}) -> (IO (RGRef <{VV : _<p##1##20> | true}, {VV : _<r##1##20> | true}> a))"-                     ]-            )-    , testCase "type spec 21" $-       parseSingleSpec "cycle        :: {v: [a] | len(v) > 0 } -> [a]" @?==-            "cycle :: v:{v : [a] | len v > 0} -> [a]"--    , testCase "type spec 22" $-       parseSingleSpec "cons :: x:a -> _ -> {v:[a] | hd v = x} " @?==-         "cons :: x:a -> lq_tmp$db##0:{VV : _ | $HOLE} -> {v : [a] | hd v == x}"--    , testCase "type spec 23" $-       parseSingleSpec "set :: a:Vector a -> i:Idx a -> a -> {v:Vector a | vlen v = vlen a}" @?==-         "set :: a:(Vector a) -> i:(Idx a) -> lq_tmp$db##0:a -> {v : (Vector a) | vlen v == vlen a}"--    , testCase "type spec 24" $-       parseSingleSpec "assume GHC.Prim.+#  :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v: GHC.Prim.Int# | v = x + y}" @?==-         "assume GHC.Prim.+# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v : GHC.Prim.Int# | v == x + y}"--    , testCase "type spec 25" $-       parseSingleSpec " measure isEVar " @?==-         "measure isEVar"--    , testCase "type spec 26" $-       parseSingleSpec (unlines $-         [ "data List a where"-         , "    Nil  :: List a "-         , "    Cons :: listHead:a -> listTail:List a -> List a  "])-        @?==-            "data List  [a] =\n    | Cons :: forall a . listHead : a ->listTail : (List a) -> (List a)\n    | Nil :: forall a . -> (List a)"--    , testCase "type spec 27" $-       parseSingleSpec (unlines $-         [ "data List2 a b <p :: a -> Bool> where"-         , "    Nil2  :: List2 a "-         , "    Cons2 :: listHead:a -> listTail:List a -> List2 a b"])-        @?== -           "data List2  [a, b] = \ -            \  | Cons2 :: forall a b . listHead : a ->listTail : (List a) -> (List2 a b) \-            \  | Nil2 :: forall a b . -> (List2 a)"--    , testCase "type spec 28" $-       parseSingleSpec (unlines $-         [ "data Ev :: Peano -> Prop where"-         , "  EZ  :: Prop (Ev Z)"-         , "  ESS :: n:Peano -> Prop (Ev n) -> Prop (Ev (S (S n)))"-         ])-        @?==-            "data Ev  [] =\n    | ESS :: forall . n : Peano ->lq_tmp$db##4 : (Prop (Ev n)) -> (Prop (Ev (S (S n))))\n    | EZ :: forall . -> (Prop (Ev Z))"--    , testCase "type spec 29" $-       parseSingleSpec (unlines $-         [ "measure fst :: (a,b) -> a"-         , "  fst (a,b) = a"-         ])-        @?==-            "measure fst :: lq_tmp$db##0:(a, b) -> a\n        fst ((,)a b) = a"-    ]---- -----------------------------------------------------------------------testFails :: TestTree-testFails =-  testGroup "Does fail"-    [ testCase "Maybe k:Int -> Int" $-          parseSingleSpec "x :: Maybe k:Int -> Int" @?==-            unlines-              [ "<test>:1:13:"-              , "  |"-              , "1 | x :: Maybe k:Int -> Int"-              , "  |             ^"-              , "unexpected ':'"-              , "expecting \"->\", \"=>\", \"~>\", '/', bareTyArgP, end of input, mmonoPredicateP, or monoPredicateP"-              ]-    ]----- -----------------------------------------------------------------------testErrorReporting :: TestTree-testErrorReporting =-  testGroup "Error reporting"-    [ testCase "assume mallocForeignPtrBytes :: n:Nat -> IO (ForeignPtrN a n " $-          parseSingleSpec "assume mallocForeignPtrBytes :: n:Nat -> IO (ForeignPtrN a n " @?==-            unlines-              [ "<test>:1:45:"-              , "  |"-              , "1 | assume mallocForeignPtrBytes :: n:Nat -> IO (ForeignPtrN a n "-              , "  |                                             ^"-              , "unexpected '('"-              , "expecting \"->\", \"=>\", \"~>\", end of input, mmonoPredicateP, or predicatesP"-              ]-    , testCase "Missing |" $-          parseSingleSpec "ff :: {v:Nat  v >= 0 }" @?==-            unlines-              [ "<test>:1:17:"-              , "  |"-              , "1 | ff :: {v:Nat  v >= 0 }"-              , "  |                 ^^"-              , "unexpected \">=\""-              , "expecting \"->\", \"<:\", \"=>\", \"~>\", '|', bareTyArgP, mmonoPredicateP, or monoPredicateP"-              ]-    ]---- ------------------------------------------------------------------------- | Parse a single type signature containing LH refinements. To be--- used in the REPL.----parseSingleSpec :: String -> String-parseSingleSpec src =-  case LH.singleSpecP (initialPos "<test>") src of-    Left err  -> errorBundlePretty err-    Right res -> F.showpp res -- show (dummyLocs res)--gadtSpec :: String-gadtSpec = unlines-  [ "data Ev where"-  , "   EZ  :: {v:Ev | prop v = Ev Z}"-  , " | ESS :: n:Peano -> {v:Ev | prop v = Ev n} -> {v:Ev | prop v = Ev (S (S n)) }"-  ]--deSpace :: String -> String-deSpace = filter (not . isSpace)--(@?==) :: HasCallStack => String -> String -> Assertion-actual @?== expected =-  assertEqualModuloSpace expected actual--assertEqualModuloSpace :: HasCallStack => String -> String -> Assertion-assertEqualModuloSpace expected actual =-  unless (deSpace expected == deSpace actual) (assertFailure msg)-  where-    msg =-      "expected (modulo whitespace):\n" ++ unlines (map ("  | " ++) (lines expected)) ++ "\n" ++-      " but got (modulo whitespace):\n" ++ unlines (map ("  | " ++) (lines actual))----------------------------------------------------------------------------dummyLocs :: (Data a) => a -> a-dummyLocs = everywhere (mkT posToDummy)-  where-    posToDummy :: SourcePos -> SourcePos-    posToDummy _ = dummyPos "Fixpoint.Types.dummyLoc"---- ---------------------------------------------------------------------
− tests/Synthesis.hs 
@@ -1,153 +0,0 @@-{-# LANGUAGE TupleSections #-}--module Main where--import           Test.Tasty -import           Test.Tasty.HUnit--import qualified Data.Text    as T-import qualified Data.Text.IO as T-import           System.FilePath-import           System.Process-import           System.IO-import           System.Directory-import           System.Exit-import           System.IO.Unsafe-import           Data.Tuple.Extra------------------------------------------------------------------ | Contains the input files---------------------------------------------------------------synthesisTestsDir :: FilePath-synthesisTestsDir = "tests/synthesis/tests"-------------------------------------------------------------------------------------------------------------------------------- | Contains the results of the synthesis on the inputs---------------------------------------------------------------logDir :: FilePath-logDir = "tests/synthesis/logs"-------------------------------------------------------------------------------------------------------------------------------- | Contains the outputs that we need to check logs against---------------------------------------------------------------outputsDir :: FilePath-outputsDir = "tests/synthesis/static"----------------------------------------------------------------main :: IO ()-main = do -    print " Synthesis test suite "-    result <- fromInput-    defaultMain (tests result)--fromInput :: IO [(FilePath, T.Text, [[T.Text]])]-fromInput = do-    res <- createLogs -- Get the filename from here-    logs <- handleLogs (map thd3 res)-    let filenames = map fst3 res-        programNames = map (head . T.words . head . head) logs -        result = zip3 filenames programNames logs-    return result--handleLogs :: [T.Text] -> IO [[[T.Text]]]-handleLogs texts -    = return (map handleLog texts)--keyword :: T.Text-keyword = T.pack " Hole Fills:"--startsWith :: T.Text -> T.Text -> Bool-startsWith kw line = T.isPrefixOf kw line---- | @walkFile@ returns empty means that there is no solution produced ---              for given specification (needs to be checked)--walkFile :: T.Text -> [T.Text]-walkFile text = dropWhile (not . startsWith keyword) ls-    where ls = T.lines text ---- | Lines from the solution in the log file (without trailing characters)-handleLog :: T.Text -> [[T.Text]]-handleLog text =-    let toBeParsed = walkFile text-        sols = T.splitOn (T.pack delim) (T.unlines (tail toBeParsed))-        noTrailing = map (filter (not . T.null)) (map (map T.strip) (map T.lines sols))-    in  noTrailing---delim :: String-delim = "*********************************************"---createLogs :: IO [(FilePath, ExitCode, T.Text)]-createLogs = do -    files <- listDirectory synthesisTestsDir-    let testFiles = filter (\x -> takeExtension x == ".hs") files-    res <- mapM runLiquid testFiles-    let (ecs, ts) = unzip res-        fs = map dropExtension testFiles-    return (zip3 fs ecs ts)--runLiquid :: FilePath -> IO (ExitCode, T.Text)-runLiquid tgt = do-    let inFile = synthesisTestsDir </> tgt-        log    = logDir </> (dropExtension tgt <.> ".log")-    -- use `liquid` if its on the path, otherwise use stack to call it-    bin <- maybe "stack exec -- liquid"-        ( <> " --ghc-option=-hide-package=base"-          <> " --ghc-option=-hide-package=containers"-        ) <$> findExecutable "liquid"-    withFile log WriteMode $ \h -> do-        (_, _, _, ph) <- createProcess $ (shell (bin ++ ' ' : inFile)) { std_out = UseHandle h, std_err = UseHandle h }-        exitCode      <- waitForProcess ph-        (exitCode, ) <$> T.readFile log---getSolutions :: FilePath -> IO T.Text-getSolutions tgt = do-    let file = outputsDir </> tgt-    T.readFile file-    -mkTgt :: FilePath -> FilePath-mkTgt t = addExtension t ".hs"------ | Get solution from outputs line by line in order to compare-lineFile :: T.Text -> T.Text -> [T.Text]-lineFile progName file = -    dropWhile (\x -> not (startsWith (progName `T.append` (T.pack " ")) x) || -                     startsWith (progName `T.append` (T.pack " ::")) x) (T.lines file)--clean :: [T.Text] -> [T.Text]-clean ls = filter (not . T.null) (map T.strip ls)--processAnswers :: [(FilePath, T.Text, [[T.Text]])] -> [(FilePath, [[T.Text]], [T.Text])]-processAnswers = map processAnswer --processAnswer :: (FilePath, T.Text, [[T.Text]]) -> (FilePath, [[T.Text]], [T.Text])-processAnswer (fp, prog, ts) = -    let file = unsafePerformIO (getSolutions (mkTgt fp))-        fileLines = lineFile prog file-        cleanLines = clean fileLines-    in  (fp, ts, cleanLines) --compareLines :: [T.Text] -> [T.Text] -> Bool-compareLines [] [] = True-compareLines (t:ts) (l:ls) = t == l && compareLines ts ls-compareLines _ _ = False--buildTestCase :: (FilePath, [[T.Text]], [T.Text]) -> TestTree-buildTestCase (fp, ls, ts) -    = testCase -        fp -        ((foldr (\l b -> compareLines ts l || b) False ls) @?= True)--tests :: [(FilePath, T.Text, [[T.Text]])] -> TestTree-tests inputs = -    let answers = processAnswers inputs-        units   = map buildTestCase answers-    in  testGroup " Tests for synthesis " units-
− tests/errors/AmbiguousInline.hs 
@@ -1,220 +0,0 @@-{-@ LIQUID "--scrape-used-imports" @-}-{-@ LIQUID "--short-names" @-}--{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--module AmbiguousInline where--import qualified Data.ByteString as BS--- RJ import qualified Data.ByteString.Search as BS-import Data.Char--- RJ import Data.List.Split(chunksOf)--import Data.Monoid-import Data.Proxy-import Debug.Trace-import GHC.TypeLits--import Language.Haskell.Liquid.Prelude (liquidAssert)--- FIX import Prelude hiding (min, max)-import Prelude hiding (max)--junk = BS.head---traceMsg msg x = trace (msg ++ show x) x--{-@ chunksBS :: Int -> b:BS.ByteString -> [BS.ByteString] / [(bLength b)] @-}-chunksBS n' xs | BS.null xs = []-               | otherwise = x : chunksBS n xs'-    where (x,xs') = BS.splitAt  (liquidAssert (n > 0) n) xs-          n       = max 1 n'--bsToString :: BS.ByteString -> String-bsToString = map (chr . fromIntegral) . BS.unpack--stringToBS :: String -> BS.ByteString-stringToBS = BS.pack . map (fromIntegral . ord)---- | get the (proxied and existentially boxed) type level Symbol for a bytestring-someSymbolValBS :: BS.ByteString -> SomeSymbol-someSymbolValBS = someSymbolVal . bsToString---- | get the bytestring corresponding to a type level Symbol-mkTarg :: forall t . KnownSymbol t => Proxy t -> BS.ByteString-mkTarg = stringToBS . symbolVal----- | Naive specification of string matching (from Bird)-{-@ indicesSpec :: t:ByteStringNE -> s:BS.ByteString -> [OkPos t s] @-}--- indicesSpec targ = map ((BS.length targ -) . BS.length) . filter (targ `BS.isSuffixOf`) . BS.inits-indicesSpec targ s = [ BS.length s' - BS.length targ | s' <- BS.inits s-                                                     , targ `BS.isSuffixOf` s' ]--indicesSpec :: BS.ByteString -> BS.ByteString -> [Int]------ | Datatype to name string matching algorithms; will use it's lifted--- version put choice in type.-data Alg = BM  -- ^ Boyer-Moore from stringsearch package-         | Spec  -- ^ Naive spec--{-@ indices :: Alg -> t:ByteStringNE -> s:BS.ByteString -> [OkPos t s] @-}-indices BM   = assumeIndices -- RJ BS.indices-indices Spec = indicesSpec----- | Monoid------ 'MatchIdxs alg targ' denotes the result of running string matching--- algorithm 'alg' search for target 'targ' in some input. In addition--- to the match indices, information needed to combine this result--- with similar results on input to the left and right are also--- included.------ We'd like to prove that the invariants in the comments hold (|x|--- denotes the length of x).-data MatchIdxs-    = Small { targ :: BS.ByteString-            , bs   :: BS.ByteString-            }-    | MatchIdxs { targ    :: BS.ByteString-                , input   :: Int-                , left    :: BS.ByteString-                , matches :: [Int]-                , right   :: BS.ByteString-                }-  deriving (Eq, Show)--{-@ data MatchIdxs-      = Small { targ    :: ByteStringNE-              , bs      :: {v:BS.ByteString | bLength v < bLength targ}-              }--      | MatchIdxs-              { targ    :: ByteStringNE-              , input   :: {v : Int | v >= bLength targ}-              , left    :: {v : BS.ByteString | bLength v == bLength targ - 1}-              , matches :: [{v:Int | v <= input - bLength targ}]-              , right   :: {v : BS.ByteString | bLength v == bLength targ - 1}-              }-  @-}---matchIdxsIs :: MatchIdxs -> [Int]-matchIdxsIs (Small _ _) = []-matchIdxsIs (MatchIdxs _ _ _ is _) = is---- | create a 'MatchIdxs'-{-@ myIndices :: Alg -> t:ByteStringNE -> BS.ByteString -> MatchIdxsT t @-}-myIndices alg t bs-  | BS.length bs > fringeLen = let right1 = BS.drop (BS.length bs - fringeLen) bs in-                                MatchIdxs t (BS.length bs) left is right1-  | otherwise = Small t bs-  where-    is        = indices alg t bs-    fringeLen = BS.length t - 1-    left      = BS.take fringeLen bs-    -- right1    = BS.drop (BS.length bs - fringeLen) bs---- ISSUE: get contextual output with --diff--- ISSUE: why does lazyvar right1 not work? it drops the output type on right1!--{- lazyvar right1 -}--{-@ type OkPos Targ Str = {v:Nat | v <= bLength Str - bLength Targ} @-}-{-@ type ByteStringNE   = {v:BS.ByteString | bLength v > 0 }   @-}-{-@ type ByteStringN N  = {v:BS.ByteString | bLength v == N}   @-}-{-@ type MatchIdxsT T   = {v:MatchIdxs | targ v == T}          @-}--{-@ assume BS.isSuffixOf :: targ:_ -> s:_ -> {v:_ | v => (bLength targ <= bLength s) } @-}-{-@ assume BS.length  :: b:BS.ByteString -> {v:Nat | v == bLength b}  @-}-{-@ assume BS.empty   :: {v:BS.ByteString | bLength v == 0}    @-}-{-@ assume BS.take    :: n:Nat -> b:BS.ByteString -> ByteStringN {min n (bLength b)} @-}-{-@ assume BS.drop    :: n:Nat -> b:{BS.ByteString | n <= bLength b} -> ByteStringN {bLength b - n} @-}-{-@ assume BS.inits   :: b:BS.ByteString -> [{v:BS.ByteString | bLength v <= bLength b}] @-}-{-@ assume BS.append  :: b1:BS.ByteString -> b2:BS.ByteString -> ByteStringN {bLength b1 + bLength b2} @-}-{-@ assume BS.null    :: b:BS.ByteString -> {v:Bool | v <=> (bLength b == 0)} @-}-{-@ assume BS.splitAt :: n:Nat -> b:BS.ByteString -> (ByteStringN {min n (bLength b)}, ByteStringN {max 0 (bLength b - n)}) @-}-{-@ assume BS.head    :: BS.ByteString -> _ @-}--{-@ measure target @-}-target :: MatchIdxs -> BS.ByteString-target (Small t _)           = t-target (MatchIdxs t _ _ _ _) = t--{-@ inline min @-}-min :: Int -> Int -> Int-min x y = if x <= y then x else y--{-@ inline max @-}-max :: Int -> Int -> Int-max x y = if x <= y then y else x---- RJ instance (KnownSymbol t, StringMatch alg) => Monoid (MatchIdxs alg t) where-{-@ mmempty :: t:ByteStringNE -> MatchIdxsT t @-}-mmempty t = Small t BS.empty--{-@ mmconcat :: (Foldable t) => Alg -> tg:ByteStringNE -> t (MatchIdxsT tg) -> (MatchIdxsT tg) @-}-mmconcat alg t = foldr (mmappend alg t) (mmempty t)--{-@ qualif BB(v:Int, n:Int, d:Int, b:BS.ByteString): v <= (n + d) - bLength b @-}--{-@ mmappend :: Alg -> t:ByteStringNE -> MatchIdxsT t -> MatchIdxsT t -> MatchIdxsT t @-}-mmappend alg t mx my =-  let fringeLen = BS.length t - 1-      idxFun    = indices alg t-  in-  case (mx, my) of-    (Small tx x, Small _ y) -> myIndices alg tx (x <> y)-    (Small tx x, MatchIdxs _ yLen ly iy rt) -> MatchIdxs tx xyLen lt is rt-       where-         xyLen = xLen + yLen-         xLen  = BS.length x-         xly   = BS.append x ly-         lt    = BS.take fringeLen xly-         is    = idxFun xly ++ map (+ xLen) iy-    (MatchIdxs tx xLen lt ix rx, Small ty y) -> MatchIdxs tx xyLen lt (ix ++ is) rt-       where-         xyLen = xLen + yLen-         yLen  = BS.length y-         is    = map (+ (xLen - fringeLen)) (idxFun rxy)-         rt    = BS.drop (BS.length rxy - fringeLen) rxy-         rxy   = BS.append rx y-    (MatchIdxs tx xLen lt ix rx, MatchIdxs ty yLen ly iy rt) -> MatchIdxs tx xyLen lt (ix ++ is) rt-       where-         xyLen = xLen + yLen-         is    = ixy ++ map (+ xLen) iy-         ixy   = map (+ (xLen - fringeLen)) $ idxFun (BS.append rx ly)---- | Example applications------ The bufLen and chunkSz arguments are there to exercise the monoid,--- though they also foreshadow a parallel implementation.-{-@ indicesBS' :: Alg -> Int -> Int -> ByteStringNE -> BS.ByteString -> [Int] @-}-indicesBS' alg bufLen chunkSz t bs =-  let si = mmconcat alg t . map (mmconcat alg t) . chunksOf bufLen . map (myIndices alg t) $ chunksBS chunkSz bs in-  matchIdxsIs si--{-@ indicesBS, indicesNaive :: Int -> Int -> ByteStringNE -> BS.ByteString -> [Int] @-}-indicesBS    = indicesBS' BM   -- RJ (Proxy :: Proxy BM)-indicesNaive = indicesBS' Spec -- RJ (Proxy :: Proxy Spec)--{-@ isInfixOfBS :: Int -> Int -> ByteStringNE -> BS.ByteString -> Bool @-}-isInfixOfBS bufLen chunkSz t = not . null . indicesBS bufLen chunkSz t---------------------------------------------------------------------------------------------{-@ invariant {v:BS.ByteString | 0 <= bLength v } @-}-{-@ measure bLength :: BS.ByteString -> Int @-}-{-@ type LNat N = {v:Nat | v < N} @-}--chunksOf :: Int -> [a] -> [[a]]-chunksOf = undefined--{-@ assumeIndices :: t:ByteStringNE -> s:BS.ByteString -> [OkPos t s] @-}-assumeIndices :: BS.ByteString -> BS.ByteString -> [Int]-assumeIndices = undefined
− tests/errors/AmbiguousReflect.hs 
@@ -1,18 +0,0 @@-{-@ LIQUID "--reflection"  @-}--module AmbiguousReflect where---- ISSUE: Uncomment the below to make this test pass------    import Prelude hiding (mappend)--- --- LH should give an error message indicating the above.--data D = D Int Int --{-@ reflect mappend @-}-mappend :: D -> D -> D --{-@ mappend :: x:D -> D -> {v:D | v == x} @-}-mappend x@(D i1 i2) (D i3 i4) = x-
− tests/errors/BadAliasApp.hs 
@@ -1,8 +0,0 @@-{-@ LIQUID "--expect-error-containing=Malformed application of type alias `ListN`" @-}-module BadAliasApp where--{-@ type ListN a N = {v:[a] | len v = N} @-}--{-@ foo :: ListN 0 0 @-}-foo :: [a]-foo = undefined
− tests/errors/BadAnnotation.hs 
@@ -1,6 +0,0 @@-{-@ LIQUID "--expect-error-containing=Malformed annotation" @-}-module BadAnnotation where--{-@ incr :: x:Int -> {v:Int | x < v } -}-incr :: Int -> Int-incr x = x - 1
− tests/errors/BadAnnotation1.hs 
@@ -1,8 +0,0 @@-{-@ LIQUID "--expect-error-containing=Malformed annotation" @-}-module BadAnnotation1 where--{-@ incr :: x:Int -         -> {v:Int | x < v } -  -}-incr :: Int -> Int-incr x = x - 1
− tests/errors/BadData0.hs 
@@ -1,7 +0,0 @@-{-@ LIQUID "--expect-error-containing=Unknown type constructor `Zoog`" @-}-module BadData0 where--data Zog = Z Int-{-@ data Zoog = Z { mkZ :: Nat } @-}--frog = Z (0 - 5)
− tests/errors/BadData1.hs 
@@ -1,43 +0,0 @@-{-@ LIQUID "--expect-error-containing=Data constructors in refinement do not match original datatype for `EntityField`" @-}-{-@ LIQUID "--no-adt"         @-}-{-@ LIQUID "--exact-data-con" @-}--{-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-}--module BadData1 where--class PersistEntity record where-    data EntityField record :: * -> *---- The reason this fails is because the refinement uses 'record'--- instead of 'Blob'. Therefore, the lookup for the GHC datatype--- will return no constructors, and consequently, LH complains--- that our refinement has two.----instance PersistEntity Blob where-    {-@ data EntityField record typ where-           BlobXVal :: EntityField Blob {v:Int | v >= 0}-           BlobYVal :: EntityField Blob Int-    @-}-    data EntityField Blob typ where-        BlobXVal :: EntityField Blob Int-        BlobYVal :: EntityField Blob Int---{-@ data Blob  = B { xVal :: {v:Int | v >= 0}, yVal :: Int } @-}-data Blob = B { xVal :: Int, yVal :: Int }--{-@ blobXVal :: EntityField Blob {v:Int | v >= 0} @-}-blobXVal :: EntityField Blob Int-blobXVal = BlobXVal---- OK--- testUpdateQuery :: () -> Update Blob Int--- testUpdateQuery () = createUpdate blobXVal 3---- BAD--- testUpdateQueryFail :: () -> Update Blob Int--- testUpdateQueryFail () = createUpdate blobXVal (-1)--main :: IO ()-main = pure ()
− tests/errors/BadData2.hs 
@@ -1,16 +0,0 @@-{-@ LIQUID "--expect-error-containing=Data constructors in refinement do not match original datatype for `Hog`" @-}-{-@ LIQUID "--exact-data-cons" @-}--module BadData2 where---- The reason this fails is because the constructor we use in the--- refinement for Hog is in fact a constructor of T.-{-@ data Hog where  -      Cuthb :: Nat -> T -  @-}--data Hog = H Int --data T = Cuthb { fldX :: Int }--zoink = Cuthb (-1)
− tests/errors/BadDataCon2.hs 
@@ -1,6 +0,0 @@-{-@ LIQUID "--expect-error-containing=GHC and Liquid specifications have different numbers of fields for `BadDataCon2.Cuthb`" @-}-module BadDataCon2 where--{-@ data T = Cuthb { fldX :: Int, fldY :: Int } @-}--data T = Cuthb { fldX :: Int }
− tests/errors/BadDataConType.hs 
@@ -1,7 +0,0 @@-{-@ LIQUID "--expect-error-containing=Illegal type specification for `BadDataConType.fldY`" @-}-{-@ LIQUID "--expect-error-containing=Specified type does not refine Haskell type for `BadDataConType.fldY`" @-}-module BadDataConType where--{-@ data T = C { fldX :: Int, fldY :: Bool } @-}--data T = C { fldX :: Int, fldY :: Int }
− tests/errors/BadDataConType1.hs 
@@ -1,6 +0,0 @@-{-@ LIQUID "--expect-error-containing=Specified type does not refine Haskell type for `BadDataConType1.C`" @-}-module BadDataConType1 where--{-@ data T = C { fldX :: Int, fldY :: String } @-}--data T = C { fldX :: Int, fldY :: Int }
− tests/errors/BadDataConType2.hs 
@@ -1,6 +0,0 @@-{-@ LIQUID "--expect-error-containing=different numbers of fields for `BadDataConType2.C`" @-}-module BadDataConType2 where--{-@ data T = C { fldX :: Int } @-}--data T = C { fldX :: Int, fldY :: Int }
− tests/errors/BadDataDeclTyVars.hs 
@@ -1,25 +0,0 @@-{-@ LIQUID "--expect-error-containing=Mismatch in number of type variables for `L`" @-}--- | With ADTs, the below fails with a nasty 'elaborate' error, when---   the actual problem is a malformed refined data-declaration where---   the type variable 'a' has been left out.------   We should flag a proper malformed data-declaration error instead.--{-@ LIQUID "--reflection" @-}-{-@ LIQUID "--ple"        @-} --module BadDataDeclTyVars where--{-@ data L = Emp | Cons {x::a, xs:: (L a)} @-}---       ^ whoops, missing a tyvar!--data L a = Emp | Cons a (L a)--{-@ reflect sz @-}-sz :: L a -> Int-sz Emp         = 0-sz (Cons _ xs) = 1 + sz xs--{-@ test :: {(sz (Cons 1 Emp)) = 1} @-}-test :: ()-test = ()
− tests/errors/BadGADT.hs 
@@ -1,42 +0,0 @@-{-@ LIQUID "--expect-error-containing=Specified type does not refine Haskell type for `BadGADT.Nil2`" @-}-{-# LANGUAGE GADTs #-}--{-@ LIQUID "--no-termination" @-}--module BadGADT where--{-@ data List a where-       Nil  :: List a-       Cons :: listHead:a -> listTail:List a -> List a-@-}--{-@ data List1 a b where-       Nil1  :: List1 a b-       Cons1 :: listHead:a -> listTail:List a -> List1 a b-@-}--{-@ data List2 a b <p :: a -> Bool> where-       Nil2  :: List2 a-       Cons2 :: listHead:a -> listTail:List a -> List2 a b-@-}---data List a where-  Nil  :: List a-  Cons :: a -> List a -> List a---data List1 a b where-  Nil1  :: List1 a b-  Cons1 :: a -> List a -> List1 a b--data List2 a b where-  Nil2  :: List2 a b-  Cons2 :: a -> List a -> List2 a b--test :: List a -> Int-test Nil = 1-test (Cons x xs) = 1 + test xs--main :: IO ()-main = pure ()
− tests/errors/BadPragma0.hs 
@@ -1,8 +0,0 @@-{-@ LIQUID "--expect-error-containing=Illegal pragma" @-}-{-@ LIQUID "--idirs=.." @-}--module BadPragma0 where--i :: Int-i = 1-
− tests/errors/BadPragma1.hs 
@@ -1,8 +0,0 @@-{-@ LIQUID "--expect-error-containing=Illegal pragma" @-}-{-@ LIQUID "--c-files=./wow.c" @-}--module BadPragma1 where--i :: Int-i = 1-
− tests/errors/BadPragma2.hs 
@@ -1,8 +0,0 @@-{-@ LIQUID "--expect-error-containing=Illegal pragma" @-}-{-@ LIQUID "--ghc-option=-O0" @-}--module BadPragma2 where--i :: Int-i = 1-
− tests/errors/BadPredApp.hs 
@@ -1,8 +0,0 @@-{-@ LIQUID "--expect-error-containing=Malformed predicate application" @-}-module BadPredApp where--{-@ data X <q :: Int -> Int -> Bool> = X (x0 :: Int) (x1 :: Int<q x0>) @-}  -data X = X Int Int  --{-@ data T <p :: Int -> Int -> Int -> Int -> Bool> = C { x :: Int, y :: Int, z :: X<p x y> } @-}-data T = C { x :: Int, y :: Int, z :: X }
− tests/errors/BadQualifier.hs 
@@ -1,10 +0,0 @@-module BadQualifier where-data RGRef a-{-@ measure tv :: RGRef a -> a @-}-{-@ qualif TERMINALVALUE(r:RGRef a): (tv r) @-}---data A-data B--{-@ qualif Foo(x:A, y:B): (x == y) @-}
− tests/errors/BadSig0.hs 
@@ -1,9 +0,0 @@-{-@ LIQUID "--expect-error-containing=Illegal type specification for `BadSig0.foo`" @-}-module BadSig0 where--{-@ measure prop :: a -> b @-}-{-@ type Prop E = {v:_ | pro v = E} @-}--foo :: Int -> Int -{-@ foo :: n:Int -> Prop 10 @-}-foo x = x + 1
− tests/errors/BadSig1.hs 
@@ -1,38 +0,0 @@-{-@ LIQUID "--expect-error-containing=Illegal type specification for `BadSig1.EZ`" @-}-{-# LANGUAGE GADTs #-}--{-@ LIQUID "--exact-data-con" @-}--module BadSig1 where--data Peano where-  Z :: Peano-  S :: Peano -> Peano---- AUTO-data EvProp where-  Ev :: Peano -> EvProp--data Ev where-  EZ  :: Ev-  ESS :: Peano -> Ev -> Ev---- AUTO/PRELUDE-{-@ measure prop :: a -> b @-}--{-@ type Prop E = {v:_ | pro v = E} @-}--      -- {v:Ev | prop v = Ev Z}-{-@ data Ev where-        EZ  :: Prop (Ev Z)-        ESS :: evn:Peano -> {evpf:Ev | prop evpf = Ev evn} -> {zing : Ev | prop zing = Ev (S (S evn)) }-  @-}--{-@ test :: n:Peano -> {v:Ev | prop v = Ev (S (S n))} -> {v:Ev | prop v = Ev n} @-}-test :: Peano -> Ev -> Ev-test n (ESS m q) = q---- G := p : {prop p  = Even (S (S n)) /\ prop p = Even (S (S m))}---        ; q : {prop q = Even m}---        ==> n = m---        ==> prop q = Even n
− tests/errors/BadSyn1.hs 
@@ -1,10 +0,0 @@-{-@ LIQUID "--expect-error-containing=Malformed application of type alias `Fooz`" @-}-module BadSyn1 where--type Foo = Int--{-@ type Fooz = {v:Int | 1 < v} @-}--{-@ bob :: Fooz 1000 @-}-bob = 10 :: Int-
− tests/errors/BadSyn2.hs 
@@ -1,8 +0,0 @@-{-@ LIQUID "--expect-error-containing=Malformed application of type alias `BadSyn2.Foo`" @-}-module BadSyn2 where--type Foo = Int--{-@ bob :: Foo 1000 @-}-bob = 10 :: Int-
− tests/errors/BadSyn3.hs 
@@ -1,8 +0,0 @@-{-@ LIQUID "--expect-error-containing=Malformed application of type alias `BadSyn3.Foo`" @-}-module BadSyn3 where--type Foo = Int--{-@ bob :: Foo String @-}-bob = 10 :: Int-
− tests/errors/BadSyn4.hs 
@@ -1,9 +0,0 @@-{-@ LIQUID "--expect-error-containing=Malformed application of type alias `BadSyn4.Point`" @-}-module BadSyn4 where--type List a = [a]-type Point  = List Double--{-@ foo :: n:Nat -> Point n @-}-foo :: Int -> List Double-foo _ = []
− tests/errors/CyclicExprAlias0.hs 
@@ -1,5 +0,0 @@-{-@ LIQUID "--expect-error-containing=Cyclic type alias definition" @-}-module CyclicExprAlias0 () where--{-@ expression CyclicA1 Q = CyclicA1 Q @-}-
− tests/errors/CyclicExprAlias1.hs 
@@ -1,6 +0,0 @@-{-@ LIQUID "--expect-error-containing=Cyclic type alias definition" @-}-module CyclicExprAlias1 () where--{-@ expression CyclicB1 Q = CyclicB2 Q @-}-{-@ expression CyclicB2 Q = CyclicB1 Q @-}-
− tests/errors/CyclicExprAlias2.hs 
@@ -1,8 +0,0 @@-{-@ LIQUID "--expect-error-containing=Cyclic type alias definition" @-}-module CyclicExprAlias2 () where--{-@ expression CyclicC1 Q = (CyclicC2 Q) && (CyclicC3 Q) @-}-{-@ expression CyclicC2 Q = CyclicC1 Q @-}-{-@ expression CyclicC3 Q = CyclicC1 Q @-}--
− tests/errors/CyclicExprAlias3.hs 
@@ -1,7 +0,0 @@-{-@ LIQUID "--expect-error-containing=Cyclic type alias definition" @-}-module CyclicExprAlias3 () where--{-@ expression CyclicD1 Q = CyclicD2 Q @-}-{-@ expression CyclicD2 Q = CyclicD3 Q @-}-{-@ expression CyclicD3 Q = CyclicD1 Q @-}-
− tests/errors/CyclicPredAlias0.hs 
@@ -1,5 +0,0 @@-{-@ LIQUID "--expect-error-containing=Cyclic type alias definition for `CyclicA1`" @-}-module CyclicPredAlias0 () where--{-@ predicate CyclicA1 Q = CyclicA1 Q @-}-
− tests/errors/CyclicPredAlias1.hs 
@@ -1,6 +0,0 @@-{-@ LIQUID "--expect-error-containing=Cyclic type alias definition for `CyclicB1`" @-}-module CyclicPredAlias1 () where--{-@ predicate CyclicB1 Q = CyclicB2 Q @-}-{-@ predicate CyclicB2 Q = CyclicB1 Q @-}-
− tests/errors/CyclicPredAlias2.hs 
@@ -1,8 +0,0 @@-{-@ LIQUID "--expect-error-containing=Cyclic type alias definition for `CyclicC1`" @-}--module CyclicPredAlias2 () where--{-@ predicate CyclicC1 Q = CyclicC2 Q && CyclicC3 Q @-}-{-@ predicate CyclicC2 Q = CyclicC1 Q @-}-{-@ predicate CyclicC3 Q = CyclicC1 Q @-}-
− tests/errors/CyclicPredAlias3.hs 
@@ -1,7 +0,0 @@-{-@ LIQUID "--expect-error-containing=Cyclic type alias definition for `CyclicD1`" @-}-module CyclicPredAlias3 () where--{-@ predicate CyclicD1 Q = CyclicD2 Q @-}-{-@ predicate CyclicD2 Q = CyclicD3 Q @-}-{-@ predicate CyclicD3 Q = CyclicD1 Q @-}-
− tests/errors/CyclicTypeAlias0.hs 
@@ -1,6 +0,0 @@-{-@ LIQUID "--expect-error-containing=Cyclic type alias definition for `CyclicA1`" @-}-module CyclicTypeAlias0 () where--{-@ type CyclicA1 = CyclicA2 @-}-{-@ type CyclicA2 = CyclicA1 @-}-
− tests/errors/CyclicTypeAlias1.hs 
@@ -1,7 +0,0 @@-{-@ LIQUID "--expect-error-containing=Cyclic type alias definition for `CyclicB1`" @-}-module CyclicTypeAlias1 () where--{-@ type CyclicB1 = CyclicB2 @-}-{-@ type CyclicB2 = CyclicB3 @-}-{-@ type CyclicB3 = CyclicB1 @-}-
− tests/errors/CyclicTypeAlias2.hs 
@@ -1,5 +0,0 @@-{-@ LIQUID "--expect-error-containing=Cyclic type alias definition for `CyclicC`" @-}-module CyclicTypeAlias2 () where--{-@ type CyclicC = [CyclicC] @-}-
− tests/errors/CyclicTypeAlias3.hs 
@@ -1,7 +0,0 @@-{-@ LIQUID "--expect-error-containing=Cyclic type alias definition for `CyclicD2" @-}-module CyclicTypeAlias3 () where--{-@ type CyclicD1 = CyclicD2 @-}-{-@ type CyclicD2 = CyclicD3 @-}-{-@ type CyclicD3 = CyclicD2 @-}-
− tests/errors/DupAlias.hs 
@@ -1,19 +0,0 @@-{-@ LIQUID "--expect-error-containing=Multiple definitions of Type Alias `BoundedNat`" @-}-{-@ LIQUID "--expect-error-containing=Multiple definitions of Pred Alias `Foo`" @-}-module DupAlias () where--import Language.Haskell.Liquid.Prelude--{-@ type BoundedNat N = {v:Nat | v < N } @-}-{-@ predicate Foo V N = V < N            @-}---- TODO: Test fails when this second alias is ALSO defined.--- FIX: should WARN that there are duplicate aliases!--{-@ type BoundedNat N = {v:Nat | v <= N } @-}-{-@ predicate Foo V N = V <= N            @-}---{-@ foo :: n:Int -> m:(BoundedNat n) -> Nat @-}-foo :: Int -> Int -> Int-foo n m = liquidAssert (m < n) m
− tests/errors/DupData.hs 
@@ -1,25 +0,0 @@-{-@ LIQUID "--expect-error-containing=Multiple specifications for `OVec`" @-}--- | See https://github.com/ucsd-progsys/liquidhaskell/issues/1175--module DupData where--data OVec a = ONil-            | (:>>) {oHd :: a, oTl :: OVec a}-infixr 5 :>>--{-@ data OVec a = ONil-               | (:>>) {oHd :: a,-                        oTl :: OVec {v:a | v >= oHd}} @-}---{-@ data OVec [mylen] @-}-{-@ measure mylen @-}-{-@ mylen :: OVec a -> Nat @-}-mylen :: OVec a -> Int-mylen ONil       = 0-mylen (_ :>> xs) = 1 + mylen xs--{-@ badVec :: OVec Int @-}-badVec :: OVec Int-badVec = 1 :>> 3 :>> 2 :>> ONil-
− tests/errors/DupFunSigs.hs 
@@ -1,28 +0,0 @@-{-@ LIQUID "--expect-error-containing=Multiple specifications for `DupFunSigs.fromWeekDayNum`" @-}--- See https://github.com/ucsd-progsys/liquidhaskell/issues/1137--module DupFunSigs where--import Data.List--{-@ type WeekDayNum = { i:Int | 0 < i && i <= 7 } @-}-type WeekDayNum = Int -- Mon == 1, ..., Sun == 7--data WeekDay = Mon | Tue | Wed | Thu | Fri | Sat | Sun-  deriving (Read, Show, Eq, Bounded)--{-@ weekdays :: { wd:[WeekDay] | len wd == 7 } @-}-weekdays :: [WeekDay]-weekdays = [Mon, Tue, Wed, Thu, Fri, Sat, Sun]--{-@ fromWeekDayNum :: WeekDayNum -> WeekDay @-}-fromWeekDayNum :: WeekDayNum -> WeekDay-fromWeekDayNum i = weekdays !! (i-1)--{-@ fromWeekDayNum :: WeekDay -> WeekDayNum @-}-toWeekDayNum :: WeekDay -> WeekDayNum-toWeekDayNum wd = case wd `elemIndex` weekdays of-        Just i -> i + 1--main :: IO ()-main = pure ()
− tests/errors/DupMeasure.hs 
@@ -1,18 +0,0 @@-{-@ LIQUID "--expect-error-containing=Multiple specifications for `lenA`" @-}-module DupMeasure where---{-@ measure lenA :: [a] -> Int -      lenA [] = 0-      lenA (x:xs) = 1 + lenA xs -  @-}--{-@ measure lenA :: [a] -> Int -      lenA [] = 0-      lenA (x:xs) = 1 + lenA xs -  @-}--{-@ zorg :: {v:[Int] | lenA v == 3} @-}-zorg :: [Int]-zorg = [1,2,3]-
− tests/errors/ElabLocation.hs 
@@ -1,15 +0,0 @@--- | This file tests that LH correctly localizes the elaboration error---   to the '10 / x' term (where we get a sort-error as the 'Ratio Int'---   is compared against '0' which appears in the refinement for '/'.)---   You can fix this by `embed Ratio * as Int`--{-@ LIQUID "--expect-error-containing=ElabLocation.hs:15:14" @-}--module ElabLocation where--import Data.Ratio--foo :: Ratio Int -> Bool-foo x = y == y-  where-    y = 10 / x
− tests/errors/ElabLocation2.hs 
@@ -1,18 +0,0 @@-{-@ LIQUID "--expect-error-containing=ElabLocation2.hs:18:54-66" @-}-module ElabLocation2 where-type Range = (Int,Int)--{-@ measure start @-}-start :: Range -> Int-start (a,b) = a--{-@ measure end @-}-end :: Range -> Int-end (a,b) = b--{-@ using (Range) as {r:Range | start r <= end r} @-}---- seemed to work earlier, now fails-{-@ intsToRanges :: Int -> Int -> Int -> Int -> Maybe (Range,Range) @-}-intsToRanges :: Int -> Int -> Int -> Int -> Maybe (Range,Range)-intsToRanges a b c d = if a <= b && c <= d then Just ((a,b),(c,d)) else Nothing
− tests/errors/ElabLocation3.hs 
@@ -1,210 +0,0 @@-module ElabLocation3 where-{-@ LIQUID "--expect-error-containing=ElabLocation3.hs:174:1-5" @-}-{-@ LIQUID "--reflection" @-}--import Language.Haskell.Liquid.ProofCombinators-import Prelude hiding (id)--{-@ type Pos = {v:Int | 0 < v} @-}--{-@ incr :: Pos -> Pos @-}-incr :: Int -> Int-incr x = x + 2----{-@-data Monkey =-  M { number :: Nat,-      items :: [Int],-      operation :: Int -> Int,-      testMod :: {n:Int | n > 0 },-      ifTrue :: Nat,-      ifFalse :: Nat,-      count :: Nat-    }-@-}-data Monkey =-  M { number :: Int,-      items :: [Int],-      operation :: Int -> Int,-      testMod :: Int,-      ifTrue :: Int,-      ifFalse :: Int,-      count :: Int }--{-@ myCount :: _ -> Nat @-}-myCount :: Monkey -> Int -myCount M { count = k}  = k ---showMonkey :: Monkey -> String-showMonkey (M n i o m ifT ifF count) =-  "#" ++ (show n) ++ " items " ++ (show i) ++ " examined " ++ (show count) ++ "\n"--instance Show Monkey where show = showMonkey--{-@ type MonkeyIR X = {m:Monkey | number m < X && ifTrue m < X && ifFalse m < X } @-}---- fst = item--- snd = destination-{-@ type MonkeyItem X = (Int, {n:Nat | n < X}) @-}--{-@ turn :: x:Int -> {worry:Int | worry /= 0 } -> {modulus:Int | modulus /= 0} -> m:MonkeyIR x -> {d:[MonkeyItem x] | len d = len (items m)} @-}-turn :: Int -> Int -> Int -> Monkey -> [(Int, Int)]-turn _ worry modulus (M _ oldItems op m dTrue dFalse _) =-  map toDestination oldItems where-  toDestination i = let newWorry = (( op i ) `div` worry) `mod` modulus in-    (newWorry, if newWorry `mod` m == 0 then dTrue else dFalse)---- What I would like to do:--- measure countOfItems :: [Monkey] -> Int--- countOfItems [] = 0--- countOfItems (m:ms) = len (items m) + countOfItems ms------      -> {m2:[MonkeyIR x] | len m2 = len m && countOfItems m2 = countOfItems m + len mi} ------ But this measure gets applied to all lists, which doesn't work--{-@ data MonkeyList = Empty | MCons { headMonkey :: MonkeyIR 8, barrel :: MonkeyList } @-}-data MonkeyList =-  Empty |-  MCons Monkey MonkeyList--{-@ measure mLen :: MonkeyList -> Int-      mLen Empty = 0-      mLen (MCons m ms) = 1 + mLen  ms -  @-}--{-@ measure countOfItems :: MonkeyList -> Int-      countOfItems Empty = 0-      countOfItems (MCons m ms) = len (items m) + countOfItems ms @-}--{--{-@ distribute2 :: m:MonkeyList -> {mi:[MonkeyItem 8] | len mi <= mLen m}-     -> {m2:MonkeyList | mLen m2 = mLen m && countOfItems m2 = countOfItems m + len mi} @-}-distribute2 :: MonkeyList -> [(Int,Int)] -> MonkeyList -distribute2 Empty [] = Empty-distribute2 Empty _ = error "Shouldn't happen"-distribute2 (MCons m ms) destinations =-  MCons (m {items = (items m) ++ newItems}) (distribute2 ms (filter (notP toMe) destinations)) where-  newItems = map fst (filter toMe destinations)-  toMe (_,d) = d == number m--}--{-@ distribute :: x:Int -> m:[MonkeyIR x] -> mi:[MonkeyItem x]-     -> {m2:[MonkeyIR x] | len m2 = len m} @-}-distribute :: Int -> [Monkey] -> [(Int,Int)] -> [Monkey]-distribute _ [] _ = []-distribute x (m:ms) destinations =-  (m {items = (items m) ++ newItems}):(distribute x ms destinations) where-  newItems = map fst (filter toMe destinations)-  toMe (_,d) = d == number m---- Monkey N's turn in the round-{-@ roundN :: x:Int -> -              {worry:Int | worry /= 0 } -> -	      {modulus:Int | modulus /= 0} -> -	      {before:[MonkeyIR x] | len before = x} -> -	      {n:Nat | n < x } -> -	      {after:[m:MonkeyIR x] | len after = x} @-}-roundN :: Int -> Int -> Int -> [Monkey] -> Int -> [Monkey]-roundN x worry modulus monkeys n =-  let m = (monkeys !! n)-      destinations = turn x worry modulus m-      newCount = (myCount m) + length (items m)-      afterRemoval = (take n monkeys) ++ [(m {items = [], count = newCount} )] ++ (drop (n+1) monkeys) in-    distribute x afterRemoval destinations---- One round of all monkeys--- Complicated by the need to prove termination.-{-@ round :: x:Int -> {worry:Int | worry /= 0} -> {modulus:Int | modulus /= 0 } -> -             {before:[MonkeyIR x] | len before = x} -> -	     {after:[MonkeyIR x] | len after = x} @-}-round :: Int -> Int -> Int -> [Monkey] -> [Monkey]-round x worry modulus monkeys = go 0 monkeys where-  {-@ go :: {n:Int | n >= 0 && n <= x} -> {m:[MonkeyIR x] | len m = x} -> {m2:[MonkeyIR x] | len m2 = x} / [ x - n ] @-}-  go n ms = if n == x then ms-    else go (n+1) (roundN x worry modulus ms n)---{-@ m0 :: MonkeyIR 4 @-}-m0 = M { number=0, items=[79,98], operation=(\o -> o * 19), testMod=23, ifTrue=2, ifFalse=3, count=0 }-{-@ m1 :: MonkeyIR 4 @-}-m1 = M { number=1, items=[54,65,75,74], operation=(\o -> o + 6), testMod=19, ifTrue=2, ifFalse=0, count=0 }-{-@ m2 :: MonkeyIR 4 @-}-m2 = M { number=2, items=[79,60,97], operation=(\o -> o * o), testMod=13, ifTrue=1, ifFalse=3, count=0 }-{-@ m3 :: MonkeyIR 4 @-}-m3 = M { number=3, items=[74], operation=(\o -> o + 3), testMod=17, ifTrue=0, ifFalse=1, count=0 }-       -{-@ example :: {m:[MonkeyIR 4] | len m = 4} @-}-example :: [Monkey]-example = [ m0, m1, m2, m3 ]--{-@ i0 :: MonkeyIR 8 @-}-i0 = M { number=0, items=[59,74,65,86], operation=(\o -> o * 19), testMod=7, ifTrue=6, ifFalse=2, count=0 }-{-@ i1 :: MonkeyIR 8 @-}-i1 = M { number=1, items=[62,84,72,91,68,78,51], operation=(\o -> o + 1), testMod=2, ifTrue=2, ifFalse=0, count=0 }-{-@ i2 :: MonkeyIR 8 @-}-i2 = M { number=2, items=[78,84,96], operation=(\o -> o + 8), testMod=19, ifTrue=6, ifFalse=5, count=0 }-{-@ i3 :: MonkeyIR 8 @-}-i3 = M { number=3, items=[97,86], operation=(\o -> o * o), testMod=3, ifTrue=1, ifFalse=0, count=0 }-{-@ i4 :: MonkeyIR 8 @-}-i4 = M { number=4, items=[50], operation=(\o -> o + 6), testMod=13, ifTrue=3, ifFalse=1, count=0 }-{-@ i5 :: MonkeyIR 8 @-}-i5 = M { number=5, items=[73,65,69,65,51], operation=(\o -> o * 17), testMod=11, ifTrue=4, ifFalse=7, count=0 }-{-@ i6 :: MonkeyIR 8 @-}-i6 = M { number=6, items=[69, 82, 97, 93, 82, 84, 58, 63], operation=(\o -> o + 5), testMod=5, ifTrue=5, ifFalse=7, count=0 }-{-@ i7 :: MonkeyIR 8 @-}-i7 = M { number=7, items=[81, 78, 82, 76, 79, 80], operation=(\o -> o + 3), testMod=17, ifTrue=3, ifFalse=4, count=0 }-       -{-@ input :: {m:[MonkeyIR 8] | len m = 8} @-}-input :: [Monkey]-input = [ i0, i1, i2, i3, i4, i5, i6, i7 ]--{-@ assume iterate :: (a -> a) -> a -> {l:[a] | len l >= 1000000 } @-}--computeModulus :: [Monkey] -> Int-computeModulus ms = foldl1 (*) (map testMod ms)---id z = z--part1 :: () -> IO ()-part1 _ = do-  putStrLn "Part 1"-  let m1 = computeModulus example in do-    putStrLn $ "Working mod " ++ show m1-    let allRounds = iterate {- (Main.round 4 3 m1) -} id example in-      print $ allRounds !! 20-    -  let m2 = computeModulus input in do-    putStrLn $ "Working mod " ++ show m2    -    let allRounds2 = iterate {- (Main.round 8 3 m2) -} id input in-      print $ allRounds2 !! 20--part2 :: () -> IO ()-part2 _ = do-  putStrLn "Part 2"-  let m1 = computeModulus example in do-    putStrLn $ "Working mod " ++ show m1-    let allRounds = iterate {- (Main.round 4 1 m1) -} id example in do-      print $ allRounds !! 1000-      print $ allRounds !! 2000-      print $ allRounds !! 3000-      print $ allRounds !! 4000-      print $ allRounds !! 5000-      print $ allRounds !! 6000-      print $ allRounds !! 7000-      print $ allRounds !! 8000-      print $ allRounds !! 9000-      print $ allRounds !! 10000-      -  let m2 = computeModulus input in do-    putStrLn $ "Working mod " ++ show m2    -    let allRounds2 = iterate {- (Main.round 8 1 m2) -} id input in-      print $ allRounds2 !! 10000--mymain :: IO ()-mymain = part1 () >> part2 ()-
− tests/errors/EmptyData.hs 
@@ -1,7 +0,0 @@-{-@ LIQUID "--expect-error-containing=one or more fields in the data declaration for `A`" @-}--- | see: https://github.com/ucsd-progsys/liquidhaskell/issues/1169--module EmptyData where--{-@ data A @-}-data A = B
− tests/errors/ErrLocation.hs 
@@ -1,11 +0,0 @@-{-@ LIQUID "--expect-error-containing=ErrLocation.hs:10:13" @-}--module ErrLocation where--{-@ inc :: Nat -> Nat @-}-inc :: Int -> Int -inc x = x + 1--bar :: Int -> Int -bar x = inc (x - 1)-
− tests/errors/ErrLocation2.hs 
@@ -1,13 +0,0 @@-{-@ LIQUID "--expect-error-containing=ErrLocation2.hs:12:20" @-}--module ErrLocation2 where--{-@ inc :: Nat -> Nat @-}-inc :: Int -> Int -inc x = x + 1--bar :: Int -> Int -bar x - | x > 0    = inc (x - 1) - | otherwise = inc x -
− tests/errors/ExportMeasure0.hs 
@@ -1,17 +0,0 @@--- FIX: module ExportMeasure (llen) where-    -module ExportMeasure0 () where--{-@ data LL [llen] @-}-data LL a = N | C a (LL a)--{-@ invariant {v:LL a | (llen v) >= 0} @-}--{-@ measure llen @-}-llen :: (LL a) -> Int -llen(N)      = 0-llen(C x xs) = 1 + (llen xs)--{-@ lmap :: (a -> b) -> xs:(LL a) -> {v: LL b | llen v = llen xs } @-} -lmap f N = N-lmap f (C x xs) = C (f x) (lmap f xs)
− tests/errors/ExportReflect0.hs 
@@ -1,28 +0,0 @@--- LH issue #1023--{-@ LIQUID "--exactdc"     @-}-{-@ LIQUID "--higherorder" @-}--module ExportReflect0 (foo, zogbert) where--import Language.Haskell.Liquid.ProofCombinators--{-@ reflect identity @-}-identity :: a -> a-identity x = x--{-@ reflect identity2 @-}-identity2 :: a -> a-identity2 x = x--{-@ reflect identity3 @-}-identity3 :: a -> a-identity3 x = x--{-@ foo :: x:a -> { identity x == x } @-}-foo :: a -> Proof-foo x = identity x === x *** QED--{-@ reflect zogbert @-}-zogbert :: a -> a-zogbert x = x
− tests/errors/Fractional.hs 
@@ -1,11 +0,0 @@-{-@ LIQUID "--expect-error-containing=Illegal type specification for `Fractional.f`" @-}-{-@ LIQUID "--expect-error-containing=Illegal type specification for `Fractional.g`" @-}-module Fractional where--{-@ f :: (Num a) => {v:a | v > 0.0} -> a @-}-f :: (Num a) => a -> a-f a = a + 1--{-@ g :: (Num a) => {v:a | v > 0.0} -> a @-}-g :: (Num a) => a -> a-g = f
− tests/errors/Frog.hs 
@@ -1,9 +0,0 @@-{-@ LIQUID "--expect-error-containing=Unbound symbol GHC.Err.undefined" @-}--module Frog where--{-@ LIQUID "--reflection" @-}--{-@ reflect frog @-}-frog :: () -> Bool-frog () = undefined
− tests/errors/HigherOrderBinder.hs 
@@ -1,9 +0,0 @@-{-@ LIQUID "--expect-error-containing=Illegal type specification for `HigherOrderBinder.foo`" @-}-module HigherOrderBinder where--{-@ foo :: a: Int -> f: (Int -> Int) -> {v : Int | v = 123 + (f a) } @-}-foo :: Int -> (Int -> Int) -> Int-foo a f = f a--main :: IO ()-main = pure ()
− tests/errors/HintMismatch.hs 
@@ -1,15 +0,0 @@-{-@ LIQUID "--expect-error-containing=HINT: Use the hole" @-}--{-# LANGUAGE DataKinds #-}--module HintMismatch where--newtype Offset struct member = Offset { unOffset :: Int }--type OffsetN t = Offset (t 'Nothing)--foo = Nothing --{-@ bar :: t 'Nothing @-}-bar :: t 'Nothing-bar = undefined
− tests/errors/HoleCrash1.hs 
@@ -1,9 +0,0 @@-{-@ LIQUID "--expect-error-containing=Illegal type specification for `HoleCrash1.t`" @-}-{-@ LIQUID "--expect-error-containing=Illegal type specification for `HoleCrash1.C`" @-}-module HoleCrash1 where--data Poo a = C { t :: Poo a }--{-@ type Geq N = {v:_ | N <= v} @-}--{-@ data Poo a = C { t :: Poo (Geq 0) } @-}
− tests/errors/HoleCrash2.hs 
@@ -1,8 +0,0 @@-{-@ LIQUID "--expect-error-containing=Malformed application of type alias `Geq`" @-}-module HoleCrash2 where--data Poo a = C { t :: Poo a }--{-@ type Geq a N = {v:a | N <= v} @-}--{-@ data Poo a = C { t :: Poo (Geq 0) } @-}
− tests/errors/HoleCrash3.hs 
@@ -1,19 +0,0 @@-{-@ LIQUID "--expect-error-containing=Specified type does not refine Haskell type for `HoleCrash3.countUp`" @-}-module HoleCrash3 where--data List a = E | (:::) { h :: a, t :: List a }--infixr  9 ::: --{-@ countUp :: n:Int -> List Int @-}-countUp n  = n ::: countUp (n + 1)----------
− tests/errors/Inconsistent0.hs 
@@ -1,64 +0,0 @@-{-@ LIQUID "--expect-error-containing=Specified type does not refine Haskell type for `Inconsistent0.id1`" @-}--- FAILING TEST: this test SHOULD FAIL BUT DOESN'T--- issue #519--{-@ LIQUID "--no-positivity-check" @-}--{-# LANGUAGE DeriveFunctor #-}-module Inconsistent0 where--data AstIndex = IxExpr | IxType--{-@ measure isExprIndex @-}-isExprIndex :: AstIndex -> Bool-isExprIndex IxExpr = True-isExprIndex _      = False--{-@ measure isTypeIndex @-}-isTypeIndex :: AstIndex -> Bool-isTypeIndex IxType = True-isTypeIndex _      = False--data AstF f = Lit Int    AstIndex-            | Var String AstIndex-            | App f f-            | Paren f--{-@-  data AstF f <ix :: AstIndex -> Bool>-    = Lit {l1 :: Int, i :: AstIndex<ix>}-    | Var {v1 :: String, i :: AstIndex<ix>}-    | App (fn :: f) (arg :: f)-    | Paren (ast :: f)-  @-}--{-@ type AstFE = AstF <{\ix -> isExprIndex ix}> @-}-{-@ type AstFT = AstF <{\ix -> isTypeIndex ix}> @-}----- Now lets tie the knot!--newtype Fix f = In { out :: f (Fix f) }--type Ast = Fix AstF--{-@ type AstE = Fix AstFE @-}-{-@ type AstT = Fix AstFT @-}--{-@ astExpr :: AstE  @-}-astExpr :: Ast-astExpr = In (Lit 10 IxExpr) --{-@ astType :: AstT @-}-astType :: Ast -astType = In (Lit 10 IxType)--{-@ app :: forall <p :: AstIndex -> Bool>. Fix (AstF<p>) -> Fix (AstF<p>) -> Fix (AstF<p>) @-}-app f x = In $ App f x--{-@ id1 :: forall <p :: AstIndex -> Bool>. Fix (AstF p) -> Fix (AstF p)  @-}-id1 :: Fix AstF -> Fix AstF-id1 z = z--{-@ wrong :: AstT @-}-wrong = id1 astExpr
− tests/errors/Inconsistent1.hs 
@@ -1,6 +0,0 @@-{-@ LIQUID "--expect-error-containing=Specified type does not refine Haskell type for `Inconsistent1.incr` (Checked)" @-}-module Inconsistent1 where--{-@ incr :: Int -> Bool @-}-incr :: Int -> Int -incr x = x + 1
− tests/errors/Inconsistent2.hs 
@@ -1,6 +0,0 @@-{-@ LIQUID "--expect-error-containing=Specified type does not refine Haskell type for `Inconsistent2.foo` (Checked)" @-}-module Inconsistent2 where--{-@ foo :: Nat @-}-foo :: Bool-foo = True
− tests/errors/InlineSubExp0.hs 
@@ -1,22 +0,0 @@-{-@ LIQUID "--expect-error-containing=== f B C" @-}---- https://github.com/ucsd-progsys/liquidhaskell/issues/1258--{-@ LIQUID "--reflection"  @-}-{-@ LIQUID "--short-names" @-} --module InlineSubExp0 where--import Language.Haskell.Liquid.ProofCombinators --data Foo = A | B-data Bar = C | D-data Baz = E | F--{-@ reflect f @-}-f :: Foo -> Bar -> Baz-f B C = F-f _ _ = E--{-@ prop :: {f B C == F} @-}-prop = f B C === E *** QED
− tests/errors/InlineSubExp1.hs 
@@ -1,27 +0,0 @@-{-@ LIQUID "--expect-error-containing== f B (g A)" @-}---- https://github.com/ucsd-progsys/liquidhaskell/issues/1258--{-@ LIQUID "--reflection"  @-}-{-@ LIQUID "--short-names" @-}--module InlineSubExp1 where--import Language.Haskell.Liquid.ProofCombinators --data Foo = A | B-data Bar = C | D-data Baz = E | F | G --{-@ reflect f @-}-f :: Foo -> Bar -> Baz-f B C = F-f A D = E-f _ _ = G --{-@ reflect g @-}-g :: Foo -> Bar -g A = C -g _ = D --test = f B (g A) === f A D *** QED
− tests/errors/IrregularData.hs 
@@ -1,77 +0,0 @@-{-@ LIQUID "--expect-error-containing=is not a subtype of the required type" @-}-{-@ LIQUID "--reflection" @-}--module IrregularData where--import Language.Haskell.Liquid.ProofCombinators (Proof, (***), QED(..), (===))---- import Demo.Lib -------------------------------------- Copy pasted from containers --------------------------------------data FingerTree a-    = EmptyT-    | Single a-    | Deep !(Digit a) (FingerTree (Node a)) !(Digit a)--data Node a-    = Node2 a a-    | Node3 a a a--data Digit a-    = One a-    | Two a a-    | Three a a a-    | Four a a a a--{-@ reflect consTree @-}-consTree        :: a -> FingerTree a -> FingerTree a-consTree a EmptyT       = Single a-consTree a (Single b)   = Deep (One a) EmptyT (One b)-consTree a (Deep (Four b c d e) m sf) = Deep (Two a b) (Node3 c d e `consTree` m) sf-consTree a (Deep (Three b c d) m sf) = Deep (Four a b c d) m sf-consTree a (Deep (Two b c) m sf) = Deep (Three a b c) m sf-consTree a (Deep (One b) m sf) = Deep (Two a b) m sf------------------------------ Complexity analysis ------------------------------{-@ phi :: FingerTree a -> Nat @-}-{-@ reflect phi @-}-phi :: FingerTree a -> Int-phi EmptyT = 0-phi (Single _) = 0-phi (Deep u q v) = dang u + phi q + dang v--{-@ dang :: Digit a -> { n:Int | n == 0 || n == 1 } @-}-{-@ reflect dang @-}-dang :: Digit a -> Int-dang One {} = 1-dang Two {} = 0-dang Three {} = 0-dang Four {} = 1--{-@ consT :: a -> FingerTree a -> Nat @-}-{-@ reflect consT @-}-consT :: a -> FingerTree a -> Int-consT _ EmptyT = 1-consT _ (Single _) = 1-consT _ (Deep One {} _ _) = 1-consT _ (Deep Two {} _ _) = 1-consT _ (Deep Three {} _ _) = 1-consT _ (Deep (Four _ a b c) q _) = 1 + consT (Node3 a b c) q--{-@ amortizedConsP :: x:a -> q:FingerTree a -> { consT x q + phi (consTree x q) - phi q <= 3 } @-}-amortizedConsP :: a -> FingerTree a -> Proof-amortizedConsP x EmptyT = consT x EmptyT + phi (consTree x EmptyT) - phi EmptyT *** QED-amortizedConsP x (Single a) =-  consT x (Single a) + phi (consTree x (Single a)) - phi (Single a)-    === 1 + phi (Deep (One x) EmptyT (One a))-    === 1 + dang (One x) + phi EmptyT + dang (One a)    -- This is the line that causes the hang/crash-    === undefined-    *** QED-amortizedConsP _ _ = undefined-
− tests/errors/LiftMeasureCase.hs 
@@ -1,17 +0,0 @@-{-@ LIQUID "--expect-error-containing=Cannot create measure 'LiftMeasureCase.foo': Does not have a case-of at the top-level" @-}-module LiftMeasureCase where--llen :: [a] -> Int-llen [] = 0-llen (x:xs) = 1 + llen xs--{-@ measure foo @-}-foo :: a -> a-foo x = x--{-@ measure lllen @-}--{-@ lllen :: xs:[a] -> {v:Int| (lllen xs) = v} @-}-lllen :: [a] -> Int-lllen [] = 0-lllen (x:xs) = 1 + lllen xs
− tests/errors/LocalHole.hs 
@@ -1,12 +0,0 @@-{-@ LIQUID "--expect-error-containing=Illegal type specification for `go`" @-}-{-@ LIQUID "--no-termination" @-}--module LocalHole where--mysum xs = go 0 0-  where-    n = length xs-    {-@ go :: i:{Nat | i <= nowhere} -> _ -> _ @-}-    go i acc-      | i >= n    = acc-      | otherwise = go (i+1) (acc + xs !! i)
− tests/errors/MissingAssume.hs 
@@ -1,23 +0,0 @@-{-@ LIQUID "--expect-error-containing=Unknown variable `goober`" @-}-module MissingAssume where--import qualified Data.Set--{-@ type UList a = {v:[a] | ListUnique v} @-}--{-@ assume goober :: Nat -> Nat @-} --{-@ assume reverse :: xs:(UList a) -> {v: UList a | EqElts v xs}  @-}--{-@ predicate ListUnique LS = (Set_emp (listDup LS)) @-}--{-@ predicate EqElts X Y    = ((listElts X) = (listElts Y)) @-}--{-@-  measure listDup :: [a] -> (Data.Set.Set a)-    listDup []    = {v | Set_emp v }-    listDup (x:xs) = {v | v = if (Set_mem x (listElts xs)) then (Set_cup (Set_sng x) (listDup xs)) else (listDup xs) }-  @-}--{-@ foo :: xs:(UList a) -> {v: UList a | EqElts v xs} @-}-foo  = reverse
− tests/errors/MissingField1.hs 
@@ -1,8 +0,0 @@--- TODO-REBARE: LH _should_ (?) complain: "Unknown field `goober` in refined definition of `Foo`"--module MissingField1 where--data Foo = F Int --{-@ data Foo = F { goober :: Int } @-}-
− tests/errors/MissingField2.hs 
@@ -1,16 +0,0 @@-{-@ LIQUID "--expect-error-containing=Unbound symbol fxx"@-}-module MissingField2 where--data F a = F {fx :: a, fy :: a, fzz :: a} | G {fx :: a}--{-@ data F a = F { fxx :: a, fy :: a, fz :: a}-             | G { fxx :: a } -  @-}--{-@ fooG :: x:a -> {v : F a | (fxx v) > x} @-}-fooG :: a -> F a-fooG x = G x --{-@ foo :: x:a -> {v : F a | (fxx v) > x} @-}-foo :: a -> F a-foo x = F x x x
− tests/errors/MissingReflect.hs 
@@ -1,23 +0,0 @@-{-@ LIQUID "--expect-error-containing=Illegal type specification for `MissingReflect.empty_foo`" @-}-{-@ LIQUID "--reflection"                     @-}-{-@ LIQUID "--ple"                                @-}--module MissingReflect where--import Language.Haskell.Liquid.ProofCombinators ---- | This fails with an error as `foo` is unbound sans the `reflect` annotation. --{- reflect foo -}--{-@ foo  :: Nat ->  xs: [Nat] -> Nat -> Bool / [len xs ]@-}-foo :: Int ->  [Int] -> Int -> Bool-foo lo [] hi     = (lo<=hi)-foo lo (x:xs) hi = (lo<=hi) && foo lo xs x--{-@ empty_foo :: lo:Nat -> hi:{Nat | lo <= hi } -> {foo lo [] hi} @-}-empty_foo :: Int -> Int -> Proof-empty_foo lo hi = (foo lo [] hi) ==. (lo <= hi) ==.True  *** QED--main :: IO ()-main = pure ()
− tests/errors/MissingSizeFun.hs 
@@ -1,16 +0,0 @@-{-@ LIQUID "--expect-error-containing=Unknown variable `llen2`" @-}-{-@ LIQUID "--nostruct" @-}--module MissingSizeFun where--{-@ data List [llen] a = N | C {lhead :: a, ltail :: List a} @-}-data List a = N | C a (List a)--{-@ measure llen @-}-llen :: List a -> Bool -llen N = True  -llen (C _ xs) = False -- 1 + llen xs---{-@ data List2 [llen2] a = N2 | C2 {lhead2 :: a, ltail2 :: List2 a} @-}-data List2 a = N2 | C2 a (List2 a)
− tests/errors/MultiInstMeasures.hs 
@@ -1,24 +0,0 @@-{-@ LIQUID "--expect-error-containing=Multiple instance measures `sizeOf` for type `GHC.Ptr.Ptr`" @-}-module MultiInstMeasures where--import Data.Word-import GHC.Ptr--{-@ class measure sizeOf :: forall a . Ptr a -> Int @-}--{-@ instance measure sizeOf :: (Ptr GHC.Word.Word16) -> Int-      sizeOf (Ptr x) = 2-@-}--{-@ instance measure sizeOf :: (Ptr GHC.Word.Word32) -> Int-      sizeOf (Ptr y) = 4-@-}--{-@ bar :: { p : Ptr Word32 | plen p >= (sizeOf p) } -> () @-}-bar :: Ptr Word32 -> ()-bar (Ptr unused) = ()--{-@ qux :: { p : Ptr Word32 | plen p >= 0 } -> () @-}-qux :: Ptr Word32 -> ()-qux (Ptr addr) = let x = Ptr addr in bar x-
− tests/errors/MultiRecSels.hs 
@@ -1,23 +0,0 @@-{-@ LIQUID "--expect-error-containing=Duplicated definitions for field `left`" @-}-{-@ LIQUID "--no-termination" @-}-module MultiRecSels where--data RBTree a = Leaf-              | Node Color a !(RBTree a) !(RBTree a)--data Color = B | R--{-@ ok :: { v: RBTree Int | false} @-}-ok = Node R (2 :: Int)-         (Node B 1 Leaf Leaf)-         (Node B 3 Leaf Leaf)---- LH should give an error message that the field names are duplicates.--{-@ data RBTree a = Leaf-                  | Node { c     :: Color-                         , key   :: a-                         , left  :: RBTree ({v:a | v < key})-                         , left  :: RBTree ({v:a | key < v})-                         }-  @-}
− tests/errors/Positivity1.hs 
@@ -1,24 +0,0 @@-{-@ LIQUID "--expect-error-containing=Negative occurence of Positivity1.Rec" @-}-module Positivity1 where--newtype Rec a = In { out :: Rec a -> a }--y :: (a -> a) -> a-y f = g (In g)-  where-    -- ghc would say: Simplifier ticks exhausted-    -- if we don't prevent this from inlining-    {-# NOINLINE g #-}-    g x = f (out x x)--{-@ foo :: n:Nat -> {v:Nat | v < n} @-}-foo :: Int -> Int-foo = y go-  where go f n = if n > 0 then n-1 else f n--prop = let x = 0 in-       assert ((\n -> 0==1) (foo 0))--{-@ assert :: b:{Bool | b} -> () @-} -assert :: Bool -> () -assert _ = ()
− tests/errors/Positivity2.hs 
@@ -1,15 +0,0 @@-{-@ LIQUID "--expect-error-containing=Negative occurence of Positivity2.Evil in Positivity2.Very" @-}-module Positivity2 where--data Evil a = Very (Evil a -> a)--{-@ type Bot = {v: () | false} @-}--{-@ bad :: Evil Bot -> Bot @-}-{-# NOINLINE bad #-}-bad :: Evil () -> ()-bad (Very f) = f (Very f)--{-@ worse :: Bot @-}-worse :: ()-worse = bad (Very bad)
− tests/errors/PositivityCheck.hs 
@@ -1,16 +0,0 @@-{-@ LIQUID "--expect-error-containing=Negative occurence of PositivityCheck.Bad1" @-}-{-@ LIQUID "--expect-error-containing=Negative occurence of PositivityCheck.Bad2" @-}-{-@ LIQUID "--expect-error-containing=Negative occurence of PositivityCheck.Bad3" @-}-{-@ LIQUID "--expect-error-containing=Negative occurence of PositivityCheck.Bad4" @-}-{-@ LIQUID "--expect-error-containing=Negative occurence of PositivityCheck.BadRec1" @-}-{-@ LIQUID "--expect-error-containing=Negative occurence of PositivityCheck.BadRec2" @-}-module PositivityCheck where--data Bad1 a = No11 (Bad1 a -> Int) | No12 (Bad1 a) -data Bad2 a = No2 (Int -> Bad2 a -> Int)-data Bad3 a = No3 (Bad3 Int -> Int)-data Bad4 a = Bar (Flip (Flip (Flip (Bad4 a))))-type Flip a = a -> Int --data BadRec1 a = NoRec1 (BadRec2 a -> Int)-data BadRec2 a = NoRec2 (BadRec1 a)
− tests/errors/ReWrite5.hs 
@@ -1,27 +0,0 @@-{-@ LIQUID "--expect-error-containing=parameter \"xs\" contains an inner refinement" @-}-module ReWrite5 where--{-@ LIQUID "--reflection" @-}-{-@ LIQUID "--ple" @-}-{-@ infix ++ @-}--import Prelude hiding (filter)--{-@ reflect lt5 @-}-lt5 :: Int -> Bool-lt5 x = x < 5--{-@ reflect filter @-}-filter _ []     = []-filter p (x:xs) = if p x then x:(filter p xs) else filter p xs---- Reject inner refinements-{-@ rw :: xs :  [{ v: Int | v > 5 }] -> { filter lt5 xs = [] } @-}-rw :: [Int] -> ()-rw []     = ()-rw (_:xs) = rw xs--{-@ rewriteWith bad [rw] @-}-{-@ bad :: xs : [Int] -> { filter lt5 xs = [] } @-}-bad :: [Int] -> ()-bad _ = ()
− tests/errors/ReWrite6.hs 
@@ -1,8 +0,0 @@-{-@ LIQUID "--expect-error-containing=Unable to use ReWrite6.bad as a rewrite because it does not prove an equality" @-}-module ReWrite6 where---- Reject non equalities-{-@ rewrite bad @-}-{-@ bad :: {1 < 2} @-}-bad :: ()-bad = ()
− tests/errors/ReWrite7.hs 
@@ -1,17 +0,0 @@-{-@ LIQUID "--expect-error-containing=Could not generate any rewrites from equality" @-}-module ReWrite7 where-{-@ LIQUID "--reflection" @-}-{-@ LIQUID "--ple" @-}--{-@ reflect f @-}-f :: [Int] -> Bool-f []      = True-f (x:xs) = f xs---- Reject both sides with free vars-{-@ rewrite bad @-}-{-@ bad :: x : [Int] -> y : [Int] -> { f x = f y } @-}-bad :: [Int] -> [Int] -> ()-bad [] []        = ()-bad (x:xs) ys    = bad xs ys-bad []    (y:ys) = bad [] ys
− tests/errors/ReWrite8.hs 
@@ -1,41 +0,0 @@-{-@ LIQUID "--expect-error-containing=Could not generate any rewrites from equality" @-}-module ReWrite8 where--{-@ LIQUID "--reflection" @-}-{-@ LIQUID "--ple" @-}-{-@ infix ++ @-}--import Prelude hiding ((++), length, head)--{-@ measure length @-}-length :: [a] -> Int-length (_:xs) = 1 + length xs-length     [] = 0--{-@ reflect head @-}-{-@ head :: {xs : [a] | length xs >= 1} -> a @-}-head (x:_) = x--{-@ rewrite singleProof @-}-{-@ assume singleProof :: -          { xs : [a] | True } -      ->  { ys : [a] | True } -      ->  { xs = ys ++ [] } @-}-singleProof :: [a] -> [a] -> ()-singleProof _ _ = ()---- Reject both sides free vars (assumed fn)-{-@ sp :: -          { xs : [a] | True } -      ->  { ys : [a] | True } -      ->  { xs = ys ++ [] } @-}-sp :: [a] -> [a] -> ()-sp _ _ = ()---{-@ reflect ++ @-}-(++)::[a] -> [a] -> [a]-[]     ++ ys = ys -(x:xs) ++ ys = x:(xs ++ys)--
− tests/errors/ReflectLam.hs 
@@ -1,15 +0,0 @@-{-@ LIQUID "--reflection" @-}---module ReflectLam where----{-@ reflect bar @-}-bar :: [Integer]-bar = mymap (\x -> x + 1) [1,2,3]--{-@ reflect mymap @-}-mymap :: (a -> b) -> [a] -> [b]-mymap f [] = [] -mymap f (x:xs) = f x : mymap f xs
− tests/errors/ShadowFieldInline.hs 
@@ -1,18 +0,0 @@-{-@ LIQUID "--expect-error-containing=Multiple specifications for `pig`" @-}-{-@ LIQUID "--exactdc" @-}--module ShadowFieldInline where---- LH should give an error message that the field selectors `pig`--- is shadowed and should be renamed.--{-@ data Zig = Zonk { pig :: Int } @-}-data Zig = Zonk Int --{-@ prop :: z:Zig -> {v:Int | v = pig z} @-}-prop :: Zig -> Int-prop (Zonk n) = n--{-@ inline pig @-}-pig :: Int -> Int-pig a = a + 1
− tests/errors/ShadowFieldReflect.hs 
@@ -1,18 +0,0 @@-{-@ LIQUID "--expect-error-containing=Multiple specifications for `pig`" @-}-{-@ LIQUID "--exactdc" @-}--module ShadowFieldReflect where---- LH should give an error message that the field selectors `pig`--- is shadowed and should be renamed.--{-@ data Zig = Zonk { pig :: Int } @-}-data Zig = Zonk Int--{-@ prop :: z:Zig -> {v:Int | v = pig z} @-}-prop :: Zig -> Int-prop (Zonk n) = n--{-@ reflect pig @-}-pig :: Int -> Int-pig a = a + 1
− tests/errors/ShadowMeasure.hs 
@@ -1,22 +0,0 @@-{-@ LIQUID "--expect-error-containing=Multiple specifications for `shadow`" @-}---- ISSUE: Currently this doesn't CRASH because the two sorts for `shadow` are the--- same, but that is a happy coincidence. We should REJECT this program as the--- measure has the same name as another binder.--module ShadowMeasure where--data Poo = Poo Int--{-@ measure shadow :: Poo -> Int-      shadow (Poo n) = n-  @-}--{-@ test :: p:Poo -> {v:Int | v = shadow p} @-}-test :: Poo -> Int-test (Poo n) = n--{-@ measure shadow @-}-shadow :: [a] -> Int-shadow [] = 0-shadow (x:xs) = 0
− tests/errors/ShadowMeasureVar.hs 
@@ -1,17 +0,0 @@--- REJECT this program as the measure has the same name as another binder.--module ShadowMeasureVar where--data Poo = Poo Int--{-@ measure shadow :: Poo -> Int-    shadow (Poo n) = n-  @-}--{-@ test :: p:Poo -> {v:Int | v = shadow p} @-}-test :: Poo -> Int-test (Poo n) = n--shadow :: Int-shadow = 121-
− tests/errors/SplitSubtype.hs 
@@ -1,9 +0,0 @@-{-@ LIQUID "--expect-error-containing=| VV > 5}" @-}-module SplitSubtype where--{-@ foo :: {v:Int | v > 0 && v > 5 && v < 10 } -> Int @-}-foo :: Int -> Int-foo x = x + 1--bar = foo 2 --- We want to see the error pinpointed to the second conjunct.
− tests/errors/T1140.hs 
@@ -1,12 +0,0 @@-{-@ LIQUID "--expect-error-containing=Specified type does not refine Haskell type for `T1140.foo`" @-}--module T1140 where--data Label = Label Int --type Proof = () --{-@ foo :: Label -> Label -> Label -> Proof @-} -foo :: Label -> Label -> Label -> Proof -> Proof -foo a b c v = ()-
− tests/errors/T1498.hs 
@@ -1,13 +0,0 @@-{-@ LIQUID "--expect-error-containing=Standalone class method refinement" @-}-module T1498 where--class A a where-  f :: a -> Int--instance A Int where-  {-@ f :: _ -> {x : Int | 0 < x} @-}-  f n = n--{-@ x :: {x : Int | 0 < x} @-}-x :: Int-x = f ((-1) :: Int)
− tests/errors/T1498A.hs 
@@ -1,11 +0,0 @@-{-@ LIQUID "--expect-error-containing=Bad Data Specification" @-}-module T1498A where--class A a where-  f :: a -> Int-  -instance A Int where-{-@ instance A Int where-      f :: _ -> {x : Int | 0 < x}-  @-}-  f n = (-1)
− tests/errors/T1708.hs 
@@ -1,57 +0,0 @@-{-# OPTIONS_GHC -Wno-missing-methods #-}-{-@ LIQUID "--expect-error-containing=Unbound symbol T1708.bool1" @-}-{-@ LIQUID "--expect-error-containing=Unbound symbol T1708.bool2" @-}-{-@ LIQUID "--reflection"  @-}-{-@ LIQUID "--ple"         @-}-{-@ LIQUID "--no-totality" @-}--module T1708 where--import Language.Haskell.Liquid.ProofCombinators---bool1, bool2 :: Bool-bool1 = undefined-bool2 = undefined--class Eq a => EqAdequate a where-  toSMT :: a -> a -> PBEq a -> ()--{-@ class Eq a => EqAdequate a where-      toSMT :: x:a -> y:a -> PEq a {x} {y} -> {x = y} -  @-}--instance EqAdequate Bool where--data PBEq a-{-@ measure eqT :: a -> a -> Bool @-}-{-@ type PEq a E1 E2 = {v:PBEq a | eqT E1 E2} @-}-{-@ cEq  :: x:a -> y:a -> PEq a {x} {y} -> ctx:(a -> b) -> PEq b {ctx x} {ctx y} @-}-cEq  :: a -> a -> PBEq a -> (a -> b) -> PBEq b-cEq = undefined--{-@ critical :: {x:a | slowSpec x } -> a @-}-critical :: a -> a-critical x = x--{-@ bar :: PEq (a -> Bool) {fastSpec} {slowSpec} -> a -> Maybe a @-}-bar :: PBEq (a -> Bool) -> a -> Maybe a-bar pf x = if fastSpec x ? toSMT (fastSpec x) (slowSpec x) (unExt fastSpec slowSpec  pf x)-            then Just (critical x)-            else Nothing--{-@ unExt :: f:(a -> b) -> g:(a -> b) -> PEq (a -> b) {f} {g} -> x:a -> PEq b {f x} {g x} @-}-unExt :: (a -> b) -> (a -> b) -> PBEq (a -> b) -> a -> PBEq b-unExt f g p x = cEq f g p (flip' x) ? flip' x f ? flip' x g--{-@ reflect flip' @-}-flip' :: a -> (a -> b) -> b-flip' x f = f x--{-@ reflect fastSpec @-}-fastSpec :: a -> Bool-fastSpec _ = bool1--{-@ reflect slowSpec @-}-slowSpec :: a -> Bool-slowSpec _ = bool2
− tests/errors/T773.hs 
@@ -1,12 +0,0 @@-{-@ LIQUID "--expect-error-containing=Illegal type specification for `T773.incr`" @-}--- | Right now this gives a rather mysterious error, ---   cannot unify `int` with `(a b)` it would be nice ---   to actually point out the offending sub-expression, namely `len x`.--module T773 where--{-@ measure goober :: String -> Int @-}--{-@ incr :: x:Int -> {v:Bool | goober x == 0} @-}-incr :: Int -> Bool-incr = undefined
− tests/errors/T774.hs 
@@ -1,11 +0,0 @@-{-@ LIQUID "--expect-error-containing=Illegal type specification for `T774.incr`" @-}---- | Why does this NOT fail?! Clearly there is a sort error?!--module T774 where--{-@ measure goober :: String -> Int @-}--{-@ incr :: x:Int -> y:Int -> {v:Bool | goober x == goober y} @-}-incr :: Int -> Int -> Bool-incr = undefined
− tests/errors/TODOUnboundAbsRef.hs 
@@ -1,43 +0,0 @@--- ISSUE: In the below datatype, mickeymouse is clearly UNBOUND, and yet--- LH happily chugs along, and just says UNSAT at the end, instead of--- pointing out the bogus datatype definition.--module TODOUnboundAbsRef () where--import Language.Haskell.Liquid.Prelude--{-@ LIQUID "--no-termination" @-}---{-@-data List [llen] a <p :: x0:a -> x1:a -> Bool>-  = Nil-  | Cons { lHd :: a, lTl :: List <p> (a <p mickeymouse>) }-@-}--{-@ measure llen :: (List a) -> Int-    llen(Nil)       = 0-    llen(Cons x xs) = 1 + (llen xs)-  @-}--{-@ invariant {v:(List a) | ((llen v) >= 0)} @-}--data List a = Nil | Cons a (List a)--{--low, high :: Int-low  = 0-high = 10--}--range l h =-  if l <= h then Cons l (range (l+1) h) else Nil--chk y =-  case y of-   Nil -> True-   Cons x1 xs -> case xs of-                 Nil -> True-                 Cons x2 xs2 -> liquidAssertB (x1 <= x2) && chk xs2--prop3 = chk $ range 1 100
− tests/errors/TODOVarInTypeAlias.hs 
@@ -1,84 +0,0 @@--- VS.hs-{-@ LIQUID "--higherorder"    @-}-{-@ LIQUID "--totality"       @-}-{-@ LIQUID "--exactdc"        @-}--module TODOVarInTypeAlias where--import Language.Haskell.Liquid.ProofCombinators--{-@ data VerifiedSemigroup a = VerifiedSemigroup { sappend :: a -> a -> a } @-}-data VerifiedSemigroup a = VerifiedSemigroup { sappend :: a -> a -> a }--infixr 6 `sappend`---- ISSUE: UNBOUND VARIABLE IN TYPE ALIAS!!!! gR should be GR-{-@ type VSappendAssoc a GR = x:a -> y:a -> z:a-                           -> { v: Proof | sappend GR x (sappend GR y z) == sappend GR (sappend gR x y) z }-  @-}-type SappendAssoc a = a -> a -> a -> Proof--{-@ axiomatize sappendInv @-}-sappendInv :: (a -> a -> a)-           -> (a -> b) -> (b -> a)-           -> b -> b -> b-sappendInv sappendA f g x y = f (sappendA (g x) (g y))-{-# INLINE sappendInv #-}--{-@ sappendInvAssoc :: sappendA:(a -> a -> a)-                    -> sappendAAssoc:(i:a -> j:a -> k:a -> { sappendA i (sappendA j k) == sappendA (sappendA i j) k })-                    -> f:(a -> b)-                    -> g:(b -> a)-                    -> gof:(z:a -> { g (f z) == z })-                    -> x:b-                    -> y:b-                    -> z:b-                    -> { sappendInv sappendA f g x (sappendInv sappendA f g y z) == sappendInv sappendA f g (sappendInv sappendA f g x y) z }-@-}-sappendInvAssoc :: (a -> a -> a)-                -> (a -> a -> a -> Proof)-                -> (a -> b)-                -> (b -> a)-                -> (a -> Proof)-                -> b -> b -> b-                -> Proof-sappendInvAssoc sappendA sappendAAssoc f g gof x y z-  =   sappendInv sappendA f g x (sappendInv sappendA f g y z)-  ==. sappendInv sappendA f g x (f (sappendA (g y) (g z)))-  ==. f (sappendA (g x) (g (f (sappendA (g y) (g z)))))-  ==. f (sappendA (g x) (sappendA (g y) (g z))) ? gof (sappendA (g y) (g z))-  ==. f (sappendA (sappendA (g x) (g y)) (g z)) ? sappendAAssoc (g x) (g y) (g z)-  ==. f (sappendA (g (f (sappendA (g x) (g y)))) (g z)) ? gof (sappendA (g x) (g y))-  ==. f (sappendA (g (sappendInv sappendA f g x y)) (g z))-  ==. sappendInv sappendA f g (sappendInv sappendA f g x y) z-  *** QED--{-@ reflect vsemigroupInv @-}-{-@ vsemigroupInv :: f:(a -> b)-                  -> g:(b -> a)-                  -> gof:(x:a -> { g (f x) == x })-                  -> VerifiedSemigroup a-                  -> VerifiedSemigroup b-@-}-vsemigroupInv :: (a -> b) -> (b -> a) -> (a -> Proof)-              -> VerifiedSemigroup a -> VerifiedSemigroup b-vsemigroupInv f g gof (VerifiedSemigroup sappendA)-  = VerifiedSemigroup (sappendInv sappendA f g)---{-@ vsgiAssoc :: f:(a -> b)-              -> g:(b -> a)-              -> gof:(x:a -> { g (f x) == x })-              -> poopa:(VerifiedSemigroup a)-              -> VSappendAssoc a poopa-              -> SappendAssoc b--  @-}-vsgiAssoc :: (a -> b) -> (b -> a) -> (a -> Proof) -> VerifiedSemigroup a-          -> SappendAssoc a-          -> SappendAssoc b-vsgiAssoc f g gof (VerifiedSemigroup sappendA) sappendAAssoc-  = sappendInvAssoc sappendA sappendAAssoc f g gof--              -- -> VSappendAssoc a va-              -- -> VSappendAssoc b {vsemigroupInv f g gof va}
− tests/errors/TerminationExprNum.hs 
@@ -1,9 +0,0 @@-{-@ LIQUID "--expect-error-containing=Illegal termination specification for `TerminationExprNum.showSep`" @-}-module TerminationExprNum where--{-@ showSep :: _ -> xs:_ -> _ / [xs] @-} -- use xs as reducing param-showSep :: String -> [String] -> String-showSep sep []     = ""-showSep sep [x]    = x-showSep sep (x:xs) = x ++ sep ++ showSep sep xs-
− tests/errors/TerminationExprSort.hs 
@@ -1,9 +0,0 @@-{-@ LIQUID "--expect-error-containing=Illegal termination specification for `TerminationExprSort.showSep`" @-}-module TerminationExprSort where--{-@ showSep :: _ -> xs:_ -> _ / [len ys] @-} -- use xs as reducing param-showSep :: String -> [String] -> String-showSep sep []     = ""-showSep sep [x]    = x-showSep sep (x:xs) = x ++ sep ++ showSep sep xs-
− tests/errors/TerminationExprUnb.hs 
@@ -1,12 +0,0 @@-{-@ LIQUID "--expect-error-containing=Illegal termination specification for `go`" @-}-module TerminationExprUnb where--{- assume (!!) :: xs:[a] -> {v:Nat | v < len xs} -> a @-}--mysum xs = go 0 0-  where-    n = length xs-    {-@ go :: i:_ -> _ -> _ / [nn - i] @-}-    go i acc-      | i >= n    = acc-      | otherwise = go (i+1) (acc + xs !! i)
− tests/errors/UnboundAbsRef.hs 
@@ -1,11 +0,0 @@-{-@ LIQUID "--expect-error-containing=Cannot apply unbound abstract refinement `p`" @-}---- ISSUE: this "crashes" without a decent source location--- You can fix this with the signature `ide :: forall <p :: a -> Prop>. a<p> -> a<p>`--- but it would be nice to have an error message that pinpoints the location.--- https://github.com/ucsd-progsys/liquidhaskell/issues/655--module UnboundAbsRef where--{-@ ide :: a<p> -> a<p> @-}-ide x = x
− tests/errors/UnboundCheckVar.hs 
@@ -1,7 +0,0 @@-{-@ LIQUID "--checks=ink" @-}--module UnboundCheckVar where--inc :: Int -> Int -inc x = x + 1-
− tests/errors/UnboundFunInSpec.hs 
@@ -1,10 +0,0 @@-{-@ LIQUID "--expect-error-containing=Illegal type specification for `UnboundFunInSpec.three`" @-}-module UnboundFunInSpec () where--cnt   :: Int -> Int-cnt 0 = 0-cnt i = 1 + cnt (i-1)--{-@ three :: {v:Int | (cnt v) = 3} @-}-three :: Int-three = 15
− tests/errors/UnboundFunInSpec1.hs 
@@ -1,5 +0,0 @@-{-@ LIQUID "--expect-error-containing=Illegal type specification for `UnboundFunInSpec1.foo`" @-}-module UnboundFunInSpec1 where--{-@ foo :: xs:_ -> {v:_ | this = rubbish } @-}-foo _ _ = 0
− tests/errors/UnboundFunInSpec2.hs 
@@ -1,6 +0,0 @@-{-@ LIQUID "--expect-error-containing=Illegal type specification for `UnboundFunInSpec2.foo`" @-}-module UnboundFunInSpec2 where--{-@ foo :: Num a => { z : (xs:t -> {v : (t -> a) | this = rubbish }) | wow = hi } @-}-foo :: Num a => t -> t -> a-foo _ _ = 0
− tests/errors/UnboundVarInAssume.hs 
@@ -1,6 +0,0 @@-{-@ LIQUID "--expect-error-containing=Illegal type specification for `UnboundVarInAssume.incr`" @-}-module UnboundVarInAssume where--{-@ assume incr :: Int -> {v : Int | v == x} @-}-incr :: Int -> Int-incr x = x + 1
− tests/errors/UnboundVarInLocSig.hs 
@@ -1,9 +0,0 @@-{-@ LIQUID "--expect-error-containing=Illegal type specification for `bar`" @-}-module UnboundVarInLocSig where--{-@ foo :: x:_ -> y:_ -> {v:Int | v = x + y} @-} -foo :: Int -> Int -> Int -foo arg0 = bar -  where -    {-@ bar :: x:_ -> {v:Int | v = x + barg0} @-} -    bar arg1 = arg0 + arg1
− tests/errors/UnboundVarInReflect.hs 
@@ -1,9 +0,0 @@-{-@ LIQUID "--expect-error-containing=Illegal type specification for `UnboundVarInReflect.frog`" @-}-module UnboundVarInReflect where---- see GH #1708--{-@ LIQUID "--reflection" @-}-{-@ reflect frog @-}-frog :: () -> Bool-frog () = undefined
− tests/errors/UnboundVarInSpec.hs 
@@ -1,8 +0,0 @@-{-@ LIQUID "--expect-error-containing=Illegal type specification for `UnboundVarInSpec.foo`" @-}-module UnboundVarInSpec where---{-@ foo :: forall <p :: s -> s -> Bool>.-                   xs:s<p y> -> s<p xs> @-}-foo :: s -> s-foo s = s
− tests/ffi-include/foo.c 
@@ -1,4 +0,0 @@-#include "foo.h"-int foo(int x) {-  return x;-}
− tests/ffi-include/foo.h 
@@ -1,1 +0,0 @@-int foo(int);
− tests/import/client/C.hs 
@@ -1,9 +0,0 @@-{-@ LIQUID "--reflection" @-}--module C where -import Language-import B--{-@ getVal :: {e:Expr l st r | isEFalse e } -> {v:Int | false} @-}-getVal :: Expr l st r -> Int-getVal (EFalse v) = v
− tests/import/client/CliAliasGen00.hs 
@@ -1,5 +0,0 @@-module CliAliasGen00 where--import LibAliasGen00 --bar = foo 10
− tests/import/client/CliRedBlue.hs 
@@ -1,7 +0,0 @@-module CliRedBlue where--import           LibBlue -import qualified LibRedBlue as RB --{-@ yumyum :: _ -> Nat @-}-yumyum = RB.foo
− tests/import/client/Client0.hs 
@@ -1,6 +0,0 @@-module Client0 where--    import Client1Lib-    -    a :: Eq a => B a -> Bool -    a (B x y) = x == y
− tests/import/client/Client1Lib.hs 
@@ -1,8 +0,0 @@-module Client1Lib where --    import Client2Lib-    -    data B a = B {b1 :: a, b2 :: a }-    {-@ data B a = B {b1 :: a, b2 :: {v:a | cProp b1 v } } @-}--
− tests/import/client/Client2Lib.hs 
@@ -1,8 +0,0 @@-module Client2Lib where --    {-@ reflect cProp @-}-    -    cProp :: Eq a => a -> a -> Bool -    cProp x y = x == y --
− tests/import/client/ExactGADT9.hs 
@@ -1,13 +0,0 @@-{-@ LIQUID "--reflection" @-}-{-@ LIQUID "--no-adt"     @-}--{-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-}--module ExactGADT9 where--import ExactGADT8Lib--{-@ reflect bar @-}-bar :: RefinedFilter Blob typ -> Bool-bar (RefinedFilter BlobXVal) = True-bar (RefinedFilter BlobYVal) = True
− tests/import/client/FunClashLibLibClient.hs 
@@ -1,12 +0,0 @@--- TEST: the "transitively" imported name `FunClashLibLib.incr` is fully qualified and so --- SHOULD NOT get resolved to `FunClashLibLibClient.incr`; we allow this for "re-exported" names,--- e.g. to let `Data.Vector.Vector` get resolved to `Data.Vector.Generic.Vector` ... --- but SOMEHOW block this. [Current workaround: make sure you import-qualified `FunClashLibLib` --- so that the name "attaches" properly. sigh.--module FunClashLibLibClient where--import FunClashLib--incr :: Bool -> Bool-incr = not
− tests/import/client/LibRedBlue.hs 
@@ -1,8 +0,0 @@-module LibRedBlue where--import LibRed -import qualified LibBlue as Blue --{-@ foo :: Thing -> Nat @-}-foo :: Thing -> Int  -foo _ = 10
− tests/import/client/LiquidArrayInit.hs 
@@ -1,71 +0,0 @@-{-@ LIQUID "--no-termination" @-}--module LiquidArrayInit () where--import Language.Haskell.Liquid.Prelude-import LiquidArrayLib--{-@ zero ::-      i: {v: Int | v >= 0} ->-      n: Int ->-      a: (j: {v: Int | (0 <= v && v < i)} -> {v: Int | v = 0}) ->-      (k: {v: Int | (0 <= v && v < n)} -> {v: Int | v = 0}) @-}-zero :: Int -> Int -> (Int -> Int) -> (Int -> Int)-zero i n a = if i >= n then a-                       else zero (i + 1) n (set i 0 a)--{-@ tenZeroes :: i: {v: Int | (0 <= v && v < 10)} -> {v: Int | v = 0} @-}-tenZeroes = zero 0 10 empty--{-@ zeroBackwards ::-      i: Int ->-      n: {v: Int | v > i} ->-      a: (j: {v: Int | (i < v && v < n)} -> {v: Int | v = 0}) ->-      (k: {v: Int | (0 <= v && v < n)} -> {v: Int | v = 0}) @-}-zeroBackwards :: Int -> Int -> (Int -> Int) -> (Int -> Int)-zeroBackwards i n a = if i < 0 then a-                               else zeroBackwards (i - 1) n (set i 0 a)--{-@ tenZeroes' :: i: {v: Int | (0 <= v && v < 10)} -> {v: Int | v = 0} @-}-tenZeroes' = zeroBackwards 9 10 empty--{-@ zeroEveryOther ::-      i: {v: Int | (v >= 0 && v mod 2 = 0)} ->-      n: Int ->-      a: (j: {v: Int | (0 <= v && v < i && v mod 2 = 0)} -> {v: Int | v = 0}) ->-      (k: {v: Int | (0 <= v && v < n && v mod 2 = 0)} -> {v: Int | v = 0}) @-}-zeroEveryOther :: Int -> Int -> (Int -> Int) -> (Int -> Int)-zeroEveryOther i n a = if i >= n then a-                       else zeroEveryOther (i + 2) n (set i 0 a)--{-@ stridedZeroes ::-      j: {v: Int | (v mod 2 = 0 && 0 <= v && v < 10)} -> {v: Int | v = 0} @-}-stridedZeroes = zeroEveryOther 0 10 empty--{-@ initArray :: forall a <p :: x0: Int -> x1: a -> Bool>.-      f: (z: Int -> a<p z>) ->-      i: {v: Int | v >= 0} ->-      n: Int ->-      a: (j: {v: Int | (0 <= v && v < i)} -> a<p j>) ->-      (k: {v: Int | (0 <= v && v < n)} -> a<p k>) @-}-initArray f i n a = if i >= n then a-                              else initArray f (i + 1) n (set i (f i) a)--{-@ zeroInitArray ::-      i: {v: Int | v >= 0} ->-      n: Int ->-      a: (j: {v: Int | (0 <= v && v < i)} -> {v: Int | v = 0}) ->-      (k: {v: Int | (0 <= v && v < n)} -> {v: Int | v = 0}) @-}-zeroInitArray :: Int -> Int -> (Int -> Int) -> (Int -> Int)-zeroInitArray = initArray (const 0)--{-@ tenZeroes'' :: i: {v: Int | (0 <= v && v < 10)} -> {v: Int | v = 0} @-}-tenZeroes'' = zeroInitArray 0 10 empty--{-@ initid ::-      i: {v: Int | v >= 0} ->-      n: Int ->-      a: (j: {v: Int | (0 <= v && v < i)} -> {v: Int | v = j}) ->-      (k: {v: Int | (0 <= v && v < n)} -> {v: Int | v = k}) @-}-initid :: Int -> Int -> (Int -> Int) -> (Int -> Int)-initid = initArray id
− tests/import/client/LiquidArrayNullTerm.hs 
@@ -1,23 +0,0 @@-{-@ LIQUID "--no-termination" @-}--module LiquidArrayNullTerm () where--import Language.Haskell.Liquid.Prelude--import LiquidArrayLib--upperCaseString' :: Int -> Int -> (Int -> Int) -> (Int -> Int)-upperCaseString' n i s =-  let c = get i s in-  if c == 0 then s-            else upperCaseString' n (i + 1) (set i (c + 32) s)--{-@ upperCaseString ::-      n: {v: Int | v > 0} ->-      s: (j: {v : Int | (0 <= v && v < n)} ->-          {v: Int | (j = n - 1 => v = 0)}) ->-      (j: {v : Int | (0 <= v && v < n)} ->-       {v: Int | (j = n - 1 => v = 0)})-@-}-upperCaseString :: Int -> (Int -> Int) -> (Int -> Int)-upperCaseString n s = upperCaseString' n 0 s
− tests/import/client/ListClient.hs 
@@ -1,37 +0,0 @@--- | A "client" that uses the reflected definitions.--{-@ LIQUID "--reflection" @-}-{-@ LIQUID "--ple"        @-} --module ListClient where--import Prelude hiding (concat, filter, foldr, map)-import ListLib--{-@ reflect incr @-}-incr :: Int -> Int-incr x = x + 1--{-@ reflect isPos @-}-isPos :: Int -> Bool -isPos x = x > 0 --{-@ reflect ints0 @-}-ints0 :: [Int] -ints0 = [0, 1, 2] --{-@ reflect ints1 @-}-ints1 :: [Int] -ints1 = [1, 2, 3] --{-@ reflect ints2 @-}-ints2 :: [Int] -ints2 = [1, 2] --{-@ mapProp :: () -> { map incr ints0 == ints1 } @-}-mapProp () = ()--{-@ filterProp :: () -> { filter isPos ints0 == ints2 } @-}-filterProp () = ()--
− tests/import/client/NameClashClient.hs 
@@ -1,11 +0,0 @@-module NameClashClient where--import qualified NameClashLib as Lib --data Foo = FooClient Int--{-@ bar :: FooAlias -> Nat @-}-bar :: Lib.Foo -> Int -bar _ = 20 --baz = Lib.foo
− tests/import/client/RC1015.hs 
@@ -1,12 +0,0 @@-{-@ LIQUID "--exactdc" @-}-{-@ LIQUID "--higherorder" @-}--module RC1015 where--import RL1015Lib--{-@ car :: f:Foo -> { v: a | fooFirst f 0 == 10 } -> Int @-}-car :: Foo -> a -> Int-car f _ = 10--zag = car (Foo bling 10) (bling 0)
− tests/import/client/ReExportClient.hs 
@@ -1,12 +0,0 @@-module ReExportClient where--import ReExportLib--{-@ bar :: Foo -> {v:Int | 0 < v} @-} -bar :: Foo -> Int -bar (FooDC x) = x---{-@ booz :: Foo -> {v:Int | 0 < v} @-} -booz :: Foo -> Int -booz x = cfun x
− tests/import/client/ReflectClient0.hs 
@@ -1,16 +0,0 @@-module ReflectClient0 where--import ReflectLib0----- the below works with GreaterThanA instead of GreaterThan,--- as the former is defined as a "predicate" alias.--{-@ incr :: x:Nat -> {v:Nat | gtThan v x} @-}-incr :: Int -> Int-incr x = x + 1----- {-@ reflect floog @-}--- floog :: Int -> Int -> Bool--- floog x y = gtThan x y
− tests/import/client/ReflectClient1.hs 
@@ -1,7 +0,0 @@-module ReflectClient1 where--import ReflectLib1--{-@ myHead :: {v:[a] | not (isNull v) } -> a @-}-myHead :: [a] -> a-myHead (x:_) = x
− tests/import/client/ReflectClient2.hs 
@@ -1,8 +0,0 @@-{-@ LIQUID "--higherorder" @-}--module ReflectClient2 where--import ReflectLib2--{-@ proof :: a -> { v: Int | incr 5 == 6 } @-}-proof _ = incr 5
− tests/import/client/ReflectClient3.hs 
@@ -1,23 +0,0 @@-{-@ LIQUID "--reflection" @-} -{-@ LIQUID "--ple"        @-} --module ReflectClient3 where--import Language.Haskell.Liquid.ProofCombinators--import ReflectLib3---- THIS IS NEEDED TO BRING THE NAMES INTO SCOPE FOR GHC ...-forceImports = [ undefined next-               , undefined lDay-               ]---- THIS WORKS-{-@ test2 :: { next Mon == Tue } @-}-test2 = next Mon === Tue *** QED---- THIS DOES NOT WORK, but it DOES work if we remove the--- type parameter from `List`. However it DOES work if we--- put this back into ReflectLib3.hs-{-@ test4 :: { lDay Nil == Mon } @-}-test4 = lDay Nil === Mon *** QED
− tests/import/client/ReflectClient4.hs 
@@ -1,50 +0,0 @@--{-@ LIQUID "--reflection" @-} -{-@ LIQUID "--ple"        @-} --module ReflectClient4 where--import Language.Haskell.Liquid.ProofCombinators--import ReflectLib4---- THIS IS NEEDED TO BRING THE NAMES INTO SCOPE FOR GHC ...-forceImports = [ ]--{-@ test1 :: {v:List a | v = Nil} @-}-test1 :: List a-test1 = Nil---{-@ test2 :: {v:Proof | llen (Cons 1 Nil) = 1} @-}-test2 :: Proof-test2 =  llen (Cons 1 Nil)-      === 1 + llen Nil-      === 1-      *** QED--{-@ test3 :: {v:Proof | llen (Cons 1 (Cons 2 Nil)) = 2} @-}-test3 :: Proof-test3 =  llen (Cons 1 (Cons 2 Nil))-      === 1 + llen (Cons 2 Nil)-      === 1 + 1 + llen Nil-      *** QED--{-@ zen :: xs:List a -> {v:Nat | v = llen xs} @-}-zen :: List a -> Int-zen Nil        = 0-zen (Cons h t) = 1 + zen t--{-@ test5 :: { app (Cons 1 Nil) (Cons 2 (Cons 3 Nil)) = Cons 1 (Cons 2 (Cons 3 Nil)) } @-}-test5 =   app (Cons 1 Nil) (Cons 2 (Cons 3 Nil))-      === Cons 1 (app Nil (Cons 2 (Cons 3 Nil)))-      === Cons 1 (Cons 2 (Cons 3 Nil))-      *** QED--{-@ thmAppLen :: xs:List a -> ys:List a -> { llen (app xs ys) == llen xs + llen ys} @-}-thmAppLen :: List a -> List a -> Proof-thmAppLen Nil ys-  =  ()--thmAppLen (Cons x xs) ys-  = thmAppLen xs ys
− tests/import/client/ReflectClient4a.hs 
@@ -1,25 +0,0 @@-{-@ LIQUID "--reflection" @-} -{-@ LIQUID "--ple"        @-} --module ReflectClient4a where--import ReflectLib4 --stupidity = [ undefined gapp ]--{-@ test1 :: { llen Nil == 0 } @-}-test1 = ()--{-@ test2 :: { llen (Cons 2 Nil) == 1 } @-}-test2 = ()--{-@ test3 :: { llen (Cons 1 (Cons 2 Nil)) == 2 } @-}-test3 = ()--{-@ test4 :: { app Nil Nil == Nil } @-}-test4 = () --{-@ test5 :: { gapp Nil = Nil } @-}-test5 = ()--
− tests/import/client/ReflectClient5.hs 
@@ -1,11 +0,0 @@-{-@ LIQUID "--reflection" @-} -{-@ LIQUID "--ple"        @-} --module ReflectClient5 where---- import Language.Haskell.Liquid.ProofCombinators--import ReflectLib5--{-@ test5 :: { gapp Nil = Nil } @-}-test5 = ()
− tests/import/client/ReflectClient6.hs 
@@ -1,15 +0,0 @@-{-@ LIQUID "--reflection" @-} -{-@ LIQUID "--ple"        @-} --module ReflectClient6 where--import Language.Haskell.Liquid.ProofCombinators--import ReflectLib6--{-@ testOK :: { next Mon == Tue } @-}-testOK = next Mon === Tue *** QED--{-@ testFAIL :: { next Tue == Mon } @-}-testFAIL = trivial -
− tests/import/client/ReflectClient7.hs 
@@ -1,30 +0,0 @@-{-@ LIQUID "--reflection" @-}-{-@ LIQUID "--ple"        @-}--module ReflectClient7 where--import ReflectLib7 --import Language.Haskell.Liquid.ProofCombinators--data U1 p = U1--{-@ axiomatize fmapU1 @-}-fmapU1 :: (p -> q) -> U1 p -> U1 q-fmapU1 _ _ = U1--{-@ fmapU1Compose :: f:(q -> r)-                  -> g:(p -> q)-                  -> x:U1 p-                  -> { fmapU1 (compose f g) x == compose (fmapU1 f) (fmapU1 g) x }-@-}-fmapU1Compose :: (q -> r) -> (p -> q)-              -> U1 p -> Proof-fmapU1Compose f g x-  = trivial --  -- =   fmapU1 (compose f g) x-  -- ==. U1-  -- ==. fmapU1 f (fmapU1 g x)-  -- ==. compose (fmapU1 f) (fmapU1 g) x-  -- *** QED
− tests/import/client/ReflectClient8.hs 
@@ -1,36 +0,0 @@--- By Zack Grannan at https://github.com/ucsd-progsys/liquidhaskell/pull/1646--{-@ LIQUID "--reflection" @-}-{-@ LIQUID "--ple"        @-}-{-@ LIQUID "--extensionality" @-}--module ReflectClient8 where--import ReflectLib8--{-@ assume extensionality :: f:(a -> b) -> g:(a -> b) -> (x:a -> {f x == g x}) ->  {f == g}  @-}-extensionality :: (a -> b) -> (a -> b) -> (a -> ()) -> ()-extensionality _ _ _ = ()--{-@ refineExt' ::-        f  : (a -> Int)-     -> g  : (a -> Int)-     -> (x : a -> { v : () | Refines (f x) (g x)})-     -> x  : a-     -> {v : () | chooseF f g x = g x}-@-}-refineExt' :: (a -> Int) -> (a -> Int) -> (a -> ()) -> a -> ()-refineExt' _ _ proof x = proof x--{-@ refineExt ::-        f  : (a -> Int)-     -> g  : (a -> Int)-     -> (x : a -> { v : () | Refines (f x) (g x)})-     -> {v : () | RefinesF f g}-@-}-refineExt :: (a -> Int) -> (a -> Int) -> (a -> ()) -> ()-refineExt f g proof =-  extensionality (chooseF f g) g (refineExt' f g proof)--{-@ predicate Refines  M1 M2 = choose   M1 M2 = M2 @-}-{-@ predicate RefinesF F1 F2 = chooseF F1 F2 = F2 @-}
− tests/import/client/RewriteClient.hs 
@@ -1,19 +0,0 @@-module RewriteClient where--{-@ LIQUID "--reflection" @-}-{-@ LIQUID "--ple" @-}-{-@ LIQUID "--rw-termination-check" @-}--{-@ infix ++ @-}--import RewriteLib--{-@ rewriteWith assoc2 [assoc] @-}-{-@ assoc2 :: xs:[a] -> ys:[a] -> zs:[a] -> ws:[a]-          -> { xs ++ (ys ++ (zs ++ ws)) == ((xs ++ ys) ++ zs) ++ ws } @-}-assoc2 :: [a] -> [a] -> [a] -> [a] -> ()-assoc2 xs ys zs ws-  = () {--    assoc xs ys (zs ++ ws)-    `const` assoc (xs ++ ys) zs ws--}
− tests/import/client/STClient.hs 
@@ -1,45 +0,0 @@--- TAG: classes --- TAG: bounds --{-@ LIQUID "--no-pattern-inline" @-}-{-@ LIQUID "--higherorder"       @-}--module STClient where--import STLib ------------------------------------------------------------------------------------{-@ fresh :: forall <pre :: Int -> Bool>.-                    { zoo::Int |- Int<pre> <: {v:Int | 0 <= v} }-                    ST <pre, {\rv v -> ( 0 <= rv && rv + 1 = v )}> Int (Int<pre>)-  @-}--{- fresh :: ST <{\v -> (0 <= v)}, {\rv v -> ( 0 <= rv && rv + 1 = v )}> Int Nat @-}-fresh :: ST Int Int-fresh = S (\n -> (n, n+1))------------------------------------------------------------------------------------{-@ incr0 :: ST <{\v -> (0 <= v)}, {\rv v -> (0 <= rv && 1 <= v)}> Int Int @-}-incr0 :: ST Int Int-incr0 = do-  n <- fresh-  return n--{-@ incr1 :: ST <{\v -> (0 <= v)}, {\rv v -> (0 <= rv && 1 <= v)}> Int Int @-}-incr1 :: ST Int Int-incr1 = fresh >>= return--{-@ incr2 :: ST <{\v -> (0 == v)}, {\rv v -> (4 == v)}> Int Int @-}-incr2 :: ST Int Int-incr2 = do-  n0 <- fresh-  n1 <- fresh-  n2 <- fresh-  n3 <- fresh-  return (checkEq 3 n3)--{-@ checkEq :: x:Int -> y:{Int | y = x} -> {v:Int | v = y} @-}-checkEq :: Int -> Int -> Int-checkEq x y = y
− tests/import/client/T1096_Foo.hs 
@@ -1,8 +0,0 @@-module T1096_Foo where--import T1096_TypesLib--{-@ foo  :: f:Foo -> Foo / [size f] @-}-foo  :: Foo -> Foo-foo (A x) = A (foo x)-foo x     = x
− tests/import/client/T1104Client.hs 
@@ -1,19 +0,0 @@-module T1104Client where--import T1104Lib ---- 'bar' should ALSO work but right now, but right now 'twerp' is simpler. --{- bar :: Foo a b -> Maybe ({v:Foo a b | isFoo v}) @-}-bar :: Foo a b -> Maybe (Foo a b)-bar x | isFoo x   = Just x -      | otherwise = Nothing --{-@ burp :: (Foo a b) -> Nat @-} -burp :: Foo a b -> Int -burp x = toNat x --{-@ twerp :: x:(Foo a b) -> {v:Bool | v = isFoo x} @-}-twerp x = g x-  where -    g = isFoo
− tests/import/client/T1117.hs 
@@ -1,25 +0,0 @@-{-@ LIQUID "--reflection"        @-}--module T1117 where--import T1117Lib --import Language.Haskell.Liquid.ProofCombinators--{-@ axiomatize leqU1 @-}-leqU1 :: U1 p -> U1 p -> Bool-leqU1 _ _ = True--{-@ leqU1Refl :: x:U1 p -> { leqU1 x x } @-}-leqU1Refl :: U1 p -> Proof-leqU1Refl U1 = leqU1 U1 U1 === True *** QED--{-@ axiomatize leqProd @-}-leqProd :: Eq (f p)-        => (f p -> f p -> Bool) -> (g p -> g p -> Bool)-        -> Product f g p -> Product f g p -> Bool-leqProd leqFP leqGP (Product x1 y1) (Product x2 y2) =-  if x1 == x2-    then leqGP y1 y2-    else leqFP x1 x2-{-# INLINE leqProd #-}
− tests/import/client/T1118.hs 
@@ -1,26 +0,0 @@-{-@ LIQUID "--reflection" @-}--module T1118 where--import T1118Lib2 -import T1118Lib1--import Language.Haskell.Liquid.ProofCombinators--{-@ reflect leqU1 @-}-leqU1 :: U1 p -> U1 p -> Bool-leqU1 _ _ = True--{-@ leqU1Refl :: x:U1 p -> { leqU1 x x } @-}-leqU1Refl :: U1 p -> Proof-leqU1Refl U1 = leqU1 U1 U1 === True *** QED--{-@ reflect leqProd @-}-leqProd :: Eq (f p)-        => (f p -> f p -> Bool) -> (g p -> g p -> Bool)-        -> Product f g p -> Product f g p -> Bool-leqProd leqFP leqGP (Product x1 y1) (Product x2 y2) =-  if x1 == x2-    then leqGP y1 y2-    else leqFP x1 x2-{-# INLINE leqProd #-}
− tests/import/client/T1180.hs 
@@ -1,12 +0,0 @@-{-# LANGUAGE GADTs #-}--{-@ LIQUID "--exact-data-con" @-}-{-@ LIQUID "--noadt" @-}--module T1180 where--import PeanoLib--pInt :: Peano -> Int -pInt Z     = 0 -pInt (S n) = 1 + pInt n
− tests/import/client/T1688.hs 
@@ -1,14 +0,0 @@-{-# LANGUAGE GADTs #-}--{-@ LIQUID "--reflection"  @-}--module T1688 where--import T1688Lib--data HasFType where-    FTBC   :: Bool -> HasFType--{-@ ftypSize :: HasFType -> { n:Int | n >= 0 } @-}-ftypSize :: HasFType -> Int-ftypSize (FTBC {}) = 1
− tests/import/client/T1738.hs 
@@ -1,9 +0,0 @@-{-@ LIQUID "--reflection" @-}--module T1738 where--import T1738Lib--{-@ reflect bar @-}-bar :: Int -> Int-bar n = incr n
− tests/import/client/WrapClient.hs 
@@ -1,8 +0,0 @@-module WrapClient where--import WrapLib-import WrapLibCode --{-@ bar :: {v:Int | v = 2 } @-}-bar = foo 1-
− tests/import/lib/B.hs 
@@ -1,8 +0,0 @@-{-@ LIQUID "--reflection" @-}-module B  where -import Language--{-@ reflect subst @-}-subst :: Expr l st r -> Expr l st r -subst EUnit  = EUnit-subst e  = e
− tests/import/lib/ExactGADT8Lib.hs 
@@ -1,32 +0,0 @@-{-@ LIQUID "--reflection" @-}-{-@ LIQUID "--no-adt"     @-}--{-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-}-----------------------------------------------------------------------------------module ExactGADT8Lib where--class PersistEntity record where-    data EntityField record :: * -> *--{-@ data Blob  = Bingo { xVal :: Int, yVal :: Int } @-}-data Blob  = Bingo { xVal :: Int, yVal :: Int }--instance PersistEntity Blob where-  data EntityField Blob typ where-    BlobXVal :: EntityField Blob Int-    BlobYVal :: EntityField Blob Int--data RefinedFilter record typ = RefinedFilter-  { refinedFilterField  :: EntityField record typ-  }--evalQBlob :: RefinedFilter Blob typ -> Blob -> Bool-evalQBlob filter blob = case refinedFilterField filter of-  BlobXVal -> True-  BlobYVal -> True--{-@ reflect foo @-}-foo :: RefinedFilter Blob typ -> Blob -> Bool-foo (RefinedFilter BlobXVal) blob = True-foo (RefinedFilter BlobYVal) blob = True
− tests/import/lib/FunClashLib.hs 
@@ -1,8 +0,0 @@-module FunClashLib (blob) where--import FunClashLibLib --{-@ blob :: Nat -> Nat @-} -blob :: Int -> Int -blob = incr -
− tests/import/lib/FunClashLibLib.hs 
@@ -1,6 +0,0 @@--module FunClashLibLib where - -{-@ incr :: Nat -> Nat @-} -incr :: Int -> Int -incr x = x + 1
− tests/import/lib/Language.hs 
@@ -1,10 +0,0 @@-module Language where--data Expr l st r = EUnit | EFalse Int -{-@ data Expr l st r = EUnit | EFalse { elb1 :: {xxx:Int | false}}  @-}---{-@ measure isEFalse @-}-isEFalse :: Expr l st r -> Bool -isEFalse (EFalse _ ) = True -isEFalse _ = False
− tests/import/lib/LibAliasGen00.hs 
@@ -1,10 +0,0 @@--- Tests that we DON'T generalize type aliases before normalizing--module LibAliasGen00 where--{-@ type Floo a N = {v:[a] | len v = N} @-}--{-@ assume foo :: n:Nat -> Floo Int n @-}-foo :: Int -> [Int]-foo _ = undefined-
− tests/import/lib/LibBlue.hs 
@@ -1,8 +0,0 @@-module LibBlue where --data Thing = ThingBlue Int --{-@ foo :: Int -> Thing @-}-foo :: Int -> Thing -foo = ThingBlue -
− tests/import/lib/LibRed.hs 
@@ -1,8 +0,0 @@-module LibRed where --data Thing = ThingRed Int --{-@ foo :: Int -> Thing @-}-foo :: Int -> Thing -foo = ThingRed -
− tests/import/lib/LiquidArrayLib.hs 
@@ -1,20 +0,0 @@-module LiquidArrayLib where--{-@ set :: forall a <p :: x0: Int -> x1: a -> Bool, r :: x0: Int -> Bool>.-      i: Int<r> ->-      x: a<p i> ->-      a: (j: {v: Int<r> | v != i} -> a<p j>) ->-      (k: Int<r> -> a<p k>) @-}-set :: Int -> a -> (Int -> a) -> (Int -> a)-set i x a = \k -> if k == i then x else a k--{-@ get :: forall a <p :: x0: Int -> x1: a -> Bool, r :: x0: Int -> Bool>.-             i: Int<r> ->-             a: (j: Int<r> -> a<p j>) ->-             a<p i> @-}-get :: Int -> (Int -> a) -> a-get i a = a i--{-@ empty :: i: {v: Int | 0 = 1} -> a @-}-empty :: Int -> a-empty = const undefined
− tests/import/lib/ListLib.hs 
@@ -1,31 +0,0 @@--- | A module with some definitions for Lists-{-@ LIQUID "--reflection" @-}--module ListLib where--import Prelude hiding (concat, filter, foldr, map)--{-@ reflect map @-}-map :: (a -> b) -> [a] -> [b]-map f []     = []-map f (x:xs) = f x : map f xs--{-@ reflect filter @-}-filter :: (a -> Bool) -> [a] -> [a]-filter f []     = []-filter f (x:xs) = if f x then x : filter f xs else filter f xs--{-@ reflect append @-}-append :: [a] -> [a] -> [a]-append []     ys = ys-append (x:xs) ys = x : append xs ys--{-@ reflect concat @-}-concat :: [[a]] -> [a]-concat []     = []-concat (l:ls) = append l (concat ls)--{-@ reflect foldr @-}-foldr :: (a -> b -> b) -> b -> [a] -> b-foldr f i [ ]    = i-foldr f i (x:xs) = f x (foldr f i xs)
− tests/import/lib/NameClashLib.hs 
@@ -1,7 +0,0 @@-module NameClashLib where --data Foo = FooLib Int --{-@ type FooAlias = {v : Foo | False} @-}-foo :: Foo -> Int -foo _ = 10
− tests/import/lib/PeanoLib.hs 
@@ -1,33 +0,0 @@-{-# LANGUAGE GADTs #-}--{-@ LIQUID "--exact-data-con" @-}-{-@ LIQUID "--higherorder"    @-}-{-@ LIQUID "--ple"            @-}-{-@ LIQUID "--noadt"          @-}---module PeanoLib where------------------------------------------------------------------------------------- | Peano Numbers ------------------------------------------------------------------------------------------------------------------------------------------------{-@ data Peano [toNat] @-}-data Peano where-  Z :: Peano-  S :: Peano -> Peano--{-@ measure toNat @-}-{-@ toNat :: Peano -> Nat @-}-toNat :: Peano -> Int-toNat Z     = 0-toNat (S n) = 1 + toNat n--{-@ reflect plus @-}-plus :: Peano -> Peano -> Peano-plus Z     n = n-plus (S m) n = S (plus m n)--{-@ reflect double @-}-double :: Peano -> Peano-double n = plus n n
− tests/import/lib/RL1015Lib.hs 
@@ -1,18 +0,0 @@-{-@ LIQUID "--exactdc" @-}-{-@ LIQUID "--higherorder" @-}--module RL1015Lib where--data Foo = Foo { fooFirst :: Int -> Int , fooSnd :: Int}--{-@ data Foo = Foo { fooFirst :: Int -> Int , fooSnd :: Nat } @-}--{-@ bar :: f:Foo -> { v: a | fooFirst f 0 == 10 } -> Int @-}-bar :: Foo -> a -> Int-bar f _ = 10--{-@ reflect bling @-}-bling :: Int -> Int-bling x = 10--bag = bar (Foo bling 10) (bling 0)
− tests/import/lib/ReExportLib.hs 
@@ -1,6 +0,0 @@-module ReExportLib ( module ReExportLib-  , module X-  ) where---import SpecLib as X
− tests/import/lib/ReflectLib0.hs 
@@ -1,8 +0,0 @@-module ReflectLib0 where--{-@ inline gtThan @-}-gtThan :: Int -> Int -> Bool-gtThan x y = x > y---{-@ predicate GreaterThanA X Y = X > Y @-}
− tests/import/lib/ReflectLib1.hs 
@@ -1,6 +0,0 @@-module ReflectLib1 where--{-@ measure isNull @-}-isNull :: [a] -> Bool-isNull []     = True-isNull (x:xs) = False
− tests/import/lib/ReflectLib2.hs 
@@ -1,28 +0,0 @@-{-@ LIQUID "--higherorder" @-}--module ReflectLib2 where--{-@ reflect incr @-}-incr :: Int -> Int-incr x = x + 1--{-@ reflect incr2 @-}-incr2 :: Int -> Int -> Int-incr2 x y = x + y--{-@ reflect plus @-}-plus :: Int -> Int-plus x = apply incr x--{-@ reflect apply @-}-apply :: (a -> b) -> a -> b-apply f x = f x--{-@ reflect toNat @-}-toNat :: Int -> Int-{-@ toNat :: Nat -> Nat @-}-toNat n = if n == 0 then 0 else (1 + toNat (n - 1))---{-@ myproof :: a -> { v: Int | incr 5 == 6 } @-}-myproof _ = incr 5
− tests/import/lib/ReflectLib3.hs 
@@ -1,26 +0,0 @@-{-@ LIQUID "--reflection" @-}-{-@ LIQUID "--ple"        @-} --module ReflectLib3 where--import Language.Haskell.Liquid.ProofCombinators---- | Days -----------------------------------------------------------------------{-@ data Day = Mon | Tue @-}-data Day = Mon | Tue--{-@ reflect next @-}-next :: Day -> Day-next Mon = Tue-next Tue = Mon---- | Lists -----------------------------------------------------------------------{-@ data List  a = Nil | Cons {lHd :: a} @-}-data List a = Nil | Cons a--{-@ reflect lDay @-}-lDay :: List a -> Day-lDay Nil      = Mon-lDay (Cons x) = Tue
− tests/import/lib/ReflectLib4.hs 
@@ -1,31 +0,0 @@-{-@ LIQUID "--reflection" @-}-{-@ LIQUID "--ple"        @-}--module ReflectLib4 where---- | Lists -----------------------------------------------------------------------{-@ data List [llen] @-} -data List a = Nil | Cons {lHd :: a, lTl :: List a} --{-@ measure llen @-}-{-@ llen :: List a -> Nat @-}-llen :: List a -> Int-llen Nil        = 0-llen (Cons h t) = 1 + llen t---- TODO: make this work WITHOUT the invariant-{- invariant {v:List a | 0 <= llen v} @-}--{-@ reflect app @-}-app :: List a -> List a -> List a-app Nil         ys = ys-app (Cons x xs) ys = Cons x (app xs ys)--{-@ reflect gapp @-}-gapp :: List a -> List a-gapp Nil         = Nil-gapp (Cons x xs) = Nil--{-@ test4 :: { gapp Nil = Nil } @-}-test4 = ()
− tests/import/lib/ReflectLib5.hs 
@@ -1,31 +0,0 @@-{-@ LIQUID "--reflection" @-}-{-@ LIQUID "--ple"        @-}--module ReflectLib5 where---- | Days -----------------------------------------------------------------------{-@ data Day = Mon | Tue @-}-data Day = Mon | Tue--{-@ reflect next @-}-next :: Day -> Day-next Mon = Tue-next Tue = Mon--{-@ reflect lDay @-}-lDay :: List a -> Day-lDay Nil      = Mon-lDay (Cons x) = Tue---- | Lists -----------------------------------------------------------------------data List  a = Nil | Cons {lHd :: a}--{-@ reflect gapp @-}-gapp :: List a -> List a-gapp Nil      = Nil-gapp (Cons x) = Cons x--{-@ test4 :: { gapp Nil = Nil } @-}-test4 = ()
− tests/import/lib/ReflectLib6.hs 
@@ -1,14 +0,0 @@-{-@ LIQUID "--reflection" @-} -{-@ LIQUID "--ple" @-} --module ReflectLib6 where--data Day = Mon | Tue--{-@ reflect next @-}-next :: Day -> Day-next Mon = Tue-next Tue = Mon--{-@ testFAIL :: { next Mon == Tue } @-}-testFAIL = ()
− tests/import/lib/ReflectLib7.hs 
@@ -1,8 +0,0 @@-{-@ LIQUID "--higherorder"    @-}-{-@ LIQUID "--exactdc"        @-}--module ReflectLib7 where--{-@ reflect compose @-}-compose :: (b -> c) -> (a -> b) -> a -> c-compose f g x = f (g x)
− tests/import/lib/ReflectLib8.hs 
@@ -1,11 +0,0 @@--- By Zack Grannan at https://github.com/ucsd-progsys/liquidhaskell/pull/1646--{-@ LIQUID "--reflection" @-}-module ReflectLib8 where--{-@ reflect choose @-}-choose _ b = b--{-@ reflect chooseF @-}-chooseF f g x =-  choose (f x) (g x)
− tests/import/lib/RewriteLib.hs 
@@ -1,18 +0,0 @@-{-@ LIQUID "--reflection" @-}-{-@ LIQUID "--ple"        @-}--{-@ infix ++ @-}--module RewriteLib where-import Prelude hiding ((++))--{-@ reflect ++ @-}-(++)::[a] -> [a] -> [a]-[]     ++ ys = ys-(x:xs) ++ ys = x:(xs ++ys)--{-@ assoc :: xs:[a] -> ys:[a] -> zs:[a]-          -> { xs ++ (ys ++ zs) == (xs ++ ys) ++ zs } @-}-assoc :: [a] -> [a] -> [a] -> ()-assoc [] _ _       = ()-assoc (_:xs) ys zs = assoc xs ys zs
− tests/import/lib/STLib.hs 
@@ -1,43 +0,0 @@--- TAG: classes --- TAG: bounds --{-@ LIQUID "--no-pattern-inline" @-}--module STLib where--data ST s a = S {runSt :: s -> (a, s) }--{-@ data ST s a <pre :: s -> Bool, post :: a -> s -> Bool>-       = S { runSt :: (x:s<pre> -> ((a, s)<post>)) }-  @-}--{-@ apply :: forall <p :: s -> Bool, q :: a -> s -> Bool>.-               ST <p, q> s a -> s<p> -> (a, s)<q>-  @-}-apply :: ST s a -> s -> (a, s)-apply (S f) s = f s--instance Functor (ST s) where-  fmap = undefined--instance Applicative (ST s) where-  pure  = undefined-  (<*>) = undefined--instance Monad (ST s) where-  {-@ instance Monad (ST s) where-        return :: forall <p :: a -> s -> Bool>. x:a -> ST <{v:s<p x>| true}, p, {v:a | true}> s a ;-        >>=    :: forall <pbind :: s -> Bool, qbind :: a -> s -> Bool, rbind :: b -> s -> Bool>.-                                  ST <pbind, qbind> s a-                              -> (xbind:a -> ST <{v:s<qbind xbind> | true}, rbind> s b)-                              -> ST <pbind, rbind> s b;-        >>    :: forall <pbind :: s -> Bool, qbind :: a -> s -> Bool, rbind :: b -> s -> Bool>.-                                 ST <pbind, qbind> s a-                              -> (ST <{v:s| true}, rbind> s b)-                              -> ST <pbind, rbind> s b-    @-}-  return x    = S $ \s -> (x, s)-  (S m) >> k  = S $ \s -> let (a, s') = m s in apply k s'-  (S m) >>= k = S $ \s -> let (a, s') = m s in apply (k a) s'--
− tests/import/lib/SpecLib.hs 
@@ -1,9 +0,0 @@-module SpecLib where --data Foo = FooDC Int -{-@ data Foo = FooDC {unfoo :: {v:Int | 0 < v }} @-} --{-@ measure cfun @-}-{-@ cfun :: Foo -> {v:Int | 0 < v} @-} -cfun :: Foo -> Int -cfun (FooDC x) = x
− tests/import/lib/T1096_TypesLib.hs 
@@ -1,13 +0,0 @@-{-@ LIQUID "--no-termination" @-}--module T1096_TypesLib where--data Foo = A Foo | B --size :: Foo -> Integer --{-@ measure size @-}-{- invariant {t:Foo | 0 <= size t} @-}-{-@ size :: Foo -> {v:Integer |  0 <= v }  @-}-size (A x) = 1 + size x-size B     = 0
− tests/import/lib/T1102_LibX.hs 
@@ -1,11 +0,0 @@-{-@ LIQUID "--exact-data-con" @-}--module T1102_LibX where--import T1102_LibY --- import T1102_LibZ --- zink = fooA --{-@ theorem :: x:Bar -> {bar x = bar x} @-}-theorem :: Bar -> ()-theorem _ = ()
− tests/import/lib/T1102_LibY.hs 
@@ -1,11 +0,0 @@-{-@ LIQUID "--exact-data-con" @-}--module T1102_LibY where --import T1102_LibZ --data Bar = Bar {barFoo :: Foo Int Int} --{-@ reflect bar @-}-bar :: Bar -> Int -bar (Bar (Foo x _)) = x
− tests/import/lib/T1102_LibZ.hs 
@@ -1,6 +0,0 @@-{-@ LIQUID "--exact-data-con" @-}--module T1102_LibZ where--{-@ data Foo a b = Foo { fooA :: a, fooB :: b} @-}-data Foo a b = Foo {fooA :: a, fooB :: b}
− tests/import/lib/T1104Lib.hs 
@@ -1,19 +0,0 @@-module T1104Lib where --data Foo a b = Foo {fooA :: a, fooB :: b}  |  Bar--{-@ measure isFoo @-}-isFoo :: Foo a b -> Bool-isFoo (Foo _ _) = True -isFoo Bar       = False --{-@ measure toNat @-}-{-@ toNat :: Foo a b -> Nat @-} -toNat :: Foo a b -> Int -toNat (Foo _ _) = 10 -toNat Bar       = 20 --{-@ twerp :: x:(Foo a b) -> {v:Bool | v = isFoo x} @-}-twerp x = g x-  where -    g = isFoo
− tests/import/lib/T1112.hs 
@@ -1,19 +0,0 @@--{-@ LIQUID "--higherorder"    @-}-{-@ LIQUID "--exact-data-con" @-}--module T1112 where--import T1112Lib--{- data Product @-}--{-@ axiomatize leqProd @-}-leqProd :: Eq (f p)-        => (f p -> f p -> Bool) -> (g p -> g p -> Bool)-        -> Product f g p -> Product f g p -> Bool-leqProd leqFP leqGP (Product x1 y1) (Product x2 y2) =-  if x1 == x2-    then leqGP y1 y2-    else leqFP x1 x2-{-# INLINE leqProd #-}
− tests/import/lib/T1112Lib.hs 
@@ -1,3 +0,0 @@-module T1112Lib where--data Product f g p = Product (f p) (g p) deriving Eq
− tests/import/lib/T1117Lib.hs 
@@ -1,8 +0,0 @@-{-@ LIQUID "--higherorder"        @-}-{-@ LIQUID "--exactdc"            @-}--module T1117Lib where--data U1 p = U1--data Product f g p = Product (f p) (g p)
− tests/import/lib/T1118Lib1.hs 
@@ -1,7 +0,0 @@-{-@ LIQUID "--higherorder"        @-}-{-@ LIQUID "--exactdc"            @-}-module T1118Lib1 where--import T1118Lib2 --{- data Product @-}
− tests/import/lib/T1118Lib2.hs 
@@ -1,4 +0,0 @@-module T1118Lib2 where--data U1 p = U1-data Product f g p = Product (f p) (g p)
− tests/import/lib/T1688Lib.hs 
@@ -1,28 +0,0 @@-{-# LANGUAGE GADTs #-}--{-@ LIQUID "--reflection"  @-}--module T1688Lib where--type Vname = Int--{-@ measure propOf :: a -> b @-}-{-@ type ProofOf E = { proofObj:_ | propOf proofObj = E } @-}--data Expr = Bc Bool                   -- True, False-          | Ic Int                    -- 0, 1, 2, ...-          | Lambda Int Expr         -- \x.e          abstractions-          | App Expr Expr             -- e e'          applications--data Basic = TBool         -- Bool-           | TInt          -- Int--data StepProp where-    Step :: Expr -> Expr -> StepProp--data StepProof where-    EFake :: Vname -> Expr -> Expr -> StepProof--{-@ data StepProof where-      EFake :: x:Vname -> e:Expr -> v:_ -> ProofOf( Step (App (Lambda x e) v) e)-  @-}
− tests/import/lib/T1738Lib.hs 
@@ -1,5 +0,0 @@-module T1738Lib where--{-@ inline incr @-}-incr :: Int -> Int-incr x = x + 1
− tests/import/lib/WrapLib.hs 
@@ -1,6 +0,0 @@-module WrapLib ( module WrapLibCode ) where --import WrapLibCode--{-@ assume WrapLibCode.foo :: x:Nat -> {v:Nat | v = x + 1}  @-}-
− tests/import/lib/WrapLibCode.hs 
@@ -1,4 +0,0 @@-module WrapLibCode (foo) where--foo :: Int -> Int -foo x = x + 1
− tests/neg/AbsApp.hs 
@@ -1,16 +0,0 @@-{-@ LIQUID "--expect-any-error" @-}--- FAILING TEST: This should be rejected if we wish to disallow applying--- concrete refinements to non-refined types (e.g. Int) where they are currently--- silently dropped.--- issue #519--module AbsApp where--{-@ id2 :: forall <p :: Int -> Bool>. Int<p> -> Int<p> @-}-id2 :: Int -> Int-id2 x = x--{-@ type Neg = Int<{\x -> x < 0}> @-}--{-@ three :: Neg @-}-three = id2 3
− tests/neg/AdtPeano0.hs

file too large to diff

− tests/neg/AdtPeano1.hs

file too large to diff

− tests/neg/Alias00.hs

file too large to diff

− tests/neg/Ass0.hs

file too large to diff

− tests/neg/Ast.hs

file too large to diff

− tests/neg/AutoSize.hs

file too large to diff

− tests/neg/AutoTerm1.hs

file too large to diff

− tests/neg/Automate.hs

file too large to diff

− tests/neg/BadNats.hs

file too large to diff

− tests/neg/Bag1.hs

file too large to diff

− tests/neg/Baz.hs

file too large to diff

− tests/neg/BigNum.hs

file too large to diff

− tests/neg/BinarySearchOverflow.hs

file too large to diff

− tests/neg/Books.hs

file too large to diff

− tests/neg/CastedTotality.hs

file too large to diff

− tests/neg/CharLiterals.hs

file too large to diff

− tests/neg/CheckedNum.hs

file too large to diff

− tests/neg/CheckedNumLib.hs

file too large to diff

− tests/neg/Class1.hs

file too large to diff

− tests/neg/Class2.hs

file too large to diff

− tests/neg/Class3.hs

file too large to diff

− tests/neg/Class4.hs

file too large to diff

− tests/neg/CompareConstraints.hs

file too large to diff

− tests/neg/Concat.hs

file too large to diff

− tests/neg/Concat1.hs

file too large to diff

− tests/neg/Concat2.hs

file too large to diff

− tests/neg/Constraints.hs

file too large to diff

− tests/neg/ConstraintsAppend.hs

file too large to diff

− tests/neg/Contra0.hs

file too large to diff

− tests/neg/Coretologic.hs

file too large to diff

− tests/neg/Csv.hs

file too large to diff

− tests/neg/Datacon_eq.hs

file too large to diff

− tests/neg/DependentTypes.hs

file too large to diff

− tests/neg/Elim000.hs

file too large to diff

− tests/neg/Elim_ex_compose.hs

file too large to diff

− tests/neg/Elim_ex_let.hs

file too large to diff

− tests/neg/Elim_ex_list.hs

file too large to diff

− tests/neg/Elim_ex_map_1.hs

file too large to diff

− tests/neg/Elim_ex_map_2.hs

file too large to diff

− tests/neg/Elim_ex_map_3.hs

file too large to diff

− tests/neg/Errmsg.hs

file too large to diff

− tests/neg/Errorloc.hs

file too large to diff

− tests/neg/Eval.hs

file too large to diff

− tests/neg/EvalQuery.hs

file too large to diff

− tests/neg/Ex0_unsafe.hs

file too large to diff

− tests/neg/Ex1_unsafe.hs

file too large to diff

− tests/neg/ExactADT6.hs

file too large to diff

− tests/neg/ExactGADT6.hs

file too large to diff

− tests/neg/ExactGADT7.hs

file too large to diff

− tests/neg/Fail.hs

file too large to diff

− tests/neg/Fail1.hs

file too large to diff

− tests/neg/FancyTerm.hs

file too large to diff

− tests/neg/FilterAbs.hs

file too large to diff

− tests/neg/FoldN.hs

file too large to diff

− tests/neg/FoldN1.hs

file too large to diff

− tests/neg/FunSoundness.hs

file too large to diff

− tests/neg/FunctionRef.hs

file too large to diff

− tests/neg/GeneralizedTermination.hs

file too large to diff

− tests/neg/Grty0.hs

file too large to diff

− tests/neg/Grty1.hs

file too large to diff

− tests/neg/Grty2.hs

file too large to diff

− tests/neg/Grty3.hs

file too large to diff

− tests/neg/HasElem.hs

file too large to diff

− tests/neg/Hex00.hs

file too large to diff

− tests/neg/HigherOrder.hs

file too large to diff

− tests/neg/HolesTop.hs

file too large to diff

− tests/neg/Inc2.hs

file too large to diff

− tests/neg/IntAbsRef.hs

file too large to diff

− tests/neg/LazyWhere.hs

file too large to diff

− tests/neg/LazyWhere1.hs

file too large to diff

− tests/neg/LetRecStack.hs

file too large to diff

− tests/neg/List00.hs

file too large to diff

− tests/neg/ListConcat.hs

file too large to diff

− tests/neg/ListElem.hs

file too large to diff

− tests/neg/ListKeys.hs

file too large to diff

− tests/neg/ListMSort.hs

file too large to diff

− tests/neg/ListRange.hs

file too large to diff

− tests/neg/Listne.hs

file too large to diff

− tests/neg/Lit.hs

file too large to diff

− tests/neg/LocalSpec.hs

file too large to diff

− tests/neg/Mapreduce.hs

file too large to diff

− tests/neg/Mapreduce_tiny.hs

file too large to diff

− tests/neg/Maps.hs

file too large to diff

− tests/neg/Maybe.hs

file too large to diff

− tests/neg/MaybeMonad.hs

file too large to diff

− tests/neg/Meas0.hs

file too large to diff

− tests/neg/Meas2.hs

file too large to diff

− tests/neg/Meas3.hs

file too large to diff

− tests/neg/Meas5.hs

file too large to diff

− tests/neg/Meas7.hs

file too large to diff

− tests/neg/Meas9.hs

file too large to diff

− tests/neg/MeasureContains.hs

file too large to diff

− tests/neg/MeasureDups.hs

file too large to diff

− tests/neg/MergeSort.hs

file too large to diff

− tests/neg/Monad3.hs

file too large to diff

− tests/neg/Monad4.hs

file too large to diff

− tests/neg/Monad5.hs

file too large to diff

− tests/neg/Monad6.hs

file too large to diff

− tests/neg/Monad7.hs

file too large to diff

− tests/neg/Mr00.hs

file too large to diff

− tests/neg/MultiParamTypeClasses.hs

file too large to diff

− tests/neg/Multi_pred_app_00.hs

file too large to diff

− tests/neg/MultipleInvariants.hs

file too large to diff

− tests/neg/NameResolution.hs

file too large to diff

− tests/neg/NestedRecursion.hs

file too large to diff

− tests/neg/NoExhaustiveGuardsError.hs

file too large to diff

− tests/neg/NoMethodBindingError.hs

file too large to diff

− tests/neg/Null.hs

file too large to diff

− tests/neg/Pair.hs

file too large to diff

− tests/neg/Pair0.hs

file too large to diff

− tests/neg/PairMeasure.hs

file too large to diff

− tests/neg/Pargs.hs

file too large to diff

− tests/neg/Pargs1.hs

file too large to diff

− tests/neg/Partial.hs

file too large to diff

− tests/neg/Poly0.hs

file too large to diff

− tests/neg/Poly1.hs

file too large to diff

− tests/neg/Poly2.hs

file too large to diff

− tests/neg/Poly2_degenerate.hs

file too large to diff

− tests/neg/Polypred.hs

file too large to diff

− tests/neg/Poslist.hs

file too large to diff

− tests/neg/Pred.hs

file too large to diff

− tests/neg/Propability.hs

file too large to diff

− tests/neg/Propability0.hs

file too large to diff

− tests/neg/Prune0.hs

file too large to diff

− tests/neg/QQTySig.hs

file too large to diff

− tests/neg/QQTySyn1.hs

file too large to diff

− tests/neg/QQTySyn2.hs

file too large to diff

− tests/neg/RG.hs

file too large to diff

− tests/neg/Range.hs

file too large to diff

− tests/neg/ReWrite.hs

file too large to diff

− tests/neg/ReWrite2.hs

file too large to diff

− tests/neg/ReWrite3.hs

file too large to diff

− tests/neg/ReWrite4.hs

file too large to diff

− tests/neg/Rebind.hs

file too large to diff

− tests/neg/RecQSort.hs

file too large to diff

− tests/neg/RecSelector.hs

file too large to diff

− tests/neg/Record0.hs

file too large to diff

− tests/neg/Revshape.hs

file too large to diff

− tests/neg/Risers.hs

file too large to diff

− tests/neg/SafePartialFunctions.hs

file too large to diff

− tests/neg/Solver.hs

file too large to diff

− tests/neg/Stacks.hs

file too large to diff

− tests/neg/State0.hs

file too large to diff

− tests/neg/State00.hs

file too large to diff

− tests/neg/StateConstraints.hs

file too large to diff

− tests/neg/StateConstraints0.hs

file too large to diff

− tests/neg/StateConstraints00.hs

file too large to diff

− tests/neg/StrictPair0.hs

file too large to diff

− tests/neg/StrictPair1.hs

file too large to diff

− tests/neg/String00.hs

file too large to diff

− tests/neg/Strings.hs

file too large to diff

− tests/neg/SumPoly.hs

file too large to diff

− tests/neg/Sumk.hs

file too large to diff

− tests/neg/T1095C.hs

file too large to diff

− tests/neg/T1126.hs

file too large to diff

− tests/neg/T1198_3.hs

file too large to diff

− tests/neg/T1267.hs

file too large to diff

− tests/neg/T1286.hs

file too large to diff

− tests/neg/T1288.hs

file too large to diff

− tests/neg/T1490.hs

file too large to diff

− tests/neg/T1490A.hs

file too large to diff

− tests/neg/T1498.hs

file too large to diff

− tests/neg/T1498A.hs

file too large to diff

− tests/neg/T1546.hs

file too large to diff

− tests/neg/T1553.hs

file too large to diff

− tests/neg/T1553A.hs

file too large to diff

− tests/neg/T1555.hs

file too large to diff

− tests/neg/T1577.hs

file too large to diff

− tests/neg/T1604.hs

file too large to diff

− tests/neg/T1613.hs

file too large to diff

− tests/neg/T1642A.hs

file too large to diff

− tests/neg/T1657.hs

file too large to diff

− tests/neg/T1657A.hs

file too large to diff

− tests/neg/T1659.hs

file too large to diff

− tests/neg/T1814.hs

file too large to diff

− tests/neg/T1907.hs

file too large to diff

− tests/neg/T602.hs

file too large to diff

− tests/neg/T743.hs

file too large to diff

− tests/neg/T743_mini.hs

file too large to diff

− tests/neg/TermReal.hs

file too large to diff

− tests/neg/TerminationNum.hs

file too large to diff

− tests/neg/TerminationNum0.hs

file too large to diff

− tests/neg/Test00.hs

file too large to diff

− tests/neg/Test00a.hs

file too large to diff

− tests/neg/Test00b.hs

file too large to diff

− tests/neg/Test00c.hs

file too large to diff

− tests/neg/Test1.hs

file too large to diff

− tests/neg/Test2.hs

file too large to diff

− tests/neg/TopLevel.hs

file too large to diff

− tests/neg/TotalHaskell.hs

file too large to diff

− tests/neg/Trans.hs

file too large to diff

− tests/neg/Truespec.hs

file too large to diff

− tests/neg/Tyclass0_unsafe.hs

file too large to diff

− tests/neg/TypeLitNat.hs

file too large to diff

− tests/neg/Variance.hs

file too large to diff

− tests/neg/Variance1.hs

file too large to diff

− tests/neg/Vector00.hs

file too large to diff

− tests/neg/Vector0a.hs

file too large to diff

− tests/neg/Vector1a.hs

file too large to diff

− tests/neg/Vector2.hs

file too large to diff

− tests/neg/VerifiedNum.hs

file too large to diff

− tests/neg/Wrap0.hs

file too large to diff

− tests/neg/Wrap1.hs

file too large to diff

− tests/pos/AVL.hs

file too large to diff

− tests/pos/AVLRJ.hs

file too large to diff

− tests/pos/Abs.hs

file too large to diff

− tests/pos/Absref_crash.hs

file too large to diff

− tests/pos/Absref_crash0.hs

file too large to diff

− tests/pos/Ackermann.hs

file too large to diff

− tests/pos/Adt0.hs

file too large to diff

− tests/pos/AdtList0.hs

file too large to diff

− tests/pos/AdtList1.hs

file too large to diff

− tests/pos/AdtList2.hs

file too large to diff

− tests/pos/AdtList3.hs

file too large to diff

− tests/pos/AdtList4.hs

file too large to diff

− tests/pos/AdtList5.hs

file too large to diff

− tests/pos/AdtPeano0.hs

file too large to diff

− tests/pos/AdtPeano1.hs

file too large to diff

− tests/pos/Alias00.hs

file too large to diff

− tests/pos/Alias01.hs

file too large to diff

− tests/pos/Alphaconvert_List.hs

file too large to diff

− tests/pos/Alphaconvert_Set.hs

file too large to diff

− tests/pos/AmortizedQueue.hs

file too large to diff

− tests/pos/Anfbug.hs

file too large to diff

− tests/pos/Anftest.hs

file too large to diff

− tests/pos/Anish1.hs

file too large to diff

− tests/pos/Assume.hs

file too large to diff

− tests/pos/AssumedRecursive.hs

file too large to diff

− tests/pos/AutoSize.hs

file too large to diff

− tests/pos/AutoTerm.hs

file too large to diff

− tests/pos/AutoTerm1.hs

file too large to diff

− tests/pos/Automate.hs

file too large to diff

− tests/pos/Avg.hs

file too large to diff

− tests/pos/BST.hs

file too large to diff

− tests/pos/BST000.hs

file too large to diff

− tests/pos/Bag1.hs

file too large to diff

− tests/pos/BangPatterns.hs

file too large to diff

− tests/pos/BinarySearch.hs

file too large to diff

− tests/pos/BinarySearchOverflow.hs

file too large to diff

− tests/pos/Books.hs

file too large to diff

− tests/pos/Bool0.hs

file too large to diff

− tests/pos/Bool1.hs

file too large to diff

− tests/pos/Bool2.hs

file too large to diff

− tests/pos/Bounds1.hs

file too large to diff

− tests/pos/Case_lambda_join.hs

file too large to diff

− tests/pos/CasesToLogic.hs

file too large to diff

− tests/pos/Cat.hs

file too large to diff

− tests/pos/CharLiterals.hs

file too large to diff

− tests/pos/CheckedNum.hs

file too large to diff

− tests/pos/CheckedNumLib.hs

file too large to diff

− tests/pos/Chunks.hs

file too large to diff

− tests/pos/Class.hs

file too large to diff

− tests/pos/Class2.hs

file too large to diff

− tests/pos/ClassReg.hs

file too large to diff

− tests/pos/Client521.hs

file too large to diff

− tests/pos/ClojurVector.hs

file too large to diff

− tests/pos/Cmptag0.hs

file too large to diff

− tests/pos/Coercion.hs

file too large to diff

− tests/pos/Comma.hs

file too large to diff

− tests/pos/CommentedOut.hs

file too large to diff

− tests/pos/Compare.hs

file too large to diff

− tests/pos/Compare1.hs

file too large to diff

− tests/pos/Compare2.hs

file too large to diff

− tests/pos/CompareConstraints.hs

file too large to diff

− tests/pos/Comprehension.hs

file too large to diff

− tests/pos/ComprehensionTerm.hs

file too large to diff

− tests/pos/Constraints.hs

file too large to diff

− tests/pos/ConstraintsAppend.hs

file too large to diff

− tests/pos/Coretologic.hs

file too large to diff

− tests/pos/CountMonad.hs

file too large to diff

− tests/pos/Csgordon_issue_296.hs

file too large to diff

− tests/pos/Cut00.hs

file too large to diff

− tests/pos/DB00.hs

file too large to diff

− tests/pos/Data2.hs

file too large to diff

− tests/pos/DataBase.hs

file too large to diff

− tests/pos/DataConQuals.hs

file too large to diff

− tests/pos/Datacon0.hs

file too large to diff

− tests/pos/Datacon1.hs

file too large to diff

− tests/pos/Datacon_inv.hs

file too large to diff

− tests/pos/Deepmeas0.hs

file too large to diff

− tests/pos/DepData.hs

file too large to diff

− tests/pos/DepTriples.hs

file too large to diff

− tests/pos/DependentPairs.hs

file too large to diff

− tests/pos/DependentPairsFun.hs

file too large to diff

− tests/pos/Deptup.hs

file too large to diff

− tests/pos/Deptup1.hs

file too large to diff

− tests/pos/Deptup3.hs

file too large to diff

− tests/pos/DeptupW.hs

file too large to diff

− tests/pos/Div000.hs

file too large to diff

− tests/pos/Dropwhile.hs

file too large to diff

− tests/pos/Duplicate_bind.hs

file too large to diff

− tests/pos/Elements.hs

file too large to diff

− tests/pos/Elems.hs

file too large to diff

− tests/pos/Elim00.hs

file too large to diff

− tests/pos/Elim01.hs

file too large to diff

− tests/pos/Elim_ex_compose.hs

file too large to diff

− tests/pos/Elim_ex_let.hs

file too large to diff

− tests/pos/Elim_ex_list.hs

file too large to diff

− tests/pos/Elim_ex_map_1.hs

file too large to diff

− tests/pos/Elim_ex_map_2.hs

file too large to diff

− tests/pos/Elim_ex_map_3.hs

file too large to diff

− tests/pos/Eq_poly_measure.hs

file too large to diff

− tests/pos/Eqelems.hs

file too large to diff

− tests/pos/Eval.hs

file too large to diff

− tests/pos/EvalQuery.hs

file too large to diff

− tests/pos/Even.hs

file too large to diff

− tests/pos/Even0.hs

file too large to diff

− tests/pos/Ex0.hs

file too large to diff

− tests/pos/Ex01.hs

file too large to diff

− tests/pos/Ex1.hs

file too large to diff

− tests/pos/ExactADT6.hs

file too large to diff

− tests/pos/ExactGADT.hs

file too large to diff

− tests/pos/ExactGADT0.hs

file too large to diff

− tests/pos/ExactGADT1.hs

file too large to diff

− tests/pos/ExactGADT2.hs

file too large to diff

− tests/pos/ExactGADT6.hs

file too large to diff

− tests/pos/Exp0.hs

file too large to diff

− tests/pos/Extype.hs

file too large to diff

− tests/pos/FFI.hs

file too large to diff

− tests/pos/Fail.hs

file too large to diff

− tests/pos/FailName.hs

file too large to diff

− tests/pos/FancyMutualTerm.hs

file too large to diff

− tests/pos/FancyTerm.hs

file too large to diff

− tests/pos/Fib0.hs

file too large to diff

− tests/pos/FibEq.hs

file too large to diff

− tests/pos/FilterAbs.hs

file too large to diff

− tests/pos/FingerTree.hs

file too large to diff

− tests/pos/FoldN.hs

file too large to diff

− tests/pos/Foldl.hs

file too large to diff

− tests/pos/Foldr.hs

file too large to diff

− tests/pos/Foo.hs

file too large to diff

− tests/pos/For.hs

file too large to diff

− tests/pos/Forloop.hs

file too large to diff

− tests/pos/Fractional.hs

file too large to diff

− tests/pos/FractionalInstance.hs

file too large to diff

− tests/pos/GCD.hs

file too large to diff

− tests/pos/GadtEval.hs

file too large to diff

− tests/pos/GeneralizedTermination.hs

file too large to diff

− tests/pos/GhcSort1.hs

file too large to diff

− tests/pos/GhcSort2.hs

file too large to diff

− tests/pos/GhcSort3.hs

file too large to diff

− tests/pos/GhcSort3_T.hs

file too large to diff

− tests/pos/Gimme.hs

file too large to diff

− tests/pos/Go.hs

file too large to diff

− tests/pos/Go_ugly_type.hs

file too large to diff

− tests/pos/GoodHMeas.hs

file too large to diff

− tests/pos/Graph.hs

file too large to diff

− tests/pos/Grty0.hs

file too large to diff

− tests/pos/Grty1.hs

file too large to diff

− tests/pos/Grty2.hs

file too large to diff

− tests/pos/Grty3.hs

file too large to diff

− tests/pos/GuardedNegative.hs

file too large to diff

− tests/pos/HasElem.hs

file too large to diff

− tests/pos/HaskellMeasure.hs

file too large to diff

− tests/pos/HedgeUnion.hs

file too large to diff

− tests/pos/Hello.hs

file too large to diff

− tests/pos/Hex00.hs

file too large to diff

− tests/pos/HigherOrderRecFun.hs

file too large to diff

− tests/pos/Hole00.hs

file too large to diff

− tests/pos/Hole_app.hs

file too large to diff

− tests/pos/Hole_fun.hs

file too large to diff

− tests/pos/Holes.hs

file too large to diff

− tests/pos/Holes_Slicing.hs

file too large to diff

− tests/pos/Hutton.hs

file too large to diff

− tests/pos/IcfpDemo.hs

file too large to diff

− tests/pos/IdNat.hs

file too large to diff

− tests/pos/IdNat0.hs

file too large to diff

− tests/pos/Ignores.hs

file too large to diff

− tests/pos/Imp0.hs

file too large to diff

− tests/pos/Implies.hs

file too large to diff

− tests/pos/Infinity.hs

file too large to diff

− tests/pos/Infix.hs

file too large to diff

− tests/pos/Inline.hs

file too large to diff

− tests/pos/Inline1.hs

file too large to diff

− tests/pos/Invlhs.hs

file too large to diff

− tests/pos/Ite.hs

file too large to diff

− tests/pos/Ite1.hs

file too large to diff

− tests/pos/Jeff.hs

file too large to diff

− tests/pos/Keys.hs

file too large to diff

− tests/pos/Kmp.hs

file too large to diff

− tests/pos/KmpIO.hs

file too large to diff

− tests/pos/KmpVec.hs

file too large to diff

− tests/pos/LNot.hs

file too large to diff

− tests/pos/LambdaDeBruijn.hs

file too large to diff

− tests/pos/LambdaEval.hs

file too large to diff

− tests/pos/LambdaEvalMini.hs

file too large to diff

− tests/pos/LambdaEvalSuperTiny.hs

file too large to diff

− tests/pos/LambdaEvalTiny.hs

file too large to diff

− tests/pos/LazyWhere.hs

file too large to diff

− tests/pos/LazyWhere1.hs

file too large to diff

− tests/pos/Lets.hs

file too large to diff

− tests/pos/Lex.hs

file too large to diff

− tests/pos/Lib521.hs

file too large to diff

− tests/pos/ListAnf.hs

file too large to diff

− tests/pos/ListConcat.hs

file too large to diff

− tests/pos/ListElem.hs

file too large to diff

− tests/pos/ListISort_bag.hs

file too large to diff

− tests/pos/ListISort_perm.hs

file too large to diff

− tests/pos/ListKeys.hs

file too large to diff

− tests/pos/ListLen.hs

file too large to diff

− tests/pos/ListLen_LType.hs

file too large to diff

− tests/pos/ListMSort.hs

file too large to diff

− tests/pos/ListMSort_LType.hs

file too large to diff

− tests/pos/ListQSort_LType.hs

file too large to diff

− tests/pos/ListRange.hs

file too large to diff

− tests/pos/ListRange_LType.hs

file too large to diff

− tests/pos/ListReverse_LType.hs

file too large to diff

− tests/pos/ListSet.hs

file too large to diff

− tests/pos/ListSetDemo.hs

file too large to diff

− tests/pos/ListSort.hs

file too large to diff

− tests/pos/Listqual.hs

file too large to diff

− tests/pos/Lit.hs

file too large to diff

− tests/pos/Lit00.hs

file too large to diff

− tests/pos/Lit02.hs

file too large to diff

− tests/pos/LocalHole.hs

file too large to diff

− tests/pos/LocalLazy.hs

file too large to diff

− tests/pos/LocalSpec.hs

file too large to diff

− tests/pos/LocalSpecLib.hs

file too large to diff

− tests/pos/LogicCurry1.hs

file too large to diff

− tests/pos/Loo.hs

file too large to diff

− tests/pos/LooLib.hs

file too large to diff

− tests/pos/LooLibLib.hs

file too large to diff

− tests/pos/Malformed0.hs

file too large to diff

− tests/pos/Map.hs

file too large to diff

− tests/pos/Map0.hs

file too large to diff

− tests/pos/Map2.hs

file too large to diff

− tests/pos/MapFusion.hs

file too large to diff

− tests/pos/MapReduceVerified.hs

file too large to diff

− tests/pos/MapTvCrash.hs

file too large to diff

− tests/pos/Mapreduce_bare.hs

file too large to diff

− tests/pos/Maps.hs

file too large to diff

− tests/pos/Maps1.hs

file too large to diff

− tests/pos/MaskError.hs

file too large to diff

− tests/pos/Maybe.hs

file too large to diff

− tests/pos/Maybe0.hs

file too large to diff

− tests/pos/Maybe000.hs

file too large to diff

− tests/pos/Maybe1.hs

file too large to diff

− tests/pos/Maybe2.hs

file too large to diff

− tests/pos/Maybe3.hs

file too large to diff

− tests/pos/Maybe4.hs

file too large to diff

− tests/pos/Maybe5.hs

file too large to diff

− tests/pos/Meas0.hs

file too large to diff

− tests/pos/Meas00.hs

file too large to diff

− tests/pos/Meas00a.hs

file too large to diff

− tests/pos/Meas0a.hs

file too large to diff

− tests/pos/Meas1.hs

file too large to diff

− tests/pos/Meas10.hs

file too large to diff

− tests/pos/Meas11.hs

file too large to diff

− tests/pos/Meas2.hs

file too large to diff

− tests/pos/Meas4.hs

file too large to diff

− tests/pos/Meas5.hs

file too large to diff

− tests/pos/Meas6.hs

file too large to diff

− tests/pos/Meas7.hs

file too large to diff

− tests/pos/Meas8.hs

file too large to diff

− tests/pos/Meas9.hs

file too large to diff

− tests/pos/MeasureContains.hs

file too large to diff

− tests/pos/MeasureDups.hs

file too large to diff

− tests/pos/MeasureSets.hs

file too large to diff

− tests/pos/Measures.hs

file too large to diff

− tests/pos/Measures1.hs

file too large to diff

− tests/pos/Merge1.hs

file too large to diff

− tests/pos/MergeSort.hs

file too large to diff

− tests/pos/MergeSort_bag.hs

file too large to diff

− tests/pos/Mod.hs

file too large to diff

− tests/pos/ModLib.hs

file too large to diff

− tests/pos/ModTest.hs

file too large to diff

− tests/pos/Monad2.hs

file too large to diff

− tests/pos/Monad5.hs

file too large to diff

− tests/pos/Monad6.hs

file too large to diff

− tests/pos/Multi_pred_app_00.hs

file too large to diff

− tests/pos/Mutrec.hs

file too large to diff

− tests/pos/MutualRec.hs

file too large to diff

− tests/pos/MutuallyDependentADT.hs

file too large to diff

− tests/pos/Nats.hs

file too large to diff

− tests/pos/Niki.hs

file too large to diff

− tests/pos/Niki1.hs

file too large to diff

− tests/pos/NoCaseExpand.hs

file too large to diff

− tests/pos/NoExhaustiveGuardsError.hs

file too large to diff

− tests/pos/NoPositivityCheck.hs

file too large to diff

− tests/pos/Null.hs

file too large to diff

− tests/pos/ORM.hs

file too large to diff

− tests/pos/OrdList.hs

file too large to diff

− tests/pos/Pair.hs

file too large to diff

− tests/pos/Pair0.hs

file too large to diff

− tests/pos/Pair00.hs

file too large to diff

− tests/pos/PairMeasure.hs

file too large to diff

− tests/pos/PairMeasure0.hs

file too large to diff

− tests/pos/Pargs.hs

file too large to diff

− tests/pos/Pargs1.hs

file too large to diff

− tests/pos/Partial_tycon.hs

file too large to diff

− tests/pos/Partialmeasure.hs

file too large to diff

− tests/pos/Permutation.hs

file too large to diff

− tests/pos/PersistentVector.hs

file too large to diff

− tests/pos/Ple1.hs

file too large to diff

− tests/pos/PointDist.hs

file too large to diff

− tests/pos/Poly0.hs

file too large to diff

− tests/pos/Poly1.hs

file too large to diff

− tests/pos/Poly2.hs

file too large to diff

− tests/pos/Poly2_degenerate.hs

file too large to diff

− tests/pos/Poly3.hs

file too large to diff

− tests/pos/Poly3a.hs

file too large to diff

− tests/pos/Poly4.hs

file too large to diff

− tests/pos/Polyfun.hs

file too large to diff

− tests/pos/Polyqual.hs

file too large to diff

− tests/pos/PositivityCheck.hs

file too large to diff

− tests/pos/Poslist.hs

file too large to diff

− tests/pos/Poslist_dc.hs

file too large to diff

− tests/pos/Pragma0.hs

file too large to diff

− tests/pos/Pred.hs

file too large to diff

− tests/pos/PrimInt0.hs

file too large to diff

− tests/pos/Product.hs

file too large to diff

− tests/pos/Profcrasher.hs

file too large to diff

− tests/pos/PromotedDataCons.hs

file too large to diff

− tests/pos/Propability.hs

file too large to diff

− tests/pos/Propmeasure.hs

file too large to diff

− tests/pos/Propmeasure1.hs

file too large to diff

− tests/pos/QQTySig.hs

file too large to diff

− tests/pos/QQTySigTyVars.hs

file too large to diff

− tests/pos/QQTySyn.hs

file too large to diff

− tests/pos/QualTest.hs

file too large to diff

− tests/pos/RBTree.hs

file too large to diff

− tests/pos/RBTree_col_height.hs

file too large to diff

− tests/pos/RBTree_color.hs

file too large to diff

− tests/pos/RBTree_height.hs

file too large to diff

− tests/pos/RBTree_ord.hs

file too large to diff

− tests/pos/Range.hs

file too large to diff

− tests/pos/Range1.hs

file too large to diff

− tests/pos/RangeAdt.hs

file too large to diff

− tests/pos/ReWrite.hs

file too large to diff

− tests/pos/ReWrite10.hs

file too large to diff

− tests/pos/ReWrite2.hs

file too large to diff

− tests/pos/ReWrite3.hs

file too large to diff

− tests/pos/ReWrite4.hs

file too large to diff

− tests/pos/ReWrite5.hs

file too large to diff

− tests/pos/ReWrite6.hs

file too large to diff

− tests/pos/ReWrite7.hs

file too large to diff

− tests/pos/ReWrite8.hs

file too large to diff

− tests/pos/ReWrite9.hs

file too large to diff

− tests/pos/RealProps.hs

file too large to diff

− tests/pos/Rebind.hs

file too large to diff

− tests/pos/RecQSort.hs

file too large to diff

− tests/pos/RecQSort0.hs

file too large to diff

− tests/pos/RecSelector.hs

file too large to diff

− tests/pos/Rec_annot_go.hs

file too large to diff

− tests/pos/Record0.hs

file too large to diff

− tests/pos/Record1.hs

file too large to diff

− tests/pos/RecordSelectorError.hs

file too large to diff

− tests/pos/Recursion0.hs

file too large to diff

− tests/pos/Reduction.hs

file too large to diff

− tests/pos/RefinedADTs.hs

file too large to diff

− tests/pos/Reflect0.hs

file too large to diff

− tests/pos/ReflectAlias.hs

file too large to diff

− tests/pos/ReflectBooleanFunctions.hs

file too large to diff

− tests/pos/ReflectMutual.hs

file too large to diff

− tests/pos/RelativeComplete.hs

file too large to diff

− tests/pos/Repeat.hs

file too large to diff

− tests/pos/RepeatHigherOrder.hs

file too large to diff

− tests/pos/Resolve.hs

file too large to diff

− tests/pos/ResolveA.hs

file too large to diff

− tests/pos/ResolveALib.hs

file too large to diff

− tests/pos/ResolveB.hs

file too large to diff

− tests/pos/ResolveBLib.hs

file too large to diff

− tests/pos/ResolvePred.hs

file too large to diff

− tests/pos/Rest.hs

file too large to diff

− tests/pos/Risers.hs

file too large to diff

− tests/pos/Rta.hs

file too large to diff

− tests/pos/SafePartialFunctions.hs

file too large to diff

− tests/pos/Scanr.hs

file too large to diff

− tests/pos/SelfList.hs

file too large to diff

− tests/pos/SimplerNotation.hs

file too large to diff

− tests/pos/SimplifyTup00.hs

file too large to diff

− tests/pos/SingletonLists.hs

file too large to diff

− tests/pos/Solver.hs

file too large to diff

− tests/pos/Spec0.hs

file too large to diff

− tests/pos/StackClass.hs

file too large to diff

− tests/pos/StackMachine.hs

file too large to diff

− tests/pos/Stacks0.hs

file too large to diff

− tests/pos/State.hquals

file too large to diff

− tests/pos/State.hs

file too large to diff

− tests/pos/State00.hs

file too large to diff

− tests/pos/StateConstraints.hs

file too large to diff

− tests/pos/StateConstraints0.hs

file too large to diff

− tests/pos/StateConstraints00.hs

file too large to diff

− tests/pos/StateF00.hs

file too large to diff

− tests/pos/StateInvarint.hs

file too large to diff

− tests/pos/StateLib.hs

file too large to diff

− tests/pos/Streams.hs

file too large to diff

− tests/pos/StrictPair0.hs

file too large to diff

− tests/pos/StrictPair1.hs

file too large to diff

− tests/pos/String00.hs

file too large to diff

− tests/pos/StringLit.hs

file too large to diff

− tests/pos/Strings.hs

file too large to diff

− tests/pos/StructRec.hs

file too large to diff

− tests/pos/Sum.hs

file too large to diff

− tests/pos/T1013.hs

file too large to diff

− tests/pos/T1013A.hs

file too large to diff

− tests/pos/T1024.hs

file too large to diff

− tests/pos/T1025.hs

file too large to diff

− tests/pos/T1025a.hs

file too large to diff

− tests/pos/T1034.hs

file too large to diff

− tests/pos/T1045.hs

file too large to diff

− tests/pos/T1045a.hs

file too large to diff

− tests/pos/T1045aLib.hs

file too large to diff

− tests/pos/T1060.hs

file too large to diff

− tests/pos/T1065.hs

file too large to diff

− tests/pos/T1074.hs

file too large to diff

− tests/pos/T1085.hs

file too large to diff

− tests/pos/T1092.hs

file too large to diff

− tests/pos/T1095A.hs

file too large to diff

− tests/pos/T1095B.hs

file too large to diff

− tests/pos/T1095C.hs

file too large to diff

− tests/pos/T1100.hs

file too large to diff

− tests/pos/T1120A.hs

file too large to diff

− tests/pos/T1126.hs

file too large to diff

− tests/pos/T1126a.hs

file too large to diff

− tests/pos/T1198_1.hs

file too large to diff

− tests/pos/T1198_2.hs

file too large to diff

− tests/pos/T1198_3.hs

file too large to diff

− tests/pos/T1198_4.hs

file too large to diff

− tests/pos/T1220.hs

file too large to diff

− tests/pos/T1223.hs

file too large to diff

− tests/pos/T1267.hs

file too large to diff

− tests/pos/T1278.hs

file too large to diff

− tests/pos/T1278_2.hs

file too large to diff

− tests/pos/T1278_3.hs

file too large to diff

− tests/pos/T1286.hs

file too large to diff

− tests/pos/T1288.hs

file too large to diff

− tests/pos/T1289a.hs

file too large to diff

− tests/pos/T1302.hs

file too large to diff

− tests/pos/T1336.hs

file too large to diff

− tests/pos/T1363.hs

file too large to diff

− tests/pos/T1461.hs

file too large to diff

− tests/pos/T1498.hs

file too large to diff

− tests/pos/T1543.hs

file too large to diff

− tests/pos/T1544.hs

file too large to diff

− tests/pos/T1547.hs

file too large to diff

− tests/pos/T1548.hs

file too large to diff

− tests/pos/T1550.hs

file too large to diff

− tests/pos/T1555.hs

file too large to diff

− tests/pos/T1556.hs

file too large to diff

− tests/pos/T1560.hs

file too large to diff

− tests/pos/T1560B.hs

file too large to diff

− tests/pos/T1567.hs

file too large to diff

− tests/pos/T1568.hs

file too large to diff

− tests/pos/T1571.hs

file too large to diff

− tests/pos/T1577.hs

file too large to diff

− tests/pos/T1593.hs

file too large to diff

− tests/pos/T1595.hs

file too large to diff

− tests/pos/T1597.hs

file too large to diff

− tests/pos/T1603.hs

file too large to diff

− tests/pos/T1633.hs

file too large to diff

− tests/pos/T1634.hs

file too large to diff

− tests/pos/T1636.hs

file too large to diff

− tests/pos/T1642.hs

file too large to diff

− tests/pos/T1642A.hs

file too large to diff

− tests/pos/T1647.hs

file too large to diff

− tests/pos/T1649MeasuresDef.hs

file too large to diff

− tests/pos/T1649WorkTypes.hs

file too large to diff

− tests/pos/T1657.hs

file too large to diff

− tests/pos/T1660.hs

file too large to diff

− tests/pos/T1669.hs

file too large to diff

− tests/pos/T1670A.hs

file too large to diff

− tests/pos/T1670B.hs

file too large to diff

− tests/pos/T1697.hs

file too large to diff

− tests/pos/T1697A.hs

file too large to diff

− tests/pos/T1697C.hs

file too large to diff

− tests/pos/T1709.hs

file too large to diff

− tests/pos/T1749.hs

file too large to diff

− tests/pos/T1761.hs

file too large to diff

− tests/pos/T1775.hs

file too large to diff

− tests/pos/T1812.hs

file too large to diff

− tests/pos/T1874.hs

file too large to diff

− tests/pos/T2091.hs

file too large to diff

− tests/pos/T2093.hs

file too large to diff

− tests/pos/T2096.hs

file too large to diff

− tests/pos/T385.hs

file too large to diff

− tests/pos/T531.hs

file too large to diff

− tests/pos/T595.hs

file too large to diff

− tests/pos/T595a.hs

file too large to diff

− tests/pos/T598.hs

file too large to diff

− tests/pos/T716.hs

file too large to diff

− tests/pos/T819.hs

file too large to diff

− tests/pos/T819A.hs

file too large to diff

− tests/pos/T820.hs

file too large to diff

− tests/pos/T866.hs

file too large to diff

− tests/pos/T914.hs

file too large to diff

− tests/pos/TagBinder.hs

file too large to diff

− tests/pos/Take.hs

file too large to diff

− tests/pos/Term.hs

file too large to diff

− tests/pos/Term0.hs

file too large to diff

− tests/pos/Termination.hs

file too large to diff

− tests/pos/TerminationNum.hs

file too large to diff

− tests/pos/TerminationNum0.hs

file too large to diff

− tests/pos/Test0.hs

file too large to diff

− tests/pos/Test00.hs

file too large to diff

− tests/pos/Test000.hs

file too large to diff

− tests/pos/Test00_int.hs

file too large to diff

− tests/pos/Test00_old.hs

file too large to diff

− tests/pos/Test00b.hs

file too large to diff

− tests/pos/Test00c.hs

file too large to diff

− tests/pos/Test1.hs

file too large to diff

− tests/pos/Test2.hs

file too large to diff

− tests/pos/Test761.hs

file too large to diff

− tests/pos/TestRec.hs

file too large to diff

− tests/pos/TokenType.hs

file too large to diff

− tests/pos/Top0.hs

file too large to diff

− tests/pos/TopLevel.hs

file too large to diff

− tests/pos/ToyMVar.hs

file too large to diff

− tests/pos/Trans.hs

file too large to diff

− tests/pos/TransTAG.hs

file too large to diff

− tests/pos/Transpose.hs

file too large to diff

− tests/pos/Tup0.hs

file too large to diff

− tests/pos/Tupparse.hs

file too large to diff

− tests/pos/TyExpr.hs

file too large to diff

− tests/pos/Tyclass0.hs

file too large to diff

− tests/pos/Tyfam0.hs

file too large to diff

− tests/pos/TypeAlias.hs

file too large to diff

− tests/pos/TypeLitNat.hs

file too large to diff

− tests/pos/TypeLitString.hs

file too large to diff

− tests/pos/Tyvar.hs

file too large to diff

− tests/pos/UnboxedTuples.hs

file too large to diff

− tests/pos/UnboxedTuplesAndTH.hs

file too large to diff

− tests/pos/UndecidedGuards.hs

file too large to diff

− tests/pos/Unusedtyvars.hs

file too large to diff

− tests/pos/Variance.hs

file too large to diff

− tests/pos/Variance2.hs

file too large to diff

− tests/pos/Vector00.hs

file too large to diff

− tests/pos/Vector1.hs

file too large to diff

− tests/pos/Vector1a.hs

file too large to diff

− tests/pos/Vector1b.hs

file too large to diff

− tests/pos/Vector2.hs

file too large to diff

− tests/pos/VerifiedNum.hs

file too large to diff

− tests/pos/WBL.hs

file too large to diff

− tests/pos/WBL0.hs

file too large to diff

− tests/pos/WhyLH.hs

file too large to diff

− tests/pos/Words.hs

file too large to diff

− tests/pos/Words1.hs

file too large to diff

− tests/pos/Wrap0.hs

file too large to diff

− tests/pos/Wrap1.hs

file too large to diff

− tests/pos/WrapUnWrap.hs

file too large to diff

− tests/pos/ZipSO.hs

file too large to diff

− tests/pos/ZipW.hs

file too large to diff

− tests/pos/ZipW1.hs

file too large to diff

− tests/pos/ZipW2.hs

file too large to diff

− tests/pos/Zipper.hs

file too large to diff

− tests/pos/Zipper0.hs

file too large to diff

− tests/pos/Zipper000.hs

file too large to diff

− tests/pos/isort_erase.hs

file too large to diff

− tests/pos/listSet.hquals

file too large to diff

− tests/pos/selfList.hquals

file too large to diff

− tests/pos/test000.hs.hquals

file too large to diff