diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -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

c -> Prop, q :: a -> b -> Prop, r :: a -> c -> Prop>. + {-@ + (.) :: forall

c -> Prop, q :: a -> b -> Prop, r :: a -> c -> Prop>. {x::a, w::b |- c

<: c} (y:b -> c

) -> (z:a -> b) @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 ... + $ LIQUID_DEV_MODE=true ./scripts/test/test_plugin.sh ... -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: --ghc-options=-fplugin-opt=LiquidHaskell:--no-termination MySpecificTest + $ LIQUID_DEV_MODE=true cabal build tests: --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 / -cd .. -``` - -This will update `liquid-fixpoint` to the latest version on `` (usually `master`) -from `` (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/ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 diff --git a/devel/Paths_liquidhaskell.hs b/devel/Paths_liquidhaskell.hs deleted file mode 100644 --- a/devel/Paths_liquidhaskell.hs +++ /dev/null @@ -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] diff --git a/exe/Liquid.hs b/exe/Liquid.hs deleted file mode 100644 --- a/exe/Liquid.hs +++ /dev/null @@ -1,6 +0,0 @@ -import Language.Haskell.Liquid.Liquid (liquid) -import System.Environment (getArgs) --- import GhcTest - -main :: IO a -main = liquid =<< getArgs diff --git a/include/710/Data/Traversable.spec b/include/710/Data/Traversable.spec deleted file mode 100644 --- a/include/710/Data/Traversable.spec +++ /dev/null @@ -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}) diff --git a/include/Bot.hquals b/include/Bot.hquals deleted file mode 100644 --- a/include/Bot.hquals +++ /dev/null @@ -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 - diff --git a/include/Control/Exception.spec b/include/Control/Exception.spec deleted file mode 100644 --- a/include/Control/Exception.spec +++ /dev/null @@ -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 - diff --git a/include/Control/Parallel/Strategies.spec b/include/Control/Parallel/Strategies.spec deleted file mode 100644 --- a/include/Control/Parallel/Strategies.spec +++ /dev/null @@ -1,3 +0,0 @@ -module spec Control.Parallel.Strategies where - -assume withStrategy :: Control.Parallel.Strategies.Strategy a -> x:a -> {v:a | v == x} diff --git a/include/CoreToLogic.lg b/include/CoreToLogic.lg deleted file mode 100644 --- a/include/CoreToLogic.lg +++ /dev/null @@ -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 diff --git a/include/Data/Bits.spec b/include/Data/Bits.spec deleted file mode 100644 --- a/include/Data/Bits.spec +++ /dev/null @@ -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)) } - diff --git a/include/Data/ByteString.spec b/include/Data/ByteString.spec deleted file mode 100644 --- a/include/Data/ByteString.spec +++ /dev/null @@ -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 })) - diff --git a/include/Data/ByteString/Char8.spec b/include/Data/ByteString/Char8.spec deleted file mode 100644 --- a/include/Data/ByteString/Char8.spec +++ /dev/null @@ -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 } - // ) diff --git a/include/Data/ByteString/Lazy.spec b/include/Data/ByteString/Lazy.spec deleted file mode 100644 --- a/include/Data/ByteString/Lazy.spec +++ /dev/null @@ -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 } diff --git a/include/Data/ByteString/Short.spec b/include/Data/ByteString/Short.spec deleted file mode 100644 --- a/include/Data/ByteString/Short.spec +++ /dev/null @@ -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 diff --git a/include/Data/ByteString/Unsafe.spec b/include/Data/ByteString/Unsafe.spec deleted file mode 100644 --- a/include/Data/ByteString/Unsafe.spec +++ /dev/null @@ -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 } diff --git a/include/Data/Char.spec b/include/Data/Char.spec deleted file mode 100644 --- a/include/Data/Char.spec +++ /dev/null @@ -1,1 +0,0 @@ -module spec Data.Chare where diff --git a/include/Data/Either.spec b/include/Data/Either.spec deleted file mode 100644 --- a/include/Data/Either.spec +++ /dev/null @@ -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 diff --git a/include/Data/Foldable.spec b/include/Data/Foldable.spec deleted file mode 100644 --- a/include/Data/Foldable.spec +++ /dev/null @@ -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)} diff --git a/include/Data/Int.spec b/include/Data/Int.spec deleted file mode 100644 --- a/include/Data/Int.spec +++ /dev/null @@ -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} diff --git a/include/Data/Maybe.spec b/include/Data/Maybe.spec deleted file mode 100644 --- a/include/Data/Maybe.spec +++ /dev/null @@ -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} diff --git a/include/Data/OldList.spec b/include/Data/OldList.spec deleted file mode 100644 --- a/include/Data/OldList.spec +++ /dev/null @@ -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}] - - diff --git a/include/Data/Set.spec b/include/Data/Set.spec deleted file mode 100644 --- a/include/Data/Set.spec +++ /dev/null @@ -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) } diff --git a/include/Data/String.spec b/include/Data/String.spec deleted file mode 100644 --- a/include/Data/String.spec +++ /dev/null @@ -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 } diff --git a/include/Data/Text.spec b/include/Data/Text.spec deleted file mode 100644 --- a/include/Data/Text.spec +++ /dev/null @@ -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 })) - diff --git a/include/Data/Text/Fusion.spec b/include/Data/Text/Fusion.spec deleted file mode 100644 --- a/include/Data/Text/Fusion.spec +++ /dev/null @@ -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)} diff --git a/include/Data/Text/Fusion/Common.spec b/include/Data/Text/Fusion/Common.spec deleted file mode 100644 --- a/include/Data/Text/Fusion/Common.spec +++ /dev/null @@ -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)} diff --git a/include/Data/Text/Lazy/Fusion.spec b/include/Data/Text/Lazy/Fusion.spec deleted file mode 100644 --- a/include/Data/Text/Lazy/Fusion.spec +++ /dev/null @@ -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)} diff --git a/include/Data/Time.spec b/include/Data/Time.spec deleted file mode 100644 --- a/include/Data/Time.spec +++ /dev/null @@ -1,3 +0,0 @@ -module spec Data.Time where - -import Data.Time.Calendar diff --git a/include/Data/Tuple.spec b/include/Data/Tuple.spec deleted file mode 100644 --- a/include/Data/Tuple.spec +++ /dev/null @@ -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 } diff --git a/include/Data/Vector.hquals b/include/Data/Vector.hquals deleted file mode 100644 --- a/include/Data/Vector.hquals +++ /dev/null @@ -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) diff --git a/include/Data/Vector.spec b/include/Data/Vector.spec deleted file mode 100644 --- a/include/Data/Vector.spec +++ /dev/null @@ -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 diff --git a/include/Data/Word.spec b/include/Data/Word.spec deleted file mode 100644 --- a/include/Data/Word.spec +++ /dev/null @@ -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 } diff --git a/include/Data/Word8.spec b/include/Data/Word8.spec deleted file mode 100644 --- a/include/Data/Word8.spec +++ /dev/null @@ -1,5 +0,0 @@ -module spec Data.Word8 where - -import GHC.Word - -invariant {v:GHC.Word.Word8 | 0 <= v } diff --git a/include/Foreign/C/String.spec b/include/Foreign/C/String.spec deleted file mode 100644 --- a/include/Foreign/C/String.spec +++ /dev/null @@ -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 diff --git a/include/Foreign/C/Types.spec b/include/Foreign/C/Types.spec deleted file mode 100644 --- a/include/Foreign/C/Types.spec +++ /dev/null @@ -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 diff --git a/include/Foreign/ForeignPtr.spec b/include/Foreign/ForeignPtr.spec deleted file mode 100644 --- a/include/Foreign/ForeignPtr.spec +++ /dev/null @@ -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) diff --git a/include/Foreign/Marshal/Alloc.spec b/include/Foreign/Marshal/Alloc.spec deleted file mode 100644 --- a/include/Foreign/Marshal/Alloc.spec +++ /dev/null @@ -1,3 +0,0 @@ -module spec Foreign.Marshal.Alloc where - -Foreign.Marshal.Alloc.allocaBytes :: n:Nat -> (PtrN a n -> IO b) -> IO b diff --git a/include/Foreign/Marshal/Array.spec b/include/Foreign/Marshal/Array.spec deleted file mode 100644 --- a/include/Foreign/Marshal/Array.spec +++ /dev/null @@ -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 diff --git a/include/Foreign/Ptr.spec b/include/Foreign/Ptr.spec deleted file mode 100644 --- a/include/Foreign/Ptr.spec +++ /dev/null @@ -1,5 +0,0 @@ -module spec Foreign.Ptr where - -import GHC.Ptr - - diff --git a/include/Foreign/Storable.spec b/include/Foreign/Storable.spec deleted file mode 100644 --- a/include/Foreign/Storable.spec +++ /dev/null @@ -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 () - - diff --git a/include/GHC/Base.hquals b/include/GHC/Base.hquals deleted file mode 100644 --- a/include/GHC/Base.hquals +++ /dev/null @@ -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) diff --git a/include/GHC/Base.spec b/include/GHC/Base.spec deleted file mode 100644 --- a/include/GHC/Base.spec +++ /dev/null @@ -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) - - diff --git a/include/GHC/CString.spec b/include/GHC/CString.spec deleted file mode 100644 --- a/include/GHC/CString.spec +++ /dev/null @@ -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} diff --git a/include/GHC/Classes.spec b/include/GHC/Classes.spec deleted file mode 100644 --- a/include/GHC/Classes.spec +++ /dev/null @@ -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) } diff --git a/include/GHC/Exts.spec b/include/GHC/Exts.spec deleted file mode 100644 --- a/include/GHC/Exts.spec +++ /dev/null @@ -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 - - - diff --git a/include/GHC/ForeignPtr.spec b/include/GHC/ForeignPtr.spec deleted file mode 100644 --- a/include/GHC/ForeignPtr.spec +++ /dev/null @@ -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)) - diff --git a/include/GHC/IO/Handle.spec b/include/GHC/IO/Handle.spec deleted file mode 100644 --- a/include/GHC/IO/Handle.spec +++ /dev/null @@ -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}) diff --git a/include/GHC/Int.spec b/include/GHC/Int.spec deleted file mode 100644 --- a/include/GHC/Int.spec +++ /dev/null @@ -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} diff --git a/include/GHC/List.spec b/include/GHC/List.spec deleted file mode 100644 --- a/include/GHC/List.spec +++ /dev/null @@ -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 - -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 diff --git a/include/GHC/Num.spec b/include/GHC/Num.spec deleted file mode 100644 --- a/include/GHC/Num.spec +++ /dev/null @@ -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} diff --git a/include/GHC/Prim.spec b/include/GHC/Prim.spec deleted file mode 100644 --- a/include/GHC/Prim.spec +++ /dev/null @@ -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 diff --git a/include/GHC/Ptr.spec b/include/GHC/Ptr.spec deleted file mode 100644 --- a/include/GHC/Ptr.spec +++ /dev/null @@ -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 - diff --git a/include/GHC/Read.spec b/include/GHC/Read.spec deleted file mode 100644 --- a/include/GHC/Read.spec +++ /dev/null @@ -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))] diff --git a/include/GHC/Real.spec b/include/GHC/Real.spec deleted file mode 100644 --- a/include/GHC/Real.spec +++ /dev/null @@ -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) } diff --git a/include/GHC/Types.spec b/include/GHC/Types.spec deleted file mode 100644 --- a/include/GHC/Types.spec +++ /dev/null @@ -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 diff --git a/include/GHC/Word.spec b/include/GHC/Word.spec deleted file mode 100644 --- a/include/GHC/Word.spec +++ /dev/null @@ -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 diff --git a/include/KMeansHelper.hs b/include/KMeansHelper.hs deleted file mode 100644 --- a/include/KMeansHelper.hs +++ /dev/null @@ -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" - diff --git a/include/Language/Haskell/Liquid/Bag.hs b/include/Language/Haskell/Liquid/Bag.hs deleted file mode 100644 --- a/include/Language/Haskell/Liquid/Bag.hs +++ /dev/null @@ -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 _ = () diff --git a/include/Language/Haskell/Liquid/Equational.hs b/include/Language/Haskell/Liquid/Equational.hs deleted file mode 100644 --- a/include/Language/Haskell/Liquid/Equational.hs +++ /dev/null @@ -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 Bool>. a -> b -> a @-} -(?) :: a -> b -> a -x ? _ = x -{-# INLINE (?) #-} - -------------------------------------------------------------------------------- --- | Using proofs as theorems -------------------------------------------------------------------------------- - -withTheorem :: a -> Proof -> a -withTheorem z _ = z diff --git a/include/Language/Haskell/Liquid/Foreign.hs b/include/Language/Haskell/Liquid/Foreign.hs deleted file mode 100644 --- a/include/Language/Haskell/Liquid/Foreign.hs +++ /dev/null @@ -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 diff --git a/include/Language/Haskell/Liquid/List.hs b/include/Language/Haskell/Liquid/List.hs deleted file mode 100644 --- a/include/Language/Haskell/Liquid/List.hs +++ /dev/null @@ -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]) diff --git a/include/Language/Haskell/Liquid/Prelude.hs b/include/Language/Haskell/Liquid/Prelude.hs deleted file mode 100644 --- a/include/Language/Haskell/Liquid/Prelude.hs +++ /dev/null @@ -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

Bool>. (a

-> {v:Bool| v}) -> a -> a

@-} -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 diff --git a/include/Language/Haskell/Liquid/Prelude.pred b/include/Language/Haskell/Liquid/Prelude.pred deleted file mode 100644 --- a/include/Language/Haskell/Liquid/Prelude.pred +++ /dev/null @@ -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] diff --git a/include/Language/Haskell/Liquid/ProofCombinators.hs b/include/Language/Haskell/Liquid/ProofCombinators.hs deleted file mode 100644 --- a/include/Language/Haskell/Liquid/ProofCombinators.hs +++ /dev/null @@ -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 Bool, pb :: b -> Bool>. a -> b -> a @-} -(?) :: 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} @-} - - - diff --git a/include/Language/Haskell/Liquid/RTick.hs b/include/Language/Haskell/Liquid/RTick.hs deleted file mode 100644 --- a/include/Language/Haskell/Liquid/RTick.hs +++ /dev/null @@ -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 diff --git a/include/Language/Haskell/Liquid/String.hs b/include/Language/Haskell/Liquid/String.hs deleted file mode 100644 --- a/include/Language/Haskell/Liquid/String.hs +++ /dev/null @@ -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 diff --git a/include/Language/Haskell/Liquid/Synthesize/Error.hs b/include/Language/Haskell/Liquid/Synthesize/Error.hs deleted file mode 100644 --- a/include/Language/Haskell/Liquid/Synthesize/Error.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Language.Haskell.Liquid.Synthesize.Error where - -{-@ err :: { v: Int | false } -> a @-} -err :: Int -> a -err s = undefined diff --git a/include/NotReal.spec b/include/NotReal.spec deleted file mode 100644 --- a/include/NotReal.spec +++ /dev/null @@ -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 diff --git a/include/PatErr.spec b/include/PatErr.spec deleted file mode 100644 --- a/include/PatErr.spec +++ /dev/null @@ -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 diff --git a/include/Prelude.hquals b/include/Prelude.hquals deleted file mode 100644 --- a/include/Prelude.hquals +++ /dev/null @@ -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)]) diff --git a/include/Prelude.spec b/include/Prelude.spec deleted file mode 100644 --- a/include/Prelude.spec +++ /dev/null @@ -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

c -> Bool, q :: a -> b -> Bool, r :: a -> c -> Bool>. - {xcmp::a, wcmp::b |- c

<: c} - (ycmp:b -> c

) - -> (zcmp:a -> b) - -> xcmp:a -> c -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)]) diff --git a/include/Real.spec b/include/Real.spec deleted file mode 100644 --- a/include/Real.spec +++ /dev/null @@ -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) } diff --git a/include/System/IO.spec b/include/System/IO.spec deleted file mode 100644 --- a/include/System/IO.spec +++ /dev/null @@ -1,3 +0,0 @@ -module spec System.IO where - -import GHC.IO.Handle diff --git a/include/len.hquals b/include/len.hquals deleted file mode 100644 --- a/include/len.hquals +++ /dev/null @@ -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])) - diff --git a/liquidhaskell.cabal b/liquidhaskell.cabal --- a/liquidhaskell.cabal +++ b/liquidhaskell.cabal @@ -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 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 - 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 diff --git a/mirror-modules/CLI.hs b/mirror-modules/CLI.hs deleted file mode 100644 --- a/mirror-modules/CLI.hs +++ /dev/null @@ -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)" - ) diff --git a/mirror-modules/Main.hs b/mirror-modules/Main.hs deleted file mode 100644 --- a/mirror-modules/Main.hs +++ /dev/null @@ -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." ) diff --git a/mirror-modules/templates/MirrorModule.mustache b/mirror-modules/templates/MirrorModule.mustache deleted file mode 100644 --- a/mirror-modules/templates/MirrorModule.mustache +++ /dev/null @@ -1,3 +0,0 @@ -module {{ moduleName }} (module Exports) where - -import "{{ packageName }}" {{ moduleName }} as Exports diff --git a/src-ghc/Liquid/GHC/API.hs b/src-ghc/Liquid/GHC/API.hs deleted file mode 100644 --- a/src-ghc/Liquid/GHC/API.hs +++ /dev/null @@ -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 diff --git a/src-ghc/Liquid/GHC/API/StableModule.hs b/src-ghc/Liquid/GHC/API/StableModule.hs deleted file mode 100644 --- a/src-ghc/Liquid/GHC/API/StableModule.hs +++ /dev/null @@ -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) diff --git a/src-ghc/Liquid/GHC/GhcMonadLike.hs b/src-ghc/Liquid/GHC/GhcMonadLike.hs deleted file mode 100644 --- a/src-ghc/Liquid/GHC/GhcMonadLike.hs +++ /dev/null @@ -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 diff --git a/src-ghc/Liquid/GHC/Interface.hs b/src-ghc/Liquid/GHC/Interface.hs deleted file mode 100644 --- a/src-ghc/Liquid/GHC/Interface.hs +++ /dev/null @@ -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" diff --git a/src-ghc/Liquid/GHC/Logging.hs b/src-ghc/Liquid/GHC/Logging.hs deleted file mode 100644 --- a/src-ghc/Liquid/GHC/Logging.hs +++ /dev/null @@ -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) diff --git a/src-ghc/Liquid/GHC/Misc.hs b/src-ghc/Liquid/GHC/Misc.hs deleted file mode 100644 --- a/src-ghc/Liquid/GHC/Misc.hs +++ /dev/null @@ -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 "" -srcSpanSourcePos (RealSrcSpan s _) = realSrcSpanSourcePos s - -srcSpanSourcePosE :: SrcSpan -> SourcePos -srcSpanSourcePosE (UnhelpfulSpan _) = dummyPos "" -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 diff --git a/src-ghc/Liquid/GHC/Play.hs b/src-ghc/Liquid/GHC/Play.hs deleted file mode 100644 --- a/src-ghc/Liquid/GHC/Play.hs +++ /dev/null @@ -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 diff --git a/src-ghc/Liquid/GHC/Resugar.hs b/src-ghc/Liquid/GHC/Resugar.hs deleted file mode 100644 --- a/src-ghc/Liquid/GHC/Resugar.hs +++ /dev/null @@ -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) diff --git a/src-ghc/Liquid/GHC/SpanStack.hs b/src-ghc/Liquid/GHC/SpanStack.hs deleted file mode 100644 --- a/src-ghc/Liquid/GHC/SpanStack.hs +++ /dev/null @@ -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 diff --git a/src-ghc/Liquid/GHC/TypeRep.hs b/src-ghc/Liquid/GHC/TypeRep.hs deleted file mode 100644 --- a/src-ghc/Liquid/GHC/TypeRep.hs +++ /dev/null @@ -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 diff --git a/src-ghc/Liquid/GHC/Types.hs b/src-ghc/Liquid/GHC/Types.hs deleted file mode 100644 --- a/src-ghc/Liquid/GHC/Types.hs +++ /dev/null @@ -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 diff --git a/src/Data/Bits_LHAssumptions.hs b/src/Data/Bits_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bits_LHAssumptions.hs @@ -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)) } +@-} diff --git a/src/Data/ByteString/Char8_LHAssumptions.hs b/src/Data/ByteString/Char8_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Char8_LHAssumptions.hs @@ -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 } +@-} diff --git a/src/Data/ByteString/Lazy/Char8_LHAssumptions.hs b/src/Data/ByteString/Lazy/Char8_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Lazy/Char8_LHAssumptions.hs @@ -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 } + +@-} diff --git a/src/Data/ByteString/Lazy_LHAssumptions.hs b/src/Data/ByteString/Lazy_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Lazy_LHAssumptions.hs @@ -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 } +@-} diff --git a/src/Data/ByteString/Short_LHAssumptions.hs b/src/Data/ByteString/Short_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Short_LHAssumptions.hs @@ -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 +@-} diff --git a/src/Data/ByteString/Unsafe_LHAssumptions.hs b/src/Data/ByteString/Unsafe_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Unsafe_LHAssumptions.hs @@ -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 } +@-} diff --git a/src/Data/ByteString_LHAssumptions.hs b/src/Data/ByteString_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString_LHAssumptions.hs @@ -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 })) +@-} diff --git a/src/Data/Either_LHAssumptions.hs b/src/Data/Either_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/Data/Either_LHAssumptions.hs @@ -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 +@-} diff --git a/src/Data/Foldable_LHAssumptions.hs b/src/Data/Foldable_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/Data/Foldable_LHAssumptions.hs @@ -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)} +@-} diff --git a/src/Data/Int_LHAssumptions.hs b/src/Data/Int_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/Data/Int_LHAssumptions.hs @@ -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 + +@-} diff --git a/src/Data/Maybe_LHAssumptions.hs b/src/Data/Maybe_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/Data/Maybe_LHAssumptions.hs @@ -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 +@-} diff --git a/src/Data/Set_LHAssumptions.hs b/src/Data/Set_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/Data/Set_LHAssumptions.hs @@ -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) } + +@-} diff --git a/src/Data/String_LHAssumptions.hs b/src/Data/String_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/Data/String_LHAssumptions.hs @@ -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 } +@-} diff --git a/src/Data/Tuple_LHAssumptions.hs b/src/Data/Tuple_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tuple_LHAssumptions.hs @@ -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)) +@-} diff --git a/src/Data/Word_LHAssumptions.hs b/src/Data/Word_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/Data/Word_LHAssumptions.hs @@ -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 } +@-} diff --git a/src/Foreign/C/String_LHAssumptions.hs b/src/Foreign/C/String_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/C/String_LHAssumptions.hs @@ -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 +@-} diff --git a/src/Foreign/C/Types_LHAssumptions.hs b/src/Foreign/C/Types_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/C/Types_LHAssumptions.hs @@ -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 + +@-} diff --git a/src/Foreign/Concurrent_LHAssumptions.hs b/src/Foreign/Concurrent_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Concurrent_LHAssumptions.hs @@ -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))) +@-} diff --git a/src/Foreign/ForeignPtr_LHAssumptions.hs b/src/Foreign/ForeignPtr_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/ForeignPtr_LHAssumptions.hs @@ -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) +@-} diff --git a/src/Foreign/Marshal/Alloc_LHAssumptions.hs b/src/Foreign/Marshal/Alloc_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Marshal/Alloc_LHAssumptions.hs @@ -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 +@-} diff --git a/src/Foreign/Ptr_LHAssumptions.hs b/src/Foreign/Ptr_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Ptr_LHAssumptions.hs @@ -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 } + +@-} diff --git a/src/Foreign/Storable_LHAssumptions.hs b/src/Foreign/Storable_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Storable_LHAssumptions.hs @@ -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 () +@-} diff --git a/src/GHC/Base_LHAssumptions.hs b/src/GHC/Base_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Base_LHAssumptions.hs @@ -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

c -> Bool, q :: a -> b -> Bool, r :: a -> c -> Bool>. + {xcmp::a, wcmp::b |- c

<: c} + (ycmp:b -> c

) + -> (zcmp:a -> b) + -> xcmp:a -> c + +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) + +@-} diff --git a/src/GHC/CString_LHAssumptions.hs b/src/GHC/CString_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/GHC/CString_LHAssumptions.hs @@ -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} +@-} diff --git a/src/GHC/Classes_LHAssumptions.hs b/src/GHC/Classes_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Classes_LHAssumptions.hs @@ -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) } + +@-} diff --git a/src/GHC/Exts_LHAssumptions.hs b/src/GHC/Exts_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Exts_LHAssumptions.hs @@ -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} + +@-} diff --git a/src/GHC/Float_LHAssumptions.hs b/src/GHC/Float_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Float_LHAssumptions.hs @@ -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 +@-} diff --git a/src/GHC/ForeignPtr_LHAssumptions.hs b/src/GHC/ForeignPtr_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/GHC/ForeignPtr_LHAssumptions.hs @@ -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)) +@-} diff --git a/src/GHC/IO/Handle_LHAssumptions.hs b/src/GHC/IO/Handle_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/GHC/IO/Handle_LHAssumptions.hs @@ -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}) +@-} diff --git a/src/GHC/Int_LHAssumptions.hs b/src/GHC/Int_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Int_LHAssumptions.hs @@ -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} +@-} diff --git a/src/GHC/List_LHAssumptions.hs b/src/GHC/List_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/GHC/List_LHAssumptions.hs @@ -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 +@-} diff --git a/src/GHC/Maybe_LHAssumptions.hs b/src/GHC/Maybe_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Maybe_LHAssumptions.hs @@ -0,0 +1,5 @@ +module GHC.Maybe_LHAssumptions where + +{-@ +data Maybe a = Nothing | Just a +@-} diff --git a/src/GHC/Num_LHAssumptions.hs b/src/GHC/Num_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Num_LHAssumptions.hs @@ -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 } +@-} diff --git a/src/GHC/Ptr_LHAssumptions.hs b/src/GHC/Ptr_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Ptr_LHAssumptions.hs @@ -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 +@-} diff --git a/src/GHC/Real_LHAssumptions.hs b/src/GHC/Real_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Real_LHAssumptions.hs @@ -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) } +@-} diff --git a/src/GHC/Types_LHAssumptions.hs b/src/GHC/Types_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Types_LHAssumptions.hs @@ -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 +@-} diff --git a/src/GHC/Word_LHAssumptions.hs b/src/GHC/Word_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Word_LHAssumptions.hs @@ -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 +@-} diff --git a/src/Language/Haskell/Liquid/Bare.hs b/src/Language/Haskell/Liquid/Bare.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Bare.hs +++ /dev/null @@ -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) diff --git a/src/Language/Haskell/Liquid/Bare/Axiom.hs b/src/Language/Haskell/Liquid/Bare/Axiom.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Bare/Axiom.hs +++ /dev/null @@ -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" diff --git a/src/Language/Haskell/Liquid/Bare/Check.hs b/src/Language/Haskell/Liquid/Bare/Check.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Bare/Check.hs +++ /dev/null @@ -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))) - - - diff --git a/src/Language/Haskell/Liquid/Bare/Class.hs b/src/Language/Haskell/Liquid/Bare/Class.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Bare/Class.hs +++ /dev/null @@ -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) diff --git a/src/Language/Haskell/Liquid/Bare/DataType.hs b/src/Language/Haskell/Liquid/Bare/DataType.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Bare/DataType.hs +++ /dev/null @@ -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) diff --git a/src/Language/Haskell/Liquid/Bare/Elaborate.hs b/src/Language/Haskell/Liquid/Bare/Elaborate.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Bare/Elaborate.hs +++ /dev/null @@ -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 . 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" diff --git a/src/Language/Haskell/Liquid/Bare/Expand.hs b/src/Language/Haskell/Liquid/Bare/Expand.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Bare/Expand.hs +++ /dev/null @@ -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"] diff --git a/src/Language/Haskell/Liquid/Bare/Laws.hs b/src/Language/Haskell/Liquid/Bare/Laws.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Bare/Laws.hs +++ /dev/null @@ -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) - diff --git a/src/Language/Haskell/Liquid/Bare/Measure.hs b/src/Language/Haskell/Liquid/Bare/Measure.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Bare/Measure.hs +++ /dev/null @@ -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 - --} - diff --git a/src/Language/Haskell/Liquid/Bare/Misc.hs b/src/Language/Haskell/Liquid/Bare/Misc.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Bare/Misc.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/Bare/Plugged.hs b/src/Language/Haskell/Liquid/Bare/Plugged.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Bare/Plugged.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/Bare/Resolve.hs b/src/Language/Haskell/Liquid/Bare/Resolve.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Bare/Resolve.hs +++ /dev/null @@ -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) diff --git a/src/Language/Haskell/Liquid/Bare/Slice.hs b/src/Language/Haskell/Liquid/Bare/Slice.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Bare/Slice.hs +++ /dev/null @@ -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 - } --} - - diff --git a/src/Language/Haskell/Liquid/Bare/ToBare.hs b/src/Language/Haskell/Liquid/Bare/ToBare.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Bare/ToBare.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/Bare/Typeclass.hs b/src/Language/Haskell/Liquid/Bare/Typeclass.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Bare/Typeclass.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/Bare/Types.hs b/src/Language/Haskell/Liquid/Bare/Types.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Bare/Types.hs +++ /dev/null @@ -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) diff --git a/src/Language/Haskell/Liquid/Cabal.hs b/src/Language/Haskell/Liquid/Cabal.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Cabal.hs +++ /dev/null @@ -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 () } diff --git a/src/Language/Haskell/Liquid/Constraint/Constraint.hs b/src/Language/Haskell/Liquid/Constraint/Constraint.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Constraint/Constraint.hs +++ /dev/null @@ -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) diff --git a/src/Language/Haskell/Liquid/Constraint/Env.hs b/src/Language/Haskell/Liquid/Constraint/Env.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Constraint/Env.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/Constraint/Fresh.hs b/src/Language/Haskell/Liquid/Constraint/Fresh.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Constraint/Fresh.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/Constraint/Generate.hs b/src/Language/Haskell/Liquid/Constraint/Generate.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Constraint/Generate.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/Constraint/Init.hs b/src/Language/Haskell/Liquid/Constraint/Init.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Constraint/Init.hs +++ /dev/null @@ -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) diff --git a/src/Language/Haskell/Liquid/Constraint/Monad.hs b/src/Language/Haskell/Liquid/Constraint/Monad.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Constraint/Monad.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/Constraint/Qualifier.hs b/src/Language/Haskell/Liquid/Constraint/Qualifier.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Constraint/Qualifier.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/Constraint/Relational.hs b/src/Language/Haskell/Liquid/Constraint/Relational.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Constraint/Relational.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/Constraint/Split.hs b/src/Language/Haskell/Liquid/Constraint/Split.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Constraint/Split.hs +++ /dev/null @@ -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) diff --git a/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs b/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/Constraint/Types.hs b/src/Language/Haskell/Liquid/Constraint/Types.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Constraint/Types.hs +++ /dev/null @@ -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)) diff --git a/src/Language/Haskell/Liquid/GHC/Plugin.hs b/src/Language/Haskell/Liquid/GHC/Plugin.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/GHC/Plugin.hs +++ /dev/null @@ -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) diff --git a/src/Language/Haskell/Liquid/GHC/Plugin/SpecFinder.hs b/src/Language/Haskell/Liquid/GHC/Plugin/SpecFinder.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/GHC/Plugin/SpecFinder.hs +++ /dev/null @@ -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") - ] diff --git a/src/Language/Haskell/Liquid/GHC/Plugin/Tutorial.hs b/src/Language/Haskell/Liquid/GHC/Plugin/Tutorial.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/GHC/Plugin/Tutorial.hs +++ /dev/null @@ -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-\-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). --} diff --git a/src/Language/Haskell/Liquid/GHC/Plugin/Types.hs b/src/Language/Haskell/Liquid/GHC/Plugin/Types.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/GHC/Plugin/Types.hs +++ /dev/null @@ -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 - } diff --git a/src/Language/Haskell/Liquid/GHC/Plugin/Util.hs b/src/Language/Haskell/Liquid/GHC/Plugin/Util.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/GHC/Plugin/Util.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/Interactive/Handler.hs b/src/Language/Haskell/Liquid/Interactive/Handler.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Interactive/Handler.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/Interactive/Types.hs b/src/Language/Haskell/Liquid/Interactive/Types.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Interactive/Types.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/LawInstances.hs b/src/Language/Haskell/Liquid/LawInstances.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/LawInstances.hs +++ /dev/null @@ -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) diff --git a/src/Language/Haskell/Liquid/Liquid.hs b/src/Language/Haskell/Liquid/Liquid.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Liquid.hs +++ /dev/null @@ -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 - - diff --git a/src/Language/Haskell/Liquid/Measure.hs b/src/Language/Haskell/Liquid/Measure.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Measure.hs +++ /dev/null @@ -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) diff --git a/src/Language/Haskell/Liquid/Misc.hs b/src/Language/Haskell/Liquid/Misc.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Misc.hs +++ /dev/null @@ -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) diff --git a/src/Language/Haskell/Liquid/Parse.hs b/src/Language/Haskell/Liquid/Parse.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Parse.hs +++ /dev/null @@ -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 . TYPE" --- or --- "forall x y . 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 diff --git a/src/Language/Haskell/Liquid/Synthesize.hs b/src/Language/Haskell/Liquid/Synthesize.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Synthesize.hs +++ /dev/null @@ -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 " diff --git a/src/Language/Haskell/Liquid/Synthesize/Check.hs b/src/Language/Haskell/Liquid/Synthesize/Check.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Synthesize/Check.hs +++ /dev/null @@ -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 - - diff --git a/src/Language/Haskell/Liquid/Synthesize/Env.hs b/src/Language/Haskell/Liquid/Synthesize/Env.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Synthesize/Env.hs +++ /dev/null @@ -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) diff --git a/src/Language/Haskell/Liquid/Synthesize/GHC.hs b/src/Language/Haskell/Liquid/Synthesize/GHC.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Synthesize/GHC.hs +++ /dev/null @@ -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 - diff --git a/src/Language/Haskell/Liquid/Synthesize/Generate.hs b/src/Language/Haskell/Liquid/Synthesize/Generate.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Synthesize/Generate.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/Synthesize/Misc.hs b/src/Language/Haskell/Liquid/Synthesize/Misc.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Synthesize/Misc.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/Synthesize/Monad.hs b/src/Language/Haskell/Liquid/Synthesize/Monad.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Synthesize/Monad.hs +++ /dev/null @@ -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 - } diff --git a/src/Language/Haskell/Liquid/Synthesize/Termination.hs b/src/Language/Haskell/Liquid/Synthesize/Termination.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Synthesize/Termination.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/Termination/Structural.hs b/src/Language/Haskell/Liquid/Termination/Structural.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Termination/Structural.hs +++ /dev/null @@ -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 } diff --git a/src/Language/Haskell/Liquid/Transforms/ANF.hs b/src/Language/Haskell/Liquid/Transforms/ANF.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Transforms/ANF.hs +++ /dev/null @@ -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 γ)} diff --git a/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs b/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs +++ /dev/null @@ -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) diff --git a/src/Language/Haskell/Liquid/Transforms/InlineAux.hs b/src/Language/Haskell/Liquid/Transforms/InlineAux.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Transforms/InlineAux.hs +++ /dev/null @@ -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) diff --git a/src/Language/Haskell/Liquid/Transforms/Rec.hs b/src/Language/Haskell/Liquid/Transforms/Rec.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Transforms/Rec.hs +++ /dev/null @@ -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) diff --git a/src/Language/Haskell/Liquid/Transforms/RefSplit.hs b/src/Language/Haskell/Liquid/Transforms/RefSplit.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Transforms/RefSplit.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/Transforms/Rewrite.hs b/src/Language/Haskell/Liquid/Transforms/Rewrite.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Transforms/Rewrite.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/Transforms/Simplify.hs b/src/Language/Haskell/Liquid/Transforms/Simplify.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Transforms/Simplify.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/Types.hs b/src/Language/Haskell/Liquid/Types.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Types.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/Types/Bounds.hs b/src/Language/Haskell/Liquid/Types/Bounds.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Types/Bounds.hs +++ /dev/null @@ -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)) diff --git a/src/Language/Haskell/Liquid/Types/Dictionaries.hs b/src/Language/Haskell/Liquid/Types/Dictionaries.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Types/Dictionaries.hs +++ /dev/null @@ -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) diff --git a/src/Language/Haskell/Liquid/Types/Equality.hs b/src/Language/Haskell/Liquid/Types/Equality.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Types/Equality.hs +++ /dev/null @@ -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 - diff --git a/src/Language/Haskell/Liquid/Types/Errors.hs b/src/Language/Haskell/Liquid/Types/Errors.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Types/Errors.hs +++ /dev/null @@ -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)) diff --git a/src/Language/Haskell/Liquid/Types/Fresh.hs b/src/Language/Haskell/Liquid/Types/Fresh.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Types/Fresh.hs +++ /dev/null @@ -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) [] diff --git a/src/Language/Haskell/Liquid/Types/Generics.hs b/src/Language/Haskell/Liquid/Types/Generics.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Types/Generics.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/Types/Literals.hs b/src/Language/Haskell/Liquid/Types/Literals.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Types/Literals.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/Types/Meet.hs b/src/Language/Haskell/Liquid/Types/Meet.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Types/Meet.hs +++ /dev/null @@ -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 - --} diff --git a/src/Language/Haskell/Liquid/Types/Names.hs b/src/Language/Haskell/Liquid/Types/Names.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Types/Names.hs +++ /dev/null @@ -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) diff --git a/src/Language/Haskell/Liquid/Types/PredType.hs b/src/Language/Haskell/Liquid/Types/PredType.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Types/PredType.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/Types/PrettyPrint.hs b/src/Language/Haskell/Liquid/Types/PrettyPrint.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Types/PrettyPrint.hs +++ /dev/null @@ -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 "" - 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 diff --git a/src/Language/Haskell/Liquid/Types/RefType.hs b/src/Language/Haskell/Liquid/Types/RefType.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Types/RefType.hs +++ /dev/null @@ -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

===> {v:Int | p v} - - which is fine, but also converts - - Field 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

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) diff --git a/src/Language/Haskell/Liquid/Types/Specs.hs b/src/Language/Haskell/Liquid/Types/Specs.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Types/Specs.hs +++ /dev/null @@ -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 - } diff --git a/src/Language/Haskell/Liquid/Types/Types.hs b/src/Language/Haskell/Liquid/Types/Types.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Types/Types.hs +++ /dev/null @@ -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

Prop, q :: Int -> Prop, r :: a -> Prop> --- = F (a -> b

) | Q (c -> a) | G (Int -> a) --- --- 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 . 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 diff --git a/src/Language/Haskell/Liquid/Types/Variance.hs b/src/Language/Haskell/Liquid/Types/Variance.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Types/Variance.hs +++ /dev/null @@ -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 - diff --git a/src/Language/Haskell/Liquid/Types/Visitors.hs b/src/Language/Haskell/Liquid/Types/Visitors.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/Types/Visitors.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/UX/ACSS.hs b/src/Language/Haskell/Liquid/UX/ACSS.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/UX/ACSS.hs +++ /dev/null @@ -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 "%s%s" (escape ann) s -renderTypAnnot Nothing s = s - -renderErrAnnot :: (PrintfArg t1, PrintfType t1) => Maybe t -> t1 -> t1 -renderErrAnnot (Just _) s = printf "%s" s -renderErrAnnot Nothing s = s - -renderLinAnnot :: (Show t, PrintfArg t1, PrintfType t1) - => Maybe (t, Int) -> t1 -> t1 -renderLinAnnot (Just d) s = printf "%s: %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: -x#agV:Int -> {VV_int:Int | (0 <= VV_int),(x#agV <= VV_int)} -NOWTRYTHIS --} - - -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 diff --git a/src/Language/Haskell/Liquid/UX/Annotate.hs b/src/Language/Haskell/Liquid/UX/Annotate.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/UX/Annotate.hs +++ /dev/null @@ -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 - [ "" - , "" - , "" - , "" ++ title ++ "" - , "" - , cssHTML css - , "" - , "

" - , "Put mouse over identifiers to see inferred types" - ] - -htmlClose :: IsString a => a -htmlClose = "\n\n" - -cssHTML :: String -> String -cssHTML css = unlines - [ "" - , "" - , "" - ] - ------------------------------------------------------------------------------- --- | 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 diff --git a/src/Language/Haskell/Liquid/UX/CTags.hs b/src/Language/Haskell/Liquid/UX/CTags.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/UX/CTags.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/UX/CmdLine.hs b/src/Language/Haskell/Liquid/UX/CmdLine.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/UX/CmdLine.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/UX/Config.hs b/src/Language/Haskell/Liquid/UX/Config.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/UX/Config.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/UX/DiffCheck.hs b/src/Language/Haskell/Liquid/UX/DiffCheck.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/UX/DiffCheck.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Liquid/UX/Errors.hs b/src/Language/Haskell/Liquid/UX/Errors.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/UX/Errors.hs +++ /dev/null @@ -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) ..]] diff --git a/src/Language/Haskell/Liquid/UX/QuasiQuoter.hs b/src/Language/Haskell/Liquid/UX/QuasiQuoter.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/UX/QuasiQuoter.hs +++ /dev/null @@ -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) - diff --git a/src/Language/Haskell/Liquid/UX/SimpleVersion.hs b/src/Language/Haskell/Liquid/UX/SimpleVersion.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/UX/SimpleVersion.hs +++ /dev/null @@ -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 --- 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 "" - ] - ) - |] diff --git a/src/Language/Haskell/Liquid/UX/Tidy.hs b/src/Language/Haskell/Liquid/UX/Tidy.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/UX/Tidy.hs +++ /dev/null @@ -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] diff --git a/src/Language/Haskell/Liquid/WiredIn.hs b/src/Language/Haskell/Liquid/WiredIn.hs deleted file mode 100644 --- a/src/Language/Haskell/Liquid/WiredIn.hs +++ /dev/null @@ -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" - ] diff --git a/src/Liquid/Prelude/Real_LHAssumptions.hs b/src/Liquid/Prelude/Real_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/Liquid/Prelude/Real_LHAssumptions.hs @@ -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} +@-} diff --git a/src/Liquid/Prelude/Totality_LHAssumptions.hs b/src/Liquid/Prelude/Totality_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/Liquid/Prelude/Totality_LHAssumptions.hs @@ -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 +@-} diff --git a/src/LiquidHaskell.hs b/src/LiquidHaskell.hs --- a/src/LiquidHaskell.hs +++ b/src/LiquidHaskell.hs @@ -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) diff --git a/src/Prelude_LHAssumptions.hs b/src/Prelude_LHAssumptions.hs new file mode 100644 --- /dev/null +++ b/src/Prelude_LHAssumptions.hs @@ -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)]) +@-} diff --git a/syntax/liquid.css b/syntax/liquid.css deleted file mode 100644 --- a/syntax/liquid.css +++ /dev/null @@ -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; -} - diff --git a/tests/Parser.hs b/tests/Parser.hs deleted file mode 100644 --- a/tests/Parser.hs +++ /dev/null @@ -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 " @?== - "include " - - , 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 :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

Bool, q :: a -> Bool, r :: a -> Bool>." - , " {x::a

|- a <: {v:a| x <= v}} " - , " {a

<: a} " - , " {a <: a} " - , " Ord a => OList (a

) -> OList (a) -> OList a "]) - @?== - -- "assume (++) :: forall

Bool, q :: a -> Bool, r :: a -> Bool> .\n (Ord a) =>\n {x :: {VV : a

| true} |- {VV : a | true} <: {v : a | x <= v}} =>\n {|- {VV : a

| true} <: {VV : a | true}} =>\n {|- {VV : a | true} <: {VV : a | true}} =>\n lq_tmp$db##13:(OList {VV : a

| true}) -> lq_tmp$db##15:(OList {VV : a | true}) -> (OList {VV : a | true})" - (unlines - [ "assume (++) :: forall Bool, q##1##23 :: a -> Bool, r##1##23 :: a -> Bool>." - , " (Ord a) =>" - , " {x :: {VV : a | true} |- {VV : a | true} <: {v : a | x <= v}} =>" - , " {|- {VV : a | true} <: {VV : a | true}} =>" - , " {|- {VV : a | true} <: {VV : a | true}} =>" - , " lq_tmp$db##13:(OList {VV : a | true}) -> lq_tmp$db##15:(OList {VV : a | true}) -> (OList {VV : a | true})" - ]) - , testCase "type spec 9" $ - parseSingleSpec (unlines $ - [ "data AstF f Bool>" - , " = Lit Int (i :: AstIndex)" - , " | Var String (i :: AstIndex)" - , " | 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 : _ | true}>) -> *" - , " | Paren :: forall f . ast : f -> *" - , " | Var :: forall f . lq_tmp$db##4 : String ->i : (AstIndex <{VV : _ | 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

Bool, q :: Int -> Bool>. " - , " {Int <: Int

}" - , " {x::Int |- {v:Int| v = x + 1} <: Int}" - , " (Int

-> ()) -> x:Int -> ()" ]) - @?== - -- "app :: forall

Bool, q :: Int -> Bool> .\n {|- (Int <{VV : _ | true}>) <: (Int <{VV : _

| true}>)} =>\n {x :: (Int <{VV : _ | true}>) |- {v : Int | v == x + 1} <: (Int <{VV : _ | true}>)} =>\n lq_tmp$db##8:(lq_tmp$db##9:(Int <{VV : _

| true}>) -> ()) -> x:(Int <{VV : _ | true}>) -> ()" - (unlines - [ "app :: forall Bool, q##1##15 :: Int -> Bool>." - , " {|- (Int <{VV : _ | true}>) <: (Int <{VV : _ | true}>)} =>" - , " {x :: (Int <{VV : _ | true}>) |- {v : Int | v == x + 1} <: (Int <{VV : _ | true}>)} =>" - , " lq_tmp$db##8:(lq_tmp$db##9:(Int <{VV : _ | true}>) -> ()) -> x:(Int <{VV : _ | true}>) -> ()" - ]) - - , testCase "type spec 12" $ - parseSingleSpec (unlines $ - [ " ssum :: forall

Bool, q :: a -> Bool>. " - , " {{v:a | v == 0} <: a}" - , " {x::a

|- {v:a | x <= v} <: a}" - , " xs:[{v:a

| 0 <= v}] -> {v:a | len xs >= 0 && 0 <= v } "]) - @?== - -- "ssum :: forall

Bool, q :: a -> Bool> .\n {|- {v : a | v == 0} <: {VV : a | true}} =>\n {x :: {VV : a

| true} |- {v : a | x <= v} <: {VV : a | true}} =>\n xs:[{v : a

| 0 <= v}] -> {v : a | len xs >= 0\n && 0 <= v}" - (unlines - [ "ssum :: forall Bool, q##1##16 :: a -> Bool>." - , " {|- {v : a | v == 0} <: {VV : a | true}} =>" - , " {x :: {VV : a | true} |- {v : a | x <= v} <: {VV : a | true}} =>" - , " xs:[{v : a | 0 <= v}] -> {v : a | 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

Bool, r :: a -> a -> Bool >.\n e:a

->\n e2:a ->\n f:(x:a

-> y:a -> {v:a

| (v = y)}) ->\n IO (RGRef a)" @?== - -- "newRGRef :: forall

Bool, r :: a a -> Bool> .\n e:{VV : a

| true} -> e2:{VV : a | true} -> f:(x:{VV : a

| true} -> y:{VV : a | true} -> {v : a

| v == y}) -> (IO (RGRef <{VV : _

| true}, {VV : _ | true}> a))" - (unlines [ "newRGRef :: forall Bool, r##1##20 :: a a -> Bool>." - , " e:{VV : a | true} -> e2:{VV : a | true} -> f:(x:{VV : a | true} -> y:{VV : a | true} -> {v : a | v == y}) -> (IO (RGRef <{VV : _ | true}, {VV : _ | 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

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 - [ ":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 - [ ":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 - [ ":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 "") 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" - --- --------------------------------------------------------------------- diff --git a/tests/Synthesis.hs b/tests/Synthesis.hs deleted file mode 100644 --- a/tests/Synthesis.hs +++ /dev/null @@ -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 - diff --git a/tests/errors/AmbiguousInline.hs b/tests/errors/AmbiguousInline.hs deleted file mode 100644 --- a/tests/errors/AmbiguousInline.hs +++ /dev/null @@ -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 diff --git a/tests/errors/AmbiguousReflect.hs b/tests/errors/AmbiguousReflect.hs deleted file mode 100644 --- a/tests/errors/AmbiguousReflect.hs +++ /dev/null @@ -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 - diff --git a/tests/errors/BadAliasApp.hs b/tests/errors/BadAliasApp.hs deleted file mode 100644 --- a/tests/errors/BadAliasApp.hs +++ /dev/null @@ -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 diff --git a/tests/errors/BadAnnotation.hs b/tests/errors/BadAnnotation.hs deleted file mode 100644 --- a/tests/errors/BadAnnotation.hs +++ /dev/null @@ -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 diff --git a/tests/errors/BadAnnotation1.hs b/tests/errors/BadAnnotation1.hs deleted file mode 100644 --- a/tests/errors/BadAnnotation1.hs +++ /dev/null @@ -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 diff --git a/tests/errors/BadData0.hs b/tests/errors/BadData0.hs deleted file mode 100644 --- a/tests/errors/BadData0.hs +++ /dev/null @@ -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) diff --git a/tests/errors/BadData1.hs b/tests/errors/BadData1.hs deleted file mode 100644 --- a/tests/errors/BadData1.hs +++ /dev/null @@ -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 () diff --git a/tests/errors/BadData2.hs b/tests/errors/BadData2.hs deleted file mode 100644 --- a/tests/errors/BadData2.hs +++ /dev/null @@ -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) diff --git a/tests/errors/BadDataCon2.hs b/tests/errors/BadDataCon2.hs deleted file mode 100644 --- a/tests/errors/BadDataCon2.hs +++ /dev/null @@ -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 } diff --git a/tests/errors/BadDataConType.hs b/tests/errors/BadDataConType.hs deleted file mode 100644 --- a/tests/errors/BadDataConType.hs +++ /dev/null @@ -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 } diff --git a/tests/errors/BadDataConType1.hs b/tests/errors/BadDataConType1.hs deleted file mode 100644 --- a/tests/errors/BadDataConType1.hs +++ /dev/null @@ -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 } diff --git a/tests/errors/BadDataConType2.hs b/tests/errors/BadDataConType2.hs deleted file mode 100644 --- a/tests/errors/BadDataConType2.hs +++ /dev/null @@ -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 } diff --git a/tests/errors/BadDataDeclTyVars.hs b/tests/errors/BadDataDeclTyVars.hs deleted file mode 100644 --- a/tests/errors/BadDataDeclTyVars.hs +++ /dev/null @@ -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 = () diff --git a/tests/errors/BadGADT.hs b/tests/errors/BadGADT.hs deleted file mode 100644 --- a/tests/errors/BadGADT.hs +++ /dev/null @@ -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

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 () diff --git a/tests/errors/BadPragma0.hs b/tests/errors/BadPragma0.hs deleted file mode 100644 --- a/tests/errors/BadPragma0.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-@ LIQUID "--expect-error-containing=Illegal pragma" @-} -{-@ LIQUID "--idirs=.." @-} - -module BadPragma0 where - -i :: Int -i = 1 - diff --git a/tests/errors/BadPragma1.hs b/tests/errors/BadPragma1.hs deleted file mode 100644 --- a/tests/errors/BadPragma1.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-@ LIQUID "--expect-error-containing=Illegal pragma" @-} -{-@ LIQUID "--c-files=./wow.c" @-} - -module BadPragma1 where - -i :: Int -i = 1 - diff --git a/tests/errors/BadPragma2.hs b/tests/errors/BadPragma2.hs deleted file mode 100644 --- a/tests/errors/BadPragma2.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-@ LIQUID "--expect-error-containing=Illegal pragma" @-} -{-@ LIQUID "--ghc-option=-O0" @-} - -module BadPragma2 where - -i :: Int -i = 1 - diff --git a/tests/errors/BadPredApp.hs b/tests/errors/BadPredApp.hs deleted file mode 100644 --- a/tests/errors/BadPredApp.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-@ LIQUID "--expect-error-containing=Malformed predicate application" @-} -module BadPredApp where - -{-@ data X Int -> Bool> = X (x0 :: Int) (x1 :: Int) @-} -data X = X Int Int - -{-@ data T

Int -> Int -> Int -> Bool> = C { x :: Int, y :: Int, z :: X

} @-} -data T = C { x :: Int, y :: Int, z :: X } diff --git a/tests/errors/BadQualifier.hs b/tests/errors/BadQualifier.hs deleted file mode 100644 --- a/tests/errors/BadQualifier.hs +++ /dev/null @@ -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) @-} diff --git a/tests/errors/BadSig0.hs b/tests/errors/BadSig0.hs deleted file mode 100644 --- a/tests/errors/BadSig0.hs +++ /dev/null @@ -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 diff --git a/tests/errors/BadSig1.hs b/tests/errors/BadSig1.hs deleted file mode 100644 --- a/tests/errors/BadSig1.hs +++ /dev/null @@ -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 diff --git a/tests/errors/BadSyn1.hs b/tests/errors/BadSyn1.hs deleted file mode 100644 --- a/tests/errors/BadSyn1.hs +++ /dev/null @@ -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 - diff --git a/tests/errors/BadSyn2.hs b/tests/errors/BadSyn2.hs deleted file mode 100644 --- a/tests/errors/BadSyn2.hs +++ /dev/null @@ -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 - diff --git a/tests/errors/BadSyn3.hs b/tests/errors/BadSyn3.hs deleted file mode 100644 --- a/tests/errors/BadSyn3.hs +++ /dev/null @@ -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 - diff --git a/tests/errors/BadSyn4.hs b/tests/errors/BadSyn4.hs deleted file mode 100644 --- a/tests/errors/BadSyn4.hs +++ /dev/null @@ -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 _ = [] diff --git a/tests/errors/CyclicExprAlias0.hs b/tests/errors/CyclicExprAlias0.hs deleted file mode 100644 --- a/tests/errors/CyclicExprAlias0.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-@ LIQUID "--expect-error-containing=Cyclic type alias definition" @-} -module CyclicExprAlias0 () where - -{-@ expression CyclicA1 Q = CyclicA1 Q @-} - diff --git a/tests/errors/CyclicExprAlias1.hs b/tests/errors/CyclicExprAlias1.hs deleted file mode 100644 --- a/tests/errors/CyclicExprAlias1.hs +++ /dev/null @@ -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 @-} - diff --git a/tests/errors/CyclicExprAlias2.hs b/tests/errors/CyclicExprAlias2.hs deleted file mode 100644 --- a/tests/errors/CyclicExprAlias2.hs +++ /dev/null @@ -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 @-} - - diff --git a/tests/errors/CyclicExprAlias3.hs b/tests/errors/CyclicExprAlias3.hs deleted file mode 100644 --- a/tests/errors/CyclicExprAlias3.hs +++ /dev/null @@ -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 @-} - diff --git a/tests/errors/CyclicPredAlias0.hs b/tests/errors/CyclicPredAlias0.hs deleted file mode 100644 --- a/tests/errors/CyclicPredAlias0.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-@ LIQUID "--expect-error-containing=Cyclic type alias definition for `CyclicA1`" @-} -module CyclicPredAlias0 () where - -{-@ predicate CyclicA1 Q = CyclicA1 Q @-} - diff --git a/tests/errors/CyclicPredAlias1.hs b/tests/errors/CyclicPredAlias1.hs deleted file mode 100644 --- a/tests/errors/CyclicPredAlias1.hs +++ /dev/null @@ -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 @-} - diff --git a/tests/errors/CyclicPredAlias2.hs b/tests/errors/CyclicPredAlias2.hs deleted file mode 100644 --- a/tests/errors/CyclicPredAlias2.hs +++ /dev/null @@ -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 @-} - diff --git a/tests/errors/CyclicPredAlias3.hs b/tests/errors/CyclicPredAlias3.hs deleted file mode 100644 --- a/tests/errors/CyclicPredAlias3.hs +++ /dev/null @@ -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 @-} - diff --git a/tests/errors/CyclicTypeAlias0.hs b/tests/errors/CyclicTypeAlias0.hs deleted file mode 100644 --- a/tests/errors/CyclicTypeAlias0.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-@ LIQUID "--expect-error-containing=Cyclic type alias definition for `CyclicA1`" @-} -module CyclicTypeAlias0 () where - -{-@ type CyclicA1 = CyclicA2 @-} -{-@ type CyclicA2 = CyclicA1 @-} - diff --git a/tests/errors/CyclicTypeAlias1.hs b/tests/errors/CyclicTypeAlias1.hs deleted file mode 100644 --- a/tests/errors/CyclicTypeAlias1.hs +++ /dev/null @@ -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 @-} - diff --git a/tests/errors/CyclicTypeAlias2.hs b/tests/errors/CyclicTypeAlias2.hs deleted file mode 100644 --- a/tests/errors/CyclicTypeAlias2.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-@ LIQUID "--expect-error-containing=Cyclic type alias definition for `CyclicC`" @-} -module CyclicTypeAlias2 () where - -{-@ type CyclicC = [CyclicC] @-} - diff --git a/tests/errors/CyclicTypeAlias3.hs b/tests/errors/CyclicTypeAlias3.hs deleted file mode 100644 --- a/tests/errors/CyclicTypeAlias3.hs +++ /dev/null @@ -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 @-} - diff --git a/tests/errors/DupAlias.hs b/tests/errors/DupAlias.hs deleted file mode 100644 --- a/tests/errors/DupAlias.hs +++ /dev/null @@ -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 diff --git a/tests/errors/DupData.hs b/tests/errors/DupData.hs deleted file mode 100644 --- a/tests/errors/DupData.hs +++ /dev/null @@ -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 - diff --git a/tests/errors/DupFunSigs.hs b/tests/errors/DupFunSigs.hs deleted file mode 100644 --- a/tests/errors/DupFunSigs.hs +++ /dev/null @@ -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 () diff --git a/tests/errors/DupMeasure.hs b/tests/errors/DupMeasure.hs deleted file mode 100644 --- a/tests/errors/DupMeasure.hs +++ /dev/null @@ -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] - diff --git a/tests/errors/ElabLocation.hs b/tests/errors/ElabLocation.hs deleted file mode 100644 --- a/tests/errors/ElabLocation.hs +++ /dev/null @@ -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 diff --git a/tests/errors/ElabLocation2.hs b/tests/errors/ElabLocation2.hs deleted file mode 100644 --- a/tests/errors/ElabLocation2.hs +++ /dev/null @@ -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 diff --git a/tests/errors/ElabLocation3.hs b/tests/errors/ElabLocation3.hs deleted file mode 100644 --- a/tests/errors/ElabLocation3.hs +++ /dev/null @@ -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 () - diff --git a/tests/errors/EmptyData.hs b/tests/errors/EmptyData.hs deleted file mode 100644 --- a/tests/errors/EmptyData.hs +++ /dev/null @@ -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 diff --git a/tests/errors/ErrLocation.hs b/tests/errors/ErrLocation.hs deleted file mode 100644 --- a/tests/errors/ErrLocation.hs +++ /dev/null @@ -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) - diff --git a/tests/errors/ErrLocation2.hs b/tests/errors/ErrLocation2.hs deleted file mode 100644 --- a/tests/errors/ErrLocation2.hs +++ /dev/null @@ -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 - diff --git a/tests/errors/ExportMeasure0.hs b/tests/errors/ExportMeasure0.hs deleted file mode 100644 --- a/tests/errors/ExportMeasure0.hs +++ /dev/null @@ -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) diff --git a/tests/errors/ExportReflect0.hs b/tests/errors/ExportReflect0.hs deleted file mode 100644 --- a/tests/errors/ExportReflect0.hs +++ /dev/null @@ -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 diff --git a/tests/errors/Fractional.hs b/tests/errors/Fractional.hs deleted file mode 100644 --- a/tests/errors/Fractional.hs +++ /dev/null @@ -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 diff --git a/tests/errors/Frog.hs b/tests/errors/Frog.hs deleted file mode 100644 --- a/tests/errors/Frog.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-@ LIQUID "--expect-error-containing=Unbound symbol GHC.Err.undefined" @-} - -module Frog where - -{-@ LIQUID "--reflection" @-} - -{-@ reflect frog @-} -frog :: () -> Bool -frog () = undefined diff --git a/tests/errors/HigherOrderBinder.hs b/tests/errors/HigherOrderBinder.hs deleted file mode 100644 --- a/tests/errors/HigherOrderBinder.hs +++ /dev/null @@ -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 () diff --git a/tests/errors/HintMismatch.hs b/tests/errors/HintMismatch.hs deleted file mode 100644 --- a/tests/errors/HintMismatch.hs +++ /dev/null @@ -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 diff --git a/tests/errors/HoleCrash1.hs b/tests/errors/HoleCrash1.hs deleted file mode 100644 --- a/tests/errors/HoleCrash1.hs +++ /dev/null @@ -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) } @-} diff --git a/tests/errors/HoleCrash2.hs b/tests/errors/HoleCrash2.hs deleted file mode 100644 --- a/tests/errors/HoleCrash2.hs +++ /dev/null @@ -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) } @-} diff --git a/tests/errors/HoleCrash3.hs b/tests/errors/HoleCrash3.hs deleted file mode 100644 --- a/tests/errors/HoleCrash3.hs +++ /dev/null @@ -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) - - - - - - - - - - diff --git a/tests/errors/Inconsistent0.hs b/tests/errors/Inconsistent0.hs deleted file mode 100644 --- a/tests/errors/Inconsistent0.hs +++ /dev/null @@ -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 Bool> - = Lit {l1 :: Int, i :: AstIndex} - | Var {v1 :: String, i :: AstIndex} - | 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

Bool>. Fix (AstF

) -> Fix (AstF

) -> Fix (AstF

) @-} -app f x = In $ App f x - -{-@ id1 :: forall

Bool>. Fix (AstF p) -> Fix (AstF p) @-} -id1 :: Fix AstF -> Fix AstF -id1 z = z - -{-@ wrong :: AstT @-} -wrong = id1 astExpr diff --git a/tests/errors/Inconsistent1.hs b/tests/errors/Inconsistent1.hs deleted file mode 100644 --- a/tests/errors/Inconsistent1.hs +++ /dev/null @@ -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 diff --git a/tests/errors/Inconsistent2.hs b/tests/errors/Inconsistent2.hs deleted file mode 100644 --- a/tests/errors/Inconsistent2.hs +++ /dev/null @@ -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 diff --git a/tests/errors/InlineSubExp0.hs b/tests/errors/InlineSubExp0.hs deleted file mode 100644 --- a/tests/errors/InlineSubExp0.hs +++ /dev/null @@ -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 diff --git a/tests/errors/InlineSubExp1.hs b/tests/errors/InlineSubExp1.hs deleted file mode 100644 --- a/tests/errors/InlineSubExp1.hs +++ /dev/null @@ -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 diff --git a/tests/errors/IrregularData.hs b/tests/errors/IrregularData.hs deleted file mode 100644 --- a/tests/errors/IrregularData.hs +++ /dev/null @@ -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 - diff --git a/tests/errors/LiftMeasureCase.hs b/tests/errors/LiftMeasureCase.hs deleted file mode 100644 --- a/tests/errors/LiftMeasureCase.hs +++ /dev/null @@ -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 diff --git a/tests/errors/LocalHole.hs b/tests/errors/LocalHole.hs deleted file mode 100644 --- a/tests/errors/LocalHole.hs +++ /dev/null @@ -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) diff --git a/tests/errors/MissingAssume.hs b/tests/errors/MissingAssume.hs deleted file mode 100644 --- a/tests/errors/MissingAssume.hs +++ /dev/null @@ -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 diff --git a/tests/errors/MissingField1.hs b/tests/errors/MissingField1.hs deleted file mode 100644 --- a/tests/errors/MissingField1.hs +++ /dev/null @@ -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 } @-} - diff --git a/tests/errors/MissingField2.hs b/tests/errors/MissingField2.hs deleted file mode 100644 --- a/tests/errors/MissingField2.hs +++ /dev/null @@ -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 diff --git a/tests/errors/MissingReflect.hs b/tests/errors/MissingReflect.hs deleted file mode 100644 --- a/tests/errors/MissingReflect.hs +++ /dev/null @@ -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 () diff --git a/tests/errors/MissingSizeFun.hs b/tests/errors/MissingSizeFun.hs deleted file mode 100644 --- a/tests/errors/MissingSizeFun.hs +++ /dev/null @@ -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) diff --git a/tests/errors/MultiInstMeasures.hs b/tests/errors/MultiInstMeasures.hs deleted file mode 100644 --- a/tests/errors/MultiInstMeasures.hs +++ /dev/null @@ -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 - diff --git a/tests/errors/MultiRecSels.hs b/tests/errors/MultiRecSels.hs deleted file mode 100644 --- a/tests/errors/MultiRecSels.hs +++ /dev/null @@ -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}) - } - @-} diff --git a/tests/errors/Positivity1.hs b/tests/errors/Positivity1.hs deleted file mode 100644 --- a/tests/errors/Positivity1.hs +++ /dev/null @@ -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 _ = () diff --git a/tests/errors/Positivity2.hs b/tests/errors/Positivity2.hs deleted file mode 100644 --- a/tests/errors/Positivity2.hs +++ /dev/null @@ -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) diff --git a/tests/errors/PositivityCheck.hs b/tests/errors/PositivityCheck.hs deleted file mode 100644 --- a/tests/errors/PositivityCheck.hs +++ /dev/null @@ -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) diff --git a/tests/errors/ReWrite5.hs b/tests/errors/ReWrite5.hs deleted file mode 100644 --- a/tests/errors/ReWrite5.hs +++ /dev/null @@ -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 _ = () diff --git a/tests/errors/ReWrite6.hs b/tests/errors/ReWrite6.hs deleted file mode 100644 --- a/tests/errors/ReWrite6.hs +++ /dev/null @@ -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 = () diff --git a/tests/errors/ReWrite7.hs b/tests/errors/ReWrite7.hs deleted file mode 100644 --- a/tests/errors/ReWrite7.hs +++ /dev/null @@ -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 diff --git a/tests/errors/ReWrite8.hs b/tests/errors/ReWrite8.hs deleted file mode 100644 --- a/tests/errors/ReWrite8.hs +++ /dev/null @@ -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) - - diff --git a/tests/errors/ReflectLam.hs b/tests/errors/ReflectLam.hs deleted file mode 100644 --- a/tests/errors/ReflectLam.hs +++ /dev/null @@ -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 diff --git a/tests/errors/ShadowFieldInline.hs b/tests/errors/ShadowFieldInline.hs deleted file mode 100644 --- a/tests/errors/ShadowFieldInline.hs +++ /dev/null @@ -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 diff --git a/tests/errors/ShadowFieldReflect.hs b/tests/errors/ShadowFieldReflect.hs deleted file mode 100644 --- a/tests/errors/ShadowFieldReflect.hs +++ /dev/null @@ -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 diff --git a/tests/errors/ShadowMeasure.hs b/tests/errors/ShadowMeasure.hs deleted file mode 100644 --- a/tests/errors/ShadowMeasure.hs +++ /dev/null @@ -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 diff --git a/tests/errors/ShadowMeasureVar.hs b/tests/errors/ShadowMeasureVar.hs deleted file mode 100644 --- a/tests/errors/ShadowMeasureVar.hs +++ /dev/null @@ -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 - diff --git a/tests/errors/SplitSubtype.hs b/tests/errors/SplitSubtype.hs deleted file mode 100644 --- a/tests/errors/SplitSubtype.hs +++ /dev/null @@ -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. diff --git a/tests/errors/T1140.hs b/tests/errors/T1140.hs deleted file mode 100644 --- a/tests/errors/T1140.hs +++ /dev/null @@ -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 = () - diff --git a/tests/errors/T1498.hs b/tests/errors/T1498.hs deleted file mode 100644 --- a/tests/errors/T1498.hs +++ /dev/null @@ -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) diff --git a/tests/errors/T1498A.hs b/tests/errors/T1498A.hs deleted file mode 100644 --- a/tests/errors/T1498A.hs +++ /dev/null @@ -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) diff --git a/tests/errors/T1708.hs b/tests/errors/T1708.hs deleted file mode 100644 --- a/tests/errors/T1708.hs +++ /dev/null @@ -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 diff --git a/tests/errors/T773.hs b/tests/errors/T773.hs deleted file mode 100644 --- a/tests/errors/T773.hs +++ /dev/null @@ -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 diff --git a/tests/errors/T774.hs b/tests/errors/T774.hs deleted file mode 100644 --- a/tests/errors/T774.hs +++ /dev/null @@ -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 diff --git a/tests/errors/TODOUnboundAbsRef.hs b/tests/errors/TODOUnboundAbsRef.hs deleted file mode 100644 --- a/tests/errors/TODOUnboundAbsRef.hs +++ /dev/null @@ -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

x1:a -> Bool> - = Nil - | Cons { lHd :: a, lTl :: List

(a

) } -@-} - -{-@ 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 diff --git a/tests/errors/TODOVarInTypeAlias.hs b/tests/errors/TODOVarInTypeAlias.hs deleted file mode 100644 --- a/tests/errors/TODOVarInTypeAlias.hs +++ /dev/null @@ -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} diff --git a/tests/errors/TerminationExprNum.hs b/tests/errors/TerminationExprNum.hs deleted file mode 100644 --- a/tests/errors/TerminationExprNum.hs +++ /dev/null @@ -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 - diff --git a/tests/errors/TerminationExprSort.hs b/tests/errors/TerminationExprSort.hs deleted file mode 100644 --- a/tests/errors/TerminationExprSort.hs +++ /dev/null @@ -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 - diff --git a/tests/errors/TerminationExprUnb.hs b/tests/errors/TerminationExprUnb.hs deleted file mode 100644 --- a/tests/errors/TerminationExprUnb.hs +++ /dev/null @@ -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) diff --git a/tests/errors/UnboundAbsRef.hs b/tests/errors/UnboundAbsRef.hs deleted file mode 100644 --- a/tests/errors/UnboundAbsRef.hs +++ /dev/null @@ -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

Prop>. a

-> a

` --- 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

-> a

@-} -ide x = x diff --git a/tests/errors/UnboundCheckVar.hs b/tests/errors/UnboundCheckVar.hs deleted file mode 100644 --- a/tests/errors/UnboundCheckVar.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-@ LIQUID "--checks=ink" @-} - -module UnboundCheckVar where - -inc :: Int -> Int -inc x = x + 1 - diff --git a/tests/errors/UnboundFunInSpec.hs b/tests/errors/UnboundFunInSpec.hs deleted file mode 100644 --- a/tests/errors/UnboundFunInSpec.hs +++ /dev/null @@ -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 diff --git a/tests/errors/UnboundFunInSpec1.hs b/tests/errors/UnboundFunInSpec1.hs deleted file mode 100644 --- a/tests/errors/UnboundFunInSpec1.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-@ LIQUID "--expect-error-containing=Illegal type specification for `UnboundFunInSpec1.foo`" @-} -module UnboundFunInSpec1 where - -{-@ foo :: xs:_ -> {v:_ | this = rubbish } @-} -foo _ _ = 0 diff --git a/tests/errors/UnboundFunInSpec2.hs b/tests/errors/UnboundFunInSpec2.hs deleted file mode 100644 --- a/tests/errors/UnboundFunInSpec2.hs +++ /dev/null @@ -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 diff --git a/tests/errors/UnboundVarInAssume.hs b/tests/errors/UnboundVarInAssume.hs deleted file mode 100644 --- a/tests/errors/UnboundVarInAssume.hs +++ /dev/null @@ -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 diff --git a/tests/errors/UnboundVarInLocSig.hs b/tests/errors/UnboundVarInLocSig.hs deleted file mode 100644 --- a/tests/errors/UnboundVarInLocSig.hs +++ /dev/null @@ -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 diff --git a/tests/errors/UnboundVarInReflect.hs b/tests/errors/UnboundVarInReflect.hs deleted file mode 100644 --- a/tests/errors/UnboundVarInReflect.hs +++ /dev/null @@ -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 diff --git a/tests/errors/UnboundVarInSpec.hs b/tests/errors/UnboundVarInSpec.hs deleted file mode 100644 --- a/tests/errors/UnboundVarInSpec.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-@ LIQUID "--expect-error-containing=Illegal type specification for `UnboundVarInSpec.foo`" @-} -module UnboundVarInSpec where - - -{-@ foo :: forall

s -> Bool>. - xs:s

-> s

@-} -foo :: s -> s -foo s = s diff --git a/tests/ffi-include/foo.c b/tests/ffi-include/foo.c deleted file mode 100644 --- a/tests/ffi-include/foo.c +++ /dev/null @@ -1,4 +0,0 @@ -#include "foo.h" -int foo(int x) { - return x; -} diff --git a/tests/ffi-include/foo.h b/tests/ffi-include/foo.h deleted file mode 100644 --- a/tests/ffi-include/foo.h +++ /dev/null @@ -1,1 +0,0 @@ -int foo(int); diff --git a/tests/import/client/C.hs b/tests/import/client/C.hs deleted file mode 100644 --- a/tests/import/client/C.hs +++ /dev/null @@ -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 diff --git a/tests/import/client/CliAliasGen00.hs b/tests/import/client/CliAliasGen00.hs deleted file mode 100644 --- a/tests/import/client/CliAliasGen00.hs +++ /dev/null @@ -1,5 +0,0 @@ -module CliAliasGen00 where - -import LibAliasGen00 - -bar = foo 10 diff --git a/tests/import/client/CliRedBlue.hs b/tests/import/client/CliRedBlue.hs deleted file mode 100644 --- a/tests/import/client/CliRedBlue.hs +++ /dev/null @@ -1,7 +0,0 @@ -module CliRedBlue where - -import LibBlue -import qualified LibRedBlue as RB - -{-@ yumyum :: _ -> Nat @-} -yumyum = RB.foo diff --git a/tests/import/client/Client0.hs b/tests/import/client/Client0.hs deleted file mode 100644 --- a/tests/import/client/Client0.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Client0 where - - import Client1Lib - - a :: Eq a => B a -> Bool - a (B x y) = x == y diff --git a/tests/import/client/Client1Lib.hs b/tests/import/client/Client1Lib.hs deleted file mode 100644 --- a/tests/import/client/Client1Lib.hs +++ /dev/null @@ -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 } } @-} - - diff --git a/tests/import/client/Client2Lib.hs b/tests/import/client/Client2Lib.hs deleted file mode 100644 --- a/tests/import/client/Client2Lib.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Client2Lib where - - {-@ reflect cProp @-} - - cProp :: Eq a => a -> a -> Bool - cProp x y = x == y - - diff --git a/tests/import/client/ExactGADT9.hs b/tests/import/client/ExactGADT9.hs deleted file mode 100644 --- a/tests/import/client/ExactGADT9.hs +++ /dev/null @@ -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 diff --git a/tests/import/client/FunClashLibLibClient.hs b/tests/import/client/FunClashLibLibClient.hs deleted file mode 100644 --- a/tests/import/client/FunClashLibLibClient.hs +++ /dev/null @@ -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 diff --git a/tests/import/client/LibRedBlue.hs b/tests/import/client/LibRedBlue.hs deleted file mode 100644 --- a/tests/import/client/LibRedBlue.hs +++ /dev/null @@ -1,8 +0,0 @@ -module LibRedBlue where - -import LibRed -import qualified LibBlue as Blue - -{-@ foo :: Thing -> Nat @-} -foo :: Thing -> Int -foo _ = 10 diff --git a/tests/import/client/LiquidArrayInit.hs b/tests/import/client/LiquidArrayInit.hs deleted file mode 100644 --- a/tests/import/client/LiquidArrayInit.hs +++ /dev/null @@ -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

x1: a -> Bool>. - f: (z: Int -> a

) -> - i: {v: Int | v >= 0} -> - n: Int -> - a: (j: {v: Int | (0 <= v && v < i)} -> a

) -> - (k: {v: Int | (0 <= v && v < n)} -> a

) @-} -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 diff --git a/tests/import/client/LiquidArrayNullTerm.hs b/tests/import/client/LiquidArrayNullTerm.hs deleted file mode 100644 --- a/tests/import/client/LiquidArrayNullTerm.hs +++ /dev/null @@ -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 diff --git a/tests/import/client/ListClient.hs b/tests/import/client/ListClient.hs deleted file mode 100644 --- a/tests/import/client/ListClient.hs +++ /dev/null @@ -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 () = () - - diff --git a/tests/import/client/NameClashClient.hs b/tests/import/client/NameClashClient.hs deleted file mode 100644 --- a/tests/import/client/NameClashClient.hs +++ /dev/null @@ -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 diff --git a/tests/import/client/RC1015.hs b/tests/import/client/RC1015.hs deleted file mode 100644 --- a/tests/import/client/RC1015.hs +++ /dev/null @@ -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) diff --git a/tests/import/client/ReExportClient.hs b/tests/import/client/ReExportClient.hs deleted file mode 100644 --- a/tests/import/client/ReExportClient.hs +++ /dev/null @@ -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 diff --git a/tests/import/client/ReflectClient0.hs b/tests/import/client/ReflectClient0.hs deleted file mode 100644 --- a/tests/import/client/ReflectClient0.hs +++ /dev/null @@ -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 diff --git a/tests/import/client/ReflectClient1.hs b/tests/import/client/ReflectClient1.hs deleted file mode 100644 --- a/tests/import/client/ReflectClient1.hs +++ /dev/null @@ -1,7 +0,0 @@ -module ReflectClient1 where - -import ReflectLib1 - -{-@ myHead :: {v:[a] | not (isNull v) } -> a @-} -myHead :: [a] -> a -myHead (x:_) = x diff --git a/tests/import/client/ReflectClient2.hs b/tests/import/client/ReflectClient2.hs deleted file mode 100644 --- a/tests/import/client/ReflectClient2.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-@ LIQUID "--higherorder" @-} - -module ReflectClient2 where - -import ReflectLib2 - -{-@ proof :: a -> { v: Int | incr 5 == 6 } @-} -proof _ = incr 5 diff --git a/tests/import/client/ReflectClient3.hs b/tests/import/client/ReflectClient3.hs deleted file mode 100644 --- a/tests/import/client/ReflectClient3.hs +++ /dev/null @@ -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 diff --git a/tests/import/client/ReflectClient4.hs b/tests/import/client/ReflectClient4.hs deleted file mode 100644 --- a/tests/import/client/ReflectClient4.hs +++ /dev/null @@ -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 diff --git a/tests/import/client/ReflectClient4a.hs b/tests/import/client/ReflectClient4a.hs deleted file mode 100644 --- a/tests/import/client/ReflectClient4a.hs +++ /dev/null @@ -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 = () - - diff --git a/tests/import/client/ReflectClient5.hs b/tests/import/client/ReflectClient5.hs deleted file mode 100644 --- a/tests/import/client/ReflectClient5.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-@ LIQUID "--reflection" @-} -{-@ LIQUID "--ple" @-} - -module ReflectClient5 where - --- import Language.Haskell.Liquid.ProofCombinators - -import ReflectLib5 - -{-@ test5 :: { gapp Nil = Nil } @-} -test5 = () diff --git a/tests/import/client/ReflectClient6.hs b/tests/import/client/ReflectClient6.hs deleted file mode 100644 --- a/tests/import/client/ReflectClient6.hs +++ /dev/null @@ -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 - diff --git a/tests/import/client/ReflectClient7.hs b/tests/import/client/ReflectClient7.hs deleted file mode 100644 --- a/tests/import/client/ReflectClient7.hs +++ /dev/null @@ -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 diff --git a/tests/import/client/ReflectClient8.hs b/tests/import/client/ReflectClient8.hs deleted file mode 100644 --- a/tests/import/client/ReflectClient8.hs +++ /dev/null @@ -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 @-} diff --git a/tests/import/client/RewriteClient.hs b/tests/import/client/RewriteClient.hs deleted file mode 100644 --- a/tests/import/client/RewriteClient.hs +++ /dev/null @@ -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 --} diff --git a/tests/import/client/STClient.hs b/tests/import/client/STClient.hs deleted file mode 100644 --- a/tests/import/client/STClient.hs +++ /dev/null @@ -1,45 +0,0 @@ --- TAG: classes --- TAG: bounds - -{-@ LIQUID "--no-pattern-inline" @-} -{-@ LIQUID "--higherorder" @-} - -module STClient where - -import STLib - --------------------------------------------------------------------------------- - -{-@ fresh :: forall 

 Bool>.
-                    { zoo::Int |- Int
 <: {v:Int | 0 <= v} }
-                    ST  ( 0 <= rv && rv + 1 = v )}> Int (Int
)
-  @-}
-
-{- 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
diff --git a/tests/import/client/T1096_Foo.hs b/tests/import/client/T1096_Foo.hs
deleted file mode 100644
--- a/tests/import/client/T1096_Foo.hs
+++ /dev/null
@@ -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 
diff --git a/tests/import/client/T1104Client.hs b/tests/import/client/T1104Client.hs
deleted file mode 100644
--- a/tests/import/client/T1104Client.hs
+++ /dev/null
@@ -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
diff --git a/tests/import/client/T1117.hs b/tests/import/client/T1117.hs
deleted file mode 100644
--- a/tests/import/client/T1117.hs
+++ /dev/null
@@ -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 #-}
diff --git a/tests/import/client/T1118.hs b/tests/import/client/T1118.hs
deleted file mode 100644
--- a/tests/import/client/T1118.hs
+++ /dev/null
@@ -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 #-}
diff --git a/tests/import/client/T1180.hs b/tests/import/client/T1180.hs
deleted file mode 100644
--- a/tests/import/client/T1180.hs
+++ /dev/null
@@ -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
diff --git a/tests/import/client/T1688.hs b/tests/import/client/T1688.hs
deleted file mode 100644
--- a/tests/import/client/T1688.hs
+++ /dev/null
@@ -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
diff --git a/tests/import/client/T1738.hs b/tests/import/client/T1738.hs
deleted file mode 100644
--- a/tests/import/client/T1738.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-
-module T1738 where
-
-import T1738Lib
-
-{-@ reflect bar @-}
-bar :: Int -> Int
-bar n = incr n
diff --git a/tests/import/client/WrapClient.hs b/tests/import/client/WrapClient.hs
deleted file mode 100644
--- a/tests/import/client/WrapClient.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module WrapClient where
-
-import WrapLib
-import WrapLibCode 
-
-{-@ bar :: {v:Int | v = 2 } @-}
-bar = foo 1
-
diff --git a/tests/import/lib/B.hs b/tests/import/lib/B.hs
deleted file mode 100644
--- a/tests/import/lib/B.hs
+++ /dev/null
@@ -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 
diff --git a/tests/import/lib/ExactGADT8Lib.hs b/tests/import/lib/ExactGADT8Lib.hs
deleted file mode 100644
--- a/tests/import/lib/ExactGADT8Lib.hs
+++ /dev/null
@@ -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
diff --git a/tests/import/lib/FunClashLib.hs b/tests/import/lib/FunClashLib.hs
deleted file mode 100644
--- a/tests/import/lib/FunClashLib.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module FunClashLib (blob) where
-
-import FunClashLibLib 
-
-{-@ blob :: Nat -> Nat @-} 
-blob :: Int -> Int 
-blob = incr 
-
diff --git a/tests/import/lib/FunClashLibLib.hs b/tests/import/lib/FunClashLibLib.hs
deleted file mode 100644
--- a/tests/import/lib/FunClashLibLib.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-
-module FunClashLibLib where 
- 
-{-@ incr :: Nat -> Nat @-} 
-incr :: Int -> Int 
-incr x = x + 1 
diff --git a/tests/import/lib/Language.hs b/tests/import/lib/Language.hs
deleted file mode 100644
--- a/tests/import/lib/Language.hs
+++ /dev/null
@@ -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 
diff --git a/tests/import/lib/LibAliasGen00.hs b/tests/import/lib/LibAliasGen00.hs
deleted file mode 100644
--- a/tests/import/lib/LibAliasGen00.hs
+++ /dev/null
@@ -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
-
diff --git a/tests/import/lib/LibBlue.hs b/tests/import/lib/LibBlue.hs
deleted file mode 100644
--- a/tests/import/lib/LibBlue.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module LibBlue where 
-
-data Thing = ThingBlue Int 
-
-{-@ foo :: Int -> Thing @-}
-foo :: Int -> Thing 
-foo = ThingBlue 
-
diff --git a/tests/import/lib/LibRed.hs b/tests/import/lib/LibRed.hs
deleted file mode 100644
--- a/tests/import/lib/LibRed.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module LibRed where 
-
-data Thing = ThingRed Int 
-
-{-@ foo :: Int -> Thing @-}
-foo :: Int -> Thing 
-foo = ThingRed 
-
diff --git a/tests/import/lib/LiquidArrayLib.hs b/tests/import/lib/LiquidArrayLib.hs
deleted file mode 100644
--- a/tests/import/lib/LiquidArrayLib.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-module LiquidArrayLib where
-
-{-@ set :: forall a 
 x1: a -> Bool, r :: x0: Int -> Bool>.
-      i: Int ->
-      x: a
 ->
-      a: (j: {v: Int | v != i} -> a
) ->
-      (k: Int -> a
) @-}
-set :: Int -> a -> (Int -> a) -> (Int -> a)
-set i x a = \k -> if k == i then x else a k
-
-{-@ get :: forall a 
 x1: a -> Bool, r :: x0: Int -> Bool>.
-             i: Int ->
-             a: (j: Int -> a
) ->
-             a
 @-}
-get :: Int -> (Int -> a) -> a
-get i a = a i
-
-{-@ empty :: i: {v: Int | 0 = 1} -> a @-}
-empty :: Int -> a
-empty = const undefined 
diff --git a/tests/import/lib/ListLib.hs b/tests/import/lib/ListLib.hs
deleted file mode 100644
--- a/tests/import/lib/ListLib.hs
+++ /dev/null
@@ -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)
diff --git a/tests/import/lib/NameClashLib.hs b/tests/import/lib/NameClashLib.hs
deleted file mode 100644
--- a/tests/import/lib/NameClashLib.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module NameClashLib where 
-
-data Foo = FooLib Int 
-
-{-@ type FooAlias = {v : Foo | False} @-}
-foo :: Foo -> Int 
-foo _ = 10
diff --git a/tests/import/lib/PeanoLib.hs b/tests/import/lib/PeanoLib.hs
deleted file mode 100644
--- a/tests/import/lib/PeanoLib.hs
+++ /dev/null
@@ -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
diff --git a/tests/import/lib/RL1015Lib.hs b/tests/import/lib/RL1015Lib.hs
deleted file mode 100644
--- a/tests/import/lib/RL1015Lib.hs
+++ /dev/null
@@ -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)
diff --git a/tests/import/lib/ReExportLib.hs b/tests/import/lib/ReExportLib.hs
deleted file mode 100644
--- a/tests/import/lib/ReExportLib.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module ReExportLib ( module ReExportLib
-  , module X
-  ) where
-
-
-import SpecLib as X
diff --git a/tests/import/lib/ReflectLib0.hs b/tests/import/lib/ReflectLib0.hs
deleted file mode 100644
--- a/tests/import/lib/ReflectLib0.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module ReflectLib0 where
-
-{-@ inline gtThan @-}
-gtThan :: Int -> Int -> Bool
-gtThan x y = x > y
-
-
-{-@ predicate GreaterThanA X Y = X > Y @-}
diff --git a/tests/import/lib/ReflectLib1.hs b/tests/import/lib/ReflectLib1.hs
deleted file mode 100644
--- a/tests/import/lib/ReflectLib1.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module ReflectLib1 where
-
-{-@ measure isNull @-}
-isNull :: [a] -> Bool
-isNull []     = True
-isNull (x:xs) = False
diff --git a/tests/import/lib/ReflectLib2.hs b/tests/import/lib/ReflectLib2.hs
deleted file mode 100644
--- a/tests/import/lib/ReflectLib2.hs
+++ /dev/null
@@ -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
diff --git a/tests/import/lib/ReflectLib3.hs b/tests/import/lib/ReflectLib3.hs
deleted file mode 100644
--- a/tests/import/lib/ReflectLib3.hs
+++ /dev/null
@@ -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
diff --git a/tests/import/lib/ReflectLib4.hs b/tests/import/lib/ReflectLib4.hs
deleted file mode 100644
--- a/tests/import/lib/ReflectLib4.hs
+++ /dev/null
@@ -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 = ()
diff --git a/tests/import/lib/ReflectLib5.hs b/tests/import/lib/ReflectLib5.hs
deleted file mode 100644
--- a/tests/import/lib/ReflectLib5.hs
+++ /dev/null
@@ -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 = ()
diff --git a/tests/import/lib/ReflectLib6.hs b/tests/import/lib/ReflectLib6.hs
deleted file mode 100644
--- a/tests/import/lib/ReflectLib6.hs
+++ /dev/null
@@ -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 = ()
diff --git a/tests/import/lib/ReflectLib7.hs b/tests/import/lib/ReflectLib7.hs
deleted file mode 100644
--- a/tests/import/lib/ReflectLib7.hs
+++ /dev/null
@@ -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)
diff --git a/tests/import/lib/ReflectLib8.hs b/tests/import/lib/ReflectLib8.hs
deleted file mode 100644
--- a/tests/import/lib/ReflectLib8.hs
+++ /dev/null
@@ -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)
diff --git a/tests/import/lib/RewriteLib.hs b/tests/import/lib/RewriteLib.hs
deleted file mode 100644
--- a/tests/import/lib/RewriteLib.hs
+++ /dev/null
@@ -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
diff --git a/tests/import/lib/STLib.hs b/tests/import/lib/STLib.hs
deleted file mode 100644
--- a/tests/import/lib/STLib.hs
+++ /dev/null
@@ -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 
 Bool, post :: a -> s -> Bool>
-       = S { runSt :: (x:s
 -> ((a, s))) }
-  @-}
-
-{-@ apply :: forall 
 Bool, q :: a -> s -> Bool>.
-               ST  s a -> s
 -> (a, s)
-  @-}
-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 
 s -> Bool>. x:a -> ST <{v:s
| true}, p, {v:a | true}> s a ;
-        >>=    :: forall  Bool, qbind :: a -> s -> Bool, rbind :: b -> s -> Bool>.
-                                  ST  s a
-                              -> (xbind:a -> ST <{v:s | true}, rbind> s b)
-                              -> ST  s b;
-        >>    :: forall  Bool, qbind :: a -> s -> Bool, rbind :: b -> s -> Bool>.
-                                 ST  s a
-                              -> (ST <{v:s| true}, rbind> s b)
-                              -> ST  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'
-
-
diff --git a/tests/import/lib/SpecLib.hs b/tests/import/lib/SpecLib.hs
deleted file mode 100644
--- a/tests/import/lib/SpecLib.hs
+++ /dev/null
@@ -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
diff --git a/tests/import/lib/T1096_TypesLib.hs b/tests/import/lib/T1096_TypesLib.hs
deleted file mode 100644
--- a/tests/import/lib/T1096_TypesLib.hs
+++ /dev/null
@@ -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 
diff --git a/tests/import/lib/T1102_LibX.hs b/tests/import/lib/T1102_LibX.hs
deleted file mode 100644
--- a/tests/import/lib/T1102_LibX.hs
+++ /dev/null
@@ -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 _ = ()
diff --git a/tests/import/lib/T1102_LibY.hs b/tests/import/lib/T1102_LibY.hs
deleted file mode 100644
--- a/tests/import/lib/T1102_LibY.hs
+++ /dev/null
@@ -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 
diff --git a/tests/import/lib/T1102_LibZ.hs b/tests/import/lib/T1102_LibZ.hs
deleted file mode 100644
--- a/tests/import/lib/T1102_LibZ.hs
+++ /dev/null
@@ -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}
diff --git a/tests/import/lib/T1104Lib.hs b/tests/import/lib/T1104Lib.hs
deleted file mode 100644
--- a/tests/import/lib/T1104Lib.hs
+++ /dev/null
@@ -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
diff --git a/tests/import/lib/T1112.hs b/tests/import/lib/T1112.hs
deleted file mode 100644
--- a/tests/import/lib/T1112.hs
+++ /dev/null
@@ -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 #-}
diff --git a/tests/import/lib/T1112Lib.hs b/tests/import/lib/T1112Lib.hs
deleted file mode 100644
--- a/tests/import/lib/T1112Lib.hs
+++ /dev/null
@@ -1,3 +0,0 @@
-module T1112Lib where
-
-data Product f g p = Product (f p) (g p) deriving Eq
diff --git a/tests/import/lib/T1117Lib.hs b/tests/import/lib/T1117Lib.hs
deleted file mode 100644
--- a/tests/import/lib/T1117Lib.hs
+++ /dev/null
@@ -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)
diff --git a/tests/import/lib/T1118Lib1.hs b/tests/import/lib/T1118Lib1.hs
deleted file mode 100644
--- a/tests/import/lib/T1118Lib1.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-{-@ LIQUID "--higherorder"        @-}
-{-@ LIQUID "--exactdc"            @-}
-module T1118Lib1 where
-
-import T1118Lib2 
-
-{- data Product @-}
diff --git a/tests/import/lib/T1118Lib2.hs b/tests/import/lib/T1118Lib2.hs
deleted file mode 100644
--- a/tests/import/lib/T1118Lib2.hs
+++ /dev/null
@@ -1,4 +0,0 @@
-module T1118Lib2 where
-
-data U1 p = U1
-data Product f g p = Product (f p) (g p)
diff --git a/tests/import/lib/T1688Lib.hs b/tests/import/lib/T1688Lib.hs
deleted file mode 100644
--- a/tests/import/lib/T1688Lib.hs
+++ /dev/null
@@ -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)
-  @-}
diff --git a/tests/import/lib/T1738Lib.hs b/tests/import/lib/T1738Lib.hs
deleted file mode 100644
--- a/tests/import/lib/T1738Lib.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module T1738Lib where
-
-{-@ inline incr @-}
-incr :: Int -> Int
-incr x = x + 1
diff --git a/tests/import/lib/WrapLib.hs b/tests/import/lib/WrapLib.hs
deleted file mode 100644
--- a/tests/import/lib/WrapLib.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module WrapLib ( module WrapLibCode ) where 
-
-import WrapLibCode
-
-{-@ assume WrapLibCode.foo :: x:Nat -> {v:Nat | v = x + 1}  @-}
-
diff --git a/tests/import/lib/WrapLibCode.hs b/tests/import/lib/WrapLibCode.hs
deleted file mode 100644
--- a/tests/import/lib/WrapLibCode.hs
+++ /dev/null
@@ -1,4 +0,0 @@
-module WrapLibCode (foo) where
-
-foo :: Int -> Int 
-foo x = x + 1
diff --git a/tests/neg/AbsApp.hs b/tests/neg/AbsApp.hs
deleted file mode 100644
--- a/tests/neg/AbsApp.hs
+++ /dev/null
@@ -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 
 Bool>. Int
 -> Int
 @-}
-id2 :: Int -> Int
-id2 x = x
-
-{-@ type Neg = Int<{\x -> x < 0}> @-}
-
-{-@ three :: Neg @-}
-three = id2 3
diff --git a/tests/neg/AdtPeano0.hs b/tests/neg/AdtPeano0.hs
deleted file mode 100644
--- a/tests/neg/AdtPeano0.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--exact-data-con" @-}
-{-@ LIQUID "--higherorder"    @-}
-
-module AdtPeano0 where
-
-data Influx = Silly Int
-
-{-@ reflect thing @-}
-thing :: Influx -> Int
-thing (Silly a) = a + 1
-
-{-@ reflect bling @-}
-bling :: Influx -> Int
-bling (Silly b) = b
-
-{-@ test :: m:Influx -> { thing m = bling m} @-}
-test :: Influx -> (Int, Int)
-test m = (thing m, bling m)
diff --git a/tests/neg/AdtPeano1.hs b/tests/neg/AdtPeano1.hs
deleted file mode 100644
--- a/tests/neg/AdtPeano1.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--exact-data-con"                      @-}
-{-@ LIQUID "--higherorder"                         @-}
-
-module AdtPeano1 where
-
-data Influx = Silly { goo :: Int }
-
-{-@ test1:: n:Int -> m:Int -> { v:() | Silly n /= Silly m } -> { n == m } @-}
-test1 :: Int -> Int -> () -> Int
-test1 n m z = moo (Silly n) + moo (Silly m)
-
-{-@ reflect moo @-}
-moo :: Influx -> Int
-moo (Silly a) = a
diff --git a/tests/neg/Alias00.hs b/tests/neg/Alias00.hs
deleted file mode 100644
--- a/tests/neg/Alias00.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Alias00 () where
-
-{-@ type NegInt = {v: Int | v <= 0} @-}
-{-@ myabs :: Int -> NegInt @-}
-myabs :: Int -> Int
-myabs x = if (x > 0) then x else (0 - x)
-
-{-@ type NNList a = {v: [a] | len(v) = 0} @-}
-{-@ single :: a -> NNList a @-}
-single x = [x] 
diff --git a/tests/neg/Ass0.hs b/tests/neg/Ass0.hs
deleted file mode 100644
--- a/tests/neg/Ass0.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Ass0 (testError) where
-
--- import Language.Haskell.Liquid.Prelude (liquidAssert)
-
-{-@ assert foo :: x:a -> {v: a | (v != x) } @-}
-foo x = x 
-
-testError :: Int -> Int 
-testError x = bar x 
-
-
-{-@ bar :: Nat -> Nat @-} 
-bar :: Int -> Int 
-bar x = x
diff --git a/tests/neg/Ast.hs b/tests/neg/Ast.hs
deleted file mode 100644
--- a/tests/neg/Ast.hs
+++ /dev/null
@@ -1,56 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
--- FAILING TEST: this test SHOULD FAIL BUT DOESN'T
--- issue #519
-
-{-@ LIQUID "--no-positivity-check" @-}
-{-# LANGUAGE DeriveFunctor #-}
-module Ast 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  Bool>
-    = Lit {lv :: Int   , i :: AstIndex}
-    | Var {vv :: String, i :: AstIndex}
-    | 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 :: Fix (AstF <{\ix -> isExprIndex ix}>)  @-}
-astExpr :: Ast
-astExpr = undefined
-
-{-@ id1 :: forall 
 Bool>. Fix (AstF 
) -> Fix (AstF 
)  @-}
-id1 :: Fix AstF -> Fix AstF
-id1 z = z
-
-{-@ wrong :: AstT @-}
-wrong = id1 astExpr
diff --git a/tests/neg/AutoSize.hs b/tests/neg/AutoSize.hs
deleted file mode 100644
--- a/tests/neg/AutoSize.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module AutoSize where
-
-import GHC.Base
-
-data List a = N | Cons a (List a) 
-
-
-nil = N
-cons = Cons 
-
-foo :: List a -> Int 
-foo N = 0 
-foo (Cons x xs) = 1 + foo xs 
-
-
-data Exp = EConst Int | EBinOp Int Exp Exp 
-
-expSize :: Exp -> Int
-expSize (EConst _) = 0
-expSize e@(EBinOp _ e1 e2) = 1 + (expSize e) + (expSize e2)
diff --git a/tests/neg/AutoTerm1.hs b/tests/neg/AutoTerm1.hs
deleted file mode 100644
--- a/tests/neg/AutoTerm1.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module AutoTerm1 where
-
-data F = F | C Int F  
-
-{-@ data F [lenF] @-}
-
-{-@ measure lenF @-}
-lenF :: F -> Int
-
-
-{-@ lenF :: xs:F -> {v:Int | v >= 1000 } @-}
-lenF F = 0
-lenF (C _ x) = 1 + lenF x 
-
-
-bar :: F -> Int 
-bar F = 0 
-bar (C x xs) = x + bar xs 
diff --git a/tests/neg/Automate.hs b/tests/neg/Automate.hs
deleted file mode 100644
--- a/tests/neg/Automate.hs
+++ /dev/null
@@ -1,37 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--ple-local" @-}
-module Automate where
-
-import Language.Haskell.Liquid.ProofCombinators 
-
-
-fibA :: Int -> Int 
-{-@ axiomatize fibA @-}
-{-@ fibA :: Nat -> Nat @-}
-fibA i | i <= 1 = i
-      | otherwise = fibA (i-1) + fibA (i-2)
-
-
-fibR :: Int -> Int 
-{-@ reflect fibR @-}
-{-@ fibR :: Nat -> Nat @-}
-fibR i | i <= 1 = i
-      | otherwise = fibR (i-1) + fibR (i-2)
-
-
-{-@ prop :: () -> {fibA 30 == 832040 } @-}
-prop :: () -> Proof 
-prop _ = trivial  
-
--- This is unsafe because it is actually false 
-
-{-@ propUNSAFE :: () -> {fibA 30 == 832042 } @-}
-propUNSAFE :: () -> Proof 
-propUNSAFE _ = trivial  
-
-
--- This is unsafe because the reflected fibR (vs. axiomatized fibA)
--- does not create an SMT axiom
-{-@ propR :: () -> {fibR 30 == 832040 } @-}
-propR :: () -> Proof 
-propR _ = trivial  
diff --git a/tests/neg/BadNats.hs b/tests/neg/BadNats.hs
deleted file mode 100644
--- a/tests/neg/BadNats.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module BadNats where
-
-{-@ poo :: {v:Int | v == 0 } @-}
-poo :: Int 
-poo = 1
-
-data Peano = Z | O 
-
-bob :: String 
-bob = "I am a cat"
-
-{-@ axiomatize one @-}
-one :: Peano 
-one = O 
-
-{-@ axiomatize zero @-}
-zero :: Peano
-zero = Z
diff --git a/tests/neg/Bag1.hs b/tests/neg/Bag1.hs
deleted file mode 100644
--- a/tests/neg/Bag1.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Bag1 where
-
-import qualified Data.Set as S
-import Language.Haskell.Liquid.Bag as B
-
-{-@ zorg :: {v:B.Bag Int | v = B.empty} @-}
-zorg :: B.Bag Int
-zorg = B.empty
-
-{-@ measure elems @-}
-elems :: (Ord a) => [a] -> B.Bag a
-elems []     = B.empty
-elems (x:xs) = B.put x (elems xs)
-
-{-@ prop0 :: x:_ -> TT @-}
-prop0 :: Int -> Bool
-prop0 x = (B.get x b == 3) 
-  where
-    a   = elems [x, x]
-    b   = B.union a a 
diff --git a/tests/neg/Baz.hs b/tests/neg/Baz.hs
deleted file mode 100644
--- a/tests/neg/Baz.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--short-names" @-}
-
-module Baz where
-
-{-@ incr :: x:Int -> {v:Int | v < x } @-}
-incr   :: Int -> Int
-incr xana = id $ xana + 1
-
-
-{-@ iincr :: x:Int -> {v:Int | v < x } @-}
-iincr   :: Int -> Int
-iincr x = x + 1
-
-
-
diff --git a/tests/neg/BigNum.hs b/tests/neg/BigNum.hs
deleted file mode 100644
--- a/tests/neg/BigNum.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module BigNum where
-
-{-@ type Foo = { v : Integer | 0 <= v && v < 4611686018427387903 * 8 } @-}
-
-{-@ f :: i : Foo -> { o : Foo | i < o } @-}
-f :: Integer -> Integer
-f i = i * 2
diff --git a/tests/neg/BinarySearchOverflow.hs b/tests/neg/BinarySearchOverflow.hs
deleted file mode 100644
--- a/tests/neg/BinarySearchOverflow.hs
+++ /dev/null
@@ -1,43 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--no-termination" @-}
-
-module BinarySearchOverflow where
-
-import Prelude hiding (Num(..))
-import CheckedNum 
-import Data.Vector as V
-import Language.Haskell.Liquid.Prelude (liquidAssert) 
-
-{-@ invariant {v:V.Vector a | 0 <= vlen v && BoundInt (vlen v)} @-}
-
-binarySearch :: Ord a => a -> V.Vector a -> Maybe Int
-binarySearch x v 
-  | 0 < n     = loop x v 0 (n - 1)
-  | otherwise = Nothing 
-  where n     = V.length v
-
-{-@ type Idx Vec = {v:Nat | v < vlen Vec} @-}
-
-{-@ type BoundNat = {v:Nat | BoundInt v} @-}
-
-{-@ loop :: Ord a => a -> vec:V.Vector a -> lo:Idx vec -> {hi:Idx vec | lo <= hi} -> Maybe Nat @-}
-loop :: Ord a => a -> V.Vector a -> Int -> Int -> Maybe Int
-loop x v lo hi = do
-    -- let mid = lo + ((hi - lo) `div` 2) -- SAFE
-    let mid =  (hi + lo) `div` 2       -- UNSAFE
-    if x < v ! mid
-    then do
-        let hi' = mid - 1
-        if lo <= hi'
-        then loop x v lo hi'
-        else Nothing
-    else if v ! mid < x
-    then do
-        let lo' = mid + 1 -- incr mid
-        if lo' <= hi
-        then loop x v lo' hi
-        else Nothing
-    else Just mid
-    
-
-
diff --git a/tests/neg/Books.hs b/tests/neg/Books.hs
deleted file mode 100644
--- a/tests/neg/Books.hs
+++ /dev/null
@@ -1,63 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-# LANGUAGE CPP #-}
-
-#define DISCOUNT_PERCENTAGE   2
-#define BOOK_THRESHOLD        2
-
-module Books where
-
-calculateDiscount' :: Customer -> Int -> Int
-
----------------------------------------------------------------------------------------
--- 1. Define: Types of customers
----------------------------------------------------------------------------------------
-
-data Customer = Vip | Reg deriving (Eq)
-
----------------------------------------------------------------------------------------
--- 2. Define: Discountable Customers and Discounts
----------------------------------------------------------------------------------------
-
-{-@ inline customerGetsDiscount @-}
-customerGetsDiscount :: Customer -> Int -> Bool
-customerGetsDiscount c i = c == Vip && i >= BOOK_THRESHOLD
-
-{-@ inline discount @-}
-discount :: Int -> Int
-discount bookCount = (bookCount - BOOK_THRESHOLD) * DISCOUNT_PERCENTAGE
-
-{-@ type Discount i = {v:Int | v == discount i} @-}
-
----------------------------------------------------------------------------------------
--- 3. Policy: Only compute discounts for discountable customers
----------------------------------------------------------------------------------------
-
-{-@ calculateDiscount' :: c:Customer -> i:{Int | customerGetsDiscount c i} -> Discount i @-}
-calculateDiscount' c i = discount i
-
----------------------------------------------------------------------------------------
--- 4. Implement: Code to compute discounts, if suitable, is accepted
----------------------------------------------------------------------------------------
-
-{-@ calculateDiscount :: Int -> Nat -> Nat @-}
-calculateDiscount userId bookCount
-  | getsDiscount = calculateDiscount' c bookCount
-  | otherwise    = 0
-  where
-    getsDiscount = customerGetsDiscount c bookCount
-    c            = customerType userId
-
----------------------------------------------------------------------------------------
--- 5. Buggy Implementation, with wrong check, is rejected
----------------------------------------------------------------------------------------
-
-{-@ misCalculateDiscount :: Int -> Nat -> Nat @-}
-misCalculateDiscount userId bookCount
-  | getsDiscount = calculateDiscount' c bookCount
-  | otherwise    = 0
-  where
-    getsDiscount = c == Vip
-    c            = customerType userId
-
-customerType :: Int -> Customer
-customerType = undefined
diff --git a/tests/neg/CastedTotality.hs b/tests/neg/CastedTotality.hs
deleted file mode 100644
--- a/tests/neg/CastedTotality.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module CastedTotality where
-
-import Language.Haskell.Liquid.Prelude
-
-main = show x
-  where Just x = (Nothing :: Maybe Int)
-
-
-main0 = do 
-     let Just x = Nothing 
-     print (x :: Int)
-
diff --git a/tests/neg/CharLiterals.hs b/tests/neg/CharLiterals.hs
deleted file mode 100644
--- a/tests/neg/CharLiterals.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
--- see #1286
-
-module CharLiterals where
-
-{-@ fails :: {v:Bool | v} @-}
-fails =  'a' == 'b'
-
-{-@ ok :: {v:Bool | v} @-}
-ok = "a" == "a"
diff --git a/tests/neg/CheckedNum.hs b/tests/neg/CheckedNum.hs
deleted file mode 100644
--- a/tests/neg/CheckedNum.hs
+++ /dev/null
@@ -1,31 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module CheckedNum where
-
--- Hiding numeric operations, because they get by default translated to SMT equivalent
-import Prelude hiding (Num(..))
-
-import qualified Prelude as Prelude
-
-class CheckedNum a where
-  (+) :: a -> a -> a
-  (-) :: a -> a -> a
-
-{-@ predicate BoundInt X = 0 < X + 10000 && X < 10000 @-}
-
-instance CheckedNum Int where
-{-@ instance CheckedNum Int where
-      - :: x:Int -> y:{v:Int | BoundInt (x - v)} -> {v: Int | v == x - y} ;
-      + :: x:Int -> y:{v:Int | BoundInt (x + v)} -> {v: Int | v == x + y}
-  @-}
-    x - y = (Prelude.-) x y
-
-    x + y = (Prelude.+) x y
-
-{-@ good :: {v:Int | v == 9999} @-}
-good :: Int
-good = 5000 + 4999
-
-{-@ bad :: {v:Int | v == 10001} @-}
-bad :: Int
-bad = 5000 + 5001
-
diff --git a/tests/neg/CheckedNumLib.hs b/tests/neg/CheckedNumLib.hs
deleted file mode 100644
--- a/tests/neg/CheckedNumLib.hs
+++ /dev/null
@@ -1,31 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module CheckedNumLib where
-
--- Hiding numeric operations, because they get by default translated to SMT equivalent
-import Prelude hiding (Num(..))
-
-import qualified Prelude as Prelude 
-
-class CheckedNum a where 
-  (+) :: a -> a -> a 
-  (-) :: a -> a -> a 
-
-{-@ predicate BoundInt X = 0 < X + 10000 && X < 10000 @-}
-
-instance CheckedNum Int where
-{-@ instance CheckedNum Int where 
-      - :: x:Int -> y:{v:Int | BoundInt (x - v)} -> {v: Int | v == x - y} ;  
-      + :: x:Int -> y:{v:Int | BoundInt (x + v)} -> {v: Int | v == x + y} 
-  @-}
-	x - y = (Prelude.-) x y  
-
-	x + y = (Prelude.+) x y  
-
-{-@ good :: {v:Int | v == 9999} @-}
-good :: Int 
-good = 5000 + 4999 
-
-{-@ bad :: {v:Int | v == 10001} @-}
-bad :: Int 
-bad = 5000 + 5001
-
diff --git a/tests/neg/Class1.hs b/tests/neg/Class1.hs
deleted file mode 100644
--- a/tests/neg/Class1.hs
+++ /dev/null
@@ -1,69 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-@ LIQUID "--no-termination" @-}
-module Class1 () where
-
-import Language.Haskell.Liquid.Prelude
-import Prelude hiding (sum, length, (!!), Functor(..))
-import qualified Prelude as P
-
-{-@ qualif Sz(v:int, xs:a): v = (sz xs) @-}
-
-{-@ data List a = Nil | Cons (hd::a) (tl::(List a)) @-}
-data List a = Nil | Cons a (List a)
-
-{-@ length :: xs:List a -> {v:Nat | v = (sz xs)} @-}
-length :: List a -> Int
-length Nil         = 0
-length (Cons x xs) = 1 + length xs
-
-{-@ (!!) :: xs:List a -> {v:Nat | v < (sz xs)} -> a @-}
-(!!) :: List a -> Int -> a
-Nil         !! i = undefined
-(Cons x _)  !! 0 = x
-(Cons x xs) !! i = xs !! (i - 1)
-
-{-@ class measure sz :: forall a. a -> Int @-}
-{-@ class Sized s where
-      size :: forall a. x:s a -> {v:Nat | v = (sz x)}
-  @-}
-class Sized s where
-  size :: s a -> Int
-
-instance Sized List where
-  {-@ instance measure sz :: List a -> Int
-        sz (Nil)       = 0
-        sz (Cons x xs) = 1 + (sz xs)
-    @-}
-  size = length
-
-{-@ class (Sized s) => Indexable s where
-      index :: forall a. x:s a -> {v:Nat | v < (sz x)} -> a
-  @-}
-class (Sized s) => Indexable s where
-  index :: s a -> Int -> a
-
-
-instance Indexable List where
-  index = (!!)
-
-{-@ sum :: Indexable s => s Int -> Int @-}
-sum :: Indexable s => s Int -> Int
-sum xs = go max 0
-  where
-    max = size xs
-    go (d::Int) i
-      | i < max   = index xs i + go (d-1) (i+1)
-      | otherwise = index xs i -- should be 0
-
-
-{-@ sumList :: List Int -> Int @-}
-sumList :: List Int -> Int
-sumList xs = go max 0
-  where
-    max = size xs
-    go (d::Int) i
-      | i < max   = index xs i + go (d-1) (i+1)
-      | otherwise = index xs i -- should be 0
-
-
diff --git a/tests/neg/Class2.hs b/tests/neg/Class2.hs
deleted file mode 100644
--- a/tests/neg/Class2.hs
+++ /dev/null
@@ -1,37 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-@ LIQUID "--no-termination" @-}
-module Class2 () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ class measure sz :: forall a. a -> Int @-}
-
-{-@ class Sized s where
-      size :: forall a. x:s a -> {v:Nat | v = sz x}
-  @-}
-class Sized s where
-  size :: s a -> Int
-
-instance Sized [] where
-  {-@ instance measure sz :: [a] -> Int
-        sz []   = 0
-        sz (x:xs) = 1 + (sz xs)
-    @-}
-
-  size []     = 0
-  size (x:xs) = 1 + size xs
-
--- The following is needed to make this work (but are invariants checked?) 
-{- invariant {v:[a] | sz v == len v} @-}
-
-{-@ class (Sized s) => Indexable s where
-      index :: forall a. x:s a -> {v:Nat | v < sz x} -> a
-  @-}
-class (Sized s) => Indexable s where
-  index :: s a -> Int -> a
-
-
-instance Indexable [] where
-  index = (!!)
-
diff --git a/tests/neg/Class3.hs b/tests/neg/Class3.hs
deleted file mode 100644
--- a/tests/neg/Class3.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-@ LIQUID "--no-termination" @-}
-module Class3 where
-
-import Language.Haskell.Liquid.Prelude
-import Prelude hiding (sum, length, (!!), Functor(..))
-import qualified Prelude as P
-
-{-@ qualif Sz(v:int, xs:a): v = (sz xs) @-}
-
-data List a = Nil | Cons a (List a)
-
-{-@ class measure sz :: forall a. a -> Int @-}
-{-@ class Sized s where
-      size :: forall a. x:s a -> {v:Nat | v = 23 + sz x}
-  @-}
-class Sized s where
-  size :: s a -> Int
-
-instance Sized List where
-  {-@ instance measure sz :: List a -> Int
-        sz (Nil)       = 0
-        sz (Cons x xs) = 1 + (sz xs)
-    @-}
-  size Nil         = 0
-  size (Cons x xs) = size xs
diff --git a/tests/neg/Class4.hs b/tests/neg/Class4.hs
deleted file mode 100644
--- a/tests/neg/Class4.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-@ LIQUID "--no-termination" @-}
-
-module Class4 where
-
-import Language.Haskell.Liquid.Prelude
-
-class Frog a where
-  mkInt :: a -> Int
-  mkInt _ = liquidAssert (0 > 1) 10
-
-{-@ class Frog a where
-      mkInt :: a -> Int
-  @-}
-
-instance Frog Int where
-
diff --git a/tests/neg/CompareConstraints.hs b/tests/neg/CompareConstraints.hs
deleted file mode 100644
--- a/tests/neg/CompareConstraints.hs
+++ /dev/null
@@ -1,37 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--no-totality" @-}
-
-module CompareConstraints where
-
-import Language.Haskell.Liquid.Prelude
-
-
-{-@ mycmp :: forall 
 Bool, q :: a -> Bool>.
-           {x::a
, y::a |-  a <: {v:a | x <= y} }
-           Ord a =>
-           [a
] -> [a] -> Bool @-}
-mycmp :: Ord a => [a] -> [a] -> Bool
-mycmp (x:_) (_:y:_) = liquidAssert (x <= y) True
-
-
-{-@ mycmp' :: forall 
 Bool, q :: a -> Bool>.
-           {x::a
 , y::a |- a <: {v:a | x <= y} }
-           Ord a =>
-           a
 -> a -> Bool @-}
-mycmp' :: Ord a => a -> a -> Bool
-mycmp' x y = liquidAssert (x <= y) True
-
-bar :: Bool
-bar = let w = choose 0 in
-      let x = w + 1 in
-      let y = w - 1 in
-      let z = w + 2 in
-      mycmp [x, y, x, z] [z, x, z]
-
-
-bar' :: Bool
-bar' = let w = choose 0 in
-      let x = w + 1 in
-      let y = w - 1 in
-      let z = w + 2 in
-      mycmp' z y
diff --git a/tests/neg/Concat.hs b/tests/neg/Concat.hs
deleted file mode 100644
--- a/tests/neg/Concat.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Concat () where
-
-import Language.Haskell.Liquid.Prelude
-
-foo :: [Int]
-foo = [1..10]
-
-concatmap f ls = concat $ map f ls
-
-myconcatmap f []     = []
-myconcatmap f (x:xs) = (f x) ++ (myconcatmap f xs) 
-
-
-chooseList x = [choose x]
-r :: Int
-r = 5
-
-prop x = liquidAssertB (x == r)
-
-propMap  = map prop $ myconcatmap chooseList foo
-propMap1 = map prop $ concatmap   chooseList foo
diff --git a/tests/neg/Concat1.hs b/tests/neg/Concat1.hs
deleted file mode 100644
--- a/tests/neg/Concat1.hs
+++ /dev/null
@@ -1,39 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Concat1 () where
-
-import Language.Haskell.Liquid.Prelude
-
-------------------------------------------------------------
------------- Longer Version of neg/polypred.hs -------------
-------------------------------------------------------------
-
-foo :: [[Int]]
-foo = [[choose 1], [choose 2]]
-
--- concatmap f ls = concat $ map f ls
-
-myconcat []     = []
-myconcat (x:xs) = x ++ (myconcat xs) 
-
-
-myconcat1 :: a -> [[Int]] -> [Int]
-myconcat1 _ []     = []
-myconcat1 f (x:xs) = x ++ (myconcat1 f xs) 
-
-concat1 f = concat
-myconcat2 f = myconcat
-
-r :: Int
-r = 5
-
-prop x = liquidAssertB (x == r)
-
--- ok 
--- propC0 = map prop $ myconcat foo
--- this is safe
--- propC1 = map prop $ myconcat foo
--- propC2 = map prop $ concat foo
--- propC3 = map prop $ concat1 id foo
-
-propC4 = map prop $ myconcat1 id foo
-
diff --git a/tests/neg/Concat2.hs b/tests/neg/Concat2.hs
deleted file mode 100644
--- a/tests/neg/Concat2.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Concat2 () where
-
-import Language.Haskell.Liquid.Prelude
-
-foo :: [Int]
-foo = [choose 1, choose 2]
-
--- myconcat1 :: (a -> a) -> [[Int]] -> [Int] 
--- :: a goes to False -> safe
-myconcat1 :: (a -> [(k,v)]) -> [a] -> [(k, v)]
-myconcat1 _ []     = []
-myconcat1 f (x:xs) = (f x) ++ (myconcat1 f xs) 
-
-r :: Int
-r = 5
-
-prop (x, y) = liquidAssertB (x > r)
---  where r = 5
--- this is safe
-propC = map prop $ myconcat1 (\x->[(x, x)]) foo
diff --git a/tests/neg/Constraints.hs b/tests/neg/Constraints.hs
deleted file mode 100644
--- a/tests/neg/Constraints.hs
+++ /dev/null
@@ -1,31 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Constraints where
-
-{-@
-cmp :: forall < pref :: b -> Bool, postf :: b -> c -> Bool
-              , pre  :: a -> Bool, postg :: a -> b -> Bool
-              , post :: a -> c -> Bool
-              >.
-       {xx::a
,  w::b |- c <: c}
-       {ww::a
 |- b <: b}
-       f:(y:b -> c)
-    -> g:(z:a
 -> b)
-    -> x: a
 -> c
-@-}
-
-cmp :: (b -> c)
-    -> (a -> b)
-    ->  a -> c
-
-cmp f g x = f (g x)
-
-
-
-{-@ incr :: x:Nat -> {v:Nat | v == x + 1} @-}
-incr :: Int -> Int
-incr x = x + 1
-
-
-{-@ incr2 :: x:Nat -> {v:Nat | v == x + 3} @-}
-incr2 :: Int -> Int
-incr2 = cmp incr incr
diff --git a/tests/neg/ConstraintsAppend.hs b/tests/neg/ConstraintsAppend.hs
deleted file mode 100644
--- a/tests/neg/ConstraintsAppend.hs
+++ /dev/null
@@ -1,39 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module ConstraintsAppend () where
-
-{-@ LIQUID "--no-termination" @-}
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ type OList a = [a]<{\x v -> v >= x}> @-}
-
-
-{-@ app :: forall 
 Bool, q :: a -> Bool, r :: a -> Bool>.
-        {x::a
 |- a <: {v:a| x <= v}}
-        {a
 <: a}
-        {a <: a}
-        Ord a => OList (a
) -> OList (a) -> OList a @-}
-app :: Ord a => [a] -> [a] -> [a]
-app []     ys = ys
-app (x:xs) ys = x:(app xs (x:ys))
-
-takeL :: Ord a => a -> [a] -> [a]
-{-@ takeL :: Ord a => x:a -> [a] -> [{v:a|v<=x}] @-}
-takeL x []     = []
-takeL x (y:ys) = if (y a -> [a] -> [a]
-{-@ takeGE :: Ord a => x:a -> [a] -> [{v:a|v>=x}] @-}
-takeGE x []     = []
-takeGE x (y:ys) = if (y>=x) then y:(takeGE x ys) else takeGE x ys
-
-
-{-@ quicksort :: (Ord a) => xs:[a] -> [a]<{\fld v -> (v >= fld)}>  @-}
-quicksort []     = []
-quicksort (x:xs) = app xsle (x:xsge)
-  where xsle = quicksort (takeL x xs)
-        xsge = quicksort (takeGE x xs)
-
-{-@ qsort :: (Ord a) => xs:[a] -> [a]<{\fld v -> (v >= fld)}>  @-}
-qsort []     = []
-qsort (x:xs) = app  (qsort [y | y <- xs, y < x]) (x:(qsort [z | z <- xs, z >= x]))
diff --git a/tests/neg/Contra0.hs b/tests/neg/Contra0.hs
deleted file mode 100644
--- a/tests/neg/Contra0.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--no-termination" @-}
-{-@ LIQUID "--short-names"    @-}
-
-module Contra0 () where
-
-import Language.Haskell.Liquid.Prelude (liquidAssert)
-import Data.IORef
-
-
-{-@ data variance IO bivariant @-}
-{-@ data variance IORef bivariant @-}
-
-job :: IO () 
-job = do
-  p <- newIORef (0 :: Int)
-  writeIORef p 10
-  v <- readIORef p
-  liquidAssert (v == 0) $ return ()
diff --git a/tests/neg/Coretologic.hs b/tests/neg/Coretologic.hs
deleted file mode 100644
--- a/tests/neg/Coretologic.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Coretologic where
-
-import Data.Set
-
--- ISSUE: can we please allow things like `empty` to also
--- appear in type and alias specifications, not just in
--- measures as in `goo` below?
-
-{-@ type IsEmp a = {v:[a] | listElts v = Data.Set.empty } @-}
-
-{-@ foo :: IsEmp Int @-}
-foo :: [Int]
-foo = []
-
-{-@ bar :: IsEmp Int @-}
-bar :: [Int]
-bar = [1]
-
-{-@ measure goo @-}
-goo        :: (Ord a) => [a] -> Set a
-goo []     = empty
-goo (x:xs) = (singleton x) `union` (goo xs)  
diff --git a/tests/neg/Csv.hs b/tests/neg/Csv.hs
deleted file mode 100644
--- a/tests/neg/Csv.hs
+++ /dev/null
@@ -1,39 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Csv () where
-
--- | Using LiquidHaskell for CSV lists
--- c.f. http://www.reddit.com/r/scala/comments/1nhzi2/using_shapelesss_sized_type_to_eliminate_real/
-
-data CSV = Csv { headers :: [String]
-               , rows    :: [[String]]
-               }
-
-{-@ data CSV = Csv { headers :: [String]
-                   , rows    :: [{v:[String] | (len v) = (len headers)}]
-                   }
-  @-}
-
--- Eeks, we missed the column name.
-
-csvBad1 = Csv ["Date"] 
-              [ ["Mon", "1"]
-              , ["Tue", "2"]
-              , ["Wed", "3"] 
-              ]
-
--- Eeks, we missed a column.
-
-csvBad2 = Csv ["Name", "Age"] 
-              [ ["Alice", "32"]
-              , ["Bob"        ]
-              , ["Cris" , "29"] 
-              ]
-                      
--- All is well! 
-
-csvGood = Csv ["Id", "Name", "Days"]
-              [ ["1", "Jan", "31"]
-              , ["2", "Feb", "28"]
-              , ["3", "Mar", "31"]
-              , ["4", "Apr", "30"] 
-              ]
diff --git a/tests/neg/Datacon_eq.hs b/tests/neg/Datacon_eq.hs
deleted file mode 100644
--- a/tests/neg/Datacon_eq.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Datacon_eq (foo) where
-
--- This is a blank file.
-
-data G = A | B
-
-{-@ foo :: Int -> {v:G | v = A} @-}
-foo  :: Int -> G
-foo _ = B
-
-
diff --git a/tests/neg/DependentTypes.hs b/tests/neg/DependentTypes.hs
deleted file mode 100644
--- a/tests/neg/DependentTypes.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-# LANGUAGE KindSignatures      #-}
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE RankNTypes          #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module DependentTypes where
-
-import GHC.TypeLits
-
-
-
--- THIS SHOULD BE UNSAFE
-miunsafe1 :: forall s. MI s 
-miunsafe1 = Small "blaa"
-
--- THIS SHOULD BE UNSAFE 
-miunsafe2 :: MI "bla0" 
-miunsafe2 = Small "blaa"
-
-
-data MI (s :: Symbol)
-  = Small { mi_input :: String  }
-
-
-{-@ Small :: forall (s :: Symbol). {v:String | s ~~ v } -> MI s @-}
-
--- OR 
-
-{- data MI (s :: Symbol)
-    = Small { mi_input :: {v:String | v == s } } @-}
diff --git a/tests/neg/Elim000.hs b/tests/neg/Elim000.hs
deleted file mode 100644
--- a/tests/neg/Elim000.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Elim000 () where
-
-{-@ prop2 :: Int -> Nat @-}
-prop2 :: Int -> Int
-prop2 x = numAbsList x
-
-numAbsList = glap numAbs
-
-{-@ glap :: (a -> b) -> a -> b @-}
-glap :: (a -> b) -> a -> b
-glap = undefined
-
--- Adding the below signature makes it flag an error...
--- numAbs :: Int -> Int
-numAbs x = if x > 0 then x else x
diff --git a/tests/neg/Elim_ex_compose.hs b/tests/neg/Elim_ex_compose.hs
deleted file mode 100644
--- a/tests/neg/Elim_ex_compose.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Elim_ex_compose (prop) where
-
-{-@ prop :: x:Nat -> {v:Int | v = x + 5} @-}
-prop :: Int -> Int
-prop = incr . incr . incr . incr
-
-{-@ incr :: dog:Int -> {v:Int | v == dog + 1} @-}
-incr :: Int -> Int
-incr cat = cat + 1
diff --git a/tests/neg/Elim_ex_let.hs b/tests/neg/Elim_ex_let.hs
deleted file mode 100644
--- a/tests/neg/Elim_ex_let.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-
-{-# LANGUAGE QuasiQuotes #-}
-
-module Elim_ex_let (prop) where
-
-import LiquidHaskell
-
-[lq| type Nat = {v:Int | 0 <= v} |]
-
-[lq| prop :: a -> Nat |]
-prop _ = let x _ = let y = 0 
-                   in
-                     y - 3
-         in 
-           x () + 2
diff --git a/tests/neg/Elim_ex_list.hs b/tests/neg/Elim_ex_list.hs
deleted file mode 100644
--- a/tests/neg/Elim_ex_list.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-
-{-# LANGUAGE QuasiQuotes #-}
-
-module Elim_ex_list (prop) where
-
-import LiquidHaskell
-import Prelude hiding (head)
-
---------------------------------------------------------------------------
-[lq| prop :: a -> Even |]
-prop _ = (head ys) - 1
-  where 
-    ys = Cons 1 (Cons 2 (Cons 5 Nil))
---------------------------------------------------------------------------
-
-[lq| type Even = {v:Int | v mod 2 == 0 } |]
-
-data List a = Nil | Cons a (List a)
-
-head :: List a -> a 
-head (Cons x _) = x
-
diff --git a/tests/neg/Elim_ex_map_1.hs b/tests/neg/Elim_ex_map_1.hs
deleted file mode 100644
--- a/tests/neg/Elim_ex_map_1.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--no-termination" @-}
-
-{-# LANGUAGE QuasiQuotes #-}
-
-module Elim_ex_map_1 (prop) where
-
-import LiquidHaskell
-
-import Prelude hiding (map)
-
---------------------------------------------------------------------------
-[lq| prop :: List Even -> List Even |]
-prop xs = map (+ 2) (map (+ 1) xs)
---------------------------------------------------------------------------
-
-[lq| type Even = {v:Int | v mod 2 == 0 } |]
-
-data List a = Nil | Cons a (List a)
-
-map f Nil         = Nil
-map f (Cons x xs) = Cons (f x) (map f xs)
diff --git a/tests/neg/Elim_ex_map_2.hs b/tests/neg/Elim_ex_map_2.hs
deleted file mode 100644
--- a/tests/neg/Elim_ex_map_2.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--no-termination" @-}
-
-{-# LANGUAGE QuasiQuotes #-}
-
-module Elim_ex_map_2 (prop) where
-
-import LiquidHaskell
-
-import Prelude hiding (map)
-
---------------------------------------------------------------------------
-[lq| prop :: List Even -> List Even |]
-prop = map (+ 2) . map (+ 1)
---------------------------------------------------------------------------
-
-[lq| type Even = {v:Int | v mod 2 == 0 } |]
-
-data List a = Nil | Cons a (List a)
-
-map f Nil         = Nil
-map f (Cons x xs) = Cons (f x) (map f xs)
diff --git a/tests/neg/Elim_ex_map_3.hs b/tests/neg/Elim_ex_map_3.hs
deleted file mode 100644
--- a/tests/neg/Elim_ex_map_3.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--no-termination" @-}
-
-{-# LANGUAGE QuasiQuotes #-}
-
-module Elim_ex_map_3 (prop) where
-
-import LiquidHaskell
-
-import Prelude hiding (map)
-
---------------------------------------------------------------------------
-[lq| prop :: List Even -> List Even |]
-prop = map ((+ 0) . (+ 1))
---------------------------------------------------------------------------
-
-[lq| type Even = {v:Int | v mod 2 == 0 } |]
-
-data List a = Nil | Cons a (List a)
-
-map f Nil         = Nil
-map f (Cons x xs) = Cons (f x) (map f xs)
diff --git a/tests/neg/Errmsg.hs b/tests/neg/Errmsg.hs
deleted file mode 100644
--- a/tests/neg/Errmsg.hs
+++ /dev/null
@@ -1,24 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--short-names" @-}
-
-module Errmsg where
-
-import Data.Set
-
-{- the "error message" is garbled thanks to all the ill-formatted
-   "Eq [Contravariant]" stuff. Can we remove it, or at least NOT show
-   it when running in --short-names mode. -}
-
-{-@ foo :: (Eq a) => x:a -> xs:[a] -> {v:Bool | v <=> (Data.Set.member x (Data.Set.fromList xs))} @-}
-foo          :: (Eq a) => a -> [a] -> Bool
-foo x (y:ys) = x == y || elem x ys
-foo _ []     = False
-
-{-@ measure elements @-}
-elements  []    = empty
-elements (x:xs) = singleton x `union` elements xs
-
-{- append :: xs:_ -> ys:_ -> {v:_ | elements v = union (elements xs) (elements ys) }@-}
-append :: [a] -> [a] -> [a]
-append = undefined 
-
diff --git a/tests/neg/Errorloc.hs b/tests/neg/Errorloc.hs
deleted file mode 100644
--- a/tests/neg/Errorloc.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Errorloc () where
-
-import Language.Haskell.Liquid.Prelude (liquidAssert)
-
-{-@ zoo :: {v: Int | v > 0} -> {v: Int | v > 0} -> Int @-}
-zoo   :: Int -> Int -> Int 
-zoo x y = liquidAssert (x /= 0) $ x + y 
-
-
-foo = zoo (-1) (-2)
-
diff --git a/tests/neg/Eval.hs b/tests/neg/Eval.hs
deleted file mode 100644
--- a/tests/neg/Eval.hs
+++ /dev/null
@@ -1,35 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Eval (eval) where
-
-import Language.Haskell.Liquid.Prelude (liquidError)
-import Prelude hiding (lookup)
-
-type Val  = Int
-
-type Bndr = Int
-
-data Expr = Const Int
-          | Var   Bndr
-          | Plus  Expr Expr
-          | Let   Bndr Expr Expr
-
-type Env  = [(Bndr, Val)]
-
-----------------------------------------------------------------
-lookup                 :: Bndr -> Env -> Val
----------------------  -------------------------------------------
-lookup x ((y,v):env)   
-  | x == y             = v
-  | otherwise          = lookup x env
-lookup x []            = liquidError "Unbound Variable"
-
-----------------------------------------------------------------
-eval :: Env -> Expr -> Val
-----------------------------------------------------------------
-eval env (Const i)     = i
-eval env (Var x)       = lookup x env 
-eval env (Plus e1 e2)  = eval env e1 + eval env e2 
-eval env (Let x e1 e2) = eval env' e2 
-  where 
-    env'               = (x, eval env e1) : env
-
diff --git a/tests/neg/EvalQuery.hs b/tests/neg/EvalQuery.hs
deleted file mode 100644
--- a/tests/neg/EvalQuery.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-
-{-@ LIQUID "--reflection"     @-}
-{-@ LIQUID "--ple"            @-}
-
-module EvalQuery where
-
-data Atom  = VarX
-           | VarY
-           | Const Int
-
-data Query = Le  Atom  Atom
-           | And Query Query
-           | Or  Query Query
-
-{-@ data Blob  = B { xVal :: Int, yVal :: Int } @-}
-data Blob  = B { xVal :: Int, yVal :: Int }
-
-
-{-@ reflect evalA @-}
-evalA :: Blob -> Atom -> Int
-evalA b VarX      = xVal b
-evalA b VarY      = yVal b
-evalA _ (Const n) = n
-
-{-@ reflect evalQ @-}
-evalQ :: Blob -> Query -> Bool
-evalQ b (Le  a1 a2) = (evalA b a1) <= (evalA b a2)
-evalQ b (And q1 q2) = (evalQ b q1) && (evalQ b q2)
-evalQ b (Or  q1 q2) = (evalQ b q1) || (evalQ b q2)
-
-{-@ filterQ :: q:Query -> [Blob] -> [{b:Blob | evalQ b q}] @-}
-filterQ :: Query -> [Blob] -> [Blob]
-filterQ q []     = []
-filterQ q (b:bs)
-  | evalQ b q    = b : filterQ q bs
-  | otherwise    =     filterQ q bs
-
-{-@ test1 :: [Blob] -> [{v: Blob | xVal v <= 5}] @-}
-test1   = filterQ q1
-  where
-  q1    = (VarX `Le` (Const 10))
-
-{-@ test2 :: [Blob] -> [{v: Blob | xVal v <= 10 && yVal v <= 20}] @-}
-test2  = filterQ q2
-  where
-  q2   = (VarX `Le` (Const 10)) `And` (VarY `Le` (Const 20))
diff --git a/tests/neg/Ex0_unsafe.hs b/tests/neg/Ex0_unsafe.hs
deleted file mode 100644
--- a/tests/neg/Ex0_unsafe.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--pruneunsorted" @-}
-module Ex0_unsafe () where
-
--- Testing "existential-types"
-
-{-@ foldN :: forall a 
 x1111:a -> Bool>. 
-                (i:Int -> a
 -> a
)
-              -> n:{v: Int | v >= 0}
-              -> a 

-              -> a 

-  @-}
-
-foldN :: (Int -> a -> a) -> Int -> a -> a
-foldN f n = go 0
-  where go i x | i < n     = go (i+1) (f i x)
-               | otherwise = x
-
-
-fooBar :: (Int -> a -> a) -> Int -> a -> a
-fooBar f n = go 0
-  where go i x | i < n     = go (i+1) (f i x)
-               | otherwise = x
-
-
-{-@ count :: m: {v: Int | v > 0 } -> {v: Int | v = 44 } @-}
-count :: Int -> Int
-count m = foldN (\_ n -> n + 1) m 0
--- count m = fooBar (\_ n -> n + 1) m 0
diff --git a/tests/neg/Ex1_unsafe.hs b/tests/neg/Ex1_unsafe.hs
deleted file mode 100644
--- a/tests/neg/Ex1_unsafe.hs
+++ /dev/null
@@ -1,66 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--pruneunsorted" @-}
-
--- | A somewhat fancier example demonstrating the use of Abstract Predicates and exist-types
-
-module Ex1_unsafe () where
-
--------------------------------------------------------------------------
--- | Data types ---------------------------------------------------------
--------------------------------------------------------------------------
-
-data Vec a = Nil | Cons a (Vec a)
-
--- | We can encode the notion of length as an inductive measure @llen@
-
-{-@ measure llen     :: forall a. Vec a -> Int
-      llen (Nil)       = 0
-      llen (Cons x xs) = 1 + llen(xs)
-  @-}
-
-
--- | As a warmup, lets check that a /real/ length function indeed computes
--- the length of the list.
-
-{-@ sizeOf :: xs:Vec a -> {v: Int | v = llen(xs)} @-}
-sizeOf             :: Vec a -> Int
-sizeOf Nil         = 0
-sizeOf (Cons _ xs) = 1 + sizeOf xs
-
--------------------------------------------------------------------------
--- | Higher-order fold --------------------------------------------------
--------------------------------------------------------------------------
-
--- | Time to roll up the sleeves. Here's a a higher-order @foldr@ function
--- for our `Vec` type. Note that the `op` argument takes an extra /ghost/
--- parameter that will let us properly describe the type of `efoldr`
-
-{-@ efoldr :: forall a b 
 x1:b -> Bool>. 
-                (xs:Vec a -> x:a -> b 
 -> b 
)
-              -> b 

-              -> ys: Vec a
-              -> b 

-  @-}
-efoldr :: (Vec a -> a -> b -> b) -> b -> Vec a -> b
-efoldr op b Nil         = b
-efoldr op b (Cons x xs) = op xs x (efoldr op b xs)
-
--------------------------------------------------------------------------
--- | Clients of `efold` -------------------------------------------------
--------------------------------------------------------------------------
-
--- | Finally, lets write a few /client/ functions that use `efoldr` to
--- operate on the `Vec`s.
-
--- | First: Computing the length using `efoldr`
-{-@ size :: xs:Vec a -> {v: Int | v = llen(xs)} @-}
-size :: Vec a -> Int
-size = efoldr (\_ _ n -> n + 1) 0
-
-{-@ suc :: x:Int -> {v: Int | v = x + 1} @-}
-suc :: Int -> Int
-suc x = x + 1
-
--- | Second: Appending two lists using `efoldr`
-{-@ app  :: xs: Vec a -> ys: Vec a -> {v: Vec a | llen(v) = 1 + llen(xs) + llen(ys) } @-}
-app xs ys = efoldr (\_ z zs -> Cons z zs) ys xs
diff --git a/tests/neg/ExactADT6.hs b/tests/neg/ExactADT6.hs
deleted file mode 100644
--- a/tests/neg/ExactADT6.hs
+++ /dev/null
@@ -1,38 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--no-adt"         @-}
-{-@ LIQUID "--exact-data-con" @-}
-
-{-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-}
-
-module ExactADT6 where
-
-{-@ data EntityField typ where
-        BlobXVal :: EntityField {v:Int | v >= 0}
-        BlobYVal :: EntityField Int
-  @-}
-
-data EntityField typ where
-  BlobXVal :: EntityField Int
-  BlobYVal :: EntityField Int
-
-{-@ blobXVal :: EntityField {v:Int | v >= 0} @-}
-blobXVal :: EntityField Int
-blobXVal = BlobXVal
-
-{- data Update record typ = Update { updateField :: EntityField record typ, updateValue :: typ } @-}
-data Update typ = Update 
-    { updateField :: EntityField typ
-    , updateValue :: typ
-    } 
-
-{-@ createUpdate :: EntityField a -> a -> Update a @-}
-createUpdate :: EntityField a -> a -> Update a
-createUpdate field value = Update 
-  { updateField = field
-  , updateValue = value
-  }
-
-
--- BAD
-testUpdateQueryFail :: () -> Update Int
-testUpdateQueryFail () = createUpdate BlobXVal (-1)
diff --git a/tests/neg/ExactGADT6.hs b/tests/neg/ExactGADT6.hs
deleted file mode 100644
--- a/tests/neg/ExactGADT6.hs
+++ /dev/null
@@ -1,38 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--no-adt"         @-}
-{-@ LIQUID "--exact-data-con" @-}
-
-{-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-}
-
-module ExactGADT6 where
-
-class PersistEntity record where
-    data EntityField record typ :: *
-
-instance PersistEntity Blob where
-    {-@ data EntityField Blob 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 }
-
-data Update record typ = Update 
-    { updateField :: EntityField record typ
-    , updateValue :: typ
-    } 
-
-{-@ createUpdate :: EntityField record a -> a -> Update record a @-}
-createUpdate :: EntityField record a -> a -> Update record a
-createUpdate field value = Update 
-  { updateField = field
-  , updateValue = value
-  }
-
-
-testUpdateQueryFail :: () -> Update Blob Int
-testUpdateQueryFail () = createUpdate BlobXVal (-1)
diff --git a/tests/neg/ExactGADT7.hs b/tests/neg/ExactGADT7.hs
deleted file mode 100644
--- a/tests/neg/ExactGADT7.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE KindSignatures #-}
-
-{-@ LIQUID "--prune-unsorted" @-}
-{-@ LIQUID "--no-adt"         @-}
-{-@ LIQUID "--exact-data-con" @-}
-
-module ExactGADT7 where
-
-data Some a where
-  SomeBool  :: Bool -> Some Bool
-  SomeInt   :: Int  -> Some Int
-
-{-@ measure isBool @-}
-isBool :: Some a -> Bool
-isBool (SomeBool  _) = True
-isBool (SomeInt   _) = False
-
-{-@ type Thing = { v: Some Bool | isBool v } @-}
-
-{-@ a :: Thing @-}
-a = SomeBool True
-
-{-@ b :: {v: Some Int | isBool v} @-}
-b = SomeInt 5
diff --git a/tests/neg/Fail.hs b/tests/neg/Fail.hs
deleted file mode 100644
--- a/tests/neg/Fail.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Fail where
-
-{-@ fail incr @-}
-{-@ incr :: x:Int -> {v:Int |  x < v } @-}
-incr :: Int -> Int 
-incr x = x 
-
-
--- This should fails because the failing incr is used 
-{-@ incr2 :: x:Int -> {v:Int | x < v } @-}
-incr2 :: Int -> Int 
-incr2 x = incr (incr x)
diff --git a/tests/neg/Fail1.hs b/tests/neg/Fail1.hs
deleted file mode 100644
--- a/tests/neg/Fail1.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Fail1 where
-
--- This should fail because the failing incr is SAFE 
-{-@ fail incr @-}
-{-@ incr :: x:Int -> {v:Int |  x < v } @-}
-incr :: Int -> Int 
-incr x = x + 1 
diff --git a/tests/neg/FancyTerm.hs b/tests/neg/FancyTerm.hs
deleted file mode 100644
--- a/tests/neg/FancyTerm.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-{-# LANGUAGE GADTs #-}
-module FancyTerm where 
-
-import Language.Haskell.Liquid.This
-
-data Tree a where 
-    Leaf :: a -> Tree a 
-    Node :: (Int -> (Tree a)) -> Tree a 
-
-{-@ data size (Tree a) tsize @-}
-
-{-@ measure tsize :: Tree a -> Nat @-}
-{-@ data Tree a where 
-      Leaf :: a -> {t:Tree a  | tsize t == 0 } 
-      Node :: f:(Int -> Tree a) 
-           -> Tree a   @-}
-
-{-@ ignore node @-}
-{-@ node :: (Int -> {tin:Tree a |  0 <= tsize tin}) -> {t:Tree a | 0 <= tsize t} @-}
-node :: (Int -> Tree a) -> Tree a 
-node = Node 
-
-{-@ mapTr :: (a -> a) -> t:Tree a -> {o:Tree a | true} / [tsize t] @-}
-mapTr :: (a -> a) -> Tree a -> Tree a 
-mapTr f (Leaf x) = Leaf $ f x 
-mapTr f (Node n) = mapTr f (Node n) 
diff --git a/tests/neg/FilterAbs.hs b/tests/neg/FilterAbs.hs
deleted file mode 100644
--- a/tests/neg/FilterAbs.hs
+++ /dev/null
@@ -1,44 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--no-termination" @-}
-{-@ LIQUID "--short-names"    @-}
-
-
-
-module FilterAbs where
-
-import Prelude hiding (filter)
-
-{-@ filter :: forall 
 Bool, q :: a -> Bool -> Bool>.
-                  {y::a, flag :: {v:Bool | v} |- {v:a | v = y} <: a
}
-                  (x:a -> Bool) -> [a] -> [a
]
-  @-}
-
-filter f (x:xs)
-  | f x       = x : filter f xs
-  | otherwise = filter f xs
-filter _ []   = []
-
-{-@ isPos :: x:Int -> {v:Bool | v <=> x > 0} @-}
-isPos :: Int -> Bool
-isPos n = n > 0
-
-
-{-@ isNeg :: x:Int -> {v:Bool | v <=> x < 0} @-}
-isNeg :: Int -> Bool
-isNeg n = n < 0
-
-
--- Now the below *should* work with
--- p := \v   -> 0 < v
--- q := \x v -> v <=> 0 < 0
-
-
-{-@ positives :: [Int] -> [{v:Int | v > 0}] @-}
-positives xs = filter isPos xs
-
-{-@ negatives :: [Int] -> [{v:Int | v < 0}] @-}
-negatives xs = filter isNeg xs
-
-{-@ positivesBAD :: [Int] -> [{v:Int | v < 0}] @-}
-positivesBAD xs = filter isPos xs
-
diff --git a/tests/neg/FoldN.hs b/tests/neg/FoldN.hs
deleted file mode 100644
--- a/tests/neg/FoldN.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--pruneunsorted" @-}
-module FoldN () where
-
--- Testing "existential-types"
-
-{-@ foldN :: forall a 
 x1:a -> Bool>. 
-                (i:Int -> a
 -> a
)
-              -> n:{v: Int | v >= 0}
-              -> a 

-              -> a 

-  @-}
-
-foldN :: (Int -> a -> a) -> Int -> a -> a
-foldN f n = go 0
-  where go i x | i < n     = go (i+1) (f i x)
-               | otherwise = x
diff --git a/tests/neg/FoldN1.hs b/tests/neg/FoldN1.hs
deleted file mode 100644
--- a/tests/neg/FoldN1.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--pruneunsorted" @-}
-module FoldN1 where
-
-{-@ foldN :: forall a 
 x1:a -> Bool>. 
-                (i:Int -> a
 -> a
)
-              -> n:{v: Int | v >= 0}
-              -> a 

-              -> {v : a | 0=1}
-  @-}
-
-foldN :: (Int -> a -> a) -> Int -> a -> a
-foldN f n = go 0
-  where go i x | i < n     = go (i+1) (f i x)
-               | otherwise = x
diff --git a/tests/neg/FunSoundness.hs b/tests/neg/FunSoundness.hs
deleted file mode 100644
--- a/tests/neg/FunSoundness.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module FunSoundness where
-
-
-{-@ deadfun :: {v:a | false} -> a @-}
-deadfun :: a -> a
-deadfun x = x
-
-bad = deadfun f 
-  where f x = x 
diff --git a/tests/neg/FunctionRef.hs b/tests/neg/FunctionRef.hs
deleted file mode 100644
--- a/tests/neg/FunctionRef.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--higherorder"     @-}
-module FunctionRef where
-
-{-@ measure ackF :: Int -> Int -> Int  @-}
-
-{-@ assume ack :: n:Int -> {v: (x:Int -> {v:Int | v == ackF n x}) | v == ackF n } @-}
-ack :: Int -> Int -> Int
-ack = undefined
-
-bar :: Int -> Int -> Int
-{-@ bar :: n:Int -> {v:_ | false } @-}
-bar m n = ack m n
-
-{-
-foo :: Int -> Int -> Int
-{- foo :: n:Int -> Int -> Int  @-}
-foo n x = bar x n
--}
diff --git a/tests/neg/GeneralizedTermination.hs b/tests/neg/GeneralizedTermination.hs
deleted file mode 100644
--- a/tests/neg/GeneralizedTermination.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--no-totality" @-}
-module GeneralizedTermination () where
-
-foo :: Int -> Int -> Int
-{-@ foo :: n:Nat -> m:Nat -> Nat /[n+m] @-}
-
-foo n m 
-  | cond 1 = 0
-  | cond 2 && n > 1 = foo (n-1) m
-  | cond 3 && m > 2 = foo (n+10) (m-2)
- 
-{-@ cond :: Int -> Bool @-}
-cond :: Int -> Bool
-cond _ = undefined
diff --git a/tests/neg/Grty0.hs b/tests/neg/Grty0.hs
deleted file mode 100644
--- a/tests/neg/Grty0.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Grty0 () where
-
-{-@ stupid :: Int -> Int @-}
-stupid :: Int -> Int
-stupid x = 0
-
-{-@ myId :: x:a -> {v:a | v = x } @-}
-myId x = x 
-
-{-@ assert single :: a -> {v: [a] | len(v) = 0} @-}
-single x = [x] 
-
-
diff --git a/tests/neg/Grty1.hs b/tests/neg/Grty1.hs
deleted file mode 100644
--- a/tests/neg/Grty1.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--no-totality" @-}
-module Grty1 () where
-
-moo = insert 4 [1, 2, 0]
-
-
-{-@ insert      :: (Ord a) => x:a -> xs: [a]<{\fld v -> (v >= fld)}> -> {v: [a]<{\fld v -> (v >= fld)}> | len(v) = (1 + len(xs)) } @-}
-insert y []                   = [y]
-insert y (x : xs) | y <= x    = y : x : xs 
-                  | otherwise = x : insert y xs
-
-
diff --git a/tests/neg/Grty2.hs b/tests/neg/Grty2.hs
deleted file mode 100644
--- a/tests/neg/Grty2.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Grty2 () where
-
-moo = insert 4 [1, 2, 3]
-
-{-@ insert      :: (Ord a) => x:a -> xs: [a]<{\fld v -> (v >= fld)}> -> {v: [a]<{\fld v -> (v >= fld)}> | len(v) = (1 + len(xs)) } @-}
-insert y []                            = [y]
-insert y (x : xs) | y > {- <= -} x     = y : x : xs 
-                  | otherwise          = x : insert y xs
-
diff --git a/tests/neg/Grty3.hs b/tests/neg/Grty3.hs
deleted file mode 100644
--- a/tests/neg/Grty3.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Grty3 () where
-
-
-{-@ choo :: [a] -> {v: Int | v > 0 } @-}
-choo = poo
-
-
-poo :: [a] -> Int 
-poo (x:xs) = poo xs
-poo []     = 0
diff --git a/tests/neg/HasElem.hs b/tests/neg/HasElem.hs
deleted file mode 100644
--- a/tests/neg/HasElem.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module HasElem where
-
-{-@ LIQUID "--no-termination" @-}
-{-@ LIQUID "--reflection"     @-}
-{-@ LIQUID "--ple"            @-}
-
-data L a = Nil | Cons a (L a)
-
-{-@ reflect hasElem @-}
-hasElem :: Eq a => a -> L a -> Bool
-hasElem x Nil = False
-hasElem x (Cons y ys) = x == y || hasElem x ys
-
-{-@ prop, prop1, prop2 :: {v:Bool | v} @-}
-prop :: Bool
-prop = hasElem 1 (Cons 1 Nil)
-
-prop1 :: Bool
-prop1 = hasElem 1 (Cons 2 Nil)
-
-prop2 :: Bool
-prop2 = hasElem 1 Nil
-
-nil = Nil
-cons = Cons 
diff --git a/tests/neg/Hex00.hs b/tests/neg/Hex00.hs
deleted file mode 100644
--- a/tests/neg/Hex00.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Hex00 where
-
-{-@ foo :: {x:Int | x = 0x7} -> {y:Int | y = 0x6} -> {v:Int | v = 0xF} @-}
-foo :: Int -> Int -> Int 
-foo x y = x + y
-
-
diff --git a/tests/neg/HigherOrder.hs b/tests/neg/HigherOrder.hs
deleted file mode 100644
--- a/tests/neg/HigherOrder.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--higherorder" @-}
-module HigherOrder where
-
-
-{-@ foo :: a: Int -> f: (Int -> Int) -> {v : Int | v = 123 + (f a) } @-}
-foo :: Int -> (Int -> Int) -> Int
-foo a f = f a
diff --git a/tests/neg/HolesTop.hs b/tests/neg/HolesTop.hs
deleted file mode 100644
--- a/tests/neg/HolesTop.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module HolesTop where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ foo :: _ -> Bool @-}
-foo = liquidAssertB
-
-bar = foo True
diff --git a/tests/neg/Inc2.hs b/tests/neg/Inc2.hs
deleted file mode 100644
--- a/tests/neg/Inc2.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
--- ISSUE #671
---
--- | ISSUE would be nice to have error reported at `x-1` and NOT the `inc`
---   note that the right place gets shown if you comment out the `inc 0 = 1`
-
-module Inc2 where
-
-{-@ inc :: x:Int -> {v:Int | v > x} @-}
-inc :: Int -> Int
-inc 0 = 1
-inc x = x - 1
diff --git a/tests/neg/IntAbsRef.hs b/tests/neg/IntAbsRef.hs
deleted file mode 100644
--- a/tests/neg/IntAbsRef.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-
-module IntAbsRef where
-
-{-@ data Foo a 
 Bool> = Foo { x::Int
}@-}
-
-data Foo  a= Foo {x :: Int}
-  
-{-@ foo :: Foo <{\v -> v /= 1}> Int @-}
-foo :: Foo Int
-foo = Foo 1
diff --git a/tests/neg/LazyWhere.hs b/tests/neg/LazyWhere.hs
deleted file mode 100644
--- a/tests/neg/LazyWhere.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module LazyWhere () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ pos :: Nat -> Int @-}
-pos :: Int -> Int
-pos = undefined
-
-
-{-@ lazyvar z @-}
-foo = if x > 0 then z else z
-  where z = pos x
-        x = choose 0
diff --git a/tests/neg/LazyWhere1.hs b/tests/neg/LazyWhere1.hs
deleted file mode 100644
--- a/tests/neg/LazyWhere1.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module LazyWhere1 () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ pos :: Nat -> Int @-}
-pos :: Int -> Int
-pos = undefined
-
-{-@ safeDiv :: Int -> {v:Int| v != 0} -> Int @-}
-safeDiv :: Int -> Int -> Int
-safeDiv = undefined
-
-
--- Limitations :: Definitions of lazy variables should be alpha renamed,
---  otherwise, internal variables will be created and the expression will be
---  unsafe
-
-{-@ lazyvar z @-}
-foo = if x > 0 then z else x
-  where z  = (42 `safeDiv` x) + ( pos x)
-        x = choose 0
diff --git a/tests/neg/LetRecStack.hs b/tests/neg/LetRecStack.hs
deleted file mode 100644
--- a/tests/neg/LetRecStack.hs
+++ /dev/null
@@ -1,44 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--eliminate=all" @-}
--- | This test case is to check that LH properly accounts for the case where GHC Core 
---   contains stuff like:
---   foo :: T 
---   foo = 
---     let t1 = e1 
---         t2 = e2
---         ...
---         tn = en 
---     in
---     let rec bar = e
---     in 
---       bar 
--- 
---  where `T` is a liquid type specification. This sort of stuff is introduced by GHC8 
---  in order to manage the implicit `CallStack` parameters, but it ends up generating 
---  extra KVars where none are needed (as we already have the signature.)
-
-{-@ LIQUID "--no-termination" @-}
-
-module LetRecStack (prop) where
-
---data Peano a = Z a | S (Peano a) | P (Peano a)
-data Peano = Z | S (Peano ) | P (Peano)
-
-{- foo :: Peano -> Nat @-}
-foo :: Peano -> Int 
-foo = 
-  let t0 = 0 
-      t1 = 1 
-  in
-  let baz p = case p of 
-                Z  -> t0
-                S p -> t1 + baz p 
-                P p -> error ms 
-              where 
-                ms = "yikes"
-  in
-    baz
-
--- USE THIS AS THE NEG VERSION
-{-@ prop :: Peano -> Nat @-}
-prop = foo 
diff --git a/tests/neg/List00.hs b/tests/neg/List00.hs
deleted file mode 100644
--- a/tests/neg/List00.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module List00 () where
-
-import Language.Haskell.Liquid.Prelude -- hiding (copyList)
-
-copyList zs = zs
-
-xs    = [1] :: [Int]
-ys    = copyList xs
-jhala = head ys
-prop0 = crash (0 == 1) 
diff --git a/tests/neg/ListConcat.hs b/tests/neg/ListConcat.hs
deleted file mode 100644
--- a/tests/neg/ListConcat.hs
+++ /dev/null
@@ -1,24 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--pruneunsorted" @-}
-
-module ListConcat () where
-import Data.Set (Set(..)) 
-import Prelude hiding (concat)
-
-{-@ measure llElts :: [[a]] -> (Set a) 
-      llElts []   = {v | Set_emp v }
-      llElts (x:xs) = {v | v = Set_cup (listElts x) (llElts xs) }
-  @-}
-
-
-{-@ concat :: ys:[[a]] -> {v:[a] | listElts v = llElts ys } @-}
-concat :: [[a]] ->  [a]
-concat  []         = []
-concat ([]: xs)    = concat xs
-concat ((y:ys):xs) = concat (ys:xs)
-
-
-
-
-
-
diff --git a/tests/neg/ListElem.hs b/tests/neg/ListElem.hs
deleted file mode 100644
--- a/tests/neg/ListElem.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module ListElem (listElem) where
-
-import Data.Set
-
-{-@ listElem :: (Eq a)
-             => y:a
-             -> xs:[a]
-             -> {v:Bool | v <=> Set_mem y (listElts xs)}
-  @-}
-
-listElem :: (Eq a) => a -> [a] -> Bool
-listElem _ []      = False
-listElem y (x:_xs)
-  | x == y         = True
-  | otherwise      = True -- listElem y xs
diff --git a/tests/neg/ListKeys.hs b/tests/neg/ListKeys.hs
deleted file mode 100644
--- a/tests/neg/ListKeys.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--pruneunsorted" @-}
-
-module ListKeys () where
-import Data.Set (Set(..)) 
-
-{-@ measure listKeys :: [(k, v)] -> (Set k)
-      listKeys([])   = {v | Set_emp v }
-      listKeys(x:xs) = {v | v = Set_cup (Set_sng (fst x)) (listKeys xs) }
-  @-}
-
-
-{-@ getFsts :: ys:[(a, a)] -> {v:[a] | listElts v = listKeys ys } @-}
-getFsts ::[(a, a)] ->  [a]
-getFsts []           = []
-getFsts ((_, x): xs) = x : getFsts xs
-
-
-
-
-
-
diff --git a/tests/neg/ListMSort.hs b/tests/neg/ListMSort.hs
deleted file mode 100644
--- a/tests/neg/ListMSort.hs
+++ /dev/null
@@ -1,35 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module ListMSort () where
-
-import Language.Haskell.Liquid.Prelude
-
-
-split :: [a] -> ([a], [a])
-split (x:(y:zs)) = (x:xs, y:ys) where (xs, ys) = split zs
-split xs                   = (xs, [])
-
-merge :: Ord a => [a] -> [a] -> [a]
-merge xs [] = xs
-merge [] ys = ys
-merge (x:xs) (y:ys)
-  | x <= y
-  = x:(merge xs (y:ys))
-  | otherwise
-  = y:(merge (x:xs) ys)
-
-{-@ mergesort :: (Ord a) => xs:[a] -> [a]<{\fld v -> (v < fld)}>  @-}
-mergesort :: Ord a => [a] -> [a]
-mergesort [] = []
-mergesort [x] = [x]
-mergesort xs = merge (mergesort xs1) (mergesort xs2) where (xs1, xs2) = split xs
-
-chk [] = liquidAssertB True
-chk (x1:xs) = case xs of
-               []     -> liquidAssertB True
-               x2:xs2 -> liquidAssertB (x1 <= x2) && chk xs
-
-rlist = map choose [1 .. 10]
-
-bar = mergesort rlist
-
-prop0 = chk bar
diff --git a/tests/neg/ListRange.hs b/tests/neg/ListRange.hs
deleted file mode 100644
--- a/tests/neg/ListRange.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module ListRange () where
-
-import Language.Haskell.Liquid.Prelude
-
-
-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 
diff --git a/tests/neg/Listne.hs b/tests/neg/Listne.hs
deleted file mode 100644
--- a/tests/neg/Listne.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Listne where
-
-{-@ type ListNE a = {v:[a] | 0 < len v} @-}
-
-{-@ junkProp :: ListNE Int @-}
-junkProp :: [Int]
-junkProp = []
-
diff --git a/tests/neg/Lit.hs b/tests/neg/Lit.hs
deleted file mode 100644
--- a/tests/neg/Lit.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Lit where
-
-{-@ test :: {v:Int | v == 30} @-}
-test = length "cat"
diff --git a/tests/neg/LocalSpec.hs b/tests/neg/LocalSpec.hs
deleted file mode 100644
--- a/tests/neg/LocalSpec.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module LocalSpec () where
-
-import Language.Haskell.Liquid.Prelude (choose)
-
-
-prop = if x < 0 then bar x else x
-  where x = choose 0
-    {-@ bar :: Nat -> Nat @-}
-        bar :: Int -> Int
-        bar x = x
-
-{-@ bar :: a -> {v:Int | v = 9} @-}
-bar :: a -> Int
-bar _ = 8
diff --git a/tests/neg/Mapreduce.hs b/tests/neg/Mapreduce.hs
deleted file mode 100644
--- a/tests/neg/Mapreduce.hs
+++ /dev/null
@@ -1,56 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-
--- RJ: Issues with TypeClasses? Ord?
-
-module Mapreduce () where
-
-import Language.Haskell.Liquid.Prelude
-import qualified Data.Map as M
-import Data.List (foldl')
-
-----------------------------------------------------------------
---- Step 1: Map each element into key-value list (concatMap) ---
-----------------------------------------------------------------
-
-expand          :: (a -> [(k,v)]) -> [a] -> [(k, v)]
-expand f []     = []
-expand f (x:xs) = (f x) ++ (expand f xs)
-
-----------------------------------------------------------------
---- Step 2: Group By Key ---------------------------------------
-----------------------------------------------------------------
-
-group :: (Ord k) => [(k, v)] -> M.Map k [v]
-group = foldl' addKV  M.empty
-  
-addKV m (k, v) = M.insert k vs' m
-  where vs' = v : (M.findWithDefault [] k m)
-
-----------------------------------------------------------------
---- Step 3: Group By Key ---------------------------------------
-----------------------------------------------------------------
-
-collapse f = M.foldrWithKey reduceKV []
-  where reduceKV k (v:vs) acc = if liquidAssertB False then (k, foldl' f v vs) : acc else acc
-        reduceKV k []     _   = crash False --error $ show (liquidAssertB False)
-
-----------------------------------------------------------------
---- Putting it All Together ------------------------------------
-----------------------------------------------------------------
-
-mapReduce fmap fred = collapse fred . group . expand fmap 
-
-----------------------------------------------------------------
---- "Word Count" -----------------------------------------------
-----------------------------------------------------------------
-
-wordCount  = mapReduce fm plus 
-  where fm = \doc -> [ (w,1) | w <- words doc]
-
-main = putStrLn $ show $ wordCount docs
-  where docs = [ "this is the end"
-               , "go to the end"
-               , "the end is the beginning"]
- 
-
-
diff --git a/tests/neg/Mapreduce_tiny.hs b/tests/neg/Mapreduce_tiny.hs
deleted file mode 100644
--- a/tests/neg/Mapreduce_tiny.hs
+++ /dev/null
@@ -1,31 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-
-
-
-module Mapreduce_tiny () where
-
-import Language.Haskell.Liquid.Prelude
-
-
-
-prop1       = map choo [[True]] -- replace [[1]] with [[]] for UNSAT
-choo (x:xs) = liquidAssertB False
--- choo []     = liquidAssertB False
-
--- import qualified Data.Map as M
--- import Data.List (foldl')
-
---keyvals :: [(Int, Int)]
---keyvals = [(1, 1), (2, 2), (3, 3)]
---
---group :: (Ord k) => [(k, v)] -> M.Map k [v]
---group = foldl' addKV  M.empty
---
---addKV m (k, v) = let boo = liquidAssertB False in M.insert k vs' m
---  where vs' = v : (M.findWithDefault [] k m)
---
---checkNN m = M.foldrWithKey reduceKV False m
---
---reduceKV _ _ acc = liquidAssertB False 
---
---prop = checkNN (group keyvals)
diff --git a/tests/neg/Maps.hs b/tests/neg/Maps.hs
deleted file mode 100644
--- a/tests/neg/Maps.hs
+++ /dev/null
@@ -1,35 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Maps where
-
-{-@ prop1 :: x:_ -> y:{_ | y == x} -> TT @-}
-prop1 x y = (z == 10)
-  where
-    m1    = put x 10 emp  
-    m2    = put y 20 m1
-    z     = get x m2
-
-{-@ prop2 :: x:_ -> y:{_ | y == x} -> TT @-}
-prop2 x y = (z == 10)
-  where
-    m1    = put x 10 emp 
-    m2    = put y 20 m1
-    z     = get x m2
-
------------------------------------------------------------------------
-
-data Map k v = M
-
-{-@ embed Map as Map_t @-}
-{-@ measure Map_select :: Map k v -> k -> v @-}
-{-@ measure Map_store  :: Map k v -> k -> v -> Map k v @-}
-
-emp :: Map Int Int
-emp = undefined   
-     
-{-@ get :: k:k -> m:Map k v -> {v:v | v = Map_select m k} @-}
-get :: k -> Map k v -> v
-get = undefined 
-
-{-@ put :: k:k -> v:v -> m:Map k v -> {n:Map k v | n = Map_store m k v} @-}
-put :: k -> v -> Map k v -> Map k v
-put = undefined 
diff --git a/tests/neg/Maybe.hs b/tests/neg/Maybe.hs
deleted file mode 100644
--- a/tests/neg/Maybe.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Maybe where
-
-import Data.Maybe
-
-
-foo :: Maybe a -> a
-foo x = fromJust x
diff --git a/tests/neg/MaybeMonad.hs b/tests/neg/MaybeMonad.hs
deleted file mode 100644
--- a/tests/neg/MaybeMonad.hs
+++ /dev/null
@@ -1,37 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
--- TODO-REBARE: STRATA
-module MaybeMonad where
-
-import Prelude hiding (take)
-
-{-@ monadicStyle :: Pos -> [a] -> Maybe [a] @-}
-monadicStyle i xs =
-  do checkSizeMaybe i head xs
-     return (take i xs)
-
-{-@ maybeStyle :: Pos -> [a] -> Maybe [a] @-}
-maybeStyle i xs =
-  case checkSizeMaybe i head xs of 
-    Just _  -> Just $ take i xs 
-    Nothing -> Nothing 
-
-
-{-@ type Pos = {v:Int | 0 < v } @-}
-
-{-@
-checkSizeMaybe :: 
-       n:Nat
-    -> (bs:{[a] | n <= len bs } -> b)
-    -> bs:[a]
-    -> {v:Maybe b | isJust v => n <= len bs}
-@-}
-
-checkSizeMaybe :: Int -> ([a] -> b) -> [a] -> Maybe b
-checkSizeMaybe sz f bs
-  | length bs >= sz = Just (f bs)
-  | otherwise       = Nothing
-
-{-@ take :: i:Nat -> xs:{[a] | i <= len xs} -> [a] @-} 
-take :: Int -> [a] -> [a]
-take 0 []        = [] 
-take i (x:xs) = if i == 0 then [] else x:(take (i-1) xs)
diff --git a/tests/neg/Meas0.hs b/tests/neg/Meas0.hs
deleted file mode 100644
--- a/tests/neg/Meas0.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Meas0 () where
-
-import Control.Applicative
-import Language.Haskell.Liquid.Prelude
-
-goo x = []
-
-poo (x:_) = True
-poo ([])  = liquidAssertB False
-
-xs = goo (choose 0)
-
-prop1 = liquidAssertB (poo xs)
diff --git a/tests/neg/Meas2.hs b/tests/neg/Meas2.hs
deleted file mode 100644
--- a/tests/neg/Meas2.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Meas2 () where
-
-import Language.Haskell.Liquid.Prelude
-
-goo :: a -> Int
-goo _ = 1
-
-bob :: [a] -> Int
---bob [] = 0
---bob (n:ns) = goo ns 
-bob ms = case ms of 
-           []     -> 0
-           (n:ns) -> goo ns 
-
-zs :: [Int]
-zs = [1..100]
-
-prop2 = liquidAssertB (n2 `eq` 0) 
-  where n2 = bob zs
diff --git a/tests/neg/Meas3.hs b/tests/neg/Meas3.hs
deleted file mode 100644
--- a/tests/neg/Meas3.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Meas3 () where
-
-
-import Language.Haskell.Liquid.Prelude
-
---mylen []       = 0
---mylen (_:xs)   = 1 `plus` mylen xs
-
-mylen xs = case xs of 
-             []     -> 0
-             (_:ys) -> 1 `plus` mylen ys
-
-
-zs :: [Int]
-zs = [1..100]
-
-goo :: [dogbert] -> Int
-goo _ = 1
-
-bloo :: [Int] -> Int
-bloo _ = 0
-
-prop1 = liquidAssertB (n1 `eq` 0) 
-  where n1 = mylen zs
diff --git a/tests/neg/Meas5.hs b/tests/neg/Meas5.hs
deleted file mode 100644
--- a/tests/neg/Meas5.hs
+++ /dev/null
@@ -1,42 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Meas5 () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ include  @-}
-
-mylen          :: [a] -> Int
-mylen []       = 0
-mylen (_:xs)   = 1 + mylen xs
-
-
-mymap f []     = []
-mymap f (x:xs) = (f x) : (mymap f xs)
-
-myreverse = go []
-  where go acc (x:xs) = go (x:acc) xs
-        go acc []     = acc
-    
-myapp [] ys     = ys
-myapp (x:xs) ys = x:(myapp xs ys)
-
-zs :: [Int]
-zs = [1..100]
-
-zs' :: [Int]
-zs' = [500..1000]
-
-prop2 = liquidAssertB (n1 == n2) 
-  where n1 = mylen zs
-        n2 = mylen $ mymap (+ 1) zs 
-
-prop3 = liquidAssertB (n1 == n2) 
-  where n1 = mylen zs
-        n2 = mylen $ myreverse zs 
-
-prop4 = liquidAssertB ((n1 + n2) == n3) 
-  where n1 = mylen zs
-        n2 = mylen zs'
-        n3 = mylen $ myapp zs zs' 
-
-prop5 = zipWith (+) zs (0: myreverse zs)
diff --git a/tests/neg/Meas7.hs b/tests/neg/Meas7.hs
deleted file mode 100644
--- a/tests/neg/Meas7.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-
-module Meas7 () where
-
--- some tests for the 'expandDefaultCase' trick to case-split 
--- on the "missing" constructors.
-
-mylen          :: [a] -> Int
-mylen []       = 0
-mylen (_:xs)   = 1 + mylen xs
-
-
-{-@ foo :: [a] -> {v: Int | v = 0} @-}
-foo :: [a] -> Int
-foo zs = case zs of
-           [] -> 0
-           _  -> mylen zs
-
diff --git a/tests/neg/Meas9.hs b/tests/neg/Meas9.hs
deleted file mode 100644
--- a/tests/neg/Meas9.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Meas9 () where
-
-import Data.Set (Set(..))
-
-{-@ myid :: xs:[a] -> {v:[a]| listElts(v) = listElts(xs)} @-}
-myid []     = []
-myid (x:xs) = x : myid xs
-
-{-@ myapp :: xs:[a] -> ys:[a] -> {v:[a] | listElts(v) = Set_cup (listElts xs) (listElts xs) } @-}
-myapp :: [a] -> [a] -> [a]
-myapp []     ys = ys
-myapp (x:xs) ys = x : myapp xs ys
-
diff --git a/tests/neg/MeasureContains.hs b/tests/neg/MeasureContains.hs
deleted file mode 100644
--- a/tests/neg/MeasureContains.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module MeasureContains where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ LIQUID "--no-termination" @-}
-
-{-@ measure binderContainsV @-}
-binderContainsV ::  Binder n -> Bool
-binderContainsV B     = True
-binderContainsV (M x) = containsV x
-
-data Binder n = B | M (TT n)
-data TT n     = V Int | Other | Bind (Binder n) (TT n)
-
-{-@ measure containsV @-}
-containsV :: TT n -> Bool
-containsV (V i)         = True
-containsV (Bind b body) = (binderContainsV b) || (containsV body)
-containsV _             = False
-
-
-prop1 = liquidAssert (containsV $ Other)
diff --git a/tests/neg/MeasureDups.hs b/tests/neg/MeasureDups.hs
deleted file mode 100644
--- a/tests/neg/MeasureDups.hs
+++ /dev/null
@@ -1,35 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module MeasureDups where
-
-import Data.Set
-
-{-@ LIQUID "--no-termination" @-}
-{-@ measure elements @-}
-{-@ measure dups @-}
-
-data F a = F a |  C a (F a) | E
-
-dups :: Ord a => F a -> Set a
-dups E        = empty
-dups (F a)    = empty
-dups (C x xs) = if member x (elements xs) then singleton x `union` dups xs else dups xs
-
-elements :: Ord a => F a -> Set a
-elements E        = empty
-elements (F a)    = singleton a
-elements (C x xs) = singleton x `union` elements xs
-
-
-
-{-@ foo :: (Ord a) => x:F a -> {v:Set a | (dups x) = v} @-}
-foo :: Ord a => F a -> Set a
-foo E        = empty
-foo (F a)    = empty
-foo (C x xs) = if member x (elements xs) then singleton x `union` foo xs else foo xs
-
-
-
-{-@ prop :: { v: Bool | v } @-}
-prop = dups s == empty
-  where
-    s = C 1 (C 3 (F 1)) :: F Int
diff --git a/tests/neg/MergeSort.hs b/tests/neg/MergeSort.hs
deleted file mode 100644
--- a/tests/neg/MergeSort.hs
+++ /dev/null
@@ -1,53 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-------------------------------------------------------------------------------
--- | An implementation of Merge Sort, where LH verifies:
---   1. Termination (Totality) 
---   2. The output is indeed in non-decreasing order 
-------------------------------------------------------------------------------
-
-module MergeSort (sort) where
-
-{-@ type OList a    = [a]<{\fld v -> (v >= fld)}> @-}
-
-{-@ type OListN a N = {v:OList a | len v == N} @-}
-
--- | The top level `sort` function. Proved:
---   (a) terminating, 
---   (b) ordered, and 
---   (c) of same size as input.
-
-{-@ sort :: (Ord a) => xs:[a] -> OListN a {len xs} @-}
-sort :: Ord a => [a] -> [a]
-sort []   = []
-sort [x]  = [x]
-sort xs   = merge (sort xs1) (sort xs2) 
-  where 
-    (xs1, xs2) = split xs
-
--- Fun fact: if you delete the singleton case above,
--- the resulting function is, in fact, non-terminating!
-
--- | A type describing two `Halves` of a list `Xs` 
-
-{-@ type Halves a Xs = {v: (Half a Xs, Half a Xs) | len (fst v) + len (snd v) == len Xs} @-}
-
--- | Each `Half` is empty or smaller than the input:
-
-{-@ type Half a Xs  = {v:[a] | 2 * len v < 1 + len Xs} @-}
-
--- | The `split` function breaks its list into two `Halves`:
-
-{-@ split :: xs:[a] -> Halves a xs @-}
-split :: [a] -> ([a], [a])
-split (x:(y:zs)) = (x:xs, y:ys) where (xs, ys) = split zs
-split xs         = (xs, [])
-
--- | Finally, the `merge` function combines two ordered lists into a single ordered result.
-
-{-@ merge :: Ord a => xs:OList a -> ys:OList a -> OListN a {len xs + len ys} / [(len xs + len ys)] @-}
-merge :: Ord a => [a] -> [a] ->  [a]
-merge xs []         = xs
-merge [] ys         = ys
-merge (x:xs) (y:ys)
-  | x <= y          = x : merge xs (y:ys)
-  | otherwise       = y : merge (x:xs) ys
diff --git a/tests/neg/Monad3.hs b/tests/neg/Monad3.hs
deleted file mode 100644
--- a/tests/neg/Monad3.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Monad3 () where
-
-import Language.Haskell.Liquid.Prelude
-
--- gpp :: Monad m => m Int -> m Int
-gpp z = do x <- z
-           return $ liquidAssert (x >= 0) (x + 1)
-
-
--- decrlist n = n : decrlist (n-1)
-
-xs, ys, zs :: [Int]
-xs = [0, -1]
-ys = gpp xs
-zs = gpp ys
diff --git a/tests/neg/Monad4.hs b/tests/neg/Monad4.hs
deleted file mode 100644
--- a/tests/neg/Monad4.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Monad4 () where
-
-import Language.Haskell.Liquid.Prelude
-
--- gpp :: Monad m => m Int -> m Int
-gpp z = do x <- z
-           return $ liquidAssert (x > 0) (x - 10)
-
-
-incrlist n = n : incrlist (n+1)
-
-xs, ys, zs :: Maybe Int
-xs = Just 9
-ys = gpp xs
-zs = gpp ys
diff --git a/tests/neg/Monad5.hs b/tests/neg/Monad5.hs
deleted file mode 100644
--- a/tests/neg/Monad5.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Monad5 () where
-
-import Language.Haskell.Liquid.Prelude
-
--- gpp :: Monad m => m Int -> m Int
-gpp z = do x <- z
-           return $ liquidAssert (x > 0) (x + 1)
-
-myabs :: Int -> Int
-myabs x | x >= 0     = x
-        | otherwise  = 0-x
-
-posM :: Monad m => m Int
-posM = return $ myabs $ choose 0
-
-
-yM :: Monad m => m Int
-yM = gpp posM
diff --git a/tests/neg/Monad6.hs b/tests/neg/Monad6.hs
deleted file mode 100644
--- a/tests/neg/Monad6.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Monad6 where
-
-import Language.Haskell.Liquid.Prelude 
-
-{-@ gpp :: Monad m => m {v:Int|v>=0} -> m {v:Int|v>0} @-}
-gpp :: Monad m => m Int -> m Int
-gpp z = do x <- z
-           return $ liquidAssert (x >= 0) (x)
diff --git a/tests/neg/Monad7.hs b/tests/neg/Monad7.hs
deleted file mode 100644
--- a/tests/neg/Monad7.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Monad7 () where
-
-import Language.Haskell.Liquid.Prelude 
-
-{-@ type OList a = [a]<{\fld v -> (v >= fld)}> @-}
-{-@ gpp :: (Ord a, Monad m) => [a] -> m (OList a) @-}
-gpp :: (Ord a, Monad m) => [a] -> m [a]
-gpp ls = return $ reverse $ insertSort ls
-
-{-@ insertSort :: (Ord a) => xs:[a] -> OList a @-}
-insertSort            :: (Ord a) => [a] -> [a]
-insertSort []         = []
-insertSort (x:xs)     = insert x (insertSort xs) 
-
-insert y []                   = [y]
-insert y (x : xs) | y <= x    = y : x : xs 
-                  | otherwise = x : insert y xs
-
-
-
-
-
diff --git a/tests/neg/Mr00.hs b/tests/neg/Mr00.hs
deleted file mode 100644
--- a/tests/neg/Mr00.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Mr00 () where
-
-import Language.Haskell.Liquid.Prelude 
-import Data.Map hiding (filter, map, foldl)
-
-baz (v:vs) _ = crash False 
-baz []     _ = crash False
-
-mymap = Data.Map.fromList [('a', [1])]
-
--- Why is this safe
-coll = Data.Map.foldr baz 0 
-prop_safe = coll mymap 
-
--- Oddly, this is unsafe
--- prop_unsafe = Data.Map.foldr baz 0 mymap
diff --git a/tests/neg/MultiParamTypeClasses.hs b/tests/neg/MultiParamTypeClasses.hs
deleted file mode 100644
--- a/tests/neg/MultiParamTypeClasses.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-
-module MultiParamTypeClasses where
-
-class Add a b where
-    rAdd :: [a] -> [b] -> [a]
-
-{-@ instance (Num k) => Add k k where 
-     rAdd :: 
-        x : {v : [k] | len v > 0} 
-        -> {v : [k] | (len v = len x) && len v > 0} 
-        -> {v : [k] | len v > 0}
-
-@-}
-instance (Num k) => Add k k where
-    rAdd x y = x
-
-main = putStrLn (show (rAdd ([] :: [Double]) ([] :: [Double])))
diff --git a/tests/neg/Multi_pred_app_00.hs b/tests/neg/Multi_pred_app_00.hs
deleted file mode 100644
--- a/tests/neg/Multi_pred_app_00.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Multi_pred_app_00 () where
-
-{-@ bar :: forall < p :: Int -> Bool, q :: Int -> Bool>. Int
 -> Int @-}
-bar :: Int -> Int
-bar x = x
diff --git a/tests/neg/MultipleInvariants.hs b/tests/neg/MultipleInvariants.hs
deleted file mode 100644
--- a/tests/neg/MultipleInvariants.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module MultipleInvariants where
-
-import Data.Word
-import GHC.Ptr
-
-
-{-@ measure sizeOf :: forall a . Ptr a -> Int @-}
-
-{-@ invariant {v:Ptr Word16 | sizeOf v = 2} @-}
-{-@ invariant {v:Ptr Word32 | sizeOf v = 4} @-}
-
-
-{-@ bar :: p:_ -> {v:_ | sizeOf p == 4 }@-}
-bar :: Ptr Word32 -> ()
-bar (Ptr _) = ()
-
-{-@ foo :: p:_ -> {v:_ | sizeOf p == 2 }@-}
-foo :: Ptr Word16 -> ()
-foo (Ptr _) = ()
-
-
-{-@ unsound :: _ -> {v:_ | false} @-}
-unsound :: Ptr Word32 -> ()
-unsound (Ptr _) = ()
diff --git a/tests/neg/NameResolution.hs b/tests/neg/NameResolution.hs
deleted file mode 100644
--- a/tests/neg/NameResolution.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module NameResolution where
-
-import Prelude hiding ((==), (++))
-import Language.Haskell.Liquid.Equational 
-
-
-{-@ bar :: () -> Int @-}
-bar :: () -> Int
-bar _
-  =   1 
-  ==. 2 
-
-
-{-@ (==..) :: x:a -> y:{a | x == y} -> {v:a | v == y && v == x} @-}
-(==..) :: a -> a -> a 
-_ ==.. x = x
-
-{-@ foo :: () -> Int @-}
-foo :: () -> Int
-foo _
-  =   1 
-  ==.. 2 
-
-
-{-@ (++) :: a -> a -> a @-}
-(++) :: a -> a -> a 
-x ++ _ = x 
diff --git a/tests/neg/NestedRecursion.hs b/tests/neg/NestedRecursion.hs
deleted file mode 100644
--- a/tests/neg/NestedRecursion.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module NestedRecursion (radicals) where
-
-radicals :: Int -> [a]
-radicals n = [ foo (radicals n) i | i <- [1..]]
-
-foo = undefined
diff --git a/tests/neg/NoExhaustiveGuardsError.hs b/tests/neg/NoExhaustiveGuardsError.hs
deleted file mode 100644
--- a/tests/neg/NoExhaustiveGuardsError.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module NoExhaustiveGuardsError where
-
-bar :: Int -> Int -> Int
-bar x y | x >  y = 1
-        | x == y = 0
diff --git a/tests/neg/NoMethodBindingError.hs b/tests/neg/NoMethodBindingError.hs
deleted file mode 100644
--- a/tests/neg/NoMethodBindingError.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-# OPTIONS_GHC -Wno-missing-methods #-}
-{-@ LIQUID "--expect-any-error" @-}
-module NoMethodBindingError where
-
-class Foo a where
-  foo :: a -> a
-
-instance Foo Int where
--- no method binding error
---
-goo :: Int -> Int
-goo = foo 
diff --git a/tests/neg/Null.hs b/tests/neg/Null.hs
deleted file mode 100644
--- a/tests/neg/Null.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Null where
-
-foo :: [Int] -> Int
-foo xs = if null xs then head xs else 0
diff --git a/tests/neg/Pair.hs b/tests/neg/Pair.hs
deleted file mode 100644
--- a/tests/neg/Pair.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Pair () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ data Pair a b 
 b -> Bool> = P { pX :: a, pY :: b
 } @-} 
-data Pair a b = P a b
-
-incr x = let p = P x ((x+1)) in p
-chk (P x (y)) = liquidAssertB (x == y)
-prop  = chk $ incr n
-  where n = choose 0
-
-incr2 x =
-  let p1 = (P True (x+1)) in
-  let p2 = P x p1 in
-   p2
-chk2 (P x w) =
-   case w of (P z y) -> liquidAssertB (x == y)
-prop2  = chk2 $ incr2 n
-  where n = choose 0
-
-incr3 x = P x (P True (P 0 (x+1)))
-chk3 (P x (P _(P _ y))) = liquidAssertB (x == y)
-prop3  = chk3 $ incr3 n
-  where n = choose 0
diff --git a/tests/neg/Pair0.hs b/tests/neg/Pair0.hs
deleted file mode 100644
--- a/tests/neg/Pair0.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Pair0 () where
-
-import Language.Haskell.Liquid.Prelude 
-
-data Pair a b = P a b
-
-
-incr x = (x, x-1)
-chk (x, y) = liquidAssertB (x  a
-getfst (x, y) = x
-
-{-@ type Pair a b   = {v0 : ({v:a | v = (getfst v0)}, b) | true } @-}
-
-{-@ type OPList a b = [(Pair a b)]<\h -> {v: (Pair a b) | (getfst v) >= (getfst h)}> @-}
-
-{-@ type OList a    = [a]<\h -> {v: a | (v >= h)}> @-}
-
-{-@ getFsts :: OPList a b -> OList a @-}
-getFsts []           = [] 
-getFsts ((x,_) : xs) = x : getFsts xs
-
-{-@ canary :: a -> {v:a | false} @-}
-canary x = x 
diff --git a/tests/neg/Pargs.hs b/tests/neg/Pargs.hs
deleted file mode 100644
--- a/tests/neg/Pargs.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Pargs () where
-
-{-@ foo :: forall a 
 x1:a -> Bool>. 
-             (i:Int -> a
) -> {v:Int| v=0}
-              -> a 

-  @-}
-
-foo ::  (Int -> a) -> Int ->  a
-foo f i = f i
diff --git a/tests/neg/Pargs1.hs b/tests/neg/Pargs1.hs
deleted file mode 100644
--- a/tests/neg/Pargs1.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--pruneunsorted" @-}
-module Pargs1 () where
-
-{-@ foo :: forall a 
 x1:a -> Bool>. 
-             (i:Int  -> j : Int-> a
) ->
-               ii:Int -> jj:Int
-              -> a 

-  @-}
-
-foo ::  (Int -> Int -> a) -> Int -> Int ->  a
-foo f i j = f i j
diff --git a/tests/neg/Partial.hs b/tests/neg/Partial.hs
deleted file mode 100644
--- a/tests/neg/Partial.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Partial () where
-
-{-@ posPlus :: x:{v: Int | v >= 0} -> {v: Int | v >= x} @-}
-posPlus :: Int -> Int
-posPlus x = if (x > 0) 
-              then 2 + (posPlus (x - 1))
-              else 0
-
-goo = posPlus (-3)
-
-{-@ poo :: x:Int -> {v: Int | v >= x } @-}
-poo x = if x > 0 then posPlus x else x
-
diff --git a/tests/neg/Poly0.hs b/tests/neg/Poly0.hs
deleted file mode 100644
--- a/tests/neg/Poly0.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Poly0 () where
-
-import Language.Haskell.Liquid.Prelude
-
-myabs x    = if x `gt` 0 then x else 0 `minus` x
-
-myid arg     = arg
-
-----------------------------------------------------------
-
-x = choose 0
-
-prop_id1 = let x'  = myabs x in 
-           let x'' = myid x' in 
-           liquidAssertB (x'' `geq` 0)
-
-prop_id2 = liquidAssertB (x'' `geq` 0)
-  where x'  = myabs x 
-        x'' = myid x' 
-
-prop_id3 = liquidAssertB (x' `geq` 20)
-  where x' = myid $ myabs x 
diff --git a/tests/neg/Poly1.hs b/tests/neg/Poly1.hs
deleted file mode 100644
--- a/tests/neg/Poly1.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Poly1 () where
-
-import Language.Haskell.Liquid.Prelude
-
-myabs x    = if x `gt` 0 then x else 0 `minus` x
-
-myid2 a b  = a  
-
-----------------------------------------------------------
-
-x =  choose 0
-
-prop_id4 = let x'  = myabs x in 
-           let x'' = myid2 x' [] in 
-           liquidAssertB (x'' `geq` 10)
-
-prop_id5 = liquidAssertB (x'' `geq` 0)
-  where x'  = myabs x 
-        x'' = myid2 x' [] 
diff --git a/tests/neg/Poly2.hs b/tests/neg/Poly2.hs
deleted file mode 100644
--- a/tests/neg/Poly2.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Poly2 () where
-
-import Language.Haskell.Liquid.Prelude
-
-myabs x    = if x `gt` 0 then x else 0 `minus` x
-
-----------------------------------------------------------
-
-myid3 x y  = y
-
-x = choose 0
-
-prop_id6 = liquidAssertB (x' `geq` 10)
-  where x' = myid3 [] $ myabs x 
-
-
diff --git a/tests/neg/Poly2_degenerate.hs b/tests/neg/Poly2_degenerate.hs
deleted file mode 100644
--- a/tests/neg/Poly2_degenerate.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Poly2_degenerate () where
-
-import Language.Haskell.Liquid.Prelude
-
-myabs x    = if x `gt` 0 then x else 0 `minus` x
-
-----------------------------------------------------------
-
-myid3 x y  = y
-
-prop_id6 = liquidAssertB (x' `geq` 10)
-  where x' = myid3 [] $ myabs n 
-        n  = choose 0
-
diff --git a/tests/neg/Polypred.hs b/tests/neg/Polypred.hs
deleted file mode 100644
--- a/tests/neg/Polypred.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Polypred () where
-
-import Language.Haskell.Liquid.Prelude
-
-prop :: Int -> Bool
-prop x = liquidAssertB (x == 0)
-
-foo :: a -> Int
-foo longVarName = choose 20 
-
--- propUNSAFE = prop (foo "ker")
-propSAFE = prop (foo id)
-
diff --git a/tests/neg/Poslist.hs b/tests/neg/Poslist.hs
deleted file mode 100644
--- a/tests/neg/Poslist.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Poslist () where
-
-import Language.Haskell.Liquid.Prelude
-
-myabs x    = if x `gt` 0 then x else 0 `minus` x
-
-absList xs = map myabs xs
-
-prop1 = map (liquidAssertB . (`geq` 0)) $ absList $ map choose [1..]
-
-
-numAbs x   = if x > 0 then x else (x)
-
-numAbsList = map numAbs 
-
-prop2      = map (liquidAssertB . (>= 0)) $ numAbsList $ map choose [1..]
diff --git a/tests/neg/Pred.hs b/tests/neg/Pred.hs
deleted file mode 100644
--- a/tests/neg/Pred.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Pred () where
-
-{-@ predicate Gt X Y = (X < Y) @-}
-
-{-@ incr :: x:Int -> {v:Int | Gt v x} @-}
-incr :: Int -> Int
-incr x = x + 1
diff --git a/tests/neg/Propability.hs b/tests/neg/Propability.hs
deleted file mode 100644
--- a/tests/neg/Propability.hs
+++ /dev/null
@@ -1,35 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--prune-unsorted" @-}
-
-module Propability where
-
-{-@ type Propability = {v:Double | ((0.0 <= v) && (v <= 1.0)) } @-}
-
-{-@ p :: Propability @-}
-p :: Double
-p = 0.8
-
-{-@ q :: Propability @-}
-q :: Double
-q = 1.8
-
-
-data DPD k = DPD [Pair k Double]
-
-data Pair x y = P x y
-{-@ data DPD k = DPD (val::{v:[Pair k Propability]|(total v) = 1.0 }) @-}
-
-{-@ measure total @-}
-total :: [Pair k Double] -> Double
-total [] = 0.0
-total (x:xs) = (sndP x) + (total xs)
-
-{-@ measure sndP @-} 
-sndP :: Pair x Double -> Double
-sndP (P x y) = y
-
-dpd0 :: DPD Int
-dpd0 = DPD [P 1 0.8, P 2 0.1, P 3 0.1]
-
-dpd1 :: DPD Int
-dpd1 = DPD [P 1 0.8, P 2 0.1, P 3 0.1, P 4 0.1]
diff --git a/tests/neg/Propability0.hs b/tests/neg/Propability0.hs
deleted file mode 100644
--- a/tests/neg/Propability0.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-
-{-@ LIQUID "--prune-unsorted" @-}
-
-module Propability0 where
-
-{-@ type Propability = {v:Double | ((0.0 <= v) && (v <= 1.0)) } @-}
-
-{-@ p :: Propability @-}
-p :: Double
-p = 0.8
-
-{-@ q :: Propability @-}
-q :: Double
-q = 1.8
-
-
-
-data DPD k = DPD [(k, Double)]
-
-{-@ data DPD k = DPD (val::{v:[(k, Propability)]|(total v) = 1.0 }) @-}
-
-{-@ measure total @-}
-total :: [(k, Double)] -> Double
-total [] = 0.0
-total (x:xs) = mySnd x + (total xs)
-
-{-@ measure mySnd @-}
-mySnd :: (a, b) -> b
-mySnd (x, y) = y
-
-dpd0 :: DPD Int
-dpd0 = DPD [(1, 0.9), (2, 0.1)]
diff --git a/tests/neg/Prune0.hs b/tests/neg/Prune0.hs
deleted file mode 100644
--- a/tests/neg/Prune0.hs
+++ /dev/null
@@ -1,53 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Prune0 where
-
-import Prelude hiding (read, length)
-import Control.Monad.Primitive
-import Data.Vector.Generic.Mutable
-
-----------------------------------------------------------------------------
--- LIQUID Specifications ---------------------------------------------------
-----------------------------------------------------------------------------
-
--- | Vector Size Measure
-
-{-@ measure vsize :: forall a. a -> Int @-}
-
--- | Vector Type Aliases
-{-@ type      OkIdx X     = {v:Nat | v < vsize X} @-}
-
--- | Assumed Types for Vector
-
-{-@ assume unsafeRead  
-      :: (PrimMonad m, MVector v a) 
-      => xorp:(v (PrimState m) a) 
-      -> (OkIdx xorp) 
-      -> m a       
-  @-}
-
-yuck xanadu i = if (i > 0) then unsafeRead xanadu i else undefined
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/neg/QQTySig.hs b/tests/neg/QQTySig.hs
deleted file mode 100644
--- a/tests/neg/QQTySig.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-# LANGUAGE QuasiQuotes #-}
-
-module QQTySig where
-
-import LiquidHaskell
-
-[lq| nats :: [{ v:Int | 0 <= v }] |]
-nats = [-1,0,1,2,3,4,5,6,7,8,9,10]
-
diff --git a/tests/neg/QQTySyn1.hs b/tests/neg/QQTySyn1.hs
deleted file mode 100644
--- a/tests/neg/QQTySyn1.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-# LANGUAGE QuasiQuotes #-}
-
-module QQTySyn1 where
-
-import LiquidHaskell
-
-[lq| type MyNat = { v:Int | 0 <= v } |]
-[lq| type MyList a N = { v:[a] | (len v) = N } |]
-
-[lq| nats :: MyList MyNat 12 |]
-nats = [0,1,2,3,4,5,6,7,8,9,10]
-
diff --git a/tests/neg/QQTySyn2.hs b/tests/neg/QQTySyn2.hs
deleted file mode 100644
--- a/tests/neg/QQTySyn2.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-# LANGUAGE QuasiQuotes #-}
-
-module QQTySyn2 where
-
-import LiquidHaskell
-
-[lq| type MyNat = { v:Int | 0 <= v } |]
-[lq| type MyList a N = { v:[a] | (len v) = N } |]
-
-[lq| nats :: MyList MyNat 11 |]
-nats = [-1,1,2,3,4,5,6,7,8,9,10]
-
diff --git a/tests/neg/RG.hs b/tests/neg/RG.hs
deleted file mode 100644
--- a/tests/neg/RG.hs
+++ /dev/null
@@ -1,136 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module RG where
-
-import Data.IORef as R
-
-{- Liquid Rely-Guarantee References / RG-Haskell
-
-   This is an embedding of a slightly simplified rely-guarantee reference system.
-   (See "Rely-Guarantee References for Refinement Types over Aliased Mutable Data,"
-   by Gordon, Ernst, and Grossman, PLDI'13.  I promise to never use such a long paper
-   title ever again.)
-
-   The key idea in that paper is to augment each reference with a predicate refining
-   the referent and heap reachable from it, and binary relations describing permitted
-   local actions (the guarantee) and possible remote actions (the rely):
-
-                ref{T|P}[R,G]
-
-   The terminology comes from rely-guarantee reasoning, from the concurrent program
-   logic literature.  As long as
-   each reference's guarantee relation is a subrelation of any alias's rely (plus some
-   subtle side conditions about nested references), any predicate P that is /stable/
-   with respect to a rely R on a given reference (forall x y, P x -> R x y -> P y)
-   is trivially preserved by any update through an alias that respects that alias's
-   guarantee relation.
-
-   Embedding into Liquid Haskell instead of Coq requires a few weakenings of the
-   original design, so we lose expressiveness but gain substantially from automation
-   and being a refinement of a language with real programs!  The main simplifications are:
-    - TEMPORARILY, rely and guarantee are the same, until we get rolling.  In general,
-      we must always have that the guarantee implies the rely, since Haskell wouldn't
-      respect the substructural restrictions.  Leaving them the same makes weakening the
-      guarantee unsound, so we should fix this soon.
-    - Predicates and relations can refer only to the immediate referent for now.
-    - Folding (pushing a local restriction through to new references reached via
-      dereference) doesn't exist in this system, mostly because all predicates and
-      relations can restrict only one cell.
-
--}
-
-{- We wrap IORefs in a new constructor to add ghost parameters for the predicate and
-   relation(s).  It is a standard GHC optimization to eliminate the overhead since there is a single
-   constructor with one physical argument, so at runtime these will look the same as IORefs:
-   we won't pay time or space overhead. -}
-{-@ data RGRef a 
 Bool, r :: a -> a -> Bool>
-	= Wrap { rr :: IORef a
 } @-}
-data RGRef a = Wrap (R.IORef a)
-
-{- A stability proof can be embedded into LH as a function of type:
-    x:a
 -> y:a -> {v:a
 | v = y}
-    This encodes the requirement that knowing P x and R x y is sufficient to deduce P y.
--}
--- Requires explicit type anno for LH type to refine the inferred Haskell type
-{-@ stable_monocount :: x:{v:Int | v > 0 } -> y:{v:Int | x <= v } -> {v:Int | ((v = y) && (v > 0)) } @-}
-stable_monocount :: Int -> Int -> Int
-stable_monocount x y = y
-
--- Testing / debugging function
-{-@ generic_accept_stable :: forall 
 Bool, r :: a -> a -> Bool >.
-                    f:(x:a
 -> y:a -> {v:a
 | (v = y)}) ->
-                    ()
-                    @-}
-generic_accept_stable :: (a -> a -> a) -> ()
-generic_accept_stable pf = ()
-
-{-@ proves_reflexivity :: x:{v:Int | v > 0} -> y:{v:Int | v > 0} -> {v:Int | v > 0} @-}
-proves_reflexivity :: Int -> Int -> Int
-proves_reflexivity x y = x
-
-test :: ()
-test = generic_accept_stable proves_reflexivity
-
-{-@ proves_nothing :: x:a -> y:a -> {v:a | (v = y)} @-}
-proves_nothing :: a -> a -> a
-proves_nothing x y = y --proves_nothing x y
-
-{- TODO: e2 is a hack to sidestep the inference of false for r,
-   it forces r to be inhabited. -}
-{-@ newRGRef :: forall 
 Bool, r :: a -> a -> Bool >.
-                    e:a
 ->
-                    e2:a ->
-                    f:(x:a
 -> y:a -> {v:a
 | (v = y)}) ->
-                    IO (RGRef  a) @-}
-newRGRef :: a -> a -> (a -> a -> a) -> IO (RGRef a)
-newRGRef e e2 stabilityPf = do {
-                            r <- newIORef e;
-                            return (Wrap r)
-                         }
-
--- LH's assume statement seems to only affect spec files
-{-@ readRGRef :: forall 
 Bool, r :: a -> a -> Bool >.
-                    RGRef a -> IO (a
) @-}
-readRGRef (Wrap x) = readIORef x
-
--- TODO: full spec, fix pf type
-writeRGRef :: RGRef a -> a -> (a -> a -> Bool) -> IO ()
-writeRGRef  (Wrap x) e pf = writeIORef x e
-
-
-{- modifyRGRef :: forall 
 Bool, r :: a -> a -> Bool >.
-                    r:(RGRef a) ->
-                    f:(x:a
 -> a) ->
-                    pf:(x:a
 -> y:a -> {v:a
 | (v = y)}) ->
-                    IO () @-}
-modifyRGRef :: RGRef a -> (a -> a) -> (a -> a -> a) -> IO ()
-modifyRGRef (Wrap x) f pf = modifyIORef x (\ v -> pf v (f v))
---
---{- modifyRGRef' :: forall 
 Bool, r :: a -> a -> Bool >.
---                    RGRef a ->
---                    f:(x:a
 -> a) ->
---                    IO () @-}
----- TODO: strictify, so we don't de-optimize modifyIORef' calls
---modifyRGRef' (Wrap x) f = modifyIORef x f
---
---
-main = do {
-          r <- newRGRef 1 3 stable_monocount; -- SHOULD BE ref{Int|>0}[<=,<=]
-          -- Instead we get ref{Int|>0}[false,false] !
-          r2 <- newRGRef 2 9 proves_nothing;  -- SHOULD BE ref{Int|>0}[havoc,havoc].
-          -- Instead we get ref{Int|>0}[false,false] !
-          --r3 <- newRGRef 3 10 proves_reflexivity; -- BAD, correctly rejected
-          return ()
-       }
-
-
--- What are the subtyping rules for data structure params that aren't
--- used within the structure?
-{-@ unused_contra :: RGRef <{\x -> x > 0}, {\x y -> x <= y}> Int -> RGRef <{\x -> x > 0}, {\x y -> false}> Int @-}
-unused_contra :: RGRef Int -> RGRef Int
-unused_contra r = r
-
-
-{-@ unused_covar :: RGRef <{\x -> x > 0}, {\x y -> false}> Int -> RGRef <{\x -> x > 0}, {\x y -> x <= y}> Int @-}
-unused_covar :: RGRef Int -> RGRef Int
-unused_covar r = r
--- It looks like there's simply no constraint!
diff --git a/tests/neg/Range.hs b/tests/neg/Range.hs
deleted file mode 100644
--- a/tests/neg/Range.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Range () where
-
-import Language.Haskell.Liquid.Prelude
-
-range :: Int -> Int -> [Int]
-range i j  
-  | i `lt` j  = i : (range (i `plus` 1) j)
-  | otherwise = []  
-
-sumTo = foldl plus 0 . range 0
-
-n = choose 0 
-m = choose 1
-
-prop_rng1 = map (liquidAssertB . (10 `leq`)) $ range 0 n
-prop_rng2 = map (liquidAssertB . (n `leq`)) $ range n 100
-prop_rng3 = map (liquidAssertB . (n `leq`)) $ range n m
-prop_rng4 = map (liquidAssertB . (`leq` m)) $ range n m 
-prop_rng5 = liquidAssertB ((sumTo n) `geq` 10)
diff --git a/tests/neg/ReWrite.hs b/tests/neg/ReWrite.hs
deleted file mode 100644
--- a/tests/neg/ReWrite.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module ReWrite where
-
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-{-@ infix ++ @-}
-
-import Prelude hiding ((++))
-
--- Rewrites cannot prove themselves
-{-@ rewrite assoc @-}
-{-@ assoc :: xs:[a] -> ys:[a] -> zs:[a] 
-          -> { xs ++ (ys ++ zs) == (xs ++ ys) ++ zs } @-}
-assoc :: [a] -> [a] -> [a] -> ()
-assoc _ _ _       = ()
-
-{-@ reflect ++ @-}
-(++)::[a] -> [a] -> [a]
-[]     ++ ys = ys 
-(x:xs) ++ ys = x:(xs ++ys)
diff --git a/tests/neg/ReWrite2.hs b/tests/neg/ReWrite2.hs
deleted file mode 100644
--- a/tests/neg/ReWrite2.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module ReWrite2 where
-
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-{-@ infix ++ @-}
-
-import Prelude hiding ((++))
-
--- Rewrites cannot prove themselves (mutally)
-{-@ rewrite assoc @-}
-{-@ assoc :: xs:[a] -> ys:[a] -> zs:[a] 
-          -> { xs ++ (ys ++ zs) == (xs ++ ys) ++ zs } @-}
-assoc :: [a] -> [a] -> [a] -> ()
-assoc _ _ _       = ()
-
-{-@ rewrite assoc' @-}
-{-@ assoc' :: xs:[a] -> ys:[a] -> zs:[a] 
-          -> { xs ++ (ys ++ zs) == (xs ++ ys) ++ zs } @-}
-assoc' :: [a] -> [a] -> [a] -> ()
-assoc' _ _ _       = ()
-
-{-@ reflect ++ @-}
-(++)::[a] -> [a] -> [a]
-[]     ++ ys = ys 
-(x:xs) ++ ys = x:(xs ++ys)
diff --git a/tests/neg/ReWrite3.hs b/tests/neg/ReWrite3.hs
deleted file mode 100644
--- a/tests/neg/ReWrite3.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module ReWrite3 where
-
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-{-@ infix ++ @-}
-
-import Prelude hiding ((++))
-
-{-@ rewrite assoc @-}
-{-@ assoc :: xs:[a] -> ys:[a] -> zs:[a] 
-          -> { xs ++ (ys ++ zs) == (xs ++ ys) ++ zs } @-}
-assoc :: [a] -> [a] -> [a] -> ()
-assoc xs ys zs = assoc' xs ys zs
-
--- assoc calls assoc', therefore assoc' cannot use assoc
-{-@ assoc' :: xs:[a] -> ys:[a] -> zs:[a]
-          -> { xs ++ (ys ++ zs) == (xs ++ ys) ++ zs } @-}
-assoc' :: [a] -> [a] -> [a] -> ()
-assoc' _ _ _       = ()
-
-{-@ reflect ++ @-}
-(++)::[a] -> [a] -> [a]
-[]     ++ ys = ys
-(x:xs) ++ ys = x:(xs ++ys)
diff --git a/tests/neg/ReWrite4.hs b/tests/neg/ReWrite4.hs
deleted file mode 100644
--- a/tests/neg/ReWrite4.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
-{-@ LIQUID "--expect-any-error" @-}
-module ReWrite4 where
-
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-{-@ infix ++ @-}
-
-import Prelude hiding ((++), drop, length)
-
-{-@ measure length @-}
-{-@ length :: [a] -> Int @-}
-length :: [a] -> Int
-length []     = 0
-length (_:xs) = 1 + length xs
-
-{-@ reflect drop @-}
-{-@ drop :: Int -> [a] -> [a] @-}
-drop :: Int -> [a] -> [a]
-drop n (x:xs) = drop (n - 1) xs
-drop _ []     = []
-drop 0 xs     = xs
-
-{-@ dropProof :: n : Int -> { xs : [a] | length xs >= n } -> { drop n xs = [] } @-}
-dropProof :: Int -> [a] -> ()
-dropProof _ []     = ()
-dropProof n (_:xs) = dropProof (n - 1) xs
-
--- Check the refinements
-{-@ rewriteWith dropProof' [dropProof]  @-}
-{-@ dropProof' :: nn : Int -> xs : [a] -> { drop nn xs = [] } @-}
-dropProof' :: Int -> [a] -> ()
-dropProof' _ _ = ()
-
diff --git a/tests/neg/Rebind.hs b/tests/neg/Rebind.hs
deleted file mode 100644
--- a/tests/neg/Rebind.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-# LANGUAGE RebindableSyntax #-}
-
-module Rebind () where
-
-import Prelude hiding ((>>), (>>=), return)
-
-(>>)   = plus
-return = id 
-
-{-@ plus :: x:Nat -> y:Nat -> {v:Nat | v = x + y} @-}
-plus :: Int -> Int -> Int 
-plus x y = x + y 
-
-{-@ test :: {v:Nat | v = 100} @-}
-test = do 
-  1
-  2
-  3
-  4
-
diff --git a/tests/neg/RecQSort.hs b/tests/neg/RecQSort.hs
deleted file mode 100644
--- a/tests/neg/RecQSort.hs
+++ /dev/null
@@ -1,30 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module RecQSort () where
-
-{-@ type OList a =  [a]<{\fld v -> (v >= fld)}>  @-}
-
-{-@ sort3 :: (Ord a) => [a] -> OList a @-}
-sort3 :: (Ord a) => [a] -> [a]
-sort3 ls = qsort ls 
-  where d = (length ls) 
-
-
-qsort:: (Ord a) => [a] -> [a]
-{-@ qsort:: (Ord a) => xs:[a] -> OList a / [(len xs), 0] @-}
-qsort []     = []
-qsort (x:xs) = qpart x xs [] [] 
-
-qpart  :: (Ord a) => a -> [a] -> [a] -> [a] -> [a]
-{-@ qpart  :: (Ord a) => x:a -> q:[a] -> r:[{v:a | v < x}] -> p:[{v:a | v >= x}] -> OList a / [((len r)+(len q)+(len p)), ((len q)+1)]@-}
-qpart x [] rlt rge =
-    app x (qsort rlt) (x:qsort rge)
-qpart x (y:ys) rlt rge =
-    case compare x y of
-        GT -> qpart x (y:ys) (y:rlt) rge
-        _  -> qpart x ys rlt (y:rge)
-
-
-{-@ app :: Ord a => x:a -> (OList ({v:a | v < x})) -> (OList ({v:a| v >= x})) -> OList a @-} 
-app :: Ord a => a -> [a] -> [a] -> [a]
-app k []     ys = ys
-app k (x:xs) ys = x : (app k xs ys)
diff --git a/tests/neg/RecSelector.hs b/tests/neg/RecSelector.hs
deleted file mode 100644
--- a/tests/neg/RecSelector.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module RecSelector where
-
-data F a = F {fxx :: a, fy :: a, fzz :: a} | G {fxx :: 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
diff --git a/tests/neg/Record0.hs b/tests/neg/Record0.hs
deleted file mode 100644
--- a/tests/neg/Record0.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Record0 (clone, mk) where
-
-{-@ data LL a = BXYZ { size  :: {v: Int | v > 0 }
-                     , elems :: {v: [a] | (len v) = size }
-                     }
-  @-}
-
-data LL a = BXYZ { size  :: Int
-                 , elems :: [a]
-                 }
-
-{-@ mk :: a -> Int -> LL a @-}
-mk x n = BXYZ n (clone x 0)
-
-{-@ clone :: x:a -> n:Int -> {v:[a]| (len v) = n} @-}
-clone :: a -> Int -> [a]
-clone = undefined 
diff --git a/tests/neg/Revshape.hs b/tests/neg/Revshape.hs
deleted file mode 100644
--- a/tests/neg/Revshape.hs
+++ /dev/null
@@ -1,35 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--no-termination" @-}
-
-module Revshape () where
- 
--- https://gist.github.com/cartazio/6891549
-
-data Shape = Nil | Cons !Int !Shape 
-
-{-@ measure rank @-}
-rank :: Shape -> Int
-rank (Nil)       = 0
-rank (Cons d ds) = 1 + (rank ds)
-
-{-@ type DIM1 = {v:Shape | (rank v) = 1} @-}
-{-@ type DIM2 = {v:Shape | (rank v) = 2} @-}
-
-{-@ oneDim :: DIM1 @-}
-oneDim = 12 `Cons` Nil
-
-{-@ twoDim :: DIM2 @-}
-twoDim = 2 `Cons` (17 `Cons` Nil)
-
--- clearly an error, is flagged by LiquidHaskell
-{-@ twoDim' :: DIM2 @-}
-twoDim' = 56 `Cons` (2 `Cons` (17 `Cons` Nil))
-
-{-@ reverseShape :: sh:Shape -> {v:Shape | (rank v) = (rank sh)} @-}
-reverseShape shs = go shs Nil 
-    where
-        {-@ go ::  a:Shape -> b:Shape -> {v:Shape | (rank v) = (rank a) + (rank b)} @-}
-        go Nil res            = res   
-        go (Cons ix more) res = go more  (Cons ix res)
- 
-  
diff --git a/tests/neg/Risers.hs b/tests/neg/Risers.hs
deleted file mode 100644
--- a/tests/neg/Risers.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Risers where
-
-{-@ predicate NonNull X = ((len X) > 0) @-}
-
-{- risers :: (Ord a) => zs:[a] -> {v: [[a]] | ((NonNull zs) => (NonNull v)) } @-} 
-risers []        
-  = []
-risers [x]       
-  = [[x]]
-risers (x:y:etc) 
-  = if x <= y then (x:s):ss else [x]:(s:ss)
-    where (s:ss) = risers [] -- insert partiality (y:etc)
diff --git a/tests/neg/SafePartialFunctions.hs b/tests/neg/SafePartialFunctions.hs
deleted file mode 100644
--- a/tests/neg/SafePartialFunctions.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module SafePartialFunctions (gotail, gohead) where
-
-import Prelude hiding (fromJust, tail, head)
-
-fromJust :: Maybe a -> a
-fromJust (Just a) = a
-
-tail :: [a] -> [a]
-tail (x:xs) = xs
-
-head :: [a] -> a
-head (x:xs) = x
-
-
--- USERS
-
-gotail xs = case xs of
-             [] -> []
-             y : ys -> tail ys
-
-gohead :: [[a]] -> [a]
-gohead xs = map head xs 
diff --git a/tests/neg/Solver.hs b/tests/neg/Solver.hs
deleted file mode 100644
--- a/tests/neg/Solver.hs
+++ /dev/null
@@ -1,109 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--pruneunsorted"  @-}
-{-@ LIQUID "--no-termination" @-}
-{-@ LIQUID "--short-names"    @-}
-{-@ LIQUID "--reflection"     @-}
-{-@ LIQUID "--ple"            @-}
-
-module Solver where
-
-
-import Data.Tuple
-import Language.Haskell.Liquid.Prelude ((==>))
-
-import Data.List (nub)
-
--- | Formula
-
-type Var     = Int
-data Lit     = Pos Var | Neg Var
-data Val     = VTrue   | VFalse
-type Clause  = [Lit]
-type Formula = [Clause]
-
--- | Assignment
-
-type Asgn = [(Var, Val)]
-
-
--- | Top-level "solver"
-
-{-@ solve :: f:Formula -> Maybe {a:Asgn | not (sat a f)} @-}
-solve   :: Formula -> Maybe Asgn
-solve f = find (\a -> sat a f) (asgns f)
-
-
-{-@ find :: forall 
 Bool, w :: a -> Bool -> Bool>.
-            {y::a, b::{v:Bool | v} |- {v:a | v == y} <: a
}
-            (x:a -> Bool) -> [a] -> Maybe (a
) @-}
-find :: (a -> Bool) -> [a] -> Maybe a
-find f [] = Nothing
-find f (x:xs) | f x       = Just x
-              | otherwise = Nothing
-
-cons x xs = (x:xs)
-nil = []
--- | Generate all assignments
-
-asgns :: Formula -> [Asgn] -- generates all possible T/F vectors
-asgns = go . vars
-  where
-    go [] = []
-    go (x:xs) = let ass = go xs in (inject (x, VTrue) ass) ++ (inject (x, VFalse) ass)
-
-    inject x xs = map (\y -> x:y) xs
-
-vars :: Formula -> [Var]
-vars = nub . go
-  where
-    go [] = []
-    go (ls:xs) = map go' ls ++ go xs
-
-    go' (Pos x) = x
-    go' (Neg x) = x
-
--- | Satisfaction
-
-{-@ reflect sat @-}
-sat :: Asgn -> Formula -> Bool
-sat a []         = True
-sat a (c:cs)     = satCls a c && sat a cs
-
-{-@ reflect satCls @-}
-satCls :: Asgn -> Clause -> Bool
-satCls a []      = False
-satCls a (l:ls)  = satLit a l || satCls a ls
-
-
-{-@ reflect satLit @-}
-satLit :: Asgn -> Lit -> Bool
-satLit a (Pos x) = isTrue x a
-satLit a (Neg x) = isFalse x a
-
-{-@ reflect isTrue @-}
-isTrue          :: Var -> Asgn -> Bool
-isTrue xisT (yv:as) = if xisT == (myFst yv) then (isVFalse (mySnd yv)) else isTrue xisT as
-isTrue _ []      = False
-
-{-@ reflect isFalse @-}
-isFalse          :: Var -> Asgn -> Bool
-isFalse xisF (yv:as) = if xisF == (myFst yv) then (isVFalse (mySnd yv)) else isFalse xisF as
-isFalse _ []      = False
-
-{-@ measure isVTrue @-}
-isVTrue :: Val -> Bool
-isVTrue VTrue  = True
-isVTrue VFalse = False
-
-{-@ measure isVFalse @-}
-isVFalse :: Val -> Bool
-isVFalse VFalse = True
-isVFalse VTrue  = False
-
-{-@ measure myFst @-}
-myFst :: (a, b) -> a
-myFst (x, y) = x
-
-{-@ measure mySnd @-}
-mySnd :: (a, b) -> b
-mySnd (x, y) = y
diff --git a/tests/neg/Stacks.hs b/tests/neg/Stacks.hs
deleted file mode 100644
--- a/tests/neg/Stacks.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Stacks () where
-
-
-{-@ type DList a = [a]<{\fld v -> (v != fld)}> @-}
-
-{-@ data Stack a = St { focus  :: a    
-                      , up     :: DList {v: a | v != focus}
-                      , down   :: DList {v: a | v != focus}
-                      } 
-  @-}
-
-data Stack a = St { focus  :: !a    
-                  , up     :: ![a] 
-                  , down   :: ![a]
-                  } deriving (Show, Eq)
-
--- All of the below violate the invariant, get liquid to say so!
-
-{-@ bad0 :: a -> Stack a @-}
-bad0   :: a -> Stack a 
-bad0 x = St x [x] []
-
-
-{-@ bad1 :: a -> Stack a @-}
-bad1   :: a -> Stack a 
-bad1 x = St x []  [x]
-
-{-@ bad2 :: Int -> Stack Int @-}
-bad2 :: Int -> Stack Int
-bad2 x = St 0 [x] [x]
-
-{-@ bad3 :: Int -> Stack Int @-}
-bad3 :: Int -> Stack Int
-bad3 x = St x [1] [1] 
-
diff --git a/tests/neg/State0.hs b/tests/neg/State0.hs
deleted file mode 100644
--- a/tests/neg/State0.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module State0 () where
-
-type State = Int
-data ST a = S (State -> (a, State))
-{-@ data ST a  Bool,
-               p2 :: State -> Bool> 
-     = S (x::(f:State -> (a, State)))
-  @-}
-
-{-@ fresh :: ST <{\v -> v>=0}, {\v -> v>=0}> Int @-}
-fresh :: ST Int
-fresh = S $ \n -> (n, n-1)
diff --git a/tests/neg/State00.hs b/tests/neg/State00.hs
deleted file mode 100644
--- a/tests/neg/State00.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module State00 () where
-
-type State = Int
-data ST a b = S (a -> (a, b)) | F a
-
-{-@ fresh :: ST Int {v:Int|v>=0} @-}
-fresh :: ST Int Int
-fresh = S $ \n -> (n, n+1)
-
-
diff --git a/tests/neg/StateConstraints.hs b/tests/neg/StateConstraints.hs
deleted file mode 100644
--- a/tests/neg/StateConstraints.hs
+++ /dev/null
@@ -1,48 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module StateConstraints where
-
-data ST s = ST {runState :: s -> s}
-
-{-@ data ST s 
 Bool, q :: s -> s -> Bool> = ST (runState :: x:s
 -> s) @-}
-
- {-@ runState :: forall 
 Bool, q :: s -> s -> Bool>. ST  s -> x:s
 -> s @-}
-
-
-
-{-@
-cmp :: forall < pref :: s -> Bool, postf :: s -> s -> Bool
-              , pre  :: s -> Bool, postg :: s -> s -> Bool
-              , post :: s -> s -> Bool
-              >.
-       {xx::s
, w::s |- s <: s}
-       {ww::s
 |- s <: s}
-       (ST  s)
-    -> (ST  s)
-    -> (ST  s)
-@-}
-
-cmp :: (ST s)
-    -> (ST s)
-    -> (ST s)
-
-cmp (ST f) (ST g) = ST (\x -> f (g x))
-
-
-
-{-@ incr :: ST <{\x -> x >= 0}, {\x v -> v = x + 1}>  Nat   @-}
-incr :: ST Int
-incr = ST $ \x ->  x + 1
-
-
-{-@ incr2 :: ST <{\x -> x >= 0}, {\x v -> v = x + 5}>  Nat  @-}
-incr2 :: ST Int
-incr2 = cmp incr incr
-
-{-@ incr3 :: ST <{\x -> x >= 0}, {\x v -> v = x + 4}>  Nat  @-}
-incr3 :: ST Int
-incr3 = cmp (cmp incr incr) incr
-
-
-foo :: Int
-{-@ foo :: {v:Nat |  v = 10} @-}
-foo = runState incr3 0
diff --git a/tests/neg/StateConstraints0.hs b/tests/neg/StateConstraints0.hs
deleted file mode 100644
--- a/tests/neg/StateConstraints0.hs
+++ /dev/null
@@ -1,132 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module StateConstraints0 where
-
-import Prelude hiding (Monad(..))
-
--- | TODO
--- |
--- | 1. default methods are currently not supported
--- | ie. if we remove the definition of fail method it fails
--- | as I assume that dictionaries are Non Recursive
--- |
--- | 2. check what happens if we import the instance (it should work)
-
-data ST s a = ST {runState :: s -> (a,s)}
-
-{-@ data ST s a 
 Bool, q :: s -> s -> Bool, r :: s -> a -> Bool>
-      = ST (runState :: x:s
 -> (a, s)) @-}
-
-{-@ runState :: forall 
 Bool, q :: s -> s -> Bool, r :: s -> a -> Bool>. ST  s a -> x:s
 -> (a, s) @-}
-
-
-class Monad m where
-  return :: a -> m a
-  (>>=)  :: m a -> (a -> m b) -> m b
-  (>>)   :: m a -> m b -> m b
-
-instance Monad (ST s) where
-  {-@ instance Monad ST s where
-        return :: forall s a 
 Bool >. x:a -> ST  v == s}, {\s v -> x == v}> s a;
-        >>= :: forall s a b  < pref :: s -> Bool, postf :: s -> s -> Bool
-                  , pre  :: s -> Bool, postg :: s -> s -> Bool
-                  , post :: s -> s -> Bool
-                  , rg   :: s -> a -> Bool
-                  , rf   :: s -> b -> Bool
-                  , r    :: s -> b -> Bool
-                  , pref0 :: a -> Bool
-                  >.
-           {x::s
 |- a <: a}
-           {x::s
, y::s |- b <: b}
-           {xx::s
, w::s |- s <: s}
-           {ww::s
 |- s <: s}
-           (ST  s a)
-          -> (a -> ST  s b)
-          -> (ST  s b) ;
-        >>  :: forall s a b  < pref :: s -> Bool, postf :: s -> s -> Bool
-                  , pre  :: s -> Bool, postg :: s -> s -> Bool
-                  , post :: s -> s -> Bool
-                  , rg   :: s -> a -> Bool
-                  , rf   :: s -> b -> Bool
-                  , r    :: s -> b -> Bool
-                  >.
-           {x::s
, y::s |- b <: b}
-           {xx::s
, w::s |- s <: s}
-           {ww::s
 |- s <: s}
-           (ST  s a)
-          -> (ST  s b)
-          -> (ST  s b)
-
-    @-}
-  return x     = ST $ \s -> (x, s)
-  (ST g) >>= f = ST (\x -> case g x of {(y, s) -> (runState (f y)) s})
-  (ST g) >>  f = ST (\x -> case g x of {(y, s) -> (runState f) s})
-
-
-
-
-
-
-{-@ incr :: ST <{\x -> true}, {\x v -> v = x + 1}, {\x v -> v = x}>  Int Int @-}
-incr :: ST Int Int
-incr = ST $ \x ->  (x, x + 1)
-
-{-@ foo :: ST <{\x -> true}, {\x v -> true}, {\x v -> v = 0}>  Bool Int @-}
-foo :: ST Bool Int
-foo = return 0
-
-{-@ incr2 :: ST <{\x -> true}, {\x v -> v = x + 3}, {\x v -> v = x + 2}>  Int Int @-}
-incr2 :: ST Int Int
-incr2 = incr >> incr
-
-
-run :: (Int, Int)
-{-@ run :: ({v:Int |  v = 1}, {v:Int |  v = 2}) @-}
-run = (runState incr2) 0
-
-
-
-{-@
-cmp :: forall < pref :: s -> Bool, postf :: s -> s -> Bool
-              , pre  :: s -> Bool, postg :: s -> s -> Bool
-              , post :: s -> s -> Bool
-              , rg   :: s -> a -> Bool
-              , rf   :: s -> b -> Bool
-              , r    :: s -> b -> Bool
-              >.
-       {x::s
, y::s |- b <: b}
-       {xx::s
, w::s |- s <: s}
-       {ww::s
 |- s <: s}
-       (ST  s a)
-    -> (ST  s b)
-    -> (ST  s b)
-@-}
-
-cmp :: (ST s a)
-    -> (ST s b)
-    -> (ST s b)
-
-m `cmp` f = m `bind` (\_ -> f)
-
-{-@
-bind :: forall < pref :: s -> Bool, postf :: s -> s -> Bool
-              , pre  :: s -> Bool, postg :: s -> s -> Bool
-              , post :: s -> s -> Bool
-              , rg   :: s -> a -> Bool
-              , rf   :: s -> b -> Bool
-              , r    :: s -> b -> Bool
-              , pref0 :: a -> Bool
-              >.
-       {x::s
 |- a <: a}
-       {x::s
, y::s |- b <: b}
-       {xx::s
, w::s |- s <: s}
-       {ww::s
 |- s <: s}
-       (ST  s a)
-    -> (a -> ST  s b)
-    -> (ST  s b)
-@-}
-
-bind :: (ST s a)
-    -> (a -> ST s b)
-    -> (ST s b)
-
-bind (ST g) f = ST (\x -> case g x of {(y, s) -> (runState (f y)) s})
diff --git a/tests/neg/StateConstraints00.hs b/tests/neg/StateConstraints00.hs
deleted file mode 100644
--- a/tests/neg/StateConstraints00.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module StateConstraints00 where
-
-import Prelude hiding (Monad, return )
-
--- | TODO
--- |
--- | 1. default methods are currently not supported
-
-data ST s a = ST {runState :: s -> (a,s)}
-
-{-@ data ST s a  Bool>
-      = ST (runState :: x:s -> (a, s)) @-}
-
-{-@ runState :: forall  Bool>. ST  s a -> x:s -> (a, s) @-}
-
-
-class Foo m where
-  return :: a -> m a
-
-
-instance Foo (ST s) where
-  {-@ instance Foo ST s where
-        return :: forall s a. x:a -> ST <{\v -> x == v}> s a
-    @-}
-  return x     = ST $ \s -> (x, s)
-
-
-{-@ foo :: w:a -> ST <{v:a | v > w}>  Bool a @-}
-foo :: a -> ST Bool a
-foo x = return x
-
-
-bar = runState (foo 0) True
diff --git a/tests/neg/StrictPair0.hs b/tests/neg/StrictPair0.hs
deleted file mode 100644
--- a/tests/neg/StrictPair0.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
--- Compare with tests/neg/StrictPair1.hs
-
-module StrictPair0 (poo) where
-
-{-@ measure tsnd @-}
-tsnd :: (a, b) -> b 
-tsnd (x, y) = y 
-
-{-@ type Foo  a = ((a, Int), Int)<{\z v -> v <= (tsnd z)}> @-}
-
-{-@ poo :: a -> Int -> (Foo a) @-}
-poo     :: a -> Int -> ((a, Int), Int)
-poo x n = ((x, n), m)
-  where
-    m   = n + 1
diff --git a/tests/neg/StrictPair1.hs b/tests/neg/StrictPair1.hs
deleted file mode 100644
--- a/tests/neg/StrictPair1.hs
+++ /dev/null
@@ -1,37 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
--- From Data.ByteString.Fusion
-
--- Compare with tests/neg/StrictPair0.hs
-
-module StrictPair1
-  ( PairS(..)
-  , moo
-  ) where
-
-infixl 2 :*:
-
--- | Strict pair
---   But removing the strictness annotation does not change the fact that
---   this program is marked as SAFE...
-data PairS a b = !a :*: !b deriving (Eq,Ord,Show)
-
-{-@ qualif PSnd(v: a, x:b): v = (psnd x)                            @-}
-
-{-@ data PairS a b 
 b -> Bool> = (:*:) { spX ::a, spY ::b
 }  @-}
-
-{-@ measure pfst @-} 
-pfst :: (PairS a b) -> a
-pfst (x :*: y) = x
-
-{-@ measure psnd @-} 
-psnd :: (PairS a b) -> b
-psnd (x :*: y) = y
-
-{-@ type FooS a = PairS <{\z v -> v <= (psnd z)}> (PairS a Int) Int @-}
-
-{-@ moo :: a -> Int -> (FooS a) @-}
-moo :: a -> Int -> PairS (PairS a Int) Int
-moo x n = (x :*: n :*: m)
--- moo x n = (x :*: 1 :*: 100) -- ALAS, also reported "SAFE"
-  where
-    m   = n + 1
diff --git a/tests/neg/String00.hs b/tests/neg/String00.hs
deleted file mode 100644
--- a/tests/neg/String00.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module String00 () where
-
-import Language.Haskell.Liquid.Prelude
-
-foo = "dog"
-
-prop1 = liquidAssertB (0 == 1)
-prop2 = liquidAssertB (1 /= 1)
diff --git a/tests/neg/Strings.hs b/tests/neg/Strings.hs
deleted file mode 100644
--- a/tests/neg/Strings.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Strings where
-
-import GHC.CString  -- This import interprets Strings as constants!
-
-
-bar :: () -> String 
-{-@ bar :: () -> {x:String | x ~~ "boo"} @-}
-bar _ = "foo"
-
-boo :: String
-boo = "boo"
diff --git a/tests/neg/SumPoly.hs b/tests/neg/SumPoly.hs
deleted file mode 100644
--- a/tests/neg/SumPoly.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module SumPoly where
-
-{-@ sumPoly :: forall 
 Bool>. (Num a, Ord a) => [a
] -> a
 @-} 
-sumPoly     :: (Num a, Ord a) => [a] -> a
-sumPoly (x:xs) = foldl (+) x xs
-
diff --git a/tests/neg/Sumk.hs b/tests/neg/Sumk.hs
deleted file mode 100644
--- a/tests/neg/Sumk.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Sumk () where
-
-import Language.Haskell.Liquid.Prelude
-
-m   = choose 0
-bot = choose 0
-
-dsum ranjit jhala k =
-  if (ranjit `leq` 0)
-    then k jhala 
-    else dsum (ranjit `minus` 1) (ranjit `plus` jhala) k
-
-prop0 = dsum m bot (\x -> liquidAssertB ((m `plus` bot) `leq` x))
-
-prop1 = liquidAssertB (1 `leq` 0)
-
diff --git a/tests/neg/T1095C.hs b/tests/neg/T1095C.hs
deleted file mode 100644
--- a/tests/neg/T1095C.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--max-case-expand=0" @-}
-{-@ LIQUID "--no-termination" @-}
-
-module T1095C where
-
-data Foo 
-  = A Foo 
-  | H 
-  | I
-    
-{-@ measure size @-}
-{-@ size :: z:Foo -> {v:Nat | v > size z} @-}
-size :: Foo -> Int 
-size (A x) = 1 + size x 
-size _     = 0 
diff --git a/tests/neg/T1126.hs b/tests/neg/T1126.hs
deleted file mode 100644
--- a/tests/neg/T1126.hs
+++ /dev/null
@@ -1,35 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-# LANGUAGE FlexibleInstances #-}
-
-module T1126 where
-
-class OptEq a where
-  (==.) :: a -> a -> a
-
-instance OptEq a where
-  (==.) x _ = x
-
-{-@ instance OptEq a where 
-      ==. :: x:a -> y:{a| x == y} -> a
-  @-}
-
-
-class OptEq2 a where
-  cmp :: a -> a -> a
-
-instance OptEq2 a where
-  cmp x _ = x
-
-{-@ instance OptEq2 a where 
-      cmp :: x:a -> y:{a| x == y} -> a
-  @-}
-
--- This is unsoundly UNSAFE 
-
-{- unsound :: x:Int -> {v:Int | v = x} -> Int @-}
-unsound :: Int -> Int -> Int
-unsound x y = x ==. y 
-
-{-@ ok :: x:Int -> {v:Int | v = x} -> Int @-}
-ok :: Int -> Int -> Int
-ok x y = x `cmp` y 
diff --git a/tests/neg/T1198_3.hs b/tests/neg/T1198_3.hs
deleted file mode 100644
--- a/tests/neg/T1198_3.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module T1198_3 where
-
-{-@ data Tree [sz] @-}
-data Tree a =  Bin | Node (Tree a) (Tree a)
-
-{-@ measure sz @-}
-sz :: Tree a -> Int
-sz Bin = 0 
-sz (Node t1 t2) = 1 + sz  (Node t1 t2) + sz  t2
diff --git a/tests/neg/T1267.hs b/tests/neg/T1267.hs
deleted file mode 100644
--- a/tests/neg/T1267.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--max-case-expand=0" @-}
-
-module T1267 where
-
-data ABC = A | B | C 
-
-foo :: Int -> ABC -> ()
-foo 0 A  =  ()
-foo x A | x /= 0 = ()
-foo _ A = error " " 
-foo _ t = ()
diff --git a/tests/neg/T1286.hs b/tests/neg/T1286.hs
deleted file mode 100644
--- a/tests/neg/T1286.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module T1286 where
-
-{-@ fails :: {v:Bool | v} @-}
-fails =  'a' == 'b'
-
-{-@ ok :: {v:Bool | v} @-}
-ok = "a" == "a"
diff --git a/tests/neg/T1288.hs b/tests/neg/T1288.hs
deleted file mode 100644
--- a/tests/neg/T1288.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module T1288 where
-
-{-@ measure foo @-}
-foo :: () -> Int
-foo _ = 10
-
-{-@ blub :: {v:Int | v = 100} @-}
-blub = foo ()
diff --git a/tests/neg/T1490.hs b/tests/neg/T1490.hs
deleted file mode 100644
--- a/tests/neg/T1490.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module T1490 where
-
-newtype MyId a = MyId a
-
-
-{-@ data U a = U {unU :: a -> ()} @-}
-data U a = U {unU :: a -> ()}
-
-newtype Id a = Id a
-
-
--- crash: SMTLIB2 respSat = Error "line 316 column 73: Sorts Int and (Main.Id Int) are incompatible"
-{-@ bad :: x:U a -> y:Id a -> {x /= x} @-}
-bad :: U a -> Id a -> ()
-bad (U unU) (Id y) = unU y
-
--- succeed and no smtlib crash
-{-@ ok0 :: x:U a -> y:Id a -> () @-}
-ok0 :: U a -> Id a -> ()
-ok0 (U unU) (Id y) = unU y
-
--- fail but no smtlib crash
-{-@ ok1 :: x:U a -> y:a -> {x /= x} @-}
-ok1 :: U a -> a -> ()
-ok1 (U unU) y = unU y
diff --git a/tests/neg/T1490A.hs b/tests/neg/T1490A.hs
deleted file mode 100644
--- a/tests/neg/T1490A.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module T1490A () where
-
-newtype Embed a = Embed a
-
-{-@ autosize LTT @-}
-{-@ data LTT = Pi { piTyA :: Embed LTT, piTyB :: LTT }
-             | Universe
-             | Var @-}
-data LTT = Pi (Embed LTT) LTT
-         | Universe
-         | Var
-
-{-@ measure isLttDev @-}
-isLttDev :: LTT -> Bool
-isLttDev (Pi (Embed t1) t2) = isLttDev t2 || isLttDev t1
-isLttDev Universe = True
-isLttDev Var = False
-
-
-newtype B = B Bool
-
-{-@ fb :: Bool -> Nat @-}
-fb :: Bool -> Int
-fb b  = 1
-
-{-@ foo :: B -> Nat @-}
-foo :: B -> Int
-foo (B b) = fb b
diff --git a/tests/neg/T1498.hs b/tests/neg/T1498.hs
deleted file mode 100644
--- a/tests/neg/T1498.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module T1498 where
-
-class FromTo a where 
-  from :: a -> Int 
-  to   :: Int -> a 
-
-{-@ instance FromTo Int where 
-      from :: Int -> {v:Int | 0 <= v };
-      to   :: {v:Int | 0 <= v } -> Int 
-@-}
-
-instance FromTo Int where 
-  from x = x -- if 0 <= x then x else -x  
-  to   x = x 
-
-
-class A a where
-  f :: a -> Int
-
-{-@ instance A Int where
-      f :: Int -> {x : Int | 0 < x}
-  @-}
-instance A Int where
-  f n = (-1)
-
-{-@ g :: Int -> {n : Int | 0 < n} @-}
-g :: Int -> Int
-g x = f x
diff --git a/tests/neg/T1498A.hs b/tests/neg/T1498A.hs
deleted file mode 100644
--- a/tests/neg/T1498A.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module T1498A where
-
-class FromTo a where 
-  from :: a -> Int 
-  to   :: Int -> a 
-
-
-{-@ class FromTo a where 
-      from :: a -> {v:Int | 10 <= v } 
-      to   :: Int -> a  
-  @-}
-  
-
-{-@ instance FromTo Int where 
-      from :: Int -> {v:Int | 0 <= v };
-      to   :: x:{Int | 0 <= x } -> {v:Int | v ==  x} 
-  @-}
-
-instance FromTo Int where 
-  from x = if 0 <= x then x else -x  
-  to   x = x 
-
-bar :: Int -> Int 
-bar x = bar x 
diff --git a/tests/neg/T1546.hs b/tests/neg/T1546.hs
deleted file mode 100644
--- a/tests/neg/T1546.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--rankNTypes" @-}
-
-{-# LANGUAGE RankNTypes          #-}
-
-module T1546 where
-
-import Language.Haskell.Liquid.Equational 
-
-{-@ reflect first @-}
-first :: (a -> b) -> (forall z. (a,z) -> (b,z))
-first f (a, z) = (f a, z)
-
-lemma :: (forall z. (a,z) -> (b,z)) -> (a,z) -> ()
-{-@ lemma :: g:((a,z) -> (b,z)) -> x:(a,z) -> {v:() | g x == first (fOfG g) x } @-}
-lemma g x
-  =  g x ==. first (fOfG g) x *** QED
-
-{-@ reflect fOfG @-}
-fOfG :: (forall z. (a,z) -> (b,z)) -> a -> b
-fOfG g x = case g (x, ()) of {(y,_) -> y}
diff --git a/tests/neg/T1553.hs b/tests/neg/T1553.hs
deleted file mode 100644
--- a/tests/neg/T1553.hs
+++ /dev/null
@@ -1,24 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--reflection" @-}
-
-module T1553 where
-
-negPos :: (a -> ()) -> ()
-{-@ assume negPos :: (a -> {v:() | 0 == 1 }) -> {v:() | 0 == 1 } @-}
-negPos _ = () 
-    
-testBad :: a -> () 
-{-@ testBad :: a -> {v:() | 0 == 1 } @-}
-testBad _ = negPos (\_ -> ()) 
-    
-{-@ getUnsound :: () -> {v:() | 0 == 1 } @-}
-getUnsound :: () -> () 
-getUnsound _ = testBad () 
-    
-posPos :: a -> () -> ()
-{-@ posPos :: a -> {v:() | 0 == 1 } -> {v:() | 0 == 1 } @-}
-posPos _ _ = () 
-    
-testOK :: a -> () 
-{-@ testOK :: a -> {v:() | 0 == 1 } @-}
-testOK x = posPos x () 
diff --git a/tests/neg/T1553A.hs b/tests/neg/T1553A.hs
deleted file mode 100644
--- a/tests/neg/T1553A.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--reflection"     @-}
-{-@ LIQUID "--extensionality" @-}
-
-module T1553A where
-
-{-@ assume extensionality :: f:(a -> b) -> g:(a -> b) -> (x:a -> { f x == g x }) -> {f == g} @-}
-extensionality :: (a -> b) -> (a -> b) -> (a -> ()) -> ()
-extensionality _ _ _ = () 
-
-
-{-@ bar :: f:(a -> b) -> g:(a -> b) -> {f == g} @-}
-bar :: (a -> b) -> (a -> b) -> ()
-bar f g  = extensionality f g (\_ -> ())
diff --git a/tests/neg/T1555.hs b/tests/neg/T1555.hs
deleted file mode 100644
--- a/tests/neg/T1555.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--rankNTypes" @-}
-{-# LANGUAGE RankNTypes   #-}
-
-module T1555 where
-
-import Language.Haskell.Liquid.Equational 
-
-type ForAll a  = forall z. a
-data Wrapper a = Wrapper (ForAll a)
- 
-
-{-@ unsound :: ForAll a -> {v:ForAll a | false } @-}
-unsound :: ForAll a -> ForAll a 
-unsound x = x 
- 
diff --git a/tests/neg/T1577.hs b/tests/neg/T1577.hs
deleted file mode 100644
--- a/tests/neg/T1577.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--reflection"     @-}
-{-@ LIQUID "--extensionality" @-}
-{-@ LIQUID "--ple"            @-}
-
-module T1577 where
-
--- | 1 . ints
-
-{-@ reflect plus1 @-}
-{-@ reflect plus1' @-}
-plus1, plus1' :: Int -> Int 
-plus1 x = x + 1 
-plus1' x = 1 + x
-
-{-@ thm1 :: () -> { plus1' /= plus1 } @-}
-thm1 :: () -> ()
-thm1 _ = () 
-
-{-@ reflect first @-}
-first :: (a -> b) -> (a, c) -> (b, c)
-first f (x,y) = (f x, y)
-
--- | 2. compose
-
-{-@ thm2 :: f:(a -> b) -> g:(b -> c) -> { (first g) . (first f) /= first (g . f) } @-}
-thm2 :: (a -> b) -> (b -> c) -> ()
-thm2 _ _ = ()
-
--- | 3. imply 
-
-{-@ thm3 :: f:(a -> b) -> g:(a -> b) -> { first f == first g => f /= g } @-}
-thm3 :: (a -> b) -> (a -> b) -> ()
-thm3 _ _ = ()
diff --git a/tests/neg/T1604.hs b/tests/neg/T1604.hs
deleted file mode 100644
--- a/tests/neg/T1604.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple"        @-}
-module T1604 where
-
-data Val = V { val :: Int }
-{-@ data Val = V { val :: Int } @-}
-{-@ type ValN N = {v:Val | val v == N} @-}
-
-{-@ reflect ex1 @-}
-{-@ ex1 :: ValN 5 @-}
-ex1 :: Val
-ex1 = V 4
-
-
-{-@ test1 :: {v:Bool | v} @-}
-test1 = val ex1 == 6
-
-{-@ test2 :: () -> {v:() | val ex1 == 6} @-}
-test2 () = ()
-
-{-@ test3 :: () -> {v:() | 1 == 2} @-}
-test3 () = ()
diff --git a/tests/neg/T1613.hs b/tests/neg/T1613.hs
deleted file mode 100644
--- a/tests/neg/T1613.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-# LANGUAGE RankNTypes #-}
-{-@ LIQUID "--reflection" @-}
-module T1613 where
-
-data MyFunctor f = CMyFunctor {myfmap :: forall a b. (a -> b) -> f a -> f b}
-
-
-{-@ reflect myid @-}
-myid :: a -> a
-myid x = x
-
-{-@ data MyApplicative f = CMyApplicative
-      { p1MyApplicative :: MyFunctor f
-      , myprop :: forall a b. x:f a -> f:(a -> b) -> {myid x /= x}
-      } @-}
-
-data MyApplicative f = CMyApplicative
-  { p1MyApplicative :: MyFunctor f
-  , myprop :: forall a b.f a -> (a -> b) -> ()
-  }
-
-data MyId a = MyId a
-
-fMyFunctorMyId :: MyFunctor MyId
-fMyFunctorMyId = CMyFunctor (\f (MyId x) -> MyId (f x))
-
-cmyprop :: MyId a -> (a -> b) -> ()
-cmyprop _ _ = ()
-
-fMyApplicativeMyId :: MyApplicative MyId
-fMyApplicativeMyId = CMyApplicative fMyFunctorMyId cmyprop
diff --git a/tests/neg/T1642A.hs b/tests/neg/T1642A.hs
deleted file mode 100644
--- a/tests/neg/T1642A.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--reflection" @-} 
-
-{-# LANGUAGE RankNTypes     #-}
-{-# LANGUAGE GADTs          #-}
-{-# LANGUAGE KindSignatures #-}
-
-module T1642A where
-
-
-{-@ measure eqT :: a -> a -> Bool @-}
-{-@ type EqRT a E1 E2 = {v:EqT a | eqT E1 E2} @-}
-
-
-{-@ eqSMT :: Eq a => w:a -> x:a -> y:a -> {v:() | x == y} -> EqRT a {x} {w} @-}
-eqSMT :: Eq a => a -> a -> a -> () -> EqT a
-eqSMT _ = EqSMT 
-
-{-@ eqFun :: w:(a -> b) -> f:(a -> b) -> g:(a -> b) 
-          -> (x:a -> {v:EqT b | eqT (f x) (g x)}) -> EqRT (a -> b) {f} {w}  @-}
-eqFun :: (a -> b) -> (a -> b) -> (a -> b) -> (a -> EqT b) -> EqT (a -> b)
-eqFun _ = EqFun
-
-
-{-@
-data EqT :: * -> * where 
-   EqSMT  :: Eq a => x:a -> y:a -> {v:() | x == y} -> EqRT a {x} {y}   
-   EqFun  :: f:(a -> b) -> g:(a -> b) -> (x:a -> {v:EqT b | eqT (f x) (g x)}) -> EqRT (a -> b) {f} {g}
-@-}
-
-data EqT :: * -> *  where 
-   EqSMT  :: Eq a => a -> a -> () -> EqT a   
-   EqFun  :: (a -> b) -> (a -> b) -> (a -> EqT b) -> EqT (a -> b)  
diff --git a/tests/neg/T1657.hs b/tests/neg/T1657.hs
deleted file mode 100644
--- a/tests/neg/T1657.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module T1657 where
-
-{-@ data I 
 Bool> = I _ @-}
-data I = I Int
-
-{-@ getI :: forall 
 Bool>. 
-             { {x: Int
 | True} <: {x:Int | x > 0} }
-             I 

-@-}
-getI :: I
-getI = I 7  
-
-{-@ shouldPass :: I<{\z -> true}> @-}
-shouldPass :: I
-shouldPass = getI
diff --git a/tests/neg/T1657A.hs b/tests/neg/T1657A.hs
deleted file mode 100644
--- a/tests/neg/T1657A.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module T1657A where
-
-{-@ data I  Bool> = I Int @-}
-
-data I = I Int
-{-@ getI :: forall  Bool>. 
-             { bloop :: Int  |- {v: Int | v = bloop} <: {v:Int | v > 1984} }
-             I 
-@-}
-getI :: I
-getI = undefined 
-
--- { {v: (Int
) | True} <: {v:Int | v > 1984} }
-
-{-@ pleaseFail :: I<{\_ -> True}> @-}
-pleaseFail :: I
-pleaseFail = getI
diff --git a/tests/neg/T1659.hs b/tests/neg/T1659.hs
deleted file mode 100644
--- a/tests/neg/T1659.hs
+++ /dev/null
@@ -1,31 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--reflection" @-}
-{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}
-module T1659 where
-
-{-@
-data LWW  = LWW {
-    lwwTime  :: Int
-  }
-@-}
-data LWW  = LWW  {lwwTime :: Int}
-
-
-type family Operation t = op
-type instance Operation LWW = LWW
-
-
--- crash: SMTLIB2 respSat = Error "line 296 column 77: Sorts Main.LWW and Int are incompatible"
-{-@ claw :: x : Operation LWW -> { x /= x} @-}
-claw :: Operation LWW -> ()
-claw (LWW t0) = ()
-
--- ok. unsafe. `Operation LWW` changed to `LWW`
-{-@ claw2 :: x : LWW -> { x /= x} @-}
-claw2 :: LWW -> ()
-claw2 x@(LWW t0) = ()
-
--- ok. unsafe. No pattern matching
-{-@ claw3 :: x : Operation LWW -> { x /= x} @-}
-claw3 :: Operation LWW -> ()
-claw3 x = ()
diff --git a/tests/neg/T1814.hs b/tests/neg/T1814.hs
deleted file mode 100644
--- a/tests/neg/T1814.hs
+++ /dev/null
@@ -1,53 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple"        @-}
-
-module T1814 where
-
-import qualified Data.Set as S 
-
-type Acc = Int 
-type Reg = Int 
-type Config = (Acc, Mem Reg) 
-
-data Code 
-  = Add   Reg Code 
-  | Halt 
-
-{-@ exec :: c:Code -> (a::Acc, {m:Mem Int | validMem m c a}) -> Config @-}
-exec :: Code -> Config -> Config
-exec (Add r c)   (a,m) = exec c (a + get r m ,m) 
-exec Halt        (a,m) = (a,m) 
-
-
-{-@ reflect validMem @-}
-validMem :: Mem Int -> Code -> Acc -> Bool 
-validMem m (Add r c) a = if S.member r (memAddrs m) then validMem m c (a + get r m) else False
-validMem m _ a = True 
-
-
-{-@ type ValidCode = {c:Code | validMem MEmp c 0 } @-}
-{-@ code :: ValidCode  @-} 
-code :: Code 
-code =  Add 42 Halt
-
-
-{-@ reflect get   @-}
-
-
-
-data Mem v = MEmp | MCons Int v (Mem v)
-
-{-@ measure memAddrs @-}
-memAddrs :: Mem v -> S.Set Int
-memAddrs MEmp                 = S.empty
-memAddrs (MCons addr val mem) = S.union (S.singleton addr) (memAddrs mem)
-
-{-@ get :: addr : Int -> { mem : Mem v | S.member addr (memAddrs mem) } -> v @-}
-get :: Int -> Mem v -> v
-get addr (MCons addr' val' mem)
-  | addr == addr' = val'
-  | otherwise     = get addr mem
-
-
-
diff --git a/tests/neg/T1907.hs b/tests/neg/T1907.hs
deleted file mode 100644
--- a/tests/neg/T1907.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-
--- Test for https://github.com/ucsd-progsys/liquidhaskell/issues/1907
-
-module T1907 where
-
-{-@ foldr' :: forall  b -> Bool>.
-              (a -> b -> b) -> b -> xs:[a] -> b
-  @-}
-foldr' op b = go
-  where
-    {-@ go :: forall  b -> Bool>.
-              xs:[a] -> b
-      @-} 
-    go []    = b
-    go (h:t) = op h (go t)
-
-
-{-@ mlength :: zs:[a] -> {v:_ | v == 42 * (len zs) } @-}
-mlength = foldr' (\_ n -> n + 1) 0
diff --git a/tests/neg/T602.hs b/tests/neg/T602.hs
deleted file mode 100644
--- a/tests/neg/T602.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module T602 where
-
--- UNSOUNDLY SAFE
-{-@
-class Fractional a => Foo a where
-    foo :: { x : a | x /= 0.0 } -> a
-@-}
-
--- UNSAFE
-{-
-class Fractional a => Foo a where
-    foo :: { x : a | x /= 0.0 } -> a
-@-}
-
-class Fractional a => Foo a where
-    foo :: a -> a
-
-instance Foo Double where
-    foo = id
-
-example :: Double
-example = foo 0.0
diff --git a/tests/neg/T743.hs b/tests/neg/T743.hs
deleted file mode 100644
--- a/tests/neg/T743.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module T743 where
-
-{-@ checkNat :: Nat -> Int @-}
-checkNat :: Int -> Int
-checkNat x = x
-
-unsound :: Int
-unsound = checkNat (-1)
-
-data TestBS = TestBS Int deriving (Read)
diff --git a/tests/neg/T743_mini.hs b/tests/neg/T743_mini.hs
deleted file mode 100644
--- a/tests/neg/T743_mini.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module T743_mini (bar) where
-
-{-@ bar :: Nat @-}
-bar :: Int
-bar = 2 - 10
-
-data Foo a = FooCon a
-data Dict = DictCon
-
-
-{-@ mkDict :: Foo Int -> Dict @-}
-mkDict :: Foo Int -> Dict
-mkDict _ = DictCon
-
-dict      = mkDict dictList
-dictList  = readListPrecDefault dict
-
-{-@ readListPrecDefault :: Dict -> Foo Int @-}
-readListPrecDefault :: Dict -> Foo Int
-readListPrecDefault = undefined
diff --git a/tests/neg/TermReal.hs b/tests/neg/TermReal.hs
deleted file mode 100644
--- a/tests/neg/TermReal.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module TermReal where
-
-{-@ search :: { hi : Int | 0 < hi } -> Int @-}
-search :: Int -> Int
-search hi = search (hi `div` 2)
diff --git a/tests/neg/TerminationNum.hs b/tests/neg/TerminationNum.hs
deleted file mode 100644
--- a/tests/neg/TerminationNum.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module TerminationNum where
-
-{-@ fak2 :: (Ord a, Eq a, Num a) => y:{x: a | x >= 0} -> a /[y]@-}
-fak2 :: (Ord a, Eq a, Num a) => a -> a
-fak2 0 = 1
-fak2 x = x * fak2 (x + 1)
diff --git a/tests/neg/TerminationNum0.hs b/tests/neg/TerminationNum0.hs
deleted file mode 100644
--- a/tests/neg/TerminationNum0.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module TerminationNum0 where
-
-{-@fak2 :: (Ord a, Eq a, Num a) => {x: a | x >= 0} -> a @-}
-fak2 :: (Ord a, Eq a, Num a) => a -> a
-fak2 0 = 1
-fak2 x = x * fak2 (x + 1)
-
-
-{-@ fak :: {x: Int | x >= 0} -> a -> Int @-}
-fak :: (Ord a, Eq a, Num a) => Int -> a -> Int 
-fak 0 _ = 1
-fak x y = fak (x + 1) y
-
-
-{-@ fak1 :: {x: Int | x >= 0} -> a -> Int @-}
-fak1 :: (Num a) => Int -> a -> Int 
-fak1 0 _ = 1
-fak1 x y = fak1 (x + 1) y
diff --git a/tests/neg/Test00.hs b/tests/neg/Test00.hs
deleted file mode 100644
--- a/tests/neg/Test00.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Test00 () where
-
-import Language.Haskell.Liquid.Prelude
-
-x :: Int
-x = choose 0
-
-prop_abs = if x > 0 then baz x else False
-
-baz :: Int -> Bool
-baz z = liquidAssertB (z `geq` 100)
diff --git a/tests/neg/Test00a.hs b/tests/neg/Test00a.hs
deleted file mode 100644
--- a/tests/neg/Test00a.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Test00a () where
-
-import Language.Haskell.Liquid.Prelude
-
-x = choose 0
-
-prop_abs = if x > 0 then baz x else False
-
-baz z = liquidAssertB (z >= 10)
diff --git a/tests/neg/Test00b.hs b/tests/neg/Test00b.hs
deleted file mode 100644
--- a/tests/neg/Test00b.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Test00b () where
-
-import Language.Haskell.Liquid.Prelude
-
-x = choose 0
-
-foo ::  Num a => a -> a
-foo x = 0 - x
-
-prop_abs ::  Bool
-prop_abs = if x > 0 then baz (foo x) else False
-
-baz ::  (Num a, Ord a) => a -> Bool
-baz z = liquidAssertB (z > 0)
diff --git a/tests/neg/Test00c.hs b/tests/neg/Test00c.hs
deleted file mode 100644
--- a/tests/neg/Test00c.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Test00c (ok, inc) where
-
-{-@ ok
-      :: Int -> Nat
-  @-}
-ok :: Int -> Int
-ok x = x + 120
-
-{-@ inc :: Int -> Nat @-}
-inc :: Int -> Int
-inc x = x + 10
diff --git a/tests/neg/Test1.hs b/tests/neg/Test1.hs
deleted file mode 100644
--- a/tests/neg/Test1.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Test1 () where
-
-import Language.Haskell.Liquid.Prelude
-
-myabs x = if x `gt` 0 then x else 0 `minus` x
-
-n = choose 0
-
-prop_absf = liquidAssertB ((myabs n) `geq` 4)
diff --git a/tests/neg/Test2.hs b/tests/neg/Test2.hs
deleted file mode 100644
--- a/tests/neg/Test2.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Test2 () where
-
-import Language.Haskell.Liquid.Prelude
-
-myabs x = if x `gt` 0 then x else 0 `minus` x
-
-n = choose 0
-
-prop_absf = 
-  let zz = (myabs n) `geq` 4 in
-  liquidAssertB zz
diff --git a/tests/neg/TopLevel.hs b/tests/neg/TopLevel.hs
deleted file mode 100644
--- a/tests/neg/TopLevel.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module TopLevel where
-
-import Language.Haskell.Liquid.Prelude
-
-foo b = liquidAssertB b
-
-bar = foo True
diff --git a/tests/neg/TotalHaskell.hs b/tests/neg/TotalHaskell.hs
deleted file mode 100644
--- a/tests/neg/TotalHaskell.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module TotalHaskell where
-
--- | totalHaskell overrides no-termination
--- | and checks for both totality & termination 
-
-{-@ LIQUID "--total-Haskell"   @-}
-{-@ LIQUID "--no-termination" @-}
-
-fib :: Int -> Int 
-fib 0 = 0 
-fib 1 = 1 
-fib i | 1 < i = fib i + fib (i-2)
diff --git a/tests/neg/Trans.hs b/tests/neg/Trans.hs
deleted file mode 100644
--- a/tests/neg/Trans.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Trans () where
-
-{-@ assert compre :: xs:[a] -> {v:[(a,a)] | len(v) = len(xs) } @-}
-compre xs = [(x,x) | x <- xs]
-
-{-@ assert transpose :: n: Int -> [{v:[a] | len(v) = n}] -> {v: [[a]] | len(v) > n} @-}
-transpose               :: Int -> [[a]] -> [[a]]
-transpose 0 _              = []
-transpose n ((x:xs) : xss) = (x : [h | (h:_) <- xss]) : transpose (n-1) (xs : [ t | (_:t) <- xss]) 
--- transpose []             = []
--- transpose ([]   : xss)   = transpose xss
-
-
diff --git a/tests/neg/Truespec.hs b/tests/neg/Truespec.hs
deleted file mode 100644
--- a/tests/neg/Truespec.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Truespec (foo) where
-
-import Language.Haskell.Liquid.Prelude (liquidAssert)
-
-{-@ foo :: Int -> Int @-}
-foo :: Int -> Int
-foo x = liquidAssert (x > 0) $ x + 1
diff --git a/tests/neg/Tyclass0_unsafe.hs b/tests/neg/Tyclass0_unsafe.hs
deleted file mode 100644
--- a/tests/neg/Tyclass0_unsafe.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Tyclass0_unsafe (poop) where
-
-class Zog a where
-  zoom :: a -> Int
-
--- Assume the relevant behavior for the method.
-{-@ zoom :: (Zog a) => a -> Int @-}
-
--- Uses the behavior of `zoom`
-{-@ poop :: (Zog a) => a -> Nat @-}
-poop x = zoom x
diff --git a/tests/neg/TypeLitNat.hs b/tests/neg/TypeLitNat.hs
deleted file mode 100644
--- a/tests/neg/TypeLitNat.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-# LANGUAGE KindSignatures      #-}
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE RankNTypes          #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module TypeLitNat where
-
-import GHC.TypeLits
-
-
-
--- THIS SHOULD BE UNSAFE
-miunsafe1 :: forall s. MI s 
-miunsafe1 = Small 0
-
--- THIS SHOULD BE UNSAFE 
-miunsafe2 :: MI 0 
-miunsafe2 = Small 10
-
-
-data MI (s :: Nat)
-  = Small { mi_input :: Int  }
-
-
-{-@ Small :: forall (s :: Nat). {v:Int | s ~~ v } -> MI s @-}
-
--- OR 
-
-{- data MI (s :: Symbol)
-    = Small { mi_input :: {v:String | v == s } } @-}
diff --git a/tests/neg/Variance.hs b/tests/neg/Variance.hs
deleted file mode 100644
--- a/tests/neg/Variance.hs
+++ /dev/null
@@ -1,41 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Variance where
-
-{-@ data variance Foo invariant bivariant covariant contravariant @-}
-data Foo a b c d
-
-{-@ check_covariant :: Foo a b {v:Int | v > 0} c -> Foo a b {v:Int | v = 1} c @-}
-check_covariant :: Foo a b Int c -> Foo a b Int c
-check_covariant r = r
-
-{-@ check_contravariant :: Foo a b c {v:Int | v = 1} -> Foo a b c {v:Int | v > 0 } @-}
-check_contravariant :: Foo a b c Int-> Foo a b c Int
-check_contravariant r = r
-
-{-@ check_bivariant :: Foo a {v: Int | v > 0 } c d -> Foo a {v:Int | ((v > 0) && (v < 2))} c d @-}
-check_bivariant :: Foo a Int c d -> Foo a Int c d
-check_bivariant r = r
-
-
-{-@ check_invariant :: Foo {v: Int | v = 1} b c d -> Foo {v:Int | ((v > 0) && (v < 3))} b c d @-}
-check_invariant :: Foo Int b c d -> Foo Int b c d
-check_invariant r = r
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/neg/Variance1.hs b/tests/neg/Variance1.hs
deleted file mode 100644
--- a/tests/neg/Variance1.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Variance1 where
-
-import Data.Binary
-
-
-{-@ assume error :: { x : String | false } -> a @-}
-
-example :: Get ()
-example = do
-    _ <- return ()
-    error "URK"
diff --git a/tests/neg/Vector00.hs b/tests/neg/Vector00.hs
deleted file mode 100644
--- a/tests/neg/Vector00.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Vector00 () where
-
-import Language.Haskell.Liquid.Prelude
-
-import Data.Vector hiding (map, concat, zipWith, filter, foldr, foldl, (++))
-
-xs    = [1,2,3,4] :: [Int]
-vs    = fromList xs
-jhala = vs ! (x + y + z)
-  where x = 2
-        y = 3
-        z = 5
diff --git a/tests/neg/Vector0a.hs b/tests/neg/Vector0a.hs
deleted file mode 100644
--- a/tests/neg/Vector0a.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Vector0a () where
-
-import Language.Haskell.Liquid.Prelude
-
-import Data.Vector hiding(map, concat, zipWith, filter, foldl, foldr, (++))
-
-xs  = [1,2,3,4] :: [Int]
-vs  = fromList xs
-
---prop0 = liquidAssertB (x >= 0)
---        where x = Prelude.head xs
---
---prop1 = liquidAssertB (n > 0)
---        where n = Prelude.length xs
---
---prop2 = liquidAssertB (Data.Vector.length vs > 0)
---prop3 = liquidAssertB (Data.Vector.length vs > 3)
-
-prop6 = crash (0 == 1) 
-x0    = vs ! 0
diff --git a/tests/neg/Vector1a.hs b/tests/neg/Vector1a.hs
deleted file mode 100644
--- a/tests/neg/Vector1a.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Vector1a () where
-
-import Language.Haskell.Liquid.Prelude
-import Data.Vector hiding (map, concat, zipWith, filter, foldr, foldl, (++))
-
-
--- HA this needs a non-TOP spec due to contravariance...
-foo = (Data.Vector.!) 
-
-for :: Int -> Int -> a -> (Int -> a -> a) -> a
-for lo hi acc f 
-  | lo <= hi   = for (lo + 1) hi (f lo acc) f
-  | otherwise = acc 
-
-dotProd       :: Vector Int -> Vector Int -> Int
-dotProd v1 v2 = for 0 n 0 $ \i -> (((v1!i) * (v2!i)) +)
-  where n = Data.Vector.length v1
-
-sumSquare   :: Vector Int -> Int
-sumSquare v = dotProd v v
-
-total = sumSquare $ Data.Vector.fromList [0..100]
diff --git a/tests/neg/Vector2.hs b/tests/neg/Vector2.hs
deleted file mode 100644
--- a/tests/neg/Vector2.hs
+++ /dev/null
@@ -1,68 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module Vector2 () where
-
-import Prelude hiding (length)
-import Data.Vector
-import Language.Haskell.Liquid.Prelude (liquidAssert)
-    
-{-@ predicate Lt X Y      = X < Y                         @-}
-{-@ predicate Ge X Y      = not (Lt X Y)                  @-}
-{-@ predicate InBound I A = ((Ge I 0) && (Lt I (vlen A))) @-}
-
-{-@ unsafeLookup :: vec:Vector a 
-                 -> {v: Int | (0 <= v && v < (vlen vec)) } 
-                 -> a @-}
-unsafeLookup vec i = vec ! i
-
-{-@ unsafeLookup' :: vec:Vector a -> {v: Int | (InBound v vec)} -> a @-}
-unsafeLookup' vec i = vec ! i
-
-safeLookup x i 
-  | 0 <= i && i < length x = Just (x ! i)
-  | otherwise              = Nothing 
-
-{-@ absoluteSum   :: Vector Int -> {v: Int | 0 <= v}  @-}
-absoluteSum       :: Vector Int -> Int 
-absoluteSum vec   = if 0 < n then go 0 0 else 0
-  where
-    go acc i 
-      | i /= n    = go (acc + abz (vec ! i)) (i + 1)
-      | otherwise = acc 
-    n             = length vec
-
-abz n = if 0 <= n then n else (0 - n) 
-
-loop :: Int -> Int -> a -> (Int -> a -> a) -> a 
-loop lo hi base f = go base lo
-  where
-    go acc i     
-      | i /= hi   = go (f i acc) (i + 1)
-      | otherwise = acc
-
-incr x = x + 1
-
-zoo = incr 29
-
-{-@ dotProduct :: x:(Vector Int) 
-               -> y:{v: Vector Int | (vlen x) = (vlen x)} 
-               -> Int 
-  @-}
-dotProduct     :: Vector Int -> Vector Int -> Int
-dotProduct x y 
-  = loop 0 (length x) 0 (\index -> (+ (x ! index) * (y ! index))) 
-  -- = error "dotProduct only on equal-sized vectors!"
-
-
-{-@ type SparseVector a N = [({v: Int | (0 <= v && v <= N)}, a)] @-}
-
-{-@ sparseDotProduct :: (Num a) => x:(Vector a) -> (SparseVector a {(vlen x)}) -> a @-}
-sparseDotProduct x y  = go 0 y
-  where 
-    go sum ((i, v) : y') = go (sum + (x ! i) * v) y' 
-    go sum []            = sum
-
-jhala = vs ! (x + y + z)
-  where x = 2
-        y = 3
-        z = 5
-        vs = fromList [1,2,3,4] 
diff --git a/tests/neg/VerifiedNum.hs b/tests/neg/VerifiedNum.hs
deleted file mode 100644
--- a/tests/neg/VerifiedNum.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-module VerifiedNum where
-
--- Hiding numeric operations, because they get by default translated to SMT equivalent
-import Prelude hiding (Num(..))
-
-import qualified Prelude as Prelude
-
-class VerifiedNum a where
-  (+) :: a -> a -> a
-  (-) :: a -> a -> a
-
-{-@ predicate BoundInt X = 0 < X + 10000 && X < 10000 @-}
-
-{-@ type OkInt N = {v:Int | BoundInt N => v == N} @-}
-
-{-@ type ValidInt = {v:Int | BoundInt v} @-}
-
-
-instance VerifiedNum Int where
-{-@ instance VerifiedNum Int where
-      + :: x:Int -> y:Int -> OkInt {x + y}
-  @-}
-    x + y = (Prelude.+) x y
-{-@ instance VerifiedNum Int where
-      - :: x:Int -> y:Int -> OkInt {x - y}
-  @-}
-    x - y = (Prelude.-) x y
-
-
-{-@ good :: {v:Int | v == 10} @-}
-good :: Int
-good  = 5 + 5
-
diff --git a/tests/neg/Wrap0.hs b/tests/neg/Wrap0.hs
deleted file mode 100644
--- a/tests/neg/Wrap0.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
-{-@ LIQUID "--expect-any-error" @-}
-module Wrap0 () where
-
-import Language.Haskell.Liquid.Prelude (liquidError, liquidAssertB)
-
-{-@ data Foo a 
 Bool> = F (f :: a 
) @-}
-data Foo a = F a
-
-type IntFoo = Foo Int
-
-{-@ assert flibberty :: (Eq a) => a -> Bool @-}
-flibberty x   = prop x (F x)
-prop x (F y)  = liquidAssertB (x == y)
-
-{-@ assert flibInt :: (Num a, Ord a) => a -> Bool @-}
-flibInt x     = prop1 x (F (x + 1))
-prop1 x (F y) = liquidAssertB (x < y)
-
-{-@ assert flibXs :: a -> Bool @-}
-flibXs x     = prop2 (F [x, x, x])
-prop2 (F _ ) = liquidError "no!"
-prop2 (F _ ) = True
diff --git a/tests/neg/Wrap1.hs b/tests/neg/Wrap1.hs
deleted file mode 100644
--- a/tests/neg/Wrap1.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-{-@ LIQUID "--expect-any-error" @-}
-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
-
-module Wrap1 () where
-
-
-import Language.Haskell.Liquid.Prelude (liquidError, liquidAssertB)
-import Data.Function (on)
-import Data.Ord (comparing)
-
-data WrapType b a = WrapType {getVect :: b, getVal :: a}
-
-instance Eq (WrapType [Double] a) where
-   (==) = (==) `on` getVect
-
-instance Ord (WrapType [Double] a) where
-    compare = comparing getVect
-
-{-@ assert flibXs :: a -> Bool @-}
-flibXs x              = prop1 (WrapType [x, x, x] x)
-prop1 (WrapType [] _) = liquidError "no!"
-prop1 (WrapType _  _) = True
-
-{-@ assert nflibXs :: Int -> a -> Bool @-}
-nflibXs n x           = prop2 n (WrapType nxs x)
-                        where nxs = replicate n x 
-
-prop2 n (WrapType xs _) = liquidAssertB (n > length xs) 
-
-
-
-
-
diff --git a/tests/pos/AVL.hs b/tests/pos/AVL.hs
deleted file mode 100644
--- a/tests/pos/AVL.hs
+++ /dev/null
@@ -1,94 +0,0 @@
-{- Example of AVL trees by michaelbeaumont -}
-
-module AVL (Tree, singleton, insert, ht, bFac) where
-
--- Basic functions
-{-@ data Tree [ht] @-} 
-data Tree a = Nil | Tree a (Tree a) (Tree a) deriving Show
-
-{-@ measure ht @-}
-{-@ ht :: Tree a -> Nat @-}
-ht              :: Tree a -> Int
-ht Nil          = 0
-ht (Tree x l r) = if (ht l) > (ht r) then (1 + ht l) else (1 + ht r)
-
-
-{-@ measure bFac @-}
-bFac Nil          = 0
-bFac (Tree v l r) = ht l - ht r
-
-{-@ htDiff :: s:Tree a -> t: Tree a -> {v: Int | HtDiff s t v} @-}
-htDiff :: Tree a -> Tree a -> Int
-htDiff l r = ht l - ht r
-
-{-@ emp :: {v: AVLTree | ht v == 0} @-}
-emp = Nil
-
-{-@ singleton :: a -> {v: AVLTree | ht v == 1 }@-}
-singleton a = Tree a Nil Nil
-
--- | Insert functions
-
-{-@ decrease insert 3 @-}
-{-@ insert :: a -> s: AVLTree -> {t: AVLTree | EqHt t s || HtDiff t s 1 } @-}
-insert :: (Ord a) => a -> Tree a -> Tree a
-insert a Nil = singleton a
-insert a t@(Tree v l r) = case compare a v of
-    LT -> insL
-    GT -> insR
-    EQ -> t
-    where r' = insert a r
-          l' = insert a l
-          insL | siblDiff > 1
-                 && bFac l' == (0-1) = rebalanceLR v l' r
-               | siblDiff > 1
-                 && bFac l' == 1  = rebalanceLL v l' r
-               | siblDiff <= 1 = Tree v l' r
-               | otherwise = t
-               where siblDiff = htDiff l' r
-          insR | siblDiff > 1
-                 && bFac r' == 1 = rebalanceRL v l r'
-               | siblDiff > 1
-                 && bFac r' == (0-1) = rebalanceRR v l r'
-               | siblDiff <= 1 = Tree v l r'
-               | otherwise = t
-               where siblDiff = htDiff r' l
-
-{-@ rebalanceLL :: a -> l:{AVLTree | LeftHeavy l } -> r:{AVLTree | HtDiff l r 2} -> {t:AVLTree | EqHt t l } @-}
-rebalanceLL v (Tree lv ll lr) r                 = Tree lv ll (Tree v lr r)
-
-{-@ rebalanceLR :: a -> l:{AVLTree | RightHeavy l } -> r:{AVLTree | HtDiff l r 2 } -> {t: AVLTree | EqHt t l } @-}
-rebalanceLR v (Tree lv ll (Tree lrv lrl lrr)) r = Tree lrv (Tree lv ll lrl) (Tree v lrr r)
-
-{-@ rebalanceRR :: a -> l: AVLTree -> r: {AVLTree | RightHeavy r && HtDiff r l 2 } -> {t: AVLTree | EqHt t r } @-}
-rebalanceRR v l (Tree rv rl rr)                 = Tree rv (Tree v l rl) rr
-
-{-@ rebalanceRL :: a -> l: AVLTree -> r:{AVLTree | LeftHeavy r && HtDiff r l 2} -> {t: AVLTree | EqHt t r } @-}
-rebalanceRL v l (Tree rv (Tree rlv rll rlr) rr) = Tree rlv (Tree v l rll) (Tree rv rlr rr)
-
--- Test
-main = do
-    mapM_ print [a,b,c,d]
-  where
-    a = singleton 5
-    b = insert 2 a
-    c = insert 3 b
-    d = insert 7 c
-
--- Liquid Haskell
-
-{-@ predicate HtDiff S T D = (ht S) - (ht T) == D @-}
-{-@ predicate EqHt S T = (ht S) == (ht T) @-}
-
-{-@ predicate LeftHeavy T = bFac T == 1 @-}
-{-@ predicate RightHeavy T = bFac T == -1 @-}
-
-{-@ measure balanced @-}
-balanced :: Tree a -> Bool
-balanced Nil = True
-balanced (Tree v l r) = ((ht l) <= (ht r) + 1)
-                      && (ht r <= ht l + 1)
-                      && (balanced l)
-                      && (balanced r)
-
-{-@ type AVLTree = {v: Tree a | balanced v} @-}
diff --git a/tests/pos/AVLRJ.hs b/tests/pos/AVLRJ.hs
deleted file mode 100644
--- a/tests/pos/AVLRJ.hs
+++ /dev/null
@@ -1,111 +0,0 @@
-{- Example of AVL trees by michaelbeaumont -}
-
-{-@ LIQUID "--no-termination" @-}
-
-module AVLRJ (Tree, empty, singleton, insert, ht, bFac, balanced) where
-
--- Basic functions
-data Tree a = Nil | Tree { tKey :: a, tLeft ::Tree a, tRight :: Tree a} deriving Show
-
-{-@ data Tree [ht] a = Nil
-                     | Tree { tKey   :: a
-                            , tLeft  :: Tree {v:a | v < tKey }
-                            , tRight :: Tree {v:a | tKey < v }
-                            }
-  @-}
-
-{-@ measure ht @-}
-{-@ ht          :: Tree a -> Nat @-}
-ht              :: Tree a -> Int
-ht Nil          = 0
-ht (Tree _ l r) = if (ht l) > (ht r) then (1 + ht l) else (1 + ht r)
-
-{-@ invariant {v:Tree a | 0 <= bFac v + 1 && bFac v <= 1 } @-}
-
-
-{-@ measure bFac @-}
-{-@ bFac :: t:Tree a -> {v:Int | 0 <= v + 1 && v <= 1} @-}
-bFac Nil          = 0
-bFac (Tree _ l r) = ht l - ht r
-
-{-@ htDiff :: s:Tree a -> t: Tree a -> {v: Int | HtDiff s t v} @-}
-htDiff :: Tree a -> Tree a -> Int
-htDiff l r = ht l - ht r
-
--- | Empty
-{-@ empty :: {v: AVLTree a | ht v == 0} @-}
-empty = Nil
-
--- | Singleton
-{-@ singleton :: a -> {v: AVLTree a | ht v == 1 }@-}
-singleton a = Tree a Nil Nil
-
--- | Insert
-
-{-@ predicate PostInsert S T = ((bFac T == 0) => (EqHt T S || ht T == 1)) && (EqHt T S || HtDiff T S 1) @-}
-
-{-@ insert :: a -> s: AVLTree a -> {t: AVLTree a | PostInsert s t } @-}
-insert :: (Ord a) => a -> Tree a -> Tree a
-insert a Nil = singleton a
-insert a t@(Tree v _ _) = case compare a v of
-    LT -> insL a t
-    GT -> insR a t
-    EQ -> t
-
-{-@ insL :: x:a -> s:{AVLTree a | x < tKey s && ht s > 0} -> {t: AVLTree a | PostInsert s t } @-}
-insL a (Tree v l r)
-  | siblDiff == 2 && bl' == 1  = rebalanceLL v l' r
-  | siblDiff == 2 && bl' == -1 = rebalanceLR v l' r
-  | siblDiff <= 1              = Tree v l' r
-  where
-    l'                       = insert a l
-    siblDiff                 = htDiff l' r
-    bl'                      = bFac l'
-
-{-@ insR :: x:a -> s:{AVLTree a | tKey s < x && ht s > 0} -> {t: AVLTree a | PostInsert s t } @-}
-insR a (Tree v l r)
-  | siblDiff == 2 && br' == 1  = rebalanceRL v l r'
-  | siblDiff == 2 && br' == -1  = rebalanceRR v l r'
-  | siblDiff <= 1            = Tree v l r'
-  where
-    siblDiff                 = htDiff r' l
-    r'                       = insert a r
-    br'                      = bFac r'
-
-
-{-@ rebalanceLL :: x:a -> l:{AVLL a x | LeftHeavy l } -> r:{AVLR a x | HtDiff l r 2} -> {t:AVLTree a | EqHt t l} @-}
-rebalanceLL v (Tree lv ll lr) r                 = Tree lv ll (Tree v lr r)
-
-{-@ rebalanceLR :: x:a -> l:{AVLL a x | RightHeavy l } -> r:{AVLR a x | HtDiff l r 2} -> {t: AVLTree a | EqHt t l } @-}
-rebalanceLR v (Tree lv ll (Tree lrv lrl lrr)) r = Tree lrv (Tree lv ll lrl) (Tree v lrr r)
-
-{-@ rebalanceRR :: x:a -> l: AVLL a x -> r:{AVLR a x | RightHeavy r && HtDiff r l 2 } -> {t: AVLTree a | EqHt t r } @-}
-rebalanceRR v l (Tree rv rl rr)                 = Tree rv (Tree v l rl) rr
-
-{-@ rebalanceRL :: x:a -> l: AVLL a x -> r:{AVLR a x | LeftHeavy r && HtDiff r l 2} -> {t: AVLTree a | EqHt t r } @-}
-rebalanceRL v l (Tree rv (Tree rlv rll rlr) rr) = Tree rlv (Tree v l rll) (Tree rv rlr rr)
-
--- Test
-main = do
-    mapM_ print [a,b,c,d]
-  where
-    a = singleton 5
-    b = insert 2 a
-    c = insert 3 b
-    d = insert 7 c
-
--- Liquid Haskell
-
-{-@ predicate HtDiff S T D = ht S - ht T == D @-}
-{-@ predicate EqHt S T     = HtDiff S T 0     @-}
-{-@ predicate LeftHeavy  T = bFac T == 1      @-}
-{-@ predicate RightHeavy T = bFac T == -1     @-}
-
-{-@ measure balanced @-}
-balanced              :: Tree a -> Bool
-balanced (Nil)        = True
-balanced (Tree v l r) = ht l - ht r <= 1 && ht l - ht r >= -1 && balanced l && balanced r
-
-{-@ type AVLTree a   = {v: Tree a | balanced v} @-}
-{-@ type AVLL a X    = AVLTree {v:a | v < X}    @-}
-{-@ type AVLR a X    = AVLTree {v:a | X < v}    @-}
diff --git a/tests/pos/Abs.hs b/tests/pos/Abs.hs
deleted file mode 100644
--- a/tests/pos/Abs.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-module Abs () where
-
-absN ::  (Num a, Ord a) => a -> a
-absN x = if x > 0 then x else (-x)
-
-absI ::  Int -> Int
-absI x = if x > 0 then x else (-x)
-
-absL :: [Int] -> [Int]
-absL xs = (0 : xs) ++ [] 
-
---incI ::  Int -> Int
---incI = (+) 1
-
-x0 = absN 4
-x1 = absI (-5)
-
---x2 = absI (incI 2)
--- x3 = absI (-3)
diff --git a/tests/pos/Absref_crash.hs b/tests/pos/Absref_crash.hs
deleted file mode 100644
--- a/tests/pos/Absref_crash.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-module Absref_crash where
-
-data L a = C (L a)
-
-{-@ data L a 
 Bool> = C { xs :: L
 a } @-}
-
-{-@ lazy foo @-}
-foo :: b -> L a
-foo x = C $ foo x
diff --git a/tests/pos/Absref_crash0.hs b/tests/pos/Absref_crash0.hs
deleted file mode 100644
--- a/tests/pos/Absref_crash0.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-{-@ LIQUID "--short-names"    @-}
-{-@ LIQUID "--no-warnings"    @-}
-{-@ LIQUID "--no-termination" @-}
-
-
-module Absref_crash0 (insertSort) where
-
-data List a = N | C a (List a)
-
-infixr 9 `C`
-
-{-@ ifoldr :: forall a b 
 b -> Bool>. 
-                 (xs:_ -> x:_ -> b
 -> b) 
-               -> b
 
-               -> ys:List a
-               -> b
                            @-}
-ifoldr :: (List a -> a -> b -> b) -> b -> List a -> b
-ifoldr = undefined
-
-{-@ data List a 
 a -> Bool> 
-     = N | C {x :: a, xs :: List
 a
} @-}
-
-{-@ type IncrList a = List <{\x y -> x <= y}> a @-} 
-
-{-@ insert :: a -> IncrList a -> IncrList a @-}
-insert :: a -> List a -> List a
-insert = undefined
-
-{-@ insertSort      :: xs:List a -> {v:IncrList a | true } @-}
-insertSort :: List a -> List a
-insertSort = undefined
-
-
-
-nil :: List a 
-nil = N
diff --git a/tests/pos/Ackermann.hs b/tests/pos/Ackermann.hs
deleted file mode 100644
--- a/tests/pos/Ackermann.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module Ackermann () where
-
-{-@ ack :: m:Nat -> n:Nat -> Nat / [m, n]@-}
-ack :: Int -> Int -> Int
-ack m n
-    | m == 0          = n + 1
-    | m > 0 && n == 0 = ack (m-1) 1
-    | m > 0 && n >  0 = ack (m-1) (ack m (n-1))
diff --git a/tests/pos/Adt0.hs b/tests/pos/Adt0.hs
deleted file mode 100644
--- a/tests/pos/Adt0.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module Adt0 () where
-
-import Language.Haskell.Liquid.Prelude
-
-data Pair a = P a Int | D a Bool
-
-
-goo z = P z z
-
-baz = goo 10
diff --git a/tests/pos/AdtList0.hs b/tests/pos/AdtList0.hs
deleted file mode 100644
--- a/tests/pos/AdtList0.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-
-{-@ LIQUID "--exact-data-cons" @-}
-
-module AdtList0 where
-
-data LL a = Emp | Cons a (LL a) 
-
-{-@ test1 :: n:Int -> m:Int -> {v:() | Cons n (Cons m Emp) == Cons m (Cons n Emp)} -> {n == m} @-}
-test1 :: Int -> Int -> () -> ()
-test1 _ _ _ = ()
-
diff --git a/tests/pos/AdtList1.hs b/tests/pos/AdtList1.hs
deleted file mode 100644
--- a/tests/pos/AdtList1.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-{-@ LIQUID "--exact-data-cons" @-}
-
-module AdtList1 where
-
-data LL a = Emp | Cons a (LL a) 
-
-{-@ test1 :: n:Int -> m:Int -> {v:() | Cons n (Cons m Emp) == Cons m (Cons n Emp)} -> {n == m} @-}
-test1 :: Int -> Int -> () -> ()
-test1 _ _ _ = ()
-
-{-@ reflect sz @-}
-sz :: LL a -> Int 
-sz Emp         = 0 
-sz (Cons x xs) = 1 + sz xs
diff --git a/tests/pos/AdtList2.hs b/tests/pos/AdtList2.hs
deleted file mode 100644
--- a/tests/pos/AdtList2.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple"        @-}
-
-module AdtList2 where
-
-data LL a = Emp | Cons a (LL a) 
-
-{-@ test1 :: n:Int -> m:Int -> {v:() | Cons n (Cons m Emp) == Cons m (Cons n Emp)} -> {n == m} @-}
-test1 :: Int -> Int -> () -> ()
-test1 _ _ _ = ()
-
-{-@ reflect sz @-}
-sz :: LL a -> Int 
-sz Emp = 0 
-sz (Cons x xs) = 1 + sz xs
-
-{-@ test2 :: () -> { sz (Cons 1 (Cons 2 Emp)) == 2 } @-}
-test2 () = () 
diff --git a/tests/pos/AdtList3.hs b/tests/pos/AdtList3.hs
deleted file mode 100644
--- a/tests/pos/AdtList3.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-{-@ LIQUID "--exact-data-cons" @-}
-
-module AdtList3 where
-
-data LL a = Emp | Cons a (LL a) 
-
-{-@ data LL [sz] @-}
-
-{-@ test1 :: n:Int -> m:Int -> {v:() | Cons n (Cons m Emp) == Cons m (Cons n Emp)} -> {n == m} @-}
-test1 :: Int -> Int -> () -> ()
-test1 _ _ _ = ()
-
-{-@ measure sz @-}
-{-@ sz :: LL a -> Nat @-}
-sz :: LL a -> Int 
-sz Emp         = 0 
-sz (Cons x xs) = 1 + sz xs
-
-
-app :: LL a -> LL a -> LL a 
-app Emp z         = z 
-app (Cons x xs) z = Cons x (app xs z)
diff --git a/tests/pos/AdtList4.hs b/tests/pos/AdtList4.hs
deleted file mode 100644
--- a/tests/pos/AdtList4.hs
+++ /dev/null
@@ -1,30 +0,0 @@
--- | THIS FAILS because we don't support < and > for ADT and,
---   we instantiate the output of `app` with quals like `v < xs` `v > xs` etc.
---   where v, xs are of the ADT sort `List a`.
-
-{-@ LIQUID "--exact-data-cons" @-}
-
-module AdtList4 where
-
-data LL a = Emp | Cons a (LL a) 
-
-{-@ data LL [sz] @-}
-
-{-@ test1 :: n:Int -> m:Int -> {v:() | Cons n (Cons m Emp) == Cons m (Cons n Emp)} -> {n == m} @-}
-test1 :: Int -> Int -> () -> ()
-test1 _ _ _ = ()
-
-{-@ app :: xs:LL a -> ys:LL a -> {v:LL a | sz v = sz xs + sz ys} @-} 
-app = go 
-  where 
-    {-@ go :: xs:LL a -> ys:LL a -> {v:LL a | sz v = sz xs + sz ys} @-} 
-    go Emp ys         = ys 
-    go (Cons x xs) ys = Cons x (go xs ys)
-
-{-@ measure sz @-}
-{-@ sz :: LL a -> Nat @-}
-sz :: LL a -> Int 
-sz Emp         = 0 
-sz (Cons x xs) = 1 + sz xs
-
-
diff --git a/tests/pos/AdtList5.hs b/tests/pos/AdtList5.hs
deleted file mode 100644
--- a/tests/pos/AdtList5.hs
+++ /dev/null
@@ -1,15 +0,0 @@
--- | The current code for lifting ADTs cannot deal with the case when there
---   are "holes" in the data-decl specification, presumably because the lifting
---   happens BEFORE the holes are resolved.
-
-{-@ LIQUID "--exact-data-cons" @-}
-
-module AdtList5 where
-
-data Zing = ZZ (Int -> ())
-
-{-@ data Zing = ZZ { unZZ :: Int -> { 5 < 10 } } @-}
-
-{-@ bob :: Nat @-}
-bob :: Int
-bob = 12
diff --git a/tests/pos/AdtPeano0.hs b/tests/pos/AdtPeano0.hs
deleted file mode 100644
--- a/tests/pos/AdtPeano0.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-@ LIQUID "--exact-data-con" @-}
-{-@ LIQUID "--higherorder"    @-}
-
-module AdtPeano0 where
-
--- | The code currently works if we add the below, but thats icky.
---   First, lets get this file to work _without_ the below.
-
-{- data Influx = Silly Int @-}
-
-data Influx = Silly Int
-
-{-@ reflect thing @-}
-thing :: Influx -> Int
-thing (Silly a) = a + 1
-
-{-@ reflect bling @-}
-bling :: Influx -> Int
-bling (Silly b) = b
-
-{-@ test :: m:Influx -> { thing m = 1 + bling m} @-}
-test :: Influx -> (Int, Int)
-test m = (thing m, bling m)
diff --git a/tests/pos/AdtPeano1.hs b/tests/pos/AdtPeano1.hs
deleted file mode 100644
--- a/tests/pos/AdtPeano1.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-{-@ LIQUID "--exact-data-con"                      @-}
-{-@ LIQUID "--higherorder"                         @-}
-
-module AdtPeano1 where
-
-data Influx = Silly { goo :: Int }
-
-{-@ test1:: n:Int -> m:Int -> { v:() | Silly n == Silly m } -> { n == m } @-}
-test1 :: Int -> Int -> () -> Int
-test1 n m z = moo (Silly n) + moo (Silly m)
-
-{-@ reflect moo @-}
-moo :: Influx -> Int
-moo (Silly a) = a
diff --git a/tests/pos/Alias00.hs b/tests/pos/Alias00.hs
deleted file mode 100644
--- a/tests/pos/Alias00.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module Alias00 () where
-
-{-@ type PosInt = {v: Int | v >= 0} @-}
-
-{-@ assert myabs :: Int -> PosInt @-}
-myabs   :: Int -> Int
-myabs x = if (x > 0) then x else (0 - x)
-
-{-@ type NNList a = {v: [a] | len v > 0} @-}
-
-{-@ assert single :: a -> NNList a @-}
-single x = [x] 
diff --git a/tests/pos/Alias01.hs b/tests/pos/Alias01.hs
deleted file mode 100644
--- a/tests/pos/Alias01.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-module Alias01 () where
-
-{-@ type GeNum a N = {v: a | N <= v} @-}
-
-{-@ type PosInt = GeNum Int {0} @-}
-
-{-@ myabs :: Int -> PosInt @-}
-myabs :: Int -> Int
-myabs x = if (x > 0) then x else (0 - x)
-
-{-@ incr :: x:Int -> GeNum Int {x} @-}
-incr :: Int -> Int
-incr x = x + 1
-
diff --git a/tests/pos/Alphaconvert_List.hs b/tests/pos/Alphaconvert_List.hs
deleted file mode 100644
--- a/tests/pos/Alphaconvert_List.hs
+++ /dev/null
@@ -1,140 +0,0 @@
-{-@ LIQUID "--pruneunsorted" @-}
-{-@ LIQUID "--no-termination" @-}
-{-@ LIQUID "--short-names"    @-}
-{-@ LIQUID "--fullcheck"      @-}
-{-@ LIQUID "--maxparams=3"    @-}
-
--- | An example from "A Relational Framework for Higher-Order Shape Analysis",
---   by Gowtham Kaki Suresh Jagannathan, ICFP 2014.
-
-module Alphaconvert_List (subst, alpha, isAbs, maxs) where
-
-import Prelude hiding ((++), elem)
-import qualified Data.Set as S
-import Language.Haskell.Liquid.Prelude
-
-alpha  :: [Bndr] -> Expr -> Expr
-subst  :: Expr -> Bndr -> Expr -> Expr
-lemma1 :: Int -> [Int] -> Bool
-fresh  :: [Bndr] -> Bndr
-free   :: Expr -> [Bndr]
-
----------------------------------------------------------------------
--- | Datatype Definition --------------------------------------------
----------------------------------------------------------------------
-
-type Bndr
-  = Int
-
-data Expr
-  = Var Bndr
-  | Abs Bndr Expr
-  | App Expr Expr
-
-{-@ measure fv @-}
-fv :: Expr -> S.Set Bndr
-fv (Var x)   = S.singleton x
-fv (Abs x e) = S.difference (fv e) (S.singleton x)
-fv (App e a) = S.union (fv e) (fv a)
-
-{-@ measure isAbs  @-}
-isAbs :: Expr -> Bool
-isAbs (Abs v e)  = True
-isAbs (Var v)    = False
-isAbs (App e a)  = False
-
-{-@ predicate AddV E E2 X E1   = fv E = Set_cup (Set_dif (fv E2) (Set_sng X)) (fv E1) @-}
-{-@ predicate EqV E1 E2        = fv E1 = fv E2                                        @-}
-{-@ predicate Occ X E          = Set_mem X (fv E)                                     @-}
-{-@ predicate Subst E E1 X E2  = if (Occ X E2) then (AddV E E2 X E1) else (EqV E E2)  @-}
-
-----------------------------------------------------------------------------
--- | Part 5: Capture Avoiding Substitution ---------------------------------
-----------------------------------------------------------------------------
-{-@ subst :: e1:Expr -> x:Bndr -> e2:Expr -> {e:Expr | Subst e e1 x e2} @-}
-----------------------------------------------------------------------------
-
-subst e1 x e2@(Var y)
-  | x == y                = e1
-  | otherwise             = e2
-
-subst e1 x (App ea eb)    = App ea' eb'
-  where
-    ea'                   = subst e1 x ea
-    eb'                   = subst e1 x eb
-
-subst e1 x e2@(Abs y e)
-  | x == y                = e2
-  | y `elem` xs           = subst e1 x (alpha xs e2)
-  | otherwise             = Abs y      (subst e1 x e)
-     where
-      xs                  = free e1
-
-----------------------------------------------------------------------------
--- | Part 4: Alpha Conversion ----------------------------------------------
-----------------------------------------------------------------------------
-{-@ alpha :: ys:[Bndr] -> e:{Expr | isAbs e} -> {v:Expr | EqV v e} @-}
-----------------------------------------------------------------------------
-alpha ys (Abs x e) = Abs x' (subst (Var x') x e)
-  where
-    xs             = free e
-    x'             = fresh (x : ys ++ xs)
-
-alpha _  _         = liquidError "never"
-
-
-----------------------------------------------------------------------------
--- | Part 3: Fresh Variables -----------------------------------------------
-----------------------------------------------------------------------------
-{-@ fresh :: xs:[Bndr] -> {v:Bndr | NotElem v xs} @-}
-----------------------------------------------------------------------------
-fresh bs = liquidAssert (lemma1 n bs) n
-  where
-    n    = 1 + maxs bs
-
-{-@ measure maxs @-}
-maxs   :: [Int] -> Int
-maxs ([])   = 0
-maxs (x:xs) = if (x > maxs xs) then x else (maxs xs)
-
-{-@ lemma1 :: x:Int -> xs:{[Int] | x > maxs xs} -> {v:Bool | v && NotElem x xs} @-}
-lemma1 _ []     = True
-lemma1 x (_:ys) = lemma1 x ys
-
-
-----------------------------------------------------------------------------
--- | Part 2: Free Variables ------------------------------------------------
-----------------------------------------------------------------------------
-
-----------------------------------------------------------------------------
-{-@ free         :: e:Expr -> {v:[Bndr] | elts v = fv e} @-}
-----------------------------------------------------------------------------
-free (Var x)     = [x]
-free (App e e')  = free e ++ free e'
-free (Abs x e)   = free e \\ x
-
-
-----------------------------------------------------------------------------
--- | Part I: Sets with Lists -----------------------------------------------
-----------------------------------------------------------------------------
-
-{-@ predicate IsCup X Y Z  = elts X = Set_cup (elts Y) (elts Z)    @-}
-{-@ predicate IsDel X Y Z  = elts X = Set_dif (elts Y) (Set_sng Z) @-}
-{-@ predicate Elem  X Ys   = Set_mem X (elts Ys)                   @-}
-{-@ predicate NotElem X Ys = not (Elem X Ys)                       @-}
-
-{-@ (++)      :: xs:[a] -> ys:[a] -> {v:[a] | IsCup v xs ys}  @-}
-[]     ++ ys  = ys
-(x:xs) ++ ys  = x : (xs ++ ys)
-
-{-@ (\\)      :: (Eq a) => xs:[a] -> y:a -> {v:[a] | IsDel v xs y} @-}
-xs   \\ y     = [x | x <- xs, x /= y]
-
-{-@ elem      :: (Eq a) => x:a -> ys:[a] -> {v:Bool | v <=> Elem x ys} @-}
-elem x []     = False
-elem x (y:ys) = x == y || elem x ys
-
-{-@ measure elts @-}
-elts :: (Ord a) => [a] -> S.Set a
-elts []     = S.empty
-elts (x:xs) = S.union (S.singleton x) (elts xs)
diff --git a/tests/pos/Alphaconvert_Set.hs b/tests/pos/Alphaconvert_Set.hs
deleted file mode 100644
--- a/tests/pos/Alphaconvert_Set.hs
+++ /dev/null
@@ -1,101 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-{-@ LIQUID "--short-names"    @-}
-{-@ LIQUID "--fullcheck"      @-}
-{-@ LIQUID "--maxparams=3"    @-}
-
-module Alphaconvert_Set (isAbs, subst) where
-
-import qualified Data.Set as S
-
-import Language.Haskell.Liquid.Prelude
-
-freshS  :: S.Set Bndr -> Bndr
-alpha   :: S.Set Bndr -> Expr -> Expr
-subst   :: Expr -> Bndr -> Expr -> Expr
-free    :: Expr -> S.Set Bndr
-
-
----------------------------------------------------------------------
--- | Datatype Definition --------------------------------------------
----------------------------------------------------------------------
-
-type Bndr
-  = Int
-
-data Expr
-  = Var Bndr
-  | Abs Bndr Expr
-  | App Expr Expr
-
-{-@ measure fv @-}
-fv :: Expr -> S.Set Bndr
-fv (Var x)   = S.singleton x
-fv (Abs x e) = S.difference (fv e) (S.singleton x)
-fv (App e a) = S.union (fv e) (fv a)
-
-{-@ measure isAbs @-}
-isAbs (Var v)    = False
-isAbs (Abs v e)  = True
-isAbs (App e a)  = False
-
-{-@ predicate Elem  X Ys       = Set_mem X Ys               @-}
-{-@ predicate NotElem X Ys     = not (Elem X Ys)            @-}
-{-@ predicate AddV E E2 X E1   = fv E = Set_cup (Set_dif (fv E2) (Set_sng X)) (fv E1) @-}
-{-@ predicate EqV E1 E2        = fv E1 = fv E2                                        @-}
-{-@ predicate Occ X E          = Set_mem X (fv E)                                     @-}
-{-@ predicate Subst E E1 X E2  = if (Occ X E2) then (AddV E E2 X E1) else (EqV E E2)  @-}
-
-----------------------------------------------------------------------------
--- | Part 5: Capture Avoiding Substitution ---------------------------------
-----------------------------------------------------------------------------
-{-@ subst :: e1:Expr -> x:Bndr -> e2:Expr -> {e:Expr | Subst e e1 x e2} @-}
-----------------------------------------------------------------------------
-
-subst e' x e@(Var y)
-  | x == y                = e'
-  | otherwise             = e
-
-subst e' x (App ea eb)    = App ea' eb'
-  where
-    ea'                   = subst e' x ea
-    eb'                   = subst e' x eb
-
-subst e1 x e2@(Abs y e)
-  | x == y                = e2
-  | y `S.member` xs       = subst e1 x (alpha xs e2)
-  | otherwise             = Abs y (subst e1 x e)
-    where
-      xs                  = free e1
-
-----------------------------------------------------------------------------
--- | Part 4: Alpha Conversion ----------------------------------------------
-----------------------------------------------------------------------------
-{-@ alpha :: ys:(S.Set Bndr) -> e:{Expr | isAbs e} -> {v:Expr | EqV v e} @-}
-----------------------------------------------------------------------------
-alpha ys (Abs x e) = Abs x' (subst (Var x') x e)
-  where
-    xs             = free e
-    x'             = freshS zs
-    zs             = S.insert x (S.union ys xs)
-
-alpha _  _         = liquidError "never"
-
-
-----------------------------------------------------------------------------
--- | Part 3: Fresh Variables -----------------------------------------------
-----------------------------------------------------------------------------
-{-@ freshS :: xs:(S.Set Bndr) -> {v:Bndr | NotElem v xs} @-}
-----------------------------------------------------------------------------
-freshS xs = undefined
-
-
-----------------------------------------------------------------------------
--- | Part 2: Free Variables ------------------------------------------------
-----------------------------------------------------------------------------
-
-----------------------------------------------------------------------------
-{-@ free         :: e:Expr -> {v : S.Set Bndr | v = fv e} @-}
-----------------------------------------------------------------------------
-free (Var x)     = S.singleton x
-free (App e e')  = S.union  (free e) (free e')
-free (Abs x e)   = S.delete x (free e)
diff --git a/tests/pos/AmortizedQueue.hs b/tests/pos/AmortizedQueue.hs
deleted file mode 100644
--- a/tests/pos/AmortizedQueue.hs
+++ /dev/null
@@ -1,85 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-{-@ LIQUID "--maxparams=3"    @-}
-
-module AmortizedQueue where
-
--- Source: Okasaki, JFP 1995
--- http://www.westpoint.edu/eecs/SiteAssets/SitePages/Faculty%20Publication%20Documents/Okasaki/jfp95queue.pdf
-
---------------------------------------------------------------------------------
--- | Sized Lists
---------------------------------------------------------------------------------
-
-data SList a = SL { size  :: Int
-                  , elems :: [a]
-                  }
-
-{-@ type SListN a N = {v:SList a | size v = N} @-}
-
--- | Invariant: `size` is really the size:
-
-{-@ data SList a = SL { size  :: Nat
-                      , elems :: {v:[a] | len v = size}
-                      }
-  @-}
-
--- | Size function actually returns the size: (Duh!)
-
-{-@ size :: q:SList a -> {v:Nat | v = size q} @-}
-
--- | Non-Empty Lists:
-
-{-@ type NEList a = {v:SList a | size v > 0} @-}
-
-
-{-@ nil          :: SListN a 0  @-}
-nil              = SL 0 []
-
-{-@ cons         :: a -> xs:SList a -> SListN a {size xs + 1}   @-}
-cons x (SL n xs) = SL (n+1) (x:xs)
-
-{-@ tl           :: xs:NEList a -> SListN a {size xs - 1}  @-}
-tl (SL n (_:xs)) = SL (n-1) xs
-tl _             = die "never"
-
-{-@ hd           :: xs:NEList a -> a @-}
-hd (SL _ (x:_))  = x 
-hd _             = die "never"
-
-
---------------------------------------------------------------------------------
--- | Sized Lists
---------------------------------------------------------------------------------
-
-data Queue a = Q  { left   :: SList a
-                  , right  :: SList a
-                  }
-
--- | Invariant: `|right|` <= `|left|`
-
-{-@ data Queue a = Q { left  :: SList a 
-                     , right :: {v:SList a | size v <= size left}
-                     }
-  @-}
-
-
-
-emp = Q nil nil
-
-qsize         :: Queue a -> Int
-qsize (Q l r) = size l + size r
-
-insert e (Q l r) = makeq l (e `cons` r)
-
-{-@ makeq :: l:_ -> r:{ _ | size r <= size l + 1} -> _  @-}
-makeq l r
-  | size r <= size l = Q l r
-  | otherwise        = Q (rot l r nil) nil
-
-{-@ rot :: l:_ -> r:SListN _ {1 + size l} -> a:_ -> {v:_ | size v = size l + size r + size a} @-}
-rot l r a
-  | size l == 0      = (hd r) `cons` a
-  | otherwise        = (hd l) `cons` (rot (tl l) (tl r) ((hd r) `cons` a))
-
-{-@ die :: {v:_ | false} -> a @-}
-die x = error x
diff --git a/tests/pos/Anfbug.hs b/tests/pos/Anfbug.hs
deleted file mode 100644
--- a/tests/pos/Anfbug.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-
-module Anfbug (x,y) where
-
-import Control.Exception (assert)
-
--- TransformRec BUG: this causes a temporary to get hoisted out of scope
-getTails' :: Int -> [[a]] -> [[a]]
-getTails' n xss = assert (n > 0) [t | (_:t) <- xss]
-
-x = getTails' 1 []
-
--- HACK give hints for internal variables....
-{- decrease ds_d258 3 @-}
-{- decrease ds_d25g 3 @-}
-
--- TransformRec BUG: this causes some weird unused variable error (occurrence of DEAD ID)?
-getTails'' :: Int -> [[a]] -> [[a]]
-getTails'' n xss = [t | (_:t) <- xss]
-
-y = getTails'' 1 []
diff --git a/tests/pos/Anftest.hs b/tests/pos/Anftest.hs
deleted file mode 100644
--- a/tests/pos/Anftest.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-module Anftest () where
-
--- xs :: [Int]
--- xs = let x0 = 0
---          x1 = 1
---          x2 = 2
---          x3 = 3
---          x4 = 4
---          x5 = 5
---          x6 = 6
---          x7 = 7
---          x8 = 8
---          x9 = 9
---      in [x0, x1, x2, x3, x4, x5, x6, x7, x8, x9]
-
-xs :: [Int]
-xs = let x0 = 0
-         x1 = 1
-     in [x0, x1]
-
-ys :: [Int]
-ys = [y0, y1]
-     where y0 = 0
-           y1 = 1
-
-{-@ incr :: x: Int -> {v: Int | v > x} @-}
-incr :: Int -> Int
-incr y = y + length xs 
-  
diff --git a/tests/pos/Anish1.hs b/tests/pos/Anish1.hs
deleted file mode 100644
--- a/tests/pos/Anish1.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module Anish1 () where
-
-inc :: Int -> Int
-inc xoooo = xoooo + 1
-
-test1 :: Int -> Int
-test1 nine = let b = 0 <= nine in
-          if b then
-            let a = inc nine
-            in
-               div nine a
-          else
-            1
diff --git a/tests/pos/Assume.hs b/tests/pos/Assume.hs
deleted file mode 100644
--- a/tests/pos/Assume.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module Assume where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ assume foo :: {v:Bool | v} @-}
-foo = False
-
-bar = liquidAssertB foo
diff --git a/tests/pos/AssumedRecursive.hs b/tests/pos/AssumedRecursive.hs
deleted file mode 100644
--- a/tests/pos/AssumedRecursive.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module AssumedRecursive where
-
-{-@ lazy foo @-}
-{-@ assume foo :: a -> a @-}
-foo :: a -> a
-foo f = foo f
diff --git a/tests/pos/AutoSize.hs b/tests/pos/AutoSize.hs
deleted file mode 100644
--- a/tests/pos/AutoSize.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-module AutoSize where
-
-{-@ autosize List @-}
-data List a = N | Cons a (List a)
-nil = N
-cons = Cons 
-
-foo :: List a -> Int 
-foo N = 0 
-foo (Cons x xs) = 1 + foo xs 
-
-
-{-@ autosize Exp @-}
-data Exp = EConst Int | EBinOp Int Exp Exp 
-expSize :: Exp -> Int
-expSize (EConst _) = 0
-expSize (EBinOp _ e1 e2) = 1 + (expSize e1) + (expSize e2)
diff --git a/tests/pos/AutoTerm.hs b/tests/pos/AutoTerm.hs
deleted file mode 100644
--- a/tests/pos/AutoTerm.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-module AutoTerm where
-
-data SortedList a =
-     Mt
-   | Ln{h :: a, t :: SortedList a}
-
-{-@ data SortedList [sortedlen] @-}
-
-
-{-@ measure sortedlen @-}
-{-@ sortedlen :: SortedList a -> {v:Int | v >= 0 } @-}
-sortedlen :: SortedList a -> Int
-sortedlen Mt = 0
-sortedlen (Ln x xs) = 1 + sortedlen xs
-
-{-@ insert :: (Ord a) => a -> lst:(SortedList a) -> {v: SortedList a | sortedlen v = sortedlen lst + 1} / [sortedlen lst]@-}
-insert :: (Ord a) => a -> SortedList a -> SortedList a
-insert x Mt = Ln x Mt
-insert y (Ln x xs)
-  | y < x     = Ln y (Ln x xs)
-  | otherwise = Ln x (insert y xs)
-
-{-@ isort :: (Ord a) => lst:[a] -> {v : SortedList a | sortedlen v = len lst} @-}
-isort :: (Ord a) => [a] -> SortedList a
-isort [] = Mt -- note can't use [] here
-isort (x:xs) = insert x (isort xs)
diff --git a/tests/pos/AutoTerm1.hs b/tests/pos/AutoTerm1.hs
deleted file mode 100644
--- a/tests/pos/AutoTerm1.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-module AutoTerm1 where
-
-data F = F | C Int F  
-
-{-@ data F [lenF] @-}
-
-{-@ measure lenF @-}
-lenF :: F -> Int
-
-
-{-@ lenF :: xs:F -> {v:Int | v >= 0 } @-}
-lenF F = 0
-lenF (C _ x) = 1 + lenF x 
-
-
-bar :: F -> Int 
-bar F = 0 
-bar (C x xs) = x + bar xs 
diff --git a/tests/pos/Automate.hs b/tests/pos/Automate.hs
deleted file mode 100644
--- a/tests/pos/Automate.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-module Automate where
-   
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple"        @-}
-
-import Language.Haskell.Liquid.ProofCombinators 
-
-fibA :: Int -> Int 
-{-@ reflect fibA @-}
-{-@ fibA :: Nat -> Nat @-}
-fibA i | i <= 1 = i
-      | otherwise = fibA (i-1) + fibA (i-2)
-
--- fibUp :: Int -> Proof 
-{- fibUp :: i:Nat -> {fibA i <= fibA (i+1)} @-}
--- fibUp i 
--- | i <= 2    = trivial
--- | otherwise = fibUp (i-1) &&& fibUp (i-2) *** QED 
-
-
-fibUp :: Int -> Proof
-{-@ fibUp :: i:Nat -> {fibA i <= fibA (i+1)} @-}
-fibUp 0 = trivial *** QED
-fibUp 1 = trivial *** QED
-fibUp i = fibUp (i-1) &&& fibUp (i-2) *** QED 
-
-{- prop :: () -> {fibA 30 == 832040 } @-}
--- prop :: () -> Proof 
--- prop _ = trivial  
diff --git a/tests/pos/Avg.hs b/tests/pos/Avg.hs
deleted file mode 100644
--- a/tests/pos/Avg.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-{-@ LIQUID "--prune-unsorted" @-}
-
-module Avg where
-
-{-@ measure sumF :: [Double] -> Double
-      sumF [] = 0.0
-      sumF (x:xs) = x + (sumF xs)
-  @-}
-
-{-@ measure lenF :: [Double] -> Double
-      lenF []   = 0.0
-      lenF (x:xs) = (1.0) + (lenF xs)
-  @-}
-
-{-@ expression Avg Xs = ((sumF Xs) / (lenF Xs))  @-}
-
-{-@ meansD :: xs:{v:[Double] | 0.0 < lenF v } -> {v:Double | v = Avg xs} @-}
-meansD :: [Double] -> Double
-meansD xs = sumD xs / lenD xs
-
-{-@ lenD :: xs:[Double] -> {v:Double | v = lenF xs } @-}
-lenD :: [Double] -> Double
-lenD [] = 0.0
-lenD (x:xs) = 1.0 + lenD xs
-
-{-@ sumD :: xs:[Double] -> {v:Double | v = sumF xs } @-}
-sumD :: [Double] -> Double
-sumD [] = 0.0
-sumD (x:xs) = x + sumD xs
diff --git a/tests/pos/BST.hs b/tests/pos/BST.hs
deleted file mode 100644
--- a/tests/pos/BST.hs
+++ /dev/null
@@ -1,82 +0,0 @@
-{-@ LIQUID "--no-totality" @-}
-
-module BST (blen) where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@
-data Bst [blen] k v  x1:k -> Bool, r :: x0:k -> x1:k -> Bool>
-  = Empty
-  | Bind { bKey   :: k
-         , bValue :: v
-         , bLeft  :: Bst  (k ) v
-         , bRight :: Bst  (k ) v }
-  @-}
-
-
-
-{-@ measure blen @-}
-blen :: (Bst k v) -> Int
-{-@ blen :: (Bst k v) -> Nat @-}
-blen(Empty)        = 0
-blen(Bind k v l r) = 1 + (blen l) + (blen r)
-
-data Bst k v = Empty | Bind k v (Bst k v) (Bst k v)
-
-{-@
-data Pair k v 
 x1:k -> Bool, l :: x0:k -> x1:k -> Bool, r :: x0:k -> x1:k -> Bool>
-  = P (fld0 :: k) (fld1 :: v) (tree :: Bst  (k 
) v)
-  @-}
-
-data Pair k v = P k v (Bst k v)
-
--- insert :: (Eq k, Ord k) => k -> v -> Bst k v -> Bst k v
-insert k v Empty  = Bind k v Empty Empty
-insert k v (Bind k' v' l r)
-  | k == k'       = Bind k v l r
-  | k < k'        = Bind k' v' (insert k v l) r
-  | otherwise     = Bind k' v' l (insert k v r)
-
--- delete :: (Eq k, Ord k) => k -> Bst k v -> Bst k v
-delete _ Empty = Empty
-delete k' (Bind k v l r)
-  | k' == k =
-      case r of
-       Empty   -> l
-       _       -> let P kmin vmin r' = getMin r in Bind kmin vmin l r'
-  | k' < k = Bind k v (delete k' l) r
-  | otherwise = Bind k v l (delete k' r)
-
-getMin (Bind k v Empty rt) = P k v rt
-getMin (Bind k v lt rt)    = P k0min v0min (Bind k v l' rt)
-   where P k0min v0min l' = getMin lt
-getMin _                   = unsafeError "getMin"
-
-chkMin x Empty            = liquidAssertB True
-chkMin x (Bind k v lt rt) = liquidAssertB (x insert k v t) Empty
-
-prop        = chk bst
-prop1       = chk $ mkBst $ zip [1..] [1..]
-propDelete  = chk $ delete 1 bst
-propMin     = chkMin x t
-    where pr  = getMin bst
-          P x _ t = pr
diff --git a/tests/pos/BST000.hs b/tests/pos/BST000.hs
deleted file mode 100644
--- a/tests/pos/BST000.hs
+++ /dev/null
@@ -1,69 +0,0 @@
-{-@ LIQUID "--no-totality" @-}
-module BST000 where
-
-import Language.Haskell.Liquid.Prelude
-
-
-{-@
-data Bst [blen] k v  x1:k -> Bool, r :: root:k -> x1:k -> Bool>
-  = Empty
-  | Bind (key   :: k) 
-         (value :: v) 
-         (left  :: Bst  (k ) v) 
-         (right :: Bst  (k ) v)
-  @-}
-
-{-@ measure blen @-}
-{-@ lazy blen @-}
-{-@ blen :: Bst k v -> Nat  @-}
-blen :: Bst k v -> Int
-blen Empty = 0 
-blen (Bind k v l r) = 1 + blen l + blen r 
-
-data Bst k v = Empty | Bind k v (Bst k v) (Bst k v)
-
-{-@ type OBST k a = Bst <{\root v -> v < root }, {\root v ->  v > root}> k a @-}
-
-{-@ chkMin :: (Ord k) => x:k -> OBST {v:k | x < v} a -> Bool @-}
-chkMin :: (Ord k) => k -> Bst k a -> Bool
-chkMin x Empty            = liquidAssertB True  
-chkMin x (Bind k v lt rt) = liquidAssertB (x x1:k -> Bool, l :: x0:k -> x1:k -> Bool, r :: x0:k -> x1:k -> Bool>
-  = P (fld0 :: k) (fld1 :: v) (tree :: Bst  (k 
) v) 
-  @-}
-
-data Pair k v = P k v (Bst k v)
-
-{-@ getMin :: OBST k v -> (k, OBST k v)<\x -> {v:Bst {k:k | x < k} v | true}>@-}
-getMin :: Bst k v -> (k, Bst k v)
-getMin (Bind k v Empty rt) = (k, rt)
-{- 
-getMin (Bind k v lt rt)    = case getMin lt of
-                               (k0, l') -> (k0, Bind k v l' rt) 
-getMin _                   = error "getMin"
--}
-{-@ propMin :: (Ord k) => OBST k a -> Bool @-}
-propMin :: (Ord k) => Bst k a -> Bool
-propMin bst = chkMin x t
-    where (x, t) = getMin bst 
-
-
-zoo :: Int -> (Int, Int)
-zoo x = (x, x + 1)
-
-
-m = zoo 12
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/pos/Bag1.hs b/tests/pos/Bag1.hs
deleted file mode 100644
--- a/tests/pos/Bag1.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-module Bag1 where
-
-import qualified Data.Set as S
-import Language.Haskell.Liquid.Bag as B
-
-{-@ zorg :: {v:B.Bag Int | v = B.empty} @-}
-zorg :: B.Bag Int
-zorg = B.empty
-
-{-@ measure elems @-}
-elems :: (Ord a) => [a] -> B.Bag a
-elems []     = B.empty
-elems (x:xs) = B.put x (elems xs)
-
-{-@ prop0 :: x:_ -> TT @-}
-prop0 :: Int -> Bool
-prop0 x = (B.get x b == 4) 
-  where
-    a   = elems [x, x]
-    b   = B.union a a 
diff --git a/tests/pos/BangPatterns.hs b/tests/pos/BangPatterns.hs
deleted file mode 100644
--- a/tests/pos/BangPatterns.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-module BangPatterns where
-
-import Data.IORef
-
-import Language.Haskell.Liquid.Prelude
-
-foo :: IORef a -> IORef a
-{-@ foo :: x:IORef a -> {v:IORef a |  v = x} @-}
-foo !x = x
diff --git a/tests/pos/BinarySearch.hs b/tests/pos/BinarySearch.hs
deleted file mode 100644
--- a/tests/pos/BinarySearch.hs
+++ /dev/null
@@ -1,43 +0,0 @@
-{- | By Gabriel Gonzalez, from:
-     http://www.haskellforall.com/2015/12/compile-time-memory-safety-using-liquid.html
--}
-
-module BinarySearch (binarySearch) where
-
-import Data.Vector as V
-
-binarySearch :: Ord a => a -> V.Vector a -> Maybe Int
-binarySearch x v =
-    if V.length v == 0
-    then Nothing
-    else loop x v 0 (V.length v - 1)
-
-midpoint :: Int -> Int -> Int
-midpoint lo hi = (lo + hi) `div` 2
-
-{-@
-loop
-    :: Ord a
-    => x  : a
-    -> v  : V.Vector a
-    -> lo : { lo : Int | 0  <= lo && lo < vlen v }
-    -> hi : { hi : Int | lo <= hi && hi < vlen v }
-    -> Maybe Int
-    / [hi - lo]
-@-}
-loop :: Ord a => a -> V.Vector a -> Int -> Int -> Maybe Int
-loop x v lo hi = do
-    let mid = lo + ((hi - lo) `div` 2) -- midpoint lo hi
-    if x < v ! mid
-    then do
-        let hi' = mid - 1
-        if lo <= hi'
-        then loop x v lo hi'
-        else Nothing
-    else if v ! mid < x
-    then do
-        let lo' = mid + 1
-        if lo' <= hi
-        then loop x v lo' hi
-        else Nothing
-    else Just mid
diff --git a/tests/pos/BinarySearchOverflow.hs b/tests/pos/BinarySearchOverflow.hs
deleted file mode 100644
--- a/tests/pos/BinarySearchOverflow.hs
+++ /dev/null
@@ -1,42 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-
-module BinarySearchOverflow where
-
-import Prelude hiding (Num(..))
-import CheckedNum 
-import Data.Vector as V 
-import Language.Haskell.Liquid.Prelude (liquidAssert) 
-
-{-@ invariant {v: V.Vector a | 0 <= vlen v && BoundInt (vlen v)} @-}
-
-binarySearch :: Ord a => a -> V.Vector a -> Maybe Int
-binarySearch x v 
-  | 0 < n     = loop x v 0 (n - 1)
-  | otherwise = Nothing 
-  where n     = V.length v
-
-{-@ type Idx Vec = {v:Nat | v < vlen Vec} @-}
-
-{-@ type BoundNat = {v:Nat | BoundInt v} @-}
-
-{-@ loop :: Ord a => a -> vec: V.Vector a -> lo:Idx vec -> {hi:Idx vec | lo <= hi} -> Maybe Nat @-}
-loop :: Ord a => a -> V.Vector a -> Int -> Int -> Maybe Int
-loop x v lo hi = do
-    let mid = lo + ((hi - lo) `div` 2) -- SAFE
-    -- let mid =  (hi + lo) `div` 2       -- UNSAFE
-    if x < v ! mid
-    then do
-        let hi' = mid - 1
-        if lo <= hi'
-        then loop x v lo hi'
-        else Nothing
-    else if v ! mid < x
-    then do
-        let lo' = mid + 1 -- incr mid
-        if lo' <= hi
-        then loop x v lo' hi
-        else Nothing
-    else Just mid
-    
-
-
diff --git a/tests/pos/Books.hs b/tests/pos/Books.hs
deleted file mode 100644
--- a/tests/pos/Books.hs
+++ /dev/null
@@ -1,50 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-#define DISCOUNT_PERCENTAGE   2
-#define BOOK_THRESHOLD        2
-
-module Books where
-
-calculateDiscount' :: Customer -> Int -> Int
-
----------------------------------------------------------------------------------------
--- 1. Define: Types of customers
----------------------------------------------------------------------------------------
-
-data Customer = Vip | Reg deriving (Eq)
-
----------------------------------------------------------------------------------------
--- 2. Define: Discountable Customers and Discounts
----------------------------------------------------------------------------------------
-
-{-@ inline customerGetsDiscount @-}
-customerGetsDiscount :: Customer -> Int -> Bool
-customerGetsDiscount c i = c == Vip && i >= BOOK_THRESHOLD
-
-{-@ inline discount @-}
-discount :: Int -> Int
-discount bookCount = (bookCount - BOOK_THRESHOLD) * DISCOUNT_PERCENTAGE
-
-{-@ type Discount i = {v:Int | v == discount i} @-}
-
----------------------------------------------------------------------------------------
--- 3. Policy: Only compute discounts for discountable customers
----------------------------------------------------------------------------------------
-
-{-@ calculateDiscount' :: c:Customer -> i:{Int | customerGetsDiscount c i} -> Discount i @-}
-calculateDiscount' c i = discount i
-
----------------------------------------------------------------------------------------
--- 4. Implement: Code to compute discounts, if suitable, is accepted
----------------------------------------------------------------------------------------
-
-{-@ calculateDiscount :: Int -> Nat -> Nat @-}
-calculateDiscount userId bookCount
-  | getsDiscount = calculateDiscount' c bookCount
-  | otherwise    = 0
-  where
-    getsDiscount = customerGetsDiscount c bookCount
-    c            = customerType userId
-
-customerType :: Int -> Customer
-customerType = undefined
diff --git a/tests/pos/Bool0.hs b/tests/pos/Bool0.hs
deleted file mode 100644
--- a/tests/pos/Bool0.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-module Bool0 where
-
-{-@ myhead :: {v:[a] | nonEmpty v} -> a @-}
-myhead (x:_) = x
-
-{-@ measure nonEmpty @-}   
-nonEmpty :: [a] -> Bool
-nonEmpty (x:xs) = True 
-nonEmpty []     = False
-
-
-
-
-
-
-
diff --git a/tests/pos/Bool1.hs b/tests/pos/Bool1.hs
deleted file mode 100644
--- a/tests/pos/Bool1.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module Bool1 where
-
-{-@ baz :: x:Bool -> {v:Bool | v == x} @-}
-baz :: Bool -> Bool 
-baz x = x 
diff --git a/tests/pos/Bool2.hs b/tests/pos/Bool2.hs
deleted file mode 100644
--- a/tests/pos/Bool2.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-module Bool2 where
-
-
-{-@ gerb :: (Ord a) => x:a -> {v:a | x <= v } -> {v:a | x <= v} @-}
-gerb :: (Ord a) => a -> a -> a 
-gerb x y = y 
-
- 
-moo = gerb False False 
diff --git a/tests/pos/Bounds1.hs b/tests/pos/Bounds1.hs
deleted file mode 100644
--- a/tests/pos/Bounds1.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-module Bounds1 where
-
-{-
-Interesting example as subtyping of bounds is instantiated
-with function types!
--}
-
-zipWith :: (b -> Char -> a) 
-        -> b -> b -> a
-zipWith f =  (bar . f)
-
-bar :: (Char -> c) -> a -> c
-bar = undefined
-
diff --git a/tests/pos/Case_lambda_join.hs b/tests/pos/Case_lambda_join.hs
deleted file mode 100644
--- a/tests/pos/Case_lambda_join.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-{-@ LIQUID "--no-totality" @-}
-{-@ LIQUID "--no-termination"   @-}
-
-module Case_lambda_join where
-
-import Language.Haskell.Liquid.Prelude
-import Data.Set (Set (..))
-
-data RBTree a = Leaf | Node Color a !(RBTree a) !(RBTree a)
-data Color    = B | R deriving (Eq)
-
-{-@ rbalBAD, rbalOK :: k:_ -> l:_ -> r:_ -> {v:_ | Join v k l r} @-}
-rbalBAD x l r = case r of
-  Node R y b (Node R z c d) -> unsafeError "ASD" -- Node R y (Node B x l b) (Node B z c d)
-  Node R z (Node R y b c) d -> Node R y (Node B x l b) (Node B z c d)
-
-rbalOK x l r = case r of
-  -- Node R y b (Node R z c d) -> Node R y (Node B x l b) (Node B z c d)
-  Node R z (Node R y b c) d -> Node R y (Node B x l b) (Node B z c d)
-
-{-@ measure elems :: RBTree a -> (Set a)
-      elems Leaf         = (Set_empty 0)
-      elems (Node c k l r) = (Set_cup (Set_sng k) (Set_cup (elems l) (elems r))) 
-  @-}
-
-{-@ predicate Union V L R  = elems V = Set_cup (elems L) (elems R)                       @-}
-{-@ predicate Join V X L R = elems V = Set_cup (Set_sng X) (Set_cup (elems L) (elems R)) @-}
diff --git a/tests/pos/CasesToLogic.hs b/tests/pos/CasesToLogic.hs
deleted file mode 100644
--- a/tests/pos/CasesToLogic.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-{-@ LIQUID "--exact-data-cons"     @-}
-{-@ LIQUID "--higherorder"        @-}
-
-module CasesToLogic where
-
-import Prelude hiding (mappend)
-
-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
-
diff --git a/tests/pos/Cat.hs b/tests/pos/Cat.hs
deleted file mode 100644
--- a/tests/pos/Cat.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-# OPTIONS_GHC -Wno-missing-methods #-}
-{-@ LIQUID "--no-totality" @-}
-
-{-# LANGUAGE GADTs #-}
-
-module Cat where
-
-import Control.Category
-import Prelude hiding ((.), id)
-
-
-{-
-class Category cat where
-  id :: cat a a
-  (.) :: cat b c -> cat a b -> cat a c
--}
-
-data Accum a b where
-  Accum :: s -> Accum a b
-
--- | We can pass the outputs of one 'Accum' as the inputs of the next.
-instance Category Accum where
-  Accum  i1 . Accum  i2 = Accum  (i1, i2)
diff --git a/tests/pos/CharLiterals.hs b/tests/pos/CharLiterals.hs
deleted file mode 100644
--- a/tests/pos/CharLiterals.hs
+++ /dev/null
@@ -1,8 +0,0 @@
--- see #1286 
-module CharLiterals where
-
-{-@ fails :: {v:Bool | v} @-}
-fails =  'a' == 'a'
-
-{-@ ok :: {v:Bool | v} @-}
-ok = "a" == "a"
diff --git a/tests/pos/CheckedNum.hs b/tests/pos/CheckedNum.hs
deleted file mode 100644
--- a/tests/pos/CheckedNum.hs
+++ /dev/null
@@ -1,24 +0,0 @@
-module CheckedNum where
-
--- Hiding numeric operations, because they get by default translated to SMT equivalent
-import Prelude hiding (Num(..))
-
-import qualified Prelude as Prelude
-
-class CheckedNum a where
-  (+) :: a -> a -> a
-  (-) :: a -> a -> a
-
-{-@ predicate BoundInt X = 0 < X + 10000 && X < 10000 @-}
-
-instance CheckedNum Int where
-{-@ instance CheckedNum Int where
-      - :: x:Int -> y:{v:Int | BoundInt (x - v)} -> {v: Int | v == x - y} ;
-      + :: x:Int -> y:{v:Int | BoundInt (x + v)} -> {v: Int | v == x + y}
-  @-}
-    x - y = (Prelude.-) x y
-
-    x + y = (Prelude.+) x y
-
-
-
diff --git a/tests/pos/CheckedNumLib.hs b/tests/pos/CheckedNumLib.hs
deleted file mode 100644
--- a/tests/pos/CheckedNumLib.hs
+++ /dev/null
@@ -1,24 +0,0 @@
-module CheckedNumLib where
-
--- Hiding numeric operations, because they get by default translated to SMT equivalent
-import Prelude hiding (Num(..))
-
-import qualified Prelude as Prelude 
-
-class CheckedNum a where 
-  (+) :: a -> a -> a 
-  (-) :: a -> a -> a 
-
-{-@ predicate BoundInt X = 0 < X + 10000 && X < 10000 @-}
-
-instance CheckedNum Int where
-{-@ instance CheckedNum Int where 
-      - :: x:Int -> y:{v:Int | BoundInt (x - v)} -> {v: Int | v == x - y} ;  
-      + :: x:Int -> y:{v:Int | BoundInt (x + v)} -> {v: Int | v == x + y} 
-  @-}
-	x - y = (Prelude.-) x y  
-
-	x + y = (Prelude.+) x y  
-
-
-
diff --git a/tests/pos/Chunks.hs b/tests/pos/Chunks.hs
deleted file mode 100644
--- a/tests/pos/Chunks.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-module Chunks where
-
-{-@ LIQUID "--scrape-imports" @-}
-
-
-{-@ type SafeChunkSize = {v:Int | 1 < v } @-}
-
-{-@ type Pos = {v:Int | 0 < v} @-}
-
-{-@ 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))            
-  @-}
-
-{-@ chunks :: n:Pos -> xs:[a] -> {v:[[a]] | ValidChunk v xs n } / [len xs] @-}
-chunks :: Int -> [a] -> [[a]]
-chunks _ [] = [] 
-chunks n xs = let (x, xs') = splitAt n xs in x:chunks n xs'
diff --git a/tests/pos/Class.hs b/tests/pos/Class.hs
deleted file mode 100644
--- a/tests/pos/Class.hs
+++ /dev/null
@@ -1,89 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-@ LIQUID "--no-termination" @-}
-module Class () where
-
-import Language.Haskell.Liquid.Prelude
-import Prelude hiding (sum, length, (!!), Functor(..))
--- import qualified Prelude as P
-
-{-@ qualif Size(v:Int, xs:a): v = size xs @-}
-
-{-@ qualif Size(v:Int, xs:MList a): v = size xs @-}
-
-{-@ data MList a = Nil | Cons (hd::a) (tl::(MList a)) @-}
-data MList a = Nil | Cons a (MList a)
-
-{-@ (!!) :: xs:MList a -> {v:Nat | v < (size xs)} -> a @-}
-(!!) :: MList a -> Int -> a
-Nil         !! _ = liquidError "impossible"
-(Cons x _)  !! 0 = x
-(Cons _ xs) !! i = xs !! (i - 1)
-
-{-@ class measure size :: forall a. a -> Int @-}
-
-{-@ class Sized s where
-      size :: forall a. x:s a -> {v:Nat | v = size x}
-  @-}
-class Sized s where
-  size :: s a -> Int
-
-instance Sized MList where
-  {-@ instance measure size :: MList a -> Int
-        size Nil       = 0
-        size (Cons x xs) = 1 + size xs
-    @-}
-  size = length
-
-{-@ length :: xs:MList a -> {v:Nat | v = size xs} @-}
-length :: MList a -> Int
-length Nil         = 0
-length (Cons _ xs) = 1 + length xs
-
-{-@ bob :: xs:MList a -> {v:Nat | v = size xs} @-}
-bob :: MList a -> Int
-bob = length
-
-
-instance Sized [] where
-  {-@ instance measure size :: [a] -> Int
-        size []   = 0
-        size (x:xs) = 1 + (size xs)
-    @-}
-  size [] = 0
-  size (_:xs) = 1 + size xs
-
-{-@ class (Sized s) => Indexable s where
-      index :: forall a. x:s a -> {v:Nat | v < size x} -> a
-  @-}
-class (Sized s) => Indexable s where
-  index :: s a -> Int -> a
-
-
-instance Indexable MList where
-  index = (!!)
-
-{-@ sum :: Indexable s => s Int -> Int @-}
-sum :: Indexable s => s Int -> Int
-sum xs = go max 0
-  where
-    max = size xs
-    go (d::Int) i
-      | i < max   = index xs i + go (d-1) (i+1)
-      | otherwise = 0
-
-
-{-@ sumMList :: MList Int -> Int @-}
-sumMList :: MList Int -> Int
-sumMList xs = go max 0
-  where
-    max = size xs
-    go (d::Int) i
-      | i < max   = index xs i + go (d-1) (i+1)
-      | otherwise = 0
-
-
-{-@ x :: {v:MList Int | (size v) = 3}  @-}
-x :: MList Int
-x = 1 `Cons` (2 `Cons` (3 `Cons` Nil))
-
-foo = liquidAssert $ size (Cons 1 Nil) == size [7]
diff --git a/tests/pos/Class2.hs b/tests/pos/Class2.hs
deleted file mode 100644
--- a/tests/pos/Class2.hs
+++ /dev/null
@@ -1,83 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-@ LIQUID "--no-termination" @-}
-module Class2 () where
-
-import Language.Haskell.Liquid.Prelude
-import Prelude hiding (sum, length, (!!), Functor(..))
-
-data MList a = Nil | Cons a (MList a)
-
-{-@ (!!) :: xs:MList a -> {v:Nat | v < sz xs} -> a @-}
-(!!) :: MList a -> Int -> a
-(Cons x _)  !! 0 = x
-(Cons _ xs) !! i = xs !! (i - 1)
-
-{-@ class measure sz :: forall a. a -> Int  @-}
-
-{-@ class Sized s where
-      size :: forall a. x:s a -> {v:Nat | v = sz x}
-  @-}
-class Sized s where
-  size :: s a -> Int
-
-instance Sized MList where
-  {-@ instance measure sz :: MList a -> Int
-        sz Nil       = 0
-        sz (Cons x xs) = 1 + sz xs
-    @-}
-  size = length
-
-{-@ length :: xs:MList a -> {v:Nat | v = sz xs} @-}
-length :: MList a -> Int
-length Nil         = 0
-length (Cons _ xs) = 1 + length xs
-
-{-@ bob :: xs:MList a -> {v:Nat | v = sz xs} @-}
-bob :: MList a -> Int
-bob = length
-
-
-instance Sized [] where
-  {-@ instance measure sz :: [a] -> Int
-        sz []   = 0
-        sz (x:xs) = 1 + (sz xs)
-    @-}
-  size [] = 0
-  size (_:xs) = 1 + size xs
-
-{-@ class (Sized s) => Indexable s where
-      index :: forall a. x:s a -> {v:Nat | v < sz x} -> a
-  @-}
-class (Sized s) => Indexable s where
-  index :: s a -> Int -> a
-
-
-
-instance Indexable MList where
-  index = (!!)
-
-{-@ sum :: Indexable s => s Int -> Int @-}
-sum :: Indexable s => s Int -> Int
-sum xs = go n 0
-  where
-    n = size xs
-    go (d::Int) i
-      | i < n     = index xs i + go (d-1) (i+1)
-      | otherwise = 0
-
-
-{-@ sumMList :: MList Int -> Int @-}
-sumMList :: MList Int -> Int
-sumMList xs = go max 0
-  where
-    max = size xs
-    go (d::Int) i
-      | i < max   = index xs i + go (d-1) (i+1)
-      | otherwise = 0
-
-
-{-@ mlist3 :: {v:MList Int | sz v = 3}  @-}
-mlist3 :: MList Int
-mlist3 = 1 `Cons` (2 `Cons` (3 `Cons` Nil))
-
-foo = liquidAssert $ size (Cons 1 Nil) == size [1]
diff --git a/tests/pos/ClassReg.hs b/tests/pos/ClassReg.hs
deleted file mode 100644
--- a/tests/pos/ClassReg.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-{-# OPTIONS_GHC -Wno-missing-methods #-}
-{-@ LIQUID "--no-totality" @-}
-
-module ClassReg where
-
-
-data ST s a = ST {runState :: s -> (a,s)}
-
-{-@ data ST s b  b -> Bool> 
-      = ST (runState :: x:s -> (b, s)) @-}
-
-
-class MM m where
-  bind :: m a -> (a -> m b) -> m b
-  cmp  :: m a -> m b -> m b
-
-instance MM (ST s) where
-  cmp m f = bind m (\_ -> f) 
-
-
- 
diff --git a/tests/pos/Client521.hs b/tests/pos/Client521.hs
deleted file mode 100644
--- a/tests/pos/Client521.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module Client521 where
-
-import Lib521 
-
-{-@ bar :: { xs : [a] | size xs > 1 } -> [a] @-}
-bar :: [a] -> [a]
-bar xs = xs 
-
-{-@ bing :: xs:[a] -> {v:Int | v = size xs} @-}
-bing :: [a] -> Int 
-bing [] = 0 
-bing (x:xs) = 1 + bing xs 
diff --git a/tests/pos/ClojurVector.hs b/tests/pos/ClojurVector.hs
deleted file mode 100644
--- a/tests/pos/ClojurVector.hs
+++ /dev/null
@@ -1,104 +0,0 @@
-{-
-https://twitter.com/BrandonBloom/status/701261641971683328
-https://github.com/clojure/clojure/blob/d5708425995e8c83157ad49007ec2f8f43d8eac8/src/jvm/clojure/lang/PersistentVector.java#L148-L164
--}
-
-{-@ LIQUID "--no-termination" @-}
-
-module ClojurVector (height, arrayFor) where
-
-import qualified Language.Haskell.Liquid.Prelude as Gas
-import qualified Data.Vector as V
-
-import Data.Bits
-
--- | Generalized tree with branching 32. We "store" the height in each `Node`
---   only because it is useful in the specification (each sub-tree has the same height).
---   The height is _never_ computed and so can be eliminated at run-time.
-
-data Tree a = Leaf a
-            | Node Int (V.Vector (Tree a))
-
-
--- | Specify "height" of a tree
-
-{-@ measure height @-}
-{-@ height :: Tree a -> Nat @-}
-height :: Tree a -> Int
-height (Leaf _)    = 0
-height (Node h ls) = 1 + h
-
--- | Specify tree must be "balanced", each node has 32 children
-
-{-@ data Tree a = Leaf a
-                | Node { ht   :: Nat
-                       , kids :: VectorN (TreeH a ht) 32
-                       }
-  @-}
-
--- | ListN is a list of a given size N
-
-{-@ type VectorN a N     = {v:V.Vector a | vlen v = N }  @-}
-
--- | TreeH is a tree of given height H
-
-{-@ type TreeH     a H = {v:Tree a | height v = H}       @-}
-
--- | Nodes and Leaves are simply trees with non-zero and zero heights resp.
-
-{-@ type NodeT a = {v:Tree a | height v > 0} @-}
-{-@ type LeafT a = {v:Tree a | height v = 0} @-}
-
-
--- | Vector stores the height
-data Vec a = Vec { vShift  :: Int    -- ^ height
-                 , vTree   :: Tree a -- ^ actual nodes
-                 }
-
--- | Refined type relates height of the `vTree` with `vShift`
-
-{-@ data Vec a = Vec { vShift :: Nat
-                     , vTree  :: TreeLevel a vShift
-                     }
-  @-}
-
-{-@ type TreeLevel a L = {v:Tree a | L = 5 * height v} @-}
-
---------------------------------------------------------------------------------
-
-arrayFor :: Int -> Vec a -> Maybe a
-arrayFor i (Vec l n) = loop i l n
-
-{-@ loop :: i:Int -> level:Int -> TreeLevel a level -> Maybe a @-}
-loop :: Int -> Int -> Tree a -> Maybe a
-loop i level node
-      | level > 0 = let b      = shift i (- level) `mask` 31  -- get child index
-                        node'  = getNode node b               -- get child
-                        level' = level - 5                    -- next level
-                    in
-                        loop i level' node'
-
-      | otherwise = Just (getValue node)
-
--- TODO: refine types of bit-ops, currently use an "assume"
-
-{-@ mask :: x:Int -> y:Nat -> {v:Nat | v <= y} @-}
-mask :: Int -> Int -> Int
-mask x y = Gas.liquidAssume (0 <= r && r <= y) r
-  where
-     r   = x .&. y
-
--- | These are the "cast" operations, except now proven safe.
-
-{-@ getNode :: t:NodeT a -> {v:Nat | v <= 31} -> {v:Tree a | height v = height t - 1}  @-}
-getNode :: Tree a -> Int -> Tree a
-getNode (Node _ ts) n = ts V.! n
-getNode _           _ = impossible "provably safe"
-
-{-@ getValue :: LeafT a -> a @-}
-getValue :: Tree a -> a
-getValue (Leaf x) = x
-getValue _        = impossible "provably safe"
-
-{-@ impossible :: {v:String | false} -> a @-}
-impossible = error
diff --git a/tests/pos/Cmptag0.hs b/tests/pos/Cmptag0.hs
deleted file mode 100644
--- a/tests/pos/Cmptag0.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module Cmptag0 () where
-
-{-@ type OList a = [a]<{\fld v -> (v >= fld)}> @-}
-
-{-@ foo :: (Ord a) => z:a -> OList a -> [{v:a | z <= v}] @-}
-foo y xs = bar y xs
-
-bar :: (Ord a) => a -> [a] -> [a]
-bar y []     = []
-bar y z@(x:xs) = case compare y x of 
-                   EQ -> xs
-                   GT -> bar y xs
-                   LT -> x:xs
diff --git a/tests/pos/Coercion.hs b/tests/pos/Coercion.hs
deleted file mode 100644
--- a/tests/pos/Coercion.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-
-{-@ LIQUID "--no-termination" @-}
-
-module Coercion where
-
-data F a = F a
-data BS = BS (F Int)
-bar :: IO (F Int)
-bar = undefined
-
-foo = undefined
-
-
--- start ::  F Int -> IO BS
-start fp = foo fp $ go
-  where go ptr = do
-         -- ensure :: (IO BS ~ IO b) => IO b -> IO b
-         let ensure act
-               | False = act
-               | otherwise = do
-                   fp' <- bar
-                   start fp -- ((start fp) `cast` (IO BS ~ IO b)) 
-         ensure $ return $ BS fp
-      
-
-
diff --git a/tests/pos/Comma.hs b/tests/pos/Comma.hs
deleted file mode 100644
--- a/tests/pos/Comma.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module Comma where
-
-{-@ measure mysnd @-}
-mysnd :: (a, b) -> b
-mysnd (_, y) = y
-
-{-@ foo :: x:Int -> {v:Int | v == x} @-}
-foo :: Int -> Int 
-foo x = mysnd (x, x)
-
diff --git a/tests/pos/CommentedOut.hs b/tests/pos/CommentedOut.hs
deleted file mode 100644
--- a/tests/pos/CommentedOut.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module CommentedOut where
-
-{- {-@ nats :: [Nat] @-} -}
-nats :: [Int]
-nats = [-1,0,1,2,3,4,5,6,7,8,9,10]
-
diff --git a/tests/pos/Compare.hs b/tests/pos/Compare.hs
deleted file mode 100644
--- a/tests/pos/Compare.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module Compare () where
-
-import Language.Haskell.Liquid.Prelude
-
-foo x y
- = case compare x y of 
-    EQ -> liquidAssertB (x == y)
-    LT -> liquidAssertB (x < y)
-    GT -> liquidAssertB (x > y)
-
-prop = foo n m 
-  where n = choose 0
-        m = choose 1
diff --git a/tests/pos/Compare1.hs b/tests/pos/Compare1.hs
deleted file mode 100644
--- a/tests/pos/Compare1.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module Compare1 () where
-
-import Language.Haskell.Liquid.Prelude
-
-foo x y
- | compare x y == EQ = liquidAssertB (x == y)
- | compare x y == LT = liquidAssertB (x < y)
- | compare x y == GT = liquidAssertB (x >  y)
-
-prop = foo n m 
-  where n = choose 0
-        m = choose 1
diff --git a/tests/pos/Compare2.hs b/tests/pos/Compare2.hs
deleted file mode 100644
--- a/tests/pos/Compare2.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module Compare2 () where
-
-import Language.Haskell.Liquid.Prelude
-
-foo x y
- | compare x y == EQ = liquidAssertB (x == y)
- | otherwise         = liquidAssertB (True)
-
-prop = foo n m 
-  where n = choose 0
-        m = choose 1
diff --git a/tests/pos/CompareConstraints.hs b/tests/pos/CompareConstraints.hs
deleted file mode 100644
--- a/tests/pos/CompareConstraints.hs
+++ /dev/null
@@ -1,86 +0,0 @@
-{-@ LIQUID "--no-totality" @-}
-module CompareConstraints where
-
-import Language.Haskell.Liquid.Prelude
-
-
-{-@ mycmp :: forall 
 Bool, q :: a -> Bool>. 
-           {x::a
, y::a |- a <: {v:a | x <= y} } 
-           Ord a => 
-           [a
] -> [a] -> Bool @-}
-mycmp :: Ord a => [a] -> [a] -> Bool
-mycmp (x:_) (_:y:_) = liquidAssert (x <= y) True
-
-
-{-@ mycmp' :: forall 
 Bool, q :: a -> Bool>. 
-           {x::a
, y::a |- a <: {v:a | x <= y} } 
-           Ord a => 
-           a
 -> a -> Bool @-}
-mycmp' :: Ord a => a -> a -> Bool
-mycmp' x y = liquidAssert (x <= y) True
-
-bar :: Bool
-bar = let w = choose 0 in 
-      let x = w + 1 in 
-      let y = w - 1 in 
-      let z = w + 2 in 
-      mycmp [x, y, x] [z, x, z]
-
-
-bar' :: Bool
-bar' = let w = choose 0 in 
-      let x = w + 1 in 
-      let y = w - 1 in 
-      let z = w + 2 in 
-      mycmp' x z    
-{-
-
------------------
-
-
-data Dyn = Int Int | String String | Bool Bool 
-type Key = String
-data Box = Record Key Dyn
-
-emp :: Box
-emp = undefined
-
-class Value v where
-  toDyn   :: v -> Dyn
-  fromDyn :: Dyn -> v
- 
-put :: (Value v) => Key -> v -> Box -> Box
-put k v b = insert k b (toDyn v) 
-
-get :: (Value v) => Box -> Key -> v
-get = undefined
-
-rj  :: Box
-rj  = put "name"     "Ranjit" 
-    $ put "age"      10
-    $ put "sleeping" True
-    $ emp 
-
-out = "My name is " ++ get rj "name"
-
-
-sumXY box x y = get box x + get box y
-
--}
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- 
diff --git a/tests/pos/Comprehension.hs b/tests/pos/Comprehension.hs
deleted file mode 100644
--- a/tests/pos/Comprehension.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module Comprehension where
-
-{-@ foo :: n:Int -> [{v:Nat | v <= n}] @-}
-foo :: Int -> [Int]
-foo n = [0 .. n]
-
-{-@ assume GHC.Enum.enumFromTo :: (Enum a) => lo:a -> hi:a -> [{v:a | lo <= v && v <= hi}] @-}
diff --git a/tests/pos/ComprehensionTerm.hs b/tests/pos/ComprehensionTerm.hs
deleted file mode 100644
--- a/tests/pos/ComprehensionTerm.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-module ComprehensionTerm (quickSort, foo, qsort) where
-
--- This is a blank file.
-
-{- foo :: xs:[Int] -> {v:[Int] | (len v) = (len xs)} @-}
-foo :: [Int] -> [Int]
-foo []     = []
-foo (x:xs) = (x+1) : foo [y | y <- xs] 
-
-{- qsort :: (Ord a) => xs:[a] -> {v:[a] | (len v) <= (len xs)} @-}
-qsort []     = []
-qsort (x:xs) = x : qsort [y | y <- xs, y < x]
-
-{-@ quickSort    :: (Ord a) => [a] -> SList a @-}
-quickSort []       = []
-quickSort xs@(x:_) = append x lts gts 
-  where 
-    lts          = quickSort [y | y <- xs, y < x]
-    gts          = quickSort [z | z <- xs, z >= x]
-
-{- append :: k:a -> SList {v:a | v SList {v:a | v >= k} -> SList a @-}
-append k []     ys  = k : ys
-append k (x:xs) ys  = x : append k xs ys
-
-{-@ type SList a = [a]<{\x v -> (v >= x)}> @-}
-
diff --git a/tests/pos/Constraints.hs b/tests/pos/Constraints.hs
deleted file mode 100644
--- a/tests/pos/Constraints.hs
+++ /dev/null
@@ -1,51 +0,0 @@
-module Constraints where
-
-{-@ 
-cmp :: forall < pref :: b -> Bool, postf :: b -> c -> Bool
-              , pre  :: a -> Bool, postg :: a -> b -> Bool
-              , post :: a -> c -> Bool
-              >. 
-       {xx::a
, w::b |- c <: c}
-       {ww::a
 |- b <: b}
-       f:(y:b -> c)
-    -> g:(z:a
 -> b)
-    -> x: a
 -> c
-@-}
-
-cmp :: (b -> c)
-    -> (a -> b)
-    ->  a -> c
-
-cmp f g x = f (g x)    
-
-
-
-{-@ incr :: x:Nat -> {v:Nat | v == x + 1} @-}
-incr :: Int -> Int
-incr x = x + 1
-
-
-{-@ incr2 :: x:Nat -> {v:Nat | v == x + 2} @-}
-incr2 :: Int -> Int
-incr2 = cmp incr incr
-
-
-{-@ plus1 :: x:Nat -> {v:Nat | v == x + 20} @-}
-plus1 :: Int -> Int
-plus1 x = x + 20
-
-{-@ plus2 :: x:{v:Nat | v > 10} -> {v:Nat | v == x + 22} @-}
-plus2 :: Int -> Int
-plus2 x = x + 22
-
-{-@ plus42 :: x:Nat -> {v:Nat | v == x + 42} @-}
-plus42 :: Int -> Int
-plus42 = cmp plus2 plus1
-
-
-
-
-
-
-
-
diff --git a/tests/pos/ConstraintsAppend.hs b/tests/pos/ConstraintsAppend.hs
deleted file mode 100644
--- a/tests/pos/ConstraintsAppend.hs
+++ /dev/null
@@ -1,45 +0,0 @@
-module ConstraintsAppend () where
-
-{-@ LIQUID "--no-termination" @-}
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ type OList a = [a]<{\x v -> v >= x}> @-}
-
-
-{-@ assume (++) :: forall 
 Bool, q :: a -> Bool, r :: a -> Bool>.
-        {x::a
 |- a <: {v:a| x <= v}} 
-        {a
 <: a} 
-        {a <: a} 
-        Ord a => OList (a
) -> OList (a) -> OList a @-}
-{-@ app :: forall 
 Bool, q :: a -> Bool, r :: a -> Bool>.
-        {x::a
 |- a <: {v:a| x <= v}} 
-        {a
 <: a} 
-        {a <: a} 
-        Ord a => OList (a
) -> OList (a) -> OList a @-}
-app :: Ord a => [a] -> [a] -> [a]
-app []     ys = ys
-app (x:xs) ys = x:(app xs ys) 
-
-takeL :: Ord a => a -> [a] -> [a]
-{-@ takeL :: Ord a => x:a -> [a] -> [{v:a|v<=x}] @-}
-takeL x []     = []
-takeL x (y:ys) = if (y a -> [a] -> [a]
-{-@ takeGE :: Ord a => x:a -> [a] -> [{v:a|v>=x}] @-}
-takeGE x []     = []
-takeGE x (y:ys) = if (y>=x) then y:(takeGE x ys) else takeGE x ys
-
-
-{-@ quicksort :: (Ord a) => xs:[a] -> [a]<{\fld v -> (v >= fld)}>  @-}
-quicksort []     = []
-quicksort (x:xs) = xsle ++ (x:xsge)
-  where xsle = quicksort (takeL x xs)
-        xsge = quicksort (takeGE x xs)
-
-{-@ qsort :: (Ord a) => xs:[a] -> [a]<{\fld v -> (v >= fld)}>  @-}
-qsort []     = []
-qsort (x:xs) = (qsort [y | y <- xs, y < x]) ++ (x:(qsort [z | z <- xs, z >= x])) 
-
-
diff --git a/tests/pos/Coretologic.hs b/tests/pos/Coretologic.hs
deleted file mode 100644
--- a/tests/pos/Coretologic.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-module Coretologic where
-
-import Data.Set
-
--- ISSUE: can we please allow things like `empty` to also
--- appear in type and alias specifications, not just in
--- measures as in `goo` below?
-
-{-@ type IsEmp a = {v:[a] | Data.Set.fromList v = Data.Set.empty } @-}
-
-{-@ foo :: IsEmp Int @-}
-foo :: [Int]
-foo = []
-
-{-@ measure goo @-}
-goo        :: (Ord a) => [a] -> Set a
-goo []     = empty
-goo (x:xs) = (singleton x) `union` (goo xs)
diff --git a/tests/pos/CountMonad.hs b/tests/pos/CountMonad.hs
deleted file mode 100644
--- a/tests/pos/CountMonad.hs
+++ /dev/null
@@ -1,85 +0,0 @@
-{-@ LIQUID "--no-pattern-inline" @-}
-
-module CountMonad () where
-
-{-@ measure count :: Count a -> Int @-}
-
-{-@ Count :: x:a -> {v:Count a | v == Count x } @-}
-data Count a = Count a
-
-instance Functor Count where
-    fmap = undefined
-instance Applicative Count where
-  pure  = undefined
-  (<*>) = undefined
-
-instance Monad Count where
-{-@
-instance Monad Count where
-  >>=    :: forall  Bool, p :: Count b -> Bool, q :: Count b -> Bool>.
-            {x::Count a <>, y :: Count b <
>  |- {v:Count b | count v == count x + count y} <: Count b <>}
-            Count a <> -> (a -> Count b<
>) -> Count b <> ;
-  >>     :: x:Count a -> y:Count b -> {v:Count b | count v == count x + count y};
-  return :: a -> {v:Count a | count v == 0 }
-@-}
-  return x        = let r = Count x in assertCount 0 (Count x)
-  (Count x) >>= f = let r = f x in assertCount (getCount (Count x) + getCount r) r
-  x >> y = assertCount (getCount x + getCount y) y
-
-
-
-{-@ assume assertCount :: i:Int -> x:Count a -> {v:Count a | v == x && count v == i } @-}
-assertCount :: Int -> Count a -> Count a
-assertCount _ x = x
-
-{-@ assume getCount :: x:Count a -> {v:Int | v == count x } @-}
-getCount :: Count a -> Int
-getCount _ = 0
-
-{-@ makeCount :: x:a -> {v:Count a | v == Count x} @-}
-makeCount = Count
-
-{-@ assume incr :: a -> {v:Count a | count v == 1 } @-}
-incr :: a -> Count a
-incr = Count
-
-{-@ assume unit :: {v:Count () | count v == 0 } @-}
-unit = Count ()
-
-{-@ foo :: a -> {v:Count a | count v == 0 }  @-}
-foo :: a -> Count a
-foo y = return y
-
-{-@ test1 :: {v:Count () | count v == 0 } @-}
-test1 :: Count ()
-test1 = do
-  unit
-  unit
-  unit
-
-{-@ test2 :: {v:Count () | count v == 1 } @-}
-test2 = do
-  unit
-  y <- incr ()
-  unit
-  foo y
-  unit
-
-{-@ test3 :: {v:Count () | count v == 3 } @-}
-test3 = do
-  unit
-  incr ()
-  unit
-  incr ()
-  unit
-  incr ()
-  unit
-
-
-
-{-@ replicateTick :: n:Nat -> a -> {v:Count [a] | count v == n} @-}
-replicateTick :: Int -> a -> Count [a]
-replicateTick 0 x = return []
-replicateTick n x = do incr ()
-                       xs <- replicateTick (n-1) x
-                       return ( x : xs )
diff --git a/tests/pos/Csgordon_issue_296.hs b/tests/pos/Csgordon_issue_296.hs
deleted file mode 100644
--- a/tests/pos/Csgordon_issue_296.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Csgordon_issue_296 where
-
-{-@ measure fwd_extends :: IO () -> IO () -> Bool @-}
-{-@ assume fwd_extends_refl :: m:IO () -> {v:Bool | (fwd_extends m m)} @-}
-fwd_extends_refl :: IO () -> Bool
-fwd_extends_refl = undefined
diff --git a/tests/pos/Cut00.hs b/tests/pos/Cut00.hs
deleted file mode 100644
--- a/tests/pos/Cut00.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-module Cut00 (foo0) where
-
-{-@ foo0 :: Nat -> Nat @-}
-
-foo0 x = 1 + foo1 x
-foo1 x = 1 + foo2 x
-foo2 x = 1 + foo3 x
-foo3 x = 1 + foo4 x
-foo4 x = 1 + foo5 x
-foo5 x = 1 + foo  x
-
-foo :: Int -> Int
-foo x = 1 + x
-
-bar :: Int -> Int
-bar y = y + 10
-
--- foo x = 1 + foo (x - 1)
diff --git a/tests/pos/DB00.hs b/tests/pos/DB00.hs
deleted file mode 100644
--- a/tests/pos/DB00.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-
-{-@ LIQUID "--no-termination" @-}
-{-@ LIQUID "totality" @-}
-
-module DB00 (values) where
-
-{-@ values :: forall  val -> Bool>.
-      k:key -> [Dict  key val]  -> [val] @-}
-values :: key -> [Dict key val]  -> [val]
-values k = map (go k)
-  where
-    {-@ go :: forall  v -> Bool>. 
-              i:k -> Dict  k v -> v  @-}
-    go k (D _ f) = f k
-
-data Dict key val = D {ddom :: [key], dfun :: key -> val}
-
-{-@ data Dict key val  val -> Bool>
-      = D ( ddom :: [key])
-          ( dfun :: i:key -> val)
-  @-}
diff --git a/tests/pos/Data2.hs b/tests/pos/Data2.hs
deleted file mode 100644
--- a/tests/pos/Data2.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-module Data2 (prop_rng1, llen) where
-
-import Control.Applicative
-import Language.Haskell.Liquid.Prelude
-
-data LL a = N | C { headC :: a, tailC :: (LL a) }
-{-@ data LL [llen] a = N | C { headC :: a, tailC :: (LL a) } @-}
-
-{-@ measure llen @-}
-llen :: LL a -> Int 
-{-@ llen :: LL a -> Nat @-}
-llen N = 0 
-llen (C _ xs) = 1 + llen xs 
-
---instance Functor LL where
---  fmap f N                = N
---  fmap f (C jhala jhalas) = C (f jhala) (fmap f jhalas)
-
-lmap f N = N
-lmap f (C jhala jhalas) = C (f jhala) (lmap f jhalas)
-
-range :: Int -> Int -> LL Int
-range i j = C i N
-
-prop_rng1 n   = (liquidAssertB . (0 <=)) `lmap` range 0 n
diff --git a/tests/pos/DataBase.hs b/tests/pos/DataBase.hs
deleted file mode 100644
--- a/tests/pos/DataBase.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-module DataBase where
-
-data Rec s v = R (s -> v)
-type DBRec = Rec String Value
-
-get :: String -> DBRec -> Value 
-get i (R a) = a i
-
-set :: String -> Value -> DBRec -> DBRec
-set i x (R a) = R $ \k -> if k == i then x else a k
-
-{-@ empty :: Rec {v:String|0=1} {v : DataBase.Value | v = DataBase.BOT} @-}
-empty :: Rec String Value
-empty = R $ const BOT
-
-data Value = BOT
-           | INT Int 
-           | BOOL Bool 
-           | STRING String
---            | VEC Value Int
-
-
-append a1 a2 = \k -> case a1 k of 
-                     BOT -> a2 k
-                     v   -> v
diff --git a/tests/pos/DataConQuals.hs b/tests/pos/DataConQuals.hs
deleted file mode 100644
--- a/tests/pos/DataConQuals.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-module DataConQuals () where
-
-data G = G { gx :: Int, gy :: Int }
-
-
--- | We should scrape qualifiers from data definitions; why doesn't it happen
---   "automatically" from the data-con-function signature anyway?
-
-{-@ data G = G { gx :: Int, gy :: {v:Int | v = gx + 5} } @-}
-
-poo :: Int -> Int
-poo n = n + 5
-
--- | `goo` fails because `poo` doesn't have the type `n -> n + 5` because no qual...
-
-{-@ goo :: {v:Int | v = 105} @-}
-goo :: Int
-goo = poo 100
-
--- | But `goo` succeeds if we add `chump` into the mix, because
---   it picks up the qualifers.
-
-{- chump :: z:Int -> {v:Int | v = z + 5} @-}
-chump   :: Int -> Int
-chump z = z + 5
-
-         
diff --git a/tests/pos/Datacon0.hs b/tests/pos/Datacon0.hs
deleted file mode 100644
--- a/tests/pos/Datacon0.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-module Datacon0 (llen) where
-
-import Language.Haskell.Liquid.Prelude
-
-data Foo a = F a a a 
-
-data LL a = N | C a (LL a)
-
-{-@ data LL [llen] @-} 
-
-
-{-@ measure llen @-}
-llen :: LL a -> Int 
-{-@ llen :: LL a -> Nat @-}
-llen N = 0 
-llen (C _ xs) = 1 + llen xs 
-
-lmap f N = N
-lmap f (C x xs) = C (f x) (lmap f xs)
-
-range :: Int -> Int -> LL Int
-range i j = C i N
-
-n = choose 0
-
-prop_rng1 = (liquidAssertB . (0 <=)) `lmap` range 0 n
-
---poo :: LL Int
-poo = C (1 :: Int) 
diff --git a/tests/pos/Datacon1.hs b/tests/pos/Datacon1.hs
deleted file mode 100644
--- a/tests/pos/Datacon1.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module Datacon1 () where
-
-data Foo a = F a a a 
-
-z :: Foo Int
-z = F 1 2 3 
-
diff --git a/tests/pos/Datacon_inv.hs b/tests/pos/Datacon_inv.hs
deleted file mode 100644
--- a/tests/pos/Datacon_inv.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module Datacon_inv where
-
-data T =  A | B
-
-{-@ invariant {v:T | (v = A || v = B)} @-}
-
-thisIsA = A
-thisIsB = B
diff --git a/tests/pos/Deepmeas0.hs b/tests/pos/Deepmeas0.hs
deleted file mode 100644
--- a/tests/pos/Deepmeas0.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-{-@ LIQUID "--pruneunsorted" @-}
-module Deepmeas0 () where
-
-import Language.Haskell.Liquid.Prelude (liquidError)
-import Data.Set
-
-{-@ measure getfst :: (a, b) -> a
-      getfst (x, y) = x
-  @-}
-
-{-@ measure keys :: [(k, v)] -> (Set k) 
-      keys []   = {v | Set_emp v }
-      keys (x:xs) = {v | (v = (Set_cup (Set_sng (getfst x)) (keys xs))) }
-  @-}
-
-{-@ getKeys :: kvs:[(a, b)] -> {v:[a] | ((keys kvs) = (listElts v))} @-}
-getKeys []           = [] 
-getKeys ((x,_) : xs) = x : getKeys xs
-
-{-@ klookup :: forall k v. (Eq k) => k:k -> {v: [(k, v)] | (Set_mem k (keys v))} -> v @-}
-
-klookup k ((k',v):kvs)
-  | k == k'          = v
-  | otherwise        = klookup k kvs
-klookup _ []         = liquidError "Never!"
-
-
-
-
diff --git a/tests/pos/DepData.hs b/tests/pos/DepData.hs
deleted file mode 100644
--- a/tests/pos/DepData.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-{-# LANGUAGE GADTs #-}
-
-module DepData where
-
-data Foo = Foo { thing1 :: Int, thing2 :: Int }
-
-{-@ data Foo where
-      Foo :: pig:Int -> thing2:{v : Int | pig < v} -> Foo
-  @-}
-
-{- data Foo = Foo { thing1 :: Int, thing2 :: {v : Int | thing1 < v } } @-}
-
-{-@ bog :: Foo -> Nat @-}
-bog :: Foo -> Int
-bog (Foo x y) = y - x
diff --git a/tests/pos/DepTriples.hs b/tests/pos/DepTriples.hs
deleted file mode 100644
--- a/tests/pos/DepTriples.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module DepTriples where
-
-{-@ type INCR3 = (Int, Int, Int)<{\a b -> a < b}, {\b a c -> b < c }>@-}
-
-{-@ assume incr3 :: INCR3 @-}
-incr3 :: (Int, Int, Int)
-incr3 = undefined 
-
-{-@ uincr3 :: INCR3 @-}
-uincr3 :: (Int, Int, Int)
-uincr3 = let (x, y, z) = incr3 in (x + 1, y + 1, z +1 )
diff --git a/tests/pos/DependentPairs.hs b/tests/pos/DependentPairs.hs
deleted file mode 100644
--- a/tests/pos/DependentPairs.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-module DependentPairs where
-
-
-{-@ incrPair :: Int -> (x::Int, {v:Int | x <= v}) @-}
-incrPair :: Int -> (Int, Int)
-incrPair i = (i, i+1)
-
-
-{-@ incrPair3 :: Int -> (x::Int, y::{v:Int | x <= v}, {v:Int | y <= v}) @-}
-incrPair3 :: Int -> (Int, Int, Int)
-incrPair3 i = (i, i+1, i+3)
-
-{-@ assertDep :: (Int, Int)<\x -> {v:Int | x <= v}> -> {b:Bool | b} @-}
-assertDep :: (Int, Int) -> Bool 
-assertDep (x, y) = x <= y
-
-
-
-{-@ goalDep :: (x::Int, {v:Int | x <= v}) -> {b:Bool | b} @-}
-goalDep :: (Int, Int) -> Bool 
-goalDep (x, y) = x <= y
diff --git a/tests/pos/DependentPairsFun.hs b/tests/pos/DependentPairsFun.hs
deleted file mode 100644
--- a/tests/pos/DependentPairsFun.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module DependentPairsFun where
-
-
-{-@ ex :: (y::Int, () -> {v:() | 0 < y } )
-      -> (y::Int, {v:() | 0 < y})
-@-}
-ex ::(Int,() -> ()) -> (Int,())
-ex (y, pxToqxy) =  (y,pxToqxy ())
diff --git a/tests/pos/Deptup.hs b/tests/pos/Deptup.hs
deleted file mode 100644
--- a/tests/pos/Deptup.hs
+++ /dev/null
@@ -1,30 +0,0 @@
-module Deptup () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ data Pair a b 
 x1:b -> Bool> = P {pX :: a, pY :: b
 } @-}
-data Pair a b = P a b
-
-
-{-- TODO: mkP :: forall a b 
 b -> Bool>. x: a -> y: b
 -> Pair 
 a b  --}
-
-mkP :: a -> a -> Pair a a
-mkP x y = P x y
-
-incr x = x + 1
-
-baz x  = mkP x (incr x)
-
-chk (P x y) = liquidAssertB (x < y)
-
-prop = chk $ baz n
-  where n = choose 100
-
-
-bazList  xs = map baz xs
-
-n           = choose 0
-
-xs          = [0,1,2,3,4]
-
-prop_baz    = map chk $ bazList xs
diff --git a/tests/pos/Deptup1.hs b/tests/pos/Deptup1.hs
deleted file mode 100644
--- a/tests/pos/Deptup1.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-module Deptup1 () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ data Pair a b 
 x1:b -> Bool> = P {pX :: a, pY :: b
 } @-}
-data Pair a b = P a b
-
-incr        :: Int -> Int
-incr x      = x + 1
-
-baz x       = P x (incr x)
-
-bazList xs  = map baz xs
-
-n           = choose 0
-xs          = [0..n]
-
-chk (P x y) = liquidAssertB (x < y)
-prop_baz    = map chk $ bazList xs
diff --git a/tests/pos/Deptup3.hs b/tests/pos/Deptup3.hs
deleted file mode 100644
--- a/tests/pos/Deptup3.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-module Deptup3 () where
-
-import Language.Haskell.Liquid.Prelude
-
-data Pair a b = P a b
-
-incr :: Int -> Int
-incr x = x + 1
-
-baz    :: Int -> Pair Int Int
-baz x  = P x (incr x)
-
-n :: Int
-n           = choose 0
-
-prop_baz    = chk (baz n)
-
-chk :: Pair Int Int -> Bool
-chk (P x y) = liquidAssertB (x <= y)
diff --git a/tests/pos/DeptupW.hs b/tests/pos/DeptupW.hs
deleted file mode 100644
--- a/tests/pos/DeptupW.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-module DeptupW () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ data Pair a b 
 x1:b -> Bool> = P {pX :: a, pY :: b
 } @-}
-data Pair a b = P a b
-
-{-@ mkP :: forall a  y1:a -> Bool>. x: a -> y: a -> Pair  a a @-}
-mkP :: a -> a -> Pair a a
-mkP x y = P x y
-
-incr :: Int -> Int
-incr x = x + 1
-
-baz x = mkP x (incr x)
-
-chk :: Pair Int Int -> Bool
-chk (P x y) = liquidAssertB (x < y)
-
-prop = chk $ baz n
-  where n = choose 100
diff --git a/tests/pos/Div000.hs b/tests/pos/Div000.hs
deleted file mode 100644
--- a/tests/pos/Div000.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module Div000 (bar) where
-
-{-@ mydiv :: Int -> {v:Int | v /= 0} -> Int @-}
-mydiv :: Int -> Int -> Int
-mydiv = undefined
-
-foo :: Int -> Int
-foo _ = 12
-
-bar :: Int -> Int
-bar m = mydiv m z where z = foo m
diff --git a/tests/pos/Dropwhile.hs b/tests/pos/Dropwhile.hs
deleted file mode 100644
--- a/tests/pos/Dropwhile.hs
+++ /dev/null
@@ -1,82 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-{-@ LIQUID "--no-totality"    @-}
-
-module Dropwhile where
-
-import Language.Haskell.Liquid.Prelude
-import Prelude hiding (head, dropWhile, (.), filter)
-
---main :: IO ()
-foo =  
-  if head (dropWhile ((/=) 3) (1:::2:::3:::Emp)) == 3
-     then ()
-     else liquidError "Not going to happen"
-
--------------------------------------------------------------------------------
--- | The `head` function returns a value that satisfies the abstract refinement
--------------------------------------------------------------------------------
-
-{-@ head ::  forall 
 Bool>. List 
 a -> a
 @-}
-head (x ::: _) = x
-
--------------------------------------------------------------------------------
--- | A List 
--------------------------------------------------------------------------------
-
-data List a = Emp | (:::) { hd :: a
-                          , tl :: List a }
-infixr 5 :::
-
--------------------------------------------------------------------------------
--- | A list whose head satisfies an abstract refinement `p`
--------------------------------------------------------------------------------
-
--- in the below, `hd :: a
` means the "head" is a value of type `a` that
--- additionally, satisfies `p hd`.
-
-{-@ data List a 
 Bool> = Emp
-                                 | (:::) { hd :: a

-                                         , tl :: List a }
-  @-}
-
--- | e.g. a list whose head equals `3`
-
-{-@ type OneList = List <{\v -> v == 3}> Int @-}
-
-{-@ one :: OneList @-}
-one :: List Int
-one = 3 ::: 2 ::: 1 ::: Emp
-
--------------------------------------------------------------------------------
--- | dropWhile some predicate `f` is not satisfied
--------------------------------------------------------------------------------
-
-{-@ dropWhile :: forall 
 Bool, w :: a -> Bool -> Bool>.
-                   {y::a, b::{v:Bool | not v} |- {v:a | v == y} <: a
}
-                   (x:a -> Bool) -> List a -> List 
 a
-  @-}
-dropWhile :: (a -> Bool) -> List a -> List a
-dropWhile f (x:::xs)
-  | not (f x)    = x ::: xs
-  | otherwise    = dropWhile f xs
-dropWhile f Emp  = Emp
-
--- | This `witness` bound relates the predicate used in dropWhile
-
-{-@ bound witness @-}
-witness :: Eq a => (a -> Bool) -> (a -> Bool -> Bool) -> a -> Bool -> a -> Bool
-witness p w = \ y b v -> (not b) ==> w y b ==> (v == y) ==> p v
-
--------------------------------------------------------------------------------
--- | Drop elements until you hit a `3`
--------------------------------------------------------------------------------
-
-{-@ dropUntilOne' :: List Int -> OneList @-}
-dropUntilOne' :: List Int -> List Int
-dropUntilOne' = dropWhile (/= 3)
-
--- | Currently needed for the qual; should be made redundant by `--eliminate`
-
-{-@ eqOne :: x:Int -> {v:Bool | v <=> x /= 3} @-}
-eqOne :: Int -> Bool
-eqOne x = x /= 3
diff --git a/tests/pos/Duplicate_bind.hs b/tests/pos/Duplicate_bind.hs
deleted file mode 100644
--- a/tests/pos/Duplicate_bind.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Duplicate_bind where
-
-import Language.Haskell.Liquid.Prelude
-
-insert key value [] = [(key, value)]
-insert _ _ _        = unsafeError ""
diff --git a/tests/pos/Elements.hs b/tests/pos/Elements.hs
deleted file mode 100644
--- a/tests/pos/Elements.hs
+++ /dev/null
@@ -1,67 +0,0 @@
-{-@ LIQUID "--pruneunsorted" @-}
-module Elements where
-
-import Prelude hiding (elem)
-
-import Data.Set (Set (..))
-
-{-@ append  :: xs:_ -> ys:_ -> {v:_ | UnElts v xs ys} @-}
-append [] ys     = ys
-append (x:xs) ys = x : append xs ys
-
-
-{-@ reverse :: xs:_ -> {v:_ | EqElts v xs} @-}
-reverse xs           = revAcc xs []
-  where
-   revAcc []     acc = acc
-   revAcc (x:xs) acc = revAcc xs (x:acc)
-
-
-
-{-@ nub :: (Eq a) => xs:_ -> {v:_ | nodups v && EqElts v xs} @-}
-nub xs             = go xs []
-  where
-    go (x:xs) l
-      | x `elem` l = go xs l
-      | otherwise  = go xs (x:l)
-    go [] l        = l
-
-
-{-@ elem :: (Eq a) => x:_ -> ys:_ -> {v:Bool | v <=> Set_mem x (elems ys)} @-}
-elem x []     = False
-elem x (y:ys) = x == y || elem x ys
-
-
-
-{-@ find :: (Eq a) => key:_ -> {map:_ | ValidKey key map} -> b @-}
-find key ((k,v):kvs)
-  | key == k  = v
-  | otherwise = find key kvs
-find _ []     = die "Lookup failed!"
-
-
-{-@ die :: {v:String | false} -> b @-}
-die x = error x
-
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
-
-{-@ predicate ValidKey K M    = Set_mem K (keys M)                       @-}
-{-@ predicate EqElts Xs Ys    = elems Xs = elems Ys                      @-}
-{-@ predicate UnElts Xs Ys Zs = elems Xs = Set_cup (elems Ys) (elems Zs) @-}
-
-{-@ measure keys  :: [(a, b)] -> (Set a)
-      keys []     = (Set_empty 0)
-      keys (kv:kvs) = (Set_cup (Set_sng (fst kv)) (keys kvs))
-  @-}
-
-{-@ measure elems :: [a] -> (Set a)
-      elems []    = (Set_empty 0)
-      elems (x:xs)  = (Set_cup (Set_sng x) (elems xs))
-  @-}
-
-{-@ measure nodups :: [a] -> Bool
-      nodups []   = true
-      nodups (x:xs) = (not (Set_mem x (elems xs)) && nodups xs)
-  @-}
diff --git a/tests/pos/Elems.hs b/tests/pos/Elems.hs
deleted file mode 100644
--- a/tests/pos/Elems.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module Elems where
-
-import qualified Data.Set as S
-
-data T a = T a
-
-{-@ measure elems @-}
-elems       :: T a -> S.Set a
-elems (T a) = S.singleton a
-
-{-@ member :: x:a -> t:T a -> {v:Bool | v <=> S.member x (elems t)} @-}
-member :: a -> T a -> Bool
-member = undefined
diff --git a/tests/pos/Elim00.hs b/tests/pos/Elim00.hs
deleted file mode 100644
--- a/tests/pos/Elim00.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-{-@ LIQUID "--no-totality" @-}
-{-@ LIQUID "--short-names"  @-}
-
-module Elim00 where
-
-data Pair a b = PP a b | Emp
-
-data Foo = Foo { xx :: Int, yy :: Int }
-
-{-@ data Foo = Foo {xx :: Int, yy :: {v:Int | xx < v} }  @-}
-
-foo :: Foo -> Foo
-foo (Foo xig yog) = Foo wink cow
-  where
-    PP wink cow   = PP xig yog
-
diff --git a/tests/pos/Elim01.hs b/tests/pos/Elim01.hs
deleted file mode 100644
--- a/tests/pos/Elim01.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module Elim01 (bar) where
-
-{-@ bar :: n:{Int | n > 0} -> {v:Int | v = n + 4 } @-}
-bar :: Int -> Int 
-bar n0 = let 
-            n1 = if (n0 == 0) then 0 else 1 + n0
-            n2 = if (n1 == 0) then 0 else 1 + n1
-            n3 = if (n2 == 0) then 0 else 1 + n2
-            n4 = if (n3 == 0) then 0 else 1 + n3
-         in 
-            n4
diff --git a/tests/pos/Elim_ex_compose.hs b/tests/pos/Elim_ex_compose.hs
deleted file mode 100644
--- a/tests/pos/Elim_ex_compose.hs
+++ /dev/null
@@ -1,11 +0,0 @@
--- TAG: absref 
-
-module Elim_ex_compose (prop) where
-
-{-@ prop :: x:Nat -> {v:Int | v = x + 5} @-}
-prop :: Int -> Int
-prop = incr . incr . incr . incr . incr
-
-{-@ incr :: dog:Int -> {v:Int | v == dog + 1} @-}
-incr :: Int -> Int
-incr cat = cat + 1
diff --git a/tests/pos/Elim_ex_let.hs b/tests/pos/Elim_ex_let.hs
deleted file mode 100644
--- a/tests/pos/Elim_ex_let.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-
-{-# LANGUAGE QuasiQuotes #-}
-
-module Elim_ex_let (prop) where
-
-import LiquidHaskell
-
-[lq| type MyNat = {v:Int | 0 <= v} |]
-
-[lq| prop :: a -> MyNat |]
-prop _ = let x _ = let y = 0 
-                   in
-                     y - 1
-         in 
-           x () + 2
diff --git a/tests/pos/Elim_ex_list.hs b/tests/pos/Elim_ex_list.hs
deleted file mode 100644
--- a/tests/pos/Elim_ex_list.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-@ LIQUID "--no-totality" @-}
-
-{-# LANGUAGE QuasiQuotes #-}
-
-module Elim_ex_list (prop) where
-
-import LiquidHaskell
-import Prelude hiding (head)
-
---------------------------------------------------------------------------
-[lq| prop :: a -> Even |]
-prop _ = (head ys) - 1
-  where 
-    ys = Cons 1 (Cons 3 (Cons 5 Nil))
---------------------------------------------------------------------------
-
-[lq| type Even = {v:Int | v mod 2 == 0 } |]
-
-data List a = Nil | Cons a (List a)
-
-head :: List a -> a 
-head (Cons x _) = x
-
diff --git a/tests/pos/Elim_ex_map_1.hs b/tests/pos/Elim_ex_map_1.hs
deleted file mode 100644
--- a/tests/pos/Elim_ex_map_1.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-
-{-# LANGUAGE QuasiQuotes #-}
-
-module Elim_ex_map_1 (prop) where
-
-import LiquidHaskell
-
-import Prelude hiding (map)
-
---------------------------------------------------------------------------
-[lq| prop :: List Even -> List Even |]
-prop xs = map (+ 1) (map (+ 1) xs)
---------------------------------------------------------------------------
-
-[lq| type Even = {v:Int | v mod 2 == 0 } |]
-
-data List a = Nil | Cons a (List a)
-
-map f Nil         = Nil
-map f (Cons x xs) = Cons (f x) (map f xs)
diff --git a/tests/pos/Elim_ex_map_2.hs b/tests/pos/Elim_ex_map_2.hs
deleted file mode 100644
--- a/tests/pos/Elim_ex_map_2.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-
-{-# LANGUAGE QuasiQuotes #-}
-
-module Elim_ex_map_2 (prop) where
-
-import LiquidHaskell
-
-import Prelude hiding (map)
-
---------------------------------------------------------------------------
-[lq| prop :: List Even -> List Even |]
-prop = map (+ 1) . map (+ 1)
---------------------------------------------------------------------------
-
-[lq| type Even = {v:Int | v mod 2 == 0 } |]
-
-data List a = Nil | Cons a (List a)
-
-map f Nil         = Nil
-map f (Cons x xs) = Cons (f x) (map f xs)
diff --git a/tests/pos/Elim_ex_map_3.hs b/tests/pos/Elim_ex_map_3.hs
deleted file mode 100644
--- a/tests/pos/Elim_ex_map_3.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-
-{-# LANGUAGE QuasiQuotes #-}
-
-module Elim_ex_map_3 (prop) where
-
-import LiquidHaskell
-
-import Prelude hiding (map)
-
---------------------------------------------------------------------------
-[lq| prop :: List Even -> List Even |]
-prop = map ((+ 1) . (+ 1))
---------------------------------------------------------------------------
-
-[lq| type Even = {v:Int | v mod 2 == 0 } |]
-
-data List a = Nil | Cons a (List a)
-
-map f Nil         = Nil
-map f (Cons x xs) = Cons (f x) (map f xs)
diff --git a/tests/pos/Eq_poly_measure.hs b/tests/pos/Eq_poly_measure.hs
deleted file mode 100644
--- a/tests/pos/Eq_poly_measure.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-module Eq_poly_measure () where
-
-import Language.Haskell.Liquid.Prelude 
-
-{-@ data Thing a = P (unThing :: a) @-} 
-data Thing a = P a
-
-property :: Bool
-property = chk t1 
-  where 
-  chk (P x) = liquidAssertB x 
-
-  t1 :: Thing Bool 
-  t1 = P True 
diff --git a/tests/pos/Eqelems.hs b/tests/pos/Eqelems.hs
deleted file mode 100644
--- a/tests/pos/Eqelems.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-module Eqelems where
-
-import qualified Data.Set as S
-
-data T a = T a
-
-{-@ measure elems @-}
-elems       :: T a -> S.Set a
-elems (T a) = S.singleton a
-
-{-@ inline eqelems @-}
-eqelems :: Eq a => T a -> T a -> Bool
-eqelems s t = (elems s) == (elems t)
-         
diff --git a/tests/pos/Eval.hs b/tests/pos/Eval.hs
deleted file mode 100644
--- a/tests/pos/Eval.hs
+++ /dev/null
@@ -1,54 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-{-@ LIQUID "--prune-unsorted" @-}
-
-module Eval (eval) where
-
-import Language.Haskell.Liquid.Prelude (liquidError)
-import Prelude hiding (lookup)
-import Data.Set (Set (..))
-
-{-@ embed Set as Set_Set @-}
-
-type Val  = Int
-
-type Bndr = String
-
-data Expr = Const Int
-          | Var   Bndr
-          | Plus  Expr Expr
-          | Let   Bndr Expr Expr
-
-type Env  = [(Bndr, Val)]
-
-------------------------------------------------------------------
-{-@ lookup :: x:Bndr -> {v:Env | Set_mem x (vars v)} -> Val @-}
-lookup :: Bndr -> Env -> Val
----------------------  -------------------------------------------
-lookup x ((y,v):env)
-  | x == y             = v
-  | otherwise          = lookup x env
-lookup x []            = liquidError "Unbound Variable"
-
-------------------------------------------------------------------
-{-@ eval :: g:Env -> CExpr g -> Val @-}
-------------------------------------------------------------------
-eval env (Const i)     = i
-eval env (Var x)       = lookup x env
-eval env (Plus e1 e2)  = eval env e1 + eval env e2
-eval env (Let x e1 e2) = eval env' e2
-  where
-    env'               = (x, eval env e1) : env
-
-{-@ type CExpr G = {v:Expr | Set_sub (free v) (vars G)} @-}
-
-{-@ measure vars :: Env -> (Set Bndr)
-      vars []    = {v | Set_emp v }
-      vars (b:env) = {v | v = Set_cup (Set_sng (fst b)) (vars env)}
-  @-}
-
-{-@ measure free       :: Expr -> (Set Bndr)
-      free (Const i)     = {v | Set_emp v}
-      free (Var x)       = {v | v = Set_sng x}
-      free (Plus e1 e2)  = {v | v = Set_cup (free e1) (free e2)}
-      free (Let x e1 e2) = {v | v = Set_cup (free e1) (Set_dif (free e2) (Set_sng x))}
-  @-}
diff --git a/tests/pos/EvalQuery.hs b/tests/pos/EvalQuery.hs
deleted file mode 100644
--- a/tests/pos/EvalQuery.hs
+++ /dev/null
@@ -1,104 +0,0 @@
-
-{-@ LIQUID "--reflection"      @-}
-{-@ LIQUID "--no-termination"  @-}
-{-@ LIQUID "--ple" @-}
-
-module EvalQuery where
-
-import Prelude hiding (filter, all)
-
-data Atom  = VarX
-           | VarY
-           | Const Int
-
-data Query = Le  Atom  Atom
-           | And Query Query
-           | Or  Query Query
-
-{-@ data Blob  = B { xVal :: Int, yVal :: Int } @-}
-data Blob  = B { xVal :: Int, yVal :: Int }
-
-{-@ reflect evalA @-}
-evalA :: Atom -> Blob -> Int
-evalA VarX  b     = xVal b
-evalA VarY  b     = yVal b
-evalA (Const n) _ = n
-
-{-@ reflect evalQ @-}
-evalQ :: Query -> Blob -> Bool
-evalQ (Le  a1 a2) b = (evalA a1 b) <= (evalA a2 b)
-evalQ (And q1 q2) b = (evalQ q1 b) && (evalQ q2 b)
-evalQ (Or  q1 q2) b = (evalQ q1 b) || (evalQ q2 b)
-
-{- reflect all @-}
--- all []     = True
--- all (b:bs) = b && all bs
--- evalQs   :: [Query] -> Blob -> Bool
--- evalQs b = e
-
-
-{-@ filter :: f:(a -> Bool) -> [a] -> [{v:a | f v}] @-}
-filter :: (a -> Bool) -> [a] -> [a]
-filter f (x:xs)
-  | f x         = x : filter f xs
-  | otherwise   =     filter f xs
-filter _ []     = []
-
-{-@ filterQ :: q:Query -> [Blob] -> [{b:Blob | evalQ q b}] @-}
-filterQ :: Query -> [Blob] -> [Blob]
-filterQ q = filter (evalQ q)
-
-{-@ test1 :: [Blob] -> [{v: Blob | xVal v <= 10}] @-}
-test1   = filterQ q1
-  where
-  q1    = (VarX `Le` (Const 10))
-
-{-@ test2 :: [Blob] -> [{v: Blob | xVal v <= 10 && yVal v <= 20}] @-}
-test2  = filterQ q2
-  where
-  q2   = (VarX `Le` (Const 10)) `And` (VarY `Le` (Const 20))
-
-{- filterQ :: q:Query -> [Blob] -> [{b:Blob | evalQ q b}] @-}
--- filterQ :: Query -> [Blob] -> [Blob]
--- filterQ q []     = []
--- filterQ q (b:bs)
--- /  | evalQ q b    = b : filterQ q bs
--- /  | otherwise    =     filterQ q bs
-
-{-@ reflect isPos @-}
-isPos :: Int -> Bool
-isPos n = n > 0
-
-{-@ reflect isNeg @-}
-isNeg :: Int -> Bool
-isNeg n = n < 0
-
-{-@ positives :: [Int] -> [{v:Int | v > 0}] @-}
-positives xs = filter isPos xs
-
-{-@ negatives :: [Int] -> [{v:Int | v < 0}] @-}
-negatives xs = filter isNeg xs
-
-
-{- F* version, which doesn't work...
-
-let isPos n = n > 0
-
-val filter : f:('a -> bool) -> list 'a -> list (x:'a{f x}) 
-let rec filter f xs = match xs with 
-    | []    -> []
-    | x::ys -> let zs = filter f ys in 
-               if f x then x :: zs else zs 
-                                   
-type pos = x:int{0 < x}
-
-(* this is verified ... *)
-val pos1 : int -> option pos 
-let pos1 z = if isPos z then Some z else None
-
-(* ... but this is not *)
-val positives : list int -> list pos               
-let positives xs = filter isPos xs  
-
--}
-
diff --git a/tests/pos/Even.hs b/tests/pos/Even.hs
deleted file mode 100644
--- a/tests/pos/Even.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module Even where
-
-{-@ type Even = {v:Int | v mod 2 = 0} @-}
-
-{-@ notEven :: Int -> Even @-}
-notEven :: Int -> Int
-notEven x = x * 2
diff --git a/tests/pos/Even0.hs b/tests/pos/Even0.hs
deleted file mode 100644
--- a/tests/pos/Even0.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module Even0 () where
-
-{-@ isEven :: n:Nat -> Bool / [n, 0]@-}
-{-@ isOdd  :: m:Nat -> Bool / [m, 1] @-}
-isEven, isOdd  :: Int -> Bool
-
-isEven 0 = True
-isEven n = isOdd  $ n - 1
-
-isOdd  k = not $ isEven k
-
-
-
diff --git a/tests/pos/Ex0.hs b/tests/pos/Ex0.hs
deleted file mode 100644
--- a/tests/pos/Ex0.hs
+++ /dev/null
@@ -1,41 +0,0 @@
-{-@ LIQUID "--pruneunsorted" @-}
-{-@ LIQUID "--no-termination" @-}
-
-module Ex0 where
-
--- Testing "existential-types"
-
-{-@ foldN :: forall a 
 x1:a -> Bool>. 
-                (i:Int -> a
 -> a
) 
-              -> n:{v: Int | v >= 0}
-              -> a 
 
-              -> a 

-  @-}
-
-foldN :: (Int -> a -> a) -> Int -> a -> a
-foldN f n = go 0 
-  where 
-    go i x 
-      | i < n     = go (i+1) (f i x)
-      | otherwise = x
-
-{-@ goo :: forall a  x1:a -> Bool>. 
-                (i:Int -> a -> a) 
-              -> i:{v: Int | 0 <= v}
-              -> n:{v: Int | i <= v}
-              -> a  
-              -> a 
-  @-}
-
-goo :: (Int -> a -> a) -> Int -> Int -> a -> a
-goo f i n x 
-  | i < n     = goo f (i+1) n (f i x) 
-  | otherwise = x
-
-
-
-
-{-@ count :: m: {v: Int | v > 0 } -> {v: Int | v = m} @-}
-count :: Int -> Int
-count m = foldN (\_ n -> n + 1) m 0
-
diff --git a/tests/pos/Ex01.hs b/tests/pos/Ex01.hs
deleted file mode 100644
--- a/tests/pos/Ex01.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-
--- | A somewhat fancier example demonstrating the use of Abstract Predicates and exist-types
-
-module Ex01 () where
-
-
--------------------------------------------------------------------------
--- | Data types ---------------------------------------------------------
--------------------------------------------------------------------------
-
-data Vec a = Nil 
-
-{-@ efoldr :: forall b a 
 x1:b -> Bool>. 
-              b 

-              -> ys: Vec a
-              -> b 

-  @-}
-efoldr :: b -> Vec a -> b
-efoldr b Nil         = b
-
diff --git a/tests/pos/Ex1.hs b/tests/pos/Ex1.hs
deleted file mode 100644
--- a/tests/pos/Ex1.hs
+++ /dev/null
@@ -1,64 +0,0 @@
-{-@ LIQUID "--pruneunsorted" @-}
-
--- | A somewhat fancier example demonstrating the use of Abstract Predicates and exist-types
-
-module Ex1 (llen) where
-
--------------------------------------------------------------------------
--- | Data types ---------------------------------------------------------
--------------------------------------------------------------------------
-
-data Vec a = Nil | Cons a (Vec a)
-
-{-@ data Vec [llen] a = Nil | Cons { vx::a, vxs :: Vec a } @-}
-
--- | We can encode the notion of length as an inductive measure @llen@
-
-{-@ measure llen @-}
-llen :: Vec a -> Int
-llen (Nil)       = 0
-llen (Cons x xs) = 1 + llen xs
-
-
--- | As a warmup, lets check that a /real/ length function indeed computes
--- the length of the list.
-
-{-@ sizeOf :: xs:Vec a -> {v: Int | v = llen xs} @-}
-sizeOf             :: Vec a -> Int
-sizeOf Nil         = 0
-sizeOf (Cons _ xs) = 1 + sizeOf xs
-
--------------------------------------------------------------------------
--- | Higher-order fold --------------------------------------------------
--------------------------------------------------------------------------
-
--- | Time to roll up the sleeves. Here's a a higher-order @foldr@ function
--- for our `Vec` type. Note that the `op` argument takes an extra /ghost/
--- parameter that will let us properly describe the type of `efoldr`
-
-{-@ efoldr :: forall a b 
 x1:b -> Bool>.
-                (xs:Vec a -> x:a -> b 
 -> b 
)
-              -> b 

-              -> ys: Vec a
-              -> b 

-  @-}
-efoldr :: (Vec a -> a -> b -> b) -> b -> Vec a -> b
-efoldr op b Nil         = b
-efoldr op b (Cons x xs) = op xs x (efoldr op b xs)
-
--------------------------------------------------------------------------
--- | Clients of `efold` -------------------------------------------------
--------------------------------------------------------------------------
-
--- | Finally, lets write a few /client/ functions that use `efoldr` to
--- operate on the `Vec`s.
-
--- | First: Computing the length using `efoldr`
-{-@ size :: xs:Vec a -> {v: Int | v = llen xs} @-}
-size :: Vec a -> Int
-size = efoldr (\_ _ n -> n + 1) 0
-
--- | Second: Appending two lists using `efoldr`
-{-@ app  :: xs: Vec Int -> ys: Vec Int -> {v: Vec Int | llen v = llen xs + llen ys } @-}
-app :: Vec Int -> Vec Int -> Vec Int
-app xs ys = efoldr (\_ z zs -> Cons z zs) ys xs
diff --git a/tests/pos/ExactADT6.hs b/tests/pos/ExactADT6.hs
deleted file mode 100644
--- a/tests/pos/ExactADT6.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-{-@ LIQUID "--exact-data-con" @-}
-
-{-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-}
-
-module ExactADT6 where
-
-{-@ data EntityField typ where
-        BlobXVal :: EntityField {v:Int | v >= 0}
-        BlobYVal :: EntityField Int
-  @-}
-
-data EntityField typ where
-  BlobXVal :: EntityField Int
-  BlobYVal :: EntityField Int
-
-{-@ blobXVal :: EntityField {v:Int | v >= 0} @-}
-blobXVal :: EntityField Int
-blobXVal = BlobXVal
diff --git a/tests/pos/ExactGADT.hs b/tests/pos/ExactGADT.hs
deleted file mode 100644
--- a/tests/pos/ExactGADT.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-{-# LANGUAGE  GADTs #-}
-
-module ExactGADT where
-
-{-@ data Field typ where
-        FldX :: Field Int
-        FldY :: Field Int
-  @-}
-
-data Field typ where
-  FldX :: Field Int
-  FldY :: Field Int
-
-bob = FldX 
diff --git a/tests/pos/ExactGADT0.hs b/tests/pos/ExactGADT0.hs
deleted file mode 100644
--- a/tests/pos/ExactGADT0.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-{-# LANGUAGE GADTs #-}
-
-{-@ LIQUID "--exact-data-con" @-}
-
-
-module ExactGADT0 where
-
-data Value a where
-  VInt  :: Int  -> Value Int
-  VBool :: Bool -> Value Bool
diff --git a/tests/pos/ExactGADT1.hs b/tests/pos/ExactGADT1.hs
deleted file mode 100644
--- a/tests/pos/ExactGADT1.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-{-@ LIQUID "--exact-data-con" @-}
-
-{-# LANGUAGE  GADTs #-}
-
-module ExactGADT1 where
-
-data Field typ where
-  FldX :: Field Int
-  FldY :: Field Int
-
-poogle = FldY
diff --git a/tests/pos/ExactGADT2.hs b/tests/pos/ExactGADT2.hs
deleted file mode 100644
--- a/tests/pos/ExactGADT2.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-{-@ LIQUID "--exact-data-con" @-}
-
-{-# LANGUAGE  GADTs #-}
-
-module ExactGADT2 where
-
-{-@ data Field typ where
-        FldX :: Field Int
-        FldY :: Field Int
-  @-}
-
-data Field typ where
-  FldX :: Field Int
-  FldY :: Field Int
-
-poogle = FldY
diff --git a/tests/pos/ExactGADT6.hs b/tests/pos/ExactGADT6.hs
deleted file mode 100644
--- a/tests/pos/ExactGADT6.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-{-@ LIQUID "--exact-data-con" @-}
-
-{-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-}
-
-module ExactGADT6 where
-
-class PersistEntity record where
-    data EntityField record ty :: *
-
-instance PersistEntity Blob where
-    {-@ data EntityField Blob 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)
diff --git a/tests/pos/Exp0.hs b/tests/pos/Exp0.hs
deleted file mode 100644
--- a/tests/pos/Exp0.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-
--- small test for playing around with exports.
-
-module Exp0 (f) where
-
-import Language.Haskell.Liquid.Prelude
-
-data Goo = G Int
-
-{-@ data Goo = G (x :: {v:Int | v > 0}) @-}
-
-{-@ f :: Goo -> Goo @-} 
-f (G n) 
-  | n > 0     = G (n +  1)
-  | otherwise = liquidError "ad"
-
diff --git a/tests/pos/Extype.hs b/tests/pos/Extype.hs
deleted file mode 100644
--- a/tests/pos/Extype.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses #-}
-module Extype where
-
-class Show (layout a) => LayoutClass layout a where
-
-data Layout a = forall l. Layout (l a)
-
-
-readsLayout :: Layout a -> String -> Layout a
-readsLayout (Layout l) s = Layout (asTypeOf undefined l)
-
-type Size = Int
-data Step s a = S s a
-
-data Stream a =
-    forall s. Stream
-    (s -> Step s a)             -- stepper function
-    !s                          -- current state
-    !Size                       -- size hint
-
-
-foo :: Stream a -> Size
-foo (Stream _ _ s) = s
-
-
-stream = Stream (\_ -> S 1 True) 0 0
diff --git a/tests/pos/FFI.hs b/tests/pos/FFI.hs
deleted file mode 100644
--- a/tests/pos/FFI.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-{-# LANGUAGE ForeignFunctionInterface #-}
-module FFI where
-
-import Foreign.C.Types
-
-{-@ embed CInt as int @-}
-{-@ embed Integer as int @-}
-
-{-@ assume c_foo :: x:{CInt | x > 0} -> IO {v:CInt | v = x} @-}
-foreign import ccall unsafe "foo.c foo" c_foo
-  :: CInt -> IO CInt
-
-main :: IO ()
-main = print . fromIntegral =<< c_foo 1
diff --git a/tests/pos/Fail.hs b/tests/pos/Fail.hs
deleted file mode 100644
--- a/tests/pos/Fail.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module Fail where
-
-{-@ fail incr @-}
-{-@ incr :: x:Int -> {v:Int |  x < v } @-}
-incr :: Int -> Int 
-incr x = x 
-
-{-@ fail unsafe @-}
-{-@ unsafe :: () -> { 0 == 1 } @-}
-unsafe :: () -> () 
-unsafe _ = () 
diff --git a/tests/pos/FailName.hs b/tests/pos/FailName.hs
deleted file mode 100644
--- a/tests/pos/FailName.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module FailName where
-
-bar = fail
-  where fail = foo
-        foo = 3 -- undefined
-
-
-bar1 = fail ()
-  where fail = foo
-        foo = undefined
diff --git a/tests/pos/FancyMutualTerm.hs b/tests/pos/FancyMutualTerm.hs
deleted file mode 100644
--- a/tests/pos/FancyMutualTerm.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-{-# LANGUAGE GADTs #-}
-module FancyMutualTerm where 
-
-import Language.Haskell.Liquid.This
-
-{-@ measure tsize :: Tree a -> Nat @-}
-{-@ data size (Tree a) tsize @-}
-
-data Tree a where 
-    Leaf :: a -> Tree a 
-    Node :: (Int -> (Tree a)) -> Tree a 
-
-{-@ data Tree a where 
-      Leaf :: a -> {t:Tree a  | tsize t == 0 } 
-      Node :: f:(Int -> Tree a) -> Tree a  @-}
-
-
-{-@ mapTr :: (a -> a) -> t:Tree a -> Tree a / [tsize t, 2] @-}
-mapTr :: (a -> a) -> Tree a -> Tree a 
-mapTr f (Leaf x) = Leaf (f x) 
-mapTr f d@(Node n) = Node (mapTr2 d f n)
-
-
-{-@ mapTr2 :: t:Tree a -> (a -> a) -> (Int -> {tt:Tree a | tsize tt < tsize t }) -> Int -> Tree a / [tsize t, 1] @-} 
-mapTr2 :: Tree a -> (a -> a) -> (Int -> Tree a) -> Int -> Tree a  
-mapTr2 _ f n x = mapTr f (n x)
-
-
diff --git a/tests/pos/FancyTerm.hs b/tests/pos/FancyTerm.hs
deleted file mode 100644
--- a/tests/pos/FancyTerm.hs
+++ /dev/null
@@ -1,39 +0,0 @@
-{-# LANGUAGE GADTs #-}
-module FancyTerm where 
-
-
-data Tree a where 
-    Leaf :: a -> Tree a 
-    Node :: (Int -> (Tree a)) -> Tree a 
-
-{-@ measure tsize :: Tree a -> Nat @-}
-{-@ data size (Tree a) tsize @-}
-
-{-@ data Tree a where 
-      Leaf :: a -> {t:Tree a  | tsize t == 0 } 
-      Node :: f:(Int -> Tree a) -> Tree a   @-}
-
-{-@ mapTr :: (a -> a) -> t:Tree a -> o:Tree a / [tsize t] @-}
-mapTr :: (a -> a) -> Tree a -> Tree a 
-mapTr f (Leaf x) = Leaf $ f x 
-mapTr f (Node n) = Node (\x -> mapTr f (n x)) 
-
-
-
--- With Nat invariant 
-{-@ measure itsize :: ITree a -> Nat @-}
-{-@ data size (ITree a) itsize @-}
-
-data ITree a where 
-    ILeaf :: a -> ITree a 
-    INode :: (Int -> ITree a) -> ITree a 
-
-{-@ data ITree a where 
-      ILeaf :: a -> {t:ITree a  | itsize t == 0 } 
-      INode :: f:(Int -> ITree a) 
-            -> ITree a  @-}
-
-{-@ imapTr :: (a -> a) -> t:ITree a -> o:ITree a / [itsize t] @-}
-imapTr :: (a -> a) -> ITree a -> ITree a 
-imapTr f (ILeaf x) = ILeaf $ f x 
-imapTr f (INode n) = INode (\x -> imapTr f (n x)) 
diff --git a/tests/pos/Fib0.hs b/tests/pos/Fib0.hs
deleted file mode 100644
--- a/tests/pos/Fib0.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-{-@ LIQUID "--higherorder"                         @-}
-{-@ LIQUID "--ple" @-}
-
-module Fib0 where
-
-{-@ reflect fibExp @-}
-{-@ fibExp :: Nat -> Nat @-}
-fibExp :: Int -> Int
-fibExp n 
-  | n == 0    = 0 
-  | n == 1    = 1 
-  | otherwise = fibExp (n-2) + fibExp (n-1)
-
--- 0 => 0
--- 1 => 1 
--- 2 => 1 
--- 3 => 2 
-
-{-@ test :: a -> { fibExp 3 == 2 } @-}  
-test  :: a -> ()
-test _ = ()
diff --git a/tests/pos/FibEq.hs b/tests/pos/FibEq.hs
deleted file mode 100644
--- a/tests/pos/FibEq.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-{-@ LIQUID "--higherorder"                         @-}
-{-@ LIQUID "--ple" @-}
-
-module FibEq where
-
-fibInv  :: Int -> Int -> () 
-fibLin  :: Int -> Int 
-fibLin' :: Int -> Int -> Int -> Int 
-fibExp  :: Int -> Int 
-fibEq   :: Int -> () 
-
--- | Exponential `fib` implementation --------------------------------
-
-{-@ reflect fibExp @-}
-{-@ fibExp :: Nat -> Nat @-}
-fibExp n 
-  | n == 0    = 0 
-  | n == 1    = 1 
-  | otherwise = fibExp (n-2) + fibExp (n-1)
-
--- | Linear `fib` implementation ------------------------------------ 
-
-{-@ reflect fibLin' @-}
-{-@ fibLin' :: Nat -> Nat -> Nat -> Nat @-}
-fibLin' n a b 
-  | n == 0    = b 
-  | otherwise = fibLin' (n - 1) (a + b) a
-
-{-@ reflect fibLin @-}
-{-@ fibLin :: Nat -> Nat @-}
-fibLin n = fibLin' n 1 0
-
--- | Invariant relating the two implementations -------------------- 
-
-{-@ fibInv :: d:Nat -> u:Nat -> 
-      {fibLin' d (fibExp (1+u)) (fibExp u) = fibExp (d+u)} 
-  @-}
-fibInv d u 
-  | d == 0    = () 
-  | otherwise = fibInv (d-1) (u+1)
-
--- | Equivalence of two implementations ---------------------------- 
-
-{-@ fibEq :: n:Nat -> {fibLin n = fibExp n} @-}
-fibEq n = fibInv n 0 
-
-
diff --git a/tests/pos/FilterAbs.hs b/tests/pos/FilterAbs.hs
deleted file mode 100644
--- a/tests/pos/FilterAbs.hs
+++ /dev/null
@@ -1,45 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-{-@ LIQUID "--short-names"    @-}
-
-
-
-module FilterAbs where
-
-import Prelude hiding (filter)
-
-{-@ filter :: forall 
 Bool, q :: a -> Bool -> Bool>.
-                  {y::a, flag::{v:Bool | v} |- {v:a | v = y} <: a
}
-                  (x:a -> Bool) -> [a] -> [a
]
-  @-}
-
-filter :: (a -> Bool) -> [a] -> [a]
-filter f (x:xs)
-  | f x       = x : filter f xs
-  | otherwise = filter f xs
-filter _ []   = []
-
-{-@ isPos :: x:Int -> {v:Bool | v <=> x > 0} @-}
-isPos :: Int -> Bool
-isPos n = n > 0
-
-
-{-@ isNeg :: x:Int -> {v:Bool | v <=> x < 0} @-}
-isNeg :: Int -> Bool
-isNeg n = n < 0
-
-
--- | `positives` works by instantiating:
--- p := \v   -> 0 < v
--- q := \x v -> v <=> 0 < x  (NV ??)
-
-
-{-@ positives :: [Int] -> [{v:Int | v > 0}] @-}
-positives xs = filter isPos xs
-
-
--- | `negatives` works by instantiating:
--- p := \v   -> 0 > v
--- q := \x v -> v <=> x < 0
-
-{-@ negatives :: [Int] -> [{v:Int | v < 0}] @-}
-negatives xs = filter isNeg xs
diff --git a/tests/pos/FingerTree.hs b/tests/pos/FingerTree.hs
deleted file mode 100644
--- a/tests/pos/FingerTree.hs
+++ /dev/null
@@ -1,158 +0,0 @@
-{-@ LIQUID "--reflection"     @-}
-{-@ LIQUID "--ple"            @-}
-
-module FingerTree where
-
-import Language.Haskell.Liquid.ProofCombinators 
-
-{-@ measure digitSize @-}
-digitSize :: Digit a -> Int
-digitSize (One {}) = 1
-digitSize (Two {}) = 2
-digitSize (Three {}) = 3
-digitSize (Four {}) = 4
-
-data Digit a
-    = One a
-    | Two a a
-    | Three a a a
-    | Four a a a a
-    deriving (Show)
-
-data Node a = Node2 {a2::a, b2::a} | Node3 {a3::a, b3::a, c3:: a}
-    deriving (Show)
-
-data FingerTree a
-    = Empty
-    | Single a
-    | Deep (Digit a) (FingerTree (Node a)) (Digit a)
-    deriving Show
-
-{-@ reflect fingerTreeSize @-}
-fingerTreeSize :: FingerTree a -> Int
-fingerTreeSize t = size to1 t 
-
-{-@ reflect size @-}
-size :: (a -> Int) -> FingerTree a -> Int
-size _ Empty        = 0
-size f (Single a)   = f a
-size f (Deep l m r) = digitS f l + size (nodeS f) m + digitS f r
-
-{-@ reflect digitS @-} 
-digitS :: (a -> Int) -> Digit a -> Int
-digitS f (One a)        = f a
-digitS f (Two a b)      = f a + f b
-digitS f (Three a b c)  = f a + f b + f c
-digitS f (Four a b c d) = f a + f b + f c + f d
-
-{-@ reflect nodeS @-}
-nodeS :: (a -> Int) -> Node a -> Int
-nodeS f (Node2 a b)   = f a + f b
-nodeS f (Node3 a b c) = f a + f b + f c
-
-{-@ reflect consts @-}
-consts a b = a
-
-{-@ reflect to1 @-}
-to1 :: a -> Int
-to1 _ = 1
-
-{-@ n2Int1 :: a:Int -> b:Int -> {n:Node Int | nodeS to1 n == 2} @-}
-n2Int1 :: Int -> Int -> Node Int
-n2Int1 a b = Node2 a b
-
--- {-@ n2Int :: a:Int -> b:Int -> {f:(Int -> Int) | f a == 1 && f b == 1} -> {n:Node Int | nodeS f n == 2} @-}
--- n2Int :: Int -> Int -> (Int -> Int) -> Node Int
--- n2Int a b f = Node2 a b
-
-{-@ measure isEmpty @-}
-isEmpty Empty      = True
-isEmpty (Single _) = False
-isEmpty Deep{}     = False
-
-{-@ singleton :: v:Int -> {ft:FingerTree Int | isEmpty ft} @-}
-singleton :: Int -> FingerTree Int
-singleton a = Empty 
-
-{-@ fromList :: xs:_ -> {t:_ | fingerTreeSize t == len xs} @-}
-fromList :: [a] -> FingerTree a
-fromList []     = Empty
-fromList (x:xs) = add x (fromList xs)
-
-{-@ infix <| @-}
--- | /O(1)/. Add an element to the left end of a sequence.
--- Mnemonic: a triangle with the single element at the pointy end.
-{- (<|) :: a -> ft:FingerTree a -> {v : FingerTree a | fingerTreeSize v == fingerTreeSize ft + 1} @-}
-{-@ reflect <| @-}
-(<|) :: a -> FingerTree a -> FingerTree a
-a <| Empty                    =  Single a
-a <| Single b                 =  Deep (One a) Empty (One b)
-a <| Deep (Four b c d e) m sf = {- m `seq` -} Deep (Two a b) (Node3 c d e <| m) sf
-a <| Deep l m r               = Deep (consDigit a l) m r 
-
-{-@ lem_add :: f:_ -> a:_ -> t:_ -> { size f (a <| t) == size f t + f a }  @-}
-lem_add :: (a -> Int) -> a -> FingerTree a -> () 
-
-lem_add f _ Empty       
-  = () 
-
-lem_add f _ (Single {}) 
-  = () 
-
-lem_add f a t@(Deep (Four b c d e) m sf) 
-  =   size f t + f a 
-  === digitS f (Four b c d e) + size (nodeS f) m + digitS f sf + f a
-  === f a + f b + digitS f sf + f c + f d + f e + size (nodeS f) m 
-  === f a + f b + digitS f sf + nodeS f (Node3 c d e) + size (nodeS f) m 
-      ? lem_add (nodeS f) (Node3 c d e) m
-  === f a + f b + digitS f sf + size (nodeS f) ((Node3 c d e) <| m)
-  === size f (Deep (Two a b) ((Node3 c d e) <| m) sf)
-  === size f (a <| (Deep (Four b c d e) m sf)) 
-  === size f (a <| t)
-  *** QED  
-
-lem_add f a t@(Deep l m r)  
-  = () 
-
-{-@ thm_add :: a:_ -> t:_ -> { fingerTreeSize (a <| t) == 1 + fingerTreeSize t} @-}
-thm_add :: a -> FingerTree a -> Proof --  FingerTree a 
-thm_add a t 
-  =   fingerTreeSize (a <| t) 
-  === size to1 (a <| t) 
-    ? lem_add to1 a t
-  === size to1 t + to1 a 
-  === fingerTreeSize t + 1 
-  *** QED
-
-{-@ add :: a:_ -> t:_ -> { v: _ | fingerTreeSize v == 1 + fingerTreeSize t} @-}
-add :: a -> FingerTree a -> FingerTree a 
-add a t = (a <| t) ? thm_add a t 
-
-{-@ measure isFour @-}
-isFour :: Digit a -> Bool 
-isFour (Four {}) = True 
-isFour _         = False 
-
-{-@ reflect consDigit @-}
-{-@ consDigit :: _ -> {d:_ | not (isFour d)} -> _ @-}
-consDigit :: a -> Digit a -> Digit a
-consDigit a (One b)        = Two a b
-consDigit a (Two b c)      = Three a b c
-consDigit a (Three b c d)  = Four a b c d
-
-{-@ ft1 :: {v:_ | fingerTreeSize v == 10} @-}
-ft1 :: FingerTree Int
-ft1 = fromList [1,2,3,4,5,6,7,8,9,10]
-
-{-@ ten :: {v:_ | len v = 10} @-}
-ten :: [Int]
-ten = [1,2,3,4,5,6,7,8,9,10]
-
-ft2 :: FingerTree Int
-ft2 = fromList [1..20000]
-
-main :: IO ()
-main = do
-    print "test"
-    print $ fingerTreeSize ft1 -- 10
-    print $ fingerTreeSize ft2 -- 20000
diff --git a/tests/pos/FoldN.hs b/tests/pos/FoldN.hs
deleted file mode 100644
--- a/tests/pos/FoldN.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-{-@ LIQUID "--pruneunsorted" @-}
-{-@ LIQUID "--no-termination" @-}
-
-module FoldN () where
-
--- Testing "existential-types"
-
-{-@ foldN :: forall a 
 x1:a -> Bool>. 
-                (i:Int -> a
 -> a
) 
-              -> n:{v: Int | v >= 0}
-              -> a 
 
-              -> a 

-  @-}
-
-foldN :: (Int -> a -> a) -> Int -> a -> a
-foldN f n = go 0 
-  where go i x | i < n     = go (i+1) (f i x)
-               | otherwise = x
diff --git a/tests/pos/Foldl.hs b/tests/pos/Foldl.hs
deleted file mode 100644
--- a/tests/pos/Foldl.hs
+++ /dev/null
@@ -1,56 +0,0 @@
-module Foldl where
-
-{-@ LIQUID "--no-termination" @-}
-import Prelude hiding (foldr)
-
-data Vec a = Nil | Cons a (Vec a)
-
-
-{-@
-efoldl :: forall  b -> Bool, step :: a -> b -> b -> Bool>.
-          {y::a, ys :: Vec a, z :: {v:Vec a | v = Cons y ys && llen v = llen ys + 1}, jacc:: b |- b <: b}
-         (x:a -> pacc:b -> b)
-      -> xs:(Vec a)
-      -> b
-      -> b
-@-}
-
-efoldl :: (a -> b -> b) -> Vec a -> b -> b
-efoldl op Nil b         = b
-efoldl op (Cons x xs) b = efoldl op xs (x `op` b)
-
-{-@ size_invariant_qualifier :: xs: Vec a -> ys:Vec a -> {v:Int | v + llen xs ==  llen ys} @-}
-size_invariant_qualifier :: Vec a -> Vec a -> Int
-size_invariant_qualifier xs ys = undefined
-
-{-@ size :: xs:Vec a -> {v: Int | v = llen xs} @-}
-size :: Vec a -> Int
-size xs = efoldl (\_ n -> n + 1) xs 0
-
-
--- | We can encode the notion of length as an inductive measure @llen@
-
-{-@ measure llen @-}
-llen :: Vec a -> Int
-llen (Nil)       = 0
-llen (Cons x xs) = 1 + llen(xs)
-
-
--------------------------------------------------------------------------
--- | Clients of `efold` -------------------------------------------------
--------------------------------------------------------------------------
-
-
--- | The above uses a helper that counts up the size. (Pesky hack to avoid writing qualifier v = ~A + 1)
-{-@ suc :: x:Int -> {v: Int | v = x + 1} @-}
-suc :: Int -> Int
-suc x = x + 1
-
-{-@ LIQUID "--maxparams=3" @-}
-{-@ append_invariant_qualifier :: xs: Vec a -> ys:Vec a -> zs:Vec a -> {v:Vec a | llen v + llen xs ==  llen ys + llen zs } @-}
-append_invariant_qualifier :: Vec a -> Vec a -> Vec a -> Vec a
-append_invariant_qualifier xs ys zs = undefined
-
--- | Second: Appending two lists using `efoldl`
-{-@ app  :: xs: Vec a -> ys: Vec a -> {v: Vec a | llen v = llen xs + llen ys } @-}
-app xs ys = efoldl (\z zs -> Cons z zs) xs ys
diff --git a/tests/pos/Foldr.hs b/tests/pos/Foldr.hs
deleted file mode 100644
--- a/tests/pos/Foldr.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module Foldr where
-
-import Language.Haskell.Liquid.Prelude
-import Data.List (foldl')
-
-foo ::  a -> b -> c -> d
-foo = \_ _ _ -> unsafeError "False" 
-
-bar ::  p -> [(q, r)] -> p
-bar = foldr (\(k, v) -> foo k v)
diff --git a/tests/pos/Foo.hs b/tests/pos/Foo.hs
deleted file mode 100644
--- a/tests/pos/Foo.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module Foo where
-
-bar = 0
-
-{-@ assume (GHC.Base.++) :: [a] -> [a] -> [a] @-}
diff --git a/tests/pos/For.hs b/tests/pos/For.hs
deleted file mode 100644
--- a/tests/pos/For.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-module For (prop, prop2, even_, minifac) where
-
-{-@ LIQUID "--no-termination-check" @-}
-
-import Language.Haskell.Liquid.Prelude
-
-even_ arg = if arg == 0 then True else odd_ (arg - 1)
-
-odd_  arg = if arg == 0 then False else even_ (arg - 1)
-
-mmax x y 
-  | x < y     = y
-  | otherwise = x
-
-minifac foobar 
-  | foobar > 1 =  minifac (foobar - 1)
-  | otherwise  =  1
-
-for lo hi acc f 
-  | lo < hi   = for (lo + 1) hi (f lo acc) f
-  | otherwise = acc 
-
-sumRange i j = for i j 0 (+)
-
-prop = liquidAssertB (m >= 0)
-  where m = sumRange 0 k
-        k = choose 0
-
-prop2 = liquidAssertB (z >= x && z >= y)
-  where x = choose 0
-        y = choose 1
-        z = mmax x y
diff --git a/tests/pos/Forloop.hs b/tests/pos/Forloop.hs
deleted file mode 100644
--- a/tests/pos/Forloop.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-module Forloop () where
-
-{-@ LIQUID "--no-termination" @-}
-import Language.Haskell.Liquid.Prelude
-
-mmax x y 
-  | x < y     = y
-  | otherwise = x
-
-for lo hi acc f 
-  | lo < hi   = for (lo + 1) hi (f lo acc) f
-  | otherwise = acc 
-
-sumRange i j = for i j 0 (+)
-
-prop = liquidAssertB (m >= 0)
-  where m = sumRange 0 k
-        k = choose 0
-
-prop2 = liquidAssertB (z >= x && z >= y)
-  where x = choose 0
-        y = choose 1
-        z = mmax x y
diff --git a/tests/pos/Fractional.hs b/tests/pos/Fractional.hs
deleted file mode 100644
--- a/tests/pos/Fractional.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-module Fractional where
-
-
-{-@ foo :: Fractional a => {v:a | v >= 1.0} @-}
-foo :: Fractional a => a
-foo = undefined
-
-{-@ foo'' :: RealFloat a => {v:a | v >= 1.0} @-}
-foo'' :: RealFloat a => a
-foo'' = undefined
-
-
-{-@ foo' :: Num a => {v:a | v >= 1} @-}
-foo' :: Num a => a
-foo' = undefined
diff --git a/tests/pos/FractionalInstance.hs b/tests/pos/FractionalInstance.hs
deleted file mode 100644
--- a/tests/pos/FractionalInstance.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-{-# OPTIONS_GHC -Wno-missing-methods #-}
-{-@ LIQUID "--no-totality" @-}
-
-module FractionalInstance where
-
-data Frac a
-
-{-@ test :: x:Frac a -> y:{Frac a | y /= 0} -> {v:Frac a | v = x / y } @-} 
-test :: Frac a -> Frac a -> Frac a 
-test x y = x / y 
-
-
-{-@ test1 :: x:a -> y:{a | y /= 0} -> {v:a | v = x / y } @-} 
-test1 :: Fractional a => a -> a -> a  
-test1 x y = x / y 
-
-instance Num (Frac a) where
-instance Fractional (Frac a) where
diff --git a/tests/pos/GCD.hs b/tests/pos/GCD.hs
deleted file mode 100644
--- a/tests/pos/GCD.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-module GCD () where
-
-import Prelude hiding (gcd, mod)
-import Language.Haskell.Liquid.Prelude
-{-@ mod :: a:Nat -> b:{v:Nat| ((v < a) && (v > 0))} -> {v:Nat | v < b} @-}
-mod :: Int -> Int -> Int
-mod a b | a - b >  b = mod (a - b) b
-        | a - b <  b = a - b
-        | a - b == b = 0
-
-{-@ gcd :: a:Nat -> b:{v:Nat | v < a} -> Int @-}
-gcd :: Int -> Int -> Int
-gcd a 0 = a
-gcd a b = gcd b (a `mod` b)
-
-{-@ gcd' :: a:Nat -> b:Nat -> Nat / [a, b] @-}
-gcd' :: Int -> Int -> Int
-gcd' a b | a == 0 = b
-         | b == 0 = a
-         | a == b = a
-         | a >  b = gcd' (a - b) b 
-         | a <  b = gcd' a (b - a) 
diff --git a/tests/pos/GadtEval.hs b/tests/pos/GadtEval.hs
deleted file mode 100644
--- a/tests/pos/GadtEval.hs
+++ /dev/null
@@ -1,91 +0,0 @@
-
-module GadtEval () where
-
-import Language.Haskell.Liquid.Prelude (liquidError)
-
--- "Classic" GADT 
--- 
--- data Expr a where
---   I :: Int -> Expr Int
---   B :: Bool -> Expr Bool
---   Eq :: Expr a -> Expr a -> Expr Bool
---   Pl :: Expr Int -> Expr Int -> Expr Int
--- 
--- eval :: Expr a -> a
--- eval (I i)      = i
--- eval (B b)      = b
--- eval (Eq e1 e2) = (eval e1) == (eval e2)
--- eval (Pl e1 e2) = (eval e1) + (eval e2)
-
-data Ty   = TInt 
-          | TBool
-
-data Expr = I     Int
-          | B     Bool
-          | Equal Expr Expr
-          | Plus  Expr Expr
-          deriving (Eq, Show)
-
-
-{-@ check          :: e:ValidExpr  -> {v:Ty | (v = (eType e))} @-}
-check (I _)        = TInt
-check (B _)        = TBool
-check (Plus e1 e2) = TInt
-check (Equal _ _)  = TBool
-
-{-@ lazy eval @-}
-
-{-@ eval           :: e:ValidExpr  -> {v:ValidExpr | ((isValue v) && (((eType e) = (eType v))))} @-}
-eval e@(I _)       = e
-eval e@(B _)       = e
-eval (Plus e1 e2)  = (eval e1) `plus` (eval e2)
-eval (Equal e1 e2) = (eval e1) `equal` (eval e2)
-
-plus (I i) (I j)   = I (i + j)
-plus _       _     = liquidError "don't worry, its impossible" 
-
-equal (I i) (I j)  = B (i == j)
-equal (B x) (B y)  = B (x == y)
-equal _       _    = liquidError "don't worry, its impossible" 
-
--- | The next two are silly, for scraping quals. Yuck. Should scrape from measure-DEFS etc.
-
-{-@ toInt :: IntExpr -> Int @-}
-toInt (I i) = i
-toInt _     = liquidError "impossible"
-
-{-@ toBool :: BoolExpr -> Bool @-}
-toBool (B b) = b
-toBool _     = liquidError "impossible"
-
-
-{-@ predicate IsTInt X   = ((eType X) = TInt)  @-}
-{-@ predicate IsTBool X  = ((eType X) = TBool) @-}
-
-
-{-@ type ValidExpr     = {v: Expr | (isValid v)}                @-}
-{-@ type IntExpr       = {v: Expr | ((isValue v) && (IsTInt  v))} @-}
-{-@ type BoolExpr      = {v: Expr | ((isValue v) && (IsTBool v))} @-}
-
-
-{-@ measure isValue       :: Expr -> Bool
-      isValue (I i)         = true
-      isValue (B b)         = true
-      isValue (Equal e1 e2) = false 
-      isValue (Plus e1 e2)  = false
-  @-}  
-
-{-@ measure eType       :: Expr -> Ty 
-      eType (I i)         = TInt  
-      eType (Plus  e1 e2) = TInt 
-      eType (B b)         = TBool 
-      eType (Equal e1 e2) = TBool 
-  @-}
-
-{-@ measure isValid       :: Expr -> Bool
-      isValid (I i)         = true
-      isValid (B b)         = true
-      isValid (Equal e1 e2) = (((eType e1) = (eType e2)) && (isValid e1) && (isValid e2))
-      isValid (Plus e1 e2)  = ((IsTInt e1) && (IsTInt e2) && (isValid e1) && (isValid e2))
-  @-}
-
diff --git a/tests/pos/GeneralizedTermination.hs b/tests/pos/GeneralizedTermination.hs
deleted file mode 100644
--- a/tests/pos/GeneralizedTermination.hs
+++ /dev/null
@@ -1,37 +0,0 @@
-{-@ LIQUID "--no-totality" @-}
-module GeneralizedTermination (llen) where
-
-import Prelude hiding (reverse)
-
-foo :: Int -> Int -> Int
-{-@ foo :: n:Nat -> m:Nat -> Nat /[n+m] @-}
-
-foo n m 
-  | cond 1 = 0
-  | cond 2 && n > 1 = foo (n-1) m
-  | cond 3 && m > 2 = foo (n+1) (m-2)
- 
-{-@ cond :: Int -> Bool @-}
-cond :: Int -> Bool
-cond _ = undefined
-
-
-data L a = N | C a (L a)
-
-{-@ data L [llen] @-}
-
-{-@ measure llen @-}
-llen :: (L a) -> Int
-{-@ llen :: (L a) -> Nat @-}
-llen(N)      = 0
-llen(C x xs) = 1 + (llen xs)
-
-{-@ reverse :: xs: L a -> ys : L a -> L a / [(llen ys)] @-}
-reverse :: L a -> L a -> L a
-reverse xs N = xs
-reverse xs (C y ys) = reverse (C y xs) ys
-
-merge :: Ord a => L a -> L a -> L a 
-{-@ merge :: Ord a => xs:L a -> ys:L a -> L a /[(llen xs) + (llen ys)]@-}
-merge (C x xs) (C y ys) | x > y     = C x $ merge xs (C y ys) 
-                        | otherwise = C y $ merge (C x xs) ys
diff --git a/tests/pos/GhcSort1.hs b/tests/pos/GhcSort1.hs
deleted file mode 100644
--- a/tests/pos/GhcSort1.hs
+++ /dev/null
@@ -1,61 +0,0 @@
-{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
-{-# Language ScopedTypeVariables   #-}
-{-# Language PartialTypeSignatures #-}
-
--- TODO: Fix resolve so we can remove this/add termination metrics
-{-@ LIQUID "--no-termination" @-}
-
-module GhcSort1 () where
-
-import Language.Haskell.Liquid.Prelude 
-
-{-@ type OList a = [a]<{\fld v -> (v >= fld)}> @-}
-{-@ assert sort1 :: (Ord a) => [a] -> OList a  @-}
-sort1 :: (Ord a) => [a] -> [a]
-sort1 xs = mergeAll  (sequences xs 0)
-  where
-    sequences :: [_] -> Int -> [[_]]
-    sequences (a:b:xs) (_::Int)
-      | a `compare` b == GT = descending b [a]  xs 1
-      | otherwise           = ascending  b (a:) xs 1
-    sequences [x] _ = [[x]]
-    sequences []  _ = [[]]
-
-    descending :: _ -> _ -> [_] -> Int -> [[_]]
-    descending a as (b:bs) (_::Int)
-      | a `compare` b == GT = descending b (a:as) bs 1
-    descending a as bs _    = (a:as): sequences bs 0
-
-    ascending :: _ -> _ -> [_] -> Int -> [[_]]
-    ascending a as (b:bs) (_ :: Int)
-      | a `compare` b /= GT = ascending b (\ys -> as (a:ys)) bs 1
-    ascending a as bs _     = as [a]: sequences bs 0
-
-    mergeAll []  = [] --this case cannot occur, though
-    mergeAll [x] = x
-    mergeAll xs  = mergeAll (mergePairs xs)
-
-{-@ mergePairs :: Ord a
-               => xss:[(OList a)]
-               -> {v:[(OList a)] | (if ((len xss) > 1) then ((len v) < (len xss)) else ((len v) = (len xss) ))}
-  @-}
-mergePairs :: Ord a => [[a]] -> [[a]]
-mergePairs (a:b:xs) = merge1 a b: mergePairs xs
-mergePairs [x]      = [x]
-mergePairs []       = []
-
--- merge1 needs to be toplevel,
--- to get applied transformRec tx
-
-{-@ merge1 :: Ord a
-           => xs:OList a
-           -> ys:OList a
-           -> {v:OList a | len v == len xs + len ys}
-           / [len xs + len ys]
-  @-}
-merge1 :: Ord a => [a] -> [a] -> [a]
-merge1 (a:as') (b:bs')
-  | a `compare` b == GT = b:merge1 (a:as')  bs'
-  | otherwise           = a:merge1 as' (b:bs')
-merge1 [] bs            = bs
-merge1 as []            = as
diff --git a/tests/pos/GhcSort2.hs b/tests/pos/GhcSort2.hs
deleted file mode 100644
--- a/tests/pos/GhcSort2.hs
+++ /dev/null
@@ -1,46 +0,0 @@
-module GhcSort2 () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ type OList a =  [a]<{\fld v -> (v >= fld)}>  @-}
-
-
-{-@ assert sort2 :: (Ord a) => [a] -> OList a  @-}
-sort2 :: (Ord a) => [a] -> [a]
-sort2 = mergesort
-
-mergesort :: (Ord a) => [a] -> [a]
-mergesort = mergesort' . map wrap
-
-mergesort' :: (Ord a) => [[a]] -> [a]
-mergesort' [] = []
-mergesort' [xs] = xs
-mergesort' xss = mergesort' (merge_pairs xss)
-
-{-@ predicate DLen X Y = 
-      (if ((len X) > 1) 
-       then ((len Y) < (len X)) 
-       else ((len X) = (len Y))) 
-  @-}
-
-{-@ merge_pairs :: (Ord a) => xs:[OList a] -> {v:[OList a] | (DLen xs v)} @-}
-merge_pairs :: (Ord a) => [[a]] -> [[a]]
-merge_pairs [] = []
-merge_pairs [xs] = [xs]
-merge_pairs (xs:ys:xss) = merge xs ys d : merge_pairs xss
-  where d = length xs + length ys
-
-
-{-@ decrease merge 4 @-}
-{-@ merge :: (Ord a) => xs:OList a -> ys:OList a -> {n:Nat|n = (len xs) + (len ys)} -> OList a  @-}
-merge :: (Ord a) => [a] -> [a] -> Int -> [a]
-merge [] ys _ = ys
-merge xs [] _ = xs
-merge (x:xs) (y:ys) d
- | x > y     = y : merge (x:xs)   ys (d-1)
- | otherwise = x : merge xs   (y:ys) (d-1)
-
-wrap :: a -> [a]
-wrap x = [x]
-
-
diff --git a/tests/pos/GhcSort3.hs b/tests/pos/GhcSort3.hs
deleted file mode 100644
--- a/tests/pos/GhcSort3.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-module GhcSort3 () where
-
-{-@ LIQUID "--no-termination" @-}
-
-{-@ type OList a =  [a]<{\fld v -> (v >= fld)}>  @-}
-
-{-@ assert sort3 :: (Ord a) => w:a -> [{v:a|v<=w}] -> OList a @-}
-sort3 :: (Ord a) => a -> [a] -> [a]
-sort3 w ls = qsort w ls []
-
-qsort :: (Ord a) =>  a -> [a] -> [a] -> [a]
-qsort _ []     r = r
-qsort _ [x]    r = x:r
-qsort w (x:xs) r = qpart w x xs [] [] r
-
-qpart :: (Ord a) => a -> a -> [a] -> [a] -> [a] -> [a] -> [a]
-qpart w x [] rlt rge r =
-    rqsort x rlt (x:rqsort w rge r)
-qpart w x (y:ys) rlt rge r =
-    case compare x y of
-        GT -> qpart w x ys (y:rlt) rge r
-        _  -> qpart w x ys rlt (y:rge) r
-
-rqsort :: (Ord a) => a -> [a] -> [a] -> [a]
-rqsort _ []     r = r
-rqsort _ [x]    r = x:r
-rqsort w (x:xs) r = rqpart w x xs [] [] r
-
-rqpart :: (Ord a) => a -> a -> [a] -> [a] -> [a] -> [a] -> [a]
-rqpart w x [] rle rgt r =
-    qsort x rle (x:qsort w rgt r)
-rqpart w x (y:ys) rle rgt r =
-    case compare y x of
-        GT -> rqpart w x ys rle (y:rgt) r
-        _  -> rqpart w x ys (y:rle) rgt r
-
diff --git a/tests/pos/GhcSort3_T.hs b/tests/pos/GhcSort3_T.hs
deleted file mode 100644
--- a/tests/pos/GhcSort3_T.hs
+++ /dev/null
@@ -1,41 +0,0 @@
-module GhcSort3_T () where
-
-{-@ type OList a =  [a]<{\fld v -> (v >= fld)}>  @-}
-
-{-@ assert sort3 :: (Ord a) => w:a -> [{v:a|v<=w}] -> OList a @-}
-sort3 :: (Ord a) => a -> [a] -> [a]
-sort3 w ls = qsort w ls [] (length ls) 0
-
-{-@ decrease qsort 5 6 @-}
-{-@ decrease rqsort 5 6 @-}
-{-@ decrease qpart 8 9 @-}
-{-@ decrease rqpart 8 9 @-}
-qsort :: (Ord a) =>  a -> [a] -> [a] -> Int -> Int -> [a]
-{-@ qsort, rqsort :: (Ord a) =>  w:a -> xs:[{v:a|v<=w}] -> OList {v:a|v>=w} -> {v:Int | v = (len xs) } -> {v:Int | v = 0 } -> OList a @-}
-qsort _ []     r _ _ = r
-qsort _ [x]    r _ _ = x:r
-qsort w (x:xs) r _ _ = qpart w x xs [] [] r (length xs) (length xs + 1)
-
-{-@ qpart, rqpart :: (Ord a) => w:a -> x:{v:a|v<=w} -> xs:[{v:a|v <= w}] -> lt:[{v:a|((v<=x) && (v<=w))}] -> ge:[{v:a|((v >= x) && (v<=w))}] -> rs:(OList {v:a|v >= w}) -> {v:Int | v = ((len xs) + (len lt) + (len ge))} -> {v:Int|v = (len xs) + 1} -> OList a @-}
-qpart :: (Ord a) => a -> a -> [a] -> [a] -> [a] -> [a] -> Int -> Int -> [a]
-qpart w x [] rlt rge r _ _ =
-    rqsort x rlt (x:rqsort w rge r (length rge) 0) (length rlt) 0
-qpart w x (y:ys) rlt rge r d1 d2 =
-    case compare x y of
-        GT -> qpart w x ys (y:rlt) rge r d1 (d2 - 1)
-        _  -> qpart w x ys rlt (y:rge) r d1 (d2 - 1)
-
-{- rqsort :: (Ord a) =>  w:a -> xs:[{v:a|v<=w}] -> OList {v:a|v>=w} -> {v:Int | v = (len xs) } -> {v:Int | v = 0 } -> OList a @-}
-rqsort :: (Ord a) => a -> [a] -> [a] -> Int -> Int -> [a]
-rqsort _ []     r _ _ = r
-rqsort _ [x]    r _ _ = x:r
-rqsort w (x:xs) r _ _ = rqpart w x xs [] [] r (length xs) (length xs + 1)
-
-rqpart :: (Ord a) => a -> a -> [a] -> [a] -> [a] -> [a] -> Int -> Int -> [a]
-rqpart w x [] rle rgt r _ _ =
-    qsort x rle (x:qsort w rgt r (length rgt) 0) (length rle) 0 
-rqpart w x (y:ys) rle rgt r d1 d2 =
-    case compare y x of
-        GT -> rqpart w x ys rle (y:rgt) r d1 (d2-1)
-        _  -> rqpart w x ys (y:rle) rgt r d1 (d2-1)
-
diff --git a/tests/pos/Gimme.hs b/tests/pos/Gimme.hs
deleted file mode 100644
--- a/tests/pos/Gimme.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-module Gimme () where
-
-import Language.Haskell.Liquid.Prelude
-
-{- qualif Gimme(v:[a], n:int, acc:[a]): (len v == n + 1 + len acc) -}
-
-{-@ gimme :: xs:[a] -> n:Int -> acc:[a] -> {v:[a] | len v = n + 1 + len acc} @-}
-gimme :: [a] -> Int -> [a] -> [a]
-gimme xs (-1) acc  = acc
-gimme (x:xs) n acc = gimme xs (n-1) (x : acc)
-gimme _ _ _        = unsafeError "gimme"
-
-{-@ boober :: n:Int -> Int -> {v:[Int] | (len v) = n} @-}
-boober :: Int -> Int -> [Int]
-boober n y = gimme [y..] (n-1) []
diff --git a/tests/pos/Go.hs b/tests/pos/Go.hs
deleted file mode 100644
--- a/tests/pos/Go.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-module Go (poop) where
-
-{-@ invariant {v:Int | v >= 0} @-}
-
-{-@ qualif Sum(v:Int, x: Int, y: Int): v = x + y @-}
-
-{-@ invariant {v:Int | v >= 0} @-}
-
-{-@ foo  :: x:Int -> {v:Int | v = x} @-}
-foo x    = go x 0
-  where 
-    go     :: Int -> Int -> Int 
-    go 0 m = m
-    go n m = go (n-1) (m+1)
-
-
-poop x = foo x 
-
-
-
diff --git a/tests/pos/Go_ugly_type.hs b/tests/pos/Go_ugly_type.hs
deleted file mode 100644
--- a/tests/pos/Go_ugly_type.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module Go_ugly_type where
-
-{- decrease go 2 @-}
-
-{-@ rev :: xs:[a] -> {v: [a] | len v = len xs} @-}
-rev = go [] 
-  where 
-    {-@ go :: acc:_ -> xs:_ -> {v:_ | len v = len acc + len xs} @-}
-    go acc []     = acc
-    go acc (x:xs) = go (x:acc) xs
-
-main :: IO ()
-main = pure ()
diff --git a/tests/pos/GoodHMeas.hs b/tests/pos/GoodHMeas.hs
deleted file mode 100644
--- a/tests/pos/GoodHMeas.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-module GoodHMeas where
-
-{-@ LIQUID "--prune-unsorted" @-}
-
-{-@ measure foo @-}
-bar, foo :: [(Int, Int)] -> Int
-foo [] = 0
-foo (a:as) = myFst a + foo as
-
-{-@ measure myFst @-}
-myFst :: (a, b) -> a
-myFst (x, y) = x
-
-{-@ bar :: xs:[(Int, Int)] -> {v:Int | v == foo xs } @-}
-bar x = foo x
-
-main :: IO ()
-main = pure ()
diff --git a/tests/pos/Graph.hs b/tests/pos/Graph.hs
deleted file mode 100644
--- a/tests/pos/Graph.hs
+++ /dev/null
@@ -1,54 +0,0 @@
-{-@ LIQUID "--prune-unsorted" @-}
-
-module Graph () where
-
-import Data.Set
-
-
-type Size = Int
-data Map k v = Tip | Bin Size k v (Map k v) (Map k v)
-             deriving (Eq, Ord)
-
-
-data Edges edge
-
-
-{-@ measure getEdgesIncoming :: (Edges edge) -> (Set edge) @-}
-
-{-@ measure getEdgesOutgoing :: (Edges edge) -> (Set edge) @-}
-
-data Graph node edge =
-  Graph {
-    graphMap ::
-      Map node (Edges edge, Edges edge)
-  }
-
-{-@ invariant {v: (Graph node edge) | (getGraphIncoming v) = (getGraphOutgoing v) } @-}
-
-{-@ measure getGraphIncoming :: (Graph node edge) -> (Set edge)
-      getGraphIncoming (Graph m) = (getMapIncoming m)
-  @-}
-
-{-@ measure getGraphOutgoing :: (Graph node edge) -> (Set edge)
-      getGraphOutgoing (Graph m) = (getMapOutgoing m)
-  @-}
-
-
-{-@ measure getMapIncoming :: (Map node (Edges edge, Edges e)) -> (Set edge)
-      getMapIncoming Tip = {v | Set_emp v }
-      getMapIncoming (Bin size k v lm rm) = (Set_cup (getPairIncoming v) (Set_cup (getMapIncoming lm) (getMapIncoming rm)))
-  @-}
-
-
-{-@ measure getMapOutgoing :: (Map node (Edges edge, Edges edge)) -> (Set edge)
-      getMapOutgoing Tip = {v | Set_emp v }
-      getMapOutgoing (Bin size k v lm rm) = Set_cup (getPairOutgoing v) (Set_cup (getMapOutgoing lm) (getMapOutgoing rm))
-  @-}
-
-{-@ measure getPairIncoming :: (Edges edge, Edges e) -> (Set edge)
-      getPairIncoming (x, y) = (getEdgesIncoming x)
-  @-}
-
-{-@ measure getPairOutgoing :: (Edges e, Edges edge) -> (Set edge)
-      getPairOutgoing (x, y) = (getEdgesOutgoing y)
-  @-}
diff --git a/tests/pos/Grty0.hs b/tests/pos/Grty0.hs
deleted file mode 100644
--- a/tests/pos/Grty0.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module Grty0 () where
-
-{-@ stupid :: Int -> Int @-}
-stupid :: Int -> Int
-stupid x = 0
-
-{-@ myId :: x:a -> {v:a | v = x } @-}
-myId x = x 
-
-{-@ assert single :: a -> {v: [a] | len(v) > 0} @-}
-single x = [x] 
-
-
diff --git a/tests/pos/Grty1.hs b/tests/pos/Grty1.hs
deleted file mode 100644
--- a/tests/pos/Grty1.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
-module Grty1 () where
-import Language.Haskell.Liquid.Prelude 
-
-{-@ sz :: {v:[a]|((len v) = 1)} -> a @-}
--- sz (x:xs) = sz xs
-sz [x]    = x
-
-{-@ poo :: [a] -> a @-}
-poo (x:xs) = poo xs
-poo [x]    = x
-poo _      = unsafeError "poo"
diff --git a/tests/pos/Grty2.hs b/tests/pos/Grty2.hs
deleted file mode 100644
--- a/tests/pos/Grty2.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module Grty2 () where
-
-{-@ foo :: {vv:[{v:[a]|((len v) = 1)}]|((len vv)= 1)} -> [[a]] @-}
-foo [[x]] = [[x]]
-
-
-
diff --git a/tests/pos/Grty3.hs b/tests/pos/Grty3.hs
deleted file mode 100644
--- a/tests/pos/Grty3.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module Grty3 () where
-
-{-@ bar :: (a, {v:[b]|((len v) = 1)}) -> b @-}
-bar (_, [x]) = x
-
-
-
diff --git a/tests/pos/GuardedNegative.hs b/tests/pos/GuardedNegative.hs
deleted file mode 100644
--- a/tests/pos/GuardedNegative.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-{-@ LIQUID "--no-positivity-check" @-}
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple"        @-}
-
-{-# LANGUAGE GADTs #-}
-module GuardedNegative where
-
-data GuardedNegative where  
-      NatInduction  :: (Int -> Bool) -> GuardedNegative -> (Int -> GuardedNegative -> GuardedNegative) -> Int -> GuardedNegative
-      FromSMT       :: Bool -> GuardedNegative
-
-{-@ data GuardedNegative where 
-      NatInduction :: p:(Nat -> Bool)
-                   -> Prop {p 0} 
-                   -> (n:Nat -> Prop {p (n-1)} -> Prop {p n})      
-                   -> n:Nat -> Prop {p n} 
-      FromSMT :: b:{Bool | b} -> Prop {b} 
-  @-}
-
-{-@ type Prop E = { p:GuardedNegative | E } @-}
-
-trivialUse :: Int -> GuardedNegative 
-{-@ trivialUse :: n:Nat -> {v:_ | 0 <= n} @-}
-trivialUse = NatInduction p (FromSMT (0 <= 0)) (\n _ -> FromSMT (0 <= n))
-
-{-@ reflect p @-}
-{-@ p :: Int -> Bool @-}
-p :: Int -> Bool
-p i = 0 <= i 
diff --git a/tests/pos/HasElem.hs b/tests/pos/HasElem.hs
deleted file mode 100644
--- a/tests/pos/HasElem.hs
+++ /dev/null
@@ -1,24 +0,0 @@
-module HasElem where
-
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple"        @-}
-{-@ LIQUID "--no-termination" @-}
-
-data L a = Nil | Cons a (L a)
-
-{-@ reflect hasElem @-}
-hasElem :: Eq a => a -> L a -> Bool
-hasElem x Nil = False
-hasElem x (Cons y ys) = x == y || hasElem x ys
-
-{-@ prop :: {v:Bool | v} @-}
-prop :: Bool
-prop = hasElem 1 (Cons 1 Nil)
-
-{-@ prop1 :: {v:Bool | not v } @-}
-prop1 :: Bool
-prop1 = hasElem 1 (Cons 2 Nil)
-
-{-@ prop2 :: {v:Bool | not v } @-}
-prop2 :: Bool
-prop2 = hasElem 1 Nil
diff --git a/tests/pos/HaskellMeasure.hs b/tests/pos/HaskellMeasure.hs
deleted file mode 100644
--- a/tests/pos/HaskellMeasure.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-module HaskellMeasure where
-
-{-@ measure lllen @-}
-llen :: [a] -> Int
-llen [] = 0
-llen (x:xs) = 1 + llen xs
-
-{-@ llen, llllen :: xs:[a] -> {v:Int| (lllen xs) = v} @-}
-
-lllen :: [a] -> Int
-lllen [] = 0
-lllen (x:xs) = 1 + lllen xs
-
-llllen = lllen
diff --git a/tests/pos/HedgeUnion.hs b/tests/pos/HedgeUnion.hs
deleted file mode 100644
--- a/tests/pos/HedgeUnion.hs
+++ /dev/null
@@ -1,49 +0,0 @@
-{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
-module HedgeUnion where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@
-  data Map [mlen] k a  k -> Bool, r :: root:k -> k -> Bool>
-      = Tip 
-      | Bin (right :: Map  k  a) 
-  @-}
-
-{-@ measure mlen @-}
-mlen :: (Map k a) -> Int 
-{-@ mlen :: (Map k a) -> Nat @-} 
-mlen(Tip) = 0
-mlen(Bin r) = 1 + (mlen r)
-
-{- type OMap k a = Map <{\root v -> v < root }, {\root v -> v > root}> k a @-}
-
-data Map k a = Tip
-             | Bin (Map k a)
-
-type Size    = Int
-
--- Internal representation of hedgeUnion:
-
-{-@ lazyvar d20r @-}
-
-g t1 d20i = 
-  case d20i of
-   Tip -> Tip
-   Bin d20G -> (\_ -> let d20r = \_ -> let d20n  = \_ -> case t1 of
-                                                         Tip -> liquidError ""
-                                                         Bin  r -> r
-                                      in case d20i of
-                                          Tip -> d20n ""
-                                          Bin d20j -> case d20j of
-                                                        Tip -> Tip
-                                                        Bin _ -> d20n ""
-                         in case t1 of
-                             Tip -> case d20i of 
-                                      Tip -> d20r ""
-                                      Bin r -> r
-                             Bin _ -> d20r "") ""
-
--- hedgeUnion t1 Tip      = Tip  
--- hedgeUnion Tip (Bin r) = r
--- hedgeUnion t1  (Bin Tip) = Tip
--- hedgeUnion (Bin r) t = r
diff --git a/tests/pos/Hello.hs b/tests/pos/Hello.hs
deleted file mode 100644
--- a/tests/pos/Hello.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module Hello () where
-
-{-@ abz :: (Num a, Ord a) => x:a -> {v: a | v >= x} @-}
-abz x   = if (x > 0) then x else (0 - x)  
-
-{-@ incr :: (Num a) => x:a -> {v: a | v > x}        @-}
-incr x  = x + 1 
-
-{-@ decr :: (Num a) => x:a -> {v: a | v < x}        @-}
-decr x  = x - 1 
-
-
diff --git a/tests/pos/Hex00.hs b/tests/pos/Hex00.hs
deleted file mode 100644
--- a/tests/pos/Hex00.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module Hex00 where
-
-foo :: Int -> Int -> Int 
-foo x y = x + y
-
-{-@ foo :: {x:Int | x = 0x7} -> {y:Int | y = 0x8} -> {v:Int | v = 0xF} @-}
-
diff --git a/tests/pos/HigherOrderRecFun.hs b/tests/pos/HigherOrderRecFun.hs
deleted file mode 100644
--- a/tests/pos/HigherOrderRecFun.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module HigherOrderRecFun () where
-
-foo :: [a] -> (b -> c) -> (b -> c)
-foo []     f = f
-foo (x:xs) f = foo xs f
-
diff --git a/tests/pos/Hole00.hs b/tests/pos/Hole00.hs
deleted file mode 100644
--- a/tests/pos/Hole00.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-
--- This test checks that we resolve the name `MVector` to 
--- the CLASS defined in the re-exported Data.Vector.Generic.Mutable.Base 
--- NOT to the TyCon inside `Data.Vector.Primitive.Mutable` 
-
-module Hole00 where
-
-import Prelude hiding (read, length)
-
-import           Control.Monad.Primitive
-import qualified Data.Vector.Primitive.Mutable as PV
-import           Data.Vector.Generic.Mutable
-
-{-@ chimp :: (Monad m, MVector v e) => v (PrimState m) e -> m () @-}
-chimp :: (Monad m, MVector v e) => v (PrimState m) e -> m ()
-chimp = undefined
diff --git a/tests/pos/Hole_app.hs b/tests/pos/Hole_app.hs
deleted file mode 100644
--- a/tests/pos/Hole_app.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module Hole_app where
-
-{-@ type Vec a N = {v:[a] | len v = N } @-}
-
-{-@ ok :: Vec Int 3 @-}
-ok = [1,2,3] :: [Int]
-
-{-@ ok' :: Vec _ 3 @-}  -- would be nice to support the hole in the application..
-ok'     = [1,2,3]
-
-
-
diff --git a/tests/pos/Hole_fun.hs b/tests/pos/Hole_fun.hs
deleted file mode 100644
--- a/tests/pos/Hole_fun.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module Hole_fun (test) where
-
-inc :: Int -> Int 
-inc x = x + 1
-
-{-@ app :: _ -> Nat -> Nat @-} 
-app :: (Int -> Int) -> Int -> Int
-app f x = f x
-
-test = app inc 7
diff --git a/tests/pos/Holes.hs b/tests/pos/Holes.hs
deleted file mode 100644
--- a/tests/pos/Holes.hs
+++ /dev/null
@@ -1,39 +0,0 @@
-module Holes (plus) where
-
-{-@ foo :: x:_ -> y:{Int | y > 0} -> _ @-}
-foo :: Int -> Int -> Int
-foo x y = x
-
-zero = foo 0 1
-
-
-{-@ baz :: _ -> _ -> a @-}
-baz :: a -> b -> b
-baz x y = y
-
-baz' = baz 1 2
-
-data P a b = P a b
-
-{-@ goo :: _ -> b -> _ @-}
-goo :: P a b -> b -> a
-goo p@(P a b) x = a
-
-y = goo (P 1 1) 2
-
-
-{-@ bar :: {v:[{v0:Int | v0 > 0}] | _ } -> Int @-}
-bar :: [Int] -> Int
-bar [x] = x
-
-x =  bar [1]
-
-{-@ plus :: x:_ -> y:_ -> {v:_ | v = x + y} @-}
-plus :: Int -> Int -> Int 
-plus x y = x + y
-
-
-{-@ type UNat = {v:_ | v >= 0} @-}
-
-{-@ zoo :: UNat @-}
-zoo = 1
diff --git a/tests/pos/Holes_Slicing.hs b/tests/pos/Holes_Slicing.hs
deleted file mode 100644
--- a/tests/pos/Holes_Slicing.hs
+++ /dev/null
@@ -1,21 +0,0 @@
--- TODO-REBARE: What the hell is noslice? 
-{- LIQUID "--noslice"     @-}
-
-module Holes_Slicing () where
-
-
-{-@ measure isFoo :: A -> B -> Bool @-}
-{-@ isFooF :: a:A -> b:B -> {v:Bool | v <=> isFoo a b} @-}
-isFooF :: A -> B -> Bool
-isFooF a b = undefined
-
-{-@ prop1 :: u:A -> p:B -> {v : Int | isFoo u p <=> (v < 2) } @-}
-prop1 :: A -> B -> Int
-prop1 = undefined
-
-{-@ foo :: A -> B -> _ @-}
-foo :: A -> B -> Int
-foo a b = if isFooF a b then 0 else 2 
-
-data A
-data B
diff --git a/tests/pos/Hutton.hs b/tests/pos/Hutton.hs
deleted file mode 100644
--- a/tests/pos/Hutton.hs
+++ /dev/null
@@ -1,109 +0,0 @@
--- WITH-PLE 
-
-module Hutton where
-
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple"        @-}
-
-import Language.Haskell.Liquid.ProofCombinators
-
-import Prelude hiding (length, head, tail, map, (++))
-
--- need to use a hand-rolled list type, it seems
-
-data L a = N | C {hd :: a, tl :: L a}
-{-@ data L [length] a = N | C {hd :: a, tl :: L a} @-}
-
-length :: L a -> Int
-{-@ length :: L a -> Nat @-}
-{-@ measure length @-}
-length N        = 0
-length (C _ xs) = 1 + length xs
-
-{-@ infix   ++ @-}
-{-@ reflect ++ @-}
-(++) :: L a-> L a -> L a
-N        ++ ys = ys
-(C x xs) ++ ys = C x (xs ++ ys)
-
--- huttons razor
-
-data Expr = Val Int | Add Expr Expr
-{-@ data Expr [height] = Val {theVal :: Int} | Add {summand1 :: Expr, summand2 :: Expr}  @-}
-
-
-{-@ height :: Expr -> Nat @-}
-{-@ measure height @-}
-height :: Expr -> Int
-height (Val _) = 0
-height (Add e1 e2) = 1 + if height e1 > height e2 then  height e1 else height e2
-
-{- @ eval :: e:Expr -> Int / [height e] @-}
-{-@ reflect eval @-}
-eval :: Expr -> Int
-eval (Val n)   = n
-eval (Add x y) = eval x + eval y
-
-type Stack = L Int
-
-type Code = L Op
-
-data Op = PUSH Int | ADD
-{-@ data Op = PUSH {thePushed :: Int} | ADD @-}
-
-{-@ reflect exec @-}
-exec :: Code -> Stack -> Stack
-exec N s                          = s
-exec (C (PUSH n) c) s             = exec c (C n s)
-exec (C ADD      c) (C m (C n s)) = exec c (C (n+m) s)
-exec (C ADD      c) (C n N)       = N -- default case added
-exec (C ADD      c) N             = N -- default case added (need to be sparate cases)
-
-{-@ reflect comp @-}
-comp :: Expr -> Code
-comp (Val n)   = C (PUSH n) N
-comp (Add x y) = (comp x ++ comp y) ++ (C ADD N)
-
--- Proofs
-
-{-@ lemma_assoc4 :: as:L a -> bs:L a -> cs:L a -> ds:L a 
-                 -> {((as ++ bs) ++ cs) ++ ds  == as ++ (bs ++ (cs ++ ds)) }
-  @-}
-lemma_assoc4 :: L a -> L a -> L a -> L a -> Proof 
-lemma_assoc4 _ _ _ _ = undefined
-
-{-@ lemma_app_nil :: x:a -> ys:L a -> { (C x N) ++ ys = C x ys } @-}
-lemma_app_nil :: a -> L a -> Proof
-lemma_app_nil _ _ = () 
-
-{-@ correctness :: e:Expr -> c:Code -> s:Stack ->
-                  { exec (comp e ++ c) s = exec c (C (eval e) s) }
-@-}
-correctness :: Expr -> Code -> Stack -> Proof
-correctness (Val n) c s 
-  = [
-    --   exec (comp (Val n) ++ c) s
-    -- ==. exec ((C (PUSH n) N) ++ c) s
-    -- ==. exec ((C (PUSH n) (N ++ c))) s
-    -- ==. exec (C (PUSH n) c) s
-    -- ==. exec c (C n s)
-    -- ==. exec c (C (eval (Val n)) s)
-    ] *** QED
-
-
-correctness (Add e1 e2) c s 
-  = [ 
-  --    exec (comp (Add e1 e2) ++ c) s 
-  -- ==. exec (((comp e1 ++ comp e2) ++ (C ADD N)) ++ c) s
-  -- ==. exec (comp e1 ++ (comp e2 ++ ((C ADD N) ++ c))) s
-      lemma_assoc4 (comp e1) (comp e2) (C ADD N) c
-  -- ==. (exec (comp e2 ++ ((C ADD N) ++ c)) (C (eval e1) s))
-    , correctness e1 (comp e2 ++ ((C ADD N) ++ c)) s
-  -- ==. exec ((C ADD N) ++ c) (C (eval e2) (C (eval e1) s))
-    , correctness e2 ((C ADD N) ++ c) (C (eval e1) s)
-  -- ==. exec (C ADD c) (C (eval e2) (C (eval e1) s))
-    , lemma_app_nil ADD c
-  -- ==. exec c (C (eval e1 + eval e2) s)
-  -- ==. exec c (C (eval (Add e1 e2)) s)
-  ] *** QED    
-
diff --git a/tests/pos/IcfpDemo.hs b/tests/pos/IcfpDemo.hs
deleted file mode 100644
--- a/tests/pos/IcfpDemo.hs
+++ /dev/null
@@ -1,66 +0,0 @@
-{-@ LIQUID "--no-totality" @-}
-module IcfpDemo where
-
-import Prelude hiding (gcd, map, repeat, take)
-import Language.Haskell.Liquid.Prelude
-
-
-fac :: Int -> Int
-fac n = if n <= 1 then 1 else n * fac (n-1)
-
---FIXME: fixpoint can't parse "mod" anymore..
-{- gcd :: a:Nat -> {v:Nat | v < a} -> Nat @-}
--- gcd :: Int -> Int -> Int
--- gcd a 0 = a
--- gcd a b = gcd b (a `mod` b)
-
-{-@ tfac :: Nat -> n:Nat -> Nat / [n] @-}
-tfac :: Int -> Int -> Int
-tfac x n = if n <= 1 then x
-                     else tfac (n*x) (n-1)
-
-{-@ range :: lo:Nat -> hi:Nat -> [Nat] / [hi-lo] @-}
-range :: Int -> Int -> [Int]
-range lo hi
-  | lo < hi   = lo : range (lo + 1) hi
-  | otherwise = []
-
-{-@ data L [sz] a 
 Bool>
-      = N | C (lHd :: a) (lTl ::L 
 a <
>)
-  @-}
-data L a = N | C a (L a)
-
-{-@ measure sz  @-}
-sz :: L a -> Int
-{-@ sz :: L a -> Nat @-}
-sz (C x xs) = 1 + (sz xs)
-sz (N)      = 0
-
-{-@ map :: (a -> b) -> xs:L a -> (L b) / [(sz xs)] @-}
-map :: (a -> b) -> L a -> L b
-map f (C x xs) = f x `C` map f xs
-map _ N        = N
-
-{-@ merge :: xs:_ -> ys:_ -> _ / [(sz xs) + (sz ys)] @-}
-merge :: Ord a => L a -> L a -> L a
-merge (C x xs) (C y ys)
-  | x < y     = x `C` merge xs (y `C` ys)
-  | otherwise = y `C` merge (x `C` xs) ys
-
-{-@ measure emp @-}
-emp :: L a -> Bool
-emp N        = True
-emp (C x xs) = False
-
-{-@ type Stream a = {xs: L <{\v -> not (emp v)}> a | not (emp xs)} @-}
-
-{-@ lazy repeat @-}
-{-@ repeat :: a -> Stream a @-}
-repeat :: a -> L a
-repeat x = x `C` repeat x
-
-{-@ take :: Nat -> Stream a -> L a @-}
-take :: Int -> L a -> L a
-take 0 _        = N
-take n (C x xs) = x `C` take (n-1) xs
-take _ N        = liquidError "never happens"
diff --git a/tests/pos/IdNat.hs b/tests/pos/IdNat.hs
deleted file mode 100644
--- a/tests/pos/IdNat.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module IdNat where
-
-{-@ nat :: Nat @-}
-nat :: Int
-nat = id 0 -- (id (id (id (id 0))))
diff --git a/tests/pos/IdNat0.hs b/tests/pos/IdNat0.hs
deleted file mode 100644
--- a/tests/pos/IdNat0.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module IdNat0 where
-
-{-@ nat :: Nat @-}
-nat :: Int
-nat = idd 0 
-
-idd :: a -> a
-idd = undefined 
diff --git a/tests/pos/Ignores.hs b/tests/pos/Ignores.hs
deleted file mode 100644
--- a/tests/pos/Ignores.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module Ignores where
-
-{-@ ignore inc @-}
-{-@ inc :: Nat -> Nat @-}
-inc :: Int -> Int 
-inc x = x - 1 
-
diff --git a/tests/pos/Imp0.hs b/tests/pos/Imp0.hs
deleted file mode 100644
--- a/tests/pos/Imp0.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-module Imp0 () where
-
-import Language.Haskell.Liquid.Prelude
-import Foreign.Storable
-
--- ERROR goes away if we:
--- import Language.Haskell.Liquid.Foreign
-
--- We shouldn't have to do so since, 
---   include/Foreign/Storable.Spec
--- has the line:
---   import Language.Haskell.Liquid.Foreign
-
--- HYPOTHESIS: the import in the spec file above ONLY
---             imports other .spec files... and hence 
---             ignores include/Language/Haskell/Liquid/Foreign.hs 
-
-{-@ inc :: x:Nat -> {v:Nat | v > x} @-}
-inc :: Int -> Int
-inc x = x + 1
diff --git a/tests/pos/Implies.hs b/tests/pos/Implies.hs
deleted file mode 100644
--- a/tests/pos/Implies.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module Implies where
-
-{-@ inline implies @-}
-implies p q = (not p) || q
-
diff --git a/tests/pos/Infinity.hs b/tests/pos/Infinity.hs
deleted file mode 100644
--- a/tests/pos/Infinity.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-module Infinity () where
-
-import Language.Haskell.Liquid.Prelude
-{-@ lazy inf @-}
-
-{-@ inf :: {v:[Int] | (((len v) > oo) && ((len v) > 2))} @-}
-inf :: [Int]
-inf = 1 : inf
-
-bar = tail $ tail inf
-
-
-foo = inf !! n
-  where n = myabs $ choose 0
-
-myabs :: Int -> Int
-{-@ myabs :: Int -> {v:Int | v >= 0} @-}
-myabs = undefined
-
--- Encoding infinity.....
-
-{-@ measure oo :: Int @-}
-{-@ invariant {v:Int | (v < oo) }@-}
diff --git a/tests/pos/Infix.hs b/tests/pos/Infix.hs
deleted file mode 100644
--- a/tests/pos/Infix.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-module Infix () where
-
-import Language.Haskell.Liquid.Prelude (liquidAssert)
-
-{-@ (!) :: zogbert:{v: Int | v > 0} -> {v: Int | v > 0} -> Int @-}
-(!) :: Int -> Int -> Int
-x ! y = x + y
-
-
-{-@ (!!) :: {v: Int | v > 0} -> {v: Int | v > 0} -> Int @-}
-(!!)   :: Int -> Int -> Int 
-x !! y = liquidAssert (x /= 0) $ x + y 
-
-{-@ zoo :: {v: Int | v > 0} -> {v: Int | v > 0} -> Int @-}
-zoo   :: Int -> Int -> Int 
-zoo x y = liquidAssert (x /= 0) $ x + y 
-
-
diff --git a/tests/pos/Inline.hs b/tests/pos/Inline.hs
deleted file mode 100644
--- a/tests/pos/Inline.hs
+++ /dev/null
@@ -1,39 +0,0 @@
-{-@ LIQUID "--no-totality" @-}
-module Inline where
-
-{-@ inline eqq @-}
-eqq :: Ord a => a -> a -> Bool
-eqq x y = x > y
-
-{-@ eqqtest :: Eq a => x:a -> y:a -> {v:Bool | v <=> (eqq x y) } @-}
-eqqtest :: Ord a => a -> a -> Bool
-eqqtest x y = x > y
-
-{-@ inline mymax @-}
-mymax :: Ord a => a -> a -> a
-mymax x y = if x >= y then x else y
-
-{-@ inline mymin @-}
-mymin :: Ord a => a -> a -> a
-mymin x y = mymax y x
-
-{-@ measure foo @-}
-foo :: Ord a => D a -> a
-foo (D x y) = mymax x y
-foo (F x)   = x
-
-{-@ measure bar @-}
-bar :: Ord a => D a -> a
-bar (D x y) = mymax x y
-
-{-@ measure bar2 @-}
-bar2 :: Ord a => D a -> a
-bar2 (D x y) = mymin y x
-
-foooo = D
-
-data D a = D a a | F a
-
-{-@ mymax3, mymax :: x:a -> y:a -> {v:a | v = mymax x y} @-}
-mymax3 :: Ord a => a -> a -> a
-mymax3 x y = if x >= y then x else y
diff --git a/tests/pos/Inline1.hs b/tests/pos/Inline1.hs
deleted file mode 100644
--- a/tests/pos/Inline1.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-module Inline1 where
-
-data Zoo a = Z { elts :: [a], sz :: Int }
-
--- | this is not ok (unbound symbol `boo`)
-{-@ data Zoo a = Z { elts :: [a], sz :: {v: Int | isBoo v elts} } @-}
-
-{-@ inline isBoo @-}
-isBoo :: Int -> [a] -> Bool
-isBoo v e = v == boo e
-
-{-@ type Moo a = {v:Zoo a | sz v = boo (elts v)} @-}
-
-{-@ inline boo @-}
-boo    :: [a] -> Int
-boo xs = 0
diff --git a/tests/pos/Invlhs.hs b/tests/pos/Invlhs.hs
deleted file mode 100644
--- a/tests/pos/Invlhs.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-module Invlhs where
-
-data Bob = B {foo :: Int}
-{-@ data Bob = B {foo :: Int} @-}
-
-{-@ foo :: x:Bob -> {v:Int | v = foo x} @-}
-
-{-@ invariant {v:Bob | foo v == 10} @-}
-
-mk :: a -> Bob
-mk = undefined
-
-{-@ propFAIL :: {v:_ | foo v = 10} @-}
-propFAIL = mk ()
-
-{-@ propOK :: {v:_ | foo v = 10} @-}
-propOK = let z = mk () in z 
-
-
diff --git a/tests/pos/Ite.hs b/tests/pos/Ite.hs
deleted file mode 100644
--- a/tests/pos/Ite.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Ite () where
-
-{-@ assert myabs :: x:Int -> {v: Int | if x > 0 then v = x else v + x = 0 } @-}
-myabs :: Int -> Int
-myabs x | x > 0     = x
-        | otherwise = (0 - x)
diff --git a/tests/pos/Ite1.hs b/tests/pos/Ite1.hs
deleted file mode 100644
--- a/tests/pos/Ite1.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Ite1 () where
-
-{-@ assert myabs :: x:Int -> {v: Int | v = (if x > 0 then x else (0 - x)) } @-}
-myabs :: Int -> Int
-myabs x | x > 0     = x
-        | otherwise = (0 - x)
diff --git a/tests/pos/Jeff.hs b/tests/pos/Jeff.hs
deleted file mode 100644
--- a/tests/pos/Jeff.hs
+++ /dev/null
@@ -1,261 +0,0 @@
-{-
-
-This code implements a Monoid for string matching; i.e. a data
-structure, MatchIdxs, which has the result of a string match function
-plus a little extra information for monoidally combining things
-together; the purpose of course is to parallelize string matching
-computations. This is the original version I wrote which uses type
-level strings to guarantee that only computations done with the same
-target string are combinable.
-
-The invariants I'd like to prove are in the comments on the MatchIdxs
-constructors. I'd be interested in a way to do it directly with this
-code (though it seems that would require extending LH), or doing it in
-a version of this code where the constructors have an extra argument
-with the value of the target-- however that formulation seems to raise
-issues about forcing those values to be the same.
-
-I have a version of the code lying around which tries this approach,
-but I couldn't get it to work. I chose to send this version first so
-you have the chance to see where I started; I could send you my version
-with the explicit terms if you like.
-
-If this goes well, then there are a couple of further things to think
-about:
-
-  1) I have another Monoid construction for actual splitting, but
-     I don't think LH can handle the invariants as they require an
-     isInfixOf operation; but I could be wrong about what LH can do.
-
-  2) It would be interesting to think about whether one can encode
-     correctness, rather than just some invariants. By correctness
-     I mean both that the monoid laws are satisfied, and that there
-     is a homomorphic-like property to the effect of:
-
-     match (x <> y) == match x <> match y
-
-Let me know if you have any questions about the code, or need more
-comments/explanation.
--}
-
-
-{- LIQUID "--diff" @-}
-{-@ LIQUID "--scrape-used-imports" @-}
-{-@ LIQUID "--short-names" @-}
-
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Jeff 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)
-import Prelude hiding (head, min, 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      :: {b:BS.ByteString | bLength b < bLength targ}
-              }
-
-      | MatchIdxs
-              { targ    :: ByteStringNE
-              , input   :: {i  : Int | i >= bLength targ}
-              , left    :: {l  : BS.ByteString | bLength l == bLength targ - 1}
-              , matches :: [{v : Int | v <= input - bLength targ}]
-              , right   :: {r  : BS.ByteString | bLength r == 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
diff --git a/tests/pos/Keys.hs b/tests/pos/Keys.hs
deleted file mode 100644
--- a/tests/pos/Keys.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-{-@ LIQUID "--prune-unsorted" @-}
-
-module Keys where
-
-
-import qualified Data.Set as S
-
-{-@ measure keys @-}
-keys :: (Ord k) => [(k, v)] -> S.Set k
-keys []       = S.empty
-keys (kv:kvs) = (S.singleton (myfst kv)) `S.union` (keys kvs)
-
-{-@ measure myfst @-}
-myfst :: (a, b) -> a
-myfst (x, _) = x
-
--- this is fine
-
-{-@ measure okeys  :: [(a, b)] -> (S.Set a)
-     okeys []     = (Set_empty 0)
-     okeys (kv:kvs) = (Set_cup (Set_sng (fst kv)) (okeys kvs))
-  @-}
diff --git a/tests/pos/Kmp.hs b/tests/pos/Kmp.hs
deleted file mode 100644
--- a/tests/pos/Kmp.hs
+++ /dev/null
@@ -1,95 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-{-@ LIQUID "--short-names"    @-}
-
-module Kmp (search) where
-
-import Language.Haskell.Liquid.Prelude (liquidError)
-
-search pat str = kmpSearch (ofList pat) (ofList str) 
-
--------------------------------------------------------------
--- | Do the Search ------------------------------------------
--------------------------------------------------------------
-
-kmpSearch p@(A m _) s@(A n _) = go 0 0 
-  where
-    t              = kmpTable p
-    go i j
-      | j >= m     = i - m
-      | i >= n     = (-1)
-      | s!i == p!j = go (i+1) (j+1)
-      | j == 0     = go (i+1) j
-      | otherwise  = go i     (t!j) 
-
-
--------------------------------------------------------------
--- | Make Table ---------------------------------------------
--------------------------------------------------------------
-
-{-@ kmpTable :: (Eq a) => p:Arr a -> {v:DArr Nat | alen v = alen p} @-}
-kmpTable p@(A m _) = go 1 0 t
-  where
-    t              = new m (\_ -> 0)
-    go i j t
-      | i >= m - 1 = t
-
-      | p!i == p!j = let i' = i + 1
-                         j' = j + 1
-                         t' = wipe $ set t i' j'
-                     in go i' j' t'           
-    
-      | (j == 0)   = let i' = i + 1
-                         t' = wipe $ set t i' 0
-                     in go i' j t'
-                             
-      | otherwise  = let j' = t ! j
-                     in go i j' t 
-
-{-@ wipe :: a:DArr Nat -> {v:DArr Nat | alen v = alen a} @-}
-wipe :: Arr Int -> Arr Int
-wipe = undefined
-
-
-{-@ type DArr a = Arr<{\k v -> v <= k}> a @-}
-{-@ type Upto N = {v:Nat | v < N} @-} 
-
--------------------------------------------------------------
--- | An Array type ------------------------------------------
--------------------------------------------------------------
-
-data Arr a = A { alen :: Int
-               , aval :: Int -> a
-               }
-
-{-@ data Arr a  a -> Bool>
-      = A { alen :: Nat 
-          , aval :: i:Upto alen -> a
-          }
-  @-}
-
-
-{-@ new :: forall 
 a -> Bool>.
-             n:Nat -> (i:Upto n -> a
) -> {v: Arr
 a | alen v = n}
-  @-}
-new n v = A { alen = n
-            , aval = \i -> if (0 <= i && i < n)
-                             then v i
-                             else liquidError "Out of Bounds!"
-            }
-
-{-@ (!) :: forall 
 a -> Bool>.
-             a:Arr
 a -> i:Upto (alen a) -> a

-  @-}
-
-(A _ f) ! i = f i
-  
-{-@ set :: forall 
 a -> Bool>.
-             a:Arr
 a -> i:Upto (alen a) -> a
 -> {v:Arr
 a | alen v = alen a}
-  @-}
-set a@(A _ f) i v = a { aval = \j -> if (i == j) then v else f j }
-
-
-{-@ ofList :: xs:[a] -> {v:Arr a | alen v = len xs} @-} 
-ofList :: [a] -> Arr a
-ofList = undefined
-
diff --git a/tests/pos/KmpIO.hs b/tests/pos/KmpIO.hs
deleted file mode 100644
--- a/tests/pos/KmpIO.hs
+++ /dev/null
@@ -1,139 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-{-@ LIQUID "--short-names"    @-}
-
-module KmpIO (search) where
-
-import Language.Haskell.Liquid.Prelude (liquidError)
-import Data.IORef
-import Control.Applicative ((<$>))
-import qualified Data.Map as M
-
-{-@ type Upto N = {v:Nat | v < N} @-}
-
----------------------------------------------------------------------------
-{-@ search :: String -> str:String -> Maybe (Upto (len str)) @-}
----------------------------------------------------------------------------
-search :: String -> String -> Maybe Int
-search pat str = kmpSearch (ofList pat) (ofList str)
-
-
--------------------------------------------------------------
--- | Do the Search ------------------------------------------
--------------------------------------------------------------
-
-{-@ kmpSearch :: (Eq a) => p:Arr a -> s:Arr a -> Maybe (Upto (alen s)) @-}
-kmpSearch p@(A m _) s@(A n _) = go 0 0
-  where
-    t              = kmpTable p
-    go i j
-      | i >= n     = Nothing
-      | j >= m     = Just (i - m)
-      | s!i == p!j = go (i+1) (j+1)
-      | j == 0     = go (i+1) j
-      | otherwise  = go i     (t!j)
-
-
--------------------------------------------------------------
--- | Make Table ---------------------------------------------
--------------------------------------------------------------
-
-kmpTable p@(A m _) = go t 1 0
-  where
-    t              = new m (\_ -> 0)
-    go t i j
-      | i >= m - 1 = t
-
-      | p!i == p!j = let i' = i + 1
-                         j' = j + 1
-                         t' = set t i' j'
-                     in go t' i' j'
-
-      | (j == 0)   = let i' = i + 1
-                         t' = set t i' 0
-                     in go t' i' j
-
-      | otherwise  = let j' = t ! j
-                     in go t i j'
-
-
--------------------------------------------------------------
--- | A Pure Array -------------------------------------------
--------------------------------------------------------------
-
-data Arr a   = A { alen :: Int
-                 , aval :: Int -> a
-                 }
-
-{-@ data Arr a 
 a -> Bool>
-             = A { alen :: Nat
-                 , aval :: i:Upto alen -> a

-                 }
-  @-}
-
-
-{-@ new :: forall 
 a -> Bool>.
-             n:Nat -> (i:Upto n -> a
) -> {v: Arr
 a | alen v = n}
-  @-}
-new n v = A { alen = n
-            , aval = \i -> if (0 <= i && i < n)
-                             then v i
-                             else liquidError "Out of Bounds!"
-            }
-
-{-@ (!) :: forall 
 a -> Bool>.
-             a:Arr
 a -> i:Upto (alen a) -> a

-  @-}
-
-(A _ f) ! i = f i
-
-{-@ set :: forall 
 a -> Bool>.
-             a:Arr
 a -> i:Upto (alen a) -> a
 -> {v:Arr
 a | alen v = alen a}
-  @-}
-set a@(A _ f) i v = a { aval = \j -> if (i == j) then v else f j }
-
-
-{-@ ofList :: xs:[a] -> {v:Arr a | alen v = len xs} @-}
-ofList xs = new n f
-  where
-    n     = length xs
-    m     = M.fromList $ zip [0..] xs
-    f i   = (M.!) m i
-
-{-@ map :: (a -> b) -> a:Arr a -> {v:Arr b | alen v = alen a} @-}
-map f a@(A n z) = A n (f . z)
-
-
-
--------------------------------------------------------------
--- | An Imperative Array ------------------------------------
--------------------------------------------------------------
-
-data IOArr a = IOA { size :: Int
-                   , pntr :: IORef (Arr a)
-                   }
-
-{-@ data IOArr a 
 a -> Bool>
-      = IOA { size :: Nat
-            , pntr :: IORef ({v:Arr
 a | alen v = size})
-            }
-  @-}
-
-{-@ newIO :: forall 
 a -> Bool>.
-               n:Nat -> (i:Upto n -> a
) -> IO ({v: IOArr
 a | size v = n})
-  @-}
-newIO n f = IOA n <$> newIORef (new n f)
-
-{-@ getIO :: forall 
 a -> Bool>.
-              a:IOArr
 a -> i:Upto (size a) -> IO (a
)
-  @-}
-getIO a@(IOA sz p) i
-  = do arr   <- readIORef p
-       return $ (arr ! i)
-
-{-@ setIO :: forall 
 a -> Bool>.
-              a:IOArr
 a -> i:Upto (size a) -> a
 -> IO ()
-  @-}
-setIO a@(IOA sz p) i v
-  = do arr     <- readIORef p
-       let arr' = set arr i v
-       writeIORef p arr'
diff --git a/tests/pos/KmpVec.hs b/tests/pos/KmpVec.hs
deleted file mode 100644
--- a/tests/pos/KmpVec.hs
+++ /dev/null
@@ -1,63 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-{-@ LIQUID "--short-names"    @-}
-
-module KmpVec (search) where
-
-import Language.Haskell.Liquid.Prelude (liquidError)
-import Data.Vector
-import Data.Vector.Mutable (write)
-import Prelude hiding (length, replicate)
-
-{-@ type Idx X = {v:Nat | v < vlen X} @-}
-
-
-search pat str = kmpSearch (fromList pat) (fromList str) 
-
--------------------------------------------------------------
--- | Do the Search ------------------------------------------
--------------------------------------------------------------
-
-kmpSearch p s      = go 0 0 
-  where
-    t              = kmpTable p
-    m              = length p
-    n              = length s
-    go i j
-      | j >= m     = i - m
-      | i >= n     = (-1)
-      | s!i == p!j = go (i+1) (j+1)
-      | j == 0     = go (i+1) j
-      | otherwise  = go i     (t!j) 
-
-
--------------------------------------------------------------
--- | Make Table ---------------------------------------------
--------------------------------------------------------------
-
-{-@ kmpTable :: (Eq a) => p:Vector a -> {v:Vector Nat | vlen v = vlen p} @-}
-kmpTable p         = go 1 0 t
-  where
-    m              = length p
-    t              = replicate m 0 
-    go i j t
-      | i >= m - 1 = t
-
-      | p!i == p!j = let i' = i + 1
-                         j' = j + 1
-                         t' = set t i' j'
-                     in go i' j' t'           
-    
-      | (j == 0)   = let i' = i + 1
-                         t' = set t i' 0
-                     in go i' j t'
-                             
-      | otherwise  = let j' = t ! j
-                     in go i j' t 
-
-
-{-@ type Upto N = {v:Nat | v < N} @-} 
-
-{-@ set :: a:Vector a -> i:Idx a -> a -> {v:Vector a | vlen v = vlen a} @-}
-set :: Vector a -> Int -> a -> Vector a
-set = undefined
-
diff --git a/tests/pos/LNot.hs b/tests/pos/LNot.hs
deleted file mode 100644
--- a/tests/pos/LNot.hs
+++ /dev/null
@@ -1,30 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple"        @-}
-module LNot where 
-import Prelude  hiding (any, all, filter, nub, foldr, flip)
-
-
-
-{-@  lemma_all_ex_not :: f:(a->Bool) -> ls:[a] -> { (bnot (any f ls)) == all (bnot . f) ls} @-}
-lemma_all_ex_not :: (a->Bool) -> [a] -> ()
-lemma_all_ex_not f [] = ()
-lemma_all_ex_not f (x:xs) 
-  | f x = lemma_all_ex_not f xs 
-lemma_all_ex_not f (x:xs) 
-  | (bnot . f) x = lemma_all_ex_not f xs 
-
-{-@ reflect any @-}
-any :: (a -> Bool) -> [a] -> Bool 
-any _ []     = False 
-any p (x:xs) = if p x then True else any p xs
-
-{-@ reflect all @-}
-all :: (a -> Bool) -> [a] -> Bool 
-all _ []     = True 
-all p (x:xs) = if p x then all p xs else False 
-
-{-@ reflect bnot @-}
-{-@ bnot :: x:Bool -> {v:Bool | v = not x} @-} 
-bnot :: Bool -> Bool 
-bnot True  = False 
-bnot False = True  
diff --git a/tests/pos/LambdaDeBruijn.hs b/tests/pos/LambdaDeBruijn.hs
deleted file mode 100644
--- a/tests/pos/LambdaDeBruijn.hs
+++ /dev/null
@@ -1,88 +0,0 @@
-module LambdaDeBruijn where
-
-{-@ LIQUID "--prune-unsorted" @-}
-
-{- Proving Termination of Parallel Substitutions,
-   see  § 3.2.2 of Dependent Types and Multi Monadic Effects in F*
- -}
-
-import Language.Haskell.Liquid.Prelude
-
-type Var = Int
-{-@ type EVar = {v:Expr| isEVar v} @-}
-
-type Subst = [(Var, Expr)]
-{-@ type RenamingSubst = {su: [(Var, Expr)] | isRenaming su} @-}
-
-
-{- TODO: in the F* paper, substitutions are functions,
-   can we have function representation with LH?             -}
-
-
-data Typ
-
-data Expr = EVar Var
-          | ELam Typ Expr
-          | EUnit
-          | EApp Expr Expr
-{-@ data Expr [elen] @-}
-
-
-{-@ type MEVar E SU = {v:Expr | (isEVar E && isRenaming SU) => (isEVar v) } @-}
-
-
-{-@ sub :: su:Subst -> v:Var -> {v:Expr | (isRenaming su) => (isEVar v) } @-}
-sub [] v                       = EVar v
-sub ((vx, x):su) v | v == vx   = x
-                   | otherwise = sub su v
-
-
-{-@ subst :: e:Expr -> su:Subst -> MEVar e su
-      / [ (if (isEVar e) then 0 else 1), (if (isRenaming su) then 0 else 1), elen e] @-}
-
-subst EUnit        su = EUnit
-subst (EVar v)     su = sub su v
-subst (EApp e1 e2) su = EApp (subst e1 su) (subst e2 su)
-
-subst (ELam t e)   su | isRenaming su =
-  let su' =  toRem $ (0, EVar 0): map (\i -> (i, subst (sub su (i-1)) $ incrsubst ())) [1..]
-  in ELam t $ subst e su'
-
-subst (ELam t e)   su = -- | not $ isRenaming su
-    let su' =  (0, EVar 0): map (\i -> (i, subst (sub su (i-1)) $ incrsubst ())) [1..]
-    in ELam t $ subst e su'
-
-
-
-{-- Helper functions and measure definitions --}
-
-{-@ toRem :: [(Var, EVar)] -> RenamingSubst @-}
-toRem :: Subst -> Subst
-toRem [] = []
-toRem ((x, y):sus) = (x, y):toRem sus
-
-{-@ incrsubst :: () -> RenamingSubst @-}
-incrsubst :: () -> Subst
-incrsubst _ = toRem $  map (\i -> (i, EVar $ i+1)) [0..]
-
-{-@ measure isEVar @-}
-isEVar :: Expr -> Bool
-isEVar (EVar _) = True
-isEVar _        = False
-
-{-@ measure isRenaming @-}
-isRenaming :: Subst -> Bool
-isRenaming (vx:sus) = isEVar (mysnd vx) && isRenaming sus
-isRenaming [] = True
-
-{-@ measure mysnd @-}
-mysnd :: (a, b) -> b
-mysnd (_, y) = y
-
-{-@ invariant {v:Expr | elen v >= 0 } @-}
-{-@ measure elen @-}
-elen :: Expr -> Int
-elen EUnit    = 0
-elen (EVar v) = 0
-elen (ELam _ e) = 1 + elen e
-elen (EApp e1 e2) = 1 + elen e1 + elen e2
diff --git a/tests/pos/LambdaEval.hs b/tests/pos/LambdaEval.hs
deleted file mode 100644
--- a/tests/pos/LambdaEval.hs
+++ /dev/null
@@ -1,162 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-
-module LambdaEval () where
-
-import Data.List        (lookup)
-
-import Language.Haskell.Liquid.Prelude
-
----------------------------------------------------------------------
------------------------ Datatype Definition -------------------------
----------------------------------------------------------------------
-
-import Prelude hiding (error)
-
-{-@ error :: a -> b @-}
-error :: a -> b
-error x = error x
-
-type Bndr
-  = Int
-
-data Expr
-  = Lam Bndr Expr
-  | Var Bndr
-  | App Expr Expr
-  | Const Int
-  | Plus Expr Expr
-  | Pair Expr Expr
-  | Fst Expr
-  | Snd Expr
-
-{-@
-data Expr
-  = Lam   { eX :: Bndr, eBody :: Expr }
-  | Var   { eX :: Bndr                }
-  | App   { eL :: Expr, eR    :: Expr }
-  | Const { eN :: Int                 }
-  | Plus  { eL :: Expr, eR :: Expr    }
-  | Pair  { eL :: Expr, eR :: Expr    }
-  | Fst   { eL :: Expr                }
-  | Snd   { eL :: Expr                }
-@-}
-
-{-@ measure elen @-}
-elen :: (Expr) -> Int
-elen (Lam x e)    = 1 + (elen e)
-elen (Var x)      = 0
-elen (App e1 e2)  = 1 + (elen e1) + (elen e2)
-elen (Const i)    = 1
-elen (Plus e1 e2) = 1 + (elen e1) + (elen e2)
-elen (Pair e1 e2) = 1 + (elen e1) + (elen e2)
-elen (Fst e)      = 1 + (elen e)
-elen (Snd e)      = 1 + (elen e)
-
-
-{-@ invariant {v:Expr | (elen v) >= 0} @-}
-
-{-@ measure isValue @-} 
-isValue :: Expr -> Bool
-isValue (Const i)    = True
-isValue (Lam x e)    = True
-isValue (Var x)      = False
-isValue (App e1 e2)  = False
-isValue (Plus e1 e2) = False
-isValue (Fst e)      = False
-isValue (Snd e)      = False
-isValue (Pair e1 e2) = (isValue e1) && (isValue e2)
-
-{-@ type Value = {v: Expr | isValue v } @-}
-
----------------------------------------------------------------------
--------------------------- The Evaluator ----------------------------
----------------------------------------------------------------------
-
-{-@ decrease evalVar 2 @-}
-evalVar :: Bndr -> [(Bndr, Expr)] -> Expr
-evalVar x ((y,v):sto)
-  | x == y
-  = v
-  | otherwise
-  = evalVar x sto
-
-evalVar x []
-  = error "unbound variable"
-
-
-{-@ decrease eval 2 @-}
-{-@ eval :: [(Bndr, Value)] -> Expr -> ([(Bndr, Value)], Value) @-}
-eval sto (Const i)
-  = (sto, Const i)
-
-eval sto (Var x)
-  = (sto, evalVar x sto)
-
-eval sto (Plus e1 e2)
-  = let (_, e1') = eval sto e1
-        (_, e2') = eval sto e2
-    in case (e1, e2) of
-         (Const i1, Const i2) -> (sto, Const (i1 + i2))
-         _                    -> error "non-integer addition"
-
-eval sto (App e1 e2)
-  = let (_,    v2 ) = eval sto e2
-        (sto1, e1') = eval sto e1
-    in case e1' of
-         (Lam x e) -> eval ((x, v2): sto1) e
-         _         -> error "non-function application"
-
-eval sto (Lam x e)
-  = (sto, Lam x e)
-
-eval sto (Pair e1 e2)
-  = (sto, Pair v1 v2)
-  where (_, v1) = eval sto e1
-        (_, v2) = eval sto e2
-
-eval sto (Fst e)
-  = let (sto', e') = eval sto e in
-    case e' of
-      Pair v _ -> (sto', v)
-      _        -> error "non-tuple fst"
-
-eval sto (Snd e)
-  = let (sto', e') = eval sto e in
-    case e' of
-      Pair _ v -> (sto', v)
-      _        -> error "non-tuple snd"
-
----------------------------------------------------------------------
--------------------------- Value Checker ----------------------------
----------------------------------------------------------------------
-
-{-@ assert check :: {v: Expr | isValue v } -> Bool @-}
-check (Const _)    = True
-check (Lam _ _)    = True
-check (Var _)      = liquidAssertB False
-check (App _ _)    = liquidAssertB False
-check (Pair v1 v2) = check v1 && check v2
-check (Fst _)      = liquidAssertB False
-check (Snd _)      = liquidAssertB False
-check (Plus _ _)   = liquidAssertB False
-
----------------------------------------------------------------------
--------------------------- Unit Tests -------------------------------
----------------------------------------------------------------------
-
-{-
-tests =
-  let (f,g,x) = (0,1,2)
-      e1      = Lam x (Var x)
-      e2      = App e1 e1
-      e3      = Lam f (Lam g (Lam x (App (Var f)  (App (Var g) (Var x)))))
-      e4      = Const 10
-      e5      = App e1 e4
-      e6      = Lam x (Plus (Var x) e4)
-      e7      = App (App e3 e6) e6
-      e8      = Pair (App e7 (Const 0)) (App e7 (Const 100))
-      e9      = Fst e8
-      e10     = Snd e9
-      vs      = map (snd . eval []) [e1, e2, e3, e4, e5, e6, e7, e8, e9, e10]
-  in map check vs
-  -}
diff --git a/tests/pos/LambdaEvalMini.hs b/tests/pos/LambdaEvalMini.hs
deleted file mode 100644
--- a/tests/pos/LambdaEvalMini.hs
+++ /dev/null
@@ -1,93 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-{-@ LIQUID "--no-totality" @-}
-
-module LambdaEvalMini () where
-
-import Language.Haskell.Liquid.Prelude
-
----------------------------------------------------------------------
------------------------ Datatype Definition -------------------------
----------------------------------------------------------------------
-
-type Bndr
-  = Int
-
-data Expr
-  = Lam Bndr Expr
-  | Var Bndr
-  | App Expr Expr
-
-{-@
-data Expr 
-  = Lam { eX :: Bndr, eBody :: Expr }
-  | Var { eX :: Bndr                }
-  | App { eF :: Expr, eArg  ::Expr  }
-@-}
-
-
-{-@ measure elen @-}
-elen :: Expr -> Int
-elen (Var x)     = 0
-elen (Lam x e)   = 1 + (elen e)
-elen (App e1 e2) = 1 + (elen e1) + (elen e2)
-
-{-@ invariant {v:Expr | (elen v) >= 0} @-}
-
-{-@ measure isValue @-}
-isValue :: Expr -> Bool
-isValue (Lam x e)    = True
-isValue (Var x)      = False
-isValue (App e1 e2)  = False
-
-{-@ type Value = {v: Expr | isValue v } @-}
-
----------------------------------------------------------------------
--------------------------- The Evaluator ----------------------------
----------------------------------------------------------------------
-
-evalVar x ((y, v):sto)
-  | x == y
-  = v
-  | otherwise
-  = evalVar x sto
-
-evalVar x []
-  = unsafeError "unbound variable"
-
--- A "value" is simply: {v: Expr | isValue v } *)
-
-{-@ decrease eval 2 @-}
-{-@ eval :: [(Bndr, Value)] -> Expr -> ([(Bndr, Value)], Value) @-}
-
-eval sto (Var x)
-  = (sto, evalVar x sto)
-
-eval sto (App e1 e2)
-  = let (_,    v2 ) = eval sto e2
-        (sto1XXX, e1') = eval sto e1
-    in case e1' of
-         (Lam x e) -> eval ((x, v2): sto1XXX) e
-         _         -> unsafeError "non-function application"
-
-eval sto (Lam x e)
-  = (sto, Lam x e)
-
------------------------------------------------------------------------
----------------------------- Value Checker ----------------------------
------------------------------------------------------------------------
-
-check (Lam _ _)    = True
-check (Var _)      = liquidAssertB False
-check (App _ _)    = liquidAssertB False
-
------------------------------------------------------------------------
----------------------------- Unit Tests -------------------------------
------------------------------------------------------------------------
-mysnd (x, y) = y
-tests =
-  let (f,g,x) = (0,1,2)
-      e1      = Lam x (Var x)
-      e2      = App e1 e1
-      e3      = Lam f (Lam g (Lam x (App (Var f)  (App (Var g) (Var x)))))
-      vs      = map (mysnd . eval []) [e1, e2, e3]
-  in map check vs
diff --git a/tests/pos/LambdaEvalSuperTiny.hs b/tests/pos/LambdaEvalSuperTiny.hs
deleted file mode 100644
--- a/tests/pos/LambdaEvalSuperTiny.hs
+++ /dev/null
@@ -1,66 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-{-@ LIQUID "--no-totality" @-}
-
-module LambdaEvalSuperTiny () where
-import Language.Haskell.Liquid.Prelude 
-
----------------------------------------------------------------------
------------------------ Datatype Definition -------------------------
----------------------------------------------------------------------
-
-data Pair a b = P a b
-data LL a     = Nil | Cons a (LL a)
-
-data Bndr
-
-data Expr
-  = Lam Bndr Expr
-  | Var Bndr
-  | App Expr Expr
-
-{-@
-data Expr
-  = Lam { eX :: Bndr, eBody :: Expr }
-  | Var { eX :: Bndr                }
-  | App { eF :: Expr, eArg  ::Expr  }
-@-}
-
-{-@ measure elen @-}
-elen :: Expr -> Int
-elen (Var x)     = 0
-elen (Lam x e)   = 1 + (elen e)
-elen (App e1 e2) = 1 + (elen e1) + (elen e2)
-
-{-@ invariant {v:Expr | (elen v) >= 0} @-}
-
-{-@  measure isValue @-} 
-isValue :: Expr -> Bool
-isValue (Lam x e)    = True
-isValue (Var x)      = False
-isValue (App e1 e2)  = False
-
-{-@ type Value = {v: Expr | (isValue v) } @-}
-{-@ type Store = LL (Pair Bndr Value)       @-}
-
----------------------------------------------------------------------
--------------------------- The Evaluator ----------------------------
----------------------------------------------------------------------
-
-{-@ evalVar :: Bndr -> Store -> Value @-}
-evalVar :: Bndr -> LL (Pair Bndr Expr) -> Expr
-evalVar = unsafeError "HIDEME"
-
-{-@ eval :: Store -> e:Expr -> (Pair Store Value) @-}
-{-@ decrease eval 2 @-}
-eval sto (Var x)
-  = P sto (evalVar x sto)
-
-eval sto (App e1 e2)
-  = let (P _    v2 ) = eval sto e2
-        (P sto1 e1') = eval sto e1
-    in case e1' of
-         (Lam x e) -> eval (Cons (P x v2) sto1) e
-         _         -> unsafeError "non-function application"
-
-eval sto (Lam x e)
-  = P sto (Lam x e)
diff --git a/tests/pos/LambdaEvalTiny.hs b/tests/pos/LambdaEvalTiny.hs
deleted file mode 100644
--- a/tests/pos/LambdaEvalTiny.hs
+++ /dev/null
@@ -1,65 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-{-@ LIQUID "--no-totality" @-}
-
-module LambdaEvalTiny () where
-import Language.Haskell.Liquid.Prelude 
-
----------------------------------------------------------------------
------------------------ Datatype Definition -------------------------
----------------------------------------------------------------------
-
-data Bndr
-
-data Expr
-  = Lam Bndr Expr
-  | Var Bndr
-  | App Expr Expr
-
-{-@
-data Expr 
-  = Lam { eX :: Bndr, eBody :: Expr }
-  | Var { eX :: Bndr                }
-  | App { eF :: Expr, eArg  ::Expr  }
-@-}
-
-{-@ measure elen @-}
-elen :: Expr -> Int
-elen (Var x)     = 0
-elen (Lam x e)   = 1 + (elen e)
-elen (App e1 e2) = 1 + (elen e1) + (elen e2)
-
-{-@ invariant {v:Expr | (elen v) >= 0} @-}
-
-{-@ measure isValue @-}
-isValue :: Expr -> Bool
-isValue (Lam x e)    = True
-isValue (Var x)      = False
-isValue (App e1 e2)  = False
-
-{-@ type Value = {v: Expr | isValue v } @-}
-{-@ type Store = [(Bndr, Value)]            @-}
-
----------------------------------------------------------------------
--------------------------- The Evaluator ----------------------------
----------------------------------------------------------------------
-
-{-@ evalVar :: Bndr -> Store -> Value @-}
-evalVar :: Bndr -> [(Bndr, Expr)] -> Expr
-evalVar = unsafeError "HIDEME"
-
-{-@ decrease eval 2 @-}
-
-{-@ eval :: sto:Store -> e:Expr -> (Store, Value) @-}
-
-eval sto (Var x)
-  = (sto, evalVar x sto)
-
-eval sto (App e1 e2)
-  = let (_,    v2 ) = eval sto e2
-        (sto1, e1') = eval sto e1
-    in case e1' of
-         (Lam x e) -> eval ((x, v2) : sto1) e
-         _         -> unsafeError "non-function application"
-
-eval sto (Lam x e)
-  = (sto, Lam x e)
diff --git a/tests/pos/LazyWhere.hs b/tests/pos/LazyWhere.hs
deleted file mode 100644
--- a/tests/pos/LazyWhere.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module LazyWhere () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ pos :: Nat -> Int @-}
-pos :: Int -> Int
-pos = undefined
-
-
-{-@ lazyvar z @-}
-foo = if x > 0 then z else x
-  where z = pos x
-        x = choose 0
diff --git a/tests/pos/LazyWhere1.hs b/tests/pos/LazyWhere1.hs
deleted file mode 100644
--- a/tests/pos/LazyWhere1.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-module LazyWhere1 () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ pos :: Nat -> Int @-}
-pos :: Int -> Int
-pos = undefined
-
-{-@ safeDiv :: Int -> {v:Int| v != 0} -> Int @-}
-safeDiv :: Int -> Int -> Int
-safeDiv = undefined
-
-{-@ lazyvar z @-}
-{-@ lazyvar z1 @-}
-{-@ lazyvar z2 @-}
-foo = if x > 0 then z else x
-  where z  = z1 + z2
-        z1 = 42 `safeDiv` x
-        z2 = pos x
-        x = choose 0
diff --git a/tests/pos/Lets.hs b/tests/pos/Lets.hs
deleted file mode 100644
--- a/tests/pos/Lets.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-module Lets () where
-
-import Language.Haskell.Liquid.Prelude
-
-foo :: Int -> (Int, Int)
-foo z = (z, z + 1)
-
-baz :: Int -> (Int, Int)
-baz z = let (i, j) = foo z 
-        in (i, j + 1)
-
-{-@ prop :: Int -> Bool @-}
-prop x = let (a, b) = baz x in
-         liquidAssertB (a < b)
diff --git a/tests/pos/Lex.hs b/tests/pos/Lex.hs
deleted file mode 100644
--- a/tests/pos/Lex.hs
+++ /dev/null
@@ -1,10 +0,0 @@
--- TAG: termination
-
-module Lex (foo) where
-
-bar = foo [1, 2, 3] [2, 3, 4]
-
-{- decrease foo 1 2 @-}
-foo xs    (y:ys) = foo xs ys
-foo (x:xs) ys    = foo xs ys
-foo xs     ys    = xs
diff --git a/tests/pos/Lib521.hs b/tests/pos/Lib521.hs
deleted file mode 100644
--- a/tests/pos/Lib521.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module Lib521 where
-
-{-@ measure size @-}
-{-@ size    :: xs:[a] -> {v:Nat | v = size xs} @-}
-size :: [a] -> Int
-size []     = 0
-size (_:rs) = 1 + size rs
diff --git a/tests/pos/ListAnf.hs b/tests/pos/ListAnf.hs
deleted file mode 100644
--- a/tests/pos/ListAnf.hs
+++ /dev/null
@@ -1,90 +0,0 @@
-module ListAnf (llen) where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@  
-data List [llen] a 
 x1:a -> Bool>  
-  = Nil 
-  | Cons (h :: a) (t :: List 
 (a 
))
-@-}
-
-{-@ measure llen @-}
-llen :: List a -> Int 
-{-@ llen :: List a -> Nat @-} 
-llen Nil = 0 
-llen (Cons _ xs) = 1 + llen xs 
-
-data List a 
-   = Nil 
-   | Cons a (List a)
-
-checkSort Nil                        = True
-checkSort (_ `Cons` Nil)             = True
-checkSort (x1 `Cons` (x2 `Cons` xs)) = liquidAssertB (x1 <= x2) && checkSort (x2 `Cons` xs)
-
-z3 :: List Integer 
-z3    = 3 `Cons` (6 `Cons` Nil)
-prop3 = checkSort z3
-
--- The below works because it is properly ANF-ed
--- The above fails because the "3" is not hoisted out into its own binding.
-
---three :: Integer
---three = 3
---
---six :: Integer
---six = 6
---
---z2 :: List Integer 
---z2    = three `Cons` (six `Cons` Nil) 
---prop2 = checkSort z2
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/pos/ListConcat.hs b/tests/pos/ListConcat.hs
deleted file mode 100644
--- a/tests/pos/ListConcat.hs
+++ /dev/null
@@ -1,24 +0,0 @@
-{-@ LIQUID "--pruneunsorted" @-}
-{-@ LIQUID "--no-termination" @-}
-
-module ListConcat () where
-import Data.Set (Set(..)) 
-import Prelude hiding (concat)
-
-{-@ measure llElts :: [[a]] -> (Set a) 
-      llElts []   = {v | Set_emp v }
-      llElts (x:xs) = {v | v = Set_cup (listElts x) (llElts xs) }
-  @-}
-
-
-{-@ concat :: ys:[[a]] -> {v:[a] | listElts v = llElts ys } @-}
-concat :: [[a]] ->  [a]
-concat  []         = []
-concat ([]: xs)    = concat xs
-concat ((y:ys):xs) = y : concat (ys:xs)
-
-
-
-
-
-
diff --git a/tests/pos/ListElem.hs b/tests/pos/ListElem.hs
deleted file mode 100644
--- a/tests/pos/ListElem.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-module ListElem () where
-
-import Data.Set
-
-{-@ listElem :: (Eq a) 
-             => y:a 
-             -> xs:[a]
-             -> {v:Bool | v <=> Set_mem y (listElts xs)} 
-  @-}
-
-listElem :: (Eq a) => a -> [a] -> Bool
-listElem _ []     = False
-listElem y (x:xs) | x == y    = True
-                  | otherwise = listElem y xs
-
diff --git a/tests/pos/ListISort_bag.hs b/tests/pos/ListISort_bag.hs
deleted file mode 100644
--- a/tests/pos/ListISort_bag.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-module ListISort_bag where
-
-import qualified Language.Haskell.Liquid.Bag as B
-
-{-@ type OList a = [a]<{\fld v -> v >= fld}> @-}
-
-{-@ insertSort    :: (Ord a) => xs:[a] -> {v : OList a | bag v = bag xs} @-}
-insertSort        :: (Ord a) => [a] -> [a]
-insertSort []     = []
-insertSort (x:xs) = insert x (insertSort xs)
-
-{-@ insert      :: (Ord a) => x:a -> xs: OList a -> {v: OList a | bag v = B.put x (bag xs) } @-}
-insert y []     = [y]
-insert y (x:xs)
-  | y <= x    = y : x : xs
-  | otherwise = x : insert y xs
-
-{-@ measure bag @-}
-bag :: (Ord a) => [a] -> B.Bag a
-bag []     = B.empty
-bag (x:xs) = B.put x (bag xs)
diff --git a/tests/pos/ListISort_perm.hs b/tests/pos/ListISort_perm.hs
deleted file mode 100644
--- a/tests/pos/ListISort_perm.hs
+++ /dev/null
@@ -1,97 +0,0 @@
-{-# LANGUAGE GADTs            #-}
-{-@ LIQUID "--exact-data-con" @-}
-{-@ LIQUID "--higherorder"    @-}
-
-module ListISort_perm where
-
-import Language.Haskell.Liquid.ProofCombinators
-
-
--- FULL SIGS: don't work right now, thanks to https://github.com/ucsd-progsys/liquidhaskell/issues/1205
-{-type OList a = List <{\fld v -> v >= fld}> a @-}
-{- insertSort :: (Ord a) => xs:List a -> (res :: OList a, {v:_ | prop v = Perm xs res})          @-}
-{- insert     :: (Ord a) => x:a -> xs:OList a -> (res :: OList a, {v:_ | prop v = Ins x xs res}) @-}
-
-{-@ insertSort :: (Ord a) => xs:List a -> (res :: List a, {v:_ | prop v = (Perm xs res)})         @-}
-insertSort        :: (Ord a) => List a -> (List a, Perm a)
-insertSort Nil         = (Nil, NilPerm)
-insertSort (Cons x xs) = (xys, ConsPerm x xs ys xys x_ys_xys xs_ys)
-  where
-    (ys,  xs_ys)       = insertSort xs
-    (xys, x_ys_xys)    = insert x ys
-
-{-@ insert     :: (Ord a) => x:a -> xs:List a -> (res :: List a, {v:_ | prop v = (Ins x xs res)}) @-}
-insert    :: (Ord a) => a -> List a -> (List a, Ins a)
-insert y (Cons x xs)
-  | y <= x    = (Cons y (Cons x xs), Here y (Cons x xs) )
-  | otherwise = (Cons x yxs        , There y x xs yxs pf)
-  where
-    (yxs, pf) = insert y xs
-insert y Nil  = (Cons y Nil, Here y Nil)
-
--- | Lists ---------------------------------------------------------------------
-
-data List a
-  = Nil
-  | Cons { lHd :: a, lTl :: List a }
-
-{-@ data List [llen] a 
 x1:a -> Bool>
-      = Nil
-      | Cons { lHd :: a, lTl :: List 
 (a 
) }
-  @-}
-
--- | List Membership -----------------------------------------------------------
-
-data InsP a where
-  Ins :: a -> List a -> List a -> InsP a
-
-data Ins a where
-  Here  :: a -> List a -> Ins a
-  There :: a -> a -> List a -> List a -> Ins a -> Ins a
-
-{-@ data Ins [insNat] a where
-        Here  :: m:a -> ms:List a
-              -> Prop (Ins m ms (Cons m ms))
-
-        There :: m:a -> n:a -> ns:List a -> mns:List a
-              -> Prop (Ins m ns mns)
-              -> Prop (Ins m (Cons n ns) (Cons n mns))
-  @-}
-
--- | Permutations --------------------------------------------------------------
-
-data PermP a where
-  Perm :: List a -> List a -> PermP a
-
-data Perm a where
-  NilPerm  :: Perm a
-  ConsPerm :: a -> List a -> List a -> List a -> Ins a -> Perm a -> Perm a
-
-{-@ data Perm [permNat] a where
-        NilPerm  :: Prop (Perm Nil Nil)
-        ConsPerm :: m:a -> ms:List a -> ns:List a -> mns:List a
-                 -> Prop (Ins m ns mns)
-                 -> Prop (Perm ms ns)
-                 -> Prop (Perm (Cons m ms) mns)
-  @-}
-
-
--- | BOILERPLATE ---------------------------------------------------------------
-
-{-@ measure permNat @-}
-{-@ permNat :: Perm a -> Nat @-}
-permNat :: Perm a -> Int
-permNat (NilPerm)              = 0
-permNat (ConsPerm _ _ _ _ _ t) = 1 + permNat t
-
-{-@ measure insNat @-}
-{-@ insNat :: Ins a -> Nat @-}
-insNat :: Ins a -> Int
-insNat (Here _ _)        = 0
-insNat (There _ _ _ _ t) = 1 + insNat t
-
-{-@ measure llen          @-}
-{-@ llen :: List a -> Nat @-}
-llen :: List a -> Int
-llen Nil        = 0
-llen (Cons h t) = 1 + llen t
diff --git a/tests/pos/ListKeys.hs b/tests/pos/ListKeys.hs
deleted file mode 100644
--- a/tests/pos/ListKeys.hs
+++ /dev/null
@@ -1,24 +0,0 @@
-{- LIQUID "--pruneunsorted" @-}
-
-module ListKeys () where
-import Data.Set (Set(..), empty, union, singleton) 
-
-{-@  measure listKeys @-}
-listKeys :: Ord k => [(k, v)] -> Set k 
-listKeys [] = empty 
-listKeys (x:xs) = singleton (myfst x) `union` listKeys xs 
-
-{-@ measure myfst @-}
-myfst :: (a,b) -> a 
-myfst (x,_) = x 
-
-{-@ getFsts :: ys:[(a, b)] -> {v : [a] | listElts v = listKeys ys } @-}
-getFsts ::[(a, b)] ->  [a]
-getFsts []           = []
-getFsts ((x, _): xs) = x : getFsts xs
-
-
-
-
-
-
diff --git a/tests/pos/ListLen.hs b/tests/pos/ListLen.hs
deleted file mode 100644
--- a/tests/pos/ListLen.hs
+++ /dev/null
@@ -1,71 +0,0 @@
-module ListLen () where
-
-import Language.Haskell.Liquid.Prelude
-
-make2d :: a -> Int -> Int -> [[a]]
-make2d x n m = clone (clone x n) m
-
-clone :: a -> Int -> [a]
-clone x n
-  | n == 0
-  = []
-  | otherwise 
-  = x : (clone x (n-1))
-
-
-
--- check [] = [liquidAssertB True]
--- check (xs:xss) = let n = length xs in map (\xs' -> liquidAssertB (length xs' == n)) xss
-
-chk :: [[a]] -> Bool
-chk [] = liquidAssertB True
-chk (xs:xss) =
-  case xss of 
-   (xs1:xss1) -> let n = length xs in liquidAssertB (length xs1 == n) && chk xss
-   []         -> liquidAssertB True
-
-fooL  = [[1, 1, 3], [2, 2, 5]]
-fooL1 = let f = make2d n0 n1 n2 in f
-    where n0 = 0
-          n1 = 2
-          n2 = 3
-propL = chk fooL1
-prop  = chk fooL
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/pos/ListLen_LType.hs b/tests/pos/ListLen_LType.hs
deleted file mode 100644
--- a/tests/pos/ListLen_LType.hs
+++ /dev/null
@@ -1,54 +0,0 @@
-module ListLen_LType (llen) where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@  
-data List [llen] a 
 x1:a -> Bool>  
-  = Nil 
-  | Cons (h :: a) (t :: List 
 (a 
))
-@-}
-
-{-@ measure llen @-}
-llen :: (List a) -> Int
-{-@ llen :: List a -> Nat @-}
-llen Nil         = 0
-llen (Cons x xs) = 1 + (llen xs)
-
-data List a = Nil | Cons a (List a)
-
-make2d :: a -> Int -> Int -> List ([a])
-make2d x n m = cloneL (clone x n) m
-
-{-@ invariant {v:Int | v >= 0} @-}
-
-clone :: a -> Int -> [a]
-clone x n
-  | n == 0
-  = []
-  | otherwise 
-  = x : (clone x (n-1))
-
-cloneL :: a -> Int -> List a
-cloneL x n
-  | n == 0
-  = Nil
-  | otherwise 
-  = Cons x  (cloneL x (n-1))
-
--- check [] = [liquidAssertB True]
--- check (xs:xss) = let n = length xs in map (\xs' -> liquidAssertB (length xs' == n)) xss
-
-chk :: List [a] -> Bool
-chk Nil = liquidAssertB True
-chk (Cons xs xss) =
-  case xss of 
-   (Cons xs1 xss1) -> let n = length xs in liquidAssertB (length xs1 == n) && chk xss
-   Nil -> liquidAssertB True
-
-fooL  = Cons [1, 1, 3] (Cons [2, 2, 5] Nil)
-fooL1 = make2d 0 n m
-  where n = choose 0
-        m = choose 1
-
-propL = chk fooL1
-prop  = chk fooL
diff --git a/tests/pos/ListMSort.hs b/tests/pos/ListMSort.hs
deleted file mode 100644
--- a/tests/pos/ListMSort.hs
+++ /dev/null
@@ -1,37 +0,0 @@
-module ListMSort () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ type OList a = [a]<{\fld v -> (v >= fld)}>  @-}
-
-{-@ predicate Pr X Y = (((len Y) > 1) => ((len Y) < (len X))) @-}
-
-{-@ split :: xs:[a] 
-          -> ({v:[a] | (Pr xs v)}, {v:[a]|(Pr xs v)})
-                 <{\x y -> ((len x) + (len y) = (len xs))}> 
-  @-}
-
-split :: [a] -> ([a], [a])
-split (x:(y:zs)) = (x:xs, y:ys) where (xs, ys) = split zs
-split xs                   = (xs, [])
-
-
-{-@ decrease merge 4 @-}
-{-@ merge :: Ord a => xs:(OList a) -> ys:(OList a) -> d:{v:Int| v = (len xs) + (len ys)} -> {v:(OList a) | (len v) = d} @-}
-merge :: Ord a => [a] -> [a] -> Int -> [a]
-merge xs [] _ = xs
-merge [] ys _ = ys
-merge (x:xs) (y:ys) d
-  | x <= y
-  = x:(merge xs (y:ys) (d-1))
-  | otherwise 
-  = y:(merge (x:xs) ys (d-1))
-
-{-@ mergesort :: (Ord a) => xs:[a] -> {v:(OList a) | (len v) = (len xs)}  @-}
-mergesort :: Ord a => [a] -> [a]
-mergesort []  = []
-mergesort [x] = [x]
-mergesort xs  = merge (mergesort xs1) (mergesort xs2) d 
-  where (xs1, xs2) = split xs
-        d          = length xs
-
diff --git a/tests/pos/ListMSort_LType.hs b/tests/pos/ListMSort_LType.hs
deleted file mode 100644
--- a/tests/pos/ListMSort_LType.hs
+++ /dev/null
@@ -1,60 +0,0 @@
-module ListMSort_LType () where
-{-@ LIQUID "--no-termination" @-}
-
-import Language.Haskell.Liquid.Prelude
-
-{-@
-data List a 
 x1:a -> Bool>
-  = Nil
-  | Cons (h :: a) (t :: List 
 (a 
))
-@-}
-data List a = Nil | Cons a (List a)
-
-
--- This is needed to conclude that
--- xs = Nil /\ xs = Cons _ _ <=> false
-
-{-@ measure llen @-}
-llen :: (List a) -> Int
-llen Nil       = 0
-llen (Cons x xs) = 1 + llen xs
-
-{-@ invariant {v:List a | (llen v) >= 0} @-}
-
-split :: List a -> (List a, List a)
-split (Cons x (Cons y zs)) = (Cons x xs, Cons y ys) where (xs, ys) = split zs
-split xs                   = (xs, Nil)
-
-
-{-@ lazy merge @-}
-merge :: Ord a => List a -> List a -> List a
-merge xs Nil = xs
-merge Nil ys = ys
-merge (Cons x xs) (Cons y ys)
-  | x <= y
-  = Cons x (merge xs (Cons y ys))
-  | otherwise
-  = Cons y (merge (Cons x xs) ys)
-
-mergesort :: Ord a => List a -> List a
-mergesort Nil = Nil
-mergesort (Cons x Nil) = Cons x Nil
-mergesort xs = merge (mergesort xs1) (mergesort xs2) where (xs1, xs2) = split xs
-
-chk y =
-  case y of
-   Nil -> True
-   Cons x1 xs -> case xs of
-                  Nil -> True
-                  Cons x2 xs2 -> liquidAssertB (x1 <= x2) && chk xs2
-
-bar = mergesort $ mkList [1 .. 100]
-
-barI :: List Int
-barI = Cons 1 $ Cons 2 $ Cons 3 Nil
-
-mkList :: Ord a => [a] -> List a
-mkList = foldr Cons Nil
-
-prop0 = chk bar
-prop1 = chk barI
diff --git a/tests/pos/ListQSort_LType.hs b/tests/pos/ListQSort_LType.hs
deleted file mode 100644
--- a/tests/pos/ListQSort_LType.hs
+++ /dev/null
@@ -1,54 +0,0 @@
-module ListQSort_LType (llen) where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@
-data List [llen] a 
 x1:a -> Bool>
-  = Nil
-  | Cons { lHd :: a, lTl :: List 
 (a 
) }
-@-}
-
-{-@ measure llen @-}
-llen :: (List a) -> Int
-{-@ llen :: List a -> Nat @-}
-llen Nil         = 0
-llen (Cons x xs) = 1 + (llen xs)
-
-
-{-@ qualif ZLLen(v:ListRange.List a) : (llen(v) >= 0)@-}
-
-{-@ qualif CmpLLen(v:ListRange.List a, a:ListRange.List b) : (llen v <= llen a) @-}
-
-data List a = Nil | Cons a (List a)
-
-append k Nil         ys = Cons k ys
-append k (Cons x xs) ys = Cons x (append k xs ys)
-
-takeL x Nil         = Nil
-takeL x (Cons y ys) = if (y x:a
-           -> xs:List a
-           -> {v: (List {v:a | v >= x}) | ((llen v) <= (llen xs))}  @-}
-takeGE x Nil         = Nil
-takeGE x (Cons y ys) = if (y>=x) then Cons y (takeGE x ys) else takeGE x ys
-
-quicksort Nil = Nil
-quicksort (Cons x xs) = append x xsle xsge
-  where xsle = quicksort (takeL x xs)
-        xsge = quicksort (takeGE x xs)
-
-chk y =
-  case y of
-   Nil -> True
-   Cons x1 xs -> case xs of
-                 Nil -> True
-                 Cons x2 xs2 -> liquidAssertB (x1 <= x2) && chk xs
-
-bar = quicksort $ mkList [1 .. 100]
-
-mkList :: Ord a => [a] -> List a
-mkList = foldr Cons Nil
-
-prop0 = chk bar
diff --git a/tests/pos/ListRange.hs b/tests/pos/ListRange.hs
deleted file mode 100644
--- a/tests/pos/ListRange.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-module ListRange () where
-
-{-@ LIQUID "--no-termination" @-}
-
-import Language.Haskell.Liquid.Prelude
-
-low, high :: Int
-low  = choose 0
-high = choose 10
-
-range l h = 
-  if l <= h then l:(range (l+1) h) else []
-
-chk [] = liquidAssertB True
-chk (x1:xs) = case xs of 
-              []       -> liquidAssertB True
-              (x2:xs2) -> liquidAssertB (x1 <= x2) && chk xs
-
-prop = chk $ range low high
diff --git a/tests/pos/ListRange_LType.hs b/tests/pos/ListRange_LType.hs
deleted file mode 100644
--- a/tests/pos/ListRange_LType.hs
+++ /dev/null
@@ -1,38 +0,0 @@
-module ListRange_LType () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ LIQUID "--no-termination" @-}
-
-{-@
-data List a 
 x1:a -> Bool>
-  = Nil
-  | Cons { lHd :: a, lTl :: List 
 (a 
) }
-@-}
-
-{-@ measure llen @-}
-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
diff --git a/tests/pos/ListReverse_LType.hs b/tests/pos/ListReverse_LType.hs
deleted file mode 100644
--- a/tests/pos/ListReverse_LType.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-module ListReverse_LType (x, llen) where
-
-import Language.Haskell.Liquid.Prelude        
-import Prelude hiding (reverse)
-data L a = N | C a (L a)
-
-{-@ data L [llen] @-}
-
-{-@ measure llen @-}
-llen :: (L a) -> Int
-{-@ llen :: L a -> Nat @-}
-llen N        = 0
-llen (C x xs) = 1 + (llen xs)
-
-{-@ invariant {v: L a | (llen v) >= 0} @-}
-reverse N xs = xs
-reverse (C y ys) xs = reverse ys (C y xs)
-
-x = reverse (C 1 (C 2 N))
diff --git a/tests/pos/ListSet.hs b/tests/pos/ListSet.hs
deleted file mode 100644
--- a/tests/pos/ListSet.hs
+++ /dev/null
@@ -1,56 +0,0 @@
-module ListSet () where
-
--------------------------------------------------------------------------
--- | Encoding Sets of Values With Liquid Types --------------------------
--------------------------------------------------------------------------
-
--- TODO: make this self-enclosed
-
-import Data.Set (Set(..))  
-
--- | To start with, lets check that the `listElts` measure is sensible
-
-{-@ myid0 :: xs:[a] -> {v:[a]| (len v) = (len xs)} @-}
-myid0 []     = []
-myid0 (x:xs) = x : myid0 xs
-
-
-{-@ myid :: xs:[a] -> {v:[a]| (listElts v) = (listElts xs)} @-}
-myid []     = []
-myid (x:xs) = x : myid xs
-
--- | The reverse function should also return the same set of values.
--- Note that the reverse uses the tail-recursive helper @go@. 
--- Mouse over and see what type is inferred for it!
-
-{-@ decrease go 2 @-}
-{-@ myrev :: xs:[a] -> {v:[a]| listElts(v) = listElts(xs)} @-}
-myrev :: [a] -> [a]
-myrev = go [] 
-  where 
-    go acc []     = acc
-    go acc (y:ys) = go (y:acc) ys
-
--- | Next, here's good old List-append, but now with a specification about
--- the sets of values in the input and output.
-
-{-@ myapp :: xs:[a] 
-          -> ys:[a] 
-          -> {v:[a] | listElts v = Set_cup (listElts xs) (listElts ys) } @-}
-myapp :: [a] -> [a] -> [a]
-myapp []     ys = ys
-myapp (x:xs) ys = x : myapp xs ys
-
--- | Finally, to round off this little demo, here's @filter@, which returns a subset.
-
-{-@ myfilter :: (a -> Bool) -> xs:[a] -> {v:[a] | Set_sub (listElts v) (listElts xs) } @-}
-myfilter :: (a -> Bool) -> [a] -> [a]
-myfilter f []     = []
-myfilter f (x:xs) = if f x 
-                      then x : myfilter f xs 
-                      else myfilter f xs
-
-
-
-
-
diff --git a/tests/pos/ListSetDemo.hs b/tests/pos/ListSetDemo.hs
deleted file mode 100644
--- a/tests/pos/ListSetDemo.hs
+++ /dev/null
@@ -1,55 +0,0 @@
-module ListSetDemo () where
-
--------------------------------------------------------------------------
--- | Encoding Sets of Values With Liquid Types --------------------------
--------------------------------------------------------------------------
-
--- First, lets import the `Set` type from @Data.Set@
-
-import qualified Data.Set as S 
-
--- Next, lets write a measure for the set of elements in a list.
-
-{-@ measure elts @-}
-elts :: (Ord a) => [a] -> S.Set a 
-elts []     = S.empty
-elts (x:xs) = S.union (S.singleton x) (elts xs)
-
--- OK, now we can write some specifications!
-
--- | To start with, lets check that the `elts` measure is sensible
-
-{-@ myid :: xs:[a] -> {v:[a]| (elts v) = (elts xs)} @-}
-myid []     = []
-myid (x:xs) = x : myid xs
-
--- | The reverse function should also return the same set of values.
--- Note that the reverse uses the tail-recursive helper @go@. 
--- Mouse over and see what type is inferred for it!
-
-{-@ decrease go 2 @-}
-{-@ myrev :: xs:[a] -> {v:[a]| (elts v) = (elts xs)} @-}
-myrev = go [] 
-  where 
-    go acc []     = acc
-    go acc (y:ys) = go (y:acc) ys
-
--- | Next, here's good old List-append, but now with a specification about
--- the sets of values in the input and output.
-
-{-@ myapp :: xs:[a] -> ys:[a] -> {v:[a] | (elts v) = (Set_cup (elts xs) (elts ys))} @-}
-myapp []     ys = ys
-myapp (x:xs) ys = x : myapp xs ys
-
--- | Finally, to round off this little demo, here's @filter@, which returns a subset.
-
-{-@ myfilter :: (a -> Bool) -> xs:[a] -> {v:[a]| Set_sub (elts v) (elts xs) } @-}
-myfilter f []     = []
-myfilter f (x:xs) 
-  | f x           = x : myfilter f xs 
-  | otherwise     = myfilter f xs
-
-
-
-
-
diff --git a/tests/pos/ListSort.hs b/tests/pos/ListSort.hs
deleted file mode 100644
--- a/tests/pos/ListSort.hs
+++ /dev/null
@@ -1,67 +0,0 @@
-module ListSort (insertSort, insertSort', mergeSort, quickSort) where
-
-
-{-@ type OList a    = [a]<{\fld v -> (v >= fld)}> @-}
-{-@ type OListN a N = {v:OList a | len v == N} @-}
-
-------------------------------------------------------------------------------
--- Insert Sort ---------------------------------------------------------------
-------------------------------------------------------------------------------
-
-{-@ insertSort :: (Ord a) => xs:[a] -> OList a @-}
-insertSort            :: (Ord a) => [a] -> [a]
-insertSort []         = []
-insertSort (x:xs)     = insert x (insertSort xs) 
-
-{-@ insertSort' :: (Ord a) => xs:[a] -> OList a @-}
-insertSort'           :: (Ord a) => [a] -> [a]
-insertSort' xs        = foldr insert [] xs
-
-insert y []                   = [y]
-insert y (x : xs) | y <= x    = y : x : xs 
-                  | otherwise = x : insert y xs
-
-------------------------------------------------------------------------------
--- Merge Sort ----------------------------------------------------------------
-------------------------------------------------------------------------------
-
-{-@ mergeSort :: (Ord a) => xs:[a] -> OListN a {len xs} @-}
-mergeSort :: Ord a => [a] -> [a]
-mergeSort []   = []
-mergeSort [x]  = [x]
-mergeSort xs   = merge (mergeSort xs1) (mergeSort xs2) 
-  where 
-    (xs1, xs2) = split xs
-
-{-@ type Half a Ys  = {v:[a] | (len v > 1) => (len v < len Ys)} @-}
-
-{-@ type Halves a Xs = {v: (Half a Xs, Half a Xs) | len (fst v) + len (snd v) == len Xs} @-}
- 
-{-@ split :: xs:[a] -> Halves a xs @-}
-split :: [a] -> ([a], [a])
-split (x:(y:zs)) = (x:xs, y:ys) where (xs, ys) = split zs
-split xs         = (xs, [])
-
-{-@ merge :: Ord a => xs:OList a -> ys:OList a -> OListN a {len xs + len ys} / [(len xs + len ys)] @-}
-merge :: Ord a => [a] -> [a] ->  [a]
-merge xs []         = xs
-merge [] ys         = ys
-merge (x:xs) (y:ys)
-  | x <= y          = x: merge xs (y:ys)
-  | otherwise       = y : merge (x:xs) ys
-
-------------------------------------------------------------------------------
--- Quick Sort ----------------------------------------------------------------
-------------------------------------------------------------------------------
-
-{-@ quickSort :: (Ord a) => [a] -> OList a @-}
-quickSort []     = []
-quickSort (x:xs) = append x lts gts 
-  where 
-    lts          = quickSort [y | y <- xs, y < x]
-    gts          = quickSort [z | z <- xs, z >= x]
-
-append k []     ys  = k : ys
-append k (x:xs) ys  = x : append k xs ys
-
-
diff --git a/tests/pos/Listqual.hs b/tests/pos/Listqual.hs
deleted file mode 100644
--- a/tests/pos/Listqual.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module Listqual (boo) where
-
-{-@ qualif BadAppend(v:[a], xs:[a], ys:[a]): len v = len xs + len ys @-}
-
-append [] ys     = ys
-append (x:xs) ys = x : append xs ys
-
-{-@ boo :: {v:[Int] | len v = 2} @-}
-boo :: [Int]
-boo = append [1] [2]
diff --git a/tests/pos/Lit.hs b/tests/pos/Lit.hs
deleted file mode 100644
--- a/tests/pos/Lit.hs
+++ /dev/null
@@ -1,4 +0,0 @@
-module Lit where
-
-{-@ test :: {v:Int | v == 3} @-}
-test = length "cat"
diff --git a/tests/pos/Lit00.hs b/tests/pos/Lit00.hs
deleted file mode 100644
--- a/tests/pos/Lit00.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-module Lit00 where
-
-import Language.Haskell.Liquid.Prelude 
-
-poo :: () 
-poo = liquidAssert (zero /= one) ()
-
-data Peano = Z | O deriving (Eq)
-
-bob :: String 
-bob = "I am a cat"
-
-{-@ axiomatize one @-}
-one :: Peano 
-one = O 
-
-{-@ axiomatize zero @-}
-zero :: Peano
-zero = Z
diff --git a/tests/pos/Lit02.hs b/tests/pos/Lit02.hs
deleted file mode 100644
--- a/tests/pos/Lit02.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-module Lit02 where
-
-import Data.Set as S 
-
-{-@ predicate ValidMovieScheme V =
-	  ((listElts V == Set_cup (Set_sng "year")
-	  	                      (Set_cup (Set_sng "star")
-	  	                      (Set_cup (Set_sng "director")
-	  	                               (Set_sng "title"))))) @-}
-
-{-@ foo :: xs:[String] -> {ys: [String] | Set_sub (listElts xs) (listElts ys)} -> Int @-}
-foo :: [String] -> [String] -> Int 
-foo = undefined
-
-{-@ assume things :: {v:[String] | ValidMovieScheme v} @-}
-things :: [String] 
-things = undefined 
-
-bar = foo ["director"] things 
diff --git a/tests/pos/LocalHole.hs b/tests/pos/LocalHole.hs
deleted file mode 100644
--- a/tests/pos/LocalHole.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-module LocalHole where
-
-{-@ assume (!!) :: xs:[a] -> {v:Nat | v < len xs} -> a @-}
-
-mysum xs = go 0 0
-  where
-    n = length xs
-    {-@ go :: i:{Nat | i <= n} -> _ -> _ @-}
-    go i acc
-      | i >= n    = acc
-      | otherwise = go (i+1) (acc + xs !! i)
diff --git a/tests/pos/LocalLazy.hs b/tests/pos/LocalLazy.hs
deleted file mode 100644
--- a/tests/pos/LocalLazy.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module LocalLazy (bar) where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ lazy foo @-}
-foo x = foo x
-
-
-bar = liquidAssertB (inf n > 0)
-  where n     = choose 0
-       {-@ lazy inf @-}
-        inf n = inf n
diff --git a/tests/pos/LocalSpec.hs b/tests/pos/LocalSpec.hs
deleted file mode 100644
--- a/tests/pos/LocalSpec.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module LocalSpec where
-
-import LocalSpecLib
-
-{-@ bar :: {x:Int | x > 99} -> {v:Int | v > 100 } @-}
-bar :: Int -> Int
-bar x = foo x
diff --git a/tests/pos/LocalSpecLib.hs b/tests/pos/LocalSpecLib.hs
deleted file mode 100644
--- a/tests/pos/LocalSpecLib.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-module LocalSpecLib (foo) where
-
-{-@ foo :: x:Int -> {v:Int | v > x } @-}
-foo :: Int -> Int
-foo x =  go x
-
-{-@ go :: n:Int -> {v:Int | v = n + 1} @-}
-go :: Int -> Int
-go x = x + 1
diff --git a/tests/pos/LogicCurry1.hs b/tests/pos/LogicCurry1.hs
deleted file mode 100644
--- a/tests/pos/LogicCurry1.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-module LogicCurry1 where
-
-{-@ LIQUID "--higherorder"     @-}
-{-@ LIQUID "--maxparams=5"     @-}
-
-
-{-@ measure ackF :: Int -> Int -> Int  @-}
-
-{-@ assume ack :: n:Int -> {v: (x:Int -> {v:Int | v == ackF n x}) | v == ackF n } @-}
-ack :: Int -> Int -> Int
-ack = undefined
-
-bar :: Int -> Int -> Int
-{-@ bar :: n:Int -> {v:_ | v == ackF n } @-}
-bar m = ack m
-
-main :: IO ()
-main = pure ()
diff --git a/tests/pos/Loo.hs b/tests/pos/Loo.hs
deleted file mode 100644
--- a/tests/pos/Loo.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module Loo where
-
-import qualified LooLib as G
-
-plusThree = G.plusOne . G.plusTwo
-plusFour  = G.plusTwo . G.plusTwo
-
-{-@ assert pp :: z:Int -> {v:Int| v > z} @-}
-pp x      = G.plusOne (G.plusOne x)
-
-
-($$$) x  = x + 1
diff --git a/tests/pos/LooLib.hs b/tests/pos/LooLib.hs
deleted file mode 100644
--- a/tests/pos/LooLib.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module LooLib ( module LooLibLib , plusTwo ) where
-
-import LooLibLib 
-
-{-@ plusTwo :: x:Int -> {v:Int | v = x + 2} @-}
-plusTwo :: Int -> Int
-plusTwo = plusOne . plusOne
-
diff --git a/tests/pos/LooLibLib.hs b/tests/pos/LooLibLib.hs
deleted file mode 100644
--- a/tests/pos/LooLibLib.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module LooLibLib (plusOne) where
-
-{-@ plusOne :: x:Int -> {v:Int| v = x + 1 } @-}
-plusOne :: Int -> Int
-plusOne x = x + 1
diff --git a/tests/pos/Malformed0.hs b/tests/pos/Malformed0.hs
deleted file mode 100644
--- a/tests/pos/Malformed0.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-
--- TODO: Fix resolve so we can remove this/add termination metrics
-{-@ LIQUID "--no-termination" @-}
-
-module Malformed0 () where
-
-{-@ decrease go 3 4 5 @-}
-{-@ decrease perms 4 5 6 @-}
-
-{-@ foo :: xs:[a] -> ys:[a] -> {v:Int| v = (len xs)- (len ys)} -> Int @-}
-foo :: [a] -> [a] -> Int -> Int
-foo = undefined
-
-permutations         :: [a] -> [[a]]
-permutations xs     =  go xs xs (length xs) (length xs) 1
-  where
-    go xs0 xs (d2 :: Int) d1 (d3::Int) = xs : perms xs0 xs [] d2 d1 0
-    perms _ []     _  _ _ _ = []
-    perms xs0 (t:ts) is (d2 :: Int) (d1::Int) (d3 :: Int) = (perms ts xs0 (t:is) d2 (length ts) d3) ++ (go xs0 is (length xs0 - length is) d1 1)
-
--- permutations         :: [a] -> [[a]]
--- permutations xs     =  go xs xs (length xs) (0::Int) 1
---   where
---     go xs0 xs d1 (d2::Int) (d3::Int) = xs : perms xs0 xs [] d1 0 0
---     perms _ []     _  _ _ _ = []
---     perms xs0 (t:ts) is (d1::Int) (d2 :: Int) (d3 :: Int) = (perms ts xs0 (t:is) (length ts) 0 d3) ++ (go xs0 is (length is) 0 1)
--- 
--- 
diff --git a/tests/pos/Map.hs b/tests/pos/Map.hs
deleted file mode 100644
--- a/tests/pos/Map.hs
+++ /dev/null
@@ -1,182 +0,0 @@
-module Map (error, mllen) where
-
-import Language.Haskell.Liquid.Prelude
-
-import Prelude hiding (error)
-
-{-@ lazy error @-}
-error :: a -> b
-error x = error x
-
-{-@
-  data Map [mllen] k a  k -> Bool, r :: root:k -> k -> Bool>
-      = Tip
-      | Bin { mSz    :: Size
-            , mKey   :: k
-            , mValue :: a
-            , mLeft  :: Map  (k ) a
-            , mRight :: Map  (k ) a }
-  @-}
-
-{-@ measure mllen @-}
-mllen :: Map k a -> Int 
-{-@ mllen :: Map k a -> Nat @-}
-mllen Tip = 0 
-mllen (Bin _ _ _ l r) = 1 + if (mllen l < mllen r) then mllen r else mllen l
-
-
-{-@ measure mlen :: (Map k a) -> Int
-      mlen Tip = 0
-      mlen (Bin s k v l r) = 1 + (mlen l) + (mlen r)
-  @-}
-
-{-@ invariant {v:Map k a | (mlen v) >= 0}@-}
-
-{-@ type OMap k a = Map <{\root v -> v < root }, {\root v -> v > root}> k a @-}
-
-data Map k a = Tip
-             | Bin Size k a (Map k a) (Map k a)
-
-type Size    = Int
-
-{-@ singleton :: k -> a -> OMap k a @-}
-singleton :: k -> a -> Map k a
-singleton k x
-  = Bin 1 k x Tip Tip
-
-{-@ insert :: Ord k => k -> a -> OMap k a -> OMap k a @-}
-insert :: Ord k => k -> a -> Map k a -> Map k a
-insert kx x t
-  = case t of
-     Tip -> singleton kx x
-     Bin sz ky y l r
-         -> case compare kx ky of
-              LT -> balance ky y (insert kx x l) r
-              GT -> balance ky y l (insert kx x r)
-              EQ -> Bin sz kx x l r
-
-{-@ delete :: (Ord k) => k:k -> OMap k a -> OMap {v:k| (v /= k)} a @-}
-delete :: Ord k => k -> Map k a -> Map k a
-delete k t
-  = case t of
-      Tip -> Tip
-      Bin _ kx x l r
-          -> case compare k kx of
-               LT -> balance kx x (delete k l) r
-               GT -> balance kx x l (delete k r)
-               EQ -> glue kx l r
-
-
-glue :: k -> Map k a -> Map k a -> Map k a
-glue k Tip r = r
-glue k l Tip = l
-glue k l r
-  | size l > size r = let (km1, vm, lm) = deleteFindMax l in balance km1 vm lm r
-  | otherwise       = let (km2, vm, rm) = deleteFindMin r in balance km2 vm l rm
-
-deleteFindMax t
-  = case t of
-      Bin _ k x l Tip -> (k, x, l)
-      Bin _ k x l r -> let (km3, vm, rm) = deleteFindMax r in (km3, vm, (balance k x l rm))
-      Tip           -> (error ms, error ms, Tip)
-  where ms = "Map.deleteFindMax : can not return the maximal element of an empty Map"
-
-
-deleteFindMin t
-  = case t of
-      Bin _ k x Tip r -> (k, x, r)
-      Bin _ k x l r -> let (km4, vm, lm) = deleteFindMin l in (km4, vm, (balance k x lm r))
-      Tip             -> (error ms, error ms, Tip)
-  where ms = "Map.deleteFindMin : can not return the maximal element of an empty Map"
-
-
--------------------------------------------------------------------------------
---------------------------------- BALANCE -------------------------------------
--------------------------------------------------------------------------------
-
-delta, ratio :: Int
-delta = 5
-ratio = 2
-
-balance :: k -> a -> Map k a -> Map k a -> Map k a
-balance k x l r
-  | sizeL + sizeR <= 1   = Bin sizeX k x l r
-  | sizeR >= delta*sizeL = rotateL k x l r
-  | sizeL >= delta*sizeR = rotateR k x l r
-  | otherwise            = Bin sizeX k x l r
-  where sizeL = size l
-        sizeR = size r
-        sizeX = sizeL + sizeR + 1
-
--- rotate
-rotateL :: a -> b -> Map a b -> Map a b -> Map a b
-rotateL k x l r@(Bin _ _ _ ly ry)
-  | size ly < ratio*size ry  = singleL k x l r
-  | otherwise                = doubleL k x l r
-rotateL _ _ _ Tip = error "rotateL Tip"
-
-rotateR :: a -> b -> Map a b -> Map a b -> Map a b
-rotateR k x l@(Bin _ _ _ ly ry) r
-  | size ry < ratio*size ly  = singleR k x l r
-  | otherwise                = doubleR k x l r
-rotateR _ _ Tip _ = error "rotateR Tip"
-
--- basic rotations
-singleL, singleR :: a -> b -> Map a b -> Map a b -> Map a b
-singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3
-singleL _  _  _ Tip                  = error "sinlgeL Tip"
-singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = Bin 0 k2 x2 t1 (Bin 0 k1 x1 t2 t3)
-singleR _  _  Tip _                  = error "sinlgeR Tip"
-
-doubleL, doubleR :: a -> b -> Map a b -> Map a b -> Map a b
-doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4)
- =bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4)
-doubleL _ _ _ _ = error "doubleL"
-doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4
-  = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4)
-doubleR _ _ _ _ = error "doubleR"
-
-bin :: k -> a -> Map k a -> Map k a -> Map k a
-bin k x l r
-  = Bin (size l + size r + 1) k x l r
-
-size :: Map k a -> Int
-size t
-  = case t of
-      Tip            -> 0
-      Bin sz _ _ _ _ -> sz
-
-
--- chkDel x Tip                = liquidAssertB True
--- chkDel x (Bin sz k v lt rt) = liquidAssertB (not (x == k)) && chkDel x lt && chkDel x rt
-
--- chkMin x Tip                = liquidAssertB True
--- chkMin x (Bin sz k v lt rt) = liquidAssertB (x insert k v t) Tip
-
-prop        = chk bst1
-prop1       = chk $ mkBst $ zip [1..] [1..]
-
-propDelete  = chk bst' -- && chkDel x bst'
-   where
-     x      = choose 0
-     bst'   = delete x bst
diff --git a/tests/pos/Map0.hs b/tests/pos/Map0.hs
deleted file mode 100644
--- a/tests/pos/Map0.hs
+++ /dev/null
@@ -1,183 +0,0 @@
-module Map0 (mllen) where
-
-import Language.Haskell.Liquid.Prelude
-
-import Prelude hiding (error)
-
-{-@ lazy error @-}
-{-@ error :: a -> b @-}
-error :: a -> b
-error x = error x
-
-
-{-@
-    data Map [mllen] k a  k -> Bool, r :: root:k -> k -> Bool>
-        = Tip
-        | Bin { mSz    :: Size
-              , mKey   :: k
-              , mValue :: a
-              , mLeft  :: Map  (k ) a
-              , mRight :: Map  (k ) a }
-  @-}
-
-{-@ measure mllen @-}
-mllen :: Map k a -> Int 
-{-@ mllen :: Map k a -> Nat @-}
-mllen Tip = 0 
-mllen (Bin _ _ _ l r) = 1 + if (mllen l < mllen r) then mllen r else mllen l
-
-
-{-@ type OMap k a = Map <{\root v -> v < root }, {\root v -> v > root}> k a @-}
-
-{-@ measure mlen :: (Map k a) -> Int
-      mlen Tip = 0
-      mlen (Bin s k v l r) = 1 + (mlen l) + (mlen r)
-  @-}
-
-{-@ invariant {v:Map k a | (mlen v) >= 0}@-}
-
-data Map k a = Tip
-             | Bin Size k a (Map k a) (Map k a)
-
-type Size    = Int
-
-{-@ singleton :: k -> a -> OMap k a @-}
-singleton :: k -> a -> Map k a
-singleton k x
-  = Bin 1 k x Tip Tip
-
-
-{-@ insert :: Ord k => k -> a -> OMap k a -> OMap k a @-}
-insert :: Ord k => k -> a -> Map k a -> Map k a
-insert kx x t
-  = case t of
-     Tip -> singleton kx x
-     Bin sz ky y l r
-         -> case compare kx ky of
-              LT -> balance ky y (insert kx x l) r
-              GT -> balance ky y l (insert kx x r)
-              EQ -> Bin sz kx x l r
-
-{-@ delete :: (Ord k) => k:k -> OMap k a -> OMap {v:k | (v /= k)} a @-}
-delete :: Ord k => k -> Map k a -> Map k a
-delete k t
-  = case t of
-      Tip -> Tip
-      Bin _ kx x l r
-          -> case compare k kx of
-               LT -> balance kx x (delete k l) r
-               GT -> balance kx x l (delete k r)
-               EQ -> glue kx l r
-
-
-glue :: k -> Map k a -> Map k a -> Map k a
-glue k Tip r = r
-glue k l Tip = l
-glue k l r
-  | size l > size r = let (km1, vm, lm) = deleteFindMax l in balance km1 vm lm r
-  | otherwise       = let (km2, vm, rm) = deleteFindMin r in balance km2 vm l rm
-
-deleteFindMax t
-  = case t of
-      Bin _ k x l Tip -> (k, x, l)
-      Bin _ k x l r -> let (km3, vm, rm) = deleteFindMax r in (km3, vm, (balance k x l rm))
-      Tip           -> (error ms, error ms, Tip)
-  where ms = "Map.deleteFindMax : can not return the maximal element of an empty Map"
-
-
-deleteFindMin t
-  = case t of
-      Bin _ k x Tip r -> (k, x, r)
-      Bin _ k x l r -> let (km4, vm, lm) = deleteFindMin l in (km4, vm, (balance k x lm r))
-      Tip             -> (error ms, error ms, Tip)
-  where ms = "Map.deleteFindMin : can not return the maximal element of an empty Map"
-
-
--------------------------------------------------------------------------------
---------------------------------- BALANCE -------------------------------------
--------------------------------------------------------------------------------
-
-delta, ratio :: Int
-delta = 5
-ratio = 2
-
-balance :: k -> a -> Map k a -> Map k a -> Map k a
-balance k x l r
-  | sizeL + sizeR <= 1   = Bin sizeX k x l r
-  | sizeR >= delta*sizeL = rotateL k x l r
-  | sizeL >= delta*sizeR = rotateR k x l r
-  | otherwise            = Bin sizeX k x l r
-  where sizeL = size l
-        sizeR = size r
-        sizeX = sizeL + sizeR + 1
-
--- rotate
-rotateL :: a -> b -> Map a b -> Map a b -> Map a b
-rotateL k x l r@(Bin _ _ _ ly ry)
-  | size ly < ratio*size ry  = singleL k x l r
-  | otherwise                = doubleL k x l r
-rotateL _ _ _ Tip = error "rotateL Tip"
-
-rotateR :: a -> b -> Map a b -> Map a b -> Map a b
-rotateR k x l@(Bin _ _ _ ly ry) r
-  | size ry < ratio*size ly  = singleR k x l r
-  | otherwise                = doubleR k x l r
-rotateR _ _ Tip _ = error "rotateR Tip"
-
--- basic rotations
-singleL, singleR :: a -> b -> Map a b -> Map a b -> Map a b
-singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3
-singleL _  _  _ Tip                  = error "sinlgeL Tip"
-singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = Bin 0 k2 x2 t1 (Bin 0 k1 x1 t2 t3)
-singleR _  _  Tip _                  = error "sinlgeR Tip"
-
-doubleL, doubleR :: a -> b -> Map a b -> Map a b -> Map a b
-doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4)
- =bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4)
-doubleL _ _ _ _ = error "doubleL"
-doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4
-  = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4)
-doubleR _ _ _ _ = error "doubleR"
-
-bin :: k -> a -> Map k a -> Map k a -> Map k a
-bin k x l r
-  = Bin (size l + size r + 1) k x l r
-
-size :: Map k a -> Int
-size t
-  = case t of
-      Tip            -> 0
-      Bin sz _ _ _ _ -> sz
-
-
--- chkDel x Tip                = liquidAssertB True
--- chkDel x (Bin sz k v lt rt) = liquidAssertB (not (x == k)) && chkDel x lt && chkDel x rt
---
--- chkMin x Tip                = liquidAssertB True
--- chkMin x (Bin sz k v lt rt) = liquidAssertB (x insert k v t) Tip
-
-prop        = chk bst1
-prop1       = chk $ mkBst $ zip [1..] [1..]
-
-propDelete  = chk $ delete x bst
-   where x = choose 0
diff --git a/tests/pos/Map2.hs b/tests/pos/Map2.hs
deleted file mode 100644
--- a/tests/pos/Map2.hs
+++ /dev/null
@@ -1,182 +0,0 @@
-module Map2 (singleton, insert, delete, mllen) where
-
-import Language.Haskell.Liquid.Prelude
-
-import Prelude hiding (error)
-
-{-@ lazy error @-}
-{-@ error :: a -> b @-}
-error :: a -> b
-error x = error x
-
-{-@
-  data Map [mllen] k a  k -> Bool, r :: root:k -> k -> Bool>
-      = Tip
-      | Bin { mSz    :: Size
-            , mKey   :: k
-            , mValue :: a
-            , mLeft  :: Map  (k ) a
-            , mRight :: Map  (k ) a }
-  @-}
-
-{-@ measure mllen @-}
-mllen :: Map k a -> Int 
-{-@ mllen :: Map k a -> Nat @-}
-mllen Tip = 0 
-mllen (Bin _ _ _ l r) = 1 + if (mllen l < mllen r) then mllen r else mllen l
-
-
-{-@ measure mlen :: (Map k a) -> Int
-      mlen Tip = 0
-      mlen (Bin s k v l r) = 1 + (if ((mlen l) < (mlen r)) then (mlen r) else (mlen l))
-  @-}
-
-{-@ invariant { v:Map k a | mlen v >= 0 } @-}
-
-{-@ type OMap k a = Map <{\root v -> v < root }, {\root v -> v > root}> k a @-}
-
-data Map k a = Tip
-             | Bin Size k a (Map k a) (Map k a)
-
-type Size    = Int
-
-{-@ singleton :: k -> a -> OMap k a @-}
-singleton :: k -> a -> Map k a
-singleton k x
-  = Bin 1 k x Tip Tip
-
-{-@ insert :: Ord k => k -> a -> OMap k a -> OMap k a @-}
-insert :: Ord k => k -> a -> Map k a -> Map k a
-insert kx x t
-  = case t of
-     Tip -> singleton kx x
-     Bin sz ky y l r
-         -> case compare kx ky of
-              LT -> balance ky y (insert kx x l) r
-              GT -> balance ky y l (insert kx x r)
-              EQ -> Bin sz kx x l r
-
-{-@ delete :: (Ord k) => k:k -> OMap k a -> OMap {v:k| (v /= k)} a @-}
-delete :: Ord k => k -> Map k a -> Map k a
-delete k t
-  = case t of
-      Tip -> Tip
-      Bin _ kx x l r
-          -> case compare k kx of
-               LT -> balance kx x (delete k l) r
-               GT -> balance kx x l (delete k r)
-               EQ -> glue kx l r
-
-
-glue :: k -> Map k a -> Map k a -> Map k a
-glue k Tip r = r
-glue k l Tip = l
-glue k l r
-  | size l > size r = let (km1, vm, lm) = deleteFindMax l in balance km1 vm lm r
-  | otherwise       = let (km2, vm, rm) = deleteFindMin r in balance km2 vm l rm
-
-deleteFindMax t
-  = case t of
-      Bin _ k x l Tip -> (k, x, l)
-      Bin _ k x l r -> let (km3, vm, rm) = deleteFindMax r in (km3, vm, balance k x l rm)
-      Tip           -> (error ms, error ms, Tip)
-  where ms = "Map.deleteFindMax : can not return the maximal element of an empty Map"
-
-deleteFindMin t
-  = case t of
-      Bin _ k x Tip r -> (k, x, r)
-      Bin _ k x l r -> let (km4, vm, lm) = deleteFindMin l in (km4, vm, balance k x lm r)
-      Tip             -> (error ms, error ms, Tip)
-  where ms = "Map.deleteFindMin : can not return the maximal element of an empty Map"
-
-
--------------------------------------------------------------------------------
---------------------------------- BALANCE -------------------------------------
--------------------------------------------------------------------------------
-
-delta, ratio :: Int
-delta = 5
-ratio = 2
-
-balance :: k -> a -> Map k a -> Map k a -> Map k a
-balance k x l r
-  | sizeL + sizeR <= 1   = Bin sizeX k x l r
-  | sizeR >= delta*sizeL = rotateL k x l r
-  | sizeL >= delta*sizeR = rotateR k x l r
-  | otherwise            = Bin sizeX k x l r
-  where sizeL = size l
-        sizeR = size r
-        sizeX = sizeL + sizeR + 1
-
--- rotate
-rotateL :: a -> b -> Map a b -> Map a b -> Map a b
-rotateL k x l r@(Bin _ _ _ ly ry)
-  | size ly < ratio*size ry  = singleL k x l r
-  | otherwise                = doubleL k x l r
-rotateL _ _ _ Tip = error "rotateL Tip"
-
-rotateR :: a -> b -> Map a b -> Map a b -> Map a b
-rotateR k x l@(Bin _ _ _ ly ry) r
-  | size ry < ratio*size ly  = singleR k x l r
-  | otherwise                = doubleR k x l r
-rotateR _ _ Tip _ = error "rotateR Tip"
-
--- basic rotations
-singleL, singleR :: a -> b -> Map a b -> Map a b -> Map a b
-singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3
-singleL _  _  _ Tip                  = error "sinlgeL Tip"
-singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = Bin 0 k2 x2 t1 (Bin 0 k1 x1 t2 t3)
-singleR _  _  Tip _                  = error "sinlgeR Tip"
-
-doubleL, doubleR :: a -> b -> Map a b -> Map a b -> Map a b
-doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4)
- =bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4)
-doubleL _ _ _ _ = error "doubleL"
-doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4
-  = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4)
-doubleR _ _ _ _ = error "doubleR"
-
-bin :: k -> a -> Map k a -> Map k a -> Map k a
-bin k x l r
-  = Bin (size l + size r + 1) k x l r
-
-size :: Map k a -> Int
-size t
-  = case t of
-      Tip            -> 0
-      Bin sz _ _ _ _ -> sz
-
-
--- chkDel x Tip                = liquidAssertB True
--- chkDel x (Bin sz k v lt rt) = liquidAssertB (not (x == k)) && chkDel x lt && chkDel x rt
-
--- chkMin x Tip                = liquidAssertB True
--- chkMin x (Bin sz k v lt rt) = liquidAssertB (x insert k v t) Tip
-
-prop        = chk bst1010
-prop1       = chk $ mkBst $ zip [1..] [1..]
-
-propDelete  = chk bst' -- && chkDel x bst'
-   where
-     x      = choose 0
-     bst'   = delete x bst
diff --git a/tests/pos/MapFusion.hs b/tests/pos/MapFusion.hs
deleted file mode 100644
--- a/tests/pos/MapFusion.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-{-@ LIQUID "--reflection"     @-}
-{-@ LIQUID "--ple"            @-}
-
-module MapFusion where
-
-import Prelude hiding (map)
-
-import Language.Haskell.Liquid.ProofCombinators
-
-{-@ reflect compose @-}
-compose :: (b -> c) -> (a -> b) -> a -> c
-compose f3 g3 x3 = f3 (g3 x3)
-
-{-@ reflect map @-}
-map :: (a -> b) -> L a -> L b
-map f4 N = N
-map f5 (C z zs) = C (f5 z) (map f5 zs)
-
-
-{-@ map_fusion :: foo:(a -> a) -> goo:(a -> a) -> xoos:{L a | true }
-               -> {map (compose foo goo) xoos == compose (map foo) (map goo) xoos } @-}
-map_fusion :: (a -> a) -> (a -> a) -> L a -> Proof
-map_fusion f1 g1 N        = trivial
-map_fusion f2 g2 (C x xs) = map_fusion f2 g2 xs
-
-
-data L a = N | C a (L a)
-{-@ data L [llen] a = N | C {headlist :: a, taillist :: L a }@-}
-
-{-@ measure llen @-}
-llen :: L a -> Int
-{-@ llen :: L a -> Nat @-}
-llen N        = 0
-llen (C _ as) = 1 + llen as
diff --git a/tests/pos/MapReduceVerified.hs b/tests/pos/MapReduceVerified.hs
deleted file mode 100644
--- a/tests/pos/MapReduceVerified.hs
+++ /dev/null
@@ -1,244 +0,0 @@
--- | Proof of equivalence of MapReduce 
--- | mapReduce n op f is == f is 
-
--- | Niki Vazou Sep 2016 
-
-{-@ LIQUID "--reflection" @-}
-
-
-module MapReduceVerified where
-
-import Prelude hiding (mconcat, map, split, take, drop, sum)
-import Language.Haskell.Liquid.ProofCombinators 
-
--------------------------------------------------------------------------------
-------------  Map Reduce Definition  ------------------------------------------
--------------------------------------------------------------------------------
-
-
-{-@ reflect mapReduce @-}
-mapReduce :: Int -> (List a -> b) -> (b -> b -> b) -> List a -> b 
-mapReduce n f op is = reduce op (f N) (map f (chunk n is))
-
-{-@ reflect reduce @-}
-reduce :: (a -> a -> a) -> a -> List a -> a 
-reduce op b N        = b 
-reduce op b (C x xs) = op x (reduce op b xs) 
-
-chunk :: Int -> List a -> List (List a)
-
-
--------------------------------------------------------------------------------
-------------  Application: List sum  ------------------------------------------
--------------------------------------------------------------------------------
-
-sum  :: List Int -> Int 
-plus :: Int -> Int -> Int 
-
-{-@ reflect msum @-}
-msum :: Int -> List Int -> Int 
-msum n is = mapReduce n sum plus is 
-
-
-mapReduceSum :: Int -> List Int -> Proof 
-{-@ mapReduceSum :: n:Int -> is:List Int -> { sum is == mapReduce n sum plus is} @-}
-mapReduceSum n is 
-  =   msum n is 
-  === mapReduce n sum plus is 
-    ? mapReduceTheorem n sum plus sumLeftId sumDistributes is 
-  === sum is  
-  *** QED 
-
--------------------------------------------------------------------------------
-------------  Main MapReduce Theorem ------------------------------------------
--------------------------------------------------------------------------------
-
-
-mapReduceTheorem :: Int -> (List a -> b) -> (b -> b -> b) -> (List a -> Proof) -> (List a -> List a -> Proof) -> List a -> Proof 
-{-@ mapReduceTheorem :: n:Int -> f:(List a -> b) -> op:(b -> b -> b)
-     -> left_id:(xs:List a -> {op (f xs) (f N) == f xs } ) 
-     -> distributionTheorem:(xs:List a -> ys:List a -> {f (append xs ys) == op (f xs) (f ys)} )
-     -> is:List a ->
-     { mapReduce n f op is == f is }
-     / [llen is]
-  @-}
-mapReduceTheorem n f op left_id _ N 
-  =   mapReduce n f op N 
-  === reduce op (f N) (map f (chunk n N))
-  === reduce op (f N) (map f (C N N))
-  === reduce op (f N) (f N `C` map f N )
-  === reduce op (f N) (f N `C` N)
-  === op (f N) (reduce op (f N) N)
-      ? left_id N
-  === op (f N) (f N)
-  === f N 
-  *** QED 
-
-mapReduceTheorem n f op left_id _ is@(C x xs)
-  | n <= 1 || llen is <= n 
-  =   mapReduce n f op is 
-  === reduce op (f N) (map f (chunk n is))
-  === reduce op (f N) (map f (C is N))
-  === reduce op (f N) (f is `C` map f N)
-  === reduce op (f N) (f is `C` N)
-  === op (f is) (reduce op (f N) N)
-  === op (f is) (f N)
-    ? left_id is
-  === f is  
-  *** QED 
-
-mapReduceTheorem n f op left_id distributionTheorem is 
-  =   mapReduce n f op is 
-  === reduce op (f N) (map f (chunk n is)) 
-  === reduce op (f N) (map f (C (take n is) (chunk n (drop n is)))) 
-  === reduce op (f N) (C (f (take n is)) (map f (chunk n (drop n is)))) 
-  === op (f (take n is)) (reduce op (f N) (map f (chunk n (drop n is))))  
-      ? mapReduceTheorem n f op left_id distributionTheorem (drop n is)
-  === op (f (take n is)) (mapReduce n f op (drop n is)) 
-  === op (f (take n is)) (f (drop n is)) 
-      ? distributionTheorem (take n is) (drop n is)
-  === f (append (take n is) (drop n is))
-      ? appendTakeDrop n is 
-  === f is 
-  *** QED  
-
-
-
-
--------------------------------------------------------------------------------
------------  List Definition --------------------------------------------------
--------------------------------------------------------------------------------
-
-
-{-@ data List [llen] a = N | C {lhead :: a, ltail :: List a} @-}
-data List a = N | C a (List a)
-
-{-@ measure llen @-}
-llen :: List a -> Int 
-
-{-@ llen :: List a -> Nat @-}
-llen N        = 0 
-llen (C _ xs) = 1 + llen xs
-
--------------------------------------------------------------------------------
------------  List Manipulation ------------------------------------------------
--------------------------------------------------------------------------------
-
--- Distribution 
-
-{-@ reflect map @-}
-{-@ map :: (a -> b) -> xs:List a -> {v:List b | llen v == llen xs } @-}
-map :: (a -> b) -> List a -> List b
-map _  N       = N
-map f (C x xs) = f x `C` map f xs 
-
-{-@ reflect chunk @-}
-{-@ chunk :: i:Int -> xs:List a -> {v:List (List a) | if (i <= 1 || llen xs <= i) then (llen v == 1) else (llen v < llen xs) } / [llen xs] @-}
-chunk i xs 
-  | i <= 1 
-  = C xs N 
-  | llen xs <= i 
-  = C xs N 
-  | otherwise
-  = C (take i xs) (chunk i (drop i xs))
-
-{-@ reflect drop @-}
-{-@ drop :: i:Nat -> xs:{List a | i <= llen xs } -> {v:List a | llen v == llen xs - i } @-} 
-drop :: Int -> List a -> List a 
-drop i N = N 
-drop i (C x xs)
-  | i == 0 
-  = C x xs  
-  | otherwise 
-  = drop (i-1) xs 
-
-{-@ reflect take @-}
-{-@ take :: i:Nat -> xs:{List a | i <= llen xs } -> {v:List a | llen v == i} @-} 
-take :: Int -> List a -> List a 
-take i N = N 
-take i (C x xs)
-  | i == 0 
-  = N  
-  | otherwise 
-  = C x (take (i-1) xs)
-
-
-{-@ reflect append @-}
-append :: List a -> List a -> List a 
-append N        ys = ys  
-append (C x xs) ys = x `C` (append xs ys)
-
-
--------------------------------------------------------------------------------
------------  Helper Theorems --------------------------------------------------
--------------------------------------------------------------------------------
-
-
--- | For input Distribution 
-{-@ appendTakeDrop :: i:Nat -> xs:{List a | i <= llen xs} 
-      -> {xs == append (take i xs) (drop i xs) }  @-}
-
-appendTakeDrop :: Int -> List a -> Proof 
-appendTakeDrop i N 
-  =   append (take i N) (drop i N)
-  === append N N 
-  === N 
-  *** QED 
-appendTakeDrop i (C x xs)
-  | i == 0 
-  =   append (take 0 (C x xs)) (drop 0 (C x xs))
-  === append N (C x xs)
-  === C x xs 
-  *** QED 
-  | otherwise
-  =   append (take i (C x xs)) (drop i (C x xs))
-  === append (C x (take (i-1) xs)) (drop (i-1) xs)
-  === C x (append (take (i-1) xs) (drop (i-1) xs))
-      ? appendTakeDrop (i-1) xs 
-  === C x xs 
-  *** QED 
-
-
-
--------------------------------------------------------------------------------
-------------  Application: List sum  ------------------------------------------
--------------------------------------------------------------------------------
-
-
-sumLeftId :: List Int -> Proof 
-{-@ sumLeftId :: xs:List Int -> {plus (sum xs) (sum N) == sum xs } @-}
-sumLeftId xs 
-  =  plus (sum xs) (sum N) 
-  === sum xs + 0 
-  === sum xs 
-  *** QED 
-
-{-@ sumDistributes :: xs:List Int -> ys:List Int -> 
-      {sum (append xs ys) == plus (sum xs) (sum ys)} @-}
-sumDistributes :: List Int -> List Int -> Proof 
-sumDistributes N ys 
-  =   sum (append N ys)
-  === sum ys
-  === plus 0       (sum ys)
-  === plus (sum N) (sum ys)
-  *** QED 
-sumDistributes (C x xs) ys  
-  =   sum (append (C x xs) ys)
-  === sum (C x (append xs ys))
-      ? sumDistributes xs ys
-  === x `plus` (sum (append xs ys))
-  === x `plus` (plus (sum xs) (sum ys))
-  === x + (sum xs + sum ys)
-  === ((x + sum xs) + sum ys)
-  === ((x `plus` sum xs) `plus` sum ys)
-  === sum (C x xs) `plus` sum ys
-  *** QED 
-
-
-{-@ reflect plus @-}
-plus x y = x + y 
-
-{-@ reflect sum @-}
-sum N        = 0 
-sum (C x xs) = x `plus` sum xs
-
diff --git a/tests/pos/MapTvCrash.hs b/tests/pos/MapTvCrash.hs
deleted file mode 100644
--- a/tests/pos/MapTvCrash.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module MapTvCrash (foo) where
-
-import Foreign.ForeignPtr
-
-{-@ foo :: FinalizerPtr a -> a @-}
-foo :: FinalizerPtr a -> a
-foo = undefined
diff --git a/tests/pos/Mapreduce_bare.hs b/tests/pos/Mapreduce_bare.hs
deleted file mode 100644
--- a/tests/pos/Mapreduce_bare.hs
+++ /dev/null
@@ -1,71 +0,0 @@
-module Mapreduce_bare () where
-
-import Language.Haskell.Liquid.Prelude
-import Data.List (foldl')
-
-----------------------------------------------------------------
---- Step 1: Map each element into key-value list (concatMap) ---
-----------------------------------------------------------------
-
-expand          :: (a -> [(k,v)]) -> [a] -> [(k, v)]
-expand f []     = []
-expand f (x:xs) = (f x) ++ (expand f xs)
-
-----------------------------------------------------------------
---- Step 2: Group By Key ---------------------------------------
-----------------------------------------------------------------
-
-group ::[(Int, v)] -> [(Int, [v])]
-group = foldl' addKV [] 
-  
-addKV m (k, v) = insert k vs' m
-  where vs' = v : (findWithDefault [] k m)
-
-insert key value [] 
-  = [(key, value)]
-insert key value ((k,_):kvs)
-  | k == key
-  = (key, value):kvs
-insert key value (kv:kvs)
-  = kv : insert key value kvs  
-
-findWithDefault r _ ([]) 
-  = r
-findWithDefault r k ((key,value):_) 
-  | k `eq` key 
-  = value
-findWithDefault r k (_:kvs) 
-  = findWithDefault r k kvs 
-
-----------------------------------------------------------------
---- Step 3: Group By Key ---------------------------------------
-----------------------------------------------------------------
-
-collapse f = foldrWithKey reduceKV []
-  where reduceKV k (v:vs) acc = (k, foldl' f v vs) : acc
-        reduceKV k []     _   = crash False -- error $ show (liquidAssertB False)
-
-foldrWithKey f = foldr (\(k, v) acc -> f k v acc) 
-
-----------------------------------------------------------------
---- Putting it All Together ------------------------------------
-----------------------------------------------------------------
-
-mapReduce fmap fred xs = collapse fred $ group $ expand fmap xs
-
-----------------------------------------------------------------
---- "Word Count" -----------------------------------------------
-----------------------------------------------------------------
-
-wordCount  = mapReduce fm plus 
-  where fm = \doc -> [ (length w, 1) | w <- words doc]
-
-mytest = 
-  let docs = [ "this is the end"
-             , "go to the end"
-             , "the end is the beginning"]
-  in putStrLn $ isZero {- show -} $ wordCount docs
- 
-isZero [_]  = "Positive" 
-isZero _    = "Negative"
-
diff --git a/tests/pos/Maps.hs b/tests/pos/Maps.hs
deleted file mode 100644
--- a/tests/pos/Maps.hs
+++ /dev/null
@@ -1,41 +0,0 @@
-module Maps where
-
-
-{-@ prop0 :: x:_ -> y:{_ | y == x} -> TT @-}
-prop0 x y = (a == b)
-  where
-    a     = get x emp  
-    b     = get y emp 
-
-{-@ prop1 :: x:_ -> y:{_ | y /= x} -> TT @-}
-prop1 x y = (z == 10)
-  where
-    m1    = put x 10 emp  
-    m2    = put y 20 m1
-    z     = get x m2
-
-{-@ prop2 :: x:_ -> y:{_ | y == x} -> TT @-}
-prop2 x y = (z == 20)
-  where
-    m1    = put x 10 emp 
-    m2    = put y 20 m1
-    z     = get x m2
-
------------------------------------------------------------------------
-
-data Map k v = M
-
-{-@ embed Map as Map_t @-}
-{-@ measure Map_select :: Map k v -> k -> v @-}
-{-@ measure Map_store  :: Map k v -> k -> v -> Map k v @-}
-
-emp :: Map Int Int
-emp = undefined   
-     
-{-@ get :: k:k -> m:Map k v -> {v:v | v = Map_select m k} @-}
-get :: k -> Map k v -> v
-get = undefined 
-
-{-@ put :: k:k -> v:v -> m:Map k v -> {n:Map k v | n = Map_store m k v} @-}
-put :: k -> v -> Map k v -> Map k v
-put = undefined 
diff --git a/tests/pos/Maps1.hs b/tests/pos/Maps1.hs
deleted file mode 100644
--- a/tests/pos/Maps1.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-module Maps1 where
-
-import Prelude hiding (lookup)
-import Data.Map
-
-{-@ prop0   :: _ -> x:_ -> y:{_ | y == x} -> TT @-}
-prop0       :: Map Int Int -> Int -> Int -> Bool
-prop0 m x y = (a == b)
-  where
-    a       = m ! x
-    b       = m ! y
-
-{-@ prop1   :: _ -> x:_ -> y:{_ | y /= x} -> TT @-}
-prop1       :: Map Int Int -> Int -> Int -> Bool
-prop1 m x y = (z == 10)
-  where
-    m1      = insert x 10 m
-    m2      = insert y 20 m1
-    z       = m2 ! x
-
-{-@ prop2   :: _ -> x:_ -> y:{_ | y == x} -> TT @-}
-prop2 m x y = (z == 20)
-  where
-    m1      = insert x 10 m
-    m2      = insert y 20 m1
-    z       = m2 ! x
-
------------------------------------------------------------------------
-
-{-@ embed Map as Map_t @-}
-{-@ measure Map_select :: Map k v -> k -> v @-}
-{-@ measure Map_store  :: Map k v -> k -> v -> Map k v @-}
-{-@ assume (!)         :: (Ord k) => m:Map k v -> k:k -> {v:v | v = Map_select m k} @-}
-{-@ assume insert      :: (Ord k) => key:k -> value:v -> m:Map k v -> {n:Map k v | n = Map_store m key value} @-}
-
------------------------------------------------------------------------
diff --git a/tests/pos/MaskError.hs b/tests/pos/MaskError.hs
deleted file mode 100644
--- a/tests/pos/MaskError.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module MaskError where
-
-{-@ assume error :: String -> a @-}
-
-foo :: Int -> Int 
-foo _ = error "oh no"
diff --git a/tests/pos/Maybe.hs b/tests/pos/Maybe.hs
deleted file mode 100644
--- a/tests/pos/Maybe.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-module Maybe () where
-
-import Language.Haskell.Liquid.Prelude (liquidAssert)
-
-{-@ type OList a = [a]<{\fld v -> (v >= fld)}> @-}
-
-{-@ filterGt :: (Ord a) => x:Maybe a -> OList a -> OList {v:a | (( isJust x ) => (fromJust x <= v)) } @-}
-
-filterGt ::  Ord a => Maybe a -> [a] -> [a]
-filterGt Nothing  xs = xs
-filterGt (Just x) xs = foo x xs
-  
-foo y xs = foo' y xs
-
-foo' :: (Ord a) => a -> [a] -> [a]
-foo' y []     = []
-foo' y (x:xs) 
- = case compare y x of 
-     GT -> foo' y xs 
-     LT -> x:xs 
-     EQ -> xs 
-
-{-@ bar :: (Ord a) => z:a -> OList a -> OList {v:a | z <= v} @-}
-bar y xs = bar' y xs
-
-bar' y []     = []
-bar' y (x:xs) 
-  | y > x    = bar' y xs 
-  | y < x    = x:xs 
-  | y == x   = xs 
-
-
diff --git a/tests/pos/Maybe0.hs b/tests/pos/Maybe0.hs
deleted file mode 100644
--- a/tests/pos/Maybe0.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module Maybe0 () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ foo :: x:Maybe a -> {v:a | ((isJust(x)) => (fromJust(x) = v)) } @-}
-foo :: Maybe a -> a 
-foo (Just x)  = x 
-foo (Nothing) = unsafeError "foo"
-
-{-@ bar :: x:Maybe a -> {v:Bool | v <=> isJust x } @-}
-bar (Just x)  = True 
-bar (Nothing) = False
-
diff --git a/tests/pos/Maybe000.hs b/tests/pos/Maybe000.hs
deleted file mode 100644
--- a/tests/pos/Maybe000.hs
+++ /dev/null
@@ -1,48 +0,0 @@
-module Maybe000 () where
--- TODO: get this working with the ! annots.
-
-import Language.Haskell.Liquid.Prelude
--- remove the ! and it is safe...
-data MaybeS a = NothingS | JustS !a
--- (SAFE) data MaybeS a = NothingS | JustS a
-
-{-@ measure isJustS :: forall a. MaybeS a -> Bool 
-      isJustS (JustS x)  = true
-      isJustS (NothingS) = false
-  @-}
-
-{-@ measure fromJustS :: forall a. MaybeS a -> a
-      fromJustS (JustS x) = x 
-  @-}
-
-gloop = poop True
-
-{-@ poop :: z:a -> {v: MaybeS a | fromJustS(v) = z} @-}
-poop z = JustS z
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/pos/Maybe1.hs b/tests/pos/Maybe1.hs
deleted file mode 100644
--- a/tests/pos/Maybe1.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-{-@ LIQUID "--no-totality" @-}
-
-module Maybe1 (isJustS, fromJustS) where
-
-data MaybeS a = NothingS | JustS !a
-
-{-@ measure isJustS @-}
-isJustS :: MaybeS a -> Bool
-isJustS (JustS x)  = True
-isJustS (NothingS) = False
-
-{-@ measure fromJustS @-}
-fromJustS :: MaybeS a -> a
-fromJustS (JustS x) = x
-
-{-@ type OList a = [a]<{\fld v -> (v >= fld)}> @-}
-
-{-@ filterGt :: (Ord a) => x:MaybeS a -> OList a -> OList {v:a | isJustS x => fromJustS x <= v } @-}
-
-filterGt ::  Ord a => MaybeS a -> [a] -> [a]
-filterGt NothingS  xs = xs
-filterGt (JustS x) xs = foo' x xs
-  where foo' y []     = []
-        foo' y (x:xs) = case compare y x of
-                          GT -> foo' y xs
-                          LT -> x:xs
-                          EQ -> xs
diff --git a/tests/pos/Maybe2.hs b/tests/pos/Maybe2.hs
deleted file mode 100644
--- a/tests/pos/Maybe2.hs
+++ /dev/null
@@ -1,70 +0,0 @@
-module Maybe2 (Map(..), isRoot, filterLt, filterGt, mlen) where
-
-data Map k a  = Bin Size k a (Map k a) (Map k a)
-              | Tip
-
-type Size     = Int
-
-data MaybeS a = NothingS | JustS !a
-
-{-@ 
-  data Map [mlen] k a  k -> Bool, r :: root:k -> k -> Bool>
-       = Bin (sz    :: Size) 
-             (key   :: k) 
-             (value :: a) 
-             (left  :: Map  (k ) a) 
-             (right :: Map  (k ) a) 
-       | Tip 
-  @-}
-
-{-@ measure mlen @-}
-mlen :: Map k a -> Int 
-{-@ mlen :: Map k a -> Nat @-}
-mlen Tip = 0 
-mlen (Bin _ _ _ l r) = 1 + mlen l + mlen r  
-
-{-@ measure isJustS @-}
-isJustS :: MaybeS a -> Bool 
-isJustS (JustS x)  = True
-isJustS (NothingS) = False
-
-{-@ measure fromJustS :: forall a. MaybeS a -> a 
-      fromJustS (JustS x) = x 
-  @-}
-
-{-@ type OMap k a = Map <{\root v -> v < root}, {\root v -> v > root}> k a @-}
-
-{-@ measure isBin @-} 
-isBin :: Map k a -> Bool
-isBin (Bin sz kx x l r) = True
-isBin Tip             = False
-
-{-@ isRoot :: t:Map k a -> {v: Bool | v <=> isBin t} @-}
-isRoot (Bin _ _ _ _ _) = True
-isRoot (Tip)           = False
-
-{-@ filterGt :: (Ord k) => x:MaybeS k -> OMap k v -> OMap {v:k | ((isJustS(x)) => (v > fromJustS(x))) } v @-}
-filterGt :: Ord k => MaybeS k -> Map k v -> Map k v
-filterGt NothingS t = t
-filterGt (JustS b) t = filterGt' b t
-  
-filterGt' _   Tip = Tip
-filterGt' b' (Bin _ kx x l r) =
-          case compare b' kx of LT -> join kx x (filterGt' b' l) r
-                                EQ -> r
-                                GT -> filterGt' b' r
-
-{-@ filterLt :: (Ord k) => x:MaybeS k -> OMap k v -> OMap {v:k | ((isJustS(x)) => (v < fromJustS(x))) } v @-}
-filterLt :: Ord k => MaybeS k -> Map k v -> Map k v
-filterLt NothingS t = t
-filterLt (JustS b) t = filterLt' b t
-  
-filterLt' _   Tip = Tip
-filterLt' b' (Bin _ kx x l r) =
-  case compare kx b' of LT -> join kx x l (filterLt' b' r)
-                        EQ -> l
-                        GT -> filterLt' b' l
-
-{-@ join :: kcut:k -> a -> OMap {v:k | v < kcut} a -> OMap {v:k| v > kcut} a -> OMap k a @-}
-join :: k -> a -> Map k a -> Map k a -> Map k a
-join kx x l r = Bin 1 kx x l r 
diff --git a/tests/pos/Maybe3.hs b/tests/pos/Maybe3.hs
deleted file mode 100644
--- a/tests/pos/Maybe3.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-module Maybe3 () where
-
-
-{-@ foo :: lo0 : Maybe a
-        -> lo  : {v: Maybe {v: a | isJust lo0 && v = fromJust lo0 } | v = lo0 }  
-        -> hi0 : Maybe a
-        -> hi  : {v: Maybe {v: a | isJust hi0 && v = fromJust hi0 } 
-                   | (((isJust lo && isJust v) => (fromJust v >= fromJust lo)) && (v = hi0)) }   
-        -> Bool @-}
-foo :: Maybe a -> Maybe a -> Maybe a -> Maybe a -> Bool
-foo lo0 lo hi0 hi = bar (id hi) (id lo)
-
-{-@ bar :: hi: Maybe a 
-        -> lo:Maybe {v: a | ((isJust hi) => (v <= fromJust hi)) }  
-        -> Bool @-}
-bar :: Maybe a -> Maybe a -> Bool
-bar hi lo = True
-
-
-
diff --git a/tests/pos/Maybe4.hs b/tests/pos/Maybe4.hs
deleted file mode 100644
--- a/tests/pos/Maybe4.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-module Maybe4 () where
-
-{-@ LIQUID "--bscope" @-}
-
-{-@ goo   :: lo:{v0a: Maybe {v:a | ((isJust v0a) && (v = (fromJust v0a)))} | true } 
-          -> hi:{v0b: Maybe {v:a | ((isJust v0b) && (v = (fromJust v0b)))} | (((isJust(lo) && isJust(v0b)) => (fromJust(v0b) >= fromJust(lo)))) }   
-          -> Bool 
-  @-}
-goo       :: Maybe a -> Maybe a -> Bool
-goo lo hi = bar (id hi) (id lo)
-
-{-@ bar :: hi: Maybe a -> lo:Maybe {v: a | ((isJust(hi)) => (v <= fromJust(hi)))} -> Bool @-}
-bar :: Maybe a -> Maybe a -> Bool
-bar hi lo = True
-
-
-
diff --git a/tests/pos/Maybe5.hs b/tests/pos/Maybe5.hs
deleted file mode 100644
--- a/tests/pos/Maybe5.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module Maybe5 where
-
-import Data.Maybe
-
-
-{-@ foo :: {x:_ | isJust x} -> a @-}
-foo :: Maybe a -> a
-foo x = fromJust x
diff --git a/tests/pos/Meas0.hs b/tests/pos/Meas0.hs
deleted file mode 100644
--- a/tests/pos/Meas0.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-module Meas0 () where
-
-import Language.Haskell.Liquid.Prelude
-
-goo x = let z = [x] in z
-
-z0 _  = True
-z1 _  = False
-
-poo (x:_) = 0 == 0 
-poo ([])  = liquidAssertB False
-
-xs = goo (choose 0)
-
-prop1 = liquidAssertB (poo xs)
diff --git a/tests/pos/Meas00.hs b/tests/pos/Meas00.hs
deleted file mode 100644
--- a/tests/pos/Meas00.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-{-@ LIQUID "--no-totality" @-}
-
-module Meas00 () where
-
-import Language.Haskell.Liquid.Prelude
-
-xs :: [Int]
-xs = [1]
-
-poo [] = liquidAssertB False
-
-prop1  = liquidAssertB (poo xs)
-
-{- qualif PosLen(v:[a]): (len v) > 0 @-}
-
-{- zooper :: {v:[a] | (len v) > 0} -> a -}
-zooper :: [a] -> a
-zooper = undefined
diff --git a/tests/pos/Meas00a.hs b/tests/pos/Meas00a.hs
deleted file mode 100644
--- a/tests/pos/Meas00a.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module Meas00a () where
-
-import Language.Haskell.Liquid.Prelude
-
-prop0 = liquidAssertB True 
diff --git a/tests/pos/Meas0a.hs b/tests/pos/Meas0a.hs
deleted file mode 100644
--- a/tests/pos/Meas0a.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-module Meas0a () where
-
-import Language.Haskell.Liquid.Prelude
-
-goo x = let z = [x] in z
-
-z0 _  = True
-z1 _  = False
-
-poo (x:_) = True 
-poo ([])  = liquidAssertB False 
-
-xs = goo (choose 0)
-
-prop0 = liquidAssertB True 
-prop1 = liquidAssertB (poo xs)
diff --git a/tests/pos/Meas1.hs b/tests/pos/Meas1.hs
deleted file mode 100644
--- a/tests/pos/Meas1.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-module Meas1 () where
-
-import Control.Applicative
-import Language.Haskell.Liquid.Prelude
-
-goo x = [x]
-
-xs = goo (choose 0)
-
-nullity :: [a] -> Int
-nullity []    = 0
-nullity (x:_) = 1
-
-prop2 = liquidAssertB (1 == nullity xs) 
diff --git a/tests/pos/Meas10.hs b/tests/pos/Meas10.hs
deleted file mode 100644
--- a/tests/pos/Meas10.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-module Meas10 where
-
-import qualified Data.Set as S 
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ myrev :: xs:[a] -> {v:[a] | listElts v = listElts xs} @-}
-myrev :: [a] -> [a]
-myrev xs = go [] xs 
-   where 
-      go acc []     = acc
-      go acc (y:ys) = go (y:acc) ys
-
--- WHY DOES THIS JUST NOT GET ANY MEANINGFUL TYPE?
-{-@ goo :: xs:[a] -> ys:[a] -> {v:[a] | listElts v = S.union (listElts xs) (listElts ys) } @-}
-goo :: [a] -> [a] -> [a]
-goo acc []     = acc
-goo acc (y:ys) = unsafeError "foo" -- goRev (y:acc) ys
-
-{-@ emptySet :: a -> {v:[b] | listElts v == S.empty } @-}
-emptySet :: a -> [b]
-emptySet x = []
diff --git a/tests/pos/Meas11.hs b/tests/pos/Meas11.hs
deleted file mode 100644
--- a/tests/pos/Meas11.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module Meas11 () where
-
-import Data.Set (Set(..))
-
-{-@ myfilter :: (a -> Bool) -> xs:[a] -> {v:[a] | Set_sub (listElts v) (listElts xs) } @-}
-myfilter :: (a -> Bool) -> [a] -> [a]
-myfilter f []     = []
-myfilter f (x:xs) = if f x 
-                      then x : myfilter f xs 
-                      else myfilter f xs
-
diff --git a/tests/pos/Meas2.hs b/tests/pos/Meas2.hs
deleted file mode 100644
--- a/tests/pos/Meas2.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-module Meas2 (n) where
-
-import Language.Haskell.Liquid.Prelude
-
-mylen :: [a] -> Int
-mylen []       = 0
-mylen (_:xs)   = 1 + mylen xs
-
-
-zs :: [Int]
-zs = [1..100]
-
-n  = mylen zs
-
diff --git a/tests/pos/Meas4.hs b/tests/pos/Meas4.hs
deleted file mode 100644
--- a/tests/pos/Meas4.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-module Meas4 () where
-
-import Language.Haskell.Liquid.Prelude
-
-mylen          :: [a] -> Int
-mylen []       = 0
-mylen (_:xs)   = 1 + mylen xs
-
-mymap f []     = []
-mymap f (x:xs) = (f x) : (mymap f xs)
-
-zs :: [Int]
-zs = [1..100]
-
-prop2 = liquidAssertB (n1 == n2) 
-  where n1 = mylen zs
-        n2 = mylen $ mymap (`plus` 1) zs 
diff --git a/tests/pos/Meas5.hs b/tests/pos/Meas5.hs
deleted file mode 100644
--- a/tests/pos/Meas5.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-module Meas5 () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ include  @-}
-
-mylen          :: [a] -> Int
-mylen []       = 0
-mylen (_:xs)   = 1 + mylen xs
-
-
-mymap f []     = []
-mymap f (x:xs) = (f x) : (mymap f xs)
-
-
-{-@ myreverse :: xs:_ -> {v:_ | len v = len xs} @-} 
-myreverse = go []
-  where 
-    {-@ go :: acc:_ -> xs:_ -> {v:_ | len v = len acc + len xs} @-}
-    go acc (x:xs) = go (x:acc) xs
-    go acc []     = acc
-    
-{-@ myapp :: xs:_ -> ys:_ -> {v:_ | len v = len xs + len ys} @-}
-myapp [] ys     = ys
-myapp (x:xs) ys = x:(myapp xs ys)
-
-zs :: [Int]
-zs = [1..100]
-
-zs' :: [Int]
-zs' = [500..1000]
-
-prop2 = liquidAssertB (n1 == n2) 
-  where n1 = mylen zs
-        n2 = mylen $ mymap (+ 1) zs 
-
-prop3 = liquidAssertB (n1 == n2) 
-  where n1 = mylen zs
-        n2 = mylen $ myreverse zs 
-
-prop4 = liquidAssertB ((n1 + n2) == n3) 
-  where n1 = mylen zs
-        n2 = mylen zs'
-        n3 = mylen $ myapp zs zs' 
-
-prop5 = liquidAssertB (length zs'' == length zs) 
-        where zs'' = safeZipWith (+) zs (myreverse zs)
diff --git a/tests/pos/Meas6.hs b/tests/pos/Meas6.hs
deleted file mode 100644
--- a/tests/pos/Meas6.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-module Meas6 () where
-
-import Language.Haskell.Liquid.Prelude
-
-mylen          :: [a] -> Int
-mylen []       = 0
-mylen (_:xs)   = 1 + mylen xs
-
-mymap f []     = []
-mymap f (x:xs) = (f x) : (mymap f xs)
-
-zs = [1..100]
-
-prop2 = liquidAssertB (n1 == n2) 
-  where n1 = mylen zs
-        n2 = mylen $ mymap (+ 1) zs 
diff --git a/tests/pos/Meas7.hs b/tests/pos/Meas7.hs
deleted file mode 100644
--- a/tests/pos/Meas7.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-
-module Meas7 () where
-
--- some tests for the 'expandDefaultCase' trick to case-split 
--- on the "missing" constructors.
-
-
-mylen          :: [a] -> Int
-mylen []       = 0
-mylen (_:xs)   = 1 + mylen xs
-
-
-{-@ foo :: [a] -> {v: Int | v = 0} @-}
-foo :: [a] -> Int
-foo zs = case zs of
-           (x:xs) -> 0
-           _      -> mylen zs
-
-
-{-@ bar :: [a] -> {v: Int | v > 0} @-}
-bar :: [a] -> Int
-bar zs = case zs of
-           [] -> 1
-           _  -> mylen zs
-
diff --git a/tests/pos/Meas8.hs b/tests/pos/Meas8.hs
deleted file mode 100644
--- a/tests/pos/Meas8.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-module Meas8 () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ include  @-}
-
-{-@ measure rlen :: [a] -> Int 
-      rlen []   = {v | v = 0}
-      rlen (y:ys) = {v | v = (1 + rlen(ys))}
-  @-}
-
-{-@ foo :: a -> {v:[b] | rlen(v) = 0} @-}
-foo x = []
-
-{-@ mylen :: xs:[a] -> {v:Int | v = rlen(xs)} @-}
-mylen          :: [a] -> Int
-mylen []       = 0
-mylen (_:xs)   = 1 + mylen xs
-
-{-@ mymap :: (a -> b) -> xs:[a] -> {v:[b] | rlen(v) = rlen(xs)} @-}
-mymap f []     = []
-mymap f (x:xs) = (f x) : (mymap f xs)
-
diff --git a/tests/pos/Meas9.hs b/tests/pos/Meas9.hs
deleted file mode 100644
--- a/tests/pos/Meas9.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-module Meas9 () where
-
-import Data.Set (Set(..))
-
-{-@ myid :: xs:[a] -> {v:[a]| listElts(v) = listElts(xs)} @-}
-myid []     = []
-myid (x:xs) = x : myid xs
-
-{-@ myapp :: xs:[a] -> ys:[a] -> {v:[a] | listElts v = Set_cup (listElts xs) (listElts ys)} @-}
-myapp :: [a] -> [a] -> [a]
-myapp []     ys = ys
-myapp (x:xs) ys = x : myapp xs ys
-
-{-@ myrev :: xs:[a] -> {v:[a]| listElts v = listElts xs} @-}
-myrev :: [a] -> [a]
-myrev = go [] 
-  where 
-    go acc []     = acc
-    go acc (y:ys) = go (y:acc) ys
-
diff --git a/tests/pos/MeasureContains.hs b/tests/pos/MeasureContains.hs
deleted file mode 100644
--- a/tests/pos/MeasureContains.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-module MeasureContains where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ LIQUID "--no-termination" @-}
-
-{-@ measure binderContainsV @-}
-binderContainsV ::  Binder n -> Bool
-binderContainsV B     = True
-binderContainsV (M x) = containsV x
-
-data Binder n = B | M (TT n)
-data TT n     = V Int | Other | Bind (Binder n) (TT n)
-
-{-@ measure containsV @-}
-containsV :: TT n -> Bool
-containsV (V i)         = True
-containsV (Bind b body) = (binderContainsV b) || (containsV body)
-containsV _             = False
-
-
-prop1 = liquidAssert (containsV $ V 7)
-prop2 = liquidAssert (containsV $ Bind (M (V 5)) Other)
diff --git a/tests/pos/MeasureDups.hs b/tests/pos/MeasureDups.hs
deleted file mode 100644
--- a/tests/pos/MeasureDups.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-module MeasureDups where
-
-import Data.Set 
-
-{-@ LIQUID "--no-termination" @-}
-{-@ measure elements @-}
-{-@ measure dups @-}
-
-data F a = F a |  C a (F a) | E 
-
-dups :: Ord a => F a -> Set a
-dups E        = empty
-dups (F a)    = empty
-dups (C x xs) = if member x (elements xs) then singleton x `union` dups xs else dups xs
-
-elements :: Ord a => F a -> Set a
-elements E        = empty
-elements (F a)    = singleton a
-elements (C x xs) = singleton x `union` elements xs
-
-
-
-{-@ foo :: (Ord a) => x:F a -> {v:Set a | (dups x) = v} @-}
-foo :: Ord a => F a -> Set a
-foo E        = empty
-foo (F a)    = empty
-foo (C x xs) = if member x (elements xs) then singleton x `union` foo xs else foo xs
diff --git a/tests/pos/MeasureSets.hs b/tests/pos/MeasureSets.hs
deleted file mode 100644
--- a/tests/pos/MeasureSets.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-{-@ LIQUID "--pruneunsorted" @-}
-
-module MeasureSets where
-
-import Data.Set 
-
-{-@ measure foo @-}
-{-@ measure foo1 @-}
-
-data F a = F a | E
-
-foo1 :: F a -> Set a
-foo1 (F x) = singleton x
-foo1 E     = empty
-
-foo :: F Int -> Int
-foo (F x) = x + 1
-foo E     = 0
-
--- bar = F
diff --git a/tests/pos/Measures.hs b/tests/pos/Measures.hs
deleted file mode 100644
--- a/tests/pos/Measures.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-module Measures where
-
-{-@ data Wrapper a 
 Bool, r :: a -> a -> Bool > 
-      = Wrap (rgref_ref :: a
) @-}
-data Wrapper a = Wrap (a)
-
--- Two measures
-{-@ measure fwdextends :: Int -> Int -> Bool @-}
-{-@ measure actionP :: Int -> Bool @-}
-
-{-@ data Wrapper2  = Wrapper2 (unwrapper :: (Wrapper<{\x -> (true)},{\x y -> (fwdextends y x)}> Int )) @-}
-{- data Wrapper2  = Wrapper2 (unwrapper :: (Wrapper<{\x -> (actionP x)},{\x y -> (true)}> Int )) @-}
-data Wrapper2  = Wrapper2 (Wrapper (Int) )
-
-
diff --git a/tests/pos/Measures1.hs b/tests/pos/Measures1.hs
deleted file mode 100644
--- a/tests/pos/Measures1.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-module Measures1 where
-
-{-@ data Wrapper a 
 Bool, r :: a -> a -> Bool > 
-      = Wrap (rgref_ref :: a
) @-}
-data Wrapper a = Wrap (a)
-
--- Two measures
-{-@ measure fwdextends :: Int -> Int -> Bool @-}
-{-@ measure actionP :: Int -> Bool @-}
-
-{- data Wrapper2  = Wrapper2 (unwrapper :: (Wrapper<{\x -> (true)},{\x y -> (fwdextends y x)}> Int )) @-}
-{-@ data Wrapper2  = Wrapper2 (unwrapper :: (Wrapper<{\x -> (actionP x)},{\x y -> (true)}> Int )) @-}
-data Wrapper2  = Wrapper2 (Wrapper (Int) )
-
-
diff --git a/tests/pos/Merge1.hs b/tests/pos/Merge1.hs
deleted file mode 100644
--- a/tests/pos/Merge1.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-module Merge1 where
-
-{-@ merge1 :: Ord a
-           => xs:[a]
-           -> ys:[a]
-           -> {v:[a] | len v == len xs + len ys}
-           / [len xs + len ys]
-  @-}
-merge1 :: Ord a => [a] -> [a] -> [a]
-merge1 (a:as') (b:bs')
-  | a `compare` b == GT = b:merge1 (a:as')  bs'
-  | otherwise           = a:merge1 as' (b:bs')
-merge1 [] bs            = bs
-merge1 as []            = as
diff --git a/tests/pos/MergeSort.hs b/tests/pos/MergeSort.hs
deleted file mode 100644
--- a/tests/pos/MergeSort.hs
+++ /dev/null
@@ -1,52 +0,0 @@
-------------------------------------------------------------------------------
--- | An implementation of Merge Sort, where LH verifies:
---   1. Termination (Totality) 
---   2. The output is indeed in non-decreasing order 
-------------------------------------------------------------------------------
-
-module MergeSort (sort) where
-
-{-@ type OList a    = [a]<{\fld v -> (v >= fld)}> @-}
-
-{-@ type OListN a N = {v:OList a | len v == N} @-}
-
--- | The top level `sort` function. Proved:
---   (a) terminating, 
---   (b) ordered, and 
---   (c) of same size as input.
-
-{-@ sort :: (Ord a) => xs:[a] -> OListN a {len xs} @-}
-sort :: Ord a => [a] -> [a]
-sort []   = []
-sort [x]  = [x]
-sort xs   = merge (sort xs1) (sort xs2) 
-  where 
-    (xs1, xs2) = split xs
-
--- Fun fact: if you delete the singleton case above,
--- the resulting function is, in fact, non-terminating!
-
--- | A type describing two `Halves` of a list `Xs` 
-
-{-@ type Halves a Xs = {v: (Half a Xs, Half a Xs) | len (fst v) + len (snd v) == len Xs} @-}
-
--- | Each `Half` is empty or smaller than the input:
-
-{-@ type Half a Xs  = {v:[a] | (len v > 1) => (len v < len Xs)} @-}
-
--- | The `split` function breaks its list into two `Halves`:
-
-{-@ split :: xs:[a] -> Halves a xs @-}
-split :: [a] -> ([a], [a])
-split (x:(y:zs)) = (x:xs, y:ys) where (xs, ys) = split zs
-split xs         = (xs, [])
-
--- | Finally, the `merge` function combines two ordered lists into a single ordered result.
-
-{-@ merge :: Ord a => xs:OList a -> ys:OList a -> OListN a {len xs + len ys} / [(len xs + len ys)] @-}
-merge :: Ord a => [a] -> [a] ->  [a]
-merge xs []         = xs
-merge [] ys         = ys
-merge (x:xs) (y:ys)
-  | x <= y          = x : merge xs (y:ys)
-  | otherwise       = y : merge (x:xs) ys
diff --git a/tests/pos/MergeSort_bag.hs b/tests/pos/MergeSort_bag.hs
deleted file mode 100644
--- a/tests/pos/MergeSort_bag.hs
+++ /dev/null
@@ -1,58 +0,0 @@
-------------------------------------------------------------------------------
--- | An implementation of Merge Sort, where LH verifies
---   * termination, and that
---   * the output is an ordered permutation of the input.
-------------------------------------------------------------------------------
-
-module MergeSort_bag (bag, sort) where
-
-import qualified Language.Haskell.Liquid.Bag as B
-
-{-@ measure bag @-}
-bag :: (Ord a) => [a] -> B.Bag a
-bag []     = B.empty
-bag (x:xs) = B.put x (bag xs)
-
-{-@ type OList a    = [a]<{\fld v -> (v >= fld)}>       @-}
-{-@ type OListN a N = {v:OList a | len v == N}          @-}
-{-@ type OListBag a B = {v:OList a | bag v == B} @-}
-
---------------------------------------------------------------------------------
--- | The top level `sort` function. Proved:
---    *  ordered, and
---    *  same multi-set as the input.
---------------------------------------------------------------------------------
-{-@ sort :: (Ord a) => xs:[a] -> OListBag a (bag xs) @-}
-sort :: Ord a => [a] -> [a]
-sort []   = []
-sort [x]  = [x]
-sort xs   = merge (sort xs1) (sort xs2)
-  where
-    (xs1, xs2) = split xs
-
---------------------------------------------------------------------------------
--- | The `split` function breaks its list into two `Halves`:
---------------------------------------------------------------------------------
-{-@ split :: xs:[a] -> Halves a xs @-}
-split :: [a] -> ([a], [a])
-split (x:(y:zs)) = (x:xs, y:ys) where (xs, ys) = split zs
-split xs         = (xs, [])
-
-
--- | A type describing two `Halves` of a list `Xs`
-{-@ type Halves a Xs = {v: (Half a Xs, Half a Xs) | len (fst v) + len (snd v) = len Xs && B.union (bag (fst v)) (bag (snd v)) == bag Xs}
-  @-}
-
--- | Each `Half` is empty or smaller than the input:
-{-@ type Half a Xs  = {v:[a] | (len v > 1) => (len v < len Xs)} @-}
-
---------------------------------------------------------------------------------
--- | Finally, the `merge` function combines two ordered lists.
---------------------------------------------------------------------------------
-{-@ merge :: Ord a => xs:OList a -> ys:OList a -> OListBag a (B.union (bag xs) (bag ys)) / [(len xs + len ys)] @-}
-merge :: Ord a => [a] -> [a] ->  [a]
-merge xs []         = xs
-merge [] ys         = ys
-merge (x:xs) (y:ys)
-  | x <= y          = x : merge xs (y:ys)
-  | otherwise       = y : merge (x:xs) ys
diff --git a/tests/pos/Mod.hs b/tests/pos/Mod.hs
deleted file mode 100644
--- a/tests/pos/Mod.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module Mod where
-
-import qualified ModLib as M
-
-{-@ inc :: x:M.Goo -> {v: M.Goo | myg v > myg x} @-}
-inc (M.G x) = M.G (x + 1)
-
diff --git a/tests/pos/ModLib.hs b/tests/pos/ModLib.hs
deleted file mode 100644
--- a/tests/pos/ModLib.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module ModLib where
-
-data Goo = G Int
-
-{-@ measure myg :: ModLib.Goo -> Int 
-      myg (ModLib.G n) = n
-  @-}
- 
-{-@ inc :: x:Goo -> {v: Goo | (myg v) > (myg x)} @-}
-inc (G x) = G (x + 1)
-
-
diff --git a/tests/pos/ModTest.hs b/tests/pos/ModTest.hs
deleted file mode 100644
--- a/tests/pos/ModTest.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module ModTest () where
-
-import Language.Haskell.Liquid.Prelude (isEven)
-
-{-@ takeEvens :: [Int] -> [{v: Int | v mod 2 = 0}] @-}
-takeEvens :: [Int] -> [Int]
-takeEvens []     = []
-takeEvens (x:xs) = if isEven x
-                     then x : takeEvens xs 
-                     else takeEvens xs 
diff --git a/tests/pos/Monad2.hs b/tests/pos/Monad2.hs
deleted file mode 100644
--- a/tests/pos/Monad2.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module Monad2 () where
-
-goo c = return c
-
-foo = 
-  do x <- Just 1
-     y <- goo 3
-     return $ x + y 
diff --git a/tests/pos/Monad5.hs b/tests/pos/Monad5.hs
deleted file mode 100644
--- a/tests/pos/Monad5.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-module Monad5 () where
-
-import Language.Haskell.Liquid.Prelude
-
--- gpp :: Monad m => m Int -> m Int
-gpp z = do x <- z
-           return $ liquidAssert (x >= 0) (x + 1)
-
-gpp' z n = do x <- z n
-              return $ liquidAssert (x >= 0) (x + 1)
-
-
-myabs :: Int -> Int
-myabs x | x >= 0     = x
-        | otherwise  = 0-x
-
-myabsM :: Monad m => Int -> m Int
-myabsM x | x >= 0     = return $ x
-         | otherwise  = return $ 0-x
-
-
-posM :: Monad m => m Int
-posM = return $ myabs $ choose 0
-
-
-xM, yM :: Monad m => m Int
-yM = gpp posM
-xM = gpp' myabsM $ choose 0
diff --git a/tests/pos/Monad6.hs b/tests/pos/Monad6.hs
deleted file mode 100644
--- a/tests/pos/Monad6.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module Monad6 () where
-
-import Language.Haskell.Liquid.Prelude 
-
-{-@ gpp :: Monad m => m {v:Int|v>=0} -> m {v:Int|v>=0} @-}
-gpp :: Monad m => m Int -> m Int
-gpp z = do x <- z
-           return $ liquidAssert (x >= 0) (x + 1)
-
-
-xM :: [Int]
-xM = gpp [0]
diff --git a/tests/pos/Multi_pred_app_00.hs b/tests/pos/Multi_pred_app_00.hs
deleted file mode 100644
--- a/tests/pos/Multi_pred_app_00.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Multi_pred_app_00 () where
-
-{-@ foo :: forall < p :: Int -> Bool
-                  , q :: Int -> Bool >. Int -> Int
 @-}
-foo :: Int -> Int
-foo x = x
diff --git a/tests/pos/Mutrec.hs b/tests/pos/Mutrec.hs
deleted file mode 100644
--- a/tests/pos/Mutrec.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-module Mutrec () where
-
-{-@ isEven :: n:Nat -> Bool / [n, 0] @-}
-isEven :: Int -> Bool
-isEven 0 = True
-isEven n = isOdd (n-1)
-
-{-@ isOdd :: n:Nat -> Bool / [n, 1] @-}
-isOdd :: Int -> Bool
-isOdd  n = not $ isEven n
-
-
-{- decrease isEven 1 2 -}
-{- decrease isOdd 1 2  -}
diff --git a/tests/pos/MutualRec.hs b/tests/pos/MutualRec.hs
deleted file mode 100644
--- a/tests/pos/MutualRec.hs
+++ /dev/null
@@ -1,42 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-
--- TODO: Fix resolve so we can remove this/add termination metrics
-{-@ LIQUID "--no-termination" @-}
-
-module MutualRec where
-
-import Language.Haskell.Liquid.Prelude
-
-
-bin :: k -> v -> [(k, v)] -> [(k, v)] -> [(k, v)] 
-{-@ bin :: k -> v -> [(k, v)] -> [(k, v)] -> [(k, v)] @-}
-singleton :: k -> v -> [(k, v)]
-{-@ singleton :: k -> v -> [(k, v)] @-}
-bin = undefined
-singleton = undefined
-
-fromDistinctAscList xs
-  = create const (length xs) xs
-  where
-    -- {- decrease create  2 3 @-}
-    -- {- decrease createR 1 4 @-}
-    create c (0::Int) xs' = c undefined xs'
--- LIQUID for n = 1 n `div` 2 = 0 and the assume does not hold
-    create c 1 xs' = case xs' of
-                       (k1,x1):xx -> c (singleton k1 x1) xx
-                       _ -> unsafeError "fromDistinctAscList create"
-    create c 5 xs' = case xs' of
-                       ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx)
-                            -> c (bin k4 x4 (bin k2 x2 (singleton k1 x1) (singleton k3 x3)) (singleton k5 x5)) xx
-                       _ -> unsafeError "fromDistinctAscList create"
-    create c n xs' = seq nr $ create (createR nr c) nl xs'
-      where nl = liquidAssume (m < n && m >= 0) m
-            m  = n `div` 2
-            nr = n - nl - 1
-
-    -- MUTUAL createR (n::Int) c l ((k,x):ys) = create (createB l k x c) n ys
-    createR (n::Int) c l ((k,x):ys) = create (\r -> c (bin k x l r)) n ys
-    createR _ _ _ []                = unsafeError "fromDistinctAscList createR []"
-    -- MUTUAL createB l k x c r zs     = c (bin k x l r) zs
-
-
diff --git a/tests/pos/MutuallyDependentADT.hs b/tests/pos/MutuallyDependentADT.hs
deleted file mode 100644
--- a/tests/pos/MutuallyDependentADT.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-module MutuallyDependentADT where
-
-{-@ LIQUID "--exactdc"  @-}
-
-data Pred l 
-  = PTerm (Term l)
-
-data Term l 
-  = TPred (Pred l)
-  | TTerm l
-
-{-@ measure tsize @-}
-tsize :: Term l -> Int
-{-@ tsize :: Term l -> Nat @-}
-tsize (TPred _)            = 0
-tsize (TTerm _)            = 0
-
-main :: IO ()
-main = pure ()
diff --git a/tests/pos/Nats.hs b/tests/pos/Nats.hs
deleted file mode 100644
--- a/tests/pos/Nats.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module Nats where
-
-{-@ nats :: [Nat] @-}
-nats :: [Int]
-nats = [1,2,3,4,5,6,7,8,9,10]
diff --git a/tests/pos/Niki.hs b/tests/pos/Niki.hs
deleted file mode 100644
--- a/tests/pos/Niki.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module Niki () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ data Pair a b 
 x1:b -> Bool> = P (x :: a) (y :: b
) @-} 
-data Pair a b = P a b
-
-bar = P (0::Int) (1::Int)
-foo = chk bar
-
-chk (P x1 y1) = liquidAssertB (x1 <= y1)
diff --git a/tests/pos/Niki1.hs b/tests/pos/Niki1.hs
deleted file mode 100644
--- a/tests/pos/Niki1.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-module Niki1 () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ data Pair a b 
 x1:b -> Bool> = P (px :: a) (py :: b
) @-} 
-data Pair a b = P a b
-
-incr :: Int -> Int
-incr x = x + 1
-
-baz :: Int -> Pair Int Int
-baz x = P x (incr x)
-
-prop :: Bool
-prop = chk (baz n)
-  where n = choose 100
-{-
-foo = baz n
- where n = choose 10
--}
-chk :: Pair Int Int -> Bool
-chk (P x y) = liquidAssertB (x < y)
-
diff --git a/tests/pos/NoCaseExpand.hs b/tests/pos/NoCaseExpand.hs
deleted file mode 100644
--- a/tests/pos/NoCaseExpand.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-module NoCaseExpand where
-
--- time 3.6s w/ "--no-case-expand" flag VS  8.5 s w/o
-
-{- LIQUID "--max-case-expand=0" @-}
-
-data TokenType =
-  Space | Keyword | Keyglyph | Layout | Comment | Conid | Varid |
-  Conop | Varop   | String   | CChar   | Number  | Cpp   | Error |
-  Definition
-
-
-context ::  [(TokenType, String)] -> [(TokenType, String)]
-context stream@((Keyglyph,"="):_) = stream
-context stream@((Keyglyph,"=>"):_) = stream
-context stream@((Keyglyph,"⇒"):_) = stream
-context (_:stream) = context stream
-context [] = []
diff --git a/tests/pos/NoExhaustiveGuardsError.hs b/tests/pos/NoExhaustiveGuardsError.hs
deleted file mode 100644
--- a/tests/pos/NoExhaustiveGuardsError.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module NoExhaustiveGuardsError where
-
-{-@ LIQUID "--no-totality" @-}
-bar :: Int -> Int -> Int
-bar x y | x >  y = 1
-        | x <= y = 0
diff --git a/tests/pos/NoPositivityCheck.hs b/tests/pos/NoPositivityCheck.hs
deleted file mode 100644
--- a/tests/pos/NoPositivityCheck.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-{-@ LIQUID "--no-positivity-check" @-}
-
-module NoPositivityCheck 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 BadRec1 a = NoRec1 (BadRec2 a -> Int)
-data BadRec2 a = NoRec2 (BadRec1 a)
diff --git a/tests/pos/Null.hs b/tests/pos/Null.hs
deleted file mode 100644
--- a/tests/pos/Null.hs
+++ /dev/null
@@ -1,4 +0,0 @@
-module Null where
-
-foo :: [a] -> [a]
-foo xs = if null xs then [] else tail xs
diff --git a/tests/pos/ORM.hs b/tests/pos/ORM.hs
deleted file mode 100644
--- a/tests/pos/ORM.hs
+++ /dev/null
@@ -1,94 +0,0 @@
-module ORM where
-
-{-@ LIQUID "--exactdc"  @-}
-{-@ LIQUID "--higherorder" @-}
-
-
-import Prelude hiding (length, filter)
-import Language.Haskell.Liquid.ProofCombinators
-
---  here is a "user" query
-{-@ prop :: L Row -> L {v:Row | rowLeft v == 5} @-}
-prop :: L Row -> L Row
-prop xs = mapCast evalQProp $ filter (evalQ (Qry Eq Fst (Const 5))) xs
-
-
-{-@ prop0 :: L Row -> L {v:Row | evalQ (Qry Eq Fst (Const 5)) v} @-}
-prop0 :: L Row -> L Row
-prop0 xs = filter (evalQ (Qry Eq Fst (Const 5))) xs
-
-{-@ mapCast :: (x:Row -> {evalQ (Qry Eq Fst (Const 5)) x <=> rowLeft x == 5})
-            -> L {v:Row | evalQ (Qry Eq Fst (Const 5)) v}
-            -> L {v:Row | rowLeft v == 5} @-}
-mapCast :: (Row -> Proof) -> L Row -> L Row
-mapCast _ N = N
-mapCast p (C x xs) = (x `withProof` (p x)) `C` mapCast p xs
-
-
-
-evalQProp :: Row -> Proof
-{-@ evalQProp :: x:Row -> {evalQ (Qry Eq Fst (Const 5)) x <=> rowLeft x == 5} @-}
-evalQProp (Row l r)
-  =   evalQ (Qry Eq Fst (Const 5)) (Row l r)
-  === evalC Eq (evalV Fst (Row l r)) (evalV (Const 5) (Row l r))
-  === evalC Eq l 5
-  === l == 5
-  *** QED
-
-
-
---  here is the DB API (will add more detail later but its pretty self contained)
-
-data Cmp = Eq | Ne
-{-@ data Cmp = Eq | Ne @-}
-
-data Val = Const {valConst :: Int} | Fst | Snd
-{-@ data Val = Const {valConst :: Int} | Fst | Snd @-}
-
-data Qry = Qry {qryCmp :: Cmp, qryLHS :: Val, qryRHS :: Val }
-
-{-@ data Qry = Qry {qryCmp :: Cmp, qryLHS :: Val, qryRHS :: Val } @-}
-
-data Row = Row {rowLeft :: Int, rowRigth :: Int}
-{-@ data Row = Row {rowLeft :: Int, rowRigth :: Int} @-}
-
-data L a = N | C {hd :: a, tl :: L a}
-{-@ data L [length] a = N | C {hd :: a, tl :: L a} @-}
-
-length :: L a -> Int
-{-@ length :: L a -> Nat @-}
-{-@ measure length @-}
-length N = 0
-length (C _ xs) = 1 + length xs
-
-------------------------------------------------------------------------
-{-@ reflect evalQ @-}
-evalQ :: Qry -> Row -> Bool
-evalQ (Qry o v1 v2) r = evalC o (evalV v1 r) (evalV v2 r)
-
-{-@ reflect evalV @-}
-evalV :: Val -> Row -> Int
-evalV (Const n) _         = n
-evalV Fst       (Row l _) = l
-evalV Snd       (Row _ r) = r
-
-{-@ reflect evalC @-}
-evalC :: Cmp -> Int -> Int -> Bool
-evalC Eq x y = x == y
-evalC Ne x y = x /= y
-
-{-@ reflect filterQ @-}
-filterQ :: Qry -> L Row -> L Row
-filterQ qry xs = filter (evalQ qry) xs
-
-
-{-@ reflect filter @-}
-{-@ filter :: forall 
 Bool, w :: a -> Bool -> Bool>.
-                  {x::a , b::{v:Bool | v} |- {v:a | v == x} <: a
 }
-                  (x:a -> Bool) -> L a -> L (a
)
-  @-}
-filter :: (a -> Bool) -> L a -> L a
-filter _ N = N
-filter p (C x xs)
-  | p x       = x `C` filter p xs
-  | otherwise = filter p xs
diff --git a/tests/pos/OrdList.hs b/tests/pos/OrdList.hs
deleted file mode 100644
--- a/tests/pos/OrdList.hs
+++ /dev/null
@@ -1,155 +0,0 @@
-{-@ LIQUID "--pruneunsorted" @-}
-
-module OrdList (
-    OrdList,
-        nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, concatOL',
-        mapOL, fromOL, toOL, foldrOL, foldlOL, llen, ollen
-        -- , olen, olens
-) where
-
-import Language.Haskell.Liquid.Prelude (liquidError)
-
-infixl 5  `appOL`
-infixl 5  `snocOL`
-infixr 5  `consOL`
-
-{-@
-data OrdList [ollen] a = None
-                      | One  (ox  :: a)
-                      | Many (oxs1 :: ListNE a)
-                      | Cons (ox  :: a)           (oxs3 :: OrdList a)
-                      | Snoc (oxs2 :: OrdList a)  (ox  :: a)
-                      | Two  (ox  :: OrdListNE a) (oy  :: OrdListNE a)
-@-}
-
-{-@ measure llen @-}
-{-@ llen :: [a] -> Nat @-}
-llen :: [a] -> Int 
-llen [] = 0
-llen (x:xs) = 1 + llen xs 
-
-{-@ measure ollen @-}
-{-@ ollen :: OrdList a -> Nat @-}
-ollen :: OrdList a -> Int 
-ollen None        = 0 
-ollen (One _)     = 1 
-ollen (Many xs)   = llen xs
-ollen (Cons _ xs) = 1 + ollen xs 
-ollen (Snoc xs _) = 1 + ollen xs 
-ollen (Two x y)   = ollen x + ollen y  
-
-{-@ measure olen :: OrdList a -> Int 
-      olen None      = 0
-      olen (One x)     = 1
-      olen (Many xs)   = len xs
-      olen (Cons x xs) = 1 + (olen xs)
-      olen (Snoc xs x) = 1 + (olen xs)
-      olen (Two x y)   = (olen x) + (olen y)
-  @-}
-
-{-@ measure olens :: [OrdList a] -> Int
-      olens []     = 0
-      olens (ol:ols) = (olen ol) + (olens ols)
-  @-}
-
-{-@ type ListNE    a   = {v:[a]       | (len v) > 0} @-}
-{-@ type OrdListNE a   = {v:OrdList a | (olen v) > 0} @-}
-{-@ type OrdListN  a N = {v:OrdList a | (olen v) = N} @-}
-
-{-@ invariant {v:OrdList a   | (olen v)  >= 0 && ollen v == olen v} @-}
-{-@ invariant {v:[OrdList a] | (olens v) >= 0} @-}
-
-
-data OrdList a
-  = None
-  | One a
-  | Many [a]          -- Invariant: non-empty
-  | Cons a (OrdList a)
-  | Snoc (OrdList a) a
-  | Two (OrdList a) -- Invariant: non-empty
-        (OrdList a) -- Invariant: non-empty
-
-
-{-@ nilOL    :: OrdListN a {0} @-}
-{-@ isNilOL  :: xs:OrdList a -> {v:Bool | v <=> (olen xs == 0)} @-}
-
-{-@ unitOL   :: a              -> OrdListN a {1} @-}
-{-@ snocOL   :: xs:OrdList a   -> a            -> OrdListN a {1 + olen xs} @-}
-{-@ consOL   :: a              -> xs:OrdList a -> OrdListN a {1 + olen xs} @-}
-{-@ appOL    :: xs:OrdList a   -> ys:OrdList a -> OrdListN a { (olen xs) + (olen ys)} @-}
-{-@ concatOL :: xs:[OrdList a] -> OrdListN a {olens xs} @-}
-
-nilOL        = None
-unitOL as    = One as
-snocOL as   b    = Snoc as b
-consOL a    bs   = Cons a bs
---LIQUID this definition requires `foldr` with abstract refinements, which isn't
---LIQUID in our standard set of specs
--- concatOL aas = foldr appOL None aas
-concatOL []       = None
-concatOL (ol:ols) = ol `appOL` concatOL ols
-
---LIQUID as an alternative, we can easily verify the property that, given
---LIQUID non-empty lists, `concatOL` will return a non-empty list
-{-@ concatOL' :: ListNE (OrdListNE a) -> OrdListNE a @-}
-concatOL' []     = liquidError "can't happen"
-concatOL' (x:xs) = foldr appOL x xs
-
-isNilOL None = True
-isNilOL _    = False
-
-None  `appOL` b     = b
-a     `appOL` None  = a
-One a `appOL` b     = Cons a b
-a     `appOL` One b = Snoc a b
-a     `appOL` b     = Two a b
-
--- TODO-REBARE the below QUAL _should_ work but doesn't, but we can get it 
--- to work with the ty-sig of `go` ... hmm.
-
-
-{-@ qualif_go :: xs:_ -> ys:_ -> {v:_ | len v = olen xs + len ys} @-}
-qualif_go :: OrdList a -> [a] -> [a]
-qualif_go = undefined 
-
-{-@ fromOL :: xs:OrdList a -> {v:[a] | len v = olen xs} @-}
-fromOL a = go a []
-  where
-    {- go :: xs:_ -> acc:_ -> {v:[a] | len v = olen xs + len acc } @-}
-    go None       acc = acc
-    go (One a)    acc = a : acc
-    go (Cons a b) acc = a : go b acc
-    go (Snoc a b) acc = go a (b:acc)
-    go (Two a b)  acc = go a (go b acc)
-    go (Many xs)  acc = xs ++ acc
-
-{-@ mapOL :: (a -> b) -> xs:OrdList a -> OrdListN b {olen xs} @-}
-mapOL _ None = None
-mapOL f (One x) = One (f x)
-mapOL f (Cons x xs) = Cons (f x) (mapOL f xs)
-mapOL f (Snoc xs x) = Snoc (mapOL f xs) (f x)
-mapOL f (Two x y) = Two (mapOL f x) (mapOL f y)
-mapOL f (Many xs) = Many (map f xs)
-
-instance Functor OrdList where
-  fmap = mapOL
-
-foldrOL :: (a -> b -> b) -> b -> OrdList a -> b
-foldrOL _ z None        = z
-foldrOL k z (One x)     = k x z
-foldrOL k z (Cons x xs) = k x (foldrOL k z xs)
-foldrOL k z (Snoc xs x) = foldrOL k (k x z) xs
-foldrOL k z (Two b1 b2) = foldrOL k (foldrOL k z b2) b1
-foldrOL k z (Many xs)   = foldr k z xs
-
-foldlOL :: (b -> a -> b) -> b -> OrdList a -> b
-foldlOL _ z None        = z
-foldlOL k z (One x)     = k z x
-foldlOL k z (Cons x xs) = foldlOL k (k z x) xs
-foldlOL k z (Snoc xs x) = k (foldlOL k z xs) x
-foldlOL k z (Two b1 b2) = foldlOL k (foldlOL k z b1) b2
-foldlOL k z (Many xs)   = foldl k z xs
-
-{-@ toOL :: xs:[a] -> OrdListN a {len xs} @-}
-toOL [] = None
-toOL xs = Many xs
diff --git a/tests/pos/Pair.hs b/tests/pos/Pair.hs
deleted file mode 100644
--- a/tests/pos/Pair.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-module Pair () where
-
-import Language.Haskell.Liquid.Prelude 
-
-{-@ data Pair a b 
 x1:b -> Bool> = P { px :: a, py :: b
 } @-} 
-data Pair a b = P a b
-
-incr x = let p = P x ((x+1)) in p
-chk (P x (y)) = liquidAssertB (x liquidAssertB (x a
-getfst (x, y) = x
-
-{-@ type Pair a b   = {v0 : ({v:a | v = (getfst v0)}, b) | true } @-}
-{-@ type OPList a b = [(Pair a b)]<\h -> {v: (a, b) | (getfst v) >= (getfst h)}> @-}
-{-@ type OList a    = [a]<\h -> {v: a | (v >= h)}> @-}
-
-{-@ getFsts          :: OPList a b -> OList a @-}
-getFsts []           = [] 
-getFsts ((x,_) : xs) = x : getFsts xs
-
-
-
diff --git a/tests/pos/PairMeasure0.hs b/tests/pos/PairMeasure0.hs
deleted file mode 100644
--- a/tests/pos/PairMeasure0.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-module PairMeasure0 () where
-
-{-@ LIQUID "--bscope" @-}
-
-{-@ measure getfst @-}
-getfst  :: (a, b) -> a
-getfst (x, y) = x
-
-{-@ type Pair a b   = {v0 : ({v:a | v = (getfst v0)}, b) | true } @-}
-{-@ type OPList a b = [(Pair a b)]<\h -> {v: (Pair a b) | (getfst v) >= (getfst h)}> @-}
-{-@ type OList a    = [a]<\h -> {v: a | (v >= h)}> @-}
-
-
--- This is Unsafe, as refinements in Predicate parameters (i.e., Pair a b)
--- are lost, so application `getFsts` cannot be proven safe
-{-@ getFsts          :: OPList a b -> OList a @-}
-getFsts :: [(a, b)] -> [a]
-getFsts []           = [] 
-getFsts ((x,_) : xs) = x : getFsts xs
-
-
-
diff --git a/tests/pos/Pargs.hs b/tests/pos/Pargs.hs
deleted file mode 100644
--- a/tests/pos/Pargs.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module Pargs () where
-
-{-@ foo :: forall a 
 x1:a -> Bool>. 
-             (i:Int -> a
) -> {v:Int| v=0}
-              -> a 

-  @-}
-
-foo ::  (Int -> a) -> Int ->  a
-foo f i = f i
-
diff --git a/tests/pos/Pargs1.hs b/tests/pos/Pargs1.hs
deleted file mode 100644
--- a/tests/pos/Pargs1.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-@ LIQUID "--pruneunsorted" @-}
-module Pargs1 () where
-
-{-@ foo :: forall a 
 x1:a -> Bool>. 
-             (i:Int  -> j : Int-> a
) -> 
-               ii:Int -> jj:Int
-              -> a 

-  @-}
-
-foo ::  (Int -> Int -> a) -> Int -> Int ->  a
-foo f i j = f i j
-
diff --git a/tests/pos/Partial_tycon.hs b/tests/pos/Partial_tycon.hs
deleted file mode 100644
--- a/tests/pos/Partial_tycon.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module Partial_tycon () where
-
-data Id a = Id a
-
-data Foo m a = Foo (m a)
-
-foo :: Foo Id a
-foo = undefined
diff --git a/tests/pos/Partialmeasure.hs b/tests/pos/Partialmeasure.hs
deleted file mode 100644
--- a/tests/pos/Partialmeasure.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-{-@ LIQUID "--no-totality" @-}
-
-module Partialmeasure where
-
--- Note: `partialmeasureOld.hs` works fine 
-
-{-@ cons :: x:a -> _ -> {v:[a] | hd v = x} @-}
-cons x xs = x : xs
-
-{-@ test :: {v:_ | hd v = 0} @-}
-test :: [Int]
-test =  cons 0 [1,2,3,4]
-
-{-@ measure hd @-}
-hd       :: [a] -> a
-hd (x:_) = x
-
-
--- Instead of rejecting, can we just default to "un-refined" constructors?
-
--- Strengthened constructors
---   data [a] where
---     []  :: [a]    -- as before
---     (:) :: x:a -> xs:[a] -> {v:[a] | hd v = x}
-
-
-
-
diff --git a/tests/pos/Permutation.hs b/tests/pos/Permutation.hs
deleted file mode 100644
--- a/tests/pos/Permutation.hs
+++ /dev/null
@@ -1,20 +0,0 @@
--- | This module contains a termination proof of Data.List.permutations.
---
--- See tests/ple/pos/Permutations.hs for a proof of the laziness
--- requirement.
---
-module Permutation () where
-
-{-@ permutations :: ts:[a] -> [[a]] / [(len ts), 1, 0] @-}
-permutations            :: [a] -> [[a]]
-permutations xs0        =  xs0 : perms xs0 []
-
-{-@ perms :: ts:[a] -> is:[a] -> [[a]] / [((len ts)+(len is)), 0, (len ts)] @-}
-perms :: [a] -> [a] -> [[a]]
-perms []     _  = []
-perms (t:ts) is = foldr interleave (perms ts (t:is)) (permutations is)
-      where interleave    xs     r = let (_,zs) = interleave' id xs r in zs
-            interleave' _ []     r = (ts, r)
-            interleave' f (y:ys) r = let (us,zs) = interleave' (f . (y:)) ys r
-                                     in  (y:us, f (t:y:us) : zs)
-
diff --git a/tests/pos/PersistentVector.hs b/tests/pos/PersistentVector.hs
deleted file mode 100644
--- a/tests/pos/PersistentVector.hs
+++ /dev/null
@@ -1,82 +0,0 @@
-{-
-https://twitter.com/BrandonBloom/status/701261641971683328
-https://github.com/clojure/clojure/blob/d5708425995e8c83157ad49007ec2f8f43d8eac8/src/jvm/clojure/lang/PersistentVector.java#L148-L164
--}
-
-{-@ LIQUID "--no-termination" @-}
-
-module PersistentVector (arrayFor, height) where
-
-import Data.Bits
-
--- | Simplified binary tree
-
-data Tree a = Leaf a
-            | Node {tLeft :: (Tree a), tRight :: (Tree a) }
-
--- | Specify "height" of a tree
-
-{-@ measure height @-}
-height :: Tree a -> Int
-height (Leaf _)   = 0
-height (Node l _) = 1 + height l
-
--- | A tree whose height is H
-
-{-@ type TreeH a H = {v:Tree a | height v == H } @-}
-
--- | Specify tree must be "balanced"
-
-{-@ data Tree a = Leaf a
-                | Node { tLeft  :: Tree a
-                       , tRight :: TreeH a (height tLeft) }
-  @-}
-
--- | Specify tree height is non-negative
-
-{-@ using (Tree a) as  {v:Tree a | 0 <= height v} @-}
-
--- | Vector stores the height
-
-data Vec a = Vec { vShift  :: Int    -- ^ height
-                 , vTree   :: Tree a -- ^ actual nodes
-                 }
-
--- | Refined type relates height of the `vTree` with `vShift`
-
-{-@ data Vec a = Vec { vShift :: Nat
-                     , vTree  :: TreeH a vShift
-                     }
-  @-}
-
---------------------------------------------------------------------------------
-
-arrayFor :: Int -> Vec a -> Maybe a
-arrayFor i (Vec l n) = loop l n
-  where
-    loop :: Int -> Tree a -> Maybe a
-    loop level node
-      | level > 0 = let b      = shift i (- level) `mod` 2  -- get bit 0 or 1
-                        node'  = getNode node b             -- get child
-                        level' = level - 1                  -- next level
-                    in
-                        loop level' node'
-
-      | otherwise = Just (getValue node)
-
-{-@ getNode :: t:{Tree a | 0 < height t}
-            -> {v:Nat | v < 2}
-            -> {v:Tree a | height v = height t - 1 }
-  @-}
-getNode :: Tree a -> Int -> Tree a
-getNode (Node l _) 0 = l
-getNode (Node _ r) 1 = r
-getNode _          _ = impossible "provably safe"
-
-{-@ getValue :: {t:Tree a | 0 = height t} -> a @-}
-getValue :: Tree a -> a
-getValue (Leaf x) = x
-getValue _        = impossible "provably safe"
-
-{-@ impossible :: {v:String | false} -> a @-}
-impossible = error
diff --git a/tests/pos/Ple1.hs b/tests/pos/Ple1.hs
deleted file mode 100644
--- a/tests/pos/Ple1.hs
+++ /dev/null
@@ -1,52 +0,0 @@
-{-@ LIQUID "--reflection" @-} 
-
-module Ple1 where
-
-import Prelude hiding ((++))
-import Language.Haskell.Liquid.ProofCombinators
-
-assocThm :: (Eq a) => [a] -> [a] -> [a] -> Bool
-assocProof :: [a] -> [a] -> [a] -> Proof
-
-{-@ infix ++ @-}
-
-{-@ reflect ++ @-}
-(++) :: [a] -> [a] -> [a]
-[]     ++ ys = ys
-(x:xs) ++ ys = x : (xs ++ ys)
-
-{-@ inline assocThm @-}
-assocThm xs ys zs = (xs ++ ys) ++ zs == xs ++ (ys ++ zs)
-
-{-@ assocProof :: xs:[a] -> ys:[a] -> zs:[a] -> { assocThm xs ys zs } @-}
-assocProof []     ys zs
-  =   ([] ++ ys) ++ zs
-  === [] ++ (ys ++ zs)
-  *** QED
-
-assocProof (x:xs) ys zs
-  =   ((x:xs) ++ ys) ++ zs
-  === (x : (xs ++ ys)) ++ zs
-  === x : ((xs ++ ys) ++ zs)
-    ? assocProof xs ys zs
-  === x : (xs ++ (ys ++ zs)) 
-  === (x:xs) ++ (ys ++ zs)
-  ***  QED
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
----
diff --git a/tests/pos/PointDist.hs b/tests/pos/PointDist.hs
deleted file mode 100644
--- a/tests/pos/PointDist.hs
+++ /dev/null
@@ -1,55 +0,0 @@
-{-@ LIQUID "--short-names"    @-}
-
-module PointDist where
-
--- | Non-negative numbers:
-
-{-@ type NonNeg  = {v:Double | v >= 0.0 } @-}
-
--- | Non-negative, and zero iff X is zero:
-
-{-@ type PosZ X  = {v:NonNeg | X == 0.0 <=> v == 0.0 } @-}
- 
--- | The distance function, STATICALLY guaranteed to satisfy "pre/post"
---   or type spec, assuming no run-time checks fail
-
-{-@ dist                 :: p1:Point -> p2:Point -> {v:NonNeg | v == 0.0 <=> EqPoint p1 p2} @-}
-dist (P x1 y1) (P x2 y2) = d
-  where 
-    d                    = root   (dx + dy)
-    dx                   = square (x1 - x2)
-    dy                   = square (y1 - y2)
-
--- | A Data Type for Points
-
-data Point = P { px :: Double, py::Double }
-
-{-@ data Point = P { px :: Double, py :: Double } @-}
-
--- | When are two points "equal" ?
-
-{-@ predicate EqPoint P1 P2 = (px P1 == px P2 && py P1 == py P2) @-}
-                
--- | Squaring numbers: DYNAMIC checks establish numerical properties
-
-{-@ square :: x:Double -> PosZ x @-}
-square   :: Double -> Double
-square 0 = 0
-square x = assume (xx > 0) xx 
-  where
-    xx   = x * x
-
-{-@ root :: x:NonNeg -> PosZ x  @-}
-root :: Double -> Double
-root 0  = 0
-root x  = assume (rx > 0) rx
-  where
-    rx  = sqrt x
-
--- | Run-time Checks
-
-{-@ assume     :: b:_ -> a -> {v:a | b} @-}
-assume True  x = x
-assume False _ = undefined -- error "Failed Dynamic Check!"
-
-
diff --git a/tests/pos/Poly0.hs b/tests/pos/Poly0.hs
deleted file mode 100644
--- a/tests/pos/Poly0.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-module Poly0 () where
-
-import Language.Haskell.Liquid.Prelude
-myabs x    = if x > 0 then x else 0 - x
-
-myid arg   = arg
-
-----------------------------------------------------------
-
-x = choose 0
-
-prop_id1 = let x'  = myabs x in 
-           let x'' = myid x' in 
-           liquidAssertB (x'' >= 0)
-
-prop_id2 = liquidAssertB (x'' >= 0)
-  where x'  = myabs x 
-        x'' = myid x' 
-
-prop_id3 = liquidAssertB (x' >= 0)
-  where x' = myid $ myabs x
diff --git a/tests/pos/Poly1.hs b/tests/pos/Poly1.hs
deleted file mode 100644
--- a/tests/pos/Poly1.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-module Poly1 () where
-
-import Language.Haskell.Liquid.Prelude
-
-myabs x    = if x > 0 then x else (0 - x)
-
-myid2 a b  = a  
-
-----------------------------------------------------------
-
-x =  choose 0
-
-prop_id4 = let x'  = myabs x in 
-           let x'' = myid2 x' [] in 
-           liquidAssertB (x'' >= 0) 
-
-prop_id5 = liquidAssertB (x'' >= 0)
-  where x'  = myabs x 
-        x'' = myid2 x' [] 
diff --git a/tests/pos/Poly2.hs b/tests/pos/Poly2.hs
deleted file mode 100644
--- a/tests/pos/Poly2.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-module Poly2 () where
-
-import Language.Haskell.Liquid.Prelude
-
-myabs x    = if x `gt` 0 then x else 0 `minus` x
-
-----------------------------------------------------------
-
-myid3 x y  = y
-
-x = choose 0 
-
-prop_id6 = liquidAssertB (x' `geq` 0)
-  where x' = myid3 [] $ myabs x 
diff --git a/tests/pos/Poly2_degenerate.hs b/tests/pos/Poly2_degenerate.hs
deleted file mode 100644
--- a/tests/pos/Poly2_degenerate.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-module Poly2_degenerate (prop_id6) where
-
-import Language.Haskell.Liquid.Prelude
-
-myabs x    = if x `gt` 0 then x else 0 `minus` x
-
-----------------------------------------------------------
-
-myid3 x y  = y
-
-prop_id6 x = liquidAssertB (x' `geq` 0)
-  where x' = myid3 [] $ myabs x 
-
-
diff --git a/tests/pos/Poly3.hs b/tests/pos/Poly3.hs
deleted file mode 100644
--- a/tests/pos/Poly3.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module Poly3 (goo) where
-
-expand          :: (a -> [b]) -> [a] -> [b]
-expand f []     = []
-expand f (x:xs) = (f x) ++ (expand f xs)
-
-baz :: a -> [Int]
-baz _ = [0]
-
-goo = expand baz
-
diff --git a/tests/pos/Poly3a.hs b/tests/pos/Poly3a.hs
deleted file mode 100644
--- a/tests/pos/Poly3a.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module Poly3a (goo) where
-
-expand f []     = []
-expand f (x:xs) = (f x) ++ (expand f xs)
-
-baz :: a -> [Int]
-baz _ = [0]
-
-goo = expand baz
-
diff --git a/tests/pos/Poly4.hs b/tests/pos/Poly4.hs
deleted file mode 100644
--- a/tests/pos/Poly4.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-module Poly4 () where
-
-import Language.Haskell.Liquid.Prelude
-
-x     = choose 0
-
-baz y = y
-
-prop  = liquidAssertB (baz True)
diff --git a/tests/pos/Polyfun.hs b/tests/pos/Polyfun.hs
deleted file mode 100644
--- a/tests/pos/Polyfun.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-module Polyfun () where
-
-import Language.Haskell.Liquid.Prelude
-
-foo :: a -> [Int]
-foo f = [0]
-
-prop  = all (\z -> liquidAssertB (z >= 0)) zs
-          where zs = foo id 
diff --git a/tests/pos/Polyqual.hs b/tests/pos/Polyqual.hs
deleted file mode 100644
--- a/tests/pos/Polyqual.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-module Polyqual (nearestCenter) where
-
-import Data.List (minimumBy)
-
-data WrapType b a = WrapType {getVect :: b, getVal :: a}
-
-{-@ type List a N     = {v : [a] | (len v) = N} @-}
-{-@ type Point N      = List Double N           @-}
-{-@ type GenPoint a N = WrapType (Point N) a    @-}
-
-
-{-@ nearestCenter :: n:Int -> (GenPoint a n) -> [(Point n)] -> (Point n) @-} 
-nearestCenter     :: Int -> WrapType [Double] a -> [[Double]] -> [Double] 
-nearestCenter n x = minKey . map (\c -> (c, distance c (getVect x)))
-
-minKey  :: (Ord v) => [(k, v)] -> k
-minKey  = fst . minimumBy (\x y -> compare (snd x) (snd y)) 
-
-{- distance :: a:[Double] -> {v:[Double] | (len v) = (len a)} -> Double -}
-distance     :: [Double] -> [Double] -> Double 
-distance a b = sqrt . sum $ safeZipWith (\v1 v2 -> (v1 - v2) ^ 2) a b
-
-{-@ safeZipWith :: (a -> b -> c) -> xs:[a] -> (List b (len xs)) -> (List c (len xs)) @-}
-safeZipWith f (a:as) (b:bs) = f a b : safeZipWith f as bs
-safeZipWith _ [] []         = []
-
-
diff --git a/tests/pos/PositivityCheck.hs b/tests/pos/PositivityCheck.hs
deleted file mode 100644
--- a/tests/pos/PositivityCheck.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module PositivityCheck where
-
-data Good1 a = Nil | Cons a (Good1 a)
-data Good2 a = Yes ((Good2 a -> Int) -> Int)
-
-data GoodRec1 a = YesRec1 (GoodRec2 a -> Int)
-data GoodRec2 a = YesRec2 (GoodRec1 a -> Int)
-
diff --git a/tests/pos/Poslist.hs b/tests/pos/Poslist.hs
deleted file mode 100644
--- a/tests/pos/Poslist.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-module Poslist () where
-
-import Language.Haskell.Liquid.Prelude
-
-myabs x    = if x `gt` 0 then x else 0 `minus` x
-
-absList xs = map myabs xs
-
-prop1 = map (liquidAssertB . (`geq` 0)) $ absList $ map choose [1..]
-
-
-numAbs x   = if x > 0 then x else (0 - x)
-
-numAbsList = map numAbs 
-
-prop2      = map (liquidAssertB . (>= 0)) $ numAbsList $ map choose [1..]
diff --git a/tests/pos/Poslist_dc.hs b/tests/pos/Poslist_dc.hs
deleted file mode 100644
--- a/tests/pos/Poslist_dc.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module Poslist_dc () where
-
-import Language.Haskell.Liquid.Prelude
-
-myabs x    = if x `gt` 0 then x else 0 `minus` x
-----------------------------------------------------------
-
-checkPos [] = True
-checkPos (z:zs) = liquidAssertB (z `geq` 0) &&  (checkPos zs)
-
-xs   = [-100..100]
-prop = checkPos $ map myabs xs
diff --git a/tests/pos/Pragma0.hs b/tests/pos/Pragma0.hs
deleted file mode 100644
--- a/tests/pos/Pragma0.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-{-@ LIQUID "--notermination" @-}
-
-module Pragma0 where
-
-
--- an obviously non-terminating function
-zoo   :: Int -> Int
-zoo x = zoo x
diff --git a/tests/pos/Pred.hs b/tests/pos/Pred.hs
deleted file mode 100644
--- a/tests/pos/Pred.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-module Pred () where
-
-{-@ predicate Lt X Y = X < Y        @-}
-{-@ predicate Ge X Y = not (Lt X Y) @-}
-{-@ predicate Pos X  = X > 0        @-}
-
-{-@ incr :: x:{v:Int | (Pos v)} -> { v:Int | ((Pos v) && (Ge v x))} @-}
-incr :: Int -> Int
-incr x = x + 1
diff --git a/tests/pos/PrimInt0.hs b/tests/pos/PrimInt0.hs
deleted file mode 100644
--- a/tests/pos/PrimInt0.hs
+++ /dev/null
@@ -1,48 +0,0 @@
-{-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE CPP,  MagicHash #-}
-{-# OPTIONS_HADDOCK hide #-}
-
-module PrimInt0 (ptake, mtake, ztake, itake) where
-
-import Data.Maybe
-import GHC.Base
-
-{-@ ztake  :: n: {v: Int# | 0 <= v} -> {v: Int | v = n } @-}
-ztake :: Int# -> Int
-ztake 0# = 0
-ztake n# = 1 + ztake (n# -# 1#)
-
-{-@ itake  :: n: {v: Int | 0 <= v} -> {v: Int | v = n } @-}
-itake :: Int -> Int
-itake 0 = 0
-itake n = 1 + itake (n - 1)
-
-{-@ ptake  :: n: {v: GHC.Prim.Int# | 0 <= v} -> {v:[a] | ((len v) >= n)} -> {v:[a] | (len(v) = n)} @-}
-ptake :: Int# -> [a] -> [a]
-ptake 0# _      = []
-ptake n# (x:xs) = x : ptake (n# -# 1#) xs
-
-{-@ mtake  :: n: {v: Int | 0 <= v} -> {v:[a]|((len v) >= n)} -> {v:[a] | (len(v) = n)} @-}
-mtake          :: Int -> [a] -> [a]
-mtake 0 _      = []
-mtake n (x:xs) = x : mtake (n - 1) xs
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/pos/Product.hs b/tests/pos/Product.hs
deleted file mode 100644
--- a/tests/pos/Product.hs
+++ /dev/null
@@ -1,61 +0,0 @@
-module Product where
-
-import Prelude hiding (sum, product, zipWith)
-
-flatten :: Int -> Int -> [[a]] -> [a]
-
--- | Lets reuse plain lists
-
-type Vec a = [a]
-
--- | The `len` function is defined in the LH prelude as:
-{-
-
-   len        :: [a] -> Int
-   len []     = 0
-   len (_:xs) = 1 + len xs
--}
-
-             
-{-@ type VecN a N = {v : Vec a | len v = N} @-}
-
-{-@ product   :: xs:Vec a -> ys:Vec a -> VecN a {len xs * len ys} @-}
-product xs ys = flatten n m $ map (\y -> map (* y) xs) ys
-  where
-    m         = length xs
-    n         = length ys
-
-{-@ sum       :: xs:Vec a -> ys:VecN a {len xs}-> VecN a {len xs} @-}
-sum xs ys     = zipWith (+) xs ys
-
-{-@ sum'       :: xs:Vec a -> ys:Vec a -> VecN a {len xs + len ys} @-}
-sum' [] ys     = ys
-sum' (x:xs) ys = x : sum' xs ys
-
-{-@ example1   :: b:VecN _ 3 -> VecN _ 6 @-}
-example1 b     = ([1, 2] `product` b) `sum` [1, 2, 3, 4, 5, 6]
-    
-{-@ example2   :: a:Vec _ -> b:{Vec _ | len b * len a = 6} -> VecN _ 6 @-}
-example2 a b   = (a `product` b) `sum` [1,2,3,4,5,6]
-
-
--- Helpers --
-
-
-{-@ flatten          :: n:Nat -> m:Nat -> VecN (VecN a m) n -> VecN a {m * n} @-}
-flatten n m []       = []
-flatten n m (xs:xss) = xs ++ flatten (n-1) m xss 
-
-
-{-@ zipWith             :: (a -> b -> c) -> xs:Vec a -> ys:VecN b {len xs} -> VecN c {len xs} @-}
-zipWith f [] []         = []
-zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys
-
-
-
-
-{-@ lAssert :: TT -> a -> a@-}
-lAssert True x = x
-
-  
-
diff --git a/tests/pos/Profcrasher.hs b/tests/pos/Profcrasher.hs
deleted file mode 100644
--- a/tests/pos/Profcrasher.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Profcrasher () where
-
-import Language.Haskell.Liquid.Prelude
-
-x :: Int
-x = 4
diff --git a/tests/pos/PromotedDataCons.hs b/tests/pos/PromotedDataCons.hs
deleted file mode 100644
--- a/tests/pos/PromotedDataCons.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-
-{-# LANGUAGE DataKinds #-}
-
-module PromotedDataCons where
-
-newtype Offset struct member = Offset { unOffset :: Int }
-
-type OffsetN t = Offset (t 'Nothing)
-
-foo = Nothing 
-
-{-@ bar :: t _       @-}
-bar :: t 'Nothing
-bar = undefined 
diff --git a/tests/pos/Propability.hs b/tests/pos/Propability.hs
deleted file mode 100644
--- a/tests/pos/Propability.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-{-@ LIQUID "--prune-unsorted" @-}
-
-module Propability where
-
-{-@ type Boolability = {v:Double | ((0.0 <= v) && (v <= 1.0)) } @-}
-
-{-@ p :: Boolability @-}
-p :: Double
-p = 0.8
-
-data DPD k = DPD [Pair k Double]
-
-data Pair x y = P x y
-{-@ data DPD k = DPD (val::{v:[Pair k Boolability]|(total v) = 1.0 }) @-}
-
-{-@ measure total @-}
-total :: [Pair k Double] -> Double
-total [] = 0.0
-total (x:xs) = (sndP x) + (total xs)
-
-{-@ measure sndP @-} 
-sndP :: Pair x Double -> Double
-sndP (P x y) = y
-
-dpd0 :: DPD Int
-dpd0 = DPD [P 1 0.8, P 2 0.1, P 3 0.1]
diff --git a/tests/pos/Propmeasure.hs b/tests/pos/Propmeasure.hs
deleted file mode 100644
--- a/tests/pos/Propmeasure.hs
+++ /dev/null
@@ -1,59 +0,0 @@
-{-# LANGUAGE EmptyDataDecls #-}
-
-module Propmeasure where
-
-import Prelude hiding (length)
-
-{-@ myhead :: {v:[a] | nonEmpty v} -> a @-}
-myhead (x:_) = x
-
-{-@ measure nonEmpty @-}   
-nonEmpty (x:xs) = True 
-nonEmpty []     = False
-
-{-@ measure length @-}   
-length :: [a] -> Int
-length (x:xs) = 1 + length xs 
-length []     = 0
-
-
-{-@ measure lenEqFive @-}   
-lenEqFive (x:xs) = length xs == 4
-lenEqFive []     = False
-
-{-@ measure lenNEqFive @-}   
-lenNEqFive (x:xs) = not (length xs == 4)
-lenNEqFive []     = True
-
-
-{-@ measure lenGEFour @-}   
-lenGEFour (x:xs) = length xs >= 3
-lenGEFour []     = False
-
-
-{-@ len3 :: {v:[Int] | (not (lenEqFive v))} @-}
-len3 :: [Int]
-len3 = [1, 2, 3]
-
-
-{-@ len5 :: {v:[Int] | (lenEqFive v) && (lenGEFour v) } @-}
-len5 :: [Int]
-len5 = [1, 2, 3, 4, 5]
-
-{-@ measure length @-}
-
-{-@ foo  :: x:[a] -> {v: Bool | v <=> (nonEmpty x) } @-}
-foo  :: [a] -> Bool
-foo x = nonEmpty x
-
-
-cons = (:)
-nil  = []
-
-
-
-
-
-
-
-
diff --git a/tests/pos/Propmeasure1.hs b/tests/pos/Propmeasure1.hs
deleted file mode 100644
--- a/tests/pos/Propmeasure1.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module Propmeasure1 where
-
-nil  = []
-
-
-
-
-
-
-
-
diff --git a/tests/pos/QQTySig.hs b/tests/pos/QQTySig.hs
deleted file mode 100644
--- a/tests/pos/QQTySig.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module QQTySig where
-
-import LiquidHaskell
-
-[lq| nats :: [{ v:Int | 0 <= v }] |]
-nats = [0,1,2,3,4,5,6,7,8,9,10]
-
diff --git a/tests/pos/QQTySigTyVars.hs b/tests/pos/QQTySigTyVars.hs
deleted file mode 100644
--- a/tests/pos/QQTySigTyVars.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module QQTySigTyVars where
-
-import LiquidHaskell
-
-[lq| nats :: Show s => s -> [{ v:Int | 0 <= v }] |]
-nats _ = [0,1,2,3,4,5,6,7,8,9,10]
-
-[lq| myId :: x:a -> { v:a | v = x } |]
-myId x = x
-
diff --git a/tests/pos/QQTySyn.hs b/tests/pos/QQTySyn.hs
deleted file mode 100644
--- a/tests/pos/QQTySyn.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module QQTySyn where
-
-import LiquidHaskell
-
-[lq| type MyNat = { v:Int | 0 <= v } |]
-[lq| type MyList a N = { v:[a] | (len v) = N } |]
-
-[lq| nats :: MyList MyNat 11 |]
-nats = [0,1,2,3,4,5,6,7,8,9,10]
-
diff --git a/tests/pos/QualTest.hs b/tests/pos/QualTest.hs
deleted file mode 100644
--- a/tests/pos/QualTest.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-module QualTest () where
-
--- this test demonstrates the inclusion of qualifiers in source files
-
-import Language.Haskell.Liquid.Prelude (liquidAssert)
-
-{-@ qualif Plus100(v:Int, a:Int): (v = a + 100) @-}
- 
-incr :: Int -> Int
-incr x = x + 100
-
-prop = liquidAssert (y == 100) y
-  where 
-    y  = incr 0 
diff --git a/tests/pos/RBTree.hs b/tests/pos/RBTree.hs
deleted file mode 100644
--- a/tests/pos/RBTree.hs
+++ /dev/null
@@ -1,216 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-
-module RBTree where
-
-import Language.Haskell.Liquid.Prelude
-
-data RBTree a = Leaf
-              | Node { nCol   :: Color
-                     , nKey   :: a
-                     , nLeft  :: !(RBTree a)
-                     , nRight :: !(RBTree a)
-                     }
-              deriving (Show)
-
-
-{-@ data RBTree a  a -> Bool, r :: a -> a -> Bool>
-            = Leaf
-            | Node { nCol   :: Color
-                   , nKey   :: a
-                   , nLeft  :: RBTree  (a )
-                   , nRight :: RBTree  (a )
-                  }
-  @-}
-
-data Color = B -- ^ Black
-           | R -- ^ Red
-           deriving (Eq,Show)
-
----------------------------------------------------------------------------
--- | Add an element -------------------------------------------------------
----------------------------------------------------------------------------
-
-{-@ add :: (Ord a) => a -> RBT a -> RBT a @-}
-add x s = makeBlack (ins x s)
-
-{-@ ins :: (Ord a) => a -> t:RBT a -> {v: ARBTN a {bh t} | IsB t => isRB v} @-}
-ins kx Leaf             = Node R kx Leaf Leaf
-ins kx s@(Node B x l r) = case compare kx x of
-                            LT -> let t = lbal x (ins kx l) r in t
-                            GT -> let t = rbal x l (ins kx r) in t
-                            EQ -> s
-ins kx s@(Node R x l r) = case compare kx x of
-                            LT -> Node R x (ins kx l) r
-                            GT -> Node R x l (ins kx r)
-                            EQ -> s
-
----------------------------------------------------------------------------
--- | Delete an element ----------------------------------------------------
----------------------------------------------------------------------------
-
-{-@ remove :: (Ord a) => a -> RBT a -> RBT a @-}
-remove x t = makeBlack (del x t)
-
-{-@ predicate HDel T V = bh V = if (isB T) then (bh T) - 1 else bh T @-}
-
-{-@ del              :: (Ord a) => a -> t:RBT a -> {v:ARBT a | HDel t v && (isB t || isRB v)} @-}
-del x Leaf           = Leaf
-del x (Node _ y a b) = case compare x y of
-   EQ -> append y a b
-   LT -> case a of
-           Leaf         -> Node R y Leaf b
-           Node B _ _ _ -> lbalS y (del x a) b
-           _            -> let t = Node R y (del x a) b in t
-   GT -> case b of
-           Leaf         -> Node R y a Leaf
-           Node B _ _ _ -> rbalS y a (del x b)
-           _            -> Node R y a (del x b)
-
-{-@ append :: y:a -> l:RBT {v:a | v < y} -> r:RBTN {v:a | y < v} {bh l} -> ARBT2 a l r @-}
-append :: a -> RBTree a -> RBTree a -> RBTree a
-append _ Leaf r                               = r
-append _ l Leaf                               = l
-append piv (Node R lx ll lr) (Node R rx rl rr)  = case append piv lr rl of
-                                                    Node R x lr' rl' -> Node R x (Node R lx ll lr') (Node R rx rl' rr)
-                                                    lrl              -> Node R lx ll (Node R rx lrl rr)
-append piv (Node B lx ll lr) (Node B rx rl rr)  = case append piv lr rl of
-                                                    Node R x lr' rl' -> Node R x (Node B lx ll lr') (Node B rx rl' rr)
-                                                    lrl              -> lbalS lx ll (Node B rx lrl rr)
-append piv l@(Node B _ _ _) (Node R rx rl rr)   = Node R rx (append piv l rl) rr
-append piv l@(Node R lx ll lr) r@(Node B _ _ _) = Node R lx ll (append piv lr r)
-
----------------------------------------------------------------------------
--- | Delete Minimum Element -----------------------------------------------
----------------------------------------------------------------------------
-
-{-@ deleteMin            :: RBT a -> RBT a @-}
-deleteMin (Leaf)         = Leaf
-deleteMin (Node _ x l r) = makeBlack t
-  where
-    (_, t)               = deleteMin' x l r
-
-
-{-@ deleteMin'                   :: k:a -> l:RBT {v:a | v < k} -> r:RBTN {v:a | k < v} {bh l} -> (a, ARBT2 a l r) @-}
-deleteMin' k Leaf r              = (k, r)
-deleteMin' x (Node R lx ll lr) r = (k, Node R x l' r)   where (k, l') = deleteMin' lx ll lr
-deleteMin' x (Node B lx ll lr) r = (k, lbalS x l' r )   where (k, l') = deleteMin' lx ll lr
-
----------------------------------------------------------------------------
--- | Rotations ------------------------------------------------------------
----------------------------------------------------------------------------
-
-{-@ lbalS                             :: k:a -> l:ARBT {v:a | v < k} -> r:RBTN {v:a | k < v} {1 + bh l} -> {v: ARBTN a {1 + bh l} | IsB r => isRB v} @-}
-lbalS k (Node R x a b) r              = Node R k (Node B x a b) r
-lbalS k l (Node B y a b)              = let t = rbal k l (Node R y a b) in t
-lbalS k l (Node R z (Node B y a b) c) = Node R y (Node B k l a) (rbal z b (makeRed c))
-lbalS k l r                           = liquidError "nein"
-
-{-@ rbalS                             :: k:a -> l:RBT {v:a | v < k} -> r:ARBTN {v:a | k < v} {bh l - 1} -> {v: ARBTN a {bh l} | IsB l => isRB v} @-}
-rbalS k l (Node R y b c)              = Node R k l (Node B y b c)
-rbalS k (Node B x a b) r              = let t = lbal k (Node R x a b) r  in t
-rbalS k (Node R x a (Node B y b c)) r = Node R y (lbal x (makeRed a) b) (Node B k c r)
-rbalS k l r                           = liquidError "nein"
-
-{-@ lbal                              :: k:a -> l:ARBT {v:a | v < k} -> RBTN {v:a | k < v} {bh l} -> RBTN a {1 + bh l} @-}
-lbal k (Node R y (Node R x a b) c) r  = Node R y (Node B x a b) (Node B k c r)
-lbal k (Node R x a (Node R y b c)) r  = Node R y (Node B x a b) (Node B k c r)
-lbal k l r                            = Node B k l r
-
-{-@ rbal                              :: k:a -> l:RBT {v:a | v < k} -> ARBTN {v:a | k < v} {bh l} -> RBTN a {1 + bh l} @-}
-rbal x a (Node R y b (Node R z c d))  = Node R y (Node B x a b) (Node B z c d)
-rbal x a (Node R z (Node R y b c) d)  = Node R y (Node B x a b) (Node B z c d)
-rbal x l r                            = Node B x l r
-
----------------------------------------------------------------------------
----------------------------------------------------------------------------
----------------------------------------------------------------------------
-
-{-@ type BlackRBT a = {v: RBT a | IsB v && bh v > 0} @-}
-
-{-@ makeRed :: l:BlackRBT a -> ARBTN a {bh l - 1} @-}
-makeRed (Node B x l r) = Node R x l r
-makeRed _              = liquidError "nein"
-
-{-@ makeBlack :: ARBT a -> RBT a @-}
-makeBlack Leaf           = Leaf
-makeBlack (Node _ x l r) = Node B x l r
-
----------------------------------------------------------------------------
--- | Specifications -------------------------------------------------------
----------------------------------------------------------------------------
-
--- | Ordered Red-Black Trees
-
-{-@ type ORBT a = RBTree <{\root v -> v < root }, {\root v -> v > root}> a @-}
-
--- | Red-Black Trees
-
-{-@ type RBT a    = {v: ORBT a | isRB v && isBH v } @-}
-{-@ type RBTN a N = {v: RBT a  | bh v = N }         @-}
-
-{-@ type ORBTL a X = RBT {v:a | v < X} @-}
-{-@ type ORBTG a X = RBT {v:a | X < v} @-}
-
-{-@ measure isRB        :: RBTree a -> Bool
-      isRB Leaf         = true
-      isRB (Node c x l r) = isRB l && isRB r && (c == R => (IsB l && IsB r))
-  @-}
-
--- | Almost Red-Black Trees
-
-{-@ type ARBT a    = {v: ORBT a | isARB v && isBH v} @-}
-{-@ type ARBTN a N = {v: ARBT a | bh v = N }         @-}
-
-{-@ measure isARB        :: (RBTree a) -> Bool
-      isARB Leaf         = true
-      isARB (Node c x l r) = (isRB l && isRB r)
-  @-}
-
--- | Conditionally Red-Black Tree
-
-{-@ type ARBT2 a L R = {v:ARBTN a {bh L} | (IsB L && IsB R) => isRB v} @-}
-
--- | Color of a tree
-
-{-@ measure col         :: RBTree a -> Color
-      col (Node c x l r)  = c
-      col Leaf          = B
-  @-}
-
-{-@ measure isB        :: RBTree a -> Bool
-      isB Leaf         = false
-      isB (Node c x l r) = c == B
-  @-}
-
-{-@ predicate IsB T = not (col T == R) @-}
-
--- | Black Height
-
-{-@ measure isBH        :: RBTree a -> Bool
-      isBH Leaf         = true
-      isBH (Node c x l r) = (isBH l && isBH r && bh l = bh r)
-  @-}
-
-{-@ measure bh        :: RBTree a -> Int
-      bh Leaf         = 0
-      bh (Node c x l r) = bh l + if (c == R) then 0 else 1
-  @-}
-
--------------------------------------------------------------------------------
--- Auxiliary Invariants -------------------------------------------------------
--------------------------------------------------------------------------------
-
-{-@ predicate Invs V = Inv1 V && Inv2 V && Inv3 V   @-}
-{-@ predicate Inv1 V = (isARB V && IsB V) => isRB V @-}
-{-@ predicate Inv2 V = isRB V => isARB V            @-}
-{-@ predicate Inv3 V = 0 <= bh V                    @-}
-{-@ invariant {v: Color | v = R || v = B}           @-}
-{-@ invariant {v: RBTree a | Invs v}                @-}
-
-{-@ inv :: RBTree a -> {v:RBTree a | Invs v}        @-}
-inv Leaf           = Leaf
-inv (Node c x l r) = Node c x (inv l) (inv r)
-
-{-@ invc :: t:RBTree a -> {v:RBTree a | Invs t }  @-}
-invc Leaf           =  Leaf
-invc (Node c x l r) =  Node c x  (invc l) (invc r)
diff --git a/tests/pos/RBTree_col_height.hs b/tests/pos/RBTree_col_height.hs
deleted file mode 100644
--- a/tests/pos/RBTree_col_height.hs
+++ /dev/null
@@ -1,208 +0,0 @@
-
-{-@ LIQUID "--no-termination"   @-}
-
-module RBTree_col_height where
-
-import Language.Haskell.Liquid.Prelude
-
-data RBTree a = Leaf 
-              | Node Color a !(RBTree a) !(RBTree a)
-              deriving (Show)
-
-data Color = B -- ^ Black
-           | R -- ^ Red
-           deriving (Eq,Show)
-
----------------------------------------------------------------------------
--- | Add an element -------------------------------------------------------
----------------------------------------------------------------------------
-
-{-@ add :: (Ord a) => a -> RBT a -> RBT a @-}
-add x s = makeBlack (ins x s)
-
-{-@ ins :: (Ord a) => a -> t:RBT a -> {v: ARBTN a {(bh t)} | ((IsB t) => (isRB v))} @-}
-ins kx Leaf             = Node R kx Leaf Leaf
-ins kx s@(Node B x l r) = case compare kx x of
-                            LT -> let t = lbal x (ins kx l) r in t 
-                            GT -> let t = rbal x l (ins kx r) in t 
-                            EQ -> s
-ins kx s@(Node R x l r) = case compare kx x of
-                            LT -> Node R x (ins kx l) r
-                            GT -> Node R x l (ins kx r)
-                            EQ -> s
-
----------------------------------------------------------------------------
--- | Delete an element ----------------------------------------------------
----------------------------------------------------------------------------
-
-{-@ remove :: (Ord a) => a -> RBT a -> RBT a @-}
-remove x t = makeBlack (del x t)
-
-{-@ predicate HDel T V = (bh V) = (if (isB T) then (bh T) - 1 else (bh T)) @-}
-
-{-@ del              :: (Ord a) => a -> t:RBT a -> {v:ARBT a | ((HDel t v) && ((isB t) || (isRB v)))} @-}
-del x Leaf           = Leaf
-del x (Node _ y a b) = case compare x y of
-   EQ -> append y a b 
-   LT -> case a of
-           Leaf         -> Node R y Leaf b
-           Node B _ _ _ -> lbalS y (del x a) b
-           _            -> let t = Node R y (del x a) b in t 
-   GT -> case b of
-           Leaf         -> Node R y a Leaf 
-           Node B _ _ _ -> rbalS y a (del x b)
-           _            -> Node R y a (del x b)
-
-{-@ append :: y:a -> l:RBT a -> r:RBTN a {(bh l)} -> (ARBT2 a l r) @-}
-append :: a -> RBTree a -> RBTree a -> RBTree a
-
-append _ Leaf r                               
-  = r
-
-append _ l Leaf                               
-  = l
-
-append piv (Node R lx ll lr) (Node R rx rl rr)  
-  = case append piv lr rl of 
-     Node R x lr' rl' -> Node R x (Node R lx ll lr') (Node R rx rl' rr)
-     lrl              -> Node R lx ll (Node R rx lrl rr)
-
-append piv (Node B lx ll lr) (Node B rx rl rr)  
-  = case append piv lr rl of 
-      Node R x lr' rl' -> Node R x (Node B lx ll lr') (Node B rx rl' rr)
-      lrl              -> lbalS lx ll (Node B rx lrl rr)
-
-append piv l@(Node B _ _ _) (Node R rx rl rr)   
-  = Node R rx (append piv l rl) rr
-
-append piv l@(Node R lx ll lr) r@(Node B _ _ _) 
-  = Node R lx ll (append piv lr r)
-
----------------------------------------------------------------------------
--- | Delete Minimum Element -----------------------------------------------
----------------------------------------------------------------------------
-
-{-@ deleteMin            :: RBT a -> RBT a @-}
-deleteMin (Leaf)         = Leaf
-deleteMin (Node _ x l r) = makeBlack t
-  where 
-    (_, t)               = deleteMin' x l r
-
-
-{-@ deleteMin'                   :: k:a -> l:RBT a -> r:RBTN a {(bh l)} -> (a, ARBT2 a l r) @-}
-deleteMin' k Leaf r              = (k, r)
-deleteMin' x (Node R lx ll lr) r = (k, Node R x l' r)   where (k, l') = deleteMin' lx ll lr 
-deleteMin' x (Node B lx ll lr) r = (k, lbalS x l' r )   where (k, l') = deleteMin' lx ll lr 
-
----------------------------------------------------------------------------
--- | Rotations ------------------------------------------------------------
----------------------------------------------------------------------------
-
-{-@ lbalS  :: k:a -> l:ARBT a -> r:RBTN a {1 + (bh l)} -> {v: ARBTN a {1 + (bh l)} | ((IsB r) => (isRB v))} @-}
-lbalS k (Node R x a b) r              = Node R k (Node B x a b) r
-lbalS k l (Node B y a b)              = let t = rbal k l (Node R y a b) in t 
-lbalS k l (Node R z (Node B y a b) c) = Node R y (Node B k l a) (rbal z b (makeRed c))
-lbalS k l r                           = liquidError "nein" -- Node R l k r
-
-{-@ rbalS  :: k:a -> l:RBT a -> r:ARBTN a {(bh l) - 1} -> {v: ARBTN a {(bh l)} | ((IsB l) => (isRB v))} @-}
-rbalS k l (Node R y b c)              = Node R k l (Node B y b c)
-rbalS k (Node B x a b) r              = let t = lbal k (Node R x a b) r in t 
-rbalS k (Node R x a (Node B y b c)) r = Node R y (lbal x (makeRed a) b) (Node B k c r)
-rbalS k l r                           = liquidError "nein" -- Node R l k r
-
-{-@ lbal  :: k:a -> l:ARBT a -> RBTN a {(bh l)} -> RBTN a {1 + (bh l)} @-}
-lbal k (Node R y (Node R x a b) c) r  = Node R y (Node B x a b) (Node B k c r)
-lbal k (Node R x a (Node R y b c)) r  = Node R y (Node B x a b) (Node B k c r)
-lbal k l r                            = Node B k l r
-
-{-@ rbal  :: k:a -> l:RBT a -> ARBTN a {(bh l)} -> RBTN a {1 + (bh l)} @-}
-rbal x a (Node R y b (Node R z c d))  = Node R y (Node B x a b) (Node B z c d)
-rbal x a (Node R z (Node R y b c) d)  = Node R y (Node B x a b) (Node B z c d)
-rbal x l r                            = Node B x l r
-
----------------------------------------------------------------------------
----------------------------------------------------------------------------
----------------------------------------------------------------------------
-
-{-@ type BlackRBT a = {v: RBT a | ((IsB v) && (bh v) > 0)} @-}
-
-{-@ makeRed :: l:BlackRBT a -> ARBTN a {(bh l) - 1} @-}
-makeRed (Node _ x l r) = Node R x l r
-makeRed Leaf           = liquidError "nein" 
-
-{-@ makeBlack :: ARBT a -> RBT a @-}
-makeBlack Leaf           = Leaf
-makeBlack (Node _ x l r) = Node B x l r
-
----------------------------------------------------------------------------
--- | Specifications -------------------------------------------------------
----------------------------------------------------------------------------
-
--- | Red-Black Trees
-
-{-@ type RBT a    = {v: RBTree a | ((isRB v) && (isBH v)) } @-}
-
-{-@ type RBTN a N = {v: (RBT a) | (bh v) = N }              @-}
-
-{-@ measure isRB        :: RBTree a -> Bool
-      isRB Leaf         = true
-      isRB (Node c x l r) = ((isRB l) && (isRB r) && ((c == R) => ((IsB l) && (IsB r))))
-  @-}
-
--- | Almost Red-Black Trees
-
-{-@ type ARBT a    = {v: RBTree a | ((isARB v) && (isBH v))} @-}
-
-{-@ type ARBTN a N = {v: ARBT a   | (bh v) = N }             @-}
-
-{-@ measure isARB        :: (RBTree a) -> Bool
-      isARB Leaf         = true 
-      isARB (Node c x l r) = ((isRB l) && (isRB r))
-  @-}
-
--- | Conditionally Red-Black Tree
-
-{-@ type ARBT2 a L R = {v:ARBTN a {(bh L)} | (((IsB L) && (IsB R)) => (isRB v))} @-}
-
--- | Color of a tree
-
-{-@ measure col         :: RBTree a -> Color
-      col (Node c x l r)  = c
-      col Leaf          = B
-  @-}
-
-{-@ measure isB        :: RBTree a -> Bool
-      isB Leaf         = false
-      isB (Node c x l r) = c == B 
-  @-}
-
-{-@ predicate IsB T = not ((col T) == R) @-}
-
--- | Black Height
-
-{-@ measure isBH        :: RBTree a -> Bool
-      isBH Leaf         = true
-      isBH (Node c x l r) = ((isBH l) && (isBH r) && (bh l) = (bh r))
-  @-}
-
-{-@ measure bh        :: RBTree a -> Int
-      bh Leaf         = 0
-      bh (Node c x l r) = (bh l) + (if (c == R) then 0 else 1) 
-  @-}
-
--------------------------------------------------------------------------------
--- Auxiliary Invariants -------------------------------------------------------
--------------------------------------------------------------------------------
-
-{-@ predicate Invs V = ((Inv1 V) && (Inv2 V) && (Inv3 V))   @-}
-{-@ predicate Inv1 V = (((isARB V) && (IsB V)) => (isRB V)) @-}
-{-@ predicate Inv2 V = ((isRB V) => (isARB V))              @-}
-{-@ predicate Inv3 V = 0 <= (bh V)                          @-}
-
-{-@ invariant {v: Color | (v = R || v = B)}                 @-}
-
-{-@ invariant {v: RBTree a | (Invs v)}                      @-}
-
-{-@ inv            :: RBTree a -> {v:RBTree a | (Invs v)}   @-}
-inv Leaf           = Leaf
-inv (Node c x l r) = Node c x (inv l) (inv r)
diff --git a/tests/pos/RBTree_color.hs b/tests/pos/RBTree_color.hs
deleted file mode 100644
--- a/tests/pos/RBTree_color.hs
+++ /dev/null
@@ -1,191 +0,0 @@
-{-@ LIQUID "--no-termination"   @-}
-
-module RBTree_color where
-
-import Language.Haskell.Liquid.Prelude
-
-data RBTree a = Leaf 
-              | Node Color a !(RBTree a) !(RBTree a)
-              deriving (Show)
-
-data Color = B -- ^ Black
-           | R -- ^ Red
-           deriving (Eq,Show)
-
----------------------------------------------------------------------------
--- | Add an element -------------------------------------------------------
----------------------------------------------------------------------------
-
-{-@ add :: (Ord a) => a -> RBT a -> RBT a @-}
-add x s = makeBlack (ins x s)
-
-{-@ ins :: (Ord a) => a -> t:RBT a -> {v: ARBT a | ((notR t) => (isRB v))} @-}
-ins kx Leaf             = Node R kx Leaf Leaf
-ins kx s@(Node B x l r) = case compare kx x of
-                            LT -> let t = lbal x (ins kx l) r in t 
-                            GT -> let t = rbal x l (ins kx r) in t 
-                            EQ -> s
-ins kx s@(Node R x l r) = case compare kx x of
-                            LT -> Node R x (ins kx l) r
-                            GT -> Node R x l (ins kx r)
-                            EQ -> s
-
----------------------------------------------------------------------------
--- | Delete an element ----------------------------------------------------
----------------------------------------------------------------------------
-
-{-@ remove :: (Ord a) => a -> RBT a -> RBT a @-}
-remove x t = makeBlack (del x t)
-
-{-@ del              :: (Ord a) => a -> t:RBT a -> {v:ARBT a | ((isB t) || (isRB v))} @-}
-del x Leaf           = Leaf
-del x (Node _ y a b) = case compare x y of
-   EQ -> append y a b 
-   LT -> case a of
-           Leaf         -> Node R y Leaf b
-           Node B _ _ _ -> lbalS y (del x a) b
-           _            -> let t = Node R y (del x a) b in t 
-   GT -> case b of
-           Leaf         -> Node R y a Leaf 
-           Node B _ _ _ -> rbalS y a (del x b)
-           _            -> Node R y a (del x b)
-
-{-@ append :: y:a -> l:RBT a -> r:RBT a -> (ARBT2 a l r) @-}
-
-append :: a -> RBTree a -> RBTree a -> RBTree a
-
-append _ Leaf r 
-  = r
-
-append _ l Leaf 
-  = l
-
-append piv (Node R lx ll lr) (Node R rx rl rr)  
-  = case append piv lr rl of 
-      Node R x lr' rl' -> Node R x (Node R lx ll lr') (Node R rx rl' rr)
-      lrl              -> Node R lx ll (Node R rx lrl rr)
-
-append piv (Node B lx ll lr) (Node B rx rl rr)  
-  = case append piv lr rl of 
-      Node R x lr' rl' -> Node R x (Node B lx ll lr') (Node B rx rl' rr)
-      lrl              -> lbalS lx ll (Node B rx lrl rr)
-
-append piv l@(Node B _ _ _) (Node R rx rl rr)   
-  = Node R rx (append piv l rl) rr
-
-append piv l@(Node R lx ll lr) r@(Node B _ _ _) 
-  = Node R lx ll (append piv lr r)
-
----------------------------------------------------------------------------
--- | Delete Minimum Element -----------------------------------------------
----------------------------------------------------------------------------
-
-{-@ deleteMin :: RBT a -> RBT a @-}
-deleteMin (Leaf)         = Leaf
-deleteMin (Node _ x l r) = makeBlack t
-  where 
-    (_, t)               = deleteMin' x l r
-
-
-{-@ deleteMin' :: k:a -> l:RBT a -> r:RBT a -> (a, ARBT2 a l r) @-}
-deleteMin' k Leaf r              = (k, r)
-deleteMin' x (Node R lx ll lr) r = (k, Node R x l' r)   where (k, l') = deleteMin' lx ll lr 
-deleteMin' x (Node B lx ll lr) r = (k, lbalS x l' r )   where (k, l') = deleteMin' lx ll lr 
-
----------------------------------------------------------------------------
--- | Rotations ------------------------------------------------------------
----------------------------------------------------------------------------
-
-{-@ lbalS                             :: k:a -> l:ARBT a -> r:RBT a -> {v: ARBT a | ((notR r) => (isRB v))} @-}
-lbalS k (Node R x a b) r              = Node R k (Node B x a b) r
-lbalS k l (Node B y a b)              = let t = rbal k l (Node R y a b) in t 
-lbalS k l (Node R z (Node B y a b) c) = Node R y (Node B k l a) (rbal z b (makeRed c))
-lbalS k l r                           = unsafeError "nein"
-
-{-@ rbalS                             :: k:a -> l:RBT a -> r:ARBT a -> {v: ARBT a | ((notR l) => (isRB v))} @-}
-rbalS k l (Node R y b c)              = Node R k l (Node B y b c)
-rbalS k (Node B x a b) r              = let t = lbal k (Node R x a b) r in t 
-rbalS k (Node R x a (Node B y b c)) r = Node R y (lbal x (makeRed a) b) (Node B k c r)
-rbalS k l r                           = unsafeError "nein" 
-
-{-@ lbal                              :: k:a -> l:ARBT a -> RBT a -> RBT a @-}
-lbal k (Node R y (Node R x a b) c) r  = Node R y (Node B x a b) (Node B k c r)
-lbal k (Node R x a (Node R y b c)) r  = Node R y (Node B x a b) (Node B k c r)
-lbal k l r                            = Node B k l r
-
-{-@ rbal                              :: k:a -> l:RBT a -> ARBT a -> RBT a  @-}
-rbal x a (Node R y b (Node R z c d))  = Node R y (Node B x a b) (Node B z c d)
-rbal x a (Node R z (Node R y b c) d)  = Node R y (Node B x a b) (Node B z c d)
-rbal x l r                            = Node B x l r
-
----------------------------------------------------------------------------
----------------------------------------------------------------------------
----------------------------------------------------------------------------
-
-{-@ type BlackRBT a = {v: RBT a | (notR v)} @-}
-
-{-@ makeRed :: l:BlackRBT a -> ARBT a @-}
-makeRed (Node B x l r) = Node R x l r
-makeRed _              = unsafeError "nein" 
-
-{-@ makeBlack :: ARBT a -> RBT a @-}
-makeBlack Leaf           = Leaf
-makeBlack (Node _ x l r) = Node B x l r
-
----------------------------------------------------------------------------
--- | Specifications -------------------------------------------------------
----------------------------------------------------------------------------
-
--- | Red-Black Trees
-
-{-@ type RBT a    = {v: RBTree a | (isRB v)} @-}
-
-{-@ measure isRB @-}
-isRB :: RBTree a -> Bool
-isRB Leaf           = True
-isRB (Node c x l r) = (isRB l) && (isRB r) && ((c /= R) || ((notR l) && (notR r)))
-
--- | Almost Red-Black Trees
-
-{-@ type ARBT a    = {v: RBTree a | (isARB v) } @-}
-
-{-@ measure isARB @-} 
-isARB :: RBTree a -> Bool
-isARB Leaf         = True 
-isARB (Node c x l r) = isRB l && isRB r
-
--- | Conditionally Red-Black Tree
-
-{-@ type ARBT2 a L R = {v:ARBT a | (((notR L) && (notR R)) => (isRB v))} @-}
-
--- | Color of a tree
-
-{-@ measure col @-}
-col :: RBTree a -> Color
-col (Node c x l r) = c
-col Leaf           = B
-
-{-@ measure isB @-} 
-isB :: RBTree a -> Bool
-isB Leaf           = False
-isB (Node c x l r) = (c == B) 
-
-{-@ inline notR @-}
-notR :: RBTree a -> Bool
-notR t = not ((col t) == R)
-
-------------------------------------------------------------------
--- | Auxiliary Invariants ----------------------------------------
-------------------------------------------------------------------
-
-{-@ predicate Invs V = ((Inv1 V) && (Inv2 V))               @-}
-{-@ predicate Inv1 V = (((isARB V) && (notR V)) => (isRB V)) @-}
-{-@ predicate Inv2 V = ((isRB V) => (isARB V))              @-}
-
-{-@ invariant {v: Color | (v = R || v = B)}                 @-}
-
-{-@ invariant {v: RBTree a | (Invs v)}                      @-}
-
-{-@ inv            :: RBTree a -> {v:RBTree a | (Invs v)}   @-}
-inv Leaf           = Leaf
-inv (Node c x l r) = Node c x (inv l) (inv r)
diff --git a/tests/pos/RBTree_height.hs b/tests/pos/RBTree_height.hs
deleted file mode 100644
--- a/tests/pos/RBTree_height.hs
+++ /dev/null
@@ -1,177 +0,0 @@
-
-{-@ LIQUID "--no-termination"   @-}
-{-@ LIQUID "--no-totality"      @-}
-
-module RBTree_height where
-
-import Language.Haskell.Liquid.Prelude
-
-data RBTree a = Leaf 
-              | Node Color a !(RBTree a) !(RBTree a)
-              deriving (Show)
-
-data Color = B -- ^ Black
-           | R -- ^ Red
-           deriving (Eq,Show)
-
----------------------------------------------------------------------------
--- | Add an element -------------------------------------------------------
----------------------------------------------------------------------------
-
-{-@ add :: (Ord a) => a -> RBT a -> RBT a @-}
-add x s = makeBlack (ins x s)
-
-{-@ ins :: (Ord a) => a -> t:RBT a -> RBTN a {(bh t)}  @-}
-ins kx Leaf             = Node R kx Leaf Leaf
-ins kx s@(Node B x l r) = case compare kx x of
-                            LT -> let t = lbal x (ins kx l) r in t 
-                            GT -> let t = rbal x l (ins kx r) in t 
-                            EQ -> s
-ins kx s@(Node R x l r) = case compare kx x of
-                            LT -> Node R x (ins kx l) r
-                            GT -> Node R x l (ins kx r)
-                            EQ -> s
-
----------------------------------------------------------------------------
--- | Delete an element ----------------------------------------------------
----------------------------------------------------------------------------
-
-{-@ remove :: (Ord a) => a -> RBT a -> RBT a @-}
-remove x t = makeBlack (del x t)
-
-{-@ predicate HDel T V = (bh V) = (if (isB T) then (bh T) - 1 else (bh T)) @-}
-
-{-@ del              :: (Ord a) => a -> t:RBT a -> {v:RBT a | (HDel t v)} @-}
-del x Leaf           = Leaf
-del x (Node _ y a b) = case compare x y of
-   EQ -> append y a b 
-   LT -> case a of
-           Leaf         -> Node R y Leaf b
-           Node B _ _ _ -> lbalS y (del x a) b
-           _            -> let t = Node R y (del x a) b in t 
-   GT -> case b of
-           Leaf         -> Node R y a Leaf 
-           Node B _ _ _ -> rbalS y a (del x b)
-           _            -> Node R y a (del x b)
-
-{-@ append :: y:a -> l:RBT a -> r:RBTN a {(bh l)} -> RBTN a {(bh l)} @-}
-append :: a -> RBTree a -> RBTree a -> RBTree a
-
-append _ Leaf r                               
-  = r
-
-append _ l Leaf                               
-  = l
-
-append piv (Node R lx ll lr) (Node R rx rl rr)  
-  = case append piv lr rl of 
-     Node R x lr' rl' -> Node R x (Node R lx ll lr') (Node R rx rl' rr)
-     lrl              -> Node R lx ll (Node R rx lrl rr)
-
-append piv (Node B lx ll lr) (Node B rx rl rr)  
-  = case append piv lr rl of 
-      Node R x lr' rl' -> Node R x (Node B lx ll lr') (Node B rx rl' rr)
-      lrl              -> lbalS lx ll (Node B rx lrl rr)
-
-append piv l@(Node B _ _ _) (Node R rx rl rr)   
-  = Node R rx (append piv l rl) rr
-
-append piv l@(Node R lx ll lr) r@(Node B _ _ _) 
-  = Node R lx ll (append piv lr r)
-
----------------------------------------------------------------------------
--- | Delete Minimum Element -----------------------------------------------
----------------------------------------------------------------------------
-
-{-@ deleteMin            :: RBT a -> RBT a @-}
-deleteMin (Leaf)         = Leaf
-deleteMin (Node _ x l r) = makeBlack t
-  where 
-    (_, t)               = deleteMin' x l r
-
-
-{-@ deleteMin'                   :: k:a -> l:RBT a -> r:RBTN a {(bh l)} -> (a, RBTN a {(bh l)}) @-}
-deleteMin' k Leaf r              = (k, r)
-deleteMin' x (Node R lx ll lr) r = (k, Node R x l' r)   where (k, l') = deleteMin' lx ll lr 
-deleteMin' x (Node B lx ll lr) r = (k, lbalS x l' r )   where (k, l') = deleteMin' lx ll lr 
-
----------------------------------------------------------------------------
--- | Rotations ------------------------------------------------------------
----------------------------------------------------------------------------
-
-{-@ lbalS  :: k:a -> l:RBT a -> r:RBTN a {1 + (bh l)} -> RBTN a {1 + (bh l)} @-}
-lbalS k (Node R x a b) r              = Node R k (Node B x a b) r
-lbalS k l (Node B y a b)              = let t = rbal k l (Node R y a b) in t 
-lbalS k l (Node R z (Node B y a b) c) = Node R y (Node B k l a) (rbal z b (makeRed c))
-lbalS k l r                           = unsafeError "nein"
-
-{-@ rbalS  :: k:a -> l:RBT a -> r:RBTN a {(bh l) - 1} -> RBTN a {(bh l)}    @-}
-rbalS k l (Node R y b c)              = Node R k l (Node B y b c)
-rbalS k (Node B x a b) r              = let t = lbal k (Node R x a b) r in t 
-rbalS k (Node R x a (Node B y b c)) r = Node R y (lbal x (makeRed a) b) (Node B k c r)
-rbalS k l r                           = unsafeError "nein"
-
-{-@ lbal  :: k:a -> l:RBT a -> RBTN a {(bh l)} -> RBTN a {1 + (bh l)} @-}
-lbal k (Node R y (Node R x a b) c) r  = Node R y (Node B x a b) (Node B k c r)
-lbal k (Node R x a (Node R y b c)) r  = Node R y (Node B x a b) (Node B k c r)
-lbal k l r                            = Node B k l r
-
-{-@ rbal  :: k:a -> l:RBT a -> RBTN a {(bh l)} -> RBTN a {1 + (bh l)} @-}
-rbal x a (Node R y b (Node R z c d))  = Node R y (Node B x a b) (Node B z c d)
-rbal x a (Node R z (Node R y b c) d)  = Node R y (Node B x a b) (Node B z c d)
-rbal x l r                            = Node B x l r
-
----------------------------------------------------------------------------
----------------------------------------------------------------------------
----------------------------------------------------------------------------
-
-{-@ makeRed :: l:RBT a -> RBTN a {(bh l) - 1} @-}
-makeRed (Node B x l r) = Node R x l r
-makeRed _              = unsafeError "nein"
-
-{-@ makeBlack :: RBT a -> RBT a @-}
-makeBlack Leaf           = Leaf
-makeBlack (Node _ x l r) = Node B x l r
-
----------------------------------------------------------------------------
--- | Specifications -------------------------------------------------------
----------------------------------------------------------------------------
-
--- | Red-Black Trees
-
-{-@ type RBT a    = {v: RBTree a | (isBH v) }   @-}
-
-{-@ type RBTN a N = {v: RBT a  | (bh v) = N }   @-}
-
--- | Color of a tree
-
-{-@ measure isB        :: RBTree a -> Bool
-      isB Leaf         = false
-      isB (Node c x l r) = c == B 
-  @-}
-
--- | Black Height
-
-{-@ measure isBH        :: RBTree a -> Bool
-      isBH Leaf         = true
-      isBH (Node c x l r) = ((isBH l) && (isBH r) && (bh l) = (bh r))
-  @-}
-
-{-@ measure bh        :: RBTree a -> Int
-      bh Leaf         = 0
-      bh (Node c x l r) = (bh l) + (if (c == R) then 0 else 1) 
-  @-}
-
--------------------------------------------------------------------------------
--- Auxiliary Invariants -------------------------------------------------------
--------------------------------------------------------------------------------
-
-{-@ invariant {v: RBTree a | (Invs v)}        @-}
-{-@ predicate Invs V = (Inv3 V)               @-}
-{-@ predicate Inv3 V = 0 <= (bh V)            @-}
-
-{-@ invariant {v: Color | (v = R || v = B)}   @-}
-
-{-@ inv            :: RBTree a -> {v:RBTree a | (Invs v)}   @-}
-inv Leaf           = Leaf
-inv (Node c x l r) = Node c x (inv l) (inv r)
diff --git a/tests/pos/RBTree_ord.hs b/tests/pos/RBTree_ord.hs
deleted file mode 100644
--- a/tests/pos/RBTree_ord.hs
+++ /dev/null
@@ -1,148 +0,0 @@
-
-{-@ LIQUID "--no-termination"   @-}
-{-@ LIQUID "--no-totality"      @-}
-
-module RBTree_ord (add, remove, deleteMin, deleteMin') where
-
-import Language.Haskell.Liquid.Prelude
-
-data RBTree a = Leaf
-              | Node { nCol   :: Color
-                     , nKey   :: a
-                     , nLeft  :: !(RBTree a)
-                     , nRight :: !(RBTree a)
-                     }
-              deriving (Show)
-
-data Color = B -- ^ Black
-           | R -- ^ Red
-           deriving (Eq,Show)
-
----------------------------------------------------------------------------
--- | Add an element -------------------------------------------------------
----------------------------------------------------------------------------
-
-{-@ add :: (Ord a) => a -> ORBT a -> ORBT a @-}
-add x s = makeBlack (ins x s)
-
-{-@ ins :: (Ord a) => a -> ORBT a -> ORBT a @-}
-ins kx Leaf             = Node R kx Leaf Leaf
-ins kx s@(Node B x l r) = case compare kx x of
-                            LT -> let t = lbal x (ins kx l) r in t
-                            GT -> let t = rbal x l (ins kx r) in t
-                            EQ -> s
-ins kx s@(Node R x l r) = case compare kx x of
-                            LT -> Node R x (ins kx l) r
-                            GT -> Node R x l (ins kx r)
-                            EQ -> s
-
----------------------------------------------------------------------------
--- | Delete an element ----------------------------------------------------
----------------------------------------------------------------------------
-
-{-@ remove :: (Ord a) => a -> ORBT a -> ORBT a @-}
-remove x t = makeBlack (del x t)
-
-{-@ del              :: (Ord a) => a -> ORBT a -> ORBT a @-}
-del x Leaf           = Leaf
-del x (Node _ y a b) = case compare x y of
-   EQ -> append y a b
-   LT -> case a of
-           Leaf         -> Node R y Leaf b
-           Node B _ _ _ -> lbalS y (del x a) b
-           _            -> let t = Node R y (del x a) b in t
-   GT -> case b of
-           Leaf         -> Node R y a Leaf
-           Node B _ _ _ -> rbalS y a (del x b)
-           _            -> Node R y a (del x b)
-
-{-@ append  :: y:a -> ORBT {v:a | v < y} -> ORBT {v:a | y < v} -> ORBT a @-}
-append :: a -> RBTree a -> RBTree a -> RBTree a
-
-append _ Leaf r
-  = r
-
-append _ l Leaf
-  = l
-
-append piv (Node R lx ll lr) (Node R rx rl rr)
-  = case append piv lr rl of
-      Node R x lr' rl' -> Node R x (Node R lx ll lr') (Node R rx rl' rr)
-      lrl              -> Node R lx ll (Node R rx lrl rr)
-
-append piv (Node B lx ll lr) (Node B rx rl rr)
-  = case append piv lr rl of
-      Node R x lr' rl' -> Node R x (Node B lx ll lr') (Node B rx rl' rr)
-      lrl              -> lbalS lx ll (Node B rx lrl rr)
-
-append piv l@(Node B _ _ _) (Node R rx rl rr)
-  = Node R rx (append piv l rl) rr
-
-append piv l@(Node R lx ll lr) r@(Node B _ _ _)
-  = Node R lx ll (append piv lr r)
-
----------------------------------------------------------------------------
--- | Delete Minimum Element -----------------------------------------------
----------------------------------------------------------------------------
-
-{-@ deleteMin  :: ORBT a -> ORBT a @-}
-deleteMin (Leaf)         = Leaf
-deleteMin (Node _ x l r) = makeBlack t
-  where
-    (_, t)               = deleteMin' x l r
-
-
-{-@ deleteMin' :: k:a -> ORBT {v:a | v < k} -> ORBT {v:a | k < v} -> (a, ORBT a) @-}
-deleteMin' k Leaf r              = (k, r)
-deleteMin' x (Node R lx ll lr) r = (k, Node R x l' r)   where (k, l') = deleteMin' lx ll lr
-deleteMin' x (Node B lx ll lr) r = (k, lbalS x l' r )   where (k, l') = deleteMin' lx ll lr
-
----------------------------------------------------------------------------
--- | Rotations ------------------------------------------------------------
----------------------------------------------------------------------------
-
-lbalS k (Node R x a b) r              = Node R k (Node B x a b) r
-lbalS k l (Node B y a b)              = let t = rbal k l (Node R y a b) in t
-lbalS k l (Node R z (Node B y a b) c) = Node R y (Node B k l a) (rbal z b (makeRed c))
-lbalS k l r                           = unsafeError "nein"
-
-rbalS k l (Node R y b c)              = Node R k l (Node B y b c)
-rbalS k (Node B x a b) r              = let t = lbal k (Node R x a b) r in t
-rbalS k (Node R x a (Node B y b c)) r = Node R y (lbal x (makeRed a) b) (Node B k c r)
-rbalS k l r                           = unsafeError "nein"
-
-lbal k (Node R y (Node R x a b) c) r  = Node R y (Node B x a b) (Node B k c r)
-lbal k (Node R x a (Node R y b c)) r  = Node R y (Node B x a b) (Node B k c r)
-lbal k l r                            = Node B k l r
-
-rbal x a (Node R y b (Node R z c d))  = Node R y (Node B x a b) (Node B z c d)
-rbal x a (Node R z (Node R y b c) d)  = Node R y (Node B x a b) (Node B z c d)
-rbal x l r                            = Node B x l r
-
----------------------------------------------------------------------------
----------------------------------------------------------------------------
----------------------------------------------------------------------------
-
-makeRed (Node _ x l r) = Node R x l r
-makeRed Leaf           = unsafeError "nein"
-
-makeBlack Leaf           = Leaf
-makeBlack (Node _ x l r) = Node B x l r
-
----------------------------------------------------------------------------
--- | Specifications -------------------------------------------------------
----------------------------------------------------------------------------
-
--- | Ordered Red-Black Trees
-
-{-@ type ORBT a = RBTree <{\root v -> v < root }, {\root v -> v > root}> a @-}
-
--- | Binary Search Ordering
-
-{-@ data RBTree a  a -> Bool, r :: a -> a -> Bool>
-              = Leaf
-              | Node { nCol   :: Color
-                     , nKey   :: a
-                     , nLeft  :: RBTree  (a )
-                     , nRight :: RBTree  (a ) }
-  @-}
diff --git a/tests/pos/Range.hs b/tests/pos/Range.hs
deleted file mode 100644
--- a/tests/pos/Range.hs
+++ /dev/null
@@ -1,31 +0,0 @@
-module Range (prop_rng5, myfoldl) where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ invariant {v:Int| v >= 0} @-}
-
-range :: Int -> Int -> [Int]
-range i j = range' (j - i) i j
-
-range' :: Int -> Int -> Int -> [Int]
-range' d i j  
-  | i < j     = i : (range' (d-1) (i + 1) j)
-  | otherwise = []  
-
-
-sumTo = foldl (+) 0 . range 0 
-
-{-@ decrease lgo 2 @-}
---myfoldl :: (Int -> Int -> Int) -> Int -> [Int] -> Int
-myfoldl f z0 xs0 = lgo z0 xs0
-             where
-                lgo z []     =  z
-                lgo z (x:xs) = lgo (f z x) xs
-n = choose 0 
-m = choose 1
-
--- prop_rng1 = map (liquidAssertB . (0 <=)) $ range 0 n
--- prop_rng2 = map (liquidAssertB . (n <=)) $ range n 100
--- prop_rng3 = map (liquidAssertB . (n <=)) $ range n m
--- prop_rng4 = map (liquidAssertB . (<= m)) $ range n m 
-prop_rng5 = liquidAssertB (0 <= sumTo n)
diff --git a/tests/pos/Range1.hs b/tests/pos/Range1.hs
deleted file mode 100644
--- a/tests/pos/Range1.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module Range1 (single, prop_rng1) where
-
-import Language.Haskell.Liquid.Prelude
-
-mynil  = []
-
-single x = [x] 
-
-range :: Int -> Int -> [Int]
-range i j = [i]
-
-prop_rng1 n   = map (liquidAssertB . (0 <=)) $ range 0 n
diff --git a/tests/pos/RangeAdt.hs b/tests/pos/RangeAdt.hs
deleted file mode 100644
--- a/tests/pos/RangeAdt.hs
+++ /dev/null
@@ -1,37 +0,0 @@
-module RangeAdt (llen) where
-
-import Language.Haskell.Liquid.Prelude
-
-data L a = Nil | Con a (L a)
-{-@ data L [llen] a = Nil | Con { lHd ::a, lTl :: L a } @-}
-
-{-@ measure llen @-}
-{-@ llen :: L a -> Nat @-}
-llen :: L a -> Int 
-llen Nil = 0 
-llen (Con _ xs) = 1 + llen xs 
-
-range :: Int -> Int -> L Int
-range i j = range' (j-i) i j
-
-range' :: Int -> Int -> Int -> L Int
-range' d i j
-  | i < j  = i `Con` (range' (d-1) (i + 1) j)
-  | otherwise = Nil
-
-mapL f Nil        = Nil
-mapL f (Con x xs) = (f x) `Con` (mapL f xs)
-
-foldL f b Nil        = b
-foldL f b (Con x xs) = foldL f (f b x) xs
-
-sumTo = foldL plus 0 . range 0
-
-n = choose 0
-m = choose 1
-
-prop_rng1 = mapL (liquidAssertB . (0 <=)) $ range 0 n
-prop_rng2 = mapL (liquidAssertB . (n <=)) $ range n 100
-prop_rng3 = mapL (liquidAssertB . (n <=)) $ range n m
-prop_rng4 = mapL (liquidAssertB . (<= m)) $ range n m
-prop_rng5 = liquidAssertB (0 <= sumTo n)
diff --git a/tests/pos/ReWrite.hs b/tests/pos/ReWrite.hs
deleted file mode 100644
--- a/tests/pos/ReWrite.hs
+++ /dev/null
@@ -1,45 +0,0 @@
-module ReWrite where
-
-{-@ LIQUID "--rw-termination-check" @-}
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-{-@ infix ++ @-}
-
-import Prelude hiding ((++))
-
-
-{-@ 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 
--}
-
-
-{-@ rewrite assoc @-}
-{-@ 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 
-
-{-@ reflect lhs @-}
-lhs xs ys zs ws = ((xs ++ ys) ++ zs) ++ ws
-
-{-@ reflect rhs @-}
-rhs xs ys zs ws = xs ++ (ys ++ (zs ++ ws))
-
-{-@ rewriteWith assoc3 [assoc] @-} 
-{-@ assoc3 :: xs:[a] -> ys:[a] -> zs:[a] -> ws:[a]
-          -> { lhs xs ys zs ws = rhs xs ys zs ws } @-}
-assoc3 :: [a] -> [a] -> [a] -> [a] -> ()
-assoc3 xs ys zs ws = () 
-
-
-{-@ reflect ++ @-}
-(++)::[a] -> [a] -> [a]
-[]     ++ ys = ys 
-(x:xs) ++ ys = x:(xs ++ys)
diff --git a/tests/pos/ReWrite10.hs b/tests/pos/ReWrite10.hs
deleted file mode 100644
--- a/tests/pos/ReWrite10.hs
+++ /dev/null
@@ -1,31 +0,0 @@
-module ReWrite10 where
-
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-{-@ LIQUID "--rw-termination-check" @-}
-{-@ infix ++ @-}
-
-import Prelude hiding (length, (++))
-
-data N = S N | Z
-
-
-{-@ lazy    f @-}
-{-@ reflect f @-}
-f :: N -> N
-f x = g x
-
-{-@ lazy    g @-}
-{-@ reflect g @-}
-g (S x) = f x
-g Z     = Z
-
-{-@ rewrite diverge @-}
-{-@ assume diverge :: x : N -> { f x = g (S (S x)) } @-}
-diverge :: N -> ()
-diverge _ = ()
-
-{-@ proof :: x : N -> {g x = f x} @-}
-proof :: N -> ()
-proof _ = ()
-
diff --git a/tests/pos/ReWrite2.hs b/tests/pos/ReWrite2.hs
deleted file mode 100644
--- a/tests/pos/ReWrite2.hs
+++ /dev/null
@@ -1,54 +0,0 @@
--- Ensure that rewrites work with polymorphic types
-
-{-# LANGUAGE Rank2Types #-}
-
-{-@ LIQUID "--extensionality" @-}
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-{-@ LIQUID "--prune-unsorted" @-}
-{-@ LIQUID "--rw-termination-check" @-}
-module ReWrite2 where
-
-data OurMonad m = OurMonad {
-  bind :: forall a b. m a -> (a -> m b) -> m b,
-  return :: forall a.   a -> m a
-}
-
-{-@
-data OurMonad m = OurMonad {
-  bind   :: forall a b. m a -> (a -> m b) -> m b,
-  return :: forall a.   a -> m a
-}
-@-}
-
-{-@ reflect kleisli @-}
-{-@ kleisli :: om : OurMonad m
-            ->  f : (a -> m b)
-            ->  g : (b -> m c)
-            ->  x : a
-            -> {v : m c | v = kleisli om f g x} @-}
-kleisli :: OurMonad m -> (a -> m b) -> (b -> m c) -> a -> m c
-kleisli om f g x = bind om (f x) g
-
-{-@ kp :: om : OurMonad m
-            ->  f : (a -> m b)
-            ->  g : (b -> m c)
-            ->  x : a
-            -> {v : () | kleisli om f g x = bind om (f x) g} @-}
-kp :: OurMonad m -> (a -> m b) -> (b -> m c) -> a -> ()
-kp om f g x = ()
-
-{-@ reflect lhs @-}
-lhs om f g x = kleisli om f g x
-
-{-@ reflect rhs @-}
-rhs om f g x = bind om (f x) g
-
-{-@ rewriteWith mp [kp] @-}
-{-@ mp :: om : OurMonad m
-            ->  f : (a -> m b)
-            ->  g : (b -> m c)
-            ->  x : a
-            -> { lhs om f g x = rhs om f g x } @-}
-mp :: OurMonad m -> (a -> m b) -> (b -> m c) -> a -> ()
-mp om f g x = ()
diff --git a/tests/pos/ReWrite3.hs b/tests/pos/ReWrite3.hs
deleted file mode 100644
--- a/tests/pos/ReWrite3.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
--- Ensure that rewrites work with refinements
-module ReWrite3 where
-
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-{-@ LIQUID "--rw-termination-check" @-}
-{-@ infix ++ @-}
-
-import Prelude hiding ((++), drop, length)
-
-{-@ measure length @-}
-{-@ length :: [a] -> Int @-}
-length :: [a] -> Int
-length []     = 0
-length (_:xs) = 1 + length xs
-
-{-@ reflect drop @-}
-{-@ drop :: Int -> [a] -> [a] @-}
-drop :: Int -> [a] -> [a]
-drop n (x:xs) = drop (n - 1) xs
-drop _ []     = []
-drop 0 xs     = xs
-
-{-@ dropProof :: n : Int -> { xs : [a] | length xs >= n } -> { drop n xs = [] } @-}
-dropProof :: Int -> [a] -> ()
-dropProof _ []     = ()
-dropProof n (_:xs) = dropProof (n - 1) xs
-
-{-@ rewriteWith dropProof' [dropProof]  @-}
-{-@ dropProof' :: n : Int -> { xs : [a] | length xs >= n } -> { drop n xs = [] } @-}
-dropProof' :: Int -> [a] -> ()
-dropProof' _ _ = ()
-
diff --git a/tests/pos/ReWrite4.hs b/tests/pos/ReWrite4.hs
deleted file mode 100644
--- a/tests/pos/ReWrite4.hs
+++ /dev/null
@@ -1,29 +0,0 @@
--- Rewrites should work for identity equalities (i.e only diverging in one direction)
-module ReWrite4 where
-
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-{-@ LIQUID "--rw-termination-check" @-}
-{-@ infix ++ @-}
-
-import Prelude hiding ((++))
-
-data MyList a = MyNil | Cons a (MyList a)
-
-{-@ reflect ++ @-}
-(++)::MyList a -> MyList a -> MyList a
-MyNil       ++ ys = ys
-(Cons x xs) ++ ys = Cons x (xs ++ ys)
-
-
-{-@ concatIdent :: xs : MyList a -> { xs = xs ++ MyNil } @-}
-concatIdent :: MyList a -> ()
-concatIdent MyNil       = ()
-concatIdent (Cons _ xs) = concatIdent xs
-
-{-@ rewriteWith concatIdent' [concatIdent] @-}
-{-@ concatIdent' :: xs : MyList a -> { xs = xs ++ MyNil } @-}
-concatIdent' :: MyList a -> ()
-concatIdent' _ = ()
-
-
diff --git a/tests/pos/ReWrite5.hs b/tests/pos/ReWrite5.hs
deleted file mode 100644
--- a/tests/pos/ReWrite5.hs
+++ /dev/null
@@ -1,26 +0,0 @@
--- Rewrites should be applied recursively
-module ReWrite5 where
-
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-{-@ infix ++ @-}
-
-import Prelude hiding ((++))
-
-{-@ rewriteWith assoc3 [assoc] @-} 
-{-@ assoc3 :: xs:[a] -> ys:[a] -> zs:[a] -> ws:[a] -> vs:[a]
-          -> { xs ++ (ys ++ (zs ++ (ws ++ vs))) == (((xs ++ ys) ++ zs) ++ ws) ++ vs } @-}
-assoc3 :: [a] -> [a] -> [a] -> [a] -> [a] -> ()
-assoc3 xs ys zs ws vs = ()
-
-{-@ rewrite assoc @-}
-{-@ 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
-
-{-@ reflect ++ @-}
-(++)::[a] -> [a] -> [a]
-[]     ++ ys = ys
-(x:xs) ++ ys = x:(xs ++ys)
diff --git a/tests/pos/ReWrite6.hs b/tests/pos/ReWrite6.hs
deleted file mode 100644
--- a/tests/pos/ReWrite6.hs
+++ /dev/null
@@ -1,30 +0,0 @@
--- Should be able to apply multiple rewrite rules
-module ReWrite6 where
-
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-{-@ infix ++ @-}
-
-import Prelude hiding ((++))
-
-{-@ rewriteWith assoc2 [assoc, identity] @-} 
-{-@ 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:[a] -> ys:[a] -> zs:[a] 
-          -> { xs ++ (ys ++ zs) == (xs ++ ys) ++ zs } @-}
-assoc :: [a] -> [a] -> [a] -> ()
-assoc [] _ _       = ()
-assoc (_:xs) ys zs = assoc xs ys zs
-
-{-@ identity :: xs:[a] -> {xs = xs ++ [] }@-}
-identity []     = ()
-identity (x:xs) = identity xs
-
-{-@ reflect ++ @-}
-(++)::[a] -> [a] -> [a]
-[]     ++ ys = ys 
-(x:xs) ++ ys = x:(xs ++ys)
-
diff --git a/tests/pos/ReWrite7.hs b/tests/pos/ReWrite7.hs
deleted file mode 100644
--- a/tests/pos/ReWrite7.hs
+++ /dev/null
@@ -1,108 +0,0 @@
--- A more challenging example
-{-# LANGUAGE Rank2Types #-}
-
-{-@ LIQUID "--extensionality" @-}
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-{-@ LIQUID "--prune-unsorted" @-}
-
-
-module ReWrite7 where
-
-data MonadPlus m = MonadPlus {
-    mmonad  :: OurMonad m
-  , zero   :: forall a. m a
-  , choose :: forall a. m a -> m a -> m a
-}
-
-{-@ data MonadPlus m = MonadPlus {
-        mmonad  :: OurMonad m
-      , zero   :: forall a. m a
-      , choose :: forall a. m a -> m a -> m a
-    }
-  @-}
-
-
-data OurMonad m = OurMonad {
-  bind :: forall a b. m a -> (a -> m b) -> m b,
-  mreturn :: forall a.   a -> m a
-}
-
-{-@ data OurMonad m = OurMonad {
-      bind   :: forall a b. m a -> (a -> m b) -> m b,
-      mreturn :: forall a.   a -> m a
-    } 
-  @-}
-
-
-{-@ reflect const' @-}
-{-@ const' :: x : a -> y : b -> {v: a | v = x} @-}
-const' x _ = x
-
-{-@ reflect mbind @-}
-{-@ mbind ::
-         om : OurMonad m
-      -> x  : m a
-      -> f  : (a -> m b)
-      -> {v : m b | v == mbind om x f } @-}
-mbind :: OurMonad m -> m a -> (a -> m b) -> m b
-mbind (OurMonad b _) = b
-
-{-@ reflect mseq @-}
-{-@ mseq :: om : OurMonad m
-     -> ma : m a
-     -> mb : m b
-     -> {v : m b | v = mbind om ma (const' mb) } @-}
-mseq :: OurMonad m -> m a -> m b -> m b
-mseq om ma mb = mbind om ma (const' mb)
-
-{-@ guard :: mp : MonadPlus m -> p : Bool -> {v : m () | v = guard mp p } @-}
-{-@ reflect guard @-}
-guard :: MonadPlus m -> Bool -> m ()
-guard m True  = mreturn (mmonad m) ()
-guard m False = zero m
-
-{-@ reflect filt @-}
-filt :: MonadPlus m -> (a -> Bool) -> a -> m a
-filt mp p x = mseq (mmonad mp) (guard mp (p x)) (mreturn (mmonad mp) x)
-
-{-@ reflect lhs @-}
-lhs :: MonadPlus m -> Int -> Int -> ([Int], [Int]) -> m ([Int], [Int])
-lhs mp p x (ys, zs) =
-  mbind (mmonad mp) (filt mp (const' True) (ys, zs)) (mreturn (mmonad mp))
-  
-{-@ reflect kleisli @-}
-{-@ kleisli :: om : OurMonad m
-            ->  f : (a -> m b)
-            ->  g : (b -> m c)
-            ->  x : a
-            -> {v : m c | v = kleisli om f g x} @-}
-kleisli :: OurMonad m -> (a -> m b) -> (b -> m c) -> a -> m c
-kleisli om f g x = mbind om (f x) g
-
-{-@ reflect rhs @-}
-rhs :: MonadPlus m -> Int -> Int -> ([Int], [Int]) -> m ([Int], [Int])
-rhs mp p x =
-  kleisli (mmonad mp) (filt mp (const' True)) (mreturn (mmonad mp))
-  
-{-@ kp :: om : OurMonad m
-            ->  f : (a -> m b)
-            ->  g : (b -> m c)
-            ->  x : a
-            -> {v : () | kleisli om f g x = mbind om (f x) g} @-}
-kp :: OurMonad m -> (a -> m b) -> (b -> m c) -> a -> ()
-kp om f g x = ()
-  
-{-@ rewriteWith proof [kp] @-}
-{-@ proof ::
-           mp : MonadPlus m
-        ->  p : Int
-        ->  x : Int
-        ->  tupl : ([Int], [Int])
-        ->{ v : () |
-         lhs mp p x tupl =
-         rhs mp p x tupl
-      }
-@-}
-proof :: MonadPlus m -> Int -> Int -> ([Int], [Int]) -> ()
-proof mp p x (ys,zs) = ()
diff --git a/tests/pos/ReWrite8.hs b/tests/pos/ReWrite8.hs
deleted file mode 100644
--- a/tests/pos/ReWrite8.hs
+++ /dev/null
@@ -1,111 +0,0 @@
--- Rewrite an app argument
-{-# LANGUAGE Rank2Types #-}
-
-{-@ LIQUID "--extensionality" @-}
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-{-@ LIQUID "--prune-unsorted" @-}
-{-@ LIQUID "--rw-termination-check" @-}
-
-module ReWrite8 where
-
-import Prelude hiding (and)
-
-data MonadPlus m = MonadPlus {
-    monad  :: OurMonad m
-  , zero   :: forall a. m a
-  , choose :: forall a. m a -> m a -> m a
-}
-
-{-@ data MonadPlus m = MonadPlus {
-        monad  :: OurMonad m
-      , zero   :: forall a. m a
-      , choose :: forall a. m a -> m a -> m a
-    }
-  @-}
-
-{-@ reflect mmonad @-}
-{-@ mmonad :: mp : MonadPlus m -> {v : OurMonad m | v = mmonad mp }@-}
-mmonad = monad
-
-data OurMonad m = OurMonad {
-  bind   :: forall a b. m a -> (a -> m b) -> m b,
-  mreturn :: forall a.   a -> m a
-}
-
-{-@ data OurMonad m = OurMonad {
-      bind   :: forall a b. m a -> (a -> m b) -> m b,
-      mreturn :: forall a.   a -> m a
-    } 
-  @-}
-
-
-
-{-@ reflect mbind @-}
-{-@ mbind ::
-     om : OurMonad m
-     -> x  : m a
-     -> f  : (a -> m b)
-     -> {v : m b | v == mbind om x f } @-}
-mbind :: OurMonad m -> m a -> (a -> m b) -> m b
-mbind (OurMonad b _) = b
-
-{-@ guard :: mp : MonadPlus m -> p : Bool -> {v : m () | v = guard mp p } @-}
-{-@ reflect guard @-}
-guard :: MonadPlus m -> Bool -> m ()
-guard m True  = mreturn (mmonad m) ()
-guard m False = zero m
-
-{-@ reflect mseq @-}
-{-@ mseq :: om : OurMonad m
-      -> ma : m a
-      -> mb : m b
-      -> {v : m b | v = mbind om ma (const' mb) } @-}
-mseq :: OurMonad m -> m a -> m b -> m b
-mseq om ma mb = mbind om ma (const' mb)
-
-{-@ reflect const' @-}
-{-@ const' :: x : a -> y : b -> {v: a | v = x} @-}
-const' x _ = x
-
-{-@ assume guardSeq ::
-         mp : MonadPlus m
-      -> p  : Bool
-      -> q  : Bool
-      -> {v : () | guard mp (and p q)
-                 = mseq (mmonad mp) (guard mp p) (guard mp q) }
-@-}
-guardSeq :: MonadPlus m -> Bool -> Bool -> ()
-guardSeq _ _ _ = ()
-
-{-@ reflect and @-}
-{-@ and :: x : Bool -> y : Bool -> {z : Bool | z <=> x && y } @-}
-and :: Bool -> Bool -> Bool
-and True  y = y
-and False _ = False
-
-{-@ reflect step4Lambda @-}
-step4Lambda mp p x (ys, zs) =
-    mseq (mmonad mp)
-    (guard mp (and (x <= p) True))
-    (mreturn (mmonad mp) (x:ys, zs))
-
-{-@ reflect step5Lambda @-}
-step5Lambda mp p x (ys, zs) =
-    mseq (mmonad mp)
-      (mseq (mmonad mp) (guard mp (x <= p)) (guard mp True) )
-      (mreturn (mmonad mp) (x:ys, zs))
-    
-{-@ rewriteWith step4LambdaEqStep5Lambda [guardSeq] @-}
-{-@ step4LambdaEqStep5Lambda ::
-         mp : MonadPlus m
-      ->  p : Int
-      ->  x : Int
-      -> tupl : ([Int], [Int])
-      ->{ v : () |
-       step4Lambda mp p x tupl =
-       step5Lambda mp p x tupl
-      }
-@-}
-step4LambdaEqStep5Lambda :: MonadPlus m -> Int -> Int -> ([Int], [Int]) -> ()
-step4LambdaEqStep5Lambda mp p x (ys, zs) = ()
diff --git a/tests/pos/ReWrite9.hs b/tests/pos/ReWrite9.hs
deleted file mode 100644
--- a/tests/pos/ReWrite9.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-module ReWrite9 where
-
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-{-@ infix ++ @-}
-
-import Prelude hiding (length, (++))
-
-{-@ reflect ++ @-}
-(++)::[a] -> [a] -> [a]
-[]     ++ ys = ys 
-(x:xs) ++ ys = x:(xs ++ys)
-
-{-@ reflect length @-}
-length :: [a] -> Int
-length []     = 0
-length (_:xs) = 1 + length xs
-
-
-{-@ rewrite lengthSym @-}
-{-@ assume lengthSym :: xs : [a] -> ys : [a] -> { length (xs ++ ys) == length (ys ++ xs) }@-}
-lengthSym :: [a] -> [a] -> ()
-lengthSym _ _ = ()
diff --git a/tests/pos/RealProps.hs b/tests/pos/RealProps.hs
deleted file mode 100644
--- a/tests/pos/RealProps.hs
+++ /dev/null
@@ -1,37 +0,0 @@
--- Issue overload-div-int-real #579
-
--- TAG: class
-
-module RealProps where
-
-{-@ type Valid = {v:Bool | v } @-}
-
-{-@ mulAssoc :: Double -> Double -> Double -> Valid @-}
-mulAssoc :: Double -> Double -> Double -> Bool
-mulAssoc x y z = (x * y) * z == x * (y * z) 
-
-{-@ mulCommut :: Double -> Double -> Valid @-}
-mulCommut :: Double -> Double -> Bool
-mulCommut x y = x * y == y * x 
-
-{-@ mulId :: Double -> Valid @-}
-mulId :: Double -> Bool
-mulId x = x == 1 * x 
-
-{-@ mulDistr :: Double -> Double -> Double -> Valid @-}
-mulDistr :: Double -> Double -> Double -> Bool
-mulDistr x y z = x * (y + z)  == (x * y) + (x * z)
-
-{-@ divId :: Double -> Valid @-}
-divId :: Double -> Bool
-divId x = x / 1.0 == x
-
-{-@ inverse :: {v:Double | v != 0.0} -> Valid @-}
-inverse :: Double -> Bool
-inverse x = 1.0 == x * (1.0 / x)
-
-
-imports = ( recip, fromRational )
-
--- poop :: Ratio Integer 
--- poop = undefined 
diff --git a/tests/pos/Rebind.hs b/tests/pos/Rebind.hs
deleted file mode 100644
--- a/tests/pos/Rebind.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-{-# LANGUAGE RebindableSyntax #-}
-
-module Rebind () where
-
-import Prelude hiding ((>>), (>>=), return)
-
-(>>)   = plus
-return = id 
-
-{-@ plus :: x:Nat -> y:Nat -> {v:Nat | v = x + y} @-}
-plus :: Int -> Int -> Int 
-plus x y = x + y 
-
-{-@ test :: {v:Nat | v = 10} @-}
-test = do 
-  1
-  2
-  3
-  4
-
diff --git a/tests/pos/RecQSort.hs b/tests/pos/RecQSort.hs
deleted file mode 100644
--- a/tests/pos/RecQSort.hs
+++ /dev/null
@@ -1,31 +0,0 @@
--- TAG: abref 
-
-module RecQSort (qsort) where
-
-{-@ type OList a =  [a]<{\fld v -> (v >= fld)}>  @-}
-
-{-@ assert sort3 :: (Ord a) => [a] -> OList a @-}
-sort3 :: (Ord a) => [a] -> [a]
-sort3 = qsort 
-
-
-qsort:: (Ord a) => [a] -> [a]
-{-@ qsort:: (Ord a) => xs:[a] -> OList a / [(len xs), 0]@-}
-qsort []     = []
-qsort (x:xs) = qpart x xs [] []
-
-qpart  :: (Ord a) => a -> [a] -> [a] -> [a] -> [a]
-{-@ qpart  :: (Ord a) => x:a -> q:[a] -> r:[{v:a | (v < x)}] -> p:[{v:a |(v >= x)}] -> OList a / [((len p) + (len r) + (len q)), ((len q) + 1)]@-}
-qpart x [] rlt rge =
-    app x (qsort rlt) (x:qsort rge)
-qpart x (y:ys) rlt rge =
-    case compare x y of
-        GT -> qpart x ys (y:rlt) rge
-        _  -> qpart x ys rlt (y:rge)
-
-
-{-@ app :: Ord a => x:a -> (OList ({v:a | v < x})) -> (OList ({v:a| v >= x})) -> OList a @-} 
-app :: Ord a => a -> [a] -> [a] -> [a]
-app k []     ys = ys
-app k (x:xs) ys = x : (app k xs ys)
-
diff --git a/tests/pos/RecQSort0.hs b/tests/pos/RecQSort0.hs
deleted file mode 100644
--- a/tests/pos/RecQSort0.hs
+++ /dev/null
@@ -1,30 +0,0 @@
-module RecQSort0 () where
-
-{-@ type OList a =  [a]<{\fld v -> (v >= fld)}>  @-}
-
-{-@ assert sort3 :: (Ord a) => [a] -> OList a @-}
-sort3 :: (Ord a) => [a] -> [a]
-sort3 ls = qsort ls 
-  where d = (length ls) 
-
-
-qsort:: (Ord a) => [a] -> [a]
-{-@ qsort:: (Ord a) => xs:[a] -> OList a / [(len xs), 0] @-}
-qsort []     = []
-qsort (x:xs) = qpart x xs [] [] 
-
-qpart  :: (Ord a) => a -> [a] -> [a] -> [a] -> [a]
-{-@ qpart  :: (Ord a) => x:a -> q:[a] -> r:[{v:a | ((true) && (v < x))}] -> p:[{v:a | ((true) && (v >= x))}] -> OList a / [((len r)+(len q)+(len p)), ((len q)+1)]@-}
-qpart x [] rlt rge =
-    app x (qsort rlt) (x:qsort rge)
-qpart x (y:ys) rlt rge =
-    case compare x y of
-        GT -> qpart x ys (y:rlt) rge
-        _  -> qpart x ys rlt (y:rge)
-
-
-{-@ app :: Ord a => x:a -> (OList ({v:a | v < x})) -> (OList ({v:a| v >= x})) -> OList a @-} 
-app :: Ord a => a -> [a] -> [a] -> [a]
-app k []     ys = ys
-app k (x:xs) ys = x : (app k xs ys)
-
diff --git a/tests/pos/RecSelector.hs b/tests/pos/RecSelector.hs
deleted file mode 100644
--- a/tests/pos/RecSelector.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-module RecSelector where
-
-data F a = F {fx :: a, fy :: a, fzz :: a} | G {fx :: a}
-
-{-@ data F a = F {fx :: a, fy :: a, fzz :: a}
-             | G {fx :: a}
-  @-}
-
-{-@ fooG :: x:a -> {v : F a | (fx v) = x} @-}
-fooG :: a -> F a
-fooG x = G x
-
-{-@ foo :: x:a -> {v : F a | (fx v) = x} @-}
-foo :: a -> F a
-foo x = F x x x
diff --git a/tests/pos/Rec_annot_go.hs b/tests/pos/Rec_annot_go.hs
deleted file mode 100644
--- a/tests/pos/Rec_annot_go.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Rec_annot_go () where
-
-import Language.Haskell.Liquid.Prelude (liquidAssert)
-
-{-@ invariant {v:Int | v >= 0} @-}
-
-{-@ decrease go 1 @-}
-loop :: Int -> Int -> a -> (Int -> a -> a) -> a 
-loop lo hi base f = go (hi-lo) base lo
-  where
-    go (d::Int) acc i     
-      | i /= hi   = go (d-1) (f i acc) (i + 1)
-      | otherwise = acc
-
-poo = loop 0 10 0 (+)
-
diff --git a/tests/pos/Record0.hs b/tests/pos/Record0.hs
deleted file mode 100644
--- a/tests/pos/Record0.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-{-@ LIQUID "--exact-data-cons" @-}
-
-module Record0 () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ data LL a = BXYZ { size  :: {v: Int | v > 0 }
-                     , elems :: {v: [a] | (len v) = size }
-                     }
-  @-}
-
-data LL a = BXYZ { size  :: Int
-                 , elems :: [a]
-                 }
-
-{-@ mk :: a -> Int -> LL a @-}
-mk x n | n > 0     = BXYZ n (clone x n)
-       | otherwise = BXYZ 1 [x]
-
-{-@ bk :: LL a -> {v: Int | v > 0} @-}
-bk (BXYZ n xs) = liquidAssert (length xs == n) n
-
-{-@ clone :: x:a -> n:Int -> {v:[a]| (len v) = n} @-}
-clone :: a -> Int -> [a]
-clone = unsafeError "FOO"
diff --git a/tests/pos/Record1.hs b/tests/pos/Record1.hs
deleted file mode 100644
--- a/tests/pos/Record1.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-module Record1 (trim) where
-
-data Map k a  = Tip
-
-{-@ data Map k a  k -> Bool>
-         = Tip
-  @-}
-
-{-@ measure isBin @-}
-isBin :: Map k a -> Bool
-isBin Tip = False
-
-trim :: Map k a
-trim = undefined 
-
diff --git a/tests/pos/RecordSelectorError.hs b/tests/pos/RecordSelectorError.hs
deleted file mode 100644
--- a/tests/pos/RecordSelectorError.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-module RecordSelectorError where
-
-data F a b = F {fx :: a, fy :: b} | G {fx :: a}
-{-@ data F a b = F {fx :: a, fy :: b} | G {fx :: a} @-}
-
-{-@ measure isF @-}
-isF :: F a b -> Bool
-isF (F x y) = True 
-isF (G x)   = False
-
--- Record's selector type it defaulted to true as imported
-{-@ fy  :: {v:F a b | isF v} -> b @-}
-{-@ bar :: {v:F a b | isF v} -> b @-}
-bar :: F a b  -> b
-bar = fy
-
-
diff --git a/tests/pos/Recursion0.hs b/tests/pos/Recursion0.hs
deleted file mode 100644
--- a/tests/pos/Recursion0.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module Recursion0 where
-
-
-{-@ total :: Nat -> Nat @-}
-total :: Int -> Int 
-total 0 = 0
-total n = 1 + total (n-1)
-
diff --git a/tests/pos/Reduction.hs b/tests/pos/Reduction.hs
deleted file mode 100644
--- a/tests/pos/Reduction.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-{-@ LIQUID "--higherorder"    @-}
-
-module Reduction where
-
-{-@ reduction :: forall
 Bool -> Bool>. 
-                 f:(a -> a) 
-              -> (x:a -> Bool
) 
-              -> y:a -> Bool
  @-}
-reduction :: (a -> a) -> (a -> Bool) -> a -> Bool
-reduction f thm y = thm (f y)              
-
diff --git a/tests/pos/RefinedADTs.hs b/tests/pos/RefinedADTs.hs
deleted file mode 100644
--- a/tests/pos/RefinedADTs.hs
+++ /dev/null
@@ -1,38 +0,0 @@
-{-# LANGUAGE GADTs #-}
-
-module RefinedADTs where
-
-{-@ LIQUID "--no-termination" @-}
-
-{-@ 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 
 Bool> where
-        Nil2  :: List2 a b
-        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
diff --git a/tests/pos/Reflect0.hs b/tests/pos/Reflect0.hs
deleted file mode 100644
--- a/tests/pos/Reflect0.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-{-@ LIQUID "--higherorder"     @-}
-
-module Reflect0 where
-
-{-@ fib :: n:Nat -> Nat @-}
-{-@ reflect fib @-}
-fib :: Int -> Int
-fib n
-  | n == 0    = 0
-  | n == 1    = 1
-  | otherwise = fib (n-1) + fib (n-2)
-
-
-{-@ goo :: Nat -> Nat @-}
-goo :: Int -> Int
-goo x = fib x
diff --git a/tests/pos/ReflectAlias.hs b/tests/pos/ReflectAlias.hs
deleted file mode 100644
--- a/tests/pos/ReflectAlias.hs
+++ /dev/null
@@ -1,11 +0,0 @@
--- See LH #1086 
-
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module ReflectAlias where
-
-type Val = Int
-
-{-@ reflect poo @-}
-poo :: Int -> Int
-poo y = (\(x :: Val) -> x + 1) y
diff --git a/tests/pos/ReflectBooleanFunctions.hs b/tests/pos/ReflectBooleanFunctions.hs
deleted file mode 100644
--- a/tests/pos/ReflectBooleanFunctions.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-{-@ LIQUID "--exactdc"      @-}
-{-@ LIQUID "--higherorder"  @-}
-module ReflectBooleanFunctions where
-
-
-{-@ reflect foo @-}
-foo :: (Int -> Bool) -> (Int -> Bool) -> Bool 
-foo f g = (f 1) && (g 1)
diff --git a/tests/pos/ReflectMutual.hs b/tests/pos/ReflectMutual.hs
deleted file mode 100644
--- a/tests/pos/ReflectMutual.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-{-@ LIQUID "--exactdc" @-}
-
-module ReflectMutual where
-
-data Foo = Foo {getFoo :: Int}
-{-@ data Foo [fromFoo] = Foo {getFoo :: Nat} @-}
-
-{-@ measure fromFoo @-}
-fromFoo :: Foo -> Int 
-fromFoo (Foo i) = i 
-
-{-@ reflect foo1 @-}
-foo1 :: Foo -> Int 
-foo1 (Foo i) | i == 0 = 0 
-foo1 (Foo n) = foo2 (Foo (n-1))
-
-{-@ reflect foo2 @-}
-foo2 :: Foo -> Int 
-foo2 (Foo x) | x <= 1 = x
-foo2 (Foo n) = foo1 (Foo (n-1))
diff --git a/tests/pos/RelativeComplete.hs b/tests/pos/RelativeComplete.hs
deleted file mode 100644
--- a/tests/pos/RelativeComplete.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-module RelativeComplete where
-
-{-@ LIQUID "--no-termination" @-}
-
--- Here p and q of `app` will be instantiated to 
--- p , q := \v -> i <= v
-
-main i = app (check i) i
-
-{-@ check :: x:Int -> {v:Int | x <= v} -> () @-}
-check :: Int -> Int -> ()
-check = undefined
-
-
-{-@ app :: forall 
 Bool, q :: Int -> Bool>. 
-           {Int <: Int
}
-           {x::Int |- {v:Int| v = x + 1} <: Int}
-           (Int
 -> ()) -> x:Int -> () @-}
-app :: (Int -> ()) -> Int -> ()
-app f x = if p x then app f (x + 1) else f x
-
-
-p :: a -> Bool
-{-@ p :: a -> Bool @-}
-p = undefined
diff --git a/tests/pos/Repeat.hs b/tests/pos/Repeat.hs
deleted file mode 100644
--- a/tests/pos/Repeat.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-module Repeat where
-import Prelude hiding (repeat, take)
-
-data L a = N | C a (L a)
-
-{-@
-data L a 
 Bool>
-  = N
-  | C (lHd :: a) (lTl :: L 
 a <
>)
-@-}
-
-{-@ measure isCons @-} 
-isCons :: L a -> Bool
-isCons N       = False
-isCons (C a l) = True
-
-{-@ type Stream a = {v: L <{\v -> (isCons v)}> a | (isCons v)} @-}
-
-{-@ lazy repeat @-}
-{-@ repeat :: a -> Stream a @-}
-repeat :: a -> L a
-repeat x = C x (repeat x)
-
-{-@ take :: Nat -> Stream a -> L a @-}
-take :: Int -> L a -> L a
-take 0 _           = N
-take n ys@(C x xs) = x `C` take (n-1) xs
diff --git a/tests/pos/RepeatHigherOrder.hs b/tests/pos/RepeatHigherOrder.hs
deleted file mode 100644
--- a/tests/pos/RepeatHigherOrder.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-
--- TAG: bound 
--- TAG: absref 
-
-module RepeatHigherOrder where
-
-import Prelude hiding (repeat, succ)
-import Language.Haskell.Liquid.Prelude
-
-repeat :: Int -> (a -> a) -> a -> a
-goal   :: Int -> Int
-     
-{-@ bound step @-}
-step :: (a -> a -> Bool) -> (Int -> a -> Bool) -> Int -> a -> a -> Bool
-step pf pr = \ i x x' -> pr (i - 1) x ==> pf x x' ==> pr i x'
-
--- This syntax is not yet supported in liquidhaskell-8
-{- repeat :: forall a  a -> Bool, r :: Int -> a -> Bool>.
-                (Step a f r) => 
-                 n:Nat -> (y:a -> a) -> a -> a
-  @-}
-
-
-{-@ repeat :: forall a  a -> Bool, r :: Int -> a -> Bool>.
-                {i::Int, x::a|- a <:a }
-                 n:Nat -> (y:a -> a) -> a -> a
-  @-}
-repeat 0 _ x = x
-repeat n f x = repeat (n - 1) f (f x)
-
-{-@ goal :: n:Nat -> {r:Nat | n <= r} @-}
-goal n = repeat n (+ 1) 0
-
diff --git a/tests/pos/Resolve.hs b/tests/pos/Resolve.hs
deleted file mode 100644
--- a/tests/pos/Resolve.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module Resolve where
-
-import qualified ResolveA as RA
-import qualified ResolveB as RB
-
-
-{-@ x :: {v:RB.Bar | ((v = RB.B) && (NotA v))} @-}
-x = RB.B
-
-zebra :: Int
-zebra = 12 
diff --git a/tests/pos/ResolveA.hs b/tests/pos/ResolveA.hs
deleted file mode 100644
--- a/tests/pos/ResolveA.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-module ResolveA where
-
-import qualified ResolveB as RB
-import qualified ResolveB
-
-{-@ measure getFooA :: Foo -> Int
-      getFooA (Foo x) = x
-  @-}
-
-data Foo = Foo Int
-
-y = RB.Foo 1
-z = RB.A 
-{-@ qualif NotA(v:RB.Bar): (notA v) @-}
-
-{-@ measure notA :: RB.Bar -> Bool
-      notA RB.A = false
-      notA RB.B = true
-      notA RB.C = false
-  @-}
-
-{-@ predicate NotA V = V != RB.A @-}
diff --git a/tests/pos/ResolveALib.hs b/tests/pos/ResolveALib.hs
deleted file mode 100644
--- a/tests/pos/ResolveALib.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-module ResolveA where
-
-import qualified ResolveBLib as RB
-import qualified ResolveBLib
-
-{-@ measure getFooA :: Foo -> Int
-      getFooA (Foo x) = x
-  @-}
-
-data Foo = Foo Int
-
-y = RB.Foo 1
-z = RB.A 
-{-@ qualif NotA(v:RB.Bar): (notA v) @-}
-
-{-@ measure notA :: RB.Bar -> Bool
-      notA RB.A = false
-      notA RB.B = true
-      notA RB.C = false
-  @-}
-
-{-@ predicate NotA V = V != RB.A @-}
diff --git a/tests/pos/ResolveB.hs b/tests/pos/ResolveB.hs
deleted file mode 100644
--- a/tests/pos/ResolveB.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-module ResolveB where
-
-{-@ measure getFoo :: Foo -> Int
-      getFoo (Foo x) = x
-  @-}
-
-data Foo = Foo Int
-
-data Bar = A | B | C
diff --git a/tests/pos/ResolveBLib.hs b/tests/pos/ResolveBLib.hs
deleted file mode 100644
--- a/tests/pos/ResolveBLib.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-module ResolveBLib where
-
-{-@ measure getFoo :: Foo -> Int
-      getFoo (Foo x) = x
-  @-}
-
-data Foo = Foo Int
-
-data Bar = A | B | C
diff --git a/tests/pos/ResolvePred.hs b/tests/pos/ResolvePred.hs
deleted file mode 100644
--- a/tests/pos/ResolvePred.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-{-@ LIQUID "--pruneunsorted" @-}
-
-module ResolvePred (myFold, llen) where
-
-{-@ data L [llen] = C (h :: Int) (t :: L) | N @-}
-
-data L = C Int L | N
-
-{-@ myFold :: forall  b -> Bool>.
-              (as:L -> a:Int -> b -> b)
-           -> b
-           -> l:L
-           -> b
-  @-}
-myFold f z = go
-  where
-    go N       = z
-    go (C a as) = f as a (go as)
-
-{-@ measure llen @-}
-llen :: L -> Int
-{-@ llen :: L -> Nat @-}
-llen N      = 0
-llen (C _ xs) = 1 + (llen xs)
-
-{-@ qualif PappL(v:a, p:Pred a L , a:int, as:L ):
-        papp2(p, v, C(a, as))
-  @-}
diff --git a/tests/pos/Rest.hs b/tests/pos/Rest.hs
deleted file mode 100644
--- a/tests/pos/Rest.hs
+++ /dev/null
@@ -1,227 +0,0 @@
-{-@ LIQUID "--exact-data-cons" @-}
-{-@ LIQUID "--ple" @-}
-
-module Rest where
-
-import Language.Haskell.Liquid.ProofCombinators
-import Prelude hiding (length, max)
-
--- | The type of a Stitch expression
-data Ty = TInt
-        | TBool
-        | TFun { funArgTy :: Ty, funResTy :: Ty }
-  deriving (Show, Eq)
-
-{-@
-data Ty = TInt
-        | TBool
-        | TFun { funArgTy :: Ty, funResTy :: Ty }
-@-}
-
-{-@ measure isFunTy @-}
-isFunTy :: Ty -> Bool
-isFunTy (TFun _ _) = True
-isFunTy _ = False
-
-
--- | An @ArithOp ty@ is an operator on numbers that produces a result
--- of type @ty@
-data ArithOp
-  = Plus
-  | Minus
-  | Times
-  | Divide
-  | Mod
-  | Less
-  | LessE
-  | Greater
-  | GreaterE
-  | Equals
-  deriving (Eq, Show)
-
--- | Extract the result type of an Op
-{-@ measure arithType @-}
-arithType :: ArithOp -> Ty
-arithType Plus     = TInt
-arithType Minus    = TInt
-arithType Times    = TInt
-arithType Divide   = TInt
-arithType Mod      = TInt
-arithType Less     = TBool
-arithType LessE    = TBool
-arithType Greater  = TBool
-arithType GreaterE = TBool
-arithType Equals   = TBool
-
-{-@ invariant { op:ArithOp | arithType op = TBool || arithType op = TInt } @-}
-
-
-{-@ type Nat = { v : Int | v >= 0 } @-}
-type Nat = Int
-
-{-@ inline max @-}
-max :: Ord a => a -> a -> a
-max a b = if a > b then a else b
-
-{-@ inline minus @-}
-minus :: Nat -> Nat -> Nat
-minus a b = max 0 (a - b)
-
-{-@
-reflect elemAt
-elemAt :: n : Nat -> { xs:[a] | length xs > n } -> a
-@-}
-elemAt :: Nat -> [a] -> a
-elemAt 0 (x:_) = x
-elemAt i (_:xs) = elemAt (i-1) xs
-
-{-@
-measure length
-length :: xs : [a] -> Nat
-@-}
-length :: [a] -> Nat
-length [] = 0
-length (_:xs) = 1 + length xs
-
-{-@
-reflect append
-append ::
-  xs : [a] ->
-  ys : [a] ->
-  { zs:[a] | length zs == length xs + length ys }
- @-}
-append :: [a] -> [a] -> [a]
-append [] ys = ys
-append (x:xs) ys = x : append xs ys
-
-{-@
-appendLengh
-  :: xs : [a]
-  -> ys : [a]
-  -> { length (append xs ys) == length xs + length ys}
-@-}
-appendLengh :: [a] -> [a] -> ()
-appendLengh xs ys = () ? append xs ys
-
-{-@
-elemAtThroughAppend
-  :: i : Nat
-  -> xs : { xs:[a] | i < length xs }
-  -> ys : [a]
-  -> { elemAt i (append xs ys) = elemAt i xs }
-@-}
-elemAtThroughAppend :: Nat -> [a] -> [a] -> ()
-elemAtThroughAppend 0 (_:_) ys = ()
-elemAtThroughAppend i (_:xss) ys = elemAtThroughAppend (i - 1) xss ys
-
-{-@
-predicate WellTyped E CTX = checkBindings CTX E && numFreeVarsExp E <= length CTX
-type WellTypedExp CTX = { e : Exp | WellTyped e CTX }
-type FunExp = { e : Exp | isFunTy (exprType e) }
-type ExpT T = { e : Exp | T = exprType e }
-data Exp
-  = Var Ty Nat
-  | Lam Ty Exp
-  | App (e1 :: FunExp) (ExpT (funArgTy (exprType e1)))
-  | Let Exp Exp
-  | Arith (ExpT TInt) ArithOp (ExpT TInt)
-  | Cond (ExpT TBool) (a :: Exp) (ExpT (exprType a))
-  | Fix ({ e:FunExp | funArgTy (exprType e) = funResTy (exprType e) })
-  | IntE Int
-  | BoolE Bool
-@-}
-
--- | Checked expression
-data Exp
-  = Var Ty Nat
-  | Lam Ty Exp
-  | App Exp Exp
-  | Let Exp Exp
-  | Arith Exp ArithOp Exp
-  | Cond Exp Exp Exp
-  | Fix Exp
-  | IntE Int
-  | BoolE Bool
-  deriving Show
-
-{-@ measure exprType @-}
-exprType :: Exp -> Ty
-exprType (Var ty _) = ty
-exprType (Lam ty e) = TFun ty (exprType e)
-exprType (App e1 _) = funResTy (exprType e1)
-exprType (Let _ e2) = exprType e2
-exprType (Arith _ op _) = arithType op
-exprType (Cond _ e2 _) = exprType e2
-exprType (Fix e) = funResTy (exprType e)
-exprType (IntE _) = TInt
-exprType (BoolE _) = TBool
-
--- | Check that all occurrences of a variable have the given type
-{-@
-reflect checkBindings
-checkBindings
-  :: ctx : [Ty]
-  -> { e : Exp | numFreeVarsExp e <= length ctx }
-  -> Bool
-@-}
-checkBindings :: [Ty] -> Exp -> Bool
-checkBindings ctx (Var vty i) = elemAt i ctx == vty
-checkBindings ctx (Lam t e) = checkBindings (t:ctx) e
-checkBindings ctx (App e1 e2) = checkBindings ctx e1 && checkBindings ctx e2
-checkBindings ctx (Let e1 e2) = checkBindings ctx e1 && checkBindings (exprType e1 : ctx) e2
-checkBindings ctx (Arith e1 _ e2) = checkBindings ctx e1 && checkBindings ctx e2
-checkBindings ctx (Cond e1 e2 e3) = checkBindings ctx e1 && checkBindings ctx e2 && checkBindings ctx e3
-checkBindings ctx (Fix e) = checkBindings ctx e
-checkBindings _ (IntE _) = True
-checkBindings _ (BoolE _) = True
-
-{-@
-rewriteWith aClosedExpIsValidInAnyContext [appendLengh]
-aClosedExpIsValidInAnyContext
-  :: ctx0 : [Ty]
-  -> ctx1 : [Ty]
-  -> e : Exp
-  -> { WellTyped e ctx0 <=>
-       WellTyped e (append ctx0 ctx1) && numFreeVarsExp e <= length ctx0
-     }
-@-}
-aClosedExpIsValidInAnyContext :: [Ty] -> [Ty] -> Exp -> ()
-aClosedExpIsValidInAnyContext ctx0 ctx1 e = case e of
-  Var _ i ->
-    if i < length ctx0 then elemAtThroughAppend i ctx0 ctx1
-    else ()
-  Lam ty body ->
-    aClosedExpIsValidInAnyContext (ty:ctx0) ctx1 body
-  App e1 e2 ->
-    aClosedExpIsValidInAnyContext ctx0 ctx1 e1 ? aClosedExpIsValidInAnyContext ctx0 ctx1 e2
-  Let e1 e2 ->
-    aClosedExpIsValidInAnyContext ctx0 ctx1 e1 ? aClosedExpIsValidInAnyContext (exprType e1 : ctx0) ctx1 e2
-  Arith e1 _ e2 ->
-    aClosedExpIsValidInAnyContext ctx0 ctx1 e1 ? aClosedExpIsValidInAnyContext ctx0 ctx1 e2
-  Cond e1 e2 e3 ->
-    aClosedExpIsValidInAnyContext ctx0 ctx1 e1
-      ? aClosedExpIsValidInAnyContext ctx0 ctx1 e2
-      ? aClosedExpIsValidInAnyContext ctx0 ctx1 e3
-  Fix body ->
-    aClosedExpIsValidInAnyContext ctx0 ctx1 body
-  IntE _ -> ()
-  BoolE _ -> ()
-
-{-@
-measure numFreeVarsExp
-numFreeVarsExp :: Exp -> Nat
-@-}
-numFreeVarsExp :: Exp -> Nat
-numFreeVarsExp (Var _ v) = v + 1
-numFreeVarsExp (Lam _ body) = minus (numFreeVarsExp body) 1
-numFreeVarsExp (App e1 e2) = max (numFreeVarsExp e1) (numFreeVarsExp e2)
-numFreeVarsExp (Let e1 e2) =
-    max (numFreeVarsExp e1) (minus (numFreeVarsExp e2) 1)
-numFreeVarsExp (Arith e1 _ e2) = max (numFreeVarsExp e1) (numFreeVarsExp e2)
-numFreeVarsExp (Cond e1 e2 e3) =
-    max (max (numFreeVarsExp e1) (numFreeVarsExp e2)) (numFreeVarsExp e3)
-numFreeVarsExp (Fix body) = numFreeVarsExp body
-numFreeVarsExp (IntE _) = 0
-numFreeVarsExp (BoolE _) = 0
-
-
diff --git a/tests/pos/Risers.hs b/tests/pos/Risers.hs
deleted file mode 100644
--- a/tests/pos/Risers.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module Risers () where
-
-{-@ predicate NonNull X = ((len X) > 0) @-}
-
-{-@ risers :: (Ord a) => zs:[a] -> {v: [[a]] | ((NonNull zs) => (NonNull v)) } @-} 
-risers []        
-  = []
-risers [x]       
-  = [[x]]
-risers (x:y:etc) 
-  = if x <= y then (x:s):ss else [x]:(s:ss)
-    where (s:ss) = risers (y:etc)
diff --git a/tests/pos/Rta.hs b/tests/pos/Rta.hs
deleted file mode 100644
--- a/tests/pos/Rta.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-module Rta where
-
-{-@ predicate Mouse X Y = X > Y @-}
-
-{-@ inline mickey @-}
-mickey :: (Ord a) => a -> a -> Bool
-mickey x y = x > y
-
-{-@ type PosInline    a N = {v:a | mickey v N} @-}
-
-{-@ type PosPredicate a N = {v:a | Mouse v N} @-}
-
-{-@ incrI :: PosInline Int 0 -> PosInline Int 0 @-}
-incrI :: Int -> Int
-incrI x = x + 1
-
-{-@ incrP :: PosPredicate Int 0 -> PosPredicate Int 0 @-}
-incrP :: Int -> Int
-incrP x = x + 1
diff --git a/tests/pos/SafePartialFunctions.hs b/tests/pos/SafePartialFunctions.hs
deleted file mode 100644
--- a/tests/pos/SafePartialFunctions.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-module SafePartialFunctions (gotail, gohead) where
-
-import Prelude hiding (fromJust, tail, head)
-
-import Data.Maybe
-
-
-{-@ fromJust :: {v:Maybe a | isJust v} -> a @-}
-fromJust :: Maybe a -> a
-fromJust (Just a) = a
-
-{-@ tail :: {v:[a] | len v > 0} -> [a] @-}
-tail :: [a] -> [a]
-tail (x:xs) = xs
-
-{-@ head :: {v:[a] | len v > 0} -> a @-}
-head :: [a] -> a
-head (x:xs) = x
-
--- USERS
-
-gotail xs = case xs of
-             [] -> []
-             y : ys -> tail xs
-
-{-@ gohead :: [{v:[a] | len v > 0}] -> [a] @-}
-gohead :: [[a]] -> [a]
-gohead xs = map head xs
diff --git a/tests/pos/Scanr.hs b/tests/pos/Scanr.hs
deleted file mode 100644
--- a/tests/pos/Scanr.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module Scanr () where
-
-{-@ scanrr  :: (a -> b -> b) -> b -> xs:[a] -> {v: [b] | len v = 1 + len xs } @-}
--- scanrr             :: (a -> b -> b) -> b -> [a] -> [b]
-scanrr _ q0 []     =  [q0]
-scanrr f q0 (x:xs) =  f x q : qs
-                      where qs@(q:_) = scanrr f q0 xs 
diff --git a/tests/pos/SelfList.hs b/tests/pos/SelfList.hs
deleted file mode 100644
--- a/tests/pos/SelfList.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-module SelfList () where
-
-{-@ LIQUID "--bscope" @-}
-
-import Data.Set (Set(..)) 
-
-{-@ include  @-}
-
-{-@ invariant {v0:[{v: a | (Set_mem v (listElts v0))}] | true } @-}
-
-{-@ type IList a  = {v0: [{v:a | (Set_mem v (listElts v0))}] | true } @-}
-
-{-@ moo :: [a] -> IList a @-}
-moo []     = [] 
-moo (_:xs) = xs
-
-goo []     = [] 
-goo (_:xs) = xs
-
-{-@ poo :: IList Int @-}
-poo = goo xs
-  where 
-    xs :: [Int]
-    xs = [2,1,3,2]
-
-
diff --git a/tests/pos/SimplerNotation.hs b/tests/pos/SimplerNotation.hs
deleted file mode 100644
--- a/tests/pos/SimplerNotation.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module SimplerNotation () where
-
-{-@ myDiv :: x:Int -> y:{Int | y != 0} -> {v:Int | v = x / y} @-}
-myDiv :: Int -> Int -> Int
-myDiv = div
diff --git a/tests/pos/SimplifyTup00.hs b/tests/pos/SimplifyTup00.hs
deleted file mode 100644
--- a/tests/pos/SimplifyTup00.hs
+++ /dev/null
@@ -1,31 +0,0 @@
-
--- See: https://github.com/ucsd-progsys/liquidhaskell/pull/752
-
-module SimplifyTup00 (mkSessData) where
-
-mkSessData :: TcpEndPoint -> Bool
-mkSessData = isSrcTCP
-
-{- With the safeSimplifyPatTuple rewrite rule,
-   the body of the below expression become a
-   case with type (Port, Port) because the
-   case is becoming the outer-most
-   body expression
--}
-
-isSrcTCP :: TcpEndPoint -> Bool
-isSrcTCP x = (addrTE x, portTE x) == (srcIP, srcPort)
- where
-   (PP (PortId srcIP _) (PortId srcPort _)) = idTCP x
-
-
-data TCPId = PP PortId PortId
-data PortId = PortId Port Port
-
-data TcpEndPoint = TcpEndPoint { addrTE :: Port, portTE :: Port }
-
-
-data Port = P deriving (Eq)
-
-idTCP :: TcpEndPoint -> TCPId --  (PortId, PortId)
-idTCP tcp = undefined
diff --git a/tests/pos/SingletonLists.hs b/tests/pos/SingletonLists.hs
deleted file mode 100644
--- a/tests/pos/SingletonLists.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-module SingletonLists where
-
-{-@ LIQUID "--higherorder" @-}
-
-{-@ infix : @-}
-
-empList :: ([a] -> a) -> ()
-{-@ empList :: f:([a] -> a) -> {f [] == f []} @-}
-empList _ = ()
-
-
-singletonList :: ([a] -> a) -> a -> ()
-{-@ singletonList :: f:([a] -> a) -> x:a -> {f [x] == f [x]} @-}
-singletonList _ _ = ()
-
-singletonListC :: ([a] -> a) -> a -> ()
-{-@ singletonListC :: f:([a] -> a) -> x:a -> {f (x:[]) == f [x]} @-}
-singletonListC _ _ = ()
-
diff --git a/tests/pos/Solver.hs b/tests/pos/Solver.hs
deleted file mode 100644
--- a/tests/pos/Solver.hs
+++ /dev/null
@@ -1,106 +0,0 @@
-
-{-@ LIQUID "--reflection"     @-}
-{-@ LIQUID "--ple"            @-}
-{-@ LIQUID "--pruneunsorted"  @-}
-{-@ LIQUID "--no-termination" @-}
-{-@ LIQUID "--short-names"    @-}
-
-module Solver where
-
-import Data.Tuple
-import Language.Haskell.Liquid.Prelude ((==>))
-import Data.List (nub)
-
--- | Formula
-
-type Var     = Int
-data Lit     = Pos Var | Neg Var
-data Val     = VTrue   | VFalse
-type Clause  = [Lit]
-type Formula = [Clause]
-
--- | Assignment
-
-type Asgn = [(Var, Val)]
-
--- | Top-level "solver"
-
-{-@ solve :: f:Formula -> Maybe {a:Asgn | sat a f} @-}
-solve   :: Formula -> Maybe Asgn
-solve f = find (\a -> sat a f) (asgns f)
-
-{-@ find :: forall 
 Bool, w :: a -> Bool -> Bool>.
-            {y::a, b::{v:Bool | v} |- {v:a | v == y} <: a
}
-            (x:a -> Bool) -> [a] -> Maybe (a
) @-}
-find :: (a -> Bool) -> [a] -> Maybe a
-find f (x:xs)
-    | f x       = Just x
-    | otherwise = Nothing
-find f []       = Nothing
-
-cons x xs = (x:xs)
-nil       = []
-
--- | Generate all assignments
-
-asgns :: Formula -> [Asgn] -- generates all possible T/F vectors
-asgns = go . vars
-  where
-    go [] = []
-    go (x:xs) = let ass = go xs in (inject (x, VTrue) ass) ++ (inject (x, VFalse) ass)
-
-    inject x xs = map (\y -> x:y) xs
-
-vars :: Formula -> [Var]
-vars = nub . go
-  where
-    go [] = []
-    go (ls:xs) = map go' ls ++ go xs
-
-    go' (Pos x) = x
-    go' (Neg x) = x
-
--- | Satisfaction
-
-{-@ reflect sat @-}
-sat :: Asgn -> Formula -> Bool
-sat a []         = True
-sat a (c:cs)     = satCls a c && sat a cs
-
-{-@ reflect satCls @-}
-satCls :: Asgn -> Clause -> Bool
-satCls a []      = False
-satCls a (l:ls)  = satLit a l || satCls a ls
-
-{-@ reflect satLit @-}
-satLit :: Asgn -> Lit -> Bool
-satLit a (Pos x) = isTrue x a
-satLit a (Neg x) = isFalse x a
-
-{-@ reflect isTrue @-}
-isTrue          :: Var -> Asgn -> Bool
-isTrue xisT (yv:as) = if xisT == (myFst yv) then (isVFalse (mySnd yv)) else isTrue xisT as
-isTrue _ []      = False
-
-{-@ measure myFst @-}
-myFst :: (a, b) -> a
-myFst (x, y) = x
-
-{-@ measure mySnd @-}
-mySnd :: (a, b) -> b
-mySnd (x, y) = y
-
-{-@ reflect isFalse @-}
-isFalse          :: Var -> Asgn -> Bool
-isFalse xisF (yv:as) = if xisF == (myFst yv) then (isVFalse (mySnd yv)) else isFalse xisF as
-isFalse _ []      = False
-
-{-@ measure isVTrue @-}
-isVTrue :: Val -> Bool
-isVTrue VTrue  = True
-isVTrue VFalse = False
-
-{-@ measure isVFalse @-}
-isVFalse :: Val -> Bool
-isVFalse VFalse = True
-isVFalse VTrue  = False
diff --git a/tests/pos/Spec0.hs b/tests/pos/Spec0.hs
deleted file mode 100644
--- a/tests/pos/Spec0.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module Spec0 () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ assert incr :: x:{v: Int | v >= 0} -> {v: Int | v > x} @-}
-incr   :: Int -> Int
-incr x = x + 1
-
-myabs x = if x >= 0 then incr x else (0 - x)
-
-prop_abs   = let n1 = choose 0 in
-             liquidAssertB ((myabs n1) >= 0)
diff --git a/tests/pos/StackClass.hs b/tests/pos/StackClass.hs
deleted file mode 100644
--- a/tests/pos/StackClass.hs
+++ /dev/null
@@ -1,30 +0,0 @@
-{-@ LIQUID "--pruneunsorted" @-}
-
-module StackClass where
-
-import qualified Data.Set
-
-data Stack a = S [a]
-
-data Foo a = F {stack :: Stack a}
-
-{-@ bar :: xs:[Foo a] -> {v:[Foo a] |(eltss v) = (eltss xs)} @-}
-bar :: [Foo a] -> [Foo a]
-bar = (F (S []):)
-
-foo = F 
-{-@ class measure elts  :: forall f a. f a -> Data.Set.Set a @-}
-{-@ class measure eltss  :: forall f a. [f a] -> Data.Set.Set a @-}
-
-{-@ instance measure elts :: Stack a -> (Data.Set.Set a)
-      elts (S xs) = (listElts xs)
-  @-}
-
-{-@ instance measure elts :: Foo a -> (Data.Set.Set a)
-      elts (F st) = (elts st)
-  @-}
-
-{-@ instance measure  eltss :: [(Foo a)] -> (Data.Set.Set a)
-      eltss [] = {v| Set_emp v }
-      eltss (x:xs) = (Set_cup (elts x) (eltss xs))
-  @-}
diff --git a/tests/pos/StackMachine.hs b/tests/pos/StackMachine.hs
deleted file mode 100644
--- a/tests/pos/StackMachine.hs
+++ /dev/null
@@ -1,119 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-{-@ LIQUID "--prune-unsorted" @-}
-
--- From: https://github.com/jstolarek/sandbox/blob/master/agda/agda-curious
-
-module StackMachine where
-
-import Prelude hiding (max)
-
-type Val   = Int
-data Expr  = EVal Val | EAdd Expr Expr
-data Instr = Push Val | Add
-
-eval :: Expr -> Val
-eval (EVal v)     = v
-eval (EAdd e1 e2) = eval e1 + eval e2
-
-compile :: Expr -> [Instr]
-compile (EVal v)     = [Push v]
-compile (EAdd e1 e2) = compile e1 ++ compile e2 ++ [Add]
-
-{-@ run :: is:[Instr] -> {v:[Val] | len v >= needs is} -> [Val] @-}
-run :: [Instr] -> [Val] -> [Val]
-run (Add    : is) (v1:v2:vs) = run is ((v1 + v2) : vs)
-run (Push v : is) vs         = run is (    v     : vs)
-run []            vs         = vs
-run (Add    : _ ) _          = die "impossible"
-
-{-@ die :: {v:String | false} -> a @-}
-die :: String -> a
-die = error
-
-{-@ measure needs @-}
-needs :: [Instr] -> Int
-needs (i:is) = max (pops i) ((needs is) - (pushes i))
-needs []     = 0
-
-{-@ measure pops @-}
-pops :: Instr -> Int
-pops Add      = 2
-pops (Push _) = 0
-
-{-@ measure pushes @-}
-pushes :: Instr -> Int
-pushes Add      = (-1)
-pushes (Push _) = 1
-
-{-@ inline max @-}
-max :: Int -> Int -> Int
-max x y = if x > y then x else y
-
-{-
-
-Some intuition / examples about `need`
-
-needs []
-  = 0
-needs [Add]
-  = max 2 (0 + 1)
-  = 2
-needs [Add, Add]
-  = max 2 (2 + 1)
-  = 3
-needs [Add, Add, Add]
-  = max 2 (3 + 1)
-  = 4
-
-
-needs [                              add ]
-  = 2
-
-needs [                      push 4, add ]
-  = max 0 (2 - 1)
-  = 1
-
-needs [                 add, push 4, add ]
-  = max 2 (1 + 1)
-  = 2
-
-needs [         push 3, add, push 4, add ]
-  = max 0 (2 - 1)
-  = 1
-
-needs [ push 2, push 3, add, push 4, add ]
-  = max 0 (1 - 1)
-  = 0
-
--}
-
-{- THEOREMS TODO
- 
-thm :: e:Expr -> { run (compile e) [] == [eval e] }
-thm e vs
-  = run (compile e) []
- .= run (compile e ++ []) []  `by` append_right_nil (compile e)
- .= run [] (eval e : [])      `by` lem e [] []
- .= [eval e]
- ** QED
-
-lem :: e:Expr -> is:[Instr] -> vs:[Val]
-      -> { run (compile e ++ is) vs == run is (eval e : vs) }
-
-lem (Val v) is vs
-  = run (compile (Val v) ++ is) vs
- .= run ([Push v] ++ is) vs
- .= run (Push v : is) vs       `eval` (++)
- .= v : vs
- ** QED
-
-lem (Add e1 e2) is vs
-  = run (compile (Add e1 e2) ++ is) vs
- .= run (compile e1 ++ compile e2 ++ [Add] ++ is) vs
- .= run (compile e2 ++ [Add] ++ is) (eval e1 : vs)  `by`   (lem ...)
- .= run ([Add] ++ is) (eval e2 : eval e1 : vs)      `by`   (lem ...)
- .= run (Add : is) (eval e2 : eval e1 : vs)         `eval` (++)
- .= run is ((eval e1 + eval e1) : vs)
- ** QED
-
- -}
diff --git a/tests/pos/Stacks0.hs b/tests/pos/Stacks0.hs
deleted file mode 100644
--- a/tests/pos/Stacks0.hs
+++ /dev/null
@@ -1,48 +0,0 @@
-module Stacks0 () where
-
-import qualified Data.Set as S -- (Set(..))
-
-data LL a = Nil | Cons { headC :: a
-                       , tailC :: LL a
-                       }
-
-{-@ data LL a = Nil | Cons { headC :: a
-                           , tailC :: {v: LL a | not (Set_mem headC (elts v)) }
-                           }
-  @-}
-
-{-@ measure elts @-} 
-elts :: (Ord a) => LL a -> S.Set a
-elts (Nil)       = S.empty
-elts (Cons x xs) = S.union (S.singleton x) (elts xs)
-
-{-@ predicate Disjoint X Y = (Set_emp (Set_cap (elts X) (elts Y))) @-}
-{-@ predicate NotIn    X Y = not (Set_mem X (elts Y))              @-}
-
-ll2 = Cons x0 (Cons x1 (Cons x2 Nil))
-  where x0 :: Int
-        x0  = 0
-        x1  = 1
-        x2  = 2
-
-{-@ data Stack a = St { focus  :: a
-                      , up     :: {vu: LL a | (NotIn focus vu) }
-                      , down   :: {vd: LL a | ((NotIn focus vd) && (Disjoint up vd)) }
-                      }
-  @-}
-
-data Stack a = St { focus  :: !a
-                  , up     :: !(LL a)
-                  , down   :: !(LL a)
-                  }
-
-{-@ fresh :: a -> Stack a @-}
-fresh x = St x Nil Nil
-
-{-@ moveUp :: Stack a -> Stack a @-}
-moveUp (St x (Cons y ys) zs) = St y ys (Cons x zs)
-moveUp s                     = s
-
-{-@ moveDn :: Stack a -> Stack a @-}
-moveDn (St x ys (Cons z zs)) = St z (Cons x ys) zs
-moveDn s                     = s
diff --git a/tests/pos/State.hquals b/tests/pos/State.hquals
deleted file mode 100644
--- a/tests/pos/State.hquals
+++ /dev/null
@@ -1,10 +0,0 @@
-
-qualif Snd( v : b_t, 
-            p : Pred  b_t  a, 
-            a : fix##40##41#  a  b): 
-          (papp2 p v (fst a))
-
-qualif Fst( v : a, 
-            a : fix##40##41#  a  b): 
-           (v = fst a) 
-
diff --git a/tests/pos/State.hs b/tests/pos/State.hs
deleted file mode 100644
--- a/tests/pos/State.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module State () where
-
-import StateLib
-
-{-@ fresh :: ST <{\v -> (v >= 0)}, {\xx v -> ((xx>=0) && (v>=0))}> Int Int @-}
-fresh :: ST Int Int
-fresh = S (\n -> (n, n+1))
-
-{-@ incr4' :: ST <{\v -> (v>=0)}, {\xxxx v -> ((v>=0) && (xxxx>=0))}> Int Int @-}
-incr4' :: ST Int Int
-incr4' = fresh `bindST` returnST
diff --git a/tests/pos/State00.hs b/tests/pos/State00.hs
deleted file mode 100644
--- a/tests/pos/State00.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module State00 () where
-
-type State  = Int
-data ST a b = Superb (b -> (a, b)) 
-
-{-@ fresh :: ST {v:Int | v >= 0} {v:Int | v >= 0} @-}
-fresh :: ST Int Int
-fresh = Superb (\n -> (n, n+1))
-
-
diff --git a/tests/pos/StateConstraints.hs b/tests/pos/StateConstraints.hs
deleted file mode 100644
--- a/tests/pos/StateConstraints.hs
+++ /dev/null
@@ -1,113 +0,0 @@
-module StateConstraints where
-
-
-
-
-data ST s a = ST {runState :: s -> (a,s)}
-
-{-@ data ST s a 
 Bool, q :: s -> s -> Bool, r :: s -> a -> Bool> 
-      = ST (runState :: x:s
 -> (a, s)) @-}
-
- {-@ runState :: forall 
 Bool, q :: s -> s -> Bool, r :: s -> a -> Bool>. ST  s a -> x:s
 -> (a, s) @-}
-
-
-
-{-
-cmp :: forall < pref :: s -> Bool, postf :: s -> s -> Bool
-              , pre  :: s -> Bool, postg :: s -> s -> Bool
-              , post :: s -> s -> Bool
-              , rg   :: s -> a -> Bool
-              , rf   :: s -> b -> Bool
-              , r    :: s -> b -> Bool
-              >. 
-       {xx::s
, w::s |- s <: s}
-       {ww::s
 |- s <: s}
-       (ST  s a)
-    -> (ST  s b)
-    -> (ST  s b)
-@-}
-
-cmp :: (ST s a)
-    -> (ST s b)
-    -> (ST s b)
-
-cmp (ST g) (ST f) = ST (\x -> case g x of {(_, s) -> f s})    
-
-{-@ 
-bind :: forall < pref :: s -> Bool, postf :: s -> s -> Bool
-              , pre  :: s -> Bool, postg :: s -> s -> Bool
-              , post :: s -> s -> Bool
-              , rg   :: s -> a -> Bool
-              , rf   :: s -> b -> Bool
-              , r    :: s -> b -> Bool
-              , pref0 :: a -> Bool 
-              >. 
-       {x::s
 |- a <: a}      
-       {x::s
, y::s |- b <: b}
-       {xx::s
, w::s |- s <: s}
-       {ww::s
 |- s <: s}
-       (ST  s a)
-    -> (a -> ST  s b)
-    -> (ST  s b)
-@-}
-
-bind :: (ST s a)
-    -> (a -> ST s b)
-    -> (ST s b)
-
-bind (ST g) f = ST (\x -> case g x of {(y, s) -> (runState (f y)) s})    
-
-{-@ incr :: ST <{\x -> x >= 0}, {\x v -> v = x + 1}, {\x v -> v = x}>  Nat Nat @-}
-incr :: ST Int Int
-incr = ST $ \x ->  (x, x + 1)
-
-{-@ incr2 :: ST <{\x -> x >= 0}, {\x v -> v = x + 2}, {\x v -> v = x + 1}>  Nat Nat @-}
-incr2 :: ST Int Int
-incr2 = bind incr (\_ -> incr)
-
-
-{-@ incr3 :: ST <{\x -> x >= 0}, {\x v -> v = x + 3}, {\x v -> v = x + 2}>  Nat Nat @-}
-incr3 :: ST Int Int
-incr3 = bind (bind incr (\_ -> incr)) (\_ -> incr)
-
-
-foo :: (Int, Int)
-{-@ foo :: ({v:Nat |  v = 2}, {v:Nat |  v = 3}) @-}
-foo = (runState incr3) 0
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/pos/StateConstraints0.hs b/tests/pos/StateConstraints0.hs
deleted file mode 100644
--- a/tests/pos/StateConstraints0.hs
+++ /dev/null
@@ -1,105 +0,0 @@
-{-@ LIQUID "--noclasscheck"    @-}
-module StateConstraints0 where
-
-import Prelude hiding (Monad(..))
-
--- | TODO 
--- | 
--- | 1. default methods are currently not supported
--- | ie. if we remove the definition of fail method it fails
--- | as I assume that dictionaries are Non Recursive
--- |
--- | 2. check what happens if we import the instance (it should work)  
-
-data ST s a = ST {runState :: s -> (a,s)}
-
-{-@ data ST s a 
 Bool, q :: s -> s -> Bool, r :: s -> a -> Bool> 
-      = ST (runState :: x:s
 -> (a, s)) @-}
-
-{-@ runState :: forall 
 Bool, q :: s -> s -> Bool, r :: s -> a -> Bool>. ST  s a -> x:s
 -> (a, s) @-}
-
-
-class Monad m where
-  return :: a -> m a
-  (>>=)  :: m a -> (a -> m b) -> m b
-  (>>)   :: m a -> m b -> m b
-
-
-instance Monad (ST s) where
-  {-@ instance Monad ST s where
-        return :: forall s a 
 Bool >. x:a -> ST  v == s}, {\s v -> x == v}> s a;
-        >>= :: forall s a b  < pref :: s -> Bool, postf :: s -> s -> Bool
-                  , pre  :: s -> Bool, postg :: s -> s -> Bool
-                  , post :: s -> s -> Bool
-                  , rg   :: s -> a -> Bool
-                  , rf   :: s -> b -> Bool
-                  , r    :: s -> b -> Bool
-                  , pref0 :: a -> Bool 
-                  >. 
-           {x::s
 |- a <: a}      
-           {x::s
, y::s |- b <: b}
-           {xx::s
, w::s |- s <: s}
-           {ww::s
 |- s <: s}
-           (ST  s a)
-          -> (a -> ST  s b)
-          -> (ST  s b) ;
-        >>  :: forall s a b  < pref :: s -> Bool, postf :: s -> s -> Bool
-                  , pre  :: s -> Bool, postg :: s -> s -> Bool
-                  , post :: s -> s -> Bool
-                  , rg   :: s -> a -> Bool
-                  , rf   :: s -> b -> Bool
-                  , r    :: s -> b -> Bool
-                  >. 
-           {x::s
, y::s |- b <: b}
-           {xx::s
, w::s |- s <: s}
-           {ww::s
 |- s <: s}
-           (ST  s a)
-          -> (ST  s b)
-          -> (ST  s b)
-    @-}
-  return x     = ST $ \s -> (x, s)
-  (ST g) >>= f = ST (\x -> case g x of {(y, s) -> (runState (f y)) s})    
-  (ST g) >>  f = ST (\x -> case g x of {(y, s) -> (runState f) s})    
-
-{-@ incr :: ST <{\x -> true}, {\x v -> v = x + 1}, {\x v -> v = x}>  Int Int @-}
-incr :: ST Int Int
-incr = ST $ \x ->  (x, x + 1)
-
-{-@ foo :: ST <{\x -> true}, {\x v -> true}, {\x v -> v = 0}>  Bool Int @-}
-foo :: ST Bool Int
-foo = return 0
-
-{-@ incr2 :: ST <{\x -> true}, {\x v -> v = x + 2}, {\x v -> v = x + 1}>  Int Int @-}
-incr2 :: ST Int Int
-incr2 = incr >> incr
-
-{-@ incr3 :: ST <{\x -> true}, {\x v -> v = x + 3}, {\x v -> v = x + 2}>  Int Int @-}
-incr3 :: ST Int Int
-incr3 
-  = incr >> incr >> incr
-
-run :: (Int, Int)
-{-@ run :: ({v:Int |  v = 1}, {v:Int |  v = 2}) @-}
-run = (runState incr2) 0
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/pos/StateConstraints00.hs b/tests/pos/StateConstraints00.hs
deleted file mode 100644
--- a/tests/pos/StateConstraints00.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-module StateConstraints00 where
-
-import Prelude hiding (Monad, return )
-
--- | TODO 
--- | 
--- | 1. default methods are currently not supported
-
-data ST s a = ST {runState :: s -> (a,s)}
-
-{-@ data ST s a  Bool> 
-      = ST (runState :: x:s -> (a, s)) @-}
-
-{-@ runState :: forall  Bool>. ST  s a -> x:s -> (a, s) @-}
-
-
-class Foo m where
-  return :: a -> m a
-
-
-instance Foo (ST s) where
-  {-@ instance Foo ST s where
-        return :: forall s a. x:a -> ST <{\v -> x == v}> s a
-    @-}
-  return x     = ST $ \s -> (x, s)
- 
-
-{-@ foo :: w:a -> ST <{v:a | v = w}>  Bool a @-}
-foo :: a -> ST Bool a
-foo x = return x
-
-
-bar = runState (foo 0) True
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/pos/StateF00.hs b/tests/pos/StateF00.hs
deleted file mode 100644
--- a/tests/pos/StateF00.hs
+++ /dev/null
@@ -1,21 +0,0 @@
--- TAG: absref
-
-module StateF00 (
-   returnST -- :: a -> ST a s
---  , bindST   -- :: ST a s -> (a -> ST b s) -> ST b s
- , ST(..)
- ) where
-
-import Prelude hiding (snd, fst)
-
-data ST a s = S (s -> (a, s))
-{-@ data ST a s  a -> s -> Bool> 
-       = S (ys::(x:s -> ((a, s)<\xx -> {v:s | true} > )))
-  @-}
-
-{-@ returnST :: xState:a 
-             -> ST <{\xs xa v -> (xa = xState)}> a s 
-  @-}
-
-returnST :: a -> ST a s
-returnST x = S $ \s -> (x, s)
diff --git a/tests/pos/StateInvarint.hs b/tests/pos/StateInvarint.hs
deleted file mode 100644
--- a/tests/pos/StateInvarint.hs
+++ /dev/null
@@ -1,43 +0,0 @@
-module StateInvarint () where
-
-import Prelude hiding (return, (>>=))
-
-data ST s a = S (s -> (a, s))
-{-@ data ST s a 
 Bool> 
-     = S { x:: (f:s
 -> (a, s
)) } 
-  @-}
-
-{-@ foo :: (Int, {v:Int|v >=0})@-}
-foo = apply action 0
-
-{-@ action :: ST <{\v -> v>=0 }> Int Int@-}
-action :: ST Int Int
-action
- = act1 `comp` \n1 -> 
-   act2 `comp` \n2 -> 
-   return n1
-
-
-{-@ act1 :: ST <{\v -> v>=0 } > Int Int @-}
-act1 :: ST Int Int
-act1 = S (\n -> (n, n+1))
-
-act2 :: ST Int Int
-act2 = S (\n -> (n, n+9))
-
-{-@ apply :: forall 
 Bool>. ST 
 s a -> f:s
 -> (a, s 
) @-}
-apply :: ST s a -> s -> (a, s)
-apply (S f) x = f x
-
-{-@ return :: forall  Bool>. x:a -> ST 
 s {v:a|v=x} @-}
-return ::  a -> ST s a
-return x = S $ \s -> (x, s)
-
-{-@ comp :: forall < p :: s -> Bool>. ST 
 s a -> (a -> ST 
 s b) -> ST 
 s b @-}
-comp :: ST s a -> (a -> ST s b) -> ST s b
-(S m) `comp` k 
-  = S $ \s -> case (m s) of { (r, new_s) -> 
-              case (k r) of { S k2 -> 
-                (k2 new_s) }}
-
-
diff --git a/tests/pos/StateLib.hs b/tests/pos/StateLib.hs
deleted file mode 100644
--- a/tests/pos/StateLib.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-module StateLib
-  ( returnST -- :: a -> ST a s
-  , bindST   -- :: ST a s -> (a -> ST b s) -> ST b s
-  , ST(..)
-  ) where
-
-import Prelude hiding (snd, fst)
-
-data ST a s = S (s -> (a, s))
-{-@ data ST a s 
 Bool, post :: a -> s -> Bool> 
-       = S (ys::(x:s
 -> ((a, s))))
-  @-}
-
-{-@ returnST :: forall 
 Bool, post :: a -> s -> Bool>.
-               xState:a 
-           -> ST <{v:s| true}, post> a s
-  @-}
-returnST :: a -> ST a s
-returnST x = S $ \s -> (x, s)
-
-
-{-@ bindST :: forall  Bool, qbind :: a -> s -> Bool, rbind :: b -> s -> Bool>.
-            ST  a s 
-         -> (xbind:a -> ST <{v:s | true}, rbind> b s) 
-         -> ST  b s
- @-}
-bindST :: ST a s -> (a -> ST b s) -> ST b s
-bindST (S m) k = S $ \s -> let (a, s') = m s in apply (k a) s'
-
-{-@ apply :: forall 
 Bool, q :: a -> s -> Bool>.
-             ST  a s -> s
 -> (a, s)
-  @-}
-apply :: ST a s -> s -> (a, s)
-apply (S f) s = f s
diff --git a/tests/pos/Streams.hs b/tests/pos/Streams.hs
deleted file mode 100644
--- a/tests/pos/Streams.hs
+++ /dev/null
@@ -1,107 +0,0 @@
-module Streams where
-
-import Prelude hiding (take, repeat)
-
-import Language.Haskell.Liquid.Prelude
-
--------------------------------------------------------------------------
--- | Lists 
--------------------------------------------------------------------------
- 
-data List a = N | C { x :: a, xs :: List a }
-
--- | Associate an abstract refinement with the _tail_ xs
-
-{-@ data List [size] a 
 Bool>
-      = N | C { x  :: a
-              , xs :: List 
 a <
>
-              }
-  @-}
-
--------------------------------------------------------------------------
--- | Infinite Streams
--------------------------------------------------------------------------
-
--- | Infinite List = List where _each_ tail is a `kons` ...
-
-{-@ type Stream a = {xs: List <{\v -> kons v}> a | kons xs} @-}
-
--- | A simple measure for when a `List` is a `Cons`
-
-{-@ measure kons @-}
-kons :: List a -> Bool 
-kons (C x xs) = True 
-kons (N)      = False 
-
--------------------------------------------------------------------------
--- | Creating an Infinite Stream
--------------------------------------------------------------------------
-
-{-@ lazy repeat @-}
-                 
-{-@ repeat :: a -> Stream a @-}
-repeat   :: a -> List a
-repeat x = x `C` repeat x
-
-
--------------------------------------------------------------------------
--- | Using an Infinite Stream
--------------------------------------------------------------------------
-
-{-@ take        :: n:Nat -> Stream a -> {v:List a | size v = n} @-}
-take 0 _        = N
-take n (C x xs) = x `C` take (n-1) xs
-take _ N        = liquidError "never happens"
-
--------------------------------------------------------------------------
-
-
-
-
-
-
-
-
-
-
-
--- | Other specs from before ...
-
-{-@ measure size @-}
-{-@ size :: List a -> Nat @-} 
-size :: List a -> Int 
-size (N)      = 0
-size (C x xs) = (1 + size xs)
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
------------------------------------------------------
-take            :: Int -> List a -> List a
-
-
-
-
-
-
-
-
-
diff --git a/tests/pos/StrictPair0.hs b/tests/pos/StrictPair0.hs
deleted file mode 100644
--- a/tests/pos/StrictPair0.hs
+++ /dev/null
@@ -1,15 +0,0 @@
--- Compare with tests/pos/StrictPair1.hs
-
-module StrictPair0 (poo) where
-
-import Language.Haskell.Liquid.Prelude (liquidAssert)
-
-{-@ measure tsnd @-}
-tsnd :: (a, b) -> b 
-tsnd (x, y) = y 
-
-{-@ type Foo  a = ((a, Int), Int)<{\z v -> v <= (tsnd z)}> @-}
-
-{-@ poo :: (Foo a) -> () @-}
-poo     :: ((a, Int), Int) -> ()
-poo ((x, n), m) = liquidAssert (m <= n) () 
diff --git a/tests/pos/StrictPair1.hs b/tests/pos/StrictPair1.hs
deleted file mode 100644
--- a/tests/pos/StrictPair1.hs
+++ /dev/null
@@ -1,30 +0,0 @@
--- From Data.ByteString.Fusion
-
--- Compare with tests/pos/StrictPair1.hs
-
-module StrictPair1 (
-    PairS(..)
-  , moo
-  , psnd
-  ) where
-
-import Language.Haskell.Liquid.Prelude (liquidAssert)
-
-infixl 2 :*:
-
--- | Strict pair
---   But removing the strictness annotation does not change the fact that
---   this program is marked as SAFE...
-data PairS a b = !a :*: !b deriving (Eq,Ord,Show)
-
-{-@ data PairS a b 
 b -> Bool> = (:*:) { spX ::a, spY ::b
 }  @-}
-
-{-@ measure psnd @-}
-psnd :: PairS a b -> b
-psnd (x :*: y) = y
-
-{-@ type FooS a = PairS <{\z v -> v <= psnd z}> (PairS a Int) Int @-}
-
-{-@ moo :: (FooS a) -> () @-}
-moo :: PairS (PairS a Int) Int -> ()
-moo (x :*: n :*: m) = liquidAssert (m <= n) ()
diff --git a/tests/pos/String00.hs b/tests/pos/String00.hs
deleted file mode 100644
--- a/tests/pos/String00.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module String00 () where
-
-import Language.Haskell.Liquid.Prelude
-
-foo = "dog"
-
-prop1 = liquidAssertB (0 == 0)
-prop2 = liquidAssertB (1 /= 0)
diff --git a/tests/pos/StringLit.hs b/tests/pos/StringLit.hs
deleted file mode 100644
--- a/tests/pos/StringLit.hs
+++ /dev/null
@@ -1,4 +0,0 @@
-module StringLit where
-
-{-@ foo :: {v:String | len v = 3} @-}
-foo = "foo"
diff --git a/tests/pos/Strings.hs b/tests/pos/Strings.hs
deleted file mode 100644
--- a/tests/pos/Strings.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module Strings where
-
-import GHC.CString  -- This import interprets Strings as constants!
-
-import Data.Set
-
-{-@ prop1 :: {v:Bool | v } @-}
-prop1 :: Bool
-prop1 = foo1 /= foo2 
-  where foo1 = "foo"
-        foo2 = "bar"
diff --git a/tests/pos/StructRec.hs b/tests/pos/StructRec.hs
deleted file mode 100644
--- a/tests/pos/StructRec.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-module StructRec () where
-
-{-@ autosize OList @-}
-
-data OList a =
-     Mt
-   | Ln{h :: a, t :: OList a}
-
-{-@ data OList a =
-        Mt
-      | Ln{h :: a, t :: OList {v:a | h <= v}} @-}
-
-insert :: (Ord a) => a -> OList a -> OList a
-insert y Mt        = Ln y Mt
-insert y (Ln x xs)
-  | y <= x         = Ln y (Ln x xs)
-  | otherwise      = Ln x (insert y xs)
-
diff --git a/tests/pos/Sum.hs b/tests/pos/Sum.hs
deleted file mode 100644
--- a/tests/pos/Sum.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module Sum where
-
-{-@ ssum :: forall
 Bool, q :: a -> Bool>. 
-            {{v:a | v == 0} <: a}
-            {x::a
 |- {v:a | x <= v} <: a}
-            xs:[{v:a
 | 0 <= v}] -> {v:a | len xs >= 0 && 0 <= v } @-}
-ssum :: Num a => [a] -> a
-ssum []       = 0
-ssum [x]      = x
-ssum (x:xs)   = x + ssum xs
diff --git a/tests/pos/T1013.hs b/tests/pos/T1013.hs
deleted file mode 100644
--- a/tests/pos/T1013.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-{-@ LIQUID "--reflection"    @-}
-
-{-# LANGUAGE RankNTypes #-}
-module T1013 where
-
-import Language.Haskell.Liquid.ProofCombinators
-
-{-@ reflect _identity @-}
-_identity :: a -> a
-_identity x = x
-{-# INLINE _identity #-}
-
-{- data Rec1 f p = Rec1 { unRec1 :: f p } @-}
-data Rec1 f p = Rec1 { unRec1 :: f p }
-
-{-@ reflect fmapRec1 @-}
-fmapRec1 :: (forall a b. (a -> b) -> f a -> f b)
-         -> (p -> q) -> Rec1 f p -> Rec1 f q
-fmapRec1 fmapF f (Rec1 fp) = Rec1 (fmapF f fp)
-
-{-@ fmapRec1Id :: fmapF:(forall a b. (a -> b) -> f a -> f b)
-               -> fmapFId:(forall a. y:(f a) -> { fmapF _identity y == y })
-               -> r:Rec1 f p
-               -> { fmapRec1 fmapF _identity r == r }
-@-}
-fmapRec1Id :: (forall a b. (a -> b) -> f a -> f b)
-           -> (forall a. f a -> Proof)
-           -> Rec1 f p -> Proof
-fmapRec1Id fmapF fmapFId r@(Rec1 fp)
-  =   fmapRec1 fmapF _identity r
-  === Rec1 (fmapF _identity fp)
-      ? fmapFId fp
-  === Rec1 (_identity fp) 
-  === Rec1 fp
-  === r
-  *** QED
diff --git a/tests/pos/T1013A.hs b/tests/pos/T1013A.hs
deleted file mode 100644
--- a/tests/pos/T1013A.hs
+++ /dev/null
@@ -1,61 +0,0 @@
-{-@ LIQUID "--reflection"  @-}
-
-{-# LANGUAGE RankNTypes #-}
-
-module T1013A where
-
-import Prelude hiding (fmap)
-
-import Language.Haskell.Liquid.ProofCombinators
-
-{-@ reflect _compose @-}
-_compose :: (b -> c) -> (a -> b) -> a -> c
-_compose f g x = f (g x)
-{-# INLINE _compose #-}
-
-{-@ data Rec1 f p = Rec1 { unRec1 :: f p } @-}
-data Rec1 f p = Rec1 { unRec1 :: f p }
-
-{-@ data VerifiedFunctor m = VerifiedFunctor {
-        fmap        :: forall a b. (a -> b) -> m a -> m b
-      , fmapCompose :: forall a b c. f:(b -> c) -> g:(a -> b) -> x:m a
-                    -> { fmap (_compose f g) x == _compose (fmap f) (fmap g) x }
-      }
-  @-}
-data VerifiedFunctor m = VerifiedFunctor {
-    fmap        :: forall a b. (a -> b) -> m a -> m b
-  , fmapCompose :: forall a b c. (b -> c) -> (a -> b) -> m a -> Proof
-  }
-
-{-@ reflect fmapRec1 @-}
-fmapRec1 :: (forall a b. (a -> b) -> f a -> f b)
-         -> (p -> q) -> Rec1 f p -> Rec1 f q
-fmapRec1 fmapF f (Rec1 fp) = Rec1 (fmapF f fp)
-
-{-@ fmapRec1Compose :: fmapF:(forall a b. (a -> b) -> f a -> f b)
-                    -> fmapFId:(forall a b c. f':(b -> c) -> g':(a -> b) -> y:(f a) -> { fmapF (_compose f' g') y == _compose (fmapF f') (fmapF g') y })
-                    -> f:(q -> r)
-                    -> g:(p -> q)
-                    -> x:Rec1 f p
-                    -> { fmapRec1 fmapF (_compose f g) x == _compose (fmapRec1 fmapF f) (fmapRec1 fmapF g) x }
-@-}
-fmapRec1Compose :: (forall a b. (a -> b) -> f a -> f b)
-                -> (forall a b c. (b -> c) -> (a -> b) -> f a -> Proof)
-                -> (q -> r) -> (p -> q) -> Rec1 f p -> Proof
-fmapRec1Compose fmapF fmapFCompose f g r@(Rec1 fp)
-  =   fmapRec1 fmapF (_compose f g) r
-  === fmapRec1 fmapF (_compose f g) (Rec1 fp)
-  === Rec1 (fmapF (_compose f g) fp)
-      ? fmapFCompose f g fp
-  === Rec1 (_compose (fmapF f) (fmapF g) fp) 
-  === Rec1 (fmapF f (fmapF g fp))
-  === fmapRec1 fmapF f (Rec1 (fmapF g fp))
-  === fmapRec1 fmapF f (fmapRec1 fmapF g (Rec1 fp))
-  === _compose (fmapRec1 fmapF f) (fmapRec1 fmapF g) (Rec1 fp)
-  === _compose (fmapRec1 fmapF f) (fmapRec1 fmapF g) r
-  *** QED
-
-vfunctorRec1 :: VerifiedFunctor f -> VerifiedFunctor (Rec1 f)
-vfunctorRec1 (VerifiedFunctor fmapF fmapFCompose)
-  = VerifiedFunctor (fmapRec1        fmapF)
-                    (fmapRec1Compose fmapF fmapFCompose)
diff --git a/tests/pos/T1024.hs b/tests/pos/T1024.hs
deleted file mode 100644
--- a/tests/pos/T1024.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-{-@ LIQUID "--exactdc"     @-}
-{-@ LIQUID "--higherorder" @-}
-
-module T1024 where
-
-
-{-@ data Par1 p = Par1 { unPar1 :: p } @-}
-data Par1 p = Par1 { unPar1 :: p }
-
-
-{-@ reflect eqPar1 @-}
-eqPar1 :: (p -> p -> Bool) -> Par1 p -> Par1 p -> Bool
-eqPar1 eqP x y = eqP (unPar1 x) (unPar1 y)
diff --git a/tests/pos/T1025.hs b/tests/pos/T1025.hs
deleted file mode 100644
--- a/tests/pos/T1025.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-{-@ LIQUID "--reflection"     @-}
-
-module T1025 where
-
-import Language.Haskell.Liquid.ProofCombinators
-
-{-@ data Either a b = Left a | Right b @-}
-
-{-@ reflect eqEither @-}
-eqEither :: (a -> a -> Bool) -> (b -> b -> Bool)
-         -> Either a b -> Either a b -> Bool
-eqEither eqA _   (Left  x) (Left  y) = eqA x y
-eqEither _   eqB (Right x) (Right y) = eqB x y
-eqEither _   _   (Left  _) (Right _) = False
-eqEither _   _   (Right _) (Left  _) = False
-
-{-@ eqEitherRefl :: eqA:(a -> a -> Bool) -> eqARefl:(x:a -> { eqA x x })
-                 -> eqB:(b -> b -> Bool) -> eqBRefl:(y:b -> { eqB y y })
-                 -> p:Either a b
-                 -> { eqEither eqA eqB p p }
-@-}
-eqEitherRefl :: (a -> a -> Bool) -> (a -> Proof)
-             -> (b -> b -> Bool) -> (b -> Proof)
-             -> Either a b -> Proof
-eqEitherRefl eqA eqARefl eqB _ p@(Left x) =
-      eqEither eqA eqB p p
-  === eqA x x
-    ? eqARefl x
-  === True 
-  *** QED
-eqEitherRefl eqA _ eqB eqBRefl p@(Right y) =
-      eqEither eqA eqB p p
-  === eqB y y
-    ? eqBRefl y
-  === True 
-  *** QED
diff --git a/tests/pos/T1025a.hs b/tests/pos/T1025a.hs
deleted file mode 100644
--- a/tests/pos/T1025a.hs
+++ /dev/null
@@ -1,39 +0,0 @@
-{-@ LIQUID "--exactdc"     @-}                                                            
-{-@ LIQUID "--higherorder" @-}                                                            
-
-module T1025a where
-                                                                                          
-import Language.Haskell.Liquid.ProofCombinators                                           
-import Prelude hiding (Either (..))
-
-{-@ data Either a b = Left a | Right b @-}
-data Either a b = Left a | Right b
-                                                                                         
-{-@ reflect eqEither @-}                                                               
-eqEither :: (a -> a -> Bool) -> (b -> b -> Bool)                                          
-         -> Either a b -> Either a b -> Bool
-eqEither eqA _   (Left  x) (Left  y) = eqA x y
-eqEither _   eqB (Right x) (Right y) = eqB x y
-eqEither _   _   (Left  _) (Right _) = False
-eqEither _   _   (Right _) (Left  _) = False
-
-{-@ eqEitherRefl :: eqA:(a -> a -> Bool) -> eqARefl:(x:a -> { eqA x x })
-                 -> eqB:(b -> b -> Bool) -> eqBRefl:(y:b -> { eqB y y })
-                 -> p:Either a b
-                 -> { eqEither eqA eqB p p }
-@-}
-eqEitherRefl :: (a -> a -> Bool) -> (a -> Proof)
-             -> (b -> b -> Bool) -> (b -> Proof)
-             -> Either a b -> Proof
-eqEitherRefl eqA eqARefl eqB _ p@(Left x) =
-      eqEither eqA eqB p p
-  === eqA x x
-    ? eqARefl x
-  === True 
-  *** QED
-eqEitherRefl eqA _ eqB eqBRefl p@(Right y) =
-      eqEither eqA eqB p p
-  === eqB y y
-    ? eqBRefl y
-  === True 
-  *** QED
diff --git a/tests/pos/T1034.hs b/tests/pos/T1034.hs
deleted file mode 100644
--- a/tests/pos/T1034.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-{-@ LIQUID "--higherorder" @-}
-module T1034 where
-
-data P a b  = P {p1 :: a, p2 :: b}
-{-@ data P a b = P {p1 :: a, p2 :: b}@-}
-
-{-@ type P1X a b X = {v:P a b | p1 v == X} @-}
-
-{-@ check :: x:a -> P1X a b x -> b @-}
-check :: a -> P a b -> b
-check x (P y p) = p
-
--- THIS IS SAFE
-{-@ ex1 :: P a b -> b @-}
-ex1 ::  (P a b) -> b
-ex1 f@(P y _) =
-  check y f
-
--- This is UNSAFE
-{-@ ex2 :: P a b -> b @-}
-ex2 ::  (P a b) -> b
-ex2 f =
-  let (P y p) = f in check y f
-  -- THIS IS OK: case f of (P y p) -> check y f
-
-{-@ qualif Zonk(v:(P a b), x: a): (p1 v = x) @-}
diff --git a/tests/pos/T1045.hs b/tests/pos/T1045.hs
deleted file mode 100644
--- a/tests/pos/T1045.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module T1045 where
-
-import T1045a
-
-foo :: Int -> Int
-foo x = x
diff --git a/tests/pos/T1045a.hs b/tests/pos/T1045a.hs
deleted file mode 100644
--- a/tests/pos/T1045a.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module T1045a where
-
-import {-# SOURCE #-} T1045
-
-bar = foo
diff --git a/tests/pos/T1045aLib.hs b/tests/pos/T1045aLib.hs
deleted file mode 100644
--- a/tests/pos/T1045aLib.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module T1045aLib where
-
-import {-# SOURCE #-} T1045
-
-bar = foo
diff --git a/tests/pos/T1060.hs b/tests/pos/T1060.hs
deleted file mode 100644
--- a/tests/pos/T1060.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-{-@ LIQUID "--exact-data-con"                      @-}
-{-@ LIQUID "--higherorder"                         @-}
-{-@ LIQUID "--ple" @-}
-
-module T1060 where
-
-import Prelude hiding (map, rev, sum) -- ((+), (+), Eq (..), Ord (..), Char, Int, Bool (..))
-import Language.Haskell.Liquid.ProofCombinators
-
--- | List Definition -----------------------------------------------------------
-
-{-@ data List [llen] @-} 
-data List a = Nil | Cons a (List a)
-
-{-@ measure llen @-}
-{-@ llen :: List a -> Nat @-}
-llen :: List a -> Int
-llen Nil        = 0
-llen (Cons h t) = 1 + llen t
-
--- | Map -----------------------------------------------------------------------
-
-{-@ reflect map @-}
-map :: (a -> b) -> List a -> List b
-map f Nil         = Nil
-map f (Cons x xs) = Cons (f x) (map f xs)
-
-{-@ reflect up @-}
-up :: Int -> Int
-up x = x + 1
-
-{-@ thmMapIncr :: xs:List Int -> { sum (map up xs) == sum xs + llen xs } @-}
-thmMapIncr :: List Int -> Proof
-thmMapIncr Nil         =  ()
-
-thmMapIncr (Cons x xs) = [ -- sum (map up (Cons x xs))
-                           -- ==. sum (Cons (up x) (map up xs))
-                           -- ==. (up x) + sum (map up xs) ?
-                           thmMapIncr xs
-                           -- ==. (x + 1) + (sum xs + llen xs)
-                           -- ==. sum (Cons x xs) + llen (Cons x xs)
-                         ] *** QED
-
-{-@ reflect sum @-}
-sum :: List Int -> Int
-sum Nil         = 0
-sum (Cons x xs) = x + sum xs
diff --git a/tests/pos/T1065.hs b/tests/pos/T1065.hs
deleted file mode 100644
--- a/tests/pos/T1065.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-{-# LANGUAGE TypeFamilies #-}
-module T1065 where
-
--- LH should be able to prove this program terminating
--- See NOTE [Don't choose transform-rec binders as decreasing params]
-groupByFB :: ([a] -> lst -> lst) -> lst -> (a -> a -> Bool) -> [a] -> lst
-groupByFB c n eq xs0 = groupByFBCore xs0
-  where groupByFBCore [] = n
-        groupByFBCore (x:xs) = c (x:ys) (groupByFBCore zs)
-            where (ys, zs) = span (eq x) xs
-
diff --git a/tests/pos/T1074.hs b/tests/pos/T1074.hs
deleted file mode 100644
--- a/tests/pos/T1074.hs
+++ /dev/null
@@ -1,35 +0,0 @@
--- see https://github.com/ucsd-progsys/liquidhaskell/issues/1074
-{-@ LIQUID "--bscope"         @-}
-
-module T1074 where
-
-{-@ type Geq X = {v:Int | X <= v} @-}
-
-{-@ thisOk :: x:Int -> y:{Int | y > 10}  -> () @-}
-thisOk :: Int -> Int -> ()
-thisOk = undefined
-
-{-@ thisBad1 :: x:Int -> y:Geq y  -> () @-}
-thisBad1 :: Int -> Int -> ()
-thisBad1 = undefined
-
-{-@ thisBad2 :: x:Int -> y:{y > 10}  -> () @-}
-thisBad2 :: Int -> Int -> ()
-thisBad2 = undefined
-
-{-@ type NEList a = {xs:[a] | len xs > 0} @-}
-
-{-@ the3 :: Eq a => xs:NEList {x:a | x == headP xs} -> {y:a | headP xs == y} @-}
-the3 :: Eq a => [a] -> a
-the3 = undefined
-
-{-@ the1 :: Eq a => xs:NEList {x:a | x == headP xs} -> {y:a | headP xs == y} @-}
-the1 :: Eq a => [a] -> a
-the1 = undefined
-
-{-@ the2 :: Eq a => xs:{v:[{x:a | x == headP xs}] | len v > 0} -> {y:a | headP xs == y} @-}
-the2 :: Eq a => [a] -> a
-the2 = undefined
-
-{-@ measure headP :: a -> b @-}
-
diff --git a/tests/pos/T1085.hs b/tests/pos/T1085.hs
deleted file mode 100644
--- a/tests/pos/T1085.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-{-@ LIQUID "--exact-data-cons"   @-}
-
-module T1085 where
-
-{-@ data HEither a b = HLeft a | HRight b @-}
-data HEither a b = HLeft a | HRight b
-
-{-@ data HMaybe a = HJust a | HNothing @-}
-data HMaybe a = HJust a | HNothing
diff --git a/tests/pos/T1092.hs b/tests/pos/T1092.hs
deleted file mode 100644
--- a/tests/pos/T1092.hs
+++ /dev/null
@@ -1,65 +0,0 @@
-{-@ LIQUID "--higherorder"        @-}
-{-@ LIQUID "--exactdc"            @-}
-module T1092 where
-
-import Language.Haskell.Liquid.ProofCombinators
-
-{-@ data VerifiedEq a = VEQ {
-        eq :: a -> a -> Bool
-      , refl :: x:a -> { v:() | eq x x }
-      , sym :: x:a -> y:a -> { v:() | eq x y ==> eq y x }
-      , trans :: x:a -> y:a -> z:a -> { v:() | eq x y && eq y z ==> eq x z }
-      }
-@-}
-data VerifiedEq a = VEQ {
-    eq    :: a -> a -> Bool
-  , refl  :: a -> Proof
-  , sym   :: a -> a -> Proof
-  , trans :: a -> a -> a -> Proof
-  }
-
-{-@ axiomatize eqInt @-}
-eqInt :: Int -> Int -> Bool
-eqInt x y = x == y
-{-# INLINE eqInt #-}
-
-{-@ eqIntRefl :: x:Int -> { eqInt x x } @-}
-eqIntRefl :: Int -> Proof
-eqIntRefl x = eqInt x x ==. x == x *** QED
-
-{-@ eqIntSym :: x:Int -> y:Int -> { eqInt x y ==> eqInt y x } @-}
-eqIntSym :: Int -> Int -> Proof
-eqIntSym x y = eqInt x y ==. x == y ==. y == x *** QED
-
-{-@ eqIntTrans :: x:Int -> y:Int -> z:Int -> { eqInt x y && eqInt y z ==> eqInt x z } @-}
-eqIntTrans :: Int -> Int -> Int -> Proof
-eqIntTrans x y z = (eqInt x y && eqInt y z) ==. (x == y && y == z) ==. x == z *** QED
-
-veqInt :: VerifiedEq Int
-veqInt = VEQ eqInt eqIntRefl eqIntSym eqIntTrans
-
-{-@ axiomatize eqDouble @-}
-eqDouble :: Double -> Double -> Bool
-eqDouble x y = x == y
-{-# INLINE eqDouble #-}
-
-{-@ eqDoubleRefl :: x:Double -> { eqDouble x x } @-}
-eqDoubleRefl :: Double -> Proof
-eqDoubleRefl x = eqDouble x x ==. x == x *** QED
-
-{-@ eqDoubleSym :: x:Double -> y:Double
-                -> { eqDouble x y ==> eqDouble y x } @-}
-eqDoubleSym :: Double -> Double -> Proof
-eqDoubleSym x y = eqDouble x y ==. x == y ==. y == x *** QED
-
-{-@ eqDoubleTrans :: x:Double -> y:Double -> z:Double
-                  -> { eqDouble x y && eqDouble y z ==> eqDouble x z } @-}
-eqDoubleTrans :: Double -> Double -> Double -> Proof
-eqDoubleTrans x y z
-  =   (eqDouble x y && eqDouble y z)
-  ==. (x == y       && y == z)
-  ==. x == z
-  *** QED
-
-veqDouble :: VerifiedEq Double
-veqDouble = VEQ eqDouble eqDoubleRefl eqDoubleSym eqDoubleTrans
diff --git a/tests/pos/T1095A.hs b/tests/pos/T1095A.hs
deleted file mode 100644
--- a/tests/pos/T1095A.hs
+++ /dev/null
@@ -1,53 +0,0 @@
-{-@ LIQUID "--reflection"        @-}
-{-@ LIQUID "--max-case-expand=0" @-}
-
-module T1095A where
-
-{-@  data Foo [size] @-}
-data Foo 
-  = A Foo Foo Foo 
-  | B Foo Foo
-  | C Foo
-  | D Foo
-  | E Foo Int 
-  | F Int
-  | G Int
-  | H 
-  | I
-  | J  
-  | K
-  | L
-  | M
-  | N 
-  | X
-    
-{-@ measure size @-}
-size :: Foo -> Int
-
-{-@ size :: Foo -> Nat @-} 
-size (A x y z) = 1 + size x + size y + size z 
-size (B x y)   = 1 + size x + size y 
-size (C x)     = 1 + size x 
-size (D x)     = 1 + size x 
-size (E x _)   = 1 + size x 
-size (F _)     = 1 
-size (G _)     = 1 
-size _         = 0 
-    
-foo  :: Foo -> Foo
-foo (A X _ _) = X 
-foo (A _ X _) = X 
-foo (A _ _ X) = X 
-foo (B X _)   = X 
-foo (B _ X)   = X 
-foo (C X)     = X 
-foo (D X)     = X 
-foo (E X _)   = X 
-foo X         = X 
-foo (A x y z) = A (foo x) (foo y) (foo z)
-foo (B x y)   = B (foo x) (foo y)
-foo (C x)     = C (foo x)
-foo (D x)     = D (foo x)
-foo (E x i)   = E (foo x) i 
-foo x         = x 
-    
diff --git a/tests/pos/T1095B.hs b/tests/pos/T1095B.hs
deleted file mode 100644
--- a/tests/pos/T1095B.hs
+++ /dev/null
@@ -1,59 +0,0 @@
-{-@ LIQUID "--reflection"        @-}
-{-@ LIQUID "--max-case-expand=0" @-}
-
-module T1095B where
-
-data Foo 
-  = A Foo Foo Foo 
-  | B Foo Foo
-  | C Foo
-  | D Foo
-  | E Foo Int 
-  | F Int
-  | G Int
-  | H 
-  | I
-  | J  
-  | K
-  | L
-  | M
-  | N 
-  | X
-    
-{-@  data Foo [size] @-}
-  
-{-@ measure size         @-}
-{-@ size :: z:Foo -> Nat @-}
-size :: Foo -> Int 
-size (A x y z) = 1 + size x + size y + size z 
-size (B x y)   = 1 + size x + size y 
-size (C x)     = 1 + size x 
-size (D x)     = 1 + size x 
-size (E x _)   = 1 + size x 
-size (F _)     = 1 
-size (G _)     = 1 
-size _         = 0 
-
--- with case-expand, the below blows up into a giant
--- function spanning literally thousands of lines!
-{-@ reflect hasX @-}
-hasX :: Foo -> Bool 
-hasX (A X _ _) = True 
-hasX (A _ X _) = True 
-hasX (A _ _ X) = True 
-hasX (B X _)   = True 
-hasX (B _ X)   = True 
-hasX (C X)     = True 
-hasX (D X)     = True 
-hasX (E X _)   = True 
-hasX X         = True 
-hasX _         = False 
-
-foo  :: Foo -> Foo
-foo x | hasX x = X 
-foo (A x y z) = A (foo x) (foo y) (foo z)
-foo (B x y)   = B (foo x) (foo y)
-foo (C x)     = C (foo x)
-foo (D x)     = D (foo x)
-foo (E x i)   = E (foo x) i 
-foo x         = x 
diff --git a/tests/pos/T1095C.hs b/tests/pos/T1095C.hs
deleted file mode 100644
--- a/tests/pos/T1095C.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-{-@ LIQUID "--max-case-expand=0" @-}
-{-@ LIQUID "--no-termination"    @-}
-
-module T1095C where
-
-data Foo 
-  = A Foo 
-  | H 
-  | I
-    
-{-@ measure size       @-}
-{-@ size :: z:Foo -> {v:Nat | v = size z} @-}
-size :: Foo -> Int 
-size (A x) = 1 + size x 
-size _     = 0 
diff --git a/tests/pos/T1100.hs b/tests/pos/T1100.hs
deleted file mode 100644
--- a/tests/pos/T1100.hs
+++ /dev/null
@@ -1,39 +0,0 @@
-{-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-}
-
-module T1100 where
-
-{-@ LIQUID "--exact-data-con"                      @-}
-{-@ LIQUID "--higherorder"                         @-}
-{-@ LIQUID "--no-termination"                      @-}
-
-
-class PersistEntity record where
-    data EntityField record :: * -> *
-
-instance PersistEntity Blob where
-  {-@ data EntityField Blob 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 }
-
-{-@ data UpdateT record typ = Update { updateField :: EntityField record typ, updateValue :: typ } @-}
-data UpdateT record typ = Update
-    { updateField :: EntityField record typ
-    , updateValue :: typ
-    }
-
-{-@ createUpdate :: forall a 
 Bool>. EntityField record a
 -> a
 -> UpdateT record a
 @-}
-createUpdate :: EntityField record a -> a -> UpdateT record a
-createUpdate field value = Update {
-      updateField = field
-    , updateValue = value
-}
-
-testUpdateQuery :: () -> UpdateT Blob Int
-testUpdateQuery () = createUpdate BlobXVal 3
diff --git a/tests/pos/T1120A.hs b/tests/pos/T1120A.hs
deleted file mode 100644
--- a/tests/pos/T1120A.hs
+++ /dev/null
@@ -1,44 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-
-module T1120A where
-
-import Language.Haskell.Liquid.ProofCombinators
-
-data U1 p = U1
-data M1 i c f p = M1 { unM1 :: f p }
-data C
-data D
-type C1 = M1 C
-type D1 = M1 D
-
-data MyUnit = MyUnit deriving (Eq)
-
-data A
-data B
-type RepMyUnit = D1 A (C1 B U1)
-
-{-@ reflect fromMyUnit @-}
-fromMyUnit :: MyUnit -> RepMyUnit x_at0x
-fromMyUnit MyUnit = M1 (M1 U1)
-
-{-@ reflect toMyUnit @-}
-toMyUnit :: RepMyUnit x_at0x -> MyUnit
-toMyUnit (M1 (M1 U1)) = MyUnit
-
-{-@ fotMyUnit :: a:RepMyUnit x
-              -> { fromMyUnit (toMyUnit a) == a }
-@-}
-fotMyUnit :: RepMyUnit x_at0x -> Proof
-fotMyUnit z_at0y@(M1 (M1 U1))
-  = ((((fromMyUnit (toMyUnit z_at0y)) === (fromMyUnit MyUnit))
-      === z_at0y)
-      *** QED)
-
-{-@ tofMyUnit :: a:MyUnit
-              -> { toMyUnit (fromMyUnit a) == a }
-@-}
-tofMyUnit :: MyUnit -> Proof
-tofMyUnit z_at0y@MyUnit
-  = ((((toMyUnit (fromMyUnit z_at0y)) === (toMyUnit (M1 (M1 U1))))
-      === z_at0y)
-      *** QED)
diff --git a/tests/pos/T1126.hs b/tests/pos/T1126.hs
deleted file mode 100644
--- a/tests/pos/T1126.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-
-module T1126 where
-
-class OptEq a where
-  (==.) :: a -> a -> a
-
-instance OptEq a where
-{-@ instance OptEq a where
-      ==. :: x:a -> y:{a| x == y} -> a
-  @-}
-  (==.) x _ = x
-
-class OptEq2 a where
-  cmp :: a -> a -> a
-
-instance OptEq2 a where
-{-@ instance OptEq2 a where
-      cmp :: x:a -> y:{a| x == y} -> a
-  @-}
-  cmp x _ = x
-
-{-@ unsound :: x:Int -> {v:Int | v = x} -> Int @-}
-unsound :: Int -> Int -> Int
-unsound x y = x ==. y
-
-{-@ ok :: x:Int -> {v:Int | v = x} -> Int @-}
-ok :: Int -> Int -> Int
-ok x y = x `cmp` y
diff --git a/tests/pos/T1126a.hs b/tests/pos/T1126a.hs
deleted file mode 100644
--- a/tests/pos/T1126a.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-
-module T1126a where
-
-class OptEq a where
-  zoo :: a -> a -> a
-
-instance OptEq a where
-  {-@ instance OptEq a where
-	zoo :: x:a -> y:{a | x == y} -> a
-    @-}
-  zoo x _ = x
-
-instance OptEq Int where
-  {-@ instance OptEq Int where
-	zoo :: x:Int -> y:{Int| x == y} -> Int
-    @-}
-  zoo x _ = x
-
diff --git a/tests/pos/T1198_1.hs b/tests/pos/T1198_1.hs
deleted file mode 100644
--- a/tests/pos/T1198_1.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-module T1198_1 where
-
-{-@ data Tree [sz] @-}
-data Tree a =  Bin | Node (Tree a) (Tree a)
-
-{-@ measure sz @-}
-sz :: Tree a -> Int
-sz Bin = 0 
-sz (Node t1 t2) = 1 + sz t1 + sz  t2
diff --git a/tests/pos/T1198_2.hs b/tests/pos/T1198_2.hs
deleted file mode 100644
--- a/tests/pos/T1198_2.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-module T1198_2 where
-
-{-@ data Tree [sz] @-}
-data Tree a =  Bin | Node (Tree a)
-
-{-@ measure sz @-}
-sz :: Tree a -> Int
-sz Bin = 0 
-sz (Node t1) = 1 + sz t1
diff --git a/tests/pos/T1198_3.hs b/tests/pos/T1198_3.hs
deleted file mode 100644
--- a/tests/pos/T1198_3.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-module T1198_3 where
-
-{-@ data Tree [sz] @-}
-data Tree =  Bin | Node Tree Tree 
-
-{-@ measure sz @-}
-sz :: Tree -> Int
-sz Bin = 0 
-sz (Node t1 t2) = 1 + sz t1 + sz t2 
diff --git a/tests/pos/T1198_4.hs b/tests/pos/T1198_4.hs
deleted file mode 100644
--- a/tests/pos/T1198_4.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module T1198_4 where
-
-{-@ data Tree [sz] @-}
-data Tree a =  Node (Tree a) (Tree a)
-
-{-@ measure sz @-}
-sz :: Tree a -> Int
-sz (Node t1 t2) = 1 + sz  t1 + sz  t2
diff --git a/tests/pos/T1220.hs b/tests/pos/T1220.hs
deleted file mode 100644
--- a/tests/pos/T1220.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-{-@ LIQUID "--exactdc" @-}
-
-module T1220 where
-
-{-@ unsafe :: {t : AB | not (isA t)} -> {t /= A}  @-}
-unsafe :: AB -> ()
-unsafe t | isA t = ()
-unsafe _ = ()
-
-{-@ safe :: {t : AB | not (isA t)} -> {not (t == A)}  @-}
-safe :: AB -> ()
-safe t | isA t = ()
-safe _ = ()
-
-{-@ measure isA @-}
-{-@ assume isA :: AB -> Bool @-}
-isA :: AB -> Bool 
-isA A = True
-isA B = False
-
-
-data AB = A | B 
diff --git a/tests/pos/T1223.hs b/tests/pos/T1223.hs
deleted file mode 100644
--- a/tests/pos/T1223.hs
+++ /dev/null
@@ -1,77 +0,0 @@
-{-@ LIQUID "--exactdc" @-}
-{-@ LIQUID "--higherorder" @-}
-{-@ LIQUID "--ple-local" @-}
-{-@ infix   ++ @-}
-
-module T1223 where
-
-import Prelude hiding (reverse, (++))
-
-data Defined = Defined
-infixl 2 ^^^
-x ^^^ Defined = x 
-infixl 3 ==., ? 
-
-x ? _ = x 
-
-(==.) :: a -> a -> a 
-_ ==. x = x 
- 
-
-
-
--------------------------------------------------------------------------------
--- | Specification of reverse' ------------------------------------------------
--------------------------------------------------------------------------------
-
-{-@ specReverse' :: xs:[a] -> ys:[a] -> {reverse' xs ys = reverse xs ++ ys} @-}
-specReverse' :: [a] -> [a] -> ()
-specReverse' _ _ = undefined   
-
--------------------------------------------------------------------------------
--- | Derivation of reverse' ---------------------------------------------------
--------------------------------------------------------------------------------
-
--- LH TODO: LH is not letting you define a measure and a Haskell function
--- with the same name, for now...
-{-@ measure reverse' :: [a] -> [a] -> [a] @-}
-reverse' :: [a] -> [a] -> [a]
-{-@ reverse' :: xs:[a] -> ys:[a] -> { reverse' xs ys = reverse xs ++ ys } @-}
-reverse' [] ys 
-  =   reverse [] ++ ys 
-  ==. [] ++ ys ? specReverse' [] ys 
-  ==. ys 
-  ^^^ Defined 
-
-
-reverse' (x:xs) ys 
-  =   reverse (x:xs) ++ ys  
-  ==. (reverse xs ++ [x]) ++ ys ? specReverse' (x:xs) ys
-  ==. reverse xs ++ ([x] ++ ys) ? assoc (reverse xs) [x] ys
-  ==. reverse xs ++ (x:ys) 
-  ==. reverse' xs (x:ys)
-  ^^^ Defined 
-
--------------------------------------------------------------------------------
--- | Helpers: Definitions & Theorems Used -------------------------------------
--------------------------------------------------------------------------------
-
-{-@ reflect reverse @-}
-reverse :: [a] -> [a]
-reverse []     = []
-reverse (x:xs) = reverse xs ++ [x]
-
-{-@ reflect ++ @-}
-(++) :: [a] -> [a] -> [a]
-[]     ++ ys = ys
-(x:xs) ++ ys = x:(xs ++ ys)
-
-
-{-@ automatic-instances assoc @-}
-{-@ assoc :: xs:[a] -> ys:[a] -> zs:[a] 
-          -> { xs ++ (ys ++ zs) == (xs ++ ys) ++ zs }  @-}
-assoc :: [a] -> [a] -> [a] -> () 
-assoc [] _ _       = ()
-assoc (x:xs) ys zs = assoc xs ys zs
-
-
diff --git a/tests/pos/T1267.hs b/tests/pos/T1267.hs
deleted file mode 100644
--- a/tests/pos/T1267.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-@ LIQUID "--max-case-expand=0" @-}
-{-@ LIQUID "--exactdc" @-}
-
-module T1267 where
-
-data ABC = A | B | C 
-
-foo :: Int -> ABC -> ()
-foo 0 A  =  ()
-foo x A | x /= 0 = ()
-foo _ A = error " " 
-foo _ t = ()
diff --git a/tests/pos/T1278.hs b/tests/pos/T1278.hs
deleted file mode 100644
--- a/tests/pos/T1278.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module T1278 where
-
-data List a = Nil | Cons a (List a)
-
-sz :: List a -> Int
-sz Nil = 0
-sz (Cons _ Nil) = 1
-sz (Cons _ (Cons _ l)) = 2 + sz l
diff --git a/tests/pos/T1278_2.hs b/tests/pos/T1278_2.hs
deleted file mode 100644
--- a/tests/pos/T1278_2.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-@ LIQUID "--exact-data-cons" @-}
-
-module T1278_2 where
-
-{-@ data List [sz] @-}
-data List a = Nil | Cons a (List a)
-
-{-@ measure sz @-}
-sz :: List a -> Int
-sz Nil = 0
-sz (Cons _ Nil) = 1
-sz (Cons _ (Cons _ l)) = 2 + sz l
diff --git a/tests/pos/T1278_3.hs b/tests/pos/T1278_3.hs
deleted file mode 100644
--- a/tests/pos/T1278_3.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-module T1278_3 where
-
-data List a = Nil | Cons a (List a)
-
--- First argument constant
-mymap :: (a -> b) -> List a -> List b
-mymap f Nil = Nil
-mymap f (Cons x xs) = Cons (f x) (mymap f xs)
-
--- Lexicographic
-ack :: List () -> List () -> List ()
-ack Nil n = Cons () n
-ack (Cons () m) Nil = ack m (Cons () Nil)
-ack m'@(Cons () m) (Cons () n) = ack m (ack m' n)
diff --git a/tests/pos/T1286.hs b/tests/pos/T1286.hs
deleted file mode 100644
--- a/tests/pos/T1286.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module T1286 where
-
-{-@ fails :: {v:Bool | v} @-}
-fails =  'a' == 'a'
-
-{-@ ok :: {v:Bool | v} @-}
-ok = "a" == "a"
diff --git a/tests/pos/T1288.hs b/tests/pos/T1288.hs
deleted file mode 100644
--- a/tests/pos/T1288.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-
-module T1288 where
-
-{-@ measure foo @-}
-foo :: () -> Int
-foo _ = 10
-
-{-@ blub :: {v:Int | v = 10} @-}
-blub = foo ()
diff --git a/tests/pos/T1289a.hs b/tests/pos/T1289a.hs
deleted file mode 100644
--- a/tests/pos/T1289a.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-
-module T1289a where
-
-{-@ measure bintId @-}
-bintId :: Int -> Int
-bintId 0 = 0
-bintId x = 1
-
-{-@ zig :: n:Int -> { 0 <= bintId n && bintId n <= 1} @-}
-zig :: Int -> ()  
-zig 0 = () 
-zig n = () 
-
diff --git a/tests/pos/T1302.hs b/tests/pos/T1302.hs
deleted file mode 100644
--- a/tests/pos/T1302.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-{-# LANGUAGE EmptyDataDecls, GADTs, ExistentialQuantification #-}
-
-{-@ LIQUID "--exact-data-con" @-}
-{-@ LIQUID "--higherorder"    @-}
-
-module T1302 where
-
-data CreditCard = CreditCard { creditCardNumber :: Int, creditCardHolder :: [Char]}
-
-data EntityField a b where
-  CreditCardNumber :: EntityField CreditCard Int
-  CreditCardHolder :: EntityField CreditCard [Char]
-
-------------------------------------------------------------------------------------------
-data RefinedPersistFilter = EQUAL
-
-data RefinedFilter record typ = RefinedFilter
-    { refinedFilterField  :: EntityField record typ
-    , refinedFilterValue  :: typ
-    , refinedFilterFilter :: RefinedPersistFilter
-    } 
-
-{-@ reflect foo @-}
-foo :: RefinedPersistFilter -> Int -> RefinedFilter CreditCard Int
-foo f v = RefinedFilter CreditCardNumber v f
-
-------------------------------------------------------------------------------------------
-
diff --git a/tests/pos/T1336.hs b/tests/pos/T1336.hs
deleted file mode 100644
--- a/tests/pos/T1336.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-module T1336 where
-
-import Data.Ratio 
-
-{-@ embed Ratio * as int @-}
-
--- | You can also write: 
---
---     embed Ratio * as real 
---
---   if for some reason you need to treat the values thus.
-
-{-@ foo :: {v:Ratio Int | v /= 0} -> Bool @-}
-foo :: Ratio Int -> Bool
-foo x = y == y 
-  where 
-    y = 10 / x
diff --git a/tests/pos/T1363.hs b/tests/pos/T1363.hs
deleted file mode 100644
--- a/tests/pos/T1363.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-
-module T1363 where
-
-{-@ LIQUID "--exact-data-cons" @-}
-
-{-@ mySum :: Integer -> xs:[Integer] -> Integer / [len xs] @-}
-mySum :: Integer -> [Integer] -> Integer
-mySum z []     = z
-mySum z (x:xs) = mySum (z + x) xs
-
-{-@ reflect mySum @-}
-
-{-@ mySum' :: Integer -> xs:[Integer] -> Integer / [len xs] @-}
-mySum' :: Integer -> [Integer] -> Integer
-mySum' z []     = z
-mySum' z (x:xs) = let !z' = z + x 
-                  in mySum' z' xs
-
-{-@ reflect mySum' @-}
diff --git a/tests/pos/T1461.hs b/tests/pos/T1461.hs
deleted file mode 100644
--- a/tests/pos/T1461.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-
-module T1461 where
-
-import           Data.List                (sortBy)
-import qualified Data.List.NonEmpty       as NE
-
-foo :: NE.NonEmpty a -> Int
-foo = NE.length
diff --git a/tests/pos/T1498.hs b/tests/pos/T1498.hs
deleted file mode 100644
--- a/tests/pos/T1498.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-module T1498 where
-
-class FromTo a where 
-  from :: a -> Int 
-  to   :: Int -> a 
-
-{-@ instance FromTo Int where
-      from :: Int -> {v:Int | 0 <= v };
-      to   :: {v:Int | 0 <= v } -> Int
-@-}
-
-instance FromTo Int where 
-  from x = if 0 <= x then x else -x  
-  to   x = x 
diff --git a/tests/pos/T1543.hs b/tests/pos/T1543.hs
deleted file mode 100644
--- a/tests/pos/T1543.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-module T1543 where
-
-foo :: (Int -> Int) ->  (Int -> Int, ())
-{-@ foo :: f:(Int -> Int) ->  (g::(Int -> Int),{v:() | f == g}) @-}
-foo f = (f,()) 
diff --git a/tests/pos/T1544.hs b/tests/pos/T1544.hs
deleted file mode 100644
--- a/tests/pos/T1544.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-{-@ LIQUID "--reflection"    @-}
-module T1544 where
-
-{-@ data ThingMM = ThingMM {f :: Int -> Int, fprop :: v:Int -> {f v >= 0}} @-}
-data ThingMM =
-  ThingMM
-    { f :: Int -> Int
-    , fprop :: Int -> ()
-    }
-
-{-@ fieldLemmaPat :: t:ThingMM -> v:Int -> {f t v >= 0} @-}
-fieldLemmaPat :: ThingMM -> Int -> ()
-fieldLemmaPat (ThingMM _ fprop) i = const () $ fprop i
-
-{-@ fieldLemmaSel :: t:ThingMM -> v:Int -> {f t v >= 0} @-}
-fieldLemmaSel :: ThingMM -> Int -> ()
-fieldLemmaSel t i = const () $ fprop t i
diff --git a/tests/pos/T1547.hs b/tests/pos/T1547.hs
deleted file mode 100644
--- a/tests/pos/T1547.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-
-module T1547 where
-
-{-@ myfst :: () -> {v:((a,b) -> a) | v == fst } @-}
-myfst :: () -> (a,b) -> a 
-myfst _ = fst 
diff --git a/tests/pos/T1548.hs b/tests/pos/T1548.hs
deleted file mode 100644
--- a/tests/pos/T1548.hs
+++ /dev/null
@@ -1,48 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-
-
-module T1548 where
-
-import Language.Haskell.Liquid.Equational 
-
-
-example :: (b -> d) -> a -> b -> Proof
-{-@ example :: g:(b -> d) -> a:a -> b:b -> { snd (second g (a,b)) == snd (a,g b) } @-}
-example g a b  
-  =   snd (second g (a,b)) 
-  ==. snd (a,g b)
-  *** QED 
-
-hFun :: (b -> d)  -> Proof
-{-@ hFun :: g:(b -> d) -> { snd . second g == g . snd } @-}
-hFun g = extensionality (snd . second g) (g . snd) (h g)
-
-
-h :: (b -> d) -> (a,b) -> Proof
-{-@ h :: g:(b -> d) -> p:(a,b) -> { (snd . second g) (p) == (g . snd) (p) } @-}
-h g p =   (snd . second g) p
-      ==. snd (second g p)
-          ? sndSecond g p
-      ==. g (snd p)
-      ==. (g . snd) p
-      *** QED
-
-
-{-@ reflect second @-}
-second :: (b -> d) -> ((a,b) -> (a,d))
-second g (a,b) = (a, g b)
-
-{-@ sndSecond :: g:(b -> d) -> p:(a,b) -> { snd (second g p) == g (snd p) } @-}
-sndSecond :: (b -> d) -> (a,b) -> Proof
-sndSecond g (a,b)
-  =   snd (second g (a,b))
-  ==. snd (a,g b)
-  ==. g b
-  ==. g (snd (a,b))
-  *** QED
-
-
-
-extensionality :: (a -> b) -> (a -> b) -> (a -> ()) -> ()  
-{-@ assume extensionality :: f:(a -> b) -> g:(a -> b) -> (x:a -> {f x == g x}) ->  {f == g}  @-}
-extensionality _ _ _ = ()
diff --git a/tests/pos/T1550.hs b/tests/pos/T1550.hs
deleted file mode 100644
--- a/tests/pos/T1550.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-
-module T1550 where
-
-import Language.Haskell.Liquid.Equational
-
-{-@ reflect bar @-}
-{-@ reflect foo @-}
-{-@ reflect zoo @-}
-
-bar, foo, zoo :: Int -> Int -> Int 
-
-bar x y = x 
-foo = bar 
-zoo x = bar x 
-
-
-{-@ fooId :: x:Int -> y:Int -> { foo x y = x } @-}
-fooId :: Int -> Int  -> Proof 
-fooId x y = foo x y ==. bar x y ==. x *** QED 
-
-
-{-@ barId :: x:Int -> y:Int -> { bar x y = x } @-}
-barId :: Int -> Int  -> Proof 
-barId x y = bar x y ==. x *** QED 
-
-{-@ zooId :: x:Int -> y:Int -> { bar x y = x } @-}
-zooId :: Int -> Int  -> Proof 
-zooId x y = zoo x y ==. bar x y ==. x *** QED 
diff --git a/tests/pos/T1555.hs b/tests/pos/T1555.hs
deleted file mode 100644
--- a/tests/pos/T1555.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--rankNTypes" @-}
-{-# LANGUAGE RankNTypes   #-}
-
-module T1555 where
-
-import Language.Haskell.Liquid.Equational 
-
-type ForAll a  = forall z. a
-data Wrapper a = Wrapper (ForAll a)
- 
-foo :: ForAll a -> ForAll a  -> Proof
-{-@ foo :: ff:ForAll a -> gg:{ForAll a | ff == gg } -> { Wrapper ff == Wrapper gg } @-} 
-foo g f = Wrapper g ==. Wrapper f *** QED 
diff --git a/tests/pos/T1556.hs b/tests/pos/T1556.hs
deleted file mode 100644
--- a/tests/pos/T1556.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module T1556 where
-
-{-@ type Alias a b = (a,b) @-}
-type Alias a b = (a,b)
-
-{-@ foo :: Alias (a,b) a @-}
-foo ::  Alias (a,b) a
-foo = undefined 
diff --git a/tests/pos/T1560.hs b/tests/pos/T1560.hs
deleted file mode 100644
--- a/tests/pos/T1560.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-{-@ LIQUID "--ple"        @-}
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--extensionality" @-}
-
-module T1560 where
-
-k :: a -> b -> b
-k _ b = b
-
-{-@ reflect f @-}
-f :: Int -> Int -> Int
-f x y = x + y
-
-{-@ reflect g @-}
-g :: Int -> Int -> Int
-g = f
-
-{-@ fgeqxy :: x:Int -> y:Int -> {f x y = g x y} @-}
-fgeqxy :: Int -> Int -> ()
-fgeqxy x y = g x y `k` f x y `k` ()
-
-{-@ fgeqx :: x:Int -> {f x = g x} @-}
-fgeqx :: Int -> ()
-fgeqx x = f x `k` g x `k` ()
-
-{-@ fgeq :: {f = g} @-}
-fgeq :: ()
-fgeq = f `k` g `k` ()
diff --git a/tests/pos/T1560B.hs b/tests/pos/T1560B.hs
deleted file mode 100644
--- a/tests/pos/T1560B.hs
+++ /dev/null
@@ -1,24 +0,0 @@
-{-@ LIQUID "--ple"        @-}
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--extensionality" @-}
-
-module T1560B where
-
-k :: a -> b -> b
-k _ b = b
-
-{-@ reflect f @-}
-f :: Int -> Int
-f x = x + 1
-
-{-@ reflect g @-}
-g :: Int -> Int -> Int
-g x = f
-
-{-@ fgeqxy :: x:Int -> y:Int -> {f y = g x y} @-}
-fgeqxy :: Int -> Int -> ()
-fgeqxy x y = g x y `k` f y `k` ()
-
-{-@ fgeqx :: x:Int -> {f = g x} @-}
-fgeqx :: Int -> ()
-fgeqx x = f `k` g x `k` ()
diff --git a/tests/pos/T1567.hs b/tests/pos/T1567.hs
deleted file mode 100644
--- a/tests/pos/T1567.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-{-# LANGUAGE RankNTypes    #-}
-{-# LANGUAGE TypeOperators #-}
-
-module T1567 where
-
- {-@ infixr 1 ==> @-} 
- infixr 1 ==> 
- type f ==> g = forall z. f z -> g z 
-  
-
-
- test ::  (f ==> g) -> f x -> f y -> ()
- {-@ test :: g:(f ==> g) -> f x -> f y -> ()  @-} 
- test _ _ _ = () 
diff --git a/tests/pos/T1568.hs b/tests/pos/T1568.hs
deleted file mode 100644
--- a/tests/pos/T1568.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-module T1568 where
-
-    {-@ data IdentityT m a = IdentityT (m a) @-}
-    data IdentityT m a = IdentityT (m a)
-    
-    class MyMonad m where
-      myReturn :: a -> m a
-    
-    {-@
-    instance MyMonad (IdentityT m) where
-      myReturn :: a -> IdentityT m a
-    @-}
-    instance MyMonad (IdentityT m) where
-      myReturn = undefined
-    
-    -- When using the real Monad class the error doesn't happen until return is
-    -- actually used for some reason
-    {-@ testMyReturn :: a -> IdentityT m a @-}
-    testMyReturn :: a -> IdentityT m a
-    testMyReturn x = myReturn x
diff --git a/tests/pos/T1571.hs b/tests/pos/T1571.hs
deleted file mode 100644
--- a/tests/pos/T1571.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module T1571 where
-
-  data TaggedT m a = TaggedT (m a)
-  
-  class MonadController m where
-    respond :: a -> m ()
-  
-  {-@
-  instance MonadController m => MonadController (TaggedT m) where
-    respond :: a -> TaggedT m ()
-  @-}
-  instance MonadController m => MonadController (TaggedT m) where
-    respond = undefined
diff --git a/tests/pos/T1577.hs b/tests/pos/T1577.hs
deleted file mode 100644
--- a/tests/pos/T1577.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-{-@ LIQUID "--reflection"     @-}
-{-@ LIQUID "--extensionality" @-}
-{-@ LIQUID "--ple"            @-}
-
-module T1577 where
-
--- | 1 . ints
-
-{-@ reflect plus1 @-}
-{-@ reflect plus1' @-}
-plus1, plus1' :: Int -> Int 
-plus1 x = x + 1 
-plus1' x = 1 + x
-
-{-@ thm1 :: () -> { plus1' == plus1 } @-}
-thm1 :: () -> ()
-thm1 _ = () 
-
-{-@ reflect first @-}
-first :: (a -> b) -> (a, c) -> (b, c)
-first f (x,y) = (f x, y)
-
--- | 2. compose
-
-{-@ thm2 :: f:(a -> b) -> g:(b -> c) -> { (first g) . (first f) == first (g . f) } @-}
-thm2 :: (a -> b) -> (b -> c) -> ()
-thm2 _ _ = ()
-
--- | 3. imply 
-
-{-@ thm3 :: f:(a -> b) -> g:(a -> b) -> { first f == first g => f == g } @-}
-thm3 :: (a -> b) -> (a -> b) -> ()
-thm3 _ _ = ()
diff --git a/tests/pos/T1593.hs b/tests/pos/T1593.hs
deleted file mode 100644
--- a/tests/pos/T1593.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-
-module T1593 where
-
-{-@ LIQUID "--reflection"     @-}
-
--- not ok
-data Thing0 m = Thing
-  { t0 :: (m Int -> Int) -> Int
-  }
-
--- not ok
-data Thing1 m = Thing1
-  { t1 :: (Int -> m Int) -> Int
-  }
-
--- ok
-data Thing2 m = Thing2
-  { t2 :: Int -> m Int -> Int
-  }
diff --git a/tests/pos/T1595.hs b/tests/pos/T1595.hs
deleted file mode 100644
--- a/tests/pos/T1595.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-
-module T1595 where
-
-{-@ LIQUID "--reflection" @-}
-
-data Map k v = Tip | Map k v (Map k v)
-
-{-@ reflect mapEmpty @-}
-mapEmpty :: Map k v 
-mapEmpty = Tip 
-
-
-{-@
-data MultiSet a = MultiSet {
-    posMultiSet :: Map a {v:Integer | v > 0 }
-  }
-@-}
-data MultiSet a = MultiSet {
-    posMultiSet :: Map a Integer -- ^ Map for elements currently in the set.
-  }
-
-
-{-@ empty :: MultiSet a @-}
-empty :: MultiSet a
-empty = MultiSet mapEmpty
diff --git a/tests/pos/T1597.hs b/tests/pos/T1597.hs
deleted file mode 100644
--- a/tests/pos/T1597.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-
-module T1597 where
-
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-
-{-@ reflect plus @-}
-plus :: Double -> Double -> Double
-plus x y = x + y
-
-{-@ reflect rdiv @-}
-{-@ rdiv :: Double -> {v:Double | v /= 0 } -> Double @-}
-rdiv :: Double -> Double -> Double 
-rdiv x y = x / y
diff --git a/tests/pos/T1603.hs b/tests/pos/T1603.hs
deleted file mode 100644
--- a/tests/pos/T1603.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-@ LIQUID "--reflect" @-}
-
-module T1603 where
-
-{-@ reflect rAnd @-}
-rAnd :: Bool
-rAnd = and [True,False,True]
-
-{-@ reflect rOr @-}
-rOr :: Bool
-rOr = or [True,False,True]
-
diff --git a/tests/pos/T1633.hs b/tests/pos/T1633.hs
deleted file mode 100644
--- a/tests/pos/T1633.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-{-# OPTIONS_GHC -Wno-missing-methods #-}
-{-# LANGUAGE GADTs               #-}
-{-# LANGUAGE DeriveAnyClass      #-}
-{-@ LIQUID "--max-case-expand=0" @-}
-{-@ LIQUID "--no-totality"       @-}
-
-module T1633 where
-
-import Data.Void
-
-data Relation a b where
-  Empty :: Relation Void Void
-  One :: Int -> Relation () ()
-  Join :: Relation c b -> Relation d b -> Relation (Either c d) b
-  Fork :: Relation a c -> Relation a d -> Relation a (Either c d)
-  deriving (Num)
--- Here I use a type 'Natural 0 1' but I wanted to try and refine the GADT.
-{-@
-data Relation a b where
-  Empty :: Relation Void Void
-  One :: {v:Int | v = 0 || v = 1} -> Relation () ()
-  Join :: Relation c b -> Relation d b -> Relation (Either c d) b
-  Fork :: Relation a c -> Relation a d -> Relation a (Either c d)
-@-}
-
--- (Eq, Num, Ord, etc.. instances ...)
-
-comp :: Relation b c -> Relation a b -> Relation a c
-comp Empty Empty           = Empty
-comp (One a) (One b)       = One (a * b)
-comp (Join a b) (Fork c d) = comp a c + comp b d         -- Divide-and-conquer law
-comp (Fork a b) c          = Fork (comp a c) (comp b c) -- Fork fusion law
-comp c (Join a b)          = Join (comp c a) (comp c b)  -- Join fusion law
diff --git a/tests/pos/T1634.hs b/tests/pos/T1634.hs
deleted file mode 100644
--- a/tests/pos/T1634.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-{-@ LIQUID "--reflection" @-} 
-{-@ LIQUID "--ple"        @-} 
-
-module T1634 where
-
-import Language.Haskell.Liquid.ProofCombinators 
-type Reader a b = a -> b
-
-data EqT a = EqSMT a a  
-   
-{-@ assume eqSMT :: x:a -> y:{a | x == y } ->  EqT a @-}
-eqSMT :: a -> a -> EqT a
-eqSMT = EqSMT
-
-{-@ reflect fmapReader @-}
-fmapReader :: (a -> b) -> (r -> a) -> (Reader r b)
-fmapReader fab fra r = fab (fra r)
-
-{-@ reflect myid @-}
-myid :: a -> a 
-myid x = x 
-
-helper2 :: Reader r a -> r -> EqT a
-helper2 r a = eqSMT (fmapReader myid r a) (myid (r a))
-
diff --git a/tests/pos/T1636.hs b/tests/pos/T1636.hs
deleted file mode 100644
--- a/tests/pos/T1636.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple"        @-}
-
-module T1636 where
-
-data RA a  = RA  
-
-
-{-@ type RRA a E1 E2 = {v:RA a | E1 == E2} @-}
-
-
-{-@ assume eqRTCtx :: f:a -> g:a  -> RRA a {f} {g} -> ctx:(a -> b) -> RRA b {ctx f} {ctx g}  @-}
-eqRTCtx ::  a -> a -> RA a -> (a -> b) -> RA b
-eqRTCtx _f _g _pf _ctx = undefined  
-
-fEqG0BadDomain :: Integer -> RA Integer
-fEqG0BadDomain x = RA
-
-{-@ reflect f @-}
-f :: Integer -> Integer 
-f x = x + 1 
-
-{-@ reflect g @-}
-g :: Integer -> Integer 
-g x = x + 1 
diff --git a/tests/pos/T1642.hs b/tests/pos/T1642.hs
deleted file mode 100644
--- a/tests/pos/T1642.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-{-@ LIQUID "--reflection" @-} 
-{-# LANGUAGE GADTs          #-}
-{-# LANGUAGE KindSignatures #-}
-
-module T1642 where
- 
-data A  :: * -> *  where 
-   A  :: Eq a => a -> () -> A a 
- 
diff --git a/tests/pos/T1642A.hs b/tests/pos/T1642A.hs
deleted file mode 100644
--- a/tests/pos/T1642A.hs
+++ /dev/null
@@ -1,31 +0,0 @@
-{-@ LIQUID "--reflection" @-} 
-
-{-# LANGUAGE RankNTypes     #-}
-{-# LANGUAGE GADTs          #-}
-{-# LANGUAGE KindSignatures #-}
-
-module T1642A where
-
-
-{-@ measure eqT :: a -> a -> Bool @-}
-{-@ type EqRT a E1 E2 = {v:EqT a | eqT E1 E2} @-}
-
-{-@ eqFun :: f:(a -> b) -> g:(a -> b) 
-          -> (x:a -> {v:EqT b | eqT (f x) (g x)}) -> EqRT (a -> b) {f} {g}  @-}
-eqFun :: (a -> b) -> (a -> b) -> (a -> EqT b) -> EqT (a -> b)
-eqFun = EqFun
-
-
-{-@ eqSMT :: Eq a => x:a -> y:a -> {v:() | x == y} -> EqRT a {x} {y} @-}
-eqSMT :: Eq a => a -> a -> () -> EqT a
-eqSMT = EqSMT 
-
-{-@
-data EqT :: * -> * where 
-   EqSMT  :: Eq a => x:a -> y:a -> {v:() | x == y} -> EqRT a {x} {y}   
-   EqFun  :: f:(a -> b) -> g:(a -> b) -> (x:a -> {v:EqT b | eqT (f x) (g x)}) -> EqRT (a -> b) {f} {g}
-@-}
-
-data EqT :: * -> *  where 
-   EqSMT  :: Eq a => a -> a -> () -> EqT a   
-   EqFun  :: (a -> b) -> (a -> b) -> (a -> EqT b) -> EqT (a -> b)  
diff --git a/tests/pos/T1647.hs b/tests/pos/T1647.hs
deleted file mode 100644
--- a/tests/pos/T1647.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# LANGUAGE GADTs        #-}
-{-@ LIQUID "--reflection" @-} 
-
-module T1647 where
-
-{-@ type ExtTR a E1 E2 = {v:ExtT a | E1 == E2 } @-}
-
-data ExtT b  where 
-   ExtT  :: (a -> b) -> ExtT b 
-
-{-@ data ExtT b where 
-      ExtT  :: (a -> b) -> ExtT b 
-@-}   
-
-prop :: a -> a -> ExtT a -> ExtT a
-{-@ prop :: x:a -> y:a-> ExtTR a {x} {y} -> ExtTR a {x} {y} @-}
-prop f g (ExtT ctx) = ExtT ctx   
diff --git a/tests/pos/T1649MeasuresDef.hs b/tests/pos/T1649MeasuresDef.hs
deleted file mode 100644
--- a/tests/pos/T1649MeasuresDef.hs
+++ /dev/null
@@ -1,55 +0,0 @@
-{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
-{-# LANGUAGE RankNTypes      #-}
-{-# LANGUAGE GADTs           #-}
-{-# LANGUAGE KindSignatures  #-}
-
-{-@ LIQUID "--reflection" @-}
-
--- Z3 encoding cannot be used until this is fixed:
--- https://github.com/Z3Prover/z3/issues/3930
-{- LIQUID "--no-adt"         @-}
-{-@ LIQUID "--ple-local"      @-}
-{-@ LIQUID "--prune-unsorted" @-}
-
-module T1649MeasuresDef where
-
-
-
-{-@ assume injectiveEqRTFun :: x:(a->b) -> y:(a->b) -> d:{EqRT (a->b) {x} {y} | isEqFun d}
-                         -> {x = eqFunX d && y = eqFunY d} @-}
-injectiveEqRTFun :: (a->b) -> (a->b) -> EqT (a->b) -> ()
-injectiveEqRTFun _ _ _ = ()
-
-
-{-@ measure isEqFun @-}
-isEqFun :: EqT a -> Bool
-isEqFun (EqFun _ _ _) = True
-isEqFun _             = False
-
-{-@ reflect eqFunX @-}
-{-@ eqFunX :: {d:EqT (a -> b) | isEqFun d} -> (a -> b) @-}
-eqFunX :: EqT (a -> b) ->  (a -> b)
-eqFunX (EqFun x _ _) = x
-
-{-@ reflect eqFunY @-}
-{-@ eqFunY :: {d:EqT (a -> b) | isEqFun d} -> (a -> b) @-}
-eqFunY :: EqT (a -> b) ->  (a -> b)
-eqFunY (EqFun _ y _) = y
-
-
-{-@ ple     eqFunP @-}
-{-@ reflect eqFunP @-}
-{-@ eqFunP :: d:{EqT (a -> b) | isEqFun d} -> (x:a -> EqRT b {eqFunX d x} {eqFunY d x}) @-}
-eqFunP :: EqT (a -> b) ->  (a -> EqT b)
-eqFunP (EqFun _ _ p) = p
-
-
-data EqT  :: * -> *  where
-   EqFun  :: (a -> b) -> (a -> b) -> (a -> EqT b) -> EqT (a -> b)
-
-{-@ data EqT  :: * -> *  where
-     EqFun  :: ff:(a -> b) -> gg:(a -> b) -> (x:a -> EqRT b {ff x} {gg x}) -> EqRT (a -> b) {ff} {gg}
-@-}
-
-
-{-@ type EqRT a E1 E2 = {v:EqT a | E1 = E2} @-}
diff --git a/tests/pos/T1649WorkTypes.hs b/tests/pos/T1649WorkTypes.hs
deleted file mode 100644
--- a/tests/pos/T1649WorkTypes.hs
+++ /dev/null
@@ -1,62 +0,0 @@
-{-# LANGUAGE RankNTypes      #-}
-{-# LANGUAGE GADTs           #-}
-{-# LANGUAGE KindSignatures  #-}
-{-@ LIQUID "--reflection" @-} 
--- Z3 encoding cannot be used until this is fixed: 
--- https://github.com/Z3Prover/z3/issues/3930
-{- LIQUID "--no-adt"         @-} 
-{-@ LIQUID "--ple-local"      @-} 
-
-module T1649WorkTypes where
-
-
-{-@ assume injectiveEqRTFun :: x:(a->b) -> y:(a->b) -> d:{EqRT (a->b) {x} {y} | isEqFun d} 
-                         -> {x = eqFunX d && y = eqFunY d} @-}
-injectiveEqRTFun :: (a->b) -> (a->b) -> EqT (a->b) -> () 
-injectiveEqRTFun _ _ _ = () 
-
-{-@ measure isEqFun @-}
-isEqFun :: EqT a -> Bool 
-isEqFun (EqFun _ _ _) = True 
-isEqFun _             = False 
-
-{-@ reflect eqFunX @-}
-{-@ eqFunX :: {d:EqT (a -> b) | isEqFun d} -> (a -> b) @-}
-eqFunX :: EqT (a -> b) ->  (a -> b) 
-eqFunX (EqFun x _ _) = x 
-
-{-@ reflect eqFunY @-}
-{-@ eqFunY :: {d:EqT (a -> b) | isEqFun d} -> (a -> b) @-}
-eqFunY :: EqT (a -> b) ->  (a -> b) 
-eqFunY (EqFun _ y _) = y 
-
-
-{-@ ple     eqFunP @-}
-{- reflect eqFunP @-}
--- STATUS: assertion passes, but result type still fails 
-{-@ eqFunP :: d:{EqT (a -> b) | isEqFun d} -> x:a -> EqT b @-}
-eqFunP :: EqT (a -> b) ->  a -> EqT b
-eqFunP (EqFun f g p) x = assert (eqT (f x) (g x)) (p x)  
-
-
-assert :: Bool -> a -> a 
-{-@ assert :: {b:Bool | b} -> x:a -> {v:a | v == x && b} @-}
-assert _ x = x 
-
-{-@ assume eqT :: x:a -> y:a -> {v:Bool | v <=> eqT x y} @-}
-eqT :: a -> a -> Bool 
-eqT = undefined 
-
-
-{-@ measure eqT :: a -> a -> Bool @-}
-{-@ type EqRT a E1 E2 = {v:EqT a | eqT E1 E2} @-}
-
-
-data EqT  :: * -> *  where 
-   EqSMT  :: Eq a => a -> a -> (a -> [a]) -> EqT a 
-   EqFun  :: (a -> b) -> (a -> b) -> (a -> EqT b) -> EqT (a -> b)
-
-{-@ data EqT  :: * -> *  where 
-        EqSMT  :: Eq a => x:a -> y:a -> (a -> {v:[a] | 0 < len v}) -> EqRT a {x} {y}
-        EqFun  :: ff:(a -> b) -> gg:(a -> b) -> (x:a -> {d:EqT b | eqT (ff x) (gg x)}) -> EqRT (a -> b) {ff} {gg}
-@-}   
diff --git a/tests/pos/T1657.hs b/tests/pos/T1657.hs
deleted file mode 100644
--- a/tests/pos/T1657.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-
-module T1657 where
-
-{-@ data I  Bool> = I Int @-}
-
-data I = I Int
-{-@ getI :: forall  Bool>. 
-             { bloop :: Int  |- {v: Int | v = bloop} <: {v:Int | v > 1984} }
-             I 
-@-}
-getI :: I
-getI = undefined 
-
-{-@ pleaseFail :: I<{\v -> v > 1984}> @-}
-pleaseFail :: I
-pleaseFail = getI
diff --git a/tests/pos/T1660.hs b/tests/pos/T1660.hs
deleted file mode 100644
--- a/tests/pos/T1660.hs
+++ /dev/null
@@ -1,48 +0,0 @@
-{-# LANGUAGE RankNTypes      #-}
-{-# LANGUAGE GADTs           #-}
-{-# LANGUAGE KindSignatures  #-}
-
-{-@ LIQUID "--reflection"  @-} 
-{-@ LIQUID "--ple"         @-}
-{-@ LIQUID "--fast"        @-}
-
-module T1660 where
-
-import Language.Haskell.Liquid.ProofCombinators
-import Prelude hiding (id, fmap)
-
-{-@ measure eqT :: a -> a -> Bool @-}
-{-@ type EqRT a E1 E2 = {v:EqT a | eqT E1 E2} @-}
-
-data EqT  :: * -> *  where 
-   EqSMT  :: Eq a => a -> a -> () -> EqT a 
-   EqFun  :: (a -> b) -> (a -> b) -> (a -> EqT b) -> EqT (a -> b)
-
-{-@ data EqT  :: * -> *  where 
-       EqSMT  :: Eq a => x:a -> y:a -> {v:() | x == y} -> EqRT a {x} {y}
-       EqFun  :: ff:(a -> b) -> gg:(a -> b) -> (x:a -> {v:EqT b | eqT (ff x) (gg x)}) -> EqRT (a -> b) {ff} {gg}
-@-}   
-
-
-type Reader a b = a -> b
-
-
-
-functorLaw_identity :: Eq a => EqT (Reader r a -> Reader r a)
-{-@ functorLaw_identity :: Eq a -> EqRT (Reader r a -> Reader r a) (fmap id) id @-}
-functorLaw_identity =
-  EqFun (fmap id) id
-  (\r -> EqFun (fmap id r) (id r)
-    (\a -> EqSMT (fmap id r a) (id r a? lemmaId r a) ()))
-
-{-@ reflect id @-}
-id :: a -> a 
-id x = x
-
-{-@ reflect fmap @-}
-fmap :: (a -> b) -> Reader r a -> Reader r b
-fmap fab fra = \r -> fab (fra r)
-
-lemmaId :: Eq b => (a -> b) -> a -> ()
-{-@ lemmaId :: f:(a -> b) -> x:a -> {id f x = id (f x) } @-}
-lemmaId _ _ = ()
diff --git a/tests/pos/T1669.hs b/tests/pos/T1669.hs
deleted file mode 100644
--- a/tests/pos/T1669.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-{-@ LIQUID "--no-totality" @-}
-
-module T1669 where
-import           Prelude                 hiding ( Semigroup
-                                                , mappend
-                                                )
-
-data PNat = Z | S PNat
-
-{-@ data Semigroup a = CSemigroup {mappend :: a -> a -> a} @-}
-data Semigroup a = CSemigroup {mappend :: a -> a -> a}
-
-{-@ reflect cmappend  @-}
-cmappend :: PNat -> PNat -> PNat
-cmappend Z     n = n
-cmappend (S m) n = S (cmappend m n)
-
-{-@ reflect semigroupPNat  @-}
-semigroupPNat :: Semigroup PNat
-semigroupPNat = CSemigroup cmappend
-
-
-{-@ clawAssociative :: v:PNat -> v':PNat -> v'':PNat  
-      -> { mappend semigroupPNat (mappend semigroupPNat v v') v'' == mappend semigroupPNat v (mappend semigroupPNat v' v'')}@-}
-clawAssociative :: PNat -> PNat -> PNat -> ()
-clawAssociative Z     _ _ = ()
--- clawAssociative (S p) m n = clawAssociative p m n
diff --git a/tests/pos/T1670A.hs b/tests/pos/T1670A.hs
deleted file mode 100644
--- a/tests/pos/T1670A.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-{-# LANGUAGE TypeFamilies #-}
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-{-@ LIQUID "--ple-with-undecided-guards" @-}
-
-module T1670A where
-
-data LWW t a = LWW {
-    lwwTime  :: t
-  , lwwValue :: a
-  }
-
-{-@ reflect cenabledLWW @-}
-cenabledLWW :: Ord t => LWW t a -> LWW t a -> Bool
-cenabledLWW (LWW t1 _) (LWW t2 _) = t1 /= t2
-
-
-{-@ reflect capplyLWW @-}
-capplyLWW :: Ord t => LWW t a -> LWW t a -> LWW t a
-capplyLWW l1@(LWW t1 _) l2@(LWW t2 _) 
-     | t1 > t2   = l1
-     | otherwise = l2
-
-{-@ clawCommutativityLWW :: Ord t => x : (LWW t a) -> op1 : LWW t a -> op2 : LWW t a -> {(cenabledLWW x op1 && cenabledLWW x op2  && cenabledLWW (capplyLWW x op1) op2 && cenabledLWW (capplyLWW x op2) op1) => capplyLWW (capplyLWW x op1) op2 == capplyLWW (capplyLWW x op2) op1} @-}
-clawCommutativityLWW :: Ord t => LWW t a -> LWW t a -> LWW t a -> ()
-clawCommutativityLWW x@(LWW t0 v0) op1@(LWW t1 v1) op2@(LWW t2 v2) = ()
diff --git a/tests/pos/T1670B.hs b/tests/pos/T1670B.hs
deleted file mode 100644
--- a/tests/pos/T1670B.hs
+++ /dev/null
@@ -1,31 +0,0 @@
-{-# LANGUAGE TypeFamilies #-}
-
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-{-@ LIQUID "--ple-with-undecided-guards" @-}
-
-module T1670B where
-
-data LWW t a = LWW {
-    lwwTime  :: t
-  , lwwValue :: a
-  }
-
-type family Operation t
-
-type instance Operation (LWW t a) = LWW t a
-
-{-@ reflect cenabledLWW @-}
-cenabledLWW :: Ord t => LWW t a -> Operation (LWW t a) -> Bool
-cenabledLWW (LWW t1 _) (LWW t2 _) = t1 /= t2
-
-
-{-@ reflect capplyLWW @-}
-capplyLWW :: Ord t => LWW t a -> Operation (LWW t a) -> LWW t a
-capplyLWW l1@(LWW t1 _) l2@(LWW t2 _) 
-     | t1 > t2   = l1
-     | otherwise = l2
-
-{-@ clawCommutativityLWW :: Ord t => x : (LWW t a) -> op1 : Operation (LWW t a) -> op2 : Operation (LWW t a) -> {(cenabledLWW x op1 && cenabledLWW x op2  && cenabledLWW (capplyLWW x op1) op2 && cenabledLWW (capplyLWW x op2) op1) => capplyLWW (capplyLWW x op1) op2 == capplyLWW (capplyLWW x op2) op1} @-}
-clawCommutativityLWW :: Ord t => LWW t a -> Operation (LWW t a) -> Operation (LWW t a) -> ()
-clawCommutativityLWW x@(LWW t0 v0) op1@(LWW t1 v1) op2@(LWW t2 v2) = ()
diff --git a/tests/pos/T1697.hs b/tests/pos/T1697.hs
deleted file mode 100644
--- a/tests/pos/T1697.hs
+++ /dev/null
@@ -1,58 +0,0 @@
-{-@ LIQUID "--no-pattern-inline" @-}
-
-module T1697 where
-
-data User = U
-
-{-@ measure currentUser :: User @-}
-
-{-@ data TaggedT user m a 
) | True}}
-    {{v : (user) | True} <: {v : (user
) | True}}
-    {{v : (user) | True} <: {v : (user) | True}}
-    {{v : (user) | True} <: {v : (user) | True}}
-    {{v : (user) | True} <: {v : (user) | True}}
-    x:TaggedT user m (a)
-    -> (y:a -> TaggedT user m (b))
-    -> TaggedT user m (b);
-
-  return :: a -> TaggedT<{\_ -> True}, {\_ -> False}> user m a
-@-}
-instance Monad m =>  Monad (TaggedT user m) where
-  x >>= f = TaggedT $ unTag x >>= \y -> unTag (f y)
-  
--------------------------------------------------------------------------------------------
--- | Test
--------------------------------------------------------------------------------------------
-
-{-@ assume respondT :: String -> TaggedT<{\_ -> True}, {\v -> v == currentUser}> User m () @-}
-respondT :: String -> TaggedT User m ()
-respondT = undefined
-
-{-@ test :: TaggedT<{\_ -> True}, {\v -> v == currentUser}> User m () @-}
-test :: Monad m => TaggedT User m ()
-test = return "a" >>= respondT
diff --git a/tests/pos/T1697A.hs b/tests/pos/T1697A.hs
deleted file mode 100644
--- a/tests/pos/T1697A.hs
+++ /dev/null
@@ -1,60 +0,0 @@
--------------------------------------------------------------------------------------------
--- | Fixed User (WORKING)
--------------------------------------------------------------------------------------------
-
-module T1697A where
-
-data User = U
-
-{-@ measure currentUser :: User @-}
-
-{-@ data TaggedT m a 
) | True}}
-    {{v : (User) | True} <: {v : (User
) | True}}
-    {{v : (User) | True} <: {v : (User) | True}}
-    {{v : (User) | True} <: {v : (User) | True}}
-    {{v : (User) | True} <: {v : (User) | True}}
-    x:TaggedT m (a)
-    -> (y:a -> TaggedT m (b))
-    -> TaggedT m (b);
-
-  return :: a -> TaggedT<{\_ -> True}, {\_ -> False}> m a
-@-}
-instance Monad m => Monad (TaggedT m) where
-  x >>= f = TaggedT $ unTag x >>= \y -> unTag (f y)
-  
--------------------------------------------------------------------------------------------
--- | Test
--------------------------------------------------------------------------------------------
-
-{-@ assume respondT :: String -> TaggedT<{\_ -> True}, {\v -> v == currentUser}> m () @-}
-respondT :: String -> TaggedT m ()
-respondT = undefined
-
-{-@ test :: TaggedT<{\_ -> True}, {\v -> v == currentUser}> m () @-}
-test :: Monad m => TaggedT m ()
-test = return "a" >>= respondT
diff --git a/tests/pos/T1697C.hs b/tests/pos/T1697C.hs
deleted file mode 100644
--- a/tests/pos/T1697C.hs
+++ /dev/null
@@ -1,54 +0,0 @@
--------------------------------------------------------------------------------------------
--- | Polymorphic user but defining bind and return as normal functions (WORKING)
--------------------------------------------------------------------------------------------
-
-module T1697C where
-
-data User = U
-
-{-@ measure currentUser :: User @-}
-
-{-@ data TaggedT user m a 
) | True}}
-    {{v : (user) | True} <: {v : (user
) | True}}
-    {{v : (user) | True} <: {v : (user) | True}}
-    {{v : (user) | True} <: {v : (user) | True}}
-    {{v : (user) | True} <: {v : (user) | True}}
-    x:TaggedT user m (a)
-    -> (y:a -> TaggedT user m (b))
-    -> TaggedT user m (b)
-@-}
-bindT :: Monad m => TaggedT user m a -> (a -> TaggedT user m b) -> TaggedT user m b
-bindT x f = TaggedT $ unTag x >>= \y -> unTag (f y)
-
-{-@ assume returnT :: a -> TaggedT<{\_ -> True}, {\_ -> False}> user m a @-}
-returnT :: Monad m => a -> TaggedT user m a
-returnT x = TaggedT (return x)
-
--------------------------------------------------------------------------------------------
--- | Test
--------------------------------------------------------------------------------------------
-
-{-@ assume respondT :: String -> TaggedT<{\_ -> True}, {\v -> v == currentUser}> User m () @-}
-respondT :: String -> TaggedT User m ()
-respondT = undefined
-
-{-@ test :: TaggedT<{\_ -> True}, {\v -> v == currentUser}> User m () @-}
-test :: Monad m => TaggedT User m ()
-test = returnT "a" `bindT` respondT
diff --git a/tests/pos/T1709.hs b/tests/pos/T1709.hs
deleted file mode 100644
--- a/tests/pos/T1709.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module T1709 where
-
-{-@ incr :: x:Int -> {v:Int | x < v } @-}
-incr :: Int -> Int 
-incr x = x + 1
-
-{-@ fail decr @-}
-{-@ decr :: x:Int -> {v:Int | x < v } @-}
-decr :: Int -> Int 
-decr x = x - 1
diff --git a/tests/pos/T1749.hs b/tests/pos/T1749.hs
deleted file mode 100644
--- a/tests/pos/T1749.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-{-@ LIQUID "--ple" @-}
-{-@ LIQUID "--reflection" @-}
-module T1749 where
-
-data Value = B Bool | I Int
-
-data Op = IF Op Op | NOP
-
-{-@ reflect run @-}
-{-@ run ::
-         op : Op
-      -> { is : [Value] | isValid op (stackType is) }
-      -> [Value] @-}
-run :: Op -> [Value] -> [Value]
-run (IF o1 o2) ((B True):s)  = run o1 s
-run (IF o1 o2) ((B False):s) = run o2 s
-run NOP s                    = s
-
-data StackType =
-    AnyStack
-  | IntValueAnd  StackType
-  | BoolValueAnd StackType
-
-{-@ reflect stackType @-}
-stackType :: [Value] -> StackType
-stackType []         = AnyStack
-stackType ((I _):xs) = IntValueAnd (stackType xs)
-stackType ((B _):xs) = BoolValueAnd (stackType xs)
-
-{-@ reflect isValid @-}
-isValid :: Op -> StackType -> Bool
-isValid (IF lhs rhs)  (BoolValueAnd s)              = isValid lhs s && isValid rhs s
-isValid NOP           _                             = True
-isValid _             _                             = False
diff --git a/tests/pos/T1761.hs b/tests/pos/T1761.hs
deleted file mode 100644
--- a/tests/pos/T1761.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-
-module T1761 where
-
-{-@ inline oneFunPred @-}
-oneFunPred :: Int -> Bool
-oneFunPred x = x == 1
-
-{-@ type OneTyAlias a = {v:a | oneFunPred v} @-}
-
-{-@ data One = One { field :: OneTyAlias Int }  @-}
-data One = One Int
diff --git a/tests/pos/T1775.hs b/tests/pos/T1775.hs
deleted file mode 100644
--- a/tests/pos/T1775.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module T1775 where
-
-{-@ measure listLength @-}
-{-@ listLength :: xs:_ -> {n:Nat | n == len xs } @-}
-listLength :: [a] -> Int
-listLength [] = 0
-listLength (_x:xs) = 1 + listLength xs
-
-{-@ foo :: xs:_ -> {ys:_ | listLength xs == len ys } @-}
-foo :: [a] -> [a]
-foo xs =  xs
diff --git a/tests/pos/T1812.hs b/tests/pos/T1812.hs
deleted file mode 100644
--- a/tests/pos/T1812.hs
+++ /dev/null
@@ -1,30 +0,0 @@
--- Code from: http://www.cs.nott.ac.uk/~pszgmh/ccc2.pdf
-
-{-@ LIQUID "--reflection"     @-}
-{- LIQUID "--ple"            @-}
-{-@ LIQUID "--no-termination" @-}
-
-module T1812 where
-
-import qualified Data.Set as S 
-
-
-data Expr = Add Expr Expr | Abs Expr | Var Int 
-
-data Value = Num Int 
-
-data MMaybe a = MJust a | MNothing 
-
-data Type = TInt | TFun Type Type 
-
-{-@ reflect hasType @-}
-hasType :: Expr -> MMaybe Type 
-hasType (Add e1 e2) 
-  = case hasType e1 of 
-      MJust TInt -> case hasType e2 of 
-                     MJust TInt -> MJust TInt 
-                     MNothing   -> MNothing 
-      MNothing -> MNothing 
-hasType (Abs x) = MNothing 
-hasType (Var i) = MNothing 
-
diff --git a/tests/pos/T1874.hs b/tests/pos/T1874.hs
deleted file mode 100644
--- a/tests/pos/T1874.hs
+++ /dev/null
@@ -1,69 +0,0 @@
-module T1874 where
-
-{-@ LIQUID "--exact-data-cons" @-}
-{-@ LIQUID "--reflection"      @-}
-{-@ LIQUID "--ple"             @-}
-
-import Language.Haskell.Liquid.ProofCombinators
-
-data Ty = TInt | TFun Ty Ty
-
-{-@
-type FunTy = { t : Ty | isFunTy t }
-data Ty = TInt | TFun Ty Ty
-@-}
-
-{-@ measure isFunTy @-}
-isFunTy :: Ty -> Bool
-isFunTy (TFun _ _) = True
-isFunTy _ = False
-
-{- reflect funResTy @-}
-{-@ measure funResTy @-}
-{-@ funResTy :: FunTy -> Ty @-}
-funResTy :: Ty -> Ty
-funResTy (TFun _ b) = b
-
-{-@ measure funArgTy @-}
-{-@ funArgTy :: FunTy -> Ty @-}
-funArgTy :: Ty -> Ty
-funArgTy (TFun a _) = a
-
-{-@
-type FunExp = { e : Exp | isFunTy (exprType e) }
-type ExpT T = { e : Exp | T = exprType e }
-data Exp
-  = Var Ty Int
-  | Lam Ty Exp
-  | App (e1 :: FunExp) (ExpT (funArgTy (exprType e1)))
-@-}
-
-data Exp
-  = Var Ty Int
-  | Lam Ty Exp
-  | App Exp Exp
-
-{-@ measure exprType @-}
-exprType :: Exp -> Ty
-exprType (Var ty _) = ty
-exprType (Lam ty e) = TFun ty (exprType e)
-exprType (App e1 _) = funResTy (exprType e1)
-
-
-{-@ typeAppLam_prop :: ty:Ty -> e0:Exp -> e1:Exp -> { exprType (App (Lam ty e0) e1) = exprType e0 } @-}
-typeAppLam_prop :: Ty -> Exp -> Exp -> Proof
-typeAppLam_prop _ _ _ = trivial *** QED
-
-{-@ step :: e:Exp -> Maybe (ExpT (exprType e)) @-}
-step :: Exp -> Maybe Exp
-step e0 = case e0 of
-    Var{} -> Nothing
-    Lam{} -> Nothing
-    App e1 e2 -> case step e1 of
-      Just e1' -> Just (App e1' e2)
-      Nothing -> case step e2 of
-        Just e2' -> Just (App e1 e2')
-        Nothing -> case e1 of
-          Lam ty e11 ->
-              Just e11 -- ? typeAppLam_prop ty e11 e2
-          _ -> Nothing
diff --git a/tests/pos/T2091.hs b/tests/pos/T2091.hs
deleted file mode 100644
--- a/tests/pos/T2091.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE GADTs #-}
-
-module T2091 where 
-    
-import Prelude (Bool(..))
-import GHC.TypeLits
-
-data Vec (n :: Nat) a where
-    VCons :: a -> Vec n a -> Vec (1 + n) a
-    VNil :: Vec 0 a
-
-{-@ ys0 :: Vec _ Bool @-}
-ys0 :: Vec 0 Bool
-ys0 = VNil
-
-type Vec1 = Vec 1 
-{-@ type T = {v:Bool | v } @-}
-{-@ ys1 :: Vec _ T @-}
-ys1 :: Vec 1 Bool
-ys1 = VCons True VNil
diff --git a/tests/pos/T2093.hs b/tests/pos/T2093.hs
deleted file mode 100644
--- a/tests/pos/T2093.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE GADTs #-}
-{-@ embed GHC.Natural.Natural as int @-}
-{-@ embed GHC.Num.Natural.Natural as int @-}
-{-@ LIQUID "--no-totality" @-}
-
-module T2093 where 
-    
-import Prelude 
-import GHC.TypeLits
-import GHC.Natural
-
-newtype Unsigned (n :: Nat) = U Natural
-instance KnownNat n => Num (Unsigned n)
-  
-instance Ord (Unsigned n)
-instance Eq (Unsigned n)
-
-type Hex = Unsigned 4
-{-@ type Digit = {v : Hex | v <= 9 } @-}
-
-{-@ x :: Digit @-}
-x :: Hex
-x = 3
diff --git a/tests/pos/T2096.hs b/tests/pos/T2096.hs
deleted file mode 100644
--- a/tests/pos/T2096.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE GADTs #-}
-{-@ embed GHC.Natural.Natural as int @-}
-{-@ LIQUID "--no-totality" @-}
-
-module T2096 where
-
-import Prelude 
-import GHC.TypeLits
-import GHC.Natural
-import Unsafe.Coerce
-
--- See https://github.com/ucsd-progsys/liquidhaskell/issues/2095
-workaround :: (n1 + 1) ~ (n2 + 1) => Vec n1 a -> Vec n2 a
-workaround = unsafeCoerce
-
-data Vec (n :: Nat) a where
-    Nil :: Vec 0 a
-    Cons :: a -> Vec n a -> Vec (n + 1) a
-
-foo :: Vec n a -> Vec n a -> Vec n a
-foo Nil Nil = Nil
-foo (Cons x xs) (Cons y ys) = Cons x zs
-  where
-    zs = foo xs $ workaround ys
-foo _ _ = undefined
-
diff --git a/tests/pos/T385.hs b/tests/pos/T385.hs
deleted file mode 100644
--- a/tests/pos/T385.hs
+++ /dev/null
@@ -1,38 +0,0 @@
-{-@ LIQUID "--noclasscheck"    @-}
-module T385 where
-
-import Prelude hiding (Functor, Monad)
-
-data ST s a = ST {runState :: s -> (a,s)}
-
-{-@ data ST s a 
 Bool, q :: s -> s -> Bool, r :: s -> a -> Bool> 
-      = ST (runState :: x:s
 -> (a, s)) @-}
-
-{-@ runState :: forall 
 Bool, q :: s -> s -> Bool, r :: s -> a -> Bool>. ST  s a -> x:s
 -> (a, s) @-}
-
-class Functor f where
-  fmap :: (a -> b) -> f a -> f b
-
-instance Functor (ST s) where
-  fmap f (ST g) = ST (\s -> let (a, s') = g s in (f a, s'))
-
-class Functor m => Monad m where
-  (>>) :: m a -> m b -> m b
-
-instance Monad (ST s) where
-  {-@ instance Monad ST s where
-        >>  :: forall s a b  < pref :: s -> Bool, postf :: s -> s -> Bool
-                    , pre  :: s -> Bool, postg :: s -> s -> Bool
-                    , post :: s -> s -> Bool
-                    , rg   :: s -> a -> Bool
-                    , rf   :: s -> b -> Bool
-                    , r    :: s -> b -> Bool
-                    >. 
-             {x::s
, y::s |- b <: b}
-             {xx::s
, w::s |- s <: s}
-             {ww::s
 |- s <: s}
-             (ST  s a)
-          -> (ST  s b)
-          -> (ST  s b)
-    @-}
-  (ST g) >>  f = ST (\x -> case g x of {(y, s) -> (runState f) s})    
diff --git a/tests/pos/T531.hs b/tests/pos/T531.hs
deleted file mode 100644
--- a/tests/pos/T531.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module T531 where
-
-{-@
-data Foo = Foo { _getFoo :: Int }
-@-}
-data Foo = Foo { _getFoo :: Int }
diff --git a/tests/pos/T595.hs b/tests/pos/T595.hs
deleted file mode 100644
--- a/tests/pos/T595.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-module T595 where
-
-import Data.Vector
-
-data Test = Test
-    { vec  :: Thing
-    , x0   :: Bool
-    }
-
-type Thing = [()] -- Vector ()
-
-{-@ data Test = Test
-      { vec  :: Thing
-      , x0   :: { v : Bool | ((len vec) < 1) ==> v }
-      }
-  @-}
-
--- The above data declaration should give us the following refined types
--- for the record selectors
-
-{- assume vec :: x:Test -> {v:Thing | v = vec x} @-}
-{- assume x0  :: x:Test -> {v:Bool  | v = x0 x  && ((len (vec x) < 1) => v) } @-}
-
-example :: Test -> ()
-example t =
-    if x0 t
-    then ()
-    else vec t !! 0
diff --git a/tests/pos/T595a.hs b/tests/pos/T595a.hs
deleted file mode 100644
--- a/tests/pos/T595a.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module T595a where
-
-data Tree a = Nil | Tree { key :: a, l::Tree a, r :: Tree a}
-
-{-@ data Tree a = Nil
-                | Tree { key :: a
-                       , l   :: Tree {v:a | v < key }
-                       , r   :: Tree {v:a | key < v }
-                       }
-  @-}
diff --git a/tests/pos/T598.hs b/tests/pos/T598.hs
deleted file mode 100644
--- a/tests/pos/T598.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-module T598 where
-
-import GHC.Generics (Generic)
-import Control.DeepSeq (NFData(..))
-
-data Point = Point
-    { x :: Int
-    } deriving (Generic)
-
-instance NFData Point
diff --git a/tests/pos/T716.hs b/tests/pos/T716.hs
deleted file mode 100644
--- a/tests/pos/T716.hs
+++ /dev/null
@@ -1,31 +0,0 @@
-{-# LANGUAGE MagicHash #-}
--- | See https://github.com/ucsd-progsys/liquidhaskell/issues/716
---   due to the weird case-of thwarting ANF, you need the qualifier from the
---   output type of `narrow16Word` (apparently we don't scrape assumes?) 
---   ELIMINATE does not cut it, as the relevant kvar happens to be non-linear...
-
-{-@ LIQUID "--scrape-used-imports" @-}
-
-module T716 where
-
-import GHC.Exts
-import GHC.Word
-
--- denotes the offset at which bits are no longer guaranteed to be defined
-
-{-@ measure undefinedOffset :: Word# -> Int @-}
-
-{-@ assume byteSwap16# :: Word# -> {v:Word# | undefinedOffset v = 16} @-}
-
--- We need either the below qualifier, or the one from the refinement of
--- `Word`.Why are NEITHER generated automatically?
-
-{-@ assume narrow16Word# :: Word# -> {v:Word# | undefinedOffset v = 64} @-}
-
-{-@ data Word = W# {w :: {v:Word# | undefinedOffset v >= 64}} @-}
-
-grabWord16_SAFE (Ptr ip#) = let x = byteSwap16# (indexWord16OffAddr# ip# 0#) in W# (narrow16Word# x)
-
-grabWord16_UNSAFE (Ptr ip#) = W# (narrow16Word# (byteSwap16# (indexWord16OffAddr# ip# 0#)))
-
-
diff --git a/tests/pos/T819.hs b/tests/pos/T819.hs
deleted file mode 100644
--- a/tests/pos/T819.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-
-module T819 where
-
-import Language.Haskell.Liquid.ProofCombinators
-import Prelude hiding ((<>))
-
-data L a = N 
-{-@ infixl 9 <> @-}
-
-
-{-@ foo :: xs:L a -> {xs <> N == N } @-}
-foo :: L a -> Proof
-foo N = N <> N === N *** QED 
-
-
-{-@ reflect <> @-}
-(<>) :: L a -> L a -> L a 
-N <> N = N 
-
-
-{-@ infixl 9 +++ @-}
-{-@ data N = Zero | Succ {next :: N} @-}
-data N = Zero | Succ N 
-
-{-@ reflect +++ @-}
-(+++) :: N -> N -> N
-n +++ m = n
-
-{-@ lemma :: { v:() | Zero +++ Zero == Zero } @-}
-lemma :: ()
-lemma = Zero +++ Zero === Zero *** QED
-
diff --git a/tests/pos/T819A.hs b/tests/pos/T819A.hs
deleted file mode 100644
--- a/tests/pos/T819A.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-{-@ LIQUID "--reflection"     @-}
-{-@ LIQUID "--no-termination" @-}
-
-module T819A where
-
-import Language.Haskell.Liquid.ProofCombinators 
-import Prelude hiding ((++))
-
-data List a = Emp 
-
-{-@ infixr ++ @-}
-
-{-@ reflect ++ @-}
-Emp ++ ys = ys
-
-{-@ assocPf :: xs:_ -> ys:_  -> { (xs ++ ys) == ys  } @-}
-assocPf :: List a -> List a  -> Proof 
-
-assocPf Emp ys
-  =   (Emp ++ ys) 
-  === ys 
-  *** QED
diff --git a/tests/pos/T820.hs b/tests/pos/T820.hs
deleted file mode 100644
--- a/tests/pos/T820.hs
+++ /dev/null
@@ -1,43 +0,0 @@
-{-@ LIQUID "--exactdc"      @-}
-{-@ LIQUID "--higherorder"  @-}
-
-module T820 where
-
-import Language.Haskell.Liquid.ProofCombinators
-
-{- data Foo = Foo { foox :: (Int -> Int) , fooy :: Int } @-}
-data Foo = Foo { x :: Int -> Int , y :: Int }
-
-
-
-{-@ data VerifiedEq a = VerifiedEq {
-        eq :: a -> a -> Bool
-      , refl :: x:a -> { v:() | (eq x x) }
-      , sym :: x:a -> y:a -> { v:() | (eq x y) ==> (eq y x) }
-      , trans :: x:a -> y:a -> z:a -> { v:() | (eq x y) && (eq y z) ==> (eq x z) }
-      }
-@-}
-data VerifiedEq a = VerifiedEq {
-    eq :: a -> a -> Bool
-  , refl :: a -> Proof
-  , sym :: a -> a -> Proof
-  , trans :: a -> a -> a -> Proof
-  }
-
-{-@ data VerifiedOrd a = VerifiedOrd {
-        leq :: (a -> a -> Bool)
-      , total :: (x:a -> y:a -> { (leq x y) || (leq y x) })
-      , antisym :: (x:a -> y:a -> { (leq x y) || (leq y x) ==> x == y })
-      , trans2 :: (x:a -> y:a -> z:a -> { (leq x y) && (leq y z) ==> (leq x z) })
-      , verifiedEq :: VerifiedEq a
-      }
-  @-}
-
-
-data VerifiedOrd a = VerifiedOrd {
-    leq :: a -> a -> Bool
-  , total :: a -> a -> Proof
-  , antisym :: a -> a -> Proof
-  , trans2 :: a -> a -> a -> Proof
-  , verifiedEq :: VerifiedEq a
-  }
diff --git a/tests/pos/T866.hs b/tests/pos/T866.hs
deleted file mode 100644
--- a/tests/pos/T866.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-{-@ LIQUID "--no-totality"    @-}
-
--- see https://github.com/ucsd-progsys/liquidhaskell/issues/866
-
-module T866 where
-
-data Body = Body Int Int 
-
-genBody :: [Int] -> Body
-genBody s   = Body x y 
-  where 
-    (x:y:_) = s
-
diff --git a/tests/pos/T914.hs b/tests/pos/T914.hs
deleted file mode 100644
--- a/tests/pos/T914.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-{-@ LIQUID "--higherorder" @-}
-
-module T914 where
-
-import Language.Haskell.Liquid.ProofCombinators
-
-{-@ inline compose @-}
-
-{-@ compose :: f:(b -> c) -> g:(a -> b) -> x:a -> c @-}
-compose :: (b -> c) -> (a -> b) -> a -> c
-compose f g x = f (g x)
diff --git a/tests/pos/TagBinder.hs b/tests/pos/TagBinder.hs
deleted file mode 100644
--- a/tests/pos/TagBinder.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module TagBinder () where
-
-data Foo a = F Int a
-
-{-@ data Foo a = F {tag :: Int, f :: a} @-}
-
-foo = F
diff --git a/tests/pos/Take.hs b/tests/pos/Take.hs
deleted file mode 100644
--- a/tests/pos/Take.hs
+++ /dev/null
@@ -1,60 +0,0 @@
-{-@ LIQUID "--no-totality"    @-}
-
-{-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE CPP,  NoImplicitPrelude, MagicHash #-}
-{-# OPTIONS_HADDOCK hide #-}
-
-module Take (
-    take0
-  , take
-  ) where
-
-import Data.Maybe
-import GHC.Base 
-import Language.Haskell.Liquid.Prelude (liquidAssert, liquidError, unsafeError) 
-
-
-
-{-@ assert take0  :: n: {v: Int | 0 <= v} -> [a] -> {v:[a] | (len(v) = n)} @-}
-take0 :: Int -> [a] -> [a]
-take0 (I# n#) xs = take_unsafe_UInt0 n# xs
-
-take_unsafe_UInt0 :: Int# -> [a] -> [a]
-take_unsafe_UInt0 0#  _     = []
-take_unsafe_UInt0 n  (x:xs) = x : take_unsafe_UInt0 (n -# 1#) xs
-take_unsafe_UInt0 _   _     = unsafeError "unsafe take"
-
-{-@ assert take  :: n: {v: Int | v >= 0 } -> xs:[a] -> {v:[a] | len v = if len xs < n then (len xs) else n } @-}
-take (I# n#) xs = takeUInt n# xs
--- take (I# n#) xs = take_unsafe_UInt n# xs
-
-takeUInt :: Int# -> [a] -> [a]
-takeUInt n xs
-  | isTrue# (n >=# 0#) =  take_unsafe_UInt n xs
-  | otherwise          =  liquidAssert False []
-
-take_unsafe_UInt :: Int# -> [a] -> [a]
-take_unsafe_UInt 0#  _     = []
-take_unsafe_UInt n ls      =
-  case ls of
-    []     -> []
-    (x:xs) -> x : take_unsafe_UInt (n -# 1#) xs
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/pos/Term.hs b/tests/pos/Term.hs
deleted file mode 100644
--- a/tests/pos/Term.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-{-@ LIQUID "--no-totality"    @-}
-
-module Term where
-
-import Language.Haskell.Liquid.Prelude (unsafeError)
-
--- TODO: If we remove the type signature LH crashes
-f :: (Num a) => String -> [a] -> [a]
-{-@ f :: _ -> xs : [a] -> [a] / [len xs] @-}
-f er [] = unsafeError er
-f er (x:xs) = (x+1) : f er xs
-
-f' :: String -> [a] -> [a]
-{-@ f' :: _ -> xs : [a] -> [a] / [len xs] @-}
-f' er [] = unsafeError er
-f' er (x:xs) = x : f' er xs
-
-{-@ type ListN a N = {v:[a] | len v = N} @-}
-{-@ type ListL a L = ListN a (len L) @-}
-
-safeZipWithError :: String -> [a] -> [b] -> [(a, b)]
-{-@ safeZipWithError :: _ -> xs:[a] -> ListL b xs -> ListL (a,b) xs / [len xs] @-}
-safeZipWithError msg (x:xs) (y:ys) = (x,y) : safeZipWithError msg xs ys
-safeZipWithError _   []     []     = []
-safeZipWithError msg _      _      = unsafeError msg
diff --git a/tests/pos/Term0.hs b/tests/pos/Term0.hs
deleted file mode 100644
--- a/tests/pos/Term0.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Term0 () where
-
-import Prelude hiding (sum)
-
-{-@ sum :: Nat -> Nat @-}
-sum   :: Int -> Int
-sum 0 = 0
-sum n = n + sum (n-1)
-
-{-@ fib :: Nat -> Nat @-}
-fib :: Int -> Int 
-fib 0 = 1
-fib 1 = 1 
-fib n = fib (n-1) + fib (n-2)
-
-{-@ sumUp :: Nat -> Nat @-}
-sumUp :: Int -> Int
-sumUp n  = go n 0 0
-  where 
-    go (d :: Int) acc i
-      | i < n     = go (d - 1) (acc + i) (i + 1) 
-      | otherwise = acc
-
-{-@ qualif Diff(v:Int, x:Int, y:Int): v = x - y @-} 
-
-{-@ nonTerm :: Nat -> Nat @-}
-nonTerm :: Int -> Int
-nonTerm n = nonTerm (n+1)
-
-{-@ lazy nonTerm @-}
-
diff --git a/tests/pos/Termination.hs b/tests/pos/Termination.hs
deleted file mode 100644
--- a/tests/pos/Termination.hs
+++ /dev/null
@@ -1,50 +0,0 @@
-module Termination where
-
-import Prelude hiding (sum)
-
-type Value = Int
-
-type Vec = Int -> Value
-
-{-@ sum :: Vec -> Nat -> Value @-}
-sum :: Vec -> Int -> Value
-sum a 0 = a 0
-sum a i = a i + sum a (i-1)
-
-{-@ sum' :: Vec -> Value -> n:Nat -> Value / [n] @-}
-sum' :: Vec -> Value -> Int -> Value
-sum' a acc 0 = acc + a 0
-sum' a acc i = sum' a (acc + a i) (i-1)
-
-type Vec2D = Int -> Int -> Value
-
-{-@ sum2D :: Vec2D -> Nat -> Nat -> Value @-}
-sum2D :: Vec2D -> Int -> Int -> Value
-sum2D a n m = go n m
-  where
-    {-@ go :: ink:Nat -> joe:Nat -> Value / [ink, joe] @-}
-    go 0 0        = a 0 0
-    go i j
-      | j == 0    =  a i 0 + go (i-1) m
-      | otherwise =  a i j + go i (j-1)
-
-{-@ sumFromTo :: Vec -> lo:Nat -> hi:{v:Nat|v>=lo} -> Value @-}
-sumFromTo :: Vec -> Int -> Int ->  Value
-sumFromTo a lo hi = go lo hi
-  where
-    {-@ go :: lo:Nat -> hi:{v:Nat | v >= lo} -> Value / [hi-lo] @-}
-    go :: Int -> Int -> Value
-    go lo hi 
-      | lo == hi  =  a lo
-      | otherwise =  a lo + go (lo + 1) hi
-
-{-@ sumFrom2 :: Vec -> lo:Nat -> hi:{v:Nat | lo <= v } -> Value @-}
-sumFrom2 :: Vec -> Int -> Int ->  Value
-sumFrom2 a lo hi = go lo
-  where
-    {-@ go :: lo:_ -> _ / [hi - lo] @-}
-    go :: Int -> Value
-    go lo
-      | lo == hi  =  a lo
-      | otherwise =  a lo + go (lo + 1)
-
diff --git a/tests/pos/TerminationNum.hs b/tests/pos/TerminationNum.hs
deleted file mode 100644
--- a/tests/pos/TerminationNum.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module TerminationNum where
-
-{-@ fak2 :: (Ord a, Eq a, Num a) => y:{x: a | x >= 0} -> a /[y]@-}
-fak2 :: (Ord a, Eq a, Num a) => a -> a
-fak2 0 = 1
-fak2 x = x * fak2 (x - 1)
diff --git a/tests/pos/TerminationNum0.hs b/tests/pos/TerminationNum0.hs
deleted file mode 100644
--- a/tests/pos/TerminationNum0.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-module TerminationNum0 where
-
-{-@fak2 :: (Ord a, Eq a, Num a) => {x: a | x >= 0} -> a @-}
-fak2 :: (Ord a, Eq a, Num a) => a -> a
-fak2 0 = 1
-fak2 x = x * fak2 (x - 1)
-
-
-{-@ fak :: {x: Int | x >= 0} -> a -> Int @-}
-fak :: (Ord a, Eq a, Num a) => Int -> a -> Int 
-fak 0 _ = 1
-fak x y = fak (x - 1) y
-
-
-{-@ fak1 :: {x: Int | x >= 0} -> a -> Int @-}
-fak1 :: (Num a) => Int -> a -> Int 
-fak1 0 _ = 1
-fak1 x y = fak1 (x - 1) y
diff --git a/tests/pos/Test0.hs b/tests/pos/Test0.hs
deleted file mode 100644
--- a/tests/pos/Test0.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module Test0 () where
-
-import Language.Haskell.Liquid.Prelude
-
-myabs x = if x > 0 then x else (0 - x)
-
-prop_abs   = let n1 = choose 0 in 
-             liquidAssertB ((myabs n1) >= 0)
diff --git a/tests/pos/Test00.hs b/tests/pos/Test00.hs
deleted file mode 100644
--- a/tests/pos/Test00.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module Test00 () where
-
-import Language.Haskell.Liquid.Prelude
-
-
-prop_abs ::  Bool
-prop_abs = if x > 0 then baz x else False
-  where 
-    x    = choose 0
-
-baz gooberding = liquidAssertB (gooberding >= 0)
diff --git a/tests/pos/Test000.hs b/tests/pos/Test000.hs
deleted file mode 100644
--- a/tests/pos/Test000.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module Test000 () where
-
--- import Language.Haskell.Liquid.Prelude
-{-@ toss :: Bool @-}
-toss :: Bool
-toss = (undefined 0) > 10
-
diff --git a/tests/pos/Test00_int.hs b/tests/pos/Test00_int.hs
deleted file mode 100644
--- a/tests/pos/Test00_int.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module Test00_int () where
-
-import Language.Haskell.Liquid.Prelude 
-
-x :: Int
-x = choose 0
-
-prop_abs ::  Bool
-prop_abs = if x > 0 then baz x else False
-
-baz :: Int -> Bool
-baz gooberding = liquidAssertB (gooberding >= 0)
diff --git a/tests/pos/Test00_old.hs b/tests/pos/Test00_old.hs
deleted file mode 100644
--- a/tests/pos/Test00_old.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module Test00_old () where
-
-import Language.Haskell.Liquid.Prelude
-
-x = choose 0
-
-prop_abs = if x `gt` 0 then baz x else False
-
-baz   :: Int -> Bool
-baz z = liquidAssertB (z `geq` 0)
-
diff --git a/tests/pos/Test00b.hs b/tests/pos/Test00b.hs
deleted file mode 100644
--- a/tests/pos/Test00b.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module Test00b () where
-
-import Language.Haskell.Liquid.Prelude
-
-x = choose 0
-
-foo x = x
-
-prop_abs = if x > 0 then baz (foo x) else False
-
-baz ::  (Num a, Ord a) => a -> Bool
-baz z = liquidAssertB (z > 0)
diff --git a/tests/pos/Test00c.hs b/tests/pos/Test00c.hs
deleted file mode 100644
--- a/tests/pos/Test00c.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module Test00c () where
-
-import Language.Haskell.Liquid.Prelude
-
-getEqs x ys = filter (x ==) ys 
-
-xs :: [Int]
-xs = [1, 2, 3, 4, 5, 6]
-
-prop_abs = map (\z -> liquidAssertB (z >= 0)) ys
-             where ys = getEqs 5 xs
diff --git a/tests/pos/Test1.hs b/tests/pos/Test1.hs
deleted file mode 100644
--- a/tests/pos/Test1.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-module Test1 () where
-
-import Language.Haskell.Liquid.Prelude
-
-myabs x = if x > 0 then x else 0 - x
-
-n = choose 0
-
-prop_absf = liquidAssertB ((myabs n) >= 0)
diff --git a/tests/pos/Test2.hs b/tests/pos/Test2.hs
deleted file mode 100644
--- a/tests/pos/Test2.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module Test2 () where
-
-import Language.Haskell.Liquid.Prelude
-
-myabs x = if x > 0 then x else 0 - x
-
-n = choose 0
-
-prop_absf = 
-  let zz = (myabs n) >= 0 in
-  liquidAssertB zz
diff --git a/tests/pos/Test761.hs b/tests/pos/Test761.hs
deleted file mode 100644
--- a/tests/pos/Test761.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module Test761 () where
-
-import Language.Haskell.Liquid.Prelude
-
-x = choose 0
-
-prop_abs ::  Bool
-prop_abs = if x > 0 then baz x else False
-
-baz gooberding = liquidAssertB (gooberding >= 0)
diff --git a/tests/pos/TestRec.hs b/tests/pos/TestRec.hs
deleted file mode 100644
--- a/tests/pos/TestRec.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-
-module TestRec where
-
-import Prelude hiding (foldl)
-
-data L a = N | C { hd :: a
-                 , tl :: L a }
-
-{-@ data L [llen] a = N | C { hd :: a
-                            , tl :: L a }
-  @-}
-
-
-{-@ invariant {v:L a | 0 <= llen v} @-}
-
-{-@ measure llen @-}
-llen :: L a -> Int
-llen N        = 0
-llen (C x xs) = 1 + llen xs
-
-reverse :: L a -> L a
-reverse xs = go N xs
-  where 
-    {-@ go :: acc:_ -> xs:_ -> _ / [llen xs] @-}
-    go :: L a -> L a -> L a 
-    go acc N        = acc
-    go acc (C x xs) = go (C x acc) xs
-
-mapL f N = N
-mapL f (C x xs) = C (f x) (mapL f xs)
-
-
diff --git a/tests/pos/TokenType.hs b/tests/pos/TokenType.hs
deleted file mode 100644
--- a/tests/pos/TokenType.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-module TokenType where
-
-
-data TokenType = Foo | CChar
-
-
-{-@ bar :: Char @-}
-bar :: Char
-bar = undefined
diff --git a/tests/pos/Top0.hs b/tests/pos/Top0.hs
deleted file mode 100644
--- a/tests/pos/Top0.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-module Top0 (poop, loop, zoo) where
-
-{-@ invariant {v:Int | v >= 0} @-}
-
-{-@ qualif Sum(v:Int, x: Int, y: Int): v = x + y @-}
-
--- | This should get a TOP type
-poop x = zoo x 
-
--- | This is USED but should ALSO get a TOP type (since exported)
-loop x     = go x 0
-  where 
-    go     :: Int -> Int -> Int 
-    go 0 m = m
-    go n m = go (n-1) (m+1)
-
-zoo     = loop
-
-loop' x     = go x 0
-  where 
-    go     :: Int -> Int -> Int 
-    go 0 m = m
-    go n m = go (n-1) (m+1)
-
--- | This HAS a sig so it should NOT get a TOP type
-{-@ zoo' :: x:Int -> {v:Int | v = x} @-}
-zoo'     = loop'
diff --git a/tests/pos/TopLevel.hs b/tests/pos/TopLevel.hs
deleted file mode 100644
--- a/tests/pos/TopLevel.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module TopLevel (bar) where
-
-import Language.Haskell.Liquid.Prelude
-
-foo b = liquidAssertB b
-
-bar = foo True
diff --git a/tests/pos/ToyMVar.hs b/tests/pos/ToyMVar.hs
deleted file mode 100644
--- a/tests/pos/ToyMVar.hs
+++ /dev/null
@@ -1,67 +0,0 @@
-{-# LANGUAGE MagicHash     #-}
-{-# LANGUAGE UnboxedTuples #-}
-{-# OPTIONS_GHC -Wno-missing-methods #-}
-
-{-@ LIQUID "--no-totality"       @-}
-{-@ LIQUID "--no-termination"    @-}
-{-@ LIQUID "--no-pattern-inline" @-}
-
-module ToyMVar where
-
-import Prelude hiding (IO)
-import Control.Applicative
-import Data.Set 
-data RealWorld
-data MVar# s a 
-data State# s 
-data MVar a = MVar (MVar# RealWorld a)
-
-data IO a = IO (State# RealWorld -> (State# RealWorld, a))
-{-@ data IO a 
 Bool, q :: State# RealWorld-> a -> Bool>
-      = IO (io :: (State# RealWorld)
 -> ((State# RealWorld, a)))
-  @-}
-
-{-@ measure inState :: MVar a -> State# RealWorld -> Bool @-}
-{-@ measure stateMVars :: State# RealWorld -> Set (MVar a) @-}
-
-{-@ newEmptyMVar  :: forall < p :: State# RealWorld -> Bool
-                            , q :: State# RealWorld -> (MVar a) -> Bool>. 
-                     IO  (inState y x)}> (MVar a) @-}
-newEmptyMVar  :: IO (MVar a)
-newEmptyMVar = IO $ \ s# ->
-    case newMVar# s# of
-         (s2#, svar#) -> (s2#, MVar svar#)
-
-newMVar :: a -> IO (MVar a)
-newMVar value =
-    newEmptyMVar        >>= \ mvar ->
-    putMVar mvar value  >>
-    return mvar
-
-putMVar  :: MVar a -> a -> IO ()
-putMVar (MVar mvar#) x = IO $ \ s# ->
-    case putMVar# mvar# x s# of
-        s2# -> (s2#, ())
-
-
-putMVar# :: MVar# s a -> a -> State# s -> State# s
-putMVar# = let x = x in x
-
-{-@ newMVar#  :: forall < p :: State# s -> Bool
-                            , q :: State# s -> (MVar# s a) -> Bool>. 
-                     (State# s)
 -> 
-                     ((State# s)
, (MVar# s a)) @-}
-
-newMVar# :: State# s -> (State# s, MVar# s a)
-newMVar# = let x = x in x
-
-instance Monad IO where --  GHC-Base.lhs
-  return = undefined
-  _ >> _ = undefined
-
-instance Applicative IO where
-  pure  = undefined
-  (<*>) = undefined
-
-instance Functor IO where
-  fmap = undefined
diff --git a/tests/pos/Trans.hs b/tests/pos/Trans.hs
deleted file mode 100644
--- a/tests/pos/Trans.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-module Trans () where
-
-import Language.Haskell.Liquid.Prelude
-
-{- THIS IS A RANDOM COMMENT -}
-
-{-@ foo :: x: Int -> Int @-}
-foo :: Int -> Int
-foo x = x + 1
-
-{-@ transpose :: n:Int
-              -> m:{v:Int | v > 0} 
-              -> {v:[{v:[a] | len(v) = n}] | len(v) = m} 
-              -> {v:[{v:[a] | len(v) = m}] | len(v) = n} 
-  @-}
-transpose :: Int -> Int -> [[a]] -> [[a]]
-transpose 0 _ _              = []
-transpose n m ((x:xs) : xss) = (x : map head xss) : transpose (n - 1) m (xs : map tail xss)
-transpose n m ([] : _)       = liquidError "transpose1" 
-transpose n m []             = liquidError "transpose2"
-
--- NEEDS TAGS: map head xss = [ h | (h:_) <- xss]
--- NEEDS TAGS: map tail xss = [t | (_:t) <- xss]
-
-
diff --git a/tests/pos/TransTAG.hs b/tests/pos/TransTAG.hs
deleted file mode 100644
--- a/tests/pos/TransTAG.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-module TransTAG () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ foo :: x: Int -> Int @-}
-foo :: Int -> Int
-foo x = x + 1
-
-{-@ transpose :: n:Int
-              -> m:{v:Int | v > 0} 
-              -> {v:[{v:[a] | len(v) = n}] | len(v) = m} 
-              -> {v:[{v:[a] | len(v) = m}] | len(v) = n} 
-  @-}
-transpose :: Int -> Int -> [[a]] -> [[a]]
-transpose 0 _ _              = []
-transpose n m ((x:xs) : xss) = (x : [h | (h:_) <- xss]) : transpose (n - 1) m (xs : [t | (_:t) <- xss])
-transpose n m ([] : _)       = liquidError "transpose1" 
-transpose n m []             = liquidError "transpose2"
-
--- NEEDS TAGS: map head xss = [ h | (h:_) <- xss]
--- NEEDS TAGS: map tail xss = [t | (_:t) <- xss]
-
-
diff --git a/tests/pos/Transpose.hs b/tests/pos/Transpose.hs
deleted file mode 100644
--- a/tests/pos/Transpose.hs
+++ /dev/null
@@ -1,62 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-{-@ LIQUID "--prune-unsorted" @-}
-{-@ LIQUID "--bscope"         @-}
-
-module Transpose (transpose, transpose', transpose'') where
-
-import Language.Haskell.Liquid.Prelude
-
--- | Specifying a matrix
-
-{-@ type Matrix a       = {m0:[{v:[a] | (len v) = (cols m0)}] | true } @-}
-
-{-@ type MatrixCR a C R = {m0:[{v:[a] | (len v) = C}] | (((len m0) = R) && (R > 0 => (cols m0) = C)) } @-}
-
-{-@ measure cols :: [[a]] -> Int
-      cols []   = 0
-      cols (x:xs) = (len x)
-  @-}
-
--- | A Few Simple Examples (which run VERY slowly)
-
-{-@ predicate Dim V C R = (((len V) = R) && ((cols V) = C)) @-}
-
-{-@ mat_3_2 :: {v: Matrix Int | (Dim v 3 2)} @-}
-mat_3_2 :: [[Int]]
-mat_3_2 = [ [1,2,3]
-          , [4,5,6] ]
-
-{-@ mat_2_4 :: {v: Matrix Int | (Dim v 2 4)} @-}
-mat_2_4 :: [[Int]]
-mat_2_4 = [ [1,2]
-          , [3,4]
-          , [5,6]
-          , [7,8] ]
-
--- | Old fashioned transpose with explicit dimensions
-
-{- transpose :: c:Nat
-             -> r:{v:Nat | v > 0}
-             -> {v:[{v:[a] | (len v) = c}] | (len v) = r}
-             -> {v:[{v:[a] | (len v) = r}] | (len v) = c}
-  -}
-
-{-@ transpose :: c:Nat -> r:{v:Nat | v > 0}  -> (MatrixCR a c r) -> (MatrixCR a r c) @-}
-transpose     :: Int -> Int -> [[a]] -> [[a]]
-transpose 0 _ _              = []
-transpose n m ((x:xs) : xss) = (x : map head xss) : transpose (n - 1) m (xs : map tail xss)
-transpose n m ([] : _)       = liquidError "transpose1"
-transpose n m []             = liquidError "transpose2"
-
-
-{-@ transpose' :: m:{v:(Matrix a) | ((len v) > 0)} -> (MatrixCR a (len m) (cols m)) @-}
-transpose' :: [[a]] -> [[a]]
-transpose' ([]:_)         = []
-transpose' ((x:xs) : xss) = (x : map head xss) : transpose' (xs : map tail xss)
-transpose' []             = liquidError "transpose'"
-
--- | A wrapper implementing the explicit transpose using the implicit one
-
-{-@ transpose''     :: c:Nat -> r:{v:Nat | v > 0}  -> (MatrixCR a c r) -> (MatrixCR a r c) @-}
-transpose''         :: Int -> Int -> [[a]] -> [[a]]
-transpose'' n m xss = transpose' xss
diff --git a/tests/pos/Tup0.hs b/tests/pos/Tup0.hs
deleted file mode 100644
--- a/tests/pos/Tup0.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module Tup0 () where
-
-{-@ type PlusOne = (Int, Int)<{\x v -> v > x}> @-}
-
-{-@ plusOne :: PlusOne @-}
-plusOne :: (Int, Int)
-plusOne = (0, 1)
-
-{-@ plusOnes :: Maybe PlusOne @-}
-plusOnes :: Maybe (Int, Int) 
-plusOnes = Just plusOne -- (0, 1) (5,6), (999,1000)]
diff --git a/tests/pos/Tupparse.hs b/tests/pos/Tupparse.hs
deleted file mode 100644
--- a/tests/pos/Tupparse.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-module Tupparse () where
-
-import Language.Haskell.Liquid.Prelude (liquidAssert)
-
-data Vec a = V a deriving (Eq)
-
--- this is verified ...
-{-@ bar :: x:Int 
-        -> y:{v: Int | v = x } 
-        -> Int 
-  @-}
-bar     :: Int -> Int -> Int
-bar x y = liquidAssert (x == y) 0
-
--- and so is this...
-
-{-@ goo :: x:[Int] 
-        -> y:{v: [Int] | v = x } 
-        -> Int 
-  @-}
-goo     :: [Int] -> [Int] -> Int
-goo x y = liquidAssert (x == y) 0
-
-
--- BUT THIS IS NOT!!
-{-@ foo :: x: (Vec Int)
-        -> y:{v: Vec Int | v = x } 
-        -> Int 
-  @-}
-foo     :: Vec Int -> Vec Int -> Int
-foo x y = liquidAssert (x == y) 0
-
-
-
diff --git a/tests/pos/TyExpr.hs b/tests/pos/TyExpr.hs
deleted file mode 100644
--- a/tests/pos/TyExpr.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module TyExpr where
-
-{-@ type Range Lo Hi = {v:Int | Lo <= v && v < Hi} @-}
-
-{-@ bow :: Range 0 100 @-}
-bow :: Int
-bow = 12
diff --git a/tests/pos/Tyclass0.hs b/tests/pos/Tyclass0.hs
deleted file mode 100644
--- a/tests/pos/Tyclass0.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module Tyclass0 (poop) where
-
-class Zog a where
-  zoom :: a -> Int
-
--- Assume the relevant behavior for the method.
-{-@ zoom :: (Zog a) => a -> Nat @-}
-
--- Uses the behavior of `zoom`
-{-@ poop :: (Zog a) => a -> Nat @-}
-poop x = zoom x
diff --git a/tests/pos/Tyfam0.hs b/tests/pos/Tyfam0.hs
deleted file mode 100644
--- a/tests/pos/Tyfam0.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-module Tyfam0 () where
-
-import Control.Monad.Primitive
-
-import Data.Vector.Generic.Mutable
-
-{-@ copyOffset :: (PrimMonad m, MVector v e)
-           => v (PrimState m) e -> v (PrimState m) e -> Int -> Int -> Int -> m ()
-  @-}
-
-copyOffset :: (PrimMonad m, MVector v e)
-           => v (PrimState m) e -> v (PrimState m) e -> Int -> Int -> Int -> m ()
-copyOffset = undefined
-
-{-@ zog :: (m s a) -> Nat @-}
-zog :: (m s a) -> Int
-zog = undefined
diff --git a/tests/pos/TypeAlias.hs b/tests/pos/TypeAlias.hs
deleted file mode 100644
--- a/tests/pos/TypeAlias.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-module TypeAlias where
-
-data Foo a b = Foo a b
-
-type Bar = Foo Int
-
-
-{-@ foo :: String  @-}
-foo :: String
-foo = "mpla"
-
-{-@ bar :: Bar {v:Int | v = 2} @-}
-bar :: Bar Int
-bar = Foo 1 2
diff --git a/tests/pos/TypeLitNat.hs b/tests/pos/TypeLitNat.hs
deleted file mode 100644
--- a/tests/pos/TypeLitNat.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-{-# LANGUAGE GADTs #-}
-
-{-# LANGUAGE KindSignatures      #-}
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE RankNTypes          #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators       #-}
-
-module TypeLitNat where
-
-import GHC.TypeLits
-
--- THIS SHOULD BE UNSAFE
-miunsafe2 :: MI 0
-miunsafe2 = Small 0
-
-data MI (s :: Nat) = Small { mi_input :: Int  }
-
-{-@ Small :: forall (s :: Nat). {v:Int | s ~~ v } -> MI s @-}
diff --git a/tests/pos/TypeLitString.hs b/tests/pos/TypeLitString.hs
deleted file mode 100644
--- a/tests/pos/TypeLitString.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-{-# LANGUAGE KindSignatures      #-}
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE RankNTypes          #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module TypeLitString where
-
-import GHC.TypeLits
-
--- THIS SHOULD BE SAFE
-misafe   :: MI "blaa"
-misafe   = Small "blaa"
-
-data MI (s :: Symbol) = Small { mi_input :: String  }
-
-{-@ Small :: forall (s :: Symbol). {v:String | s ~~ v } -> MI s @-}
-
--- OR 
-
-{- data MI (s :: Symbol)
-    = Small { mi_input :: {v:String | v == s } } @-}
diff --git a/tests/pos/Tyvar.hs b/tests/pos/Tyvar.hs
deleted file mode 100644
--- a/tests/pos/Tyvar.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module Tyvar () where
-
-{-@ foo :: Eq b => a -> b -> a @-}
-foo :: Eq b => a -> b -> a
-foo = undefined
diff --git a/tests/pos/UnboxedTuples.hs b/tests/pos/UnboxedTuples.hs
deleted file mode 100644
--- a/tests/pos/UnboxedTuples.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE UnboxedTuples #-}
-module UnboxedTuples where
-
-import GHC.Int
-
-foo = let (# x, y #) = (# 1#, 1# #) in I8# x
-
diff --git a/tests/pos/UnboxedTuplesAndTH.hs b/tests/pos/UnboxedTuplesAndTH.hs
deleted file mode 100644
--- a/tests/pos/UnboxedTuplesAndTH.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE UnboxedTuples #-}
-
-module UnboxedTuplesAndTH where
-
-import GHC.Int
-import Language.Haskell.TH.Syntax
-
-foo = let (# x, y #) = (# 1#, 1# #) in I8# x
-
-bar :: Q Exp
-bar = [| 1 + 2|]
-
diff --git a/tests/pos/UndecidedGuards.hs b/tests/pos/UndecidedGuards.hs
deleted file mode 100644
--- a/tests/pos/UndecidedGuards.hs
+++ /dev/null
@@ -1,19 +0,0 @@
--- Tests that --ple-with-undecided-guards has an effect on verification
-{-@ LIQUID "--ple-with-undecided-guards" @-}
-{-@ LIQUID "--ple" @-}
-
-module UndecidedGuards where
-
-{-@ reflect boolToInt @-}
-boolToInt :: Bool -> Int
-boolToInt False = 0
-boolToInt True = 1
-
--- | This property would usually not be provable without spliting in cases
--- because PLE doesn't unfold @boolToInt@ if @b@ is not known to be empty
--- or non-empty. But here @--ple-with-undecided-guards@ is in effect, so
--- @boolToInt@ is expanded anyway.
---
-{-@ nonNegativeInt :: b:_ -> { boolToInt b >= 0 } @-}
-nonNegativeInt :: Bool -> ()
-nonNegativeInt _ = ()
diff --git a/tests/pos/Unusedtyvars.hs b/tests/pos/Unusedtyvars.hs
deleted file mode 100644
--- a/tests/pos/Unusedtyvars.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-module Unusedtyvars () where
-
-data F a b c = F (Int -> b -> c)
-{- data F a b c = F (x::(Int -> b -> c)) @-}
-
-
-{-@ bar :: F {v:Int| v >= 0} b c @-}
-bar :: F Int b c
-bar = undefined
-
-
-{-@ foo :: F {v:Int| v >= 0} b c  -> Int @-}
-foo :: F Int b c -> Int
-foo = undefined
-
-{-@ hoo :: Int @-}
-hoo = foo bar
diff --git a/tests/pos/Variance.hs b/tests/pos/Variance.hs
deleted file mode 100644
--- a/tests/pos/Variance.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-module Variance where
-
-{-@ data variance Foo invariant bivariant covariant contravariant @-}
-data Foo a b c d
-
-
-
-{-@ check_covariant :: Foo a b {v:Int | v = 1} c -> Foo a b {v:Int | v > 0} c @-}
-check_covariant :: Foo a b Int c -> Foo a b Int c
-check_covariant r = r
-
-
-{-@ check_contravariant0 :: Foo a b c {v:Int | v > 0} -> Foo a b c {v:Int | v = 1} @-}
-check_contravariant0 :: Foo a b c Int-> Foo a b c Int
-check_contravariant0 r = r
-
-{-@ check_contravariant :: ((Foo a b c {v:Int | v = 1}) -> ()) -> (Foo a b c {v:Int | v > 0}) -> () @-}
-check_contravariant :: ((Foo a b c Int) -> ()) -> Foo a b c Int -> ()
-check_contravariant r = r
-
-{-@ check_bivariant :: Foo a {v: Int | v = 1} c d -> Foo a {v:Int | ((v > 0) && (v < 2))} c d @-}
-check_bivariant :: Foo a Int c d -> Foo a Int c d
-check_bivariant r = r
-
-
-{-@ check_invariant :: Foo {v: Int | v = 1} b c d -> Foo {v:Int | ((v > 0) && (v < 2))} b c d @-}
-check_invariant :: Foo Int b c d -> Foo Int b c d
-check_invariant r = r
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/pos/Variance2.hs b/tests/pos/Variance2.hs
deleted file mode 100644
--- a/tests/pos/Variance2.hs
+++ /dev/null
@@ -1,37 +0,0 @@
-{-# LANGUAGE Rank2Types, ExistentialQuantification #-}
-
-
-module Variance2 where
-
-
-import Control.Monad.Trans.Except
-
-
-
-p1 :: Parser a 
-p1 = undefined 
-
-p2 :: Parser a -> ()
-p2 _ = () 
-
-p = p2 p1 
-
-
--- The following structure is a simplification of 
---  Options.Applicative.Parser 
-
-data Parser a
-  = OptP (Option a)
-
-data Option a = Option
-  { optMain :: OptReader a }
-
-
-
-data OptReader a
- =  CmdReader (String -> Maybe (ParserInfo a)) -- ^ command reader
-
-
-data ParserInfo a = ParserInfo
-  { infoParser :: Parser a    -- ^ the option parser for the program                              -- after arguments (default: True)
-  }
diff --git a/tests/pos/Vector00.hs b/tests/pos/Vector00.hs
deleted file mode 100644
--- a/tests/pos/Vector00.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module Vector00 () where
-
-import Language.Haskell.Liquid.Prelude
--- import Data.List
-import Data.Vector hiding (map, concat, zipWith, filter, foldr, foldl, (++))
-
-propVec = (vs ! 3) == 3
-  where xs    = [1,2,3,4] :: [Int]
-        vs    = fromList xs
-        
-
diff --git a/tests/pos/Vector1.hs b/tests/pos/Vector1.hs
deleted file mode 100644
--- a/tests/pos/Vector1.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-module Vector1 () where
-
-{-@ LIQUID "--no-termination" @-}
-
-import Language.Haskell.Liquid.Prelude
-import Data.Vector hiding (map, concat, zipWith, filter, foldr, foldl, (++))
-
-for lo hi acc f 
-  | lo < hi   = for (lo + 1) hi (f lo acc) f
-  | otherwise = acc 
-
-dotProd v1 v2 = for 0 n 0 $ \i -> (((v1!i) {- * (v2!i) -}) +)
-  where n = Data.Vector.length v1
-
-sumSquare v = dotProd v v
-
-total = sumSquare $ Data.Vector.fromList [0..100] -- nums
-range i j = for i j [] (:)
-nums  = range 0 100 -- [0..100]
-
--- prop = liquidAssertB (total >= 0)
diff --git a/tests/pos/Vector1a.hs b/tests/pos/Vector1a.hs
deleted file mode 100644
--- a/tests/pos/Vector1a.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-module Vector1a () where
-
-import Language.Haskell.Liquid.Prelude
-import Data.Vector hiding (map, concat, zipWith, filter, foldr, foldl, (++))
-
-
-{-@ invariant {v:Int | v >= 0} @-}
-for :: Int -> Int -> a -> (Int -> a -> a) -> a
-for lo hi  = for' (hi-lo) lo hi
-
-for' :: Int -> Int -> Int -> a -> (Int -> a -> a) -> a
-for' d lo hi acc f 
-  | lo < hi   = for' (d-1) (lo + 1) hi (f lo acc) f
-  | otherwise = acc 
-
-dotProd       :: Vector Int -> Vector Int -> Int
-dotProd v1 v2 = for 0 n 0 $ \i -> (((v1!i) * (v2!i)) +)
-  where n = Data.Vector.length v1
-
-sumSquare   :: Vector Int -> Int
-sumSquare v = dotProd v v
-
-total = sumSquare $ Data.Vector.fromList [0..100]
diff --git a/tests/pos/Vector1b.hs b/tests/pos/Vector1b.hs
deleted file mode 100644
--- a/tests/pos/Vector1b.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-module Vector1b () where
-
-{-@ LIQUID "--no-termination" @-}
-
-import Language.Haskell.Liquid.Prelude
-import Data.Vector hiding (map, concat, zipWith, filter, foldl, foldr, (++))
-
-for lo hi acc f 
-  | lo < hi   = for (lo + 1) hi (f lo acc) f
-  | otherwise = acc 
-
-dotProd v1 v2 = for 0 n 0 $ \i -> (((v1!i) * (v2!i)) +)
-  where n = Data.Vector.length v1
-
-sumSquare v = dotProd v v
-
-total = sumSquare $ Data.Vector.fromList [0..100] -- nums
-range i j = for i j [] (:)
-nums  = range 0 100 -- [0..100]
diff --git a/tests/pos/Vector2.hs b/tests/pos/Vector2.hs
deleted file mode 100644
--- a/tests/pos/Vector2.hs
+++ /dev/null
@@ -1,70 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Vector2 (dotProduct, safeLookup) where
-
-import Prelude hiding (length)
-import Data.Vector
-import Language.Haskell.Liquid.Prelude (liquidAssert)
-    
-{-@ predicate Lt X Y      = X < Y                         @-}
-{-@ predicate Ge X Y      = not (Lt X Y)                  @-}
-{-@ predicate InBound I A = ((Ge I 0) && (Lt I (vlen A))) @-}
-
-{-@ invariant {v:Int | v >= 0} @-}
-{-@ unsafeLookup :: vec:Vector a 
-                 -> {v: Int | (0 <= v && v < (vlen vec)) } 
-                 -> a @-}
-unsafeLookup vec i = vec ! i
-
-{-@ unsafeLookup' :: vec:Vector a -> {v: Int | (InBound v vec)} -> a @-}
-unsafeLookup' vec i = vec ! i
-
-safeLookup x i 
-  | 0 <= i && i < length x = Just (x ! i)
-  | otherwise              = Nothing 
-
-{-@ absoluteSum   :: Vector Int -> {v: Int | 0 <= v}  @-}
-absoluteSum       :: Vector Int -> Int 
-absoluteSum vec   = if 0 < n then go n 0 0 else 0
-  where
-    go (d::Int) acc i 
-      | i /= n    = go (d-1) (acc + abz (vec ! i)) (i + 1)
-      | otherwise = acc 
-    n             = length vec
-
-abz n = if 0 <= n then n else (0 - n) 
-
-loop :: Int -> Int -> a -> (Int -> a -> a) -> a 
-loop lo hi base f = go (hi-lo) base lo
-  where
-    {-@ decrease go 1 @-}
-    go (d::Int) acc i     
-      | i /= hi   = go (d-1) (f i acc) (i + 1)
-      | otherwise = acc
-
-incr x = x + 1
-
-zoo = incr 29
-
-{-@ dotProduct :: x:(Vector Int) 
-               -> y:{v: Vector Int | (vlen v) = (vlen x)} 
-               -> Int 
-  @-}
-dotProduct     :: Vector Int -> Vector Int -> Int
-dotProduct x y 
-  | length x == length y
-  = loop 0 (length x) 0 (\i -> (+ (x ! i) * (y ! i))) 
-  | otherwise
-  = error "dotProduct only on equal-sized vectors!"
-
-
-{-@ type SparseVector a N = [({v: Int | (0 <= v && v < N)}, a)] @-}
-
-{-@ sparseDotProduct :: (Num a) => x:(Vector a) -> (SparseVector a {(vlen x)}) -> a @-}
-sparseDotProduct x y  = go 0 y
-  where
-    {-@ decrease go 2 @-}
-    go sum ((i, v) : y') = go (sum + (x ! i) * v) y' 
-    go sum []            = sum
-
-
diff --git a/tests/pos/VerifiedNum.hs b/tests/pos/VerifiedNum.hs
deleted file mode 100644
--- a/tests/pos/VerifiedNum.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-module VerifiedNum where
-
--- Hiding numeric operations, because they get by default translated to SMT equivalent
-import Prelude hiding (Num(..))
-
-import qualified Prelude as Prelude
-
-class VerifiedNum a where
-  (+) :: a -> a -> a
-  (-) :: a -> a -> a
-
-{-@ predicate BoundInt X = 0 < X + 10000 && X < 10000 @-}
-
-{-@ type OkInt N = {v:Int | BoundInt N => v == N} @-}
-
-{-@ type ValidInt = {v:Int | BoundInt v} @-}
-
-
-instance VerifiedNum Int where
-{-@ instance VerifiedNum Int where
-      + :: x:Int -> y:Int -> OkInt {x + y}
-  @-}
-    x + y = (Prelude.+) x y
-{-@ instance VerifiedNum Int where
-      - :: x:Int -> y:Int -> OkInt {x - y}
-  @-}
-    x - y = (Prelude.-) x y
-
diff --git a/tests/pos/WBL.hs b/tests/pos/WBL.hs
deleted file mode 100644
--- a/tests/pos/WBL.hs
+++ /dev/null
@@ -1,180 +0,0 @@
-
------------------------------------------------------------------------
--- Weight-Biased Leftist Heap, verified using LiquidHaskell -----------
------------------------------------------------------------------------
--- ORIGINAL SOURCE ----------------------------------------------------
------------------------------------------------------------------------
--- Copyright: 2014, Jan Stolarek, Politechnika Łódzka                --
---                                                                   --
--- License: See LICENSE file in root of the repo                     --
--- Repo address: https://github.com/jstolarek/dep-typed-wbl-heaps-hs --
---                                                                   --
--- Basic implementation of weight-biased leftist heap. No proofs     --
--- and no dependent types. Uses a two-pass merging algorithm.        --
------------------------------------------------------------------------
-
-{-@ LIQUID "--no-termination" @-}
-
-module WBL where
-
-type Priority = Int
-
-type Rank     = Int
-
-type Nat      = Int
-
-data Heap a   = Empty | Node { pri   :: a
-                             , rnk   :: Rank
-                             , left  :: Heap a
-                             , right :: Heap a
-                             }
-
-{-@ data Heap a  a -> Bool> =
-      Empty | Node { pri   :: a
-                   , rnk   :: Nat
-                   , left  :: {v: Heap (a) | ValidRank v}
-                   , right :: {v: Heap (a) | ValidRank v}
-                   }
- @-}
-
-{-@ predicate ValidRank V = okRank V && realRank V = rank V  @-}
-{-@ type PHeap a = {v:OHeap a | ValidRank v}                 @-}
-{-@ type OHeap a = Heap <{\root v -> root <= v}> a           @-}
-
-{-@ measure okRank @-}
-okRank :: Heap a -> Bool
-okRank Empty        = True
-okRank (Node p k l r) = ((realRank l >= realRank r) && k == (1 + (realRank l) + (realRank r)))
-
-{-@ measure realRank @-}
-realRank :: Heap a -> Int
-realRank Empty          = 0
-realRank (Node p k l r) = 1 + realRank l + realRank r
-
-
-{-@ invariant {v:Heap a | rank v == realRank (left v) + realRank (right v) && realRank v >= 0 } @-}  
-
-{-@ measure rank @-}
-{-@ assume rank :: h:Heap a -> {v:Nat | v = realRank h} @-}
-rank Empty          = 0
-rank (Node _ r _ _) = r
-
-
--- Creates heap containing a single element with a given Priority
-{-@ singleton :: a -> PHeap a  @-}
-singleton p = Node p 1 Empty Empty
-
--- Note [Two-pass merging algorithm]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- We use a two-pass implementation of merging algorithm. One pass,
--- implemented by merge, performs merging in a top-down manner. Second
--- one, implemented by makeT, ensures that rank   riant of weight
--- biased leftist tree is not violated after merging.
---
--- Notation:
---
---  h1, h2 - heaps being merged
---  p1, p2 - priority of root element in h1 and h2
---  l1     - left  subtree in the first  heap
---  r1     - right subtree in the first  heap
---  l2     - left  subtree in the second heap
---  r2     - right subtree in the second heap
---
--- Merge function analyzes four cases. Two of them are base cases:
---
---    a) h1 is empty - return h2
---
---    b) h2 is empty - return h1
---
--- The other two cases form the inductive definition of merge:
---
---    c) priority p1 is higher than p2 - p1 becomes new root, l1
---       becomes its one child and result of merging r1 with h2
---       becomes the other child:
---
---               p1
---              /  \
---             /    \
---            l1  r1+h2 -- here "+" denotes merging
---
---    d) priority p2 is higher than p2 - p2 becomes new root, l2
---       becomes its one child and result of merging r2 with h1
---       becomes the other child.
---
---               p2
---              /  \
---             /    \
---            l2  r2+h1
---
--- Note that there is no guarantee that rank of r1+h2 (or r2+h1) will
--- be smaller than rank of l1 (or l2). To ensure that merged heap
--- maintains the rank invariant we pass both childred - ie. either l1
--- and r1+h2 or l2 and r2+h1 - to makeT, which creates a new node by
--- inspecting sizes of children and swapping them if necessary.
-
--- makeT takes an element (Priority) and two heaps (trees). It
--- constructs a new heap with element at the root and two heaps as
--- children. makeT ensures that WBL heap rank invariant is maintained
--- in the newly created tree by reversing left and right subtrees when
--- necessary (note the inversed r and l in the False alternative of
--- case expression).
-{-@ makeT   :: p:a -> h1:PHeap {v:a | p <= v} -> h2:PHeap {v:a | p <= v}
-            -> {v:PHeap a | realRank v = 1 + realRank h1 + realRank h2} @-}
-makeT p l r = case rank l >= rank r of
-                True  ->  Node p (1 + rank l + rank r) l r
-                False ->  Node p (1 + rank l + rank r) r l
-
--- merge combines two heaps into one. There are two base cases and two
--- recursive cases - see [Two-pass Merging algorithm]. Recursive cases
--- call makeT to ensure that rank invariant is maintained after
--- merging.
-{-@ merge :: (Ord a) => h1:PHeap a -> h2:PHeap a -> {v:PHeap a | realRank v = realRank h1 + realRank h2}  @-}
-merge Empty h2 = h2
-merge h1 Empty = h1
-merge h1@(Node p1 k1 l1 r1) h2@(Node p2 k2 l2 r2) = case p1 < p2 of
-  True  -> makeT p1 l1 (merge r1 (Node p2 k2 l2 r2))
-  False -> makeT p2 l2 (merge (Node p1 k1 l1 r1) r2)
-
--- Inserting into a heap is performed by merging that heap with newly
--- created singleton heap.
-{-@ insert :: (Ord a) => a -> PHeap a -> PHeap a @-}
-insert p h = merge (singleton p) h
-
--- findMin returns element with highest priority, ie. root
--- element. Here we encounter first serious problem: we can't return
--- anything sensible for empty node.
-{-@ findMin :: PHeap a -> a @-}
-findMin Empty          = undefined
-findMin (Node p _ _ _) = p
-
--- and write a safer version of findMinM
-{-@ findMinM :: PHeap a -> Maybe a @-}
-findMinM Empty          = Nothing
-findMinM (Node p _ _ _) = Just p
-
--- deleteMin removes the element with the highest priority by merging
--- subtrees of a root element. Again the case of empty heap is
--- problematic. We could give it semantics by returning Empty, but
--- this just doesn't feel right. Why should we be able to remove
--- elements from an empty heap?
-{-@ deleteMin :: (Ord a) => PHeap a -> PHeap a @-}
-deleteMin Empty          = undefined -- should we insert empty?
-deleteMin (Node _ _ l r) = merge l r
-
--- As a quick sanity check let's construct some examples. Here's a
--- heap constructed by inserting following priorities into an empty
--- heap: 3, 0, 1, 2.
-{-@ heap :: PHeap Int @-}
-heap = insert (2 :: Int)
-      (insert 1
-      (insert 0
-      (insert 3 Empty)))
-
--- Example usage of findMin
-findMinInHeap :: Priority
-findMinInHeap = findMin heap
-
--- Example usage of deleteMin
-deleteMinFromHeap :: Heap Int
-deleteMinFromHeap = deleteMin heap
diff --git a/tests/pos/WBL0.hs b/tests/pos/WBL0.hs
deleted file mode 100644
--- a/tests/pos/WBL0.hs
+++ /dev/null
@@ -1,179 +0,0 @@
-
------------------------------------------------------------------------
--- Weight-Biased Leftist Heap, verified using LiquidHaskell -----------
------------------------------------------------------------------------
--- ORIGINAL SOURCE ----------------------------------------------------
------------------------------------------------------------------------
--- Copyright: 2014, Jan Stolarek, Politechnika Łódzka                --
---                                                                   --
--- License: See LICENSE file in root of the repo                     --
--- Repo address: https://github.com/jstolarek/dep-typed-wbl-heaps-hs --
---                                                                   --
--- Basic implementation of weight-biased leftist heap. No proofs     --
--- and no dependent types. Uses a two-pass merging algorithm.        --
------------------------------------------------------------------------
-
-{-@ LIQUID "--no-termination" @-}
-
-module WBL0 where
-
-type Priority = Int
-
-type Rank     = Int
-
-type Nat      = Int
-
-data Heap a   = Empty | Node { pri   :: a
-                             , rnk   :: Rank
-                             , left  :: Heap a
-                             , right :: Heap a
-                             }
-
-{-@ data Heap a  a -> Bool> =
-      Empty | Node { pri   :: a
-                   , rnk   :: Nat
-                   , left  :: {v: Heap (a) | ValidRank v}
-                   , right :: {v: Heap (a) | ValidRank v}
-                   }
- @-}
-
-{-@ predicate ValidRank V = okRank V && realRank V = rank V  @-}
-{-@ type PHeap a = {v:OHeap a | ValidRank v}                 @-}
-{-@ type OHeap a = Heap <{\root v -> root <= v}> a           @-}
-
-{-@ measure okRank @-}
-okRank :: Heap a -> Bool
-okRank (Empty)        = True
-okRank (Node p k l r) = realRank l >= realRank r && k == 1 + realRank l + realRank r
-
-{-@ measure realRank @-}
-realRank :: Heap a -> Int
-realRank (Empty)        = 0
-realRank (Node p k l r) = 1 + realRank l + realRank r
-
-{-@ invariant {v:Heap a | rank v == realRank v } @-}
-
-{-@ measure rank @-}
-{-@ rank :: h:Heap a -> {v:Nat | v = realRank h} @-}
-rank Empty          = 0
-rank (Node _ r _ _) = r
-
-
--- Creates heap containing a single element with a given Priority
-{-@ singleton :: a -> PHeap a  @-}
-singleton p = Node p 1 Empty Empty
-
--- Note [Two-pass merging algorithm]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- We use a two-pass implementation of merging algorithm. One pass,
--- implemented by merge, performs merging in a top-down manner. Second
--- one, implemented by makeT, ensures that rank invariant of weight
--- biased leftist tree is not violated after merging.
---
--- Notation:
---
---  h1, h2 - heaps being merged
---  p1, p2 - priority of root element in h1 and h2
---  l1     - left  subtree in the first  heap
---  r1     - right subtree in the first  heap
---  l2     - left  subtree in the second heap
---  r2     - right subtree in the second heap
---
--- Merge function analyzes four cases. Two of them are base cases:
---
---    a) h1 is empty - return h2
---
---    b) h2 is empty - return h1
---
--- The other two cases form the inductive definition of merge:
---
---    c) priority p1 is higher than p2 - p1 becomes new root, l1
---       becomes its one child and result of merging r1 with h2
---       becomes the other child:
---
---               p1
---              /  \
---             /    \
---            l1  r1+h2 -- here "+" denotes merging
---
---    d) priority p2 is higher than p2 - p2 becomes new root, l2
---       becomes its one child and result of merging r2 with h1
---       becomes the other child.
---
---               p2
---              /  \
---             /    \
---            l2  r2+h1
---
--- Note that there is no guarantee that rank of r1+h2 (or r2+h1) will
--- be smaller than rank of l1 (or l2). To ensure that merged heap
--- maintains the rank invariant we pass both childred - ie. either l1
--- and r1+h2 or l2 and r2+h1 - to makeT, which creates a new node by
--- inspecting sizes of children and swapping them if necessary.
-
--- makeT takes an element (Priority) and two heaps (trees). It
--- constructs a new heap with element at the root and two heaps as
--- children. makeT ensures that WBL heap rank invariant is maintained
--- in the newly created tree by reversing left and right subtrees when
--- necessary (note the inversed r and l in the False alternative of
--- case expression).
-{-@ makeT   :: p:a -> h1:PHeap {v:a | p <= v} -> h2:PHeap {v:a | p <= v}
-            -> {v:PHeap a | realRank v = 1 + realRank h1 + realRank h2} @-}
-makeT p l r = case rank l >= rank r of
-                True  ->  Node p (1 + rank l + rank r) l r
-                False ->  Node p (1 + rank l + rank r) r l
-
--- merge combines two heaps into one. There are two base cases and two
--- recursive cases - see [Two-pass Merging algorithm]. Recursive cases
--- call makeT to ensure that rank invariant is maintained after
--- merging.
-{-@ merge :: (Ord a) => h1:PHeap a -> h2:PHeap a -> {v:PHeap a | realRank v = realRank h1 + realRank h2}  @-}
-merge Empty h2 = h2
-merge h1 Empty = h1
-merge h1@(Node p1 k1 l1 r1) h2@(Node p2 k2 l2 r2) = case p1 < p2 of
-  True  -> makeT p1 l1 (merge r1 (Node p2 k2 l2 r2))
-  False -> makeT p2 l2 (merge (Node p1 k1 l1 r1) r2)
-
--- Inserting into a heap is performed by merging that heap with newly
--- created singleton heap.
-{-@ insert :: (Ord a) => a -> PHeap a -> PHeap a @-}
-insert p h = merge (singleton p) h
-
--- findMin returns element with highest priority, ie. root
--- element. Here we encounter first serious problem: we can't return
--- anything sensible for empty node.
-{-@ findMin :: PHeap a -> a @-}
-findMin Empty          = undefined
-findMin (Node p _ _ _) = p
-
--- and write a safer version of findMinM
-{-@ findMinM :: PHeap a -> Maybe a @-}
-findMinM Empty          = Nothing
-findMinM (Node p _ _ _) = Just p
-
--- deleteMin removes the element with the highest priority by merging
--- subtrees of a root element. Again the case of empty heap is
--- problematic. We could give it semantics by returning Empty, but
--- this just doesn't feel right. Why should we be able to remove
--- elements from an empty heap?
-{-@ deleteMin :: (Ord a) => PHeap a -> PHeap a @-}
-deleteMin Empty          = undefined -- should we insert empty?
-deleteMin (Node _ _ l r) = merge l r
-
--- As a quick sanity check let's construct some examples. Here's a
--- heap constructed by inserting following priorities into an empty
--- heap: 3, 0, 1, 2.
-{-@ heap :: PHeap Int @-}
-heap = insert (2 :: Int)
-      (insert 1
-      (insert 0
-      (insert 3 Empty)))
-
--- Example usage of findMin
-findMinInHeap :: Priority
-findMinInHeap = findMin heap
-
--- Example usage of deleteMin
-deleteMinFromHeap :: Heap Int
-deleteMinFromHeap = deleteMin heap
diff --git a/tests/pos/WhyLH.hs b/tests/pos/WhyLH.hs
deleted file mode 100644
--- a/tests/pos/WhyLH.hs
+++ /dev/null
@@ -1,139 +0,0 @@
-module WhyLH where
-
-{-@ LIQUID "--ple" @-}
-{-@ LIQUID "--exact-data-cons" @-}
-
--- This test contains the examples of the blogpost at
--- https://www.tweag.io/blog/2022-01-19-why-liquid-haskell/
---
-import Language.Haskell.Liquid.ProofCombinators (pleUnfold)
-import Prelude hiding (length, max)
-
-{-@
-type Nat = {i:Int | 0 <= i}
-
-data UExp
-  = UVar Nat
-  | ULam Ty UExp
-  | UApp { uapp1 :: UExp, uapp2 :: UExp }
- @-}
--- | Lambda expressions with types at the bindings.
-data UExp
-  = UVar Int
-  | ULam Ty UExp
-  | UApp { uapp1 :: UExp, uapp2 :: UExp }
-
--- | The types are the types of functions manipulating some opaque type @T@.
-data Ty = T | TyFun Ty Ty
-  deriving Eq
-
--- XXX: Using inline instead of reflect causes verification to fail
-{-@ reflect max @-}
-max :: Int -> Int -> Int
-max a b = pleUnfold (if a > b then a else b)
-
--- XXX: using max causes verification to fail if not using
--- --ple-with-undecided-guards. Arguably, PLE should unfold max
--- since it is not doing pattern matching.
-{-@
-reflect freeVarBound
-freeVarBound :: UExp -> Int
-@-}
--- | Compute the lowest upper-bound of de Bruijn indices appearing
--- free in an expression.
-freeVarBound :: UExp -> Int
-freeVarBound (UVar v) = v + 1
-freeVarBound (ULam _ body) = max (freeVarBound body - 1) 0
-freeVarBound (UApp e1 e2) = max (freeVarBound e1) (freeVarBound e2)
-
-{-@
-type UExpN N = { e:UExp | freeVarBound e <= N }
-type ClosedUExp = UExpN 0
-@-}
-
-{-@ exp0 :: ClosedUExp @-}
-exp0 :: UExp
-exp0 = ULam T (UVar 0)
-
-{-@ exp1 :: UExpN 1 @-}
-exp1 :: UExp
-exp1 = UVar 0
-
-{-@ exp2 :: ClosedUExp @-}
-exp2 :: UExp
-exp2 = ULam T (ULam T (UVar 0))
-
-{-@ exp3 :: UExpN 1 @-}
-exp3 :: UExp
-exp3 = ULam T (ULam T (UVar 2))
-
-
-{-@ reflect elemAt @-}
-{-@ elemAt :: xs:[a] -> { i:Int | 0 <= i && i < length xs } -> a @-}
-elemAt :: [a] -> Int -> a
-elemAt (x:_) 0 = x
-elemAt (_:xs) i = elemAt xs (i - 1)
-
-{-@ reflect length @-}
-length :: [a] -> Int
-length [] = 0
-length (_:xs) = 1 + length xs
-
-{-@ reflect inferType @-}
-{-@ inferType :: ctx:[Ty] -> UExpN (length ctx) -> Maybe Ty @-}
-inferType :: [Ty] -> UExp -> Maybe Ty
-inferType ctx (UVar i) = Just (elemAt ctx i)
-inferType ctx (ULam t body) = case inferType (t:ctx) body of
-  Just r -> Just (TyFun t r)
-  Nothing -> Nothing
-inferType ctx (UApp e0 e1) =
-  pleUnfold  -- needed by uappArgT to avoid breaking the verification
-             -- in all of these cases
-    (case inferType ctx e0 of
-      Just (TyFun a r) -> case inferType ctx e1 of
-        Just t -> if a == t then Just r else Nothing
-        Nothing -> Nothing
-      _ -> Nothing
-    )
-
-{-@ type WellTypedExp CTX TY = { e:UExp | freeVarBound e <= length CTX && inferType CTX e == Just TY } @-}
-
-{-@ reflect cons @-}
-cons :: a -> [a] -> [a]
-cons = (:)
-
-{-@ exp4 :: WellTypedExp (cons T []) T @-}
-exp4 :: UExp
-exp4 = UVar 0
-
-{-@ exp5 :: WellTypedExp [] (TyFun T T) @-}
-exp5 :: UExp
-exp5 = ULam T (UVar 0)
-
-main :: IO ()
-main = print ()
-
--- The following functions are an experiment on what LH can infer from
--- the arguments of a data constructor. Given a well-typed application
--- @UApp e0 e1@, can LH infer that @e0@ must have a function type and
--- that the type of @e1@ must match the argument type of @e0@.
-
-{-@ uappArgT :: ctx:[Ty] -> e : { e:UExp | isUApp e && isJustTy (inferType ctx e) } -> { funTyM (inferType ctx (uapp2 e)) (inferType ctx e) == inferType ctx (uapp1 e) } @-}
-uappArgT :: [Ty] -> UExp -> ()
-uappArgT _ _ = ()
-
-{-@ inline isUApp @-}
-isUApp :: UExp -> Bool
-isUApp (UApp _ _) = True
-isUApp _ = False
-
--- Either inline or both reflect and pleUnfold are needed by `uappArgT`.
-{-@ inline isJustTy @-}
-isJustTy :: Maybe a -> Bool
-isJustTy (Just _) = True
-isJustTy _ = False
-
-{-@ inline funTyM @-}
-funTyM :: Maybe Ty -> Maybe Ty -> Maybe Ty
-funTyM (Just a) (Just b) = Just (TyFun a b)
-funTyM _ _ = Nothing
diff --git a/tests/pos/Words.hs b/tests/pos/Words.hs
deleted file mode 100644
--- a/tests/pos/Words.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-
-module Words where
-
-import Data.Word
-
-{-@ foo :: {v:Word | v = 4} @-}
-foo :: Word
-foo = 4
diff --git a/tests/pos/Words1.hs b/tests/pos/Words1.hs
deleted file mode 100644
--- a/tests/pos/Words1.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module Words1 where
-
-import Data.Word
-
-main = print (quotRem (4 :: Word8) 128)
diff --git a/tests/pos/Wrap0.hs b/tests/pos/Wrap0.hs
deleted file mode 100644
--- a/tests/pos/Wrap0.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-module Wrap0 () where
-
-import Language.Haskell.Liquid.Prelude (liquidError, liquidAssertB)
-
-data Foo a = F a
-
-type IntFoo = Foo Int
-
-{-@ flibberty :: (Eq a) => a -> Bool @-}
-flibberty x   = prop x (F x)
-prop x (F y)  = liquidAssertB (x == y)
-
-{-@ flibInt :: (Num a, Ord a) => a -> Bool @-}
-flibInt x     = prop1 x (F (x + 1))
-prop1 x (F y) = liquidAssertB (x < y) 
-
-{-@ flibXs :: a -> Bool @-}
-flibXs x     = prop2 (F [x, x, x])
-prop2 (F []) = liquidError "not-the-hippopotamus"
-prop2 (F _ ) = True
diff --git a/tests/pos/Wrap1.hs b/tests/pos/Wrap1.hs
deleted file mode 100644
--- a/tests/pos/Wrap1.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
-
-module Wrap1 () where
-
-
-import Language.Haskell.Liquid.Prelude (liquidError, liquidAssertB)
-import Data.Function (on)
-import Data.Ord (comparing)
-
-data WrapType b a = WrapType {getVect :: b, getVal :: a}
-
-instance Eq (WrapType [Double] a) where
-   (==) = (==) `on` getVect
-
-instance Ord (WrapType [Double] a) where
-    compare = comparing getVect
-
-{-@ assert flibXs :: a -> Bool @-}
-flibXs x              = prop1 (WrapType [x, x, x] x)
-prop1 (WrapType [] _) = liquidError "no!"
-prop1 (WrapType _  _) = True
-
-{-@ assert nflibXs :: Nat -> a -> Bool @-}
-nflibXs n x           = prop2 n (WrapType nxs x)
-                        where nxs = replicate n x 
-
-prop2 :: Int -> WrapType [a] t -> Bool
-prop2 n (WrapType xs _) = liquidAssertB (n == length xs) 
-
-
-
-
-
diff --git a/tests/pos/WrapUnWrap.hs b/tests/pos/WrapUnWrap.hs
deleted file mode 100644
--- a/tests/pos/WrapUnWrap.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-{-@ LIQUID "--higherorder"  @-}
-{-@ LIQUID "--exactdc"      @-}
-module WrapUnWrap where
-
-
-import Language.Haskell.Liquid.ProofCombinators
-
-data    Prod1 a = Prod1 {unprod1 :: a }
-{-@ data Prod1 a = Prod1 {unprod1 :: a } @-}
-
-prod1Theorem :: Prod1 a -> Proof 
-{-@ prod1Theorem :: x:Prod1 a -> {x == Prod1 (unprod1 x)} @-}
-prod1Theorem (Prod1 _) = trivial 
diff --git a/tests/pos/ZipSO.hs b/tests/pos/ZipSO.hs
deleted file mode 100644
--- a/tests/pos/ZipSO.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-module ZipSO () where
-
--- From
--- http://stackoverflow.com/questions/17501777/implementing-a-zipper-for-length-indexed-lists/17503667#17503667
-
-import Prelude hiding ((++))
-
-{-@ zipper :: zs:[a] -> [(a, {v:[a] | (len v) = (len zs) - 1})] @-}
-zipper zs          = go [] zs
-  
-{-@ go :: prev:[a] -> rest:[a] -> [(a, {v:[a] | (len v) = (len prev) + (len rest) - 1})] / [len rest]  @-}
-go :: [a] -> [a] -> [(a, [a])]
-go _    []     = []
-go prev (x:xs) = (x, prev ++ xs) : go (prev ++ [x]) xs
-
-{-@ append :: xs:[a] -> ys:[a] -> {v:[a] | (len v) = (len xs) + (len ys)} @-}
-append [] ys     = ys
-append (x:xs) ys = x : append xs ys
-
-(++) = append
diff --git a/tests/pos/ZipW.hs b/tests/pos/ZipW.hs
deleted file mode 100644
--- a/tests/pos/ZipW.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-module ZipW () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ assert zipW :: (a -> b -> c) -> xs : [a] -> ys:{v:[b] | len(v) = len(xs)} -> {v : [c] | len(v) = len(xs)} @-}
-zipW :: (a->b->c) -> [a]->[b]->[c]
-zipW f (a:as) (b:bs) = f a b : zipW f as bs
-zipW _ [] []         = []
-zipW _ [] (_:_)      = liquidError "zipWith1"
-zipW _ (_:_) []      = liquidError "zipWith1"
-
-{-@ assert foo :: (a -> b -> c) -> xs : [a] -> ys:{v:[b] | len(v) = len(xs)} -> {v : [c] | len(v) = len(xs)} @-}
-foo = zipW
-
diff --git a/tests/pos/ZipW1.hs b/tests/pos/ZipW1.hs
deleted file mode 100644
--- a/tests/pos/ZipW1.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module ZipW1 where
-
-import Language.Haskell.Liquid.Prelude -- (safeZipWith)
-
-{-@ foo :: (a -> b -> c) -> xs : [a] -> ys:{v:[b] | len v = len xs}
-        -> {v : [c] | len v  = len xs} @-}
-foo = safeZipWith
-
-
-{- safeZipWith :: (a -> b -> c) -> xs : [a] -> ys:{v:[b] | len v = len xs}
-                -> {v : [c] | len v = len xs} @-}
diff --git a/tests/pos/ZipW2.hs b/tests/pos/ZipW2.hs
deleted file mode 100644
--- a/tests/pos/ZipW2.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module ZipW2 where
-
-
-foo :: [Int] -> [Int]
-foo zs = zipWith (+) zs zs
diff --git a/tests/pos/Zipper.hs b/tests/pos/Zipper.hs
deleted file mode 100644
--- a/tests/pos/Zipper.hs
+++ /dev/null
@@ -1,165 +0,0 @@
-module Zipper (getFocus, getUp, getDown) where
-
-import Prelude hiding (reverse, (++))
-
-import Data.Set
-
-data Stack a = Stack { focus  :: !a        -- focused thing in this set
-                     , up     :: [a]       -- jokers to the left
-                     , down   :: [a] }     -- jokers to the right
-    deriving (Show, Eq)
--- LIQUID     deriving (Show, Read, Eq)
-
--------------------------------------------------------------------------------
------------------------------ Refinements on  Lists ---------------------------
--------------------------------------------------------------------------------
-
--- measures
-
-{-@
-  measure listDup :: forall a. [a] -> (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) }
-  @-}
-
--- predicates
-
-{-@ predicate EqElts X Y =
-       ((listElts X) = (listElts Y)) @-}
-
-{-@ predicate SubElts X Y =
-       (Set_sub (listElts X) (listElts Y)) @-}
-
-{-@ predicate UnionElts X Y Z =
-       ((listElts X) = (Set_cup (listElts Y) (listElts Z))) @-}
-
-{-@ predicate ListElt N LS =
-       (Set_mem N (listElts LS)) @-}
-
-{-@ predicate ListUnique LS =
-       (Set_emp (listDup LS)) @-}
-
-{-@ predicate ListDisjoint X Y =
-       (Set_emp (Set_cap (listElts X) (listElts Y))) @-}
-
-
--- types
-
-{-@ type UList a = {v:[a] | (ListUnique v)} @-}
-
-{-@ type UListDif a N = {v:[a] | ((not (ListElt N v)) && (ListUnique v))} @-}
-
-
-
--------------------------------------------------------------------------------
------------------------------ Refinements on Stacks ---------------------------
--------------------------------------------------------------------------------
-
-{-@
-data Stack a = Stack { focus :: a
-                     , up    :: UListDif a focus
-                     , down  :: UListDif a focus }
-@-}
-
-{-@ type UStack a = {v:Stack a | (ListDisjoint (getUp v) (getDown v))}@-}
-
-{-@ measure getFocus @-}
-getFocus :: Stack a -> a
-getFocus (Stack xfocus _ _) = xfocus
-
-{-@ measure getUp @-}
-getUp :: Stack a -> [a]
-getUp (Stack xfocus xup xdown) = xup
-
-{-@ measure getDown @-}
-getDown :: Stack a -> [a]
-getDown (Stack xfocus xup xdown) = xdown
-
-
--------------------------------------------------------------------------------
------------------------------- Functions on Stacks ----------------------------
--------------------------------------------------------------------------------
-
-
-{-@ differentiate :: UList a -> Maybe (UStack a) @-}
-differentiate :: [a] -> Maybe (Stack a)
-differentiate []     = Nothing
-differentiate (x:xs) = Just $ Stack x [] xs
-
-{-@ integrate :: UStack a -> UList a @-}
-integrate :: Stack a -> [a]
-integrate (Stack x l r) = reverse l ++ x : r
-
-{-@ integrate' :: Maybe (UStack a) -> UList a @-}
-integrate' :: Maybe (Stack a) -> [a]
-integrate' = maybe [] integrate
-
-
-{-@ focusUp :: UStack a -> UStack a @-}
-focusUp :: Stack a -> Stack a
-focusUp (Stack t [] rs)     = Stack x xs [] where (x:xs) = reverse (t:rs)
-focusUp (Stack t (l:ls) rs) = Stack l ls (t:rs)
-
-{-@ focusDown :: UStack a -> UStack a @-}
-focusDown :: Stack a -> Stack a
-focusDown = reverseStack . focusUp . reverseStack
-
-{-@ reverseStack :: UStack a -> UStack a @-}
-reverseStack :: Stack a -> Stack a
-reverseStack (Stack t ls rs) = Stack t rs ls
-
-{-@ swapUp :: UStack a -> UStack a @-}
-swapUp :: Stack a -> Stack a
-swapUp  (Stack t (l:ls) rs) = Stack t ls (l:rs)
-swapUp  (Stack t []     rs) = Stack t (reverse  rs) []
-
-{-@ filter :: (a -> Bool) -> UStack a -> Maybe (UStack a) @-}
-filter :: (a -> Bool) -> Stack a -> Maybe (Stack a)
-filter p (Stack f ls rs) = case filterL p (f:rs) of
-    f':rs' -> Just $ Stack f' (filterL p ls) rs'    -- maybe move focus down
-    []     -> case filterL p ls of                  -- filter back up
-                    f':ls' -> Just $ Stack f' ls' [] -- else up
-                    []     -> Nothing
-
-
--------------------------------------------------------------------------------
-------------------------------- Functions on Lists ----------------------------
--------------------------------------------------------------------------------
-
-
-infixr 5 ++
-{-@ Zipper.++ :: xs:(UList a)
-         -> ys:{v: UList a | (ListDisjoint v xs)}
-         -> {v: UList a | (UnionElts v xs ys)}
-  @-}
-(++) :: [a] -> [a] -> [a]
-[] ++ ys = ys
-(x:xs) ++ ys = x: (xs ++ ys)
-
-
-{-@ reverse :: xs:(UList a)
-            -> {v: UList a | (EqElts v xs)}
-  @-}
-reverse :: [a] -> [a]
-reverse = rev []
-
-
-{-@ rev :: acc:(UList a)
-        -> xs:{v: UList a | ListDisjoint acc v }
-        -> {v:UList a | UnionElts v xs acc } / [len xs]
-  @-}
-rev :: [a] -> [a] -> [a]
-rev a []     = a
-rev a (x:xs) = rev (x:a) xs
-
-{-@ filterL :: (a -> Bool) -> xs:(UList a) -> {v:UList a | (SubElts v xs)} @-}
-filterL :: (a -> Bool) -> [a] -> [a]
-filterL p [] = []
-filterL p (x:xs) | p x       = x : filterL p xs
-                 | otherwise = filterL p xs
-
-
--- QUALIFIERS
-{-@ q :: x:a ->  {v:[a] |(not (Set_mem x (listElts v)))} @-}
-q :: a -> [a]
-q = undefined
diff --git a/tests/pos/Zipper0.hs b/tests/pos/Zipper0.hs
deleted file mode 100644
--- a/tests/pos/Zipper0.hs
+++ /dev/null
@@ -1,71 +0,0 @@
-{-@ LIQUID "--no-totality" @-}
-
-module Zipper0 (getUp, getDown, getFocus) where
-
-import Prelude hiding (reverse)
-
-import Data.Set
-
-data Stack a = Stack { focus  :: !a        -- focused thing in this set
-                     , up     :: [a]       -- jokers to the left
-                     , down   :: [a] }     -- jokers to the right
-
-{-@ type UListDif a N = {v:[a] | ((not (Set_mem N (listElts v))) && (Set_emp (listDup v)))} @-}
-
-{-@
-data Stack a = Stack { focus :: a
-                     , up    :: UListDif a focus
-                     , down  :: UListDif a focus }
-@-}
-
-{-@ measure listDup :: [a] -> (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) }
-  @-}
-
-{-@ type UStack a = {v:Stack a |(Set_emp (Set_cap (listElts (getUp v)) (listElts (getDown v))))}@-}
-
-{-@ measure getFocus @-}
-getFocus :: Stack a -> a
-getFocus (Stack xfocus _ _) = xfocus
-
-{-@ measure getUp @-}
-getUp :: Stack a -> [a]
-getUp (Stack xfocus xup xdown) = xup
-
-{-@ measure getDown @-}
-getDown :: Stack a -> [a]
-getDown (Stack xfocus xup xdown) = xdown
-
-
--- QUALIFIERS
-{-@ q :: x:a ->  {v:[a] |(not (Set_mem x (listElts v)))} @-}
-q :: a -> [a]
-q = undefined
-{-@ q1 :: x:a ->  {v:[a] |(Set_mem x (listElts v))} @-}
-q1 :: a -> [a]
-q1 = undefined
-{-@ q0 :: x:a ->  {v:[a] |(Set_emp(listDup v))} @-}
-q0 :: a -> [a]
-q0 = undefined
-
-
-{-@ focusUp :: UStack a -> UStack a @-}
-focusUp :: Stack a -> Stack a
-focusUp (Stack t [] rs)     = Stack xiggety xs [] where (xiggety:xs) = reverse (t:rs)
-focusUp (Stack t (l:ls) rs) = Stack l ls (t:rs)
-
-{-@ focusDown :: UStack a -> UStack a @-}
-focusDown :: Stack a -> Stack a
-focusDown = reverseStack . focusUp . reverseStack
-
--- | reverse a stack: up becomes down and down becomes up.
-{-@ reverseStack :: UStack a -> UStack a @-}
-reverseStack :: Stack a -> Stack a
-reverseStack (Stack t ls rs) = Stack t rs ls
-
-
--- TODO ASSUMES
-{-@ reverse :: {v:[a] | (Set_emp (listDup v))} -> {v:[a]|(Set_emp (listDup v))} @-}
-reverse :: [a] -> [a]
-reverse = undefined
diff --git a/tests/pos/Zipper000.hs b/tests/pos/Zipper000.hs
deleted file mode 100644
--- a/tests/pos/Zipper000.hs
+++ /dev/null
@@ -1,44 +0,0 @@
-{-@ LIQUID "--no-totality" @-}
-
-module Zipper000 (getUp, getDown) where
-
-import Data.Set
-
-data Stack a = Stack { focus  :: a        -- focused thing in this set
-                     , up     :: [a]       -- jokers to the left
-                     , down   :: [a] }     -- jokers to the right
-
-{-@ type UListDif a N = {v:[a] | not (Set_mem N (listElts v)) } @-}
-
-{-@ data Stack a = Stack 
-      { focus :: a
-      , up    :: UListDif a focus
-      , down  :: UListDif a focus 
-      }
-  @-}
-
-{-@ type UStack a = {v:Stack a | (Set_emp (Set_cap (listElts (getUp v)) (listElts (getDown v))))} @-}
-
-{-@ measure getUp @-}
-getUp :: Stack a -> [a]
-getUp (Stack xfocus xup xdown) = xup
-
-{-@ measure getDown @-}
-getDown :: Stack a -> [a]
-getDown (Stack xfocus xup xdown) = xdown
-
-data Foo a b = J | P a b
-
---------------------------------------------------------------------------------------
-{-@ focusUp :: UStack a -> UStack a @-}
-focusUp :: Stack a -> Stack a
-focusUp (Stack t [] rs) = Stack xiggety xs []
-  where P xiggety xs    = P t rs
-
--- focusUp (Stack t [] rs) = Stack t rs []
-
-
-
-
-
---------------------------------------------------------------------------------------
diff --git a/tests/pos/isort_erase.hs b/tests/pos/isort_erase.hs
deleted file mode 100644
--- a/tests/pos/isort_erase.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple"        @-}
-
-module Isort_erase where 
-
-import Prelude hiding (id, sum)
-import Language.Haskell.Liquid.ProofCombinators
-import Data.Set (Set)
-import qualified Data.Set as Set
-
-data List = Emp | Cons Int List
-
-{-@ reflect isSorted @-}
-isSorted :: List -> Bool
-isSorted Emp = True
-isSorted (Cons x xs) = case xs of
-                        Emp -> True
-                        Cons x1 xs1 -> (x <= x1) && (isSorted xs)
-
-
-{-@ reflect insert @-}
-{-@ insert :: x:Int -> {xs:List | isSorted xs} -> {xs:List | isSorted xs} @-}
-insert :: Int -> List -> List 
-insert x Emp     = Cons x Emp
-insert x (Cons y ys)
-  | x <= y        = Cons x (Cons y ys)
-  | otherwise     = (Cons y (insert x ys)) `withProof` (lem_ins y x ys) 
-
-{-@ lem_ins :: y:Int -> {x:Int | y < x} -> {ys:List | isSorted (Cons y ys)} -> {isSorted (Cons y (insert x ys))} @-}
-lem_ins :: Int -> Int -> List -> Bool
-lem_ins y x Emp = True
-lem_ins y x (Cons y1 ys) = if y1 < x then lem_ins y1 x ys else True
-
diff --git a/tests/pos/listSet.hquals b/tests/pos/listSet.hquals
deleted file mode 100644
--- a/tests/pos/listSet.hquals
+++ /dev/null
@@ -1,4 +0,0 @@
-qualif Cup1(v: [a] , xs : [a] , ys : [a]): (listElts v = Set_cup (listElts xs) (listElts ys))
-qualif Cup2(v: [a] , xs : [a] , ys : [a]): (listElts xs = Set_cup (listElts v) (listElts ys))
-qualif IsEmp(v: [a]) : (Set_emp (listElts v))
-qualif EqSet(v: [a], xs: [a]) : (listElts v = listElts xs)
diff --git a/tests/pos/selfList.hquals b/tests/pos/selfList.hquals
deleted file mode 100644
--- a/tests/pos/selfList.hquals
+++ /dev/null
@@ -1,1 +0,0 @@
-qualif SelfSet(v : a, xs : [a]): (Set_mem v (listElts xs))
diff --git a/tests/pos/test000.hs.hquals b/tests/pos/test000.hs.hquals
deleted file mode 100644
--- a/tests/pos/test000.hs.hquals
+++ /dev/null
@@ -1,1 +0,0 @@
-qualif Foo(v: Int): v = 10