packages feed

liquidhaskell 0.8.6.2 → 0.8.10.1

raw patch · 468 files changed

+13009/−8416 lines, 468 filesdep +Cabaldep +extradep +mustachedep −hintdep ~basedep ~cmdargsdep ~containersnew-component:exe:mirror-modulesnew-uploader

Dependencies added: Cabal, extra, mustache, optics, shelly, split, string-conv, tasty-golden

Dependencies removed: hint

Dependency ranges changed: base, cmdargs, containers, directory, filepath, ghc, hashable, hscolour, liquid-fixpoint, optparse-applicative, process, tasty, tasty-hunit, text

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

Files

− .DS_Store

binary file changed (10244 → absent bytes)

− ._.DS_Store

binary file changed (120 → absent bytes)

− .circleci/config.yml 
@@ -1,46 +0,0 @@-----version: 2.0--jobs:-  build:-    docker:-      - image: fpco/stack-build:lts-13.20-    steps:-      - add_ssh_keys-      - run: apt-get install z3-      - checkout-      - run: git submodule init-      #- run: find .git-      #- run: sed -i '/fixpoint.git/a fetch = +refs/pull/*/head:refs/remotes/origin/pr/*' .git/modules/liquid-fixpoint/config-      - run: git submodule update-      - restore_cache:-          keys:-            - stack-{{ checksum "stack.yaml" }}-      - run:-          name: Dependencies-          command: |-            stack setup-            # rm -fr $(stack path --dist-dir) $(stack path --local-install-root)-            stack build liquidhaskell --only-dependencies --test --no-run-tests-      - save_cache:-          key: stack-{{ checksum "stack.yaml" }}-          paths:-            - ~/.stack-            - ./.stack-work-      - run:-          name: Test-          command: |-            stack clean-            mkdir -p /tmp/junit-            stack test liquidhaskell:test --flag liquidhaskell:include --flag liquidhaskell:devel --test-arguments="-t 1200s --xml=/tmp/junit/main-test-results.xml": #--liquid-opts='--cores=1'":-            stack test liquidhaskell:liquidhaskell-parser --test-arguments="--xml=/tmp/junit/parser-test-results.xml":-            stack sdist-            # stack haddock liquidhaskell --flag liquidhaskell:-devel --no-haddock-deps --haddock-arguments="--no-print-missing-docs --odir=$CIRCLE_ARTIFACTS"-            stack haddock liquidhaskell  --no-haddock-deps --haddock-arguments="--no-print-missing-docs"-      - store_test_results:-          path: /tmp/junit-      - store_artifacts:-          path: tests/logs/cur-      - run:-          name: Dist-          command: stack sdist
− .ghci 
@@ -1,1 +0,0 @@-:set -isrc
− .gitignore 
@@ -1,51 +0,0 @@-dist-cabal-dev-.hsenv-*.o-*.hi-*.chi-*.chs.h-.virthualenv-*.a-*.cmxa-*.cm[oxai]-*.annot-*.vmap-*.di?-*.native-*.fqout-*.out-*.fq-*.bfq-*.annot-*.cgi-*.log-*.html-*.pyc-build.sh-config.make-*.scalarlog-*.tags-_build-*~-*.swp-*.swo-dist-newstyle-.cabal-sandbox/-cabal.sandbox.config-.ghc.environment.*-cabal.project.local--/tests/logs/-/.stack-work/-/.vagrant/-TAGS-tags-a.out-*.json-js/-css/--*.smt2-.liquid-.dir-locals.el
− .gitmodules 
@@ -1,6 +0,0 @@-[submodule "liquid-fixpoint"]-	path = liquid-fixpoint-	url = https://github.com/ucsd-progsys/liquid-fixpoint.git-[submodule "ghc-options"]-	path = ghc-options-	url = https://github.com/ranjitjhala/ghc-options.git
CHANGES.md view
@@ -1,6 +1,11 @@ # Changes -## NEXT 0.8.6.0+## NEXT 0.8.10.1++- Support for GHC 8.10.1+- LiquidHaskell is now available as a GHC Plugin++## 0.8.6.0  - Automatically check (transitive) dependencies - Built with GHC 8.6.4
− CONTRIBUTING.md 
@@ -1,7 +0,0 @@-Contributing---------------We are thrilled to get PRs. A few notes:--- Pull requests should be created against *develop* branch.-
− HLint.hs 
@@ -1,5 +0,0 @@-import "hint" HLint.Default-import "hint" HLint.Dollar--ignore "Eta reduce"-ignore "Use ."
− INSTALL.md 
@@ -1,73 +0,0 @@-# Install LiquidHaskell--To run `liquid` you need to install:--1. An SMT solver-2. The `liquid` binary via package manager *or* source.---## Step 1: Install SMT Solver--Download and install *at least one* of--+ [Z3](https://github.com/Z3Prover/z3/releases) or [Microsoft official binary](https://www.microsoft.com/en-us/download/details.aspx?id=52270)-+ [CVC4](http://cvc4.cs.stanford.edu/web/)-+ [MathSat](http://mathsat.fbk.eu/download.html)--Note: It should be findable from PATH. LiquidHaskell is executing it as a child process.--## Step 2: Install `liquid` via Package Manager--Simply do:--    cabal install liquidhaskell--We are working to put `liquid` on `stackage`.--You can designate a specific version of LiquidHaskell to ensure that the correct-GHC version is in the environment. As an example,--    cabal install liquidhaskell-0.6.0.0--## Step 2: Install `liquid` from Source--If you want the most recent version, you can build from source as follows,-either using `stack` (recommended) or `cabal`. In either case: *recursively*-clone the repo and then build:--### Build with `stack` (recommended)--This requires that you have installed [stack][stack] (which we strongly recommend!)--    git clone --recursive git@github.com:ucsd-progsys/liquidhaskell.git-    cd liquidhaskell-    stack install-    -If you haven't set up your ssh keys with github, use the `https` method to clone and build-    -    git clone --recursive https://github.com/ucsd-progsys/liquidhaskell.git-    cd liquidhaskell-    stack install-    --## Troubleshooting---1. If you're on Windows, please make sure the SMT solver is installed-    in the **same** directory as LiquidHaskell itself (i.e. wherever-    `cabal` or `stack` puts your binaries). That is, do:--    ```-    which liquid-    ```--    and make sure that `z3` or `cvc4` or `mathsat` are in the `PATH`-    returned by the above.--2. If you installed via `stack` and are experiencing path related woes, try:--    ```-    stack exec -- liquid path/to/file.hs-    ```--[stack]: https://github.com/commercialhaskell/stack/blob/master/doc/install_and_upgrade.md
− LICENSE_Z3 
@@ -1,7 +0,0 @@-Z3-Copyright (c) Microsoft Corporation-All rights reserved. -MIT License-Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the ""Software""), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:-The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.-THE SOFTWARE IS PROVIDED *AS IS*, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
− Makefile 
@@ -1,112 +0,0 @@-THREADS=1-SMTSOLVER=z3--FASTOPTS=-O0-DISTOPTS=-O2-PROFOPTS=-O2 --enable-library-profiling --enable-executable-profiling-LIQUIDOPTS=--CABAL=cabal-CABALI=$(CABAL) install-CABALP=$(CABAL) install --enable-library-profiling--# to deal with cabal sandboxes using dist/dist-sandbox-xxxxxx/build/test/test-# TASTY=find dist -type f -name test | head -n1-TASTY=./dist/build/test/test--DEPS=--dependencies-only--ghcid: -	stack exec -- ghcid --command="stack ghci --ghci-options=-fno-code"---##############################################################################-##############################################################################-##############################################################################--fast:-	$(CABAL) install -fdevel $(FASTOPTS)--first:-	$(CABAL) install $(FASTOPTS) --only-dependencies --enable-tests --enable-benchmarks--dist:-	# $(CABAL) install $(DISTOPTS)-	$(CABAL) configure -fdevel --enable-tests --disable-library-profiling -O2-	$(CABAL) build-	-prof:-	$(CABAL) install $(PROFOPTS)--igotgoto:-	$(CABAL) build $(OPTS)-	cp dist/build/liquid/liquid ~/.cabal/bin/--clean:-	cabal clean--docs:-	$(CABAL) hscolour-	$(CABAL) haddock --hoogle--deps:-	$(CABALI) $(DEPS)--pdeps:-	$(CABALP) $(DEPS)--all-test-py:-	cd tests && ./regrtest.py -a -t $(THREADS) && cd ../--test-py:-	cd tests && ./regrtest.py -t $(THREADS) && cd ../--test:-	$(CABAL) configure -fdevel --enable-tests --disable-library-profiling -O2-	$(CABAL) build-	$(CABAL) exec $(TASTY) -- --smtsolver $(SMTSOLVER) --hide-successes --rerun-update -p 'Unit/' -j$(THREADS) +RTS -N$(THREADS) -RTS-	# $(CABAL) exec $(TASTY) -- --smtsolver $(SMTSOLVER) --liquid-opts='$(LIQUIDOPTS)' --hide-successes --rerun-update -p 'Unit/' -j$(THREADS) +RTS -N$(THREADS) -RTS--test710:-	$(CABAL) configure -fdevel --enable-tests --disable-library-profiling -O2-	$(CABAL) build-	$(TASTY) --smtsolver $(SMTSOLVER) --hide-successes --rerun-update -p 'Unit/' -j$(THREADS) +RTS -N$(THREADS) -RTS---retest:-	cabal configure -fdevel --enable-tests --disable-library-profiling -O2-	cabal build-	cabal exec $(TASTY) -- --smtsolver $(SMTSOLVER) --hide-successes --rerun-filter "exceptions,failures,new" --rerun-update -p 'Unit/' -j$(THREADS) +RTS -N$(THREADS) -RTS--all-test:-	cabal configure -fdevel --enable-tests --disable-library-profiling -O2-	cabal build-	cabal exec $(TASTY) -- --smtsolver $(SMTSOLVER) --hide-successes --rerun-update -j$(THREADS) +RTS -N$(THREADS) -RTS--all-test-710:-	cabal configure -fdevel --enable-tests --disable-library-profiling -O2-	cabal build-	$(TASTY) --smtsolver $(SMTSOLVER) --hide-successes --rerun-update -j$(THREADS) +RTS -N$(THREADS) -RTS----all-retest:-	cabal configure -fdevel --enable-tests --disable-library-profiling -O2-	cabal build-	cabal exec $(TASTY) -- --smtsolver $(SMTSOLVER) --hide-successes --rerun-filter "exceptions,failures,new" --rerun-update -j$(THREADS) +RTS -N$(THREADS) -RTS--all-retest-710:-	cabal configure -fdevel --enable-tests --disable-library-profiling -O2-	cabal build-	$(TASTY) --smtsolver $(SMTSOLVER) --hide-successes --rerun-filter "exceptions,failures,new" --rerun-update -j$(THREADS) +RTS -N$(THREADS) -RTS----lint:-	hlint --colour --report .--tags:-	hasktags -x -c src/-	# hasktags -c src/-	# hasktags -e src/-
− NIX.md 
@@ -1,67 +0,0 @@-# Running LiquidHaskell with Nix--Via [Gabriel Gonzalez](https://github.com/Gabriel439), -see [this issue](https://github.com/ucsd-progsys/liquidhaskell/issues/1099) for details.--Nix lets you create transient GHC environments with corresponding -package databases that may be needed to run LH on specific programs.--1. Create shell, that lists the extra dependencies: --- the version of GHC (must be the same as you build LH with, e.g. GHC 8.0.2)-- any extra libraries (e.g. `vector`) ---```-$ nix-shell --packages 'haskell.packages.ghc802.ghcWithPackages (pkgs: [ pkgs.vector ])'-```--2. Set environment variables--```-[nix-shell]$ eval "$(egrep ^export "$(type -p ghc)")"-```--3. Run LH--```-[nix-shell]$ liquid examples/search.hs-```--Steps 1-3 can be encapsulated in a single `shell.nix` e.g. --```nix-let-  inherit (import <nixpkgs> { }) fetchFromGitHub;--  nixpkgs = fetchFromGitHub {-    owner = "NixOS";--    repo = "nixpkgs";--    rev = "1715436b75696d9885b345dd8159e12244d0f7f5";-    sha256 = "18qp76cppm1yxmzdaak9kcllbypvv22c9g7iaycq2wz0qkka6rx5";-  };--  pkgs = import nixpkgs { };--  liquid =-    pkgs.runCommand "liquidhaskell" { buildInputs = [ pkgs.makeWrapper ]; } ''-      mkdir -p $out/bin-      ln -s ${pkgs.haskellPackages.liquidhaskell}/bin/liquid $out/bin-      wrapProgram $out/bin/liquid --prefix PATH : ${pkgs.z3}/bin-    '';--  ghc = pkgs.haskellPackages.ghcWithPackages (ps: with ps; [-          vector-        ]);-in-  pkgs.stdenv.mkDerivation {-    name = "my-haskell-env-0";-    buildInputs = [ ghc liquid ];-    shellHook = "eval $(egrep ^export ${ghc}/bin/ghc)";-  }-```---
README.md view
@@ -5,1524 +5,23 @@ [![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) -Main Web site----------------* [Try LiquidHaskell in your browser](http://goto.ucsd.edu:8090/index.html)-* [Splash page with examples and link to blog](https://ucsd-progsys.github.io/liquidhaskell-blog/)-* [120 minute workshop with more examples](http://ucsd-progsys.github.io/lh-workshop/01-index.html)-* [Long ish Tutorial](http://ucsd-progsys.github.io/liquidhaskell-tutorial/)--Questions-------------If you have any questions--* Join the Liquid Haskell [slack channel](https://join.slack.com/t/liquidhaskell/shared_invite/enQtMjY4MTk3NDkwODE3LTY1YzBiY2JlZjBjMTM5M2ZkMjNmZDk5ZjA2MGQyZjQ5ZjBmYjZjNGMzOTUyMTU2MDlmM2YzZDM2YjhiMWFjM2I)-* Mail the [users mailing list](https://groups.google.com/forum/#!forum/liquidhaskell)-* Create a github issue--Contributing Guide---------------------Please see the [contributing guide](CONTRIBUTING.md)--Requirements---------------LiquidHaskell requires (in addition to the cabal dependencies)--- SMTLIB2 compatible solver installed and its executable found on PATH--How To Clone, Build and Install----------------------------------You may want to [try LiquidHaskell online](http://goto.ucsd.edu:8090/index.html)--See [install instructions](INSTALL.md)--How To Run-------------To verify a file called `foo.hs` at type--    $ liquid foo.hs--How to Run inside GHCi-------------------------To run inside `ghci` e.g. when developing do:--    $ stack ghci liquidhaskell-    ghci> :m +Language.Haskell.Liquid.Liquid-    ghci> liquid ["tests/pos/Abs.hs"]--See [this file](NIX.md) for instructions on running inside a custom `nix`-shell.---How To Get Editor Support----------------------------To get Liquid Haskell in your editor use the Haskell IDE Engine and activate the liquid plugin. -For example, --- [VS Code](https://code.visualstudio.com/)--    1. Install the [haskell-ide-engine](https://github.com/haskell/haskell-ide-engine)-    2. Enable Haskell Language Server extension from VS Code. -    3. In the VS Code settings search for `liquid` and enable the `Liquid On` extension.----How To Run Regression Tests------------------------------You can run all the tests by--    $ stack test--To pass in specific parameters and run a subset of the tests --    $ stack test liquidhaskell --fast  --test-arguments "--liquid-opts --no-termination -p Unit"--Or your favorite number of threads, depending on cores etc.--You can directly extend and run the tests by modifying--    tests/test.hs--How to Profile-----------------1. Build with profiling on--    ```-    $ stack build liquidhaskell --fast --profile-    ```---2. Run with profiling--    ```-    $ stack exec -- liquid range.hs +RTS -hc -p-    $ stack exec -- liquid range.hs +RTS -hy -p-    ```--    Followed by this which shows the stats file--    ```-    $ more liquid.prof-    ```--    or by this to see the graph--    ```-    $ hp2ps -e8in -c liquid.hp-    $ gv liquid.ps-    ```--    etc.--How to Get Stack Traces On Exceptions----------------------------------------1. Build with profiling on--    ```-    $ stack build liquidhaskell --fast --profile-    ```--2. Run with backtraces--    ```-    $ liquid +RTS -xc -RTS foo.hs-    ```--    ```-    stack exec -- liquid List00.hs +RTS -p -xc -RTS-    ```--Working With Submodules-------------------------- - To update the `liquid-fixpoint` submodule, run--    ```-    cd ./liquid-fixpoint-    git fetch --all-    git checkout <remote>/<branch>-    cd ..-    ```--   This will update `liquid-fixpoint` to the latest version on `<branch>`-   (usually `master`) from `<remote>` (usually `origin`).-- - After updating `liquid-fixpoint`, make sure to include this change in a-   commit! Running--    ```-    git add ./liquid-fixpoint-    ```--   will save the current commit hash of `liquid-fixpoint` in your next commit-   to the `liquidhaskell` repository.-- - For the best experience, **don't** make changes directly to the-   `./liquid-fixpoint` submodule, or else git may get confused. Do any-   `liquid-fixpoint` development inside a separate clone/copy elsewhere.-- - If something goes wrong, run--    ```-    rm -r ./liquid-fixpoint-    git submodule update --init-    ```--   to blow away your copy of the `liquid-fixpoint` submodule and revert to the-   last saved commit hash.-- - Want to work fully offline? git lets you add a local directory as a remote.-   Run--    ```-    cd ./liquid-fixpoint-    git remote add local /path/to/your/fixpoint/clone-    cd ..-    ```--   Then to update the submodule from your local clone, you can run--    ```-    cd ./liquid-fixpoint-    git fetch local-    git checkout local/<branch>-    cd ..-    ```--Command Line Options-====================--LiquidHaskell supports several command line options, to configure the-checking. Each option can be passed in at the command line, or directly-added to the source file via:--```haskell-    {-@ LIQUID "option-within-quotes" @-}-```--for example, to disable termination checking (see below)--```haskell-    {-@ LIQUID "--no-termination" @-}-```--You may also put command line options in the environment variable-`LIQUIDHASKELL_OPTS`. For example, if you add the line:--```-    LIQUIDHASKELL_OPTS="--diff"-```--to your `.bashrc` then, by default, all files will be-*incrementally checked* unless you run with the overriding-`--full` flag (see below).--Theorem Proving ------------------To enable theorem proving, e.g. as [described here](https://ucsd-progsys.github.io/liquidhaskell-blog/tags/reflection.html)-use the option --```haskell-    {-@ LIQUID "--reflection" @-}-```--To additionally turn on _proof by logical evaluation_ use the option--```haskell-    {-@ LIQUID "--ple" @-}-```--You can see many examples of proofs by logical evaluation in `benchmarks/popl18/ple/pos`--This flag is **global** and will symbolically evaluate all the terms that appear in the specifications.--As an alternative, the `liquidinstanceslocal` flag has local behavior. [See](https://github.com/ucsd-progsys/liquidhaskell/blob/develop/benchmarks/proofautomation/pos/Unification.hs)--```-{-@ LIQUID "--ple-local" @-}-```--will only evaluate terms appearing in the specifications-of the function `theorem`, in the function `theorem` is-annotated for automatic instantiation using the following-liquid annotation--```-{-@ automatic-instances theorem @-}-```--Incremental Checking-----------------------LiquidHaskell supports *incremental* checking where each run only checks-the part of the program that has been modified since the previous run.--```-    $ liquid --diff foo.hs-```--Each run of `liquid` saves the file to a `.bak` file and the *subsequent* run--    + does a `diff` to see what has changed w.r.t. the `.bak` file-    + only generates constraints for the `[CoreBind]` corresponding to the-       changed top-level binders and their transitive dependencies.--The time savings are quite significant. For example:--```-    $ time liquid --notermination -i . Data/ByteString.hs > log 2>&1--    real	7m3.179s-    user	4m18.628s-    sys	    0m21.549s-```--Now if you go and tweak the definition of `spanEnd` on line 1192 and re-run:--```-    $ time liquid -d --notermination -i . Data/ByteString.hs > log 2>&1--    real	0m11.584s-    user	0m6.008s-    sys	    0m0.696s-```--The diff is only performed against **code**, i.e. if you only change-specifications, qualifiers, measures, etc. `liquid -d` will not perform-any checks. In this case, you may specify individual definitions to verify:--```-    $ liquid -b bar -b baz foo.hs-```--This will verify `bar` and `baz`, as well as any functions they use.--If you always want to run a given file with diff-checking, add-the pragma:--    {-@ LIQUID "--diff" @-}---Full Checking (DEFAULT)--------------------------To force LiquidHaskell to check the **whole** file (DEFAULT), use:--    $ liquid --full foo.hs--to the file. This will override any other `--diff` incantation-elsewhere (e.g. inside the file.)---If you always want to run a given file with full-checking, add-the pragma:--    {-@ LIQUID "--full" @-}--Specifying Different SMT Solvers-----------------------------------By default, LiquidHaskell uses the SMTLIB2 interface for Z3.--To run a different solver (supporting SMTLIB2) do:--    $ liquid --smtsolver=NAME foo.hs--Currently, LiquidHaskell supports--+ [CVC4](http://cvc4.cs.stanford.edu/web/)-+ [MathSat](http://mathsat.fbk.eu/download.html )--To use these solvers, you must install the corresponding binaries-from the above web-pages into your `PATH`.--You can also build and link against the Z3 API (faster but requires more-dependencies). If you do so, you can use that interface with:--    $ liquid --smtsolver=z3mem foo.hs---Short Error Messages-----------------------By default, subtyping error messages will contain the inferred type, the-expected type -- which is **not** a super-type, hence the error -- and a-context containing relevant variables and their type to help you understand-the error. If you don't want the above and instead, want only the-**source position** of the error use:--    --short-errors--Short (Unqualified) Module Names----------------------------------By default, the inferred types will have fully qualified module names.-To use unqualified names, much easier to read, use:--    --short-names--Disabling Checks on Functions--------------------------------You can _disable_ checking of a particular function (e.g. because it is unsafe,-or somehow not currently outside the scope of LH) by using the `ignore` directive.--For example,--```haskell-{-@ ignore foo @-}-```--will _disable_ the checking of the code for the top-level binder `foo`.--See `tests/pos/Ignores.hs` for an example.---Totality Check-----------------LiquidHaskell proves the absence of pattern match failures.--For example, the definition--    fromJust :: Maybe a -> a-    fromJust (Just a) = a--is not total and it will create an error message.-If we exclude `Nothing` from its domain, for example using the following specification--    {-@ fromJust :: {v:Maybe a | (isJust v)} -> a @-}--`fromJust` will be safe.--Use the `no-totality` flag to disable totality checking.--    liquid --no-totality test.hs--Termination Check--------------------By **default** a termination check is performed on all recursive functions.--Use the `--no-termination` option to disable the check--    liquid --no-termination test.hs--In recursive functions the *first* algebraic or integer argument should be decreasing.--The default decreasing measure for lists is length and Integers its value.--### Default Termination Metrics--The user can specify the *size* of a data-type in the data definition--```haskell-    {-@ data L [llen] a = Nil | Cons { x::a, xs:: L a} @-}-```--In the above, the measure `llen`, which needs to be defined by the user-(see below), is defined as the *default metric* for the type `L a`. LH-will use this default metric to _automatically_ prove that the following-terminates:--```haskell-    append :: L a -> L a -> L a  -    append N           ys = ys-    append (Cons x xs) ys = Cons x (append xs ys)-```--as, by default the *first* (non-function) argument with an-associated size metric is checked to be strictly terminating-and non-negative at each recursive call.--A default termination metric is a Haskell function that is proved terminating -using structural induction. To deactivate structional induction check on the -termination metric, use the `--trust-sizes` flag. --### Explicit Termination Metrics--However, consider the function `reverse`--```haskell-    reverseAcc :: L a -> L a -> L a  -    reverseAcc acc N           = acc-    reverseAcc acc (Cons x xs) = reverseAcc (Cons x acc) xs-```--Here, the first argument does not decrease, instead-the second does. We can tell LH to use the second-argument using the *explicit termination metric*--```haskell-    reverseAcc :: L a -> xs:L a -> L a / [llen xs]  -```  --which tells LH that the `llen` of the second argument `xs`-is what decreases at each recursive call.--Decreasing expressions can be arbitrary refinement expressions, e.g.,--```haskell-    {-@ merge :: Ord a => xs:L a -> ys:L a -> L a / [llen xs + llen ys] @-}-```--states that at each recursive call of `merge` the _sum of the lengths_-of its arguments will decrease.--### Lexicographic Termination Metrics--Some functions do not decrease on a single argument, but rather a-combination of arguments, e.g. the Ackermann function.--```haskell-    {-@ ack :: m:Int -> n:Int -> Nat / [m, n] @-}-    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))-```--In all but one recursive call `m` decreases, in the final call `m`-does not decrease but `n` does. We can capture this notion of `m`-normally decreases, but if it does not, `n` will decrease with a-*lexicographic* termination metric `[m, n]`.---An alternative way to express this specification is by annotating-the function's type with the appropriate *numeric* decreasing expressions.-As an example, you can give `ack` a type--    {-@ ack :: m:Nat -> n:Nat -> Nat / [m,n] @-}--stating that the *numeric* expressions `[m, n]` are lexicographically decreasing.--### Mutually Recursive Functions--When dealing with mutually recursive functions you may run into a-situation where the decreasing parameter must be measured *across* a-series of invocations, e.g.--```haskell-    even :: Int -> Bool-    even 0 = True-    even n = odd (n-1)--    odd :: Int -> Bool-    odd  n = not (even n)-```--In this case, you can introduce a ghost parameter that *orders the functions*--```haskell-    {-@ isEven :: n:Nat -> z:{v:Int | v = 0} -> Bool / [n, z] @-}-    isEven :: Int -> Int -> Bool-    isEven 0 _ = True-    isEven n _ = isOdd (n-1) 1--    {-@ isOdd :: n:Nat -> z:{v:Int | v = 1} -> Bool / [n, z] @-}-    isOdd :: Int -> Int -> Bool-    isOdd  n _ = not (isEven n 0)-```--thus recovering a decreasing measure for the pair of functions, the-pair of arguments. This can be encoded with the lexicographic-termination annotation as shown above.-See [tests/pos/mutrec.hs](tests/pos/mutrec.hs) for the full example.--### Automatic Termination Metrics--Apart from specifying a specific decreasing measure for-an Algebraic Data Type, the user can specify that the ADT-follows the expected decreasing measure by--```haskell-    {-@ autosize L @-}-```--Then, LH will define an instance of the function `autosize`-for `L` that decreases by 1 at each recursive call and use-`autosize` at functions that recurse on `L`.--For example, `autosize L` will refine the data constructors-of `L a` with the `autosize :: a -> Int` information, such-that--```haskell-    Nil  :: {v:L a | autosize v = 0}-    Cons :: x:a -> xs:L a -> {v:L a | autosize v = 1 + autosize xs}-```--Also, an invariant that `autosize` is non negative will be generated--```haskell-    invariant  {v:L a| autosize v >= 0 }-```--This information is all LiquidHaskell needs to prove termination-on functions that recurse on `L a` (on ADTs in general.)---### Disabling Termination Checking--To *disable* termination checking for `foo` that is,-to *assume* that it is terminating (possibly for some-complicated reason currently beyond the scope of LH)-you can write--```haskell-    {-@ lazy foo @-}-```--Total Haskell-----------------LiquidHaskell provides a total Haskell flag that checks both totallity and termination of the program,-overriding a potential no-termination flag.--    liquid --total-Haskell test.hs---Lazy Variables-----------------A variable can be specified as `LAZYVAR`--    {-@ LAZYVAR z @-}--With this annotation the definition of `z` will be checked at the points where-it is used. For example, with the above annotation the following code is SAFE:--    foo   = if x > 0 then z else x-      where-        z = 42 `safeDiv` x-        x = choose 0--By default, all the variables starting with `fail` are marked as LAZY, to defer-failing checks at the point where these variables are used.--No measure fields---------------------When a data type is refined, Liquid Haskell automatically turns the data constructor fields into measures.-For example,--    {-@ data L a = N | C {hd :: a, tl :: L a} @-}--will automatically create two measures `hd` and `td`.-To deactivate this automatic measure definition, and speed up verification, you can use the `no-measure-fields` flag.--    liquid --no-measure-fields test.hs----Prune Unsorted Predicates-----------------------------The `--prune-unsorted` flag is needed when using *measures over specialized instances* of ADTs. --For example, consider a measure over lists of integers--```haskell-    sum :: [Int] -> Int-    sum [] = 0-    sum (x:xs) = 1 + sum xs-```--This measure will translate into strengthening the types of list constructors--```-    [] :: {v:[Int] | sum v = 0 }-    (:) :: x:Int -> xs:[Int] -> {v:[Int] | sum v = x + sum xs}-```--But what if our list is polymorphic `[a]` and later instantiate to list of ints?-The workaround we have right now is to strengthen the polymorphic list with the -`sum` information--```-    [] :: {v:[a] | sum v = 0 }-    (:) :: x:a -> xs:[a] -> {v:[a] | sum v = x + sum xs}-```--But for non numeric `a`s, refinements like `x + sum xs` are ill-sorted! --We use the flag `--prune-unsorted` to prune away unsorted expressions -(like `x + sum xs`) inside refinements.---```-    liquid --prune-unsorted test.hs-```---Case Expansion----------------------------By default LiquidHaskell expands all data constructors to the case statements.-For example,-if `F = A1 | A2 | .. | A10`,-then LiquidHaskell will expand the code-`case f of {A1 -> True; _ -> False}`-to `case f of {A1 -> True; A2 -> False; ...; A10 -> False}`.-This expansion can lead to more precise code analysis-but it can get really expensive due to code explosion.-The `no-case-expand` flag prevents this expansion and keeps the user-provided cases for the case expression.--    liquid --no-case-expand test.hs---Higher order logic---------------------The flag `--higherorder` allows reasoning about higher order functions.---Restriction to Linear Arithmetic-----------------------------------When using `z3` as the solver, LiquidHaskell allows for non-linear arithmetic:-division and multiplication on integers are interpreted by `z3`. To treat division-and multiplication as uninterpreted functions use the `linear` flag--    liquid --linear test.hs--Counter examples (Experimental!)----------------------------------When given the `--counter-examples` flag, LiquidHaskell will attempt to produce-counter-examples for the type errors it discovers. For example, see-[tests/neg/ListElem.hs](https://github.com/ucsd-progsys/liquidhaskell/blob/master/tests/neg/ListElem.hs)--```-% liquid --counter-examples tests/neg/ListElem.hs--...--tests/neg/ListElem.hs:12:1-8: Error: Liquid Type Mismatch-- 12 | listElem _ []      = False-      ^^^^^^^^--   Inferred type-     VV : {VV : Bool | VV == True}-     VV = True--   not a subtype of Required type-     VV : {VV : Bool | Prop VV <=> Set_mem ?b (listElts ?a)}--   In Context-     ?a : {?a : [a] | len ?a >= 0}-     ?a = [1]--     ?b : a-     ?b = 0-```--The `--counter-examples` flag requires that each type in the context be-an instance of `GHC.Generics.Generic` or `Test.Targetable.Targetable`-(provided as part of LiquidHaskell).  LiquidHaskell cannot generate-counter-examples for polymorphic types, but will try (naively) to-instantiate type variables with `Int` (as seen in the example above).--Writing Specifications-======================--Modules WITHOUT code-----------------------When checking a file `target.hs`, you can specify an _include_ directory by--    liquid -i /path/to/include/  target.hs--Now, to write specifications for some **external module** `Foo.Bar.Baz` for which-you **do not have the code**, you can create a `.spec` file at:--    /path/to/include/Foo/Bar/Baz.spec--See, for example, the contents of--+ [include/Prelude.spec](https://github.com/ucsd-progsys/liquidhaskell/blob/master/include/Prelude.spec)-+ [include/Data/List.spec](https://github.com/ucsd-progsys/liquidhaskell/blob/master/include/Data/List.spec)-+ [include/Data/Vector.spec](https://github.com/ucsd-progsys/liquidhaskell/blob/master/include/Data/Vector.spec)--**Note**:--+ The above directories are part of the LH prelude, and included by-  default when running `liquid`.-+ The `.spec` mechanism is *only for external modules** without code,-  see below for standalone specifications for **internal** or **home** modules.---Modules WITH code: Data--------------------------Write the specification directly into the .hs or .lhs file,-above the data definition. See, for example, [tests/pos/Map.hs](tests/pos/Map.hs)--    {-@-    data Map k a <l :: k -> k -> Prop, r :: k -> k -> Prop>-      = Tip-      | Bin (sz    :: Size)-            (key   :: k)-            (value :: a)-            (left  :: Map <l, r> (k <l key>) a)-            (right :: Map <l, r> (k <r key>) a)-    @-}-    data Map k a = Tip-                 | Bin Size k a (Map k a) (Map k a)--You can also write invariants for data type definitions-together with the types. For example, see [tests/pos/record0.hs](tests/pos/record0.hs)--    {-@ data LL a = BXYZ { size  :: {v: Int | v > 0 }-                         , elems :: {v: [a] | (len v) = size }-                         }-    @-}--Finally you can specify the variance of type variables for data types.-For example, see [tests/pos/Variance.hs](tests/pos/Variance.hs), where data type `Foo` has four-type variables `a`, `b`, `c`, `d`, specified as invariant, bivariant,-covariant and contravariant, respectively.--    data Foo a b c d-    {-@ data variance Foo invariant bivariant covariant contravariant @-}---Modules WITH code: Functions-------------------------------Write the specification directly into the .hs or .lhs file,-above the function definition. [For example](tests/pos/spec0.hs)--    {-@ incr :: x:{v: Int | v > 0} -> {v: Int | v > x} @-}-    incr   :: Int -> Int-    incr x = x + 1--Modules WITH code: Type Classes----------------------------------Write the specification directly into the .hs or .lhs file,-above the type class definition. [For example](tests/pos/Class.hs)--    {-@ class Sized s where-          size :: forall a. x:s a -> {v:Int | v = (size x)}-    @-}-    class Sized s where-      size :: s a -> Int--Any measures used in the refined class definition will need to be-*generic* (see [Specifying Measures](#specifying-measures)).---As an alternative, you can refine class instances.-[For example](tests/classes/pos/Inst00.hs)--~~~~-instance Compare Int where--{-@ instance Compare Int where-    cmax :: Odd -> Odd -> Odd-  @-}--cmax y x = if x >= y then x else y-~~~~--When `cmax` method is used on `Int`, liquidHaskell will give it-the refined type `Odd -> Odd -> Odd`.--Note that currently liquidHaskell does not allow refining instances of-refined classes.--Modules WITH code: QuasiQuotation------------------------------------Instead of writing both a Haskell type signature *and* a-LiquidHaskell specification for a function, the `lq`-quasiquoter in the `LiquidHaskell` module can be used-to generate both from just the LiquidHaskell specification.--```haskell-module Nats (nats) where--{-@ nats :: [{v:Int | 0 <= v}] @-}-nats :: [Int]-nats = [1,2,3]-```--can be written as--```haskell-{-# LANGUAGE QuasiQuotes #-}-module Nats (nats) where--import LiquidHaskell--[lq| nats :: [{v:Int | 0 <= v}] |]-nats = [1,2,3]-```--and the `lq` quasiquoter will generate the plain `nats :: [Int]` when GHC-compiles the module.--Refined type aliases (see the next section) can also be written inside `lq`; for-example:--```haskell-{-# LANGUAGE QuasiQuoters #-}-module Nats (Nat, nats) where--[lq| type Nat = {v:Int | 0 <= v} |]--[lq| nats :: [Nat] |]-nats = [1,2,3]-```--Here, the `lq` quasiquoter will generate a plain Haskell-type synonym for `Nat` as well as the refined one.--Note that this is still an experimental feature, and-currently requires that one depend on LiquidHaskell-as a build dependency for your project; the quasiquoter-will be split out eventually into an independent,-dependency-light package. Also, at this time, writing-a type inside `lq` which refers to a refined type alias-for which there is not a plain Haskell type synonym of the-same name will result in a "not in scope" error from GHC.--Standalone Specifications for Internal Modules-------------------------------------------------Recall that the `.spec` mechanism is only for modules whose-code is absent; if code is present then there can be multiple,-possibly conflicting specifications. Nevertheless, you may want,-for one reason or another, to write (assumed) specifications-outside the file implementing the module.--You can do this as follows.--`Lib.hs`--```haskell-module Lib (foo) where--foo a = a-```--now, instead of a `.spec` file, just use a haskell module, e.g. `LibSpec.hs`--```haskell-module LibSpec ( module Lib ) where--import Lib---- Don't forget to qualify the name!--{-@ Lib.foo :: {v:a | false} -> a @-}-```--and then here's `Client.hs`--```haskell-module Client where--import Lib      -- use this if you DON'T want the spec-import LibSpec  -- use this if you DO want the spec, in addition to OR instead of the previous import.--bar = foo 1     -- if you `import LibSpec` then this call is rejected by LH-```--Inductive Predicates-----------------------**Very Experimental**--LH recently added support for *Inductive Predicates*-in the style of Isabelle, Coq etc. These are encoded-simply as plain Haskell GADTs but suitably refined.--Apologies for the minimal documentation; see the-following examples for details:--* [Even and Odd](https://github.com/ucsd-progsys/liquidhaskell/blob/develop/tests/ple/pos/IndEven.hs)-* [Permutations](https://github.com/ucsd-progsys/liquidhaskell/blob/develop/tests/ple/pos/IndPerm.hs)-* [Transitive Closure](https://github.com/ucsd-progsys/liquidhaskell/blob/develop/tests/ple/pos/IndStar.hs)-* [RegExp Derivatives](https://github.com/ucsd-progsys/liquidhaskell/blob/develop/tests/ple/pos/RegexpDerivative.hs)-* [Type Safety of STLC](https://github.com/ucsd-progsys/liquidhaskell/blob/develop/tests/ple/pos/STLC2.hs)--Implicit Arguments---------------------**Experimental**--There is experimental support for implicit arguments, solved for with congruence closure. For example, consider [Implicit1.hs](https://github.com/ucsd-progsys/liquidhaskell/blob/develop/tests/pos/Implicit1.hs):--```haskell-{-@ type IntN N = {v:Int | v = N} @-}--{-@ foo :: n:Int ~> (() -> IntN n) -> IntN {n+1} @-}-foo f = 1 + f ()--{-@ test1 :: IntN 11 @-}-test1 = foo (\_ -> 10)-```--Here, the refinement on `(\_ -> 10) :: Int -> { v:Int | v = 10 }` allows us to solve for `n = 10`, the implicit argument to `foo`.---Refinement Type Aliases--------------------------#### Predicate Aliases--Often, the propositions in the refinements can get rather long and-verbose. You can write predicate aliases like so:--    {-@ predicate Lt X Y = X < Y        @-}-    {-@ predicate Ge X Y = not (Lt X Y) @-}--and then use the aliases inside refinements, [for example](tests/pos/pred.hs)--    {-@ incr :: x:{v:Int | (Pos v)} -> { v:Int | ((Pos v) && (Ge v x))} @-}-    incr :: Int -> Int-    incr x = x + 1--See [Data.Map](benchmarks/esop2013-submission/Base.hs) for a more substantial-and compelling example.--**Syntax:** The key requirements for type aliases are:--- Value parameters are specified in **upper**case: `X`, `Y`, `Z` etc.---#### Class Laws--Class laws can be defined and checked using the `class laws` -and `instance laws` keywords. For an example, see: --* [class-laws/pos/SemiGroup.hs](https://github.com/ucsd-progsys/liquidhaskell/blob/06d22aa070933d9ea833e30d84ed91de2a28eaee/tests/class-laws/pos/SemiGroup.hs)-* [class-laws/pos/SemiGroup.hs](tests/class-laws/pos/SemiGroup.hs)--#### Type Aliases---Similarly, it is often quite tedious to keep writing--    {v: Int | v > 0}--Thus, LiquidHaskell supports refinement-type aliases of the form:--    {-@ type Gt      N = {v: Int | N <  v} @-}-    {-@ type GeNum a N = {v: a   | N <= v} @-}--or--    {-@ type SortedList a = [a]<{\fld v -> (v >= fld)}> @-}--or--    {-@ type OMap k a = Map <{\root v -> v < root}, {\root v -> v > root}> k a @-}--or--    {-@ type MinSPair a = (a, OSplay a) <\fld -> {v : Splay {v:a|v>fld} | 0=0}> @-}--and then use the above in signatures like:--    {-@ incr: x: Int -> GeNum Int x @-}--or--    {-@ incr: x: Int -> Gt x @-}--and:--    {-@ assert insert :: (Ord a) => a -> SortedList a -> SortedList a @-}--see [tests/pos/ListSort.hs](tests/pos/ListSort.hs)--and:--    {-@ assert insert :: (Ord k) => k -> a -> OMap k a -> OMap k a @-}--see [tests/pos/Map.hs](tests/pos/Map.hs)--**Syntax:** The key requirements for type aliases are:--1. Type parameters are specified in **lower**case: `a`, `b`, `c` etc.-2. Value parameters are specified in **upper**case: `X`, `Y`, `Z` etc.---Infix Logic Operators------------------------You can define infix operators in logic, following [Haskell's infix notation](https://www.haskell.org/onlinereport/decls.html#fixity).-For example, if `(+++)` is defined as a measure or reflected function, you can use it infix by declaring--    {-@ infixl 9 +++ @-}---Note: infix operators cannot contain the dot character `.`.---Specifying Measures----------------------Can be placed in .spec file or in .hs/.lhs file wrapped around `{-@ @-}`--Value measures: [include/GHC/Base.spec](include/GHC/Base.spec)--    measure len :: forall a. [a] -> GHC.Types.Int-    len ([])     = 0-    len (y:ys)   = 1 + len(ys)--Propositional measures: [tests/pos/LambdaEval.hs](tests/pos/LambdaEval.hs)--    {-@-    measure 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))))-    @-}--Raw measures: [tests/pos/meas8.hs](tests/pos/meas8.hs)--    {-@ measure rlen :: [a] -> Int-    rlen ([])   = {v | v = 0}-    rlen (y:ys) = {v | v = (1 + rlen(ys))}-    @-}--Generic measures: [tests/pos/Class.hs](tests/pos/Class.hs)--    {-@ class measure size :: a -> Int @-}-    {-@ instance measure size :: [a] -> Int-        size ([])   = 0-        size (x:xs) = 1 + (size xs)-    @-}-    {-@ instance measure size :: Tree a -> Int-        size (Leaf)       = 0-        size (Node x l r) = 1 + (size l) + (size r)-    @-}--**Note:** Measure names **do not** have to be the same as-field name, e.g. we could call the measure `sz` in the above-as shown in [tests/pos/Class2.hs](tests/pos/Class2.hs).---Haskell Functions as Measures (beta): [tests/pos/HaskellMeasure.hs](tests/pos/HaskellMeasure.hs)--Inductive Haskell Functions from Data Types to some type can be lifted to logic--```haskell-    {-@ measure llen @-}-    llen        :: [a] -> Int-    llen []     = 0-    llen (x:xs) = 1 + llen xs-```--The above definition-  - refines list's data constructors types with the llen information, and-  - specifies a singleton type for the haskell function-        `llen :: xs:[a] -> {v:Int | v == llen xs}`-    If the user specifies another type for llen, say-        `llen :: xs:[a] -> {v:Int | llen xs >= 0}`-    then the auto generated singleton type is overwritten.--Inlines ----------The `inline`  lets you use a Haskell function in a type specification. --```-{-@ inline max @-}-{-@ max :: Int -> Int -> Int @-}-max :: Int -> Int -> Int-max x y = if x > y then x else y-```--For example, if you write the above you can then write a function:--```haskell -{-@ floor :: x:Int -> {v:Int | max 0 x} @-}-floor :: Int -> Int-floor x -  | x <= 0    = 0-  | otherwise = x-``` --That is, you can use the haskell `max` in the refinement type and -it will automatically get “expanded” out to the full definition. -This makes it useful e.g. to reuse plain Haskell code to compose -specifications, and to share definitions common to refinements and code.--However, as they are *expanded* at compile time, `inline` functions -**cannot be recursive**. The can call _other_ (non-recursive) inline functions.--If you want to talk about arbitrary (recursive) functions inside your types, -then you need to use `reflect` described [in the blog] (https://ucsd-progsys.github.io/liquidhaskell-blog/tags/reflection.html)--Self-Invariants-===============--Sometimes, we require specifications that allow *inner* components of a-type to refer to the *outer* components, typically, to measure-based-properties of outer components. For example, the following invariant-about `Maybe` values--    {-@ type IMaybe a = {v0 : Maybe {v : a | ((isJust v0) && v = (fromJust v0))} | 0 = 0 } @-}--states that the *inner* `a` enjoys the property that the *outer* container-is definitely a `Just` and furthermore, the inner value is exactly the same-as the `fromJust` property of the outer container.--As another example, suppose we have a [measure](include/Data/Set.spec):--    measure listElts :: [a] -> (Set a)-    listElts([])   = {v | (? Set_emp(v))}-    listElts(x:xs) = {v | v = Set_cup(Set_sng(x), listElts(xs)) }--Now, all lists enjoy the property--    {-@ type IList a = {v0 : List  {v : a | (Set_mem v (listElts v0)) } | true } @-}--which simply states that each *inner* element is indeed, a member of the-set of the elements belonging to the entire list.--One often needs these *circular* or *self* invariants to connect different-levels (or rather, to *reify* the connections between the two levels.) See-[this test](tests/pos/maybe4.hs) for a simple example and `hedgeUnion` and-[Data.Map.Base](benchmarks/esop2013-submission/Base.hs) for a complex one.----Abstract and Bounded Refinements-================================--This is probably the best example of the abstract refinement syntax:--+ [Abstract Refinements](tests/pos/Map.hs)-+ [Bounded Refinements](benchmarks/icfp15/pos/Overview.lhs)--Unfortunately, the best documentation for these two advanced features-is the relevant papers at--+ [ESOP 2013](https://ranjitjhala.github.io/static/abstract_refinement_types.pdf)-+ [ICFP 2015](https://arxiv.org/abs/1507.00385)--The bounds correspond to Horn implications between abstract refinements,-which, as in the classical setting, correspond to subtyping constraints-that must be satisfied by the concrete refinements used at any call-site.--Dependent Pairs-===============-Dependent Pairs are expressed by binding the initial tuples of the pair. For example-`incrPair` defines an increasing pair.--    {-@ incrPair :: Int -> (x::Int, {v:Int | x <= v}) @-}-    incrPair i = (i, i+1)--Internally dependent pairs are implemented using abstract refinement types.-That is `(x::a, {v:b | p x})` desugars to `(a,b)<\x -> {v:b | p x}>`.--Invariants-==========--LH lets you locally associate invariants with specific data types.--For example, in [tests/measure/pos/Using00.hs](tests/measure/pos/Using00.hs) every-list is treated as a Stream. To establish this local invariant one can use the-`using` declaration--    {-@ using ([a]) as  {v:[a] | (len v > 0)} @-}--denoting that each list is not empty.--Then, LiquidHaskell will prove that this invariant holds, by proving that *all-calls* to List's constructors (ie., `:` and `[]`) satisfy it, and-will assume that each list element that is created satisfies-this invariant.--With this, at the [above](tests/measure/neg/Using00.hs) test LiquidHaskell-proves that taking the `head` of a list is safe.-But, at [tests/measure/neg/Using00.hs](tests/measure/neg/Using00.hs) the usage of-`[]` falsifies this local invariant resulting in an "Invariant Check" error.---**WARNING:** There is an older _global_ invariant mechanism that-attaches a refinement to a datatype globally.-Do not use this mechanism -- it is *unsound* and about to-deprecated in favor of something that is [actually sound](https://github.com/ucsd-progsys/liquidhaskell/issues/126)--Forexample,  the length of a list cannot be negative--    {-@ invariant {v:[a] | (len v >= 0)} @-}--LiquidHaskell can prove that this invariant holds, by proving that all List's-constructors (ie., `:` and `[]`) satisfy it.(TODO!) Then, LiquidHaskell-assumes that each list element that is created satisfies-this invariant.--Formal Grammar of Refinement Predicates-=======================================--(C)onstants--------------    c := 0, 1, 2, ...--(V)ariables--------------    v := x, y, z, ...---(E)xpressions----------------    e := v                      -- variable-       | c                      -- constant-       | (e + e)                -- addition-       | (e - e)                -- subtraction-       | (c * e)                -- multiplication by constant-       | (v e1 e2 ... en)       -- uninterpreted function application-       | (if p then e else e)   -- if-then-else--(R)elations--------------    r := ==               -- equality-       | /=               -- disequality-       | >=               -- greater than or equal-       | <=               -- less than or equal-       | >                -- greater than-       | <                -- less than---(P)redicates---------------    p := (e r e)          -- binary relation-       | (v e1 e2 ... en) -- predicate (or alias) application-       | (p && p)         -- and-       | (p || p)         -- or-       | (p => p)         -- implies-       | (not p)          -- negation-       | true-       | false---Specifying Qualifiers-=====================--There are several ways to specify qualifiers.--By Separate `.hquals` Files------------------------------You can write qualifier files e.g. [Prelude.hquals](include/Prelude.hquals)--If a module is called or imports--    Foo.Bar.Baz--Then the system automatically searches for--    include/Foo/Bar/Baz.hquals--By Including `.hquals` Files-------------------------------Additional qualifiers may be used by adding lines of the form:--    {-@ include <path/to/file.hquals> @-}--to the Haskell source. See, [this](tests/pos/meas5.hs) for example.---In Haskell Source or Spec Files----------------------------------Finally, you can specifiers directly inside source (.hs or .lhs) or spec (.spec)-files by writing as shown [here](tests/pos/qualTest.hs)--    {-@ qualif Foo(v:Int, a: Int) : (v = a + 100)   @-}---**Note** In addition to these, LiquidHaskell scrapes qualifiers from all-the specifications you write i.e.--1. all imported type signatures,-2. measure bodies and,-3. data constructor definitions.---Generating HTML Output-======================--The system produces HTML files with colorized source, and mouseover-inferred type annotations, which are quite handy for debugging failed-verification attempts.--- **Regular Haskell** When you run: `liquid foo.hs` you get a file-  `foo.hs.html` with the annotations. The coloring is done using-  `hscolour`.--- **Markdown + Literate Haskell** You can also feed in literate haskell files-  where the comments are in [Pandoc markdown](http://johnmacfarlane.net/pandoc/demo/example9/pandocs-markdown.html).-  In this case, the tool will run `pandoc` to generate the HTML from the comments.-  Of course, this requires that you have `pandoc` installed as a binary on-  your system. If not, `hscolour` is used to render the HTML.--  It is also possible to generate *slide shows* from the above.-  See the [slides directory](docs/slides) for an example.--Editor Integration-==================--+ [Emacs/Flycheck](https://github.com/ucsd-progsys/liquid-types.el)-+ [Vim/Syntastic](https://github.com/ucsd-progsys/liquid-types.vim)--Command Line Options-====================--To see all options, run `liquid --help`. Here are some common options:--- `--cabaldir` will automatically find a .cabal file in the ancestor-  path from which the target file belongs, and then add the relevant-  source and dependencies to the paths searched for by LiquidHaskell.--  This means we don't have to manually do `-i src` etc. when checking-  large projects, which can be tedious e.g. within emacs.--- `--diff` performs differential checking, i.e. only checks those binders-  that have transitively affected by edits since the previous check.-  Can speed things up greatly during editing.--- `--short-names` prints out non-qualified names i.e. `Int` instead of-  `GHC.Types.Int` for inferred type annotations and error messages.--**Pragmas** are useful for embedding options directly within the source file,-that is, somewhere in the file (perhaps at the top) put in:--    {-@ LIQUID "--diff"        @-}-    {-@ LIQUID "--short-names" @-}-    {-@ LIQUID "--cabaldir"    @-}--to have the relevant option be used for that file.--Generating Performance Reports---------------------------------We have set up infrastructure to generate performance reports using [Gipeda](https://github.com/nomeata/gipeda).--Gipeda will generate a static webpage that tracks the performance improvements-and regressions between commits. To generate the site, first ensure you have the-following dependencies available:--* Git-* Cabal >= 1.18-* GHC-* Make-* Bash (installed at `/bin/bash`)--After ensuring all dependencies are available, from the Liquid Haskell-directory, execute:--    cd scripts/performance-    ./deploy-gipeda.bash--This will download and install all the relevant repositories and files. Next, to-generate the performance report, use the `generate-site.bash` script. This script-has a few options:--* `-s [hash]`: Do not attempt to generate performance reports for any commit-older than the commit specified by the entered git hash-* `-e [hash]`: Do not attempt to generate performance reports for any commit-newer than the commit specified by the entered git hash-* `-f`: The default behavior of `generate-site.bash` is to first check if logs-have been created for a given hash. If logs already exist, `generate-site.bash`-will not recreate them. Specify this option to skip this check and regenerate-all logs.--You should expect this process to take a very long time. `generate-site.bash`-will compile each commit, then run the entire test suite and benchmark suite-for each commit. It is suggested to provide a manageable range to `generate-site.bash`:--    ./generate-site.bash -s [starting hash] -e [ending hash]--...will generate reports for all commits between (inclusive) [starting hash]-and [ending hash].--    ./generate-site.bash -s [starting hash]--... will generate reports for all commits newer than [starting hash]. This command-can be the basis for some automated report generation process (i.e. a cron job).--Finally, to remove the Gipeda infrastructure from your computer, you may execute:--    ./cleanup-gipeda.bash--...which will remove any files created by `deploy-gipeda.bash` and `generate-site.bash`-from your computer.---Configuration Management---------------------------It is very important that the version of Liquid Haskell be maintained properly.--Suppose that the current version of Liquid Haskell is `A.B.C.D`:--+ After a release to hackage is made, if any of the components `B`, `C`, or `D` are missing, they shall be added and set to `0`. Then the `D` component of Liquid Haskell shall be incremented by `1`. The version of Liquid Haskell is now `A.B.C.(D + 1)`--+ The first time a new function or type is exported from Liquid Haskell, if any of the components `B`, or `C` are missing, they shall be added and set to `0`. Then the `C` component shall be incremented by `1`, and the `D` component shall stripped. The version of Liquid Haskell is now `A.B.(C + 1)`--+ The first time the signature of an exported function or type is changed, or an exported function or type is removed (this includes functions or types that Liquid Haskell re-exports from its own dependencies), if the `B` component is missing, it shall be added and set to `0`. Then the `B` component shall be incremented by `1`, and the `C` and `D` components shall be stripped. The version of Liquid Haskell is now `A.(B + 1)`--+ The `A` component shall be updated at the sole discretion of the project owners.--Updating GHC-============--Here's a script to generate the diff for the `desugar` modules.--```-export GHCSRC=$HOME/Documents/ghc--# Checkout GHC-8.2.2-(cd $GHCSRC && git checkout ghc-8.2.2 && git pull)--# make a patch-diff -ur $GHCSRC/compiler/deSugar src/Language/Haskell/Liquid/Desugar > liquid.patch--# Checkout GHC-8.4.3-(cd $GHCSRC && git checkout ghc-8.2.2 && git pull)--# Copy GHC desugarer to temporary directory-cp -r $GHCSRC/compiler/deSugar .--# Patch-(cd deSugar && patch -p5 --merge --ignore-whitespace < ../liquid.patch)--# Copy stuff over-for i in src/Language/Haskell/Liquid/Desugar/*.*; do j=$(basename $i); echo $j; cp deSugar/$j src/Language/Haskell/Liquid/Desugar; done-```---Here's the magic diff that we did at some point that we keep bumping up to new GHC versions:--https://github.com/ucsd-progsys/liquidhaskell/commit/d380018850297b8f1878c33d0e4c586a1fddc2b8#diff-3644b76a8e6b3405f5492d8194da3874R224 -+## Quick Links++* [Try LiquidHaskell in your browser](http://goto.ucsd.edu:8090/index.html)+* [Splash page with examples and link to blog](https://ucsd-progsys.github.io/liquidhaskell-blog/)+* [120 minute workshop with more examples](http://ucsd-progsys.github.io/lh-workshop/01-index.html)+* [Long ish Tutorial](http://ucsd-progsys.github.io/liquidhaskell-tutorial/)++## Documentation++* [LH Documentation](http://ucsd-progsys.github.io/liquidhaskell/) +* [Edit here](/docs/mkDocs)++## Questions++If you have any questions++* Join the Liquid Haskell [slack channel](https://join.slack.com/t/liquidhaskell/shared_invite/enQtMjY4MTk3NDkwODE3LTFmZGFkNGEzYWRkNDJmZDQ0ZGU1MzBiZWZiZDhhNmY3YTJiMjUzYTRlNjMyZDk1NDU3ZGIxYzhlOTIzN2UxNWE)+* Mail the [users mailing list](https://groups.google.com/forum/#!forum/liquidhaskell)+* Create a github issue
− Syntax.md 
@@ -1,297 +0,0 @@-## New Syntax for Abstract Refinements--### Ghost Parameters---```haskell-A n -> B (n + 1)---- becomes-{ p n => q (n + 1)}. A<p> -> B<q>---- i.e.-{ p n => v = n + 1 => q v}. A<p> -> B<q>-```--which means, I suppose that--```haskell-A n -> B (op n)---- becomes-{ p n => q (op n) }. A<p> -> B<q>---- i.e.--{ p n => v = op n => q v }. A<p> -> B<q>-```---(a -> Count b <<p>>) -> xs:List a -> (Count (List b) <<q>>)---```haskell-A n -> B m -> C (n + m)---- becomes-{ p n => q m => r (n + m) }. A<p> -> B<q> -> C<r>---- i.e.-{ p n => q m => v = n + m => r v }. A<p> -> B<q> -> C<r>-```--{ n::Int<p> |- {v:Int | v = n+1} <: Int<q> }--```haskell-{-@ bump1 :: forall <p::Int -> Bool, q::Int -> Bool>.-               { n::Int<p> |- {v:Int | v = n + 1} <: Int<q> }-               (Int -> Int<p>) -> Int<q>-  @-}-bump1 :: (Int -> Int) -> Int-bump1 f = f 0 + 1--{-@ bumps :: forall <p::[Int] -> Bool, q::Int -> Bool>.-               { xs :: [Int]<p> |- {v:Int | v = len xs} <: Int<q> }-               (Int -> [Int]<p>) -> Int<q>-  @-}--bumps :: (Int -> ListN Int n) -> IntN n-bumps f = size (f 0)--{-@ bump2 :: forall <p::Int -> Bool, q::Int -> Bool, r::Int -> Bool>.-               { n::Int<p>, m::Int<q> |- {v:Int | v = n + m} <: Int<r> }-               (Int -> Int<p>) -> (Int -> Int<q>) -> Int<r>-  @-}-bump2 :: (Int -> Int) -> (Int -> Int) -> Int-bump2 f g = f 0 + g 0--{-@ flerb :: ({v:Int | v = 6}, {v:Int | v = 10}) @-}-flerb = (a, b)   -  where-    a = bump  zong-    b = bump2 zong zong-    zong :: Int -> Int-    zong n = 5--{-@ type IntN N = {v:Int | v == N} @-}-bump1 :: Ghost n. (Int -> IntN n) -> IntN (n+1)-bump2 :: Ghost n m. (Int -> IntN n) -> (Int -> IntN m) -> IntN (n+m)-```--### New Proposal--**NOTE:** I believe this is a **purely syntactic change**:-it should not affect how absref is actually implemented,-but it more precisely describes the implementation than-the current `-> Bool` formulation.--#### Step 1: Abstract Refinement is "Type with Shape"--Key idea is to think of an abstract refinement as a (function returning a) refinement type.--That is, the abstract refinement:--```haskell-  T1 -> T2 -> T3 -> ... -> S -> Bool-```--now just becomes--```haskell-  T1 -> T2 -> T3 -> ... -> {S}-```--Here, `{S}` denotes a refinement type with shape `S`--**Key Payoff:** This means that we don't need an _explicit application_ form, that is--```haskell-  foo :: forall <p :: Int -> Bool>. [Int<p>] -> Int<p>-```--can just be written as--```haskell-  foo :: forall <p :: {Int}>. [p] -> p-```--where we need not write `Int<p>`, its enough to just write `p`.--#### Step 2: An explicit "Meet" Operator--However, sometimes you need to write things like:--```haskell-  List <p> a <<p>>-```--where `p :: List a -> Bool` i.e. `p :: {List a}` and which denotes--* a list-of-a that is recursively indexed by `p`, AND-* where the top-level list is constrained by `p`.--That is, more generally, where you want to--* additionally, index the type with other abstract refinements, AND-* "apply" an abstract refinement to the "top-level" type.--For this, I think we should have an explicit *meet* operator-Note that, earlier `Int<p>` was an *implicit* meet operator,-where we were *conjoining* `Int` and `p`. Viewing `p` as-just being a refined `Int` allows us to SEPARATE "meet"-to only those places where its really needed.--So we can write the funny `List <p> a <<p>>` as:--```haskell-  p /\ List <p> a-```--See below for many other examples:--#### Example: Value Dependencies--**Old**--```haskell-  foo :: forall <p :: Int -> Int -> Bool>. x:Int -> [Int<p x>] -> Int<p x>-```--**New**--```haskell-  foo :: forall <p :: Int -> {Int}>. x:Int -> [p x] -> p x-```--#### Example: Dependent Pairs--**Old**--```haskell-  data Pair a b <p :: a -> b -> Bool>-    = Pair { pairX :: a-           , pairB :: b<p pairX>-           }--  type OrdPair a = Pair <{\px py -> px < py}> a a-```--**New**--```haskell-  data Pair a b <p :: a -> {b}>-    = Pair { pairX :: a-           , pairY :: p pairX-           }---  type OrdPair a = Pair a a <\px ->  {py:a | px < py}>-```--#### Example: Binary Search Maps--**Old**--```haskell-  data Map k a <l :: root:k -> k -> Bool, r :: root:k -> k -> Bool>-      = Tip-      | Bin { mSz    :: Size-            , mKey   :: k-            , mValue :: a-            , mLeft  :: Map <l, r> (k <l mKey>) a-            , mRight :: Map <l, r> (k <r mKey>) a }--  type OMap k a = Map <{\root v -> v < root }, {\root v -> v > root}> k a-```--**New**--```haskell-  data Map k a <l :: root:k -> {k}, r :: root:k -> {k}>-      = Tip-      | Bin { mSz    :: Size-            , mKey   :: k-            , mValue :: a-            , mLeft  :: Map (l mKey) a <l, r>-            , mRight :: Map (r mKey) a <l, r> }--  type OMap k a = Map k a <\root -> {v:k | v < root }, \root -> {v:k | root < v}>-```--#### Example: Ordered Lists--**Old**--```haskell-  data List a <p :: a -> a -> Bool>-    = Emp-    | Cons { lHd :: a-           , lTl :: List <p> (a<p lHd>)-           }--  type OList a = List <{\x v -> x <= v}> a-```--**New**--```haskell-  data List a <p :: a -> {a}>-    = Emp-    | Cons { lHd :: a-           , lTl :: List (p lHd) <p>-           }--  type OList a = List a <\x -> {v:a | x <= v}>-```--#### Example: Infinite Streams--**Old**--```haskell-  data List a <p :: List a -> Prop>-    = N-    | C { x  :: a-        , xs :: List <p> a <<p>>-        }--  type Stream a = {xs: List <{\v -> isCons v}> a | isCons xs}-```--**New**--```haskell-  data List a <p :: {List a}>-    = N-    | C { x  :: a-        , xs :: p /\ List a <p>-        }--  type Stream a = {xs: List a <{v | isCons v}> | isCons xs}-```-----### Old Proposal---|                      | Current Syntax                | Future Syntax                 |-|----------------------|-------------------------------|-------------------------------|-| Abstract Refinements | `List <{\x v -> v >= x}> Int` | `List Int (\x v -> v >= x)`   |-|                      | `[a<p>]<{\x v -> v >= x}>`    | `[a p] (\x v -> v >= x) (??)` |-|                      | `Int<p>`                      | `Int p`                       |-|                      | `Int<\x -> x >=0>`            | `Int (\x -> x >= 0)`          |--|                      | `Maybe <<p>> (a<q>) (?)`      | `Maybe (a q) p`               |-|                      | `Map <l, r> <<p>> k v  (?)`   | `Maybe k v l r p`             |--| Type Arguments       | `ListN a {len xs + len ys}`   | `ListN a (len xs + len ys)`   |--Q: How do I distinguish `Int p` with `ListN a n`?-(`p` is a abstract refinement and `n` is an `Integer`)--A: From the context!-Use simple kinds, i.e.-`ListN :: * -> Int -> *`-`Int :: ?AR -> *`
− appveyor-copy.bat 
@@ -1,9 +0,0 @@-rem Copy runtime DLLs --echo "" | stack exec -- where libstdc++-6.dll > lib.txt-echo "" | stack exec -- where libgcc_s_seh-1.dll >> lib.txt-echo "" | stack exec -- where libwinpthread-1.dll >> lib.txt--FOR /F %%I IN (lib.txt) DO copy /Y "%%I" .\--del /q lib.txt
− appveyor.yml 
@@ -1,43 +0,0 @@-platform: x64--init:-- git --version-  -install:-# http://help.appveyor.com/discussions/problems/6312-curl-command-not-found-- set PATH=%PATH%;C:\Program Files\Git\mingw64\bin--# Update GIT submodules-- git submodule update --init --recursive--# Download latest stable Stack tool-- curl -sS -ostack.zip -L --insecure https://get.haskellstack.org/stable/windows-x86_64.zip-- 7z x stack.zip stack.exe-- stack --version--# Install Microsoft Z3 from NuGet-- nuget install z3x64win -Version 4.5.0.1	--- set PATH=%PATH%;%cd%;%cd%\z3x64win.4.5.0.1\tools-- z3 --version--build_script:-# Build LiquidHaskell-- echo "" | stack --no-terminal build --copy-bins --local-bin-path .--# Copy runtime DLLs-- call appveyor-copy.bat--# Test if they are working-- fixpoint --version-- liquid --version--# ZIP execturable -- 7z a liquidhaskell.zip liquid.exe fixpoint.exe .\include\CoreToLogic.lg LICENSE LICENSE_Z3 libstdc++-6.dll libgcc_s_seh-1.dll libwinpthread-1.dll %APPVEYOR_BUILD_FOLDER%\z3x64win.4.5.0.1\tools\*.exe %APPVEYOR_BUILD_FOLDER%\z3x64win.4.5.0.1\lib\*.dll %APPVEYOR_BUILD_FOLDER%\z3x64win.4.5.0.1\*.dll--test_script:-- echo "" | stack --no-terminal test liquidhaskell --fast --test-arguments "-p Micro"--artifacts:-- path: liquidhaskell.zip-  name: LiquidHaskell
− cabal.project 
@@ -1,13 +0,0 @@--- For more information see---  http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html--packages: .-          ./liquid-fixpoint--package liquid-fixpoint-  flags: devel--package liquidhaskell-  flags: devel--with-compiler: ghc-8.6.4
− cleanup 
@@ -1,2 +0,0 @@-rm -rf **/.liquid .-# find . | grep -E -e '\.(smt2|bak|json|css|md|hi|out|fqout|fq|o|err|annot|log|html|cgi|liquid)$' | xargs rm -rf
+ exe/Liquid.hs view
@@ -0,0 +1,6 @@+import Language.Haskell.Liquid.Liquid (liquid)+import System.Environment             (getArgs)+-- import GhcTest ++main :: IO a+main = liquid =<< getArgs
− include/Data/ByteString/Lazy/Char8.spec 
@@ -1,417 +0,0 @@-module spec Data.ByteString.Lazy where--assume empty :: { bs : Data.ByteString.Lazy.ByteString | bllen bs == 0 }--assume singleton-    :: Char -> { bs : Data.ByteString.Lazy.ByteString | bllen bs == 1 }--assume pack-    :: w8s : [Char]-    -> { bs : Data.ByteString.ByteString | bllen bs == len w8s }--assume unpack-    :: bs : Data.ByteString.Lazy.ByteString-    -> { w8s : [Char] | 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-    :: Char-    -> i : Data.ByteString.Lazy.ByteString-    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i + 1 }--assume snoc-    :: i : Data.ByteString.Lazy.ByteString-    -> Char-    -> { 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 }--head-    :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }-    -> Char--assume uncons-    :: i : Data.ByteString.Lazy.ByteString-    -> Maybe (Char, { 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 }, Char)--last-    :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }-    -> Char--tail-    :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }-    -> Char--init-    :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }-    -> Char--assume null-    :: bs : Data.ByteString.Lazy.ByteString-    -> { b : GHC.Types.Bool | b <=> bllen bs == 0 }--assume length-    :: bs : Data.ByteString.Lazy.ByteString -> { n : Data.Int.Int64 | bllen bs == n }--assume map-    :: (Char -> Char)-    -> 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-    :: 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 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}--foldl1-    :: (Char -> Char -> Char)-    -> { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }-    -> Char--foldl1'-    :: (Char -> Char -> Char)-    -> { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }-    -> Char--foldr1-    :: (Char -> Char -> Char)-    -> { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }-    -> Char--foldr1'-    :: (Char -> Char -> Char)-    -> { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }-    -> Char--assume concat-    :: is : [Data.ByteString.Lazy.ByteString]-    -> { o : Data.ByteString.Lazy.ByteString | len is == 0 ==> bllen o }--assume concatMap-    :: (Char -> Data.ByteString.Lazy.ByteString)-    -> i : Data.ByteString.Lazy.ByteString-    -> { o : Data.ByteString.Lazy.ByteString | bllen i == 0 ==> bllen o == 0 }--assume any :: (Char -> GHC.Types.Bool)-    -> bs : Data.ByteString.Lazy.ByteString-    -> { b : GHC.Types.Bool | bllen bs == 0 ==> not b }--assume all :: (Char -> GHC.Types.Bool)-    -> bs : Data.ByteString.Lazy.ByteString-    -> { b : GHC.Types.Bool | bllen bs == 0 ==> b }--maximum :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs } -> Char--minimum :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs } -> Char--assume scanl-    :: (Char -> Char -> Char)-    -> Char-    -> i : Data.ByteString.Lazy.ByteString-    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i }--assume scanl1-    :: (Char -> Char -> Char)-    -> i : { i : Data.ByteString.Lazy.ByteString | 1 <= bllen i }-    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i }--assume scanr-    :: (Char -> Char -> Char)-    -> Char-    -> i : Data.ByteString.Lazy.ByteString-    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i }--assume scanr1-    :: (Char -> Char -> Char)-    -> i : { i : Data.ByteString.Lazy.ByteString | 1 <= bllen i }-    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i }--assume mapAccumL-    :: (acc -> Char -> (acc, Char))-    -> acc-    -> i : Data.ByteString.Lazy.ByteString-    -> (acc, { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i })--assume mapAccumR-    :: (acc -> Char -> (acc, Char))-    -> acc-    -> i : Data.ByteString.Lazy.ByteString-    -> (acc, { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i })--assume replicate-    :: n : Data.Int.Int64-    -> Char-    -> { bs : Data.ByteString.Lazy.ByteString | bllen bs == n }--assume unfoldrN-    :: n : Int-    -> (a -> Maybe (Char, a))-    -> a-    -> ({ bs : Data.ByteString.Lazy.ByteString | bllen bs <= n }, Maybe a)--assume take-    :: n : Data.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 : Data.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 : Data.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-    :: (Char -> GHC.Types.Bool)-    -> i : Data.ByteString.Lazy.ByteString-    -> { o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }--assume dropWhile-    :: (Char -> GHC.Types.Bool)-    -> i : Data.ByteString.Lazy.ByteString-    -> { o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }--assume span-    :: (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 spanEnd-    :: (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 break-    :: (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 breakEnd-    :: (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 group-    :: i : Data.ByteString.Lazy.ByteString-    -> [{ o : Data.ByteString.Lazy.ByteString | 1 <= bllen o && bllen o <= bllen i }]--assume groupBy-    :: (Char -> Char -> 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-    :: Char-    -> i : Data.ByteString.Lazy.ByteString-    -> [{ o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }]--assume splitWith-    :: (Char -> GHC.Types.Bool)-    -> i : Data.ByteString.Lazy.ByteString-    -> [{ o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }]--assume lines-    :: i : Data.ByteString.Lazy.ByteString-    -> [{ o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }]--assume words-    :: i : Data.ByteString.Lazy.ByteString-    -> [{ o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }]--assume unlines-    :: is : [Data.ByteString.Lazy.ByteString]-    -> { o : Data.ByteString.Lazy.ByteString | (len is == 0 <=> bllen o == 0) && bllen o >= len is }--assume 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 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 isInfixOf-    :: l : Data.ByteString.Lazy.ByteString-    -> r : Data.ByteString.Lazy.ByteString-    -> { b : GHC.Types.Bool | bllen l >= bllen r ==> not b }--assume breakSubstring-    :: il : Data.ByteString.Lazy.ByteString-    -> ir : Data.ByteString.Lazy.ByteString-    -> ( { ol : Data.ByteString.Lazy.ByteString | bllen ol <= bllen ir && (bllen il > bllen ir ==> bllen ol == bllen ir)}-       , { or : Data.ByteString.Lazy.ByteString | bllen or <= bllen ir && (bllen il > bllen ir ==> bllen or == 0) }-       )--assume elem-    :: Char-    -> bs : Data.ByteString.Lazy.ByteString-    -> { b : GHC.Types.Bool | bllen b == 0 ==> not b }--assume notElem-    :: Char-    -> bs : Data.ByteString.Lazy.ByteString-    -> { b : GHC.Types.Bool | bllen b == 0 ==> b }--assume find-    :: (Char -> GHC.Types.Bool)-    -> bs : Data.ByteString.Lazy.ByteString-    -> Maybe { w8 : Char | bllen bs /= 0 }--assume filter-    :: (Char -> GHC.Types.Bool)-    -> i : Data.ByteString.Lazy.ByteString-    -> { o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }--assume partition-    :: (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 }-       )--index-    :: bs : Data.ByteString.Lazy.ByteString-    -> { n : Data.Int.Int64 | 0 <= n && n < bllen bs }-    -> Char--assume elemIndex-    :: Char-    -> bs : Data.ByteString.Lazy.ByteString-    -> Maybe { n : Data.Int.Int64 | 0 <= n && n < bllen bs }--assume elemIndices-    :: Char-    -> bs : Data.ByteString.Lazy.ByteString-    -> [{ n : Data.Int.Int64 | 0 <= n && n < bllen bs }]--assume elemIndexEnd-    :: Char-    -> bs : Data.ByteString.Lazy.ByteString-    -> Maybe { n : Data.Int.Int64 | 0 <= n && n < bllen bs }--assume findIndex-    :: (Char -> GHC.Types.Bool)-    -> bs : Data.ByteString.Lazy.ByteString-    -> Maybe { n : Data.Int.Int64 | 0 <= n && n < bllen bs }--assume findIndices-    :: (Char -> GHC.Types.Bool)-    -> bs : Data.ByteString.Lazy.ByteString-    -> [{ n : Data.Int.Int64 | 0 <= n && n < bllen bs }]--assume count-    :: Char-    -> bs : Data.ByteString.Lazy.ByteString-    -> { n : Data.Int.Int64 | 0 <= n && n < bllen bs }--assume zip-    :: l : Data.ByteString.Lazy.ByteString-    -> r : Data.ByteString.Lazy.ByteString-    -> { o : [(Char, Char)] | len o <= bllen l && len o <= bllen r }--assume zipWith-    :: (Char -> Char -> a)-    -> l : Data.ByteString.Lazy.ByteString-    -> r : Data.ByteString.Lazy.ByteString-    -> { o : [a] | len o <= bllen l && len o <= bllen r }--assume unzip-    :: i : [(Char, Char)]-    -> ( { l : Data.ByteString.Lazy.ByteString | bllen l == len i }-       , { r : Data.ByteString.Lazy.ByteString | bllen r == len i }-       )--assume sort-    :: i : Data.ByteString.Lazy.ByteString-    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i }--assume readInt-    :: i : Data.ByteString.Lazy.ByteString-    -> Maybe { p : (Int, { o : Data.ByteString.Lazy.ByteString | bllen o < bllen i}) | bllen i /= 0 }--assume readInteger-    :: i : Data.ByteString.Lazy.ByteString-    -> Maybe { p : (Integer, { o : Data.ByteString.Lazy.ByteString | bllen o < bllen i}) | bllen i /= 0 }--assume copy-    :: i : Data.ByteString.Lazy.ByteString-    -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i }--assume hGet-    :: System.IO.Handle-    -> n : { n : Int | 0 <= n }-    -> IO { bs : Data.ByteString.Lazy.ByteString | bllen bs == n || bllen bs == 0 }--assume hGetNonBlocking-    :: System.IO.Handle-    -> n : { n : Int | 0 <= n }-    -> IO { bs : Data.ByteString.Lazy.ByteString | bllen bs <= n }
include/Data/Either.spec view
@@ -1,5 +1,5 @@ module spec Data.Either where  measure isLeft :: Data.Either.Either a b -> Bool-isLeft (Left x)  = true-isLeft (Right x) = false+  isLeft (Left x)  = true+  isLeft (Right x) = false
− include/Data/Map.hiddenspec 
@@ -1,27 +0,0 @@-module spec Data.Map where--embed Data.Map.Map as Map_t-------------------------------------------------------------------------------------------- | Logical Map Operators: Interpreted "natively" by the SMT solver ------------------------------------------------------------------------------------------------------------measure Map_select :: forall k v. Data.Map.Map k v -> k -> v--measure Map_store  :: forall k v. Data.Map.Map k v -> k -> v -> Data.Map.Map k v---insert :: Ord k => k:k -> v:v -> m:Data.Map.Map k v -> {n:Data.Map.Map k v | n = Map_store m k v}--lookup :: Ord k => k:k -> m:Data.Map.Map k v -> Maybe {v:v | v = Map_select m k}--(!)    :: Ord k => m:Data.Map.Map k v -> k:k -> {v:v | v = Map_select m k}---------
− include/Data/Time/Calendar.spec 
@@ -1,11 +0,0 @@-module spec Data.Time.Calendar where--type NumericMonth = { x:Nat | 0 < x && x <= 12 }--type NumericDayOfMonth = { x:Nat | 0 < x && x <= 31 }--fromGregorian :: Integer -> NumericMonth -> NumericDayOfMonth -> Day--toGregorian :: Day -> (Integer,NumericMonth,NumericDayOfMonth)--gregorianMonthLength :: Integer -> NumericMonth -> { x:Nat | 28 <= x && x <= 31 }
include/Data/Tuple.spec view
@@ -1,4 +1,4 @@ module spec Data.Tuple where -fst :: x:(a,b) -> {v:a | v = (fst x)}-snd :: x:(a,b) -> {v:b | v = (snd x)}+fst :: {f:(x:(a,b) -> {v:a | v = (fst x)}) | f == fst }+snd :: {f:(x:(a,b) -> {v:b | v = (snd x)}) | f == snd }
include/Foreign/C/String.spec view
@@ -8,4 +8,4 @@ // 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+  cStringLen (c, n) = n
include/Foreign/C/Types.spec view
@@ -1,5 +1,7 @@ module spec Foreign.C.Types where +import GHC.Word+ embed Foreign.C.Types.CInt   as int embed Foreign.C.Types.CSize  as int embed Foreign.C.Types.CULong as int
include/GHC/Base.spec view
@@ -11,28 +11,28 @@ 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+  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+  fst (a, b) = a  measure snd :: (a, b) -> b-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+  isJust (Just x)  = true+  isJust (Nothing) = false  measure fromJust :: Maybe a -> a-fromJust (Just x) = x+  fromJust (Just x) = x   invariant {v: [a] | len v >= 0 }
include/GHC/List.spec view
@@ -49,7 +49,7 @@ GHC.List.!!         :: xs:[a] -> {v: _ | ((0 <= v) && (v < len(xs)))} -> a  - zip :: xs : [a] -> ys:[b] +zip :: xs : [a] -> ys:[b]             -> {v : [(a, b)] | ((((len v) <= (len xs)) && ((len v) <= (len ys)))             && (((len xs) = (len ys)) => ((len v) = (len xs))) )}
include/GHC/Prim.spec view
@@ -1,6 +1,8 @@ module spec GHC.Prim where   embed GHC.Prim.Int#     as int-embed GHC.Prim.Double#  as real+embed GHC.Prim.Addr#    as Str+embed GHC.Prim.Char#    as Char+embed GHC.Prim.Double# as real embed GHC.Prim.Float#  as real embed GHC.Prim.Word#    as int
include/KMeansHelper.hs view
@@ -37,7 +37,7 @@  {-@ type PosInt = {v: Int | v > 0 } @-} -{-@ partition           :: size:PosInt -> [a] -> (Clustering a) @-}+{-@ partition           :: size:PosInt -> xs:[a] -> (Clustering a) / [len xs] @-}  partition size []       = [] partition size ys@(_:_) = zs : partition size zs'
include/Language/Haskell/Liquid/Bag.hs view
− include/Language/Haskell/Liquid/Example.hs 
@@ -1,62 +0,0 @@-{-@ LIQUID "--exact-data-cons" @-}-{-@ LIQUID "--higherorder"     @-}--module ListExample where--import ProofCombinators--import Prelude hiding ((++))------------------------------------------------------------------------------------- | Lists----------------------------------------------------------------------------------{-@ data L [size] @-}-data L a = C a (L a) | N--size :: L a -> Int-{-@ measure size @-}-{-@ size :: L a -> Nat @-}-size N       = 0-size (C _ x) = 1 + size x------------------------------------------------------------------------------------- | Appending Lists----------------------------------------------------------------------------------{-@ reflect ++ @-}-{-@ infixr  ++ @-}-(++) :: L a -> L a -> L a-N ++ ys        = ys-(C x xs) ++ ys = C x (xs ++ ys)------------------------------------------------------------------------------------- | Complete Proofs----------------------------------------------------------------------------------{-@ leftId :: x:L a -> { x ++ N == x } @-}-leftId :: L a -> Proof-leftId N-  =   N ++ N-  === N                        -- equality `N ++ N === N` holds by unfolding `++`-  *** QED--leftId (C x xs)-  =    (C x xs) ++ N-  ===  C x (xs ++ N)           -- equality holds by unfolding `++`-  ==? C x xs     ? leftId xs   -- equality requires "certificate" `leftId xs`-  *** QED-------------------------------------------------------------------------------------- | Incomplete Proofs-----------------------------------------------------------------------------------{-@ assoc :: x:L a -> y:L a -> z:L a->  { (x ++ y) ++ z = x ++ (y ++ z) } @-}-assoc :: L a -> L a -> L a -> Proof-assoc N y z-  =   ()-  *** Admit                  -- Give up. Replace with QED to see ERROR.--assoc (C a x) y z-  =  ((C a x) ++ y) ++ z-  ==! C a (x ++ (y ++ z))    -- Unsafe-eq; replace with `==.` or `===` to see error )-  === (C a x) ++ (y ++ z)-  *** QED
include/Language/Haskell/Liquid/Foreign.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# LANGUAGE MagicHash #-}  {- OPTIONS_GHC -cpp #-}@@ -10,6 +11,8 @@ 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        -}@@ -36,7 +39,7 @@ mkPtr = undefined -- Ptr x  -{-@ isNullPtr :: p:(Ptr a) -> {v:Bool | (v <=> (isNullPtr p)) } @-}+{-@ assume isNullPtr :: p:(Ptr a) -> {v:Bool | (v <=> (isNullPtr p)) } @-} isNullPtr :: Ptr a -> Bool isNullPtr p = (p == nullPtr) {-# INLINE isNullPtr #-}
include/Language/Haskell/Liquid/List.hs view
@@ -1,5 +1,6 @@ module Language.Haskell.Liquid.List (transpose) where +{-@ lazy transpose @-} transpose                  :: Int -> [[a]] -> [[a]] transpose _ []             = [] transpose n ([]   : xss)   = transpose n xss
− include/Language/Haskell/Liquid/OldProofCombinators.hs 
@@ -1,272 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE IncoherentInstances   #-}--module Language.Haskell.Liquid.OldProofCombinators (--    (==:), (<=:), (<:), (>:)--  , (==?)--  , (==.), (<=.), (<.), (>.), (>=.)--  , (?), (***)--  , (==>), (&&&), (∵)--  , proof, toProof, simpleProof, trivial--  , QED(..)--  , Proof--  , byTheorem, castWithTheorem, cast --  -- Function Equality -  , Arg--  , (=*=.)--  -- Conjunction-  , PAnd (..)---  -- Disjunction-  , POr (..)--  ) where---type Proof = ()--trivial :: Proof-trivial = ()---data QED = QED--infixl 2 ***--(***) :: a -> QED -> Proof-_ *** _ = ()----- | Because provide lemmata ? or ∵--infixl 3 ∵--(∵) :: (Proof -> a) -> Proof -> a-f ∵ y = f y---infixl 3 ?--(?) :: (Proof -> a) -> Proof -> a-f ? y = f y----{-@ measure proofBool :: Proof -> Bool @-}---- | Proof combinators (are Proofean combinators)-{-@ (==>) :: p:Proof-          -> q:Proof-          -> {v:Proof |-          (((proofBool p)) && ((proofBool p) => (proofBool q)))-          =>-          (((proofBool p) && (proofBool q)))-          } @-}-(==>) :: Proof -> Proof -> Proof-_ ==> _ = ()---{- (&&&) :: p:{Proof | (proofBool p) }-          -> q:{Proof | (proofBool q) }-          -> {v:Proof | (proofBool p) && (proofBool q) } @-}-(&&&) :: Proof -> Proof -> Proof-_ &&& _ = ()----- | proof goes from Int to resolve types for the optional proof combinators-proof :: Int -> Proof-proof _ = ()--toProof :: a -> Proof-toProof _ = ()--simpleProof :: Proof-simpleProof = ()---- | proof operators requiring proof terms-infixl 3 ==:, <=:, <:, >:, ==?----- | Comparison operators requiring proof terms--(<=:) :: a -> a -> Proof -> a-{-@ (<=:) :: x:a -> y:a -> {v:Proof | x <= y } -> {v:a | v == y } @-}-(<=:) _ y _ = y--(<:) :: a -> a -> Proof -> a-{-@ (<:) :: x:a -> y:a -> {v:Proof | x < y } -> {v:a | v == y } @-}-(<:) _ y _ = y---(>:) :: a -> a -> Proof -> a-{-@ (>:) :: x:a -> y:a -> {v:Proof | x > y } -> {v:a | v == y } @-}-(>:) _ y _ = y---(==:) :: a -> a -> Proof -> a-{-@ (==:) :: x:a -> y:a -> {v:Proof| x == y} -> {v:a | v == x && v == y } @-}-(==:) x _ _ = x----- | proof operators with optional proof terms-infixl 3 ==., <=., <., >., >=.----- | Comparison operators requiring proof terms optionally--class ToProve a r where-  (==?) :: a -> a -> r---instance (a~b) => ToProve a b where-{-@ instance ToProve a b where-  ==? :: x:a -> y:a -> {v:b | v ~~ x }-  @-}-  (==?)  = undefined--instance (a~b) => ToProve a (Proof -> b) where-{-@ instance ToProve a (Proof -> b) where-  ==? :: x:a -> y:a -> Proof -> {v:b | v ~~ x  }-  @-}-  (==?) = undefined----class OptEq a r where-  (==.) :: a -> a -> r--instance (a~b) => OptEq a (Proof -> b) where-{-@ instance OptEq a (Proof -> b) where-  ==. :: x:a -> y:a -> {v:Proof | x == y} -> {v:b | v ~~ x && v ~~ y}-  @-}-  (==.) x _ _ = x--instance (a~b) => OptEq a b where-{-@ instance OptEq a b where-  ==. :: x:a -> y:{a| x == y} -> {v:b | v ~~ x && v ~~ y }-  @-}-  (==.) x _ = x---class OptLEq a r where-  (<=.) :: a -> a -> r---instance (a~b) => OptLEq a (Proof -> b) where-{-@ instance OptLEq a (Proof -> b) where-  <=. :: x:a -> y:a -> {v:Proof | x <= y} -> {v:b | v ~~ y }-  @-}-  (<=.) _ y _ = y--instance (a~b) => OptLEq a b where-{-@ instance OptLEq a b where-  <=. :: x:a -> y:{a | x <= y} -> {v:b | v ~~ y }-  @-}-  (<=.) _ y = y--class OptGEq a r where-  (>=.) :: a -> a -> r--instance OptGEq a (Proof -> a) where-{-@ instance OptGEq a (Proof -> a) where-  >=. :: x:a -> y:a -> {v:Proof| x >= y} -> {v:a | v == y }-  @-}-  (>=.) _ y _ = y--instance OptGEq a a where-{-@ instance OptGEq a a where-  >=. :: x:a -> y:{a| x >= y} -> {v:a | v == y  }-  @-}-  (>=.) _ y = y---class OptLess a r where-  (<.) :: a -> a -> r--instance (a~b) => OptLess a (Proof -> b) where-{-@ instance OptLess a (Proof -> b) where-  <. :: x:a -> y:a -> {v:Proof | x < y} -> {v:b | v ~~ y  }-  @-}-  (<.) _ y _ = y--instance (a~b) => OptLess a b where-{-@ instance OptLess a b where-  <. :: x:a -> y:{a| x < y} -> {v:b | v ~~ y  }-  @-}-  (<.) _ x = x---class OptGt a r where-  (>.) :: a -> a -> r--instance (a~b) => OptGt a (Proof -> b) where-{-@ instance OptGt a (Proof -> b) where-  >. :: x:a -> y:a -> {v:Proof| x > y} -> {v:b | v ~~ y }-  @-}-  (>.) _ y _ = y--instance (a~b) => OptGt a b where-{-@ instance OptGt a b where-  >. :: x:a -> y:{a| x > y} -> {v:b | v ~~ y  }-  @-}-  (>.) _ x = x---------------------------------------------------------------------------------------------  Casting ---------------------------------------------------------------------------------------------------------------------------------------------{-@ measure castWithTheorem :: a -> b -> b @-}-castWithTheorem :: a -> b -> b -castWithTheorem _ x = x ---{-@ measure cast :: b -> a -> a @-}-{-@ cast :: b -> x:a -> {v:a | v == x } @-}-cast :: b -> a -> a -cast _ x = x ---byTheorem :: a -> Proof -> a-byTheorem a _ = a---- | Function Equality --{- TO REFINE -class FunEq a b r where-  (=*=.) :: (a -> b) -> (a -> b) -> r--instance (c~(a -> b)) => FunEq a b ((a -> Proof) -> c) where-  {-@ instance FunEq a b ((a -> Proof) -> a -> b) where-   =*=. :: f:(a -> b) -> g:(a -> b) -> (r:a -> {f r == g r}) -> {v:_ | f == g && v ~~ f && v ~~ g}-   @-} -   f =*=. g = undefined  --}--class Arg a where ---{-@ assume (=*=.) :: Arg a => f:(a -> b) -> g:(a -> b) -> (r:a -> {f r == g r}) -> {v:(a -> b) | f == g} @-}-(=*=.) :: Arg a => (a -> b) -> (a -> b) -> (a -> Proof) -> (a -> b)-(=*=.) f _ _ = f----data POr  a b = POrLeft a | POrRight b -data PAnd a b = PAnd a b 
include/Language/Haskell/Liquid/Prelude.hs view
@@ -61,6 +61,7 @@ -------------------------------------------------------------------  +{-@ ignore liquidAssertB @-} {-@ assume liquidAssertB :: x:{v:Bool | v} -> {v: Bool | v} @-} {-# NOINLINE liquidAssertB #-} liquidAssertB :: Bool -> Bool@@ -71,23 +72,26 @@ liquidAssert :: Bool -> a -> a liquidAssert _ x = x +{-@ ignore liquidAssume @-} {-@ assume liquidAssume :: b:Bool -> a -> {v: a | b}  @-} {-# NOINLINE liquidAssume #-} liquidAssume :: Bool -> a -> a liquidAssume b x = if b then x else error "liquidAssume fails" +{-@ ignore liquidAssumeB @-} {-@ assume liquidAssumeB :: forall <p :: a -> Bool>. (a<p> -> {v:Bool| v}) -> a -> a<p> @-} liquidAssumeB :: (a -> Bool) -> a -> a liquidAssumeB p x | p x = x                   | otherwise = error "liquidAssumeB fails"  +{-@ ignore unsafeError @-} {-# NOINLINE unsafeError #-} unsafeError :: String -> a unsafeError = error  -{-@ assume liquidError :: {v:String | 0 = 1} -> a  @-}+{-@ liquidError :: {v:String | 0 = 1} -> a  @-} {-# NOINLINE liquidError #-} liquidError :: String -> a liquidError = error@@ -109,7 +113,7 @@ ----------- Modular Arithmetic Wrappers --------------------------- ------------------------------------------------------------------- --- tedium because fixpoint doesnt want to deal with (x mod y) only (x mod c)+-- 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@@ -129,9 +133,6 @@ safeZipWith _ []     []     = [] safeZipWith _ _ _ = error "safeZipWith: cannot happen!" --- {-@ (==>) :: p:Bool -> q:Bool -> {v:Bool | v <=> (p =>  q)} @-} infixr 8 ==> (==>) :: Bool -> Bool -> Bool@@ -139,12 +140,3 @@ False ==> True  = True True  ==> True  = True True  ==> False = False---- {- measure fst @-}--- fst :: (a, b) -> a --- fst (x, _) = x --- --- {- measure snd @-}--- snd :: (a, b) -> b --- snd (_, y) = y -
include/Language/Haskell/Liquid/ProofCombinators.hs view
@@ -26,7 +26,7 @@   , (==.)     -- Uncheck operator used only for proof debugging-  , (==!) -- x ==! y always succeds+  , (==!) -- x ==! y always succeeds    -- * Combining Proofs   , (&&&)
include/Language/Haskell/Liquid/RTick/Combinators.hs view
@@ -5,7 +5,7 @@  {-@ LIQUID "--reflection" @-} -module Language.Haskell.Liquid.RTick.Combinators where +module Language.Haskell.Liquid.RTick.Combinators   (    -- Basic:@@ -51,7 +51,7 @@   , assert   ) where -import RTick ( Tick(..) )+import Language.Haskell.Liquid.RTick ( Tick(..) )  -- -- Proof combinators for extrinsic cost analysis.
include/Language/Haskell/Liquid/String.hs view
@@ -43,11 +43,11 @@ subString (S s) o l = S (BS.take l $ BS.drop o s)   -{-@ takeString :: i:Nat -> xs:{SMTString | i <= stringLen xs } -> {v:SMTString | stringLen v == i && v == takeString i xs } @-} +{-@ 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) -{-@ dropString :: i:Nat -> xs:{SMTString | i <= stringLen xs } -> {v:SMTString | stringLen v == stringLen xs - i && v == dropString i xs } @-} +{-@ 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) @@ -57,6 +57,6 @@ fromString = S . ST.fromString   -{-@ isNullString :: i:SMTString -> {b:Bool | b <=> stringLen i == 0 } @-} +{-@ assume isNullString :: i:SMTString -> {b:Bool | b <=> stringLen i == 0 } @-}  isNullString :: SMTString -> Bool  isNullString (S s) = BS.length s == 0 
+ include/Language/Haskell/Liquid/Synthesize/Error.hs view
@@ -0,0 +1,5 @@+module Language.Haskell.Liquid.Synthesize.Error where ++{-@ err :: { v: Int | false } -> a @-}+err :: Int -> a+err s = undefined
− liquidhaskell-0.8.6.2.tar.gz 
binary file changed (45 → absent bytes)
liquidhaskell.cabal view
@@ -1,8 +1,9 @@+cabal-version:      2.4 name:               liquidhaskell-version:            0.8.6.2+version:            0.8.10.1 synopsis:           Liquid Types for Haskell description:        Liquid Types for Haskell.-license:            BSD3+license:            BSD-3-Clause license-file:       LICENSE copyright:          2010-19 Ranjit Jhala & Niki Vazou & Eric L. Seidel, University of California, San Diego. author:             Ranjit Jhala, Niki Vazou, Eric Seidel@@ -10,6 +11,7 @@ category:           Language homepage:           https://github.com/ucsd-progsys/liquidhaskell build-type:         Simple+tested-with:        GHC == 8.6.5, GHC == 8.10.1 extra-source-files: CHANGES.md                     README.md                     devel/Paths_liquidhaskell.hs@@ -40,21 +42,23 @@                     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                     syntax/liquid.css-cabal-version:      >= 1.22+                    -- Remove the lines above once we switch to the source plugin.+                    include/*.hs+                    include/Language/Haskell/Liquid/*.hs+                    include/Language/Haskell/Liquid/*.pred +                    -- Needed for the mirror-modules helper+                    mirror-modules/templates/MirrorModule.mustache+ source-repository head   type:     git   location: https://github.com/ucsd-progsys/liquidhaskell/ -flag devel-  default:     False-  manual:      True-  description: turn on stricter error reporting for development- flag include   default:     False   description: use in-tree include directory@@ -64,7 +68,18 @@   description: Support building against GHC with <https://phabricator.haskell.org/D4388>                backported +flag no-plugin+  default:     False+  manual:      True+  description: Use the legacy executable for testing.++flag mirror-modules-helper+  default:     False+  manual:      True+  description: Build the "mirror-modules" helper executable.+ library+  autogen-modules:    Paths_liquidhaskell   exposed-modules:    Gradual.Concretize                       Gradual.GUI                       Gradual.GUI.Annotate@@ -76,7 +91,7 @@                       Gradual.Trivial                       Gradual.Types                       Gradual.Uniquify-                      Language.Haskell.Liquid.Bag+                      Language.Haskell.Liquid.Cabal                       Language.Haskell.Liquid.Bare                       Language.Haskell.Liquid.Bare.Axiom                       Language.Haskell.Liquid.Bare.Check@@ -100,25 +115,30 @@                       Language.Haskell.Liquid.Constraint.Split                       Language.Haskell.Liquid.Constraint.ToFixpoint                       Language.Haskell.Liquid.Constraint.Types-                      Language.Haskell.Liquid.Equational-                      Language.Haskell.Liquid.Foreign                       Language.Haskell.Liquid.GHC.API+                      Language.Haskell.Liquid.GHC.GhcMonadLike                       Language.Haskell.Liquid.GHC.Interface+                      Language.Haskell.Liquid.GHC.Logging                       Language.Haskell.Liquid.GHC.Misc                       Language.Haskell.Liquid.GHC.Play                       Language.Haskell.Liquid.GHC.Resugar                       Language.Haskell.Liquid.GHC.SpanStack+                      Language.Haskell.Liquid.GHC.Types                       Language.Haskell.Liquid.GHC.TypeRep                       Language.Haskell.Liquid.Interactive.Handler                       Language.Haskell.Liquid.Interactive.Types                       Language.Haskell.Liquid.LawInstances                       Language.Haskell.Liquid.Liquid-                      Language.Haskell.Liquid.List                       Language.Haskell.Liquid.Measure                       Language.Haskell.Liquid.Misc                       Language.Haskell.Liquid.Parse-                      Language.Haskell.Liquid.Prelude-                      Language.Haskell.Liquid.ProofCombinators+                      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@@ -132,6 +152,7 @@                       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@@ -139,10 +160,10 @@                       Language.Haskell.Liquid.Types.PrettyPrint                       Language.Haskell.Liquid.Types.RefType                       Language.Haskell.Liquid.Types.Specs-                      Language.Haskell.Liquid.Types.Strata                       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@@ -155,12 +176,39 @@                       Language.Haskell.Liquid.WiredIn                       LiquidHaskell                       Paths_liquidhaskell-  hs-source-dirs:     src, include++  -- FIXME: Temporary measure to ensure that if the source plugin is available, then:+  --   1. we compile it;+  --   2. We don't rely on the \"liquid-prelude\" Haskell files previously shipped as part of LH itself.+  -- Once the source plugin is out, we should also removed the duplicate \"liquid-prelude\" files from+  -- the \"include\" directory.++  if impl(ghc >= 8.10)+      exposed-modules:    Language.Haskell.Liquid.GHC.Plugin+                          Language.Haskell.Liquid.GHC.Plugin.Tutorial+      other-modules:      Language.Haskell.Liquid.GHC.Plugin.SpecFinder+                          Language.Haskell.Liquid.GHC.Plugin.Types+                          Language.Haskell.Liquid.GHC.Plugin.Util+      hs-source-dirs:     src+  else+      hs-source-dirs:     src include+      exposed-modules:    Language.Haskell.Liquid.RTick+                          Language.Haskell.Liquid.Prelude+                          Language.Haskell.Liquid.Foreign+                          Language.Haskell.Liquid.RTick.Combinators+                          Language.Haskell.Liquid.String+                          Language.Haskell.Liquid.List+                          Language.Haskell.Liquid.Equational+                          Language.Haskell.Liquid.Bag+                          Language.Haskell.Liquid.ProofCombinators+                          KMeansHelper+   build-depends:      base                 >= 4.11.1.0 && < 5-                    , Diff                 >= 0.3+                    , Diff                 >= 0.3 && < 0.4                     , aeson                     , binary                     , bytestring           >= 0.10+                    , Cabal                < 3.3                     , cereal                     , cmdargs              >= 0.10                     , containers           >= 0.5@@ -174,14 +222,16 @@                     , ghc-paths            >= 0.1                     , ghc-prim                     , gitrev-                    , hashable             >= 1.2+                    , hashable             >= 1.3                     , hscolour             >= 1.22                     , liquid-fixpoint      >= 0.8.0.0                     , mtl                  >= 2.1+                    , optics               >= 0.2                     , optparse-simple                     , githash                     , parsec               >= 3.1                     , pretty               >= 1.1+                    , split                     , syb                  >= 0.4.4                     , template-haskell     >= 2.9                     , temporary            >= 1.2@@ -191,8 +241,9 @@                     , transformers         >= 0.3                     , unordered-containers >= 0.2                     , vector               >= 0.10+                    , extra   default-language:   Haskell98-  default-extensions: PatternGuards+  default-extensions: PatternGuards, RecordWildCards, DoAndIfThenElse   ghc-options:        -W -fwarn-missing-signatures    if flag(include)@@ -201,32 +252,18 @@   if flag(deterministic-profiling)     cpp-options: -DDETERMINISTIC_PROFILING +  if impl(ghc < 8.10) || flag(no-plugin)+    cpp-options: -DLIQUID_NO_PLUGIN++-- This is the (legacy) 'liquid' executable which uses the old GHC Interface. executable liquid-  main-is:            src/Liquid.hs+  main-is:            exe/Liquid.hs   build-depends:      base >= 4.9.1.0 && < 5, liquidhaskell   default-language:   Haskell98   default-extensions: PatternGuards   ghc-options:        -W -threaded -fdefer-typed-holes  -executable gradual-  main-is:          src/Gradual.hs-  build-depends:    base            >= 4.8.1.0 && < 5-                  , cmdargs-                  , hscolour-                  , liquid-fixpoint >= 0.7.0.5-                  , liquidhaskell-  default-language: Haskell2010-  buildable:        False-  ghc-options:      -W -threaded---executable target-  main-is:          src/Target.hs-  build-depends:    base >= 4.8.1.0 && < 5, hint, liquidhaskell-  default-language: Haskell2010-  buildable:        False- test-suite test   type:             exitcode-stdio-1.0   main-is:          test.hs@@ -240,15 +277,19 @@                   , optparse-applicative >= 0.11                   , process              >= 1.2                   , stm                  >= 2.4+                  , string-conv          >= 0.1                   , tagged               >= 0.7.3-                  , tasty                >= 0.10+                  , tasty                >= 0.10 && < 1.3                   , tasty-ant-xml+                  , tasty-golden         >= 2.0.0                   , tasty-hunit          >= 0.9                   , tasty-rerun          >= 1.1                   , text                   , transformers         >= 0.3   default-language: Haskell98   ghc-options:      -W -threaded+  if !flag(no-plugin)+    cpp-options: -DUSE_NEW_EXECUTABLE  test-suite liquidhaskell-parser   type:             exitcode-stdio-1.0@@ -265,3 +306,51 @@                   , tasty-hunit     >= 0.9   default-language: Haskell2010   ghc-options:      -W++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.0.0+                  , liquidhaskell+                  , tasty           >= 0.7+                  , tasty-hunit+                  , process+                  , filepath+                  , text+                  , directory+                  , ghc+                  , extra+  default-language: Haskell2010+  ghc-options:      -W+++-- 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.16.1.0+    buildable: True+  else+    buildable: False++  default-language:   Haskell2010+  default-extensions:+    OverloadedStrings+    RecordWildCards+    MultiWayIf+    LambdaCase+  ghc-options:        -W -threaded
+ mirror-modules/CLI.hs view
@@ -0,0 +1,59 @@+module CLI (+    CLI (..)+  , Flag(..)+  , parseCLI+  ) where+++import Options.Applicative+import qualified Data.Text as T+++-- Flags+data OverrideFiles++-- The @Flag@ datatype.++newtype Flag ix = Flag { unFlag :: Bool }++data CLI = CLI {+    overrideFiles       :: Flag OverrideFiles+  , modulesList         :: FilePath+  -- ^ A path to a list of modules to create.+  , mirrorPackageName   :: T.Text+  , moduleHierarchyRoot :: FilePath+  -- ^ A path to the root of the module hierarchy for the package we would like to target.+  }++parseCLI :: Parser CLI+parseCLI = CLI <$> parseOverrideFiles+               <*> parseModulesList+               <*> parsePackageName+               <*> parseModuleRoot++parseOverrideFiles :: Parser (Flag OverrideFiles)+parseOverrideFiles =+  Flag <$> switch (  long "unsafe-override-files"+                  <> help "Overrides an Haskell module if already present in the folder."+                  )++parseModulesList :: Parser FilePath+parseModulesList =+  strOption (  short 'l'+            <> long "modules-list"+            <> help "The path to a file containing a newline-separated list of modules to mirror."+            )++parsePackageName :: Parser T.Text+parsePackageName = T.pack <$>+  strOption (  short 'p'+            <> long "mirror-package-name"+            <> help "The name of the mirror package we are targeting. (example: liquid-foo)"+            )++parseModuleRoot :: Parser FilePath+parseModuleRoot =+  strOption (  short 'i'+            <> long "target"+            <> help "The path to the root of the module hierarchy for the target package. (example: liquid-foo/src)"+            )
+ mirror-modules/Main.hs view
@@ -0,0 +1,90 @@++module Main where++import           CLI+import           Options.Applicative++import           Control.Monad++import qualified Data.Text                               as T+import qualified Data.Set                                as S+import qualified Data.Map.Strict                         as M+import           Data.Set                                 ( Set )+import           Data.Function                            ( (&) )++import           System.FilePath+import           Shelly                                  as Sh hiding ((</>))++import           Text.Mustache                           (substitute, automaticCompile)++import Paths_liquidhaskell++--+-- Utility functions+--++findExistingModules :: CLI -> Sh (Set T.Text)+findExistingModules cli = do+  allFiles <- Sh.findWhen (\f -> pure $ takeExtension f == ".hs") (moduleHierarchyRoot cli)+  pure . S.fromList . map transform $ allFiles+  where+    -- Transform an input file by:+    -- * Stripping the path;+    -- * Replacing slashes with dots;+    -- * Remove the final \".hs"\ extension.+    transform :: FilePath -> T.Text+    transform f = f & dropExtension+                    & T.pack+                    & T.replace (T.pack $ moduleHierarchyRoot cli) mempty+                    & T.replace "/" "."+                    & T.replace "/" "."++-- Extracts the name of the mirrored package by dropping the \"liquid-\" prefix.+mirroredPackage :: CLI -> T.Text+mirroredPackage = T.tail . snd . T.breakOn "-" . mirrorPackageName++--+-- The main workhorse+--++mirrorModules :: CLI -> IO ()+mirrorModules cli@CLI{..} = shelly $ silently $ do+  dataDir         <- liftIO getDataDir+  inputModules    <- S.fromList . map T.strip . T.words <$> readfile modulesList+  existingModules <- findExistingModules cli++  -- If the user decided to completely override existing files, simply return all the input modules.+  let notMirrored = if | unFlag overrideFiles -> inputModules+                       | otherwise            -> inputModules `S.difference` existingModules+++  -- Use a template to automatically generate the module.+  let searchSpace = [dataDir </> "mirror-modules/templates"]+      templateName = "MirrorModule.mustache"++  compiled <- liftIO $ automaticCompile searchSpace templateName+  case compiled of+    Left err       -> errorExit (T.pack . show $ err)+    Right template -> do+      forM_ notMirrored $ \toMirror -> do+        let ctx = M.fromList [("packageName" :: String, mirroredPackage cli), ("moduleName", toMirror)]+        let newModule = substitute template ctx++        let pathToModule = moduleHierarchyRoot </> T.unpack (T.replace "." "/" toMirror) <> ".hs"+        parentFolder <- T.strip <$> run "dirname" [T.pack pathToModule]++        -- Create the parent folder, if necessary.+        mkdir_p (T.unpack parentFolder)++        -- Write the module.+        writefile pathToModule newModule++      echo $ "Mirrored " <> T.pack (show . length $ notMirrored) <> " modules."++main :: IO ()+main = mirrorModules =<< execParser opts+  where+    opts = info (parseCLI <**> helper)+      ( fullDesc+     <> progDesc "Create modules to be used in mirror packages."+     <> header "mirror-modules - Generate modules in mirror packages." )
+ mirror-modules/templates/MirrorModule.mustache view
@@ -0,0 +1,3 @@+module {{ moduleName }} (module Exports) where++import "{{ packageName }}" {{ moduleName }} as Exports
− scripts/CountBinders.hs 
@@ -1,93 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-module Main where---import           Control.Applicative-import           Data.Function-import           Data.Generics-import           Data.List-import           System.Environment-import           Text.Printf--import           CoreMonad-import           CoreSyn-import           DynFlags-import           GHC-import           GHC.Paths-import           HscTypes-import qualified Outputable as Out-import           Type-import           Var--import           Language.Haskell.Liquid.GhcMisc-import           Language.Haskell.Liquid.Misc--getCoreBinds :: FilePath -> IO [CoreBind]-getCoreBinds target = runGhc (Just libdir) $ do-  addTarget =<< guessTarget target Nothing-  flags <- getSessionDynFlags-  inc <- liftIO getIncludeDir-  setSessionDynFlags $ updateDynFlags flags [inc]-  load LoadAllTargets-  modGraph <- getModuleGraph-  case find ((== target) . msHsFilePath) modGraph of-    Just modSummary -> do-      mod_guts <- coreModule <$> (desugarModule =<< typecheckModule =<< parseModule modSummary)-      return   $! mg_binds mod_guts-    Nothing     -> error "Ghc Interface: Unable to get GhcModGuts"---updateDynFlags :: DynFlags -> [FilePath] -> DynFlags-updateDynFlags df ps-  = df { importPaths  = ps ++ importPaths df-       , libraryPaths = ps ++ libraryPaths df-       , profAuto     = ProfAutoCalls-       , ghcLink      = NoLink-       , hscTarget    = HscInterpreted-       , ghcMode      = CompManager-       } `xopt_set` Opt_MagicHash-         `dopt_set` Opt_ImplicitImportQualified---allBinders :: [CoreBind] -> [CoreBind]-allBinders cbs = cbs ++ map bind (concatMap (listify isBinder) cbs)-  where-    bind (Let x _)     = x-    isBinder (Let _ _) = True-    isBinder _         = False---recsAndFuns :: [CoreBind] -> ([Var],[Var],[Var])-recsAndFuns binds = (recs,recfuns,funs)-  where-    recs    = [v | Rec bs <- binds, (v,_)  <- bs]-    recfuns = filter isFun recs-    -- GHC does transforms recursive functions (at least with tyvars)-    -- into a let binding that quantifies over the tyvar followed by a-    -- letrec that defines the function, e.g.-    --     let foo = \ @a -> { letrec foo = ... in foo }-    -- but we don't want to count foo as rec and nonrec-    funs    = nubBy ((==) `on` getOccName)-            $ [v | NonRec v _ <- binds, isFun v]-           ++ recfuns-    isFun   = isFunTy . snd . splitForAllTys . varType---main :: IO ()-main = do-  target <- head <$> getArgs-  binds  <- allBinders <$> getCoreBinds target--  let (recs,recfuns,funs) = recsAndFuns binds--  printf "funs:     %d\n" (length funs)-  printf "recs:     %d\n" (length recs)-  printf "recsFuns: %d\n" (length recfuns)---instance Show CoreBind where-  show = showPpr--instance Show (Expr CoreBndr) where-  show = showPpr
− scripts/haskell_count 
@@ -1,122 +0,0 @@-#!/usr/bin/perl -w-# haskell_count - count physical lines of code-# Strips out {- .. -} and -- comments and counts the rest.-# Pragmas, {-#...}, are counted as SLOC.-# BUG: Doesn't handle strings with embedded block comment markers gracefully.-#      In practice, that shouldn't be a problem.-# Usage: haskell_count [-f file] [list_of_files]-#  file: file with a list of files to count (if "-", read list from stdin)-#  list_of_files: list of files to count-#  -f file or list_of_files can be used, or both--# This is part of SLOCCount, a toolsuite that counts-# source lines of code (SLOC).-# Copyright (C) 2001-2004 David A. Wheeler.-# -# This program is free software; you can redistribute it and/or modify-# it under the terms of the GNU General Public License as published by-# the Free Software Foundation; either version 2 of the License, or-# (at your option) any later version.-# -# This program is distributed in the hope that it will be useful,-# but WITHOUT ANY WARRANTY; without even the implied warranty of-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the-# GNU General Public License for more details.-# -# You should have received a copy of the GNU General Public License-# along with this program; if not, write to the Free Software-# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA-# -# To contact David A. Wheeler, see his website at:-#  http://www.dwheeler.com.-# ------$total_sloc = 0;--# Do we have "-f" (read list of files from second argument)?-if (($#ARGV >= 1) && ($ARGV[0] eq "-f")) {-  # Yes, we have -f-  if ($ARGV[1] eq "-") {-    # The list of files is in STDIN-    while (<STDIN>) {-      chomp ($_);-      &count_file ($_);-    }-  } else {-    # The list of files is in the file $ARGV[1]-    open (FILEWITHLIST, $ARGV[1]) || die "Error: Could not open $ARGV[1]\n";-    while (<FILEWITHLIST>) {-      chomp ($_);-      &count_file ($_);-    }-    close FILEWITHLIST;-  }-  shift @ARGV; shift @ARGV;-}-# Process all (remaining) arguments as file names-while ($file = shift @ARGV) {-  &count_file ($file);-}--print "Total:\n";-print "$total_sloc\n";--sub determine_lit_type {-  my ($file) = @_;--  open (FILE, $file);-  while (<FILE>) {-    if (m/^\\begin{code}/) { close FILE; return 2; }-    if (m/^>\s/) { close FILE; return 1; }-  }--  return 0;-}--sub count_file {-  my ($file) = @_;-  my $sloc = 0;-  my $incomment = 0;-  my ($literate, $inlitblock) = (0,0);--  $literate = 1 if $file =~ /\.lhs$/;-  if($literate) { $literate = determine_lit_type($file) }--  open (FILE, $file);-  while (<FILE>) {-    if ($literate == 1) {-      if (!s/^>//) { s/.*//; }-    } elsif ($literate == 2) {-      if ($inlitblock) {-        if (m/^\\end{code}/) { s/.*//; $inlitblock = 0; }-      } elsif (!$inlitblock) {-        if (m/^\\begin{code}/) { s/.*//; $inlitblock = 1; }-        else { s/.*//; }-      }-    }--    if ($incomment) {-      if (m/\-\}/) { s/^.*?\-\}//;  $incomment = 0;}-      else { s/.*//; }-    }-    if (!$incomment) {-      s!{-[^#].*?-}!!g;-      s/--.*//;-      if (m/{-/ && (!m/{-#/)) {-        s/{-.*//;-	$incomment = 1;-      }-    }-    if (m/\S/) {$sloc++;}-  }-  print "$sloc $file\n";-  if ($incomment) {print "ERROR: ended in comment in $ARGV\n";}-  $total_sloc += $sloc;-  $sloc = 0;-  $incomment = 0;-  close (FILE);-}
− scripts/metrics.py 
@@ -1,200 +0,0 @@-#!/usr/bin/python--from collections import defaultdict-from datetime import datetime-import os-import re-import string-import subprocess-import sys--benchmarks = {-    'benchmarks/text-0.11.2.3': [ 'Data/Text.hs'-                                , 'Data/Text/Array.hs'-                                , 'Data/Text/Encoding.hs'-                                , 'Data/Text/Foreign.hs'-                                , 'Data/Text/Fusion.hs'-                                , 'Data/Text/Fusion/Size.hs'-                                , 'Data/Text/Internal.hs'-                                , 'Data/Text/Lazy.hs'-                                , 'Data/Text/Lazy/Builder.hs'-                                , 'Data/Text/Lazy/Encoding.hs'-                                , 'Data/Text/Lazy/Fusion.hs'-                                , 'Data/Text/Lazy/Internal.hs'-                                , 'Data/Text/Lazy/Search.hs'-                                , 'Data/Text/Private.hs'-                                , 'Data/Text/Search.hs'-                                , 'Data/Text/Unsafe.hs'-                                , 'Data/Text/UnsafeChar.hs' ],--    'benchmarks/bytestring-0.9.2.1': [ 'Data/ByteString.T.hs'-                                     , 'Data/ByteString/Char8.hs'-                                     , 'Data/ByteString/Fusion.T.hs'-                                     , 'Data/ByteString/Internal.hs'-                                     , 'Data/ByteString/Lazy.hs'-                                     # , 'Data/ByteString/LazyZip.hs'-                                     , 'Data/ByteString/Lazy/Char8.hs'-                                     , 'Data/ByteString/Lazy/Internal.hs'-                                     , 'Data/ByteString/Unsafe.hs' ],--    'benchmarks/vector-algorithms-0.5.4.2': [ 'Data/Vector/Algorithms/AmericanFlag.hs'-                                            , 'Data/Vector/Algorithms/Combinators.hs'-                                            , 'Data/Vector/Algorithms/Common.hs'-                                            , 'Data/Vector/Algorithms/Heap.hs'-                                            , 'Data/Vector/Algorithms/Insertion.hs'-                                            , 'Data/Vector/Algorithms/Intro.hs'-                                            , 'Data/Vector/Algorithms/Merge.hs'-                                            , 'Data/Vector/Algorithms/Optimal.hs'-                                            , 'Data/Vector/Algorithms/Radix.hs'-                                            , 'Data/Vector/Algorithms/Search.hs' ],--    'benchmarks/esop2013-submission': [ 'Base.hs', 'Splay.hs' ],--    'benchmarks/hscolour-1.20.0.0': [ 'Language/Haskell/HsColour.hs'-                                    , 'Language/Haskell/HsColour/ACSS.hs'-                                    , 'Language/Haskell/HsColour/Anchors.hs'-                                    , 'Language/Haskell/HsColour/ANSI.hs'-                                    , 'Language/Haskell/HsColour/Classify.hs'-                                    , 'Language/Haskell/HsColour/ColourHighlight.hs'-                                    , 'Language/Haskell/HsColour/Colourise.hs'-                                    , 'Language/Haskell/HsColour/CSS.hs'-                                    , 'Language/Haskell/HsColour/General.hs'-                                    , 'Language/Haskell/HsColour/HTML.hs'-                                    , 'Language/Haskell/HsColour/InlineCSS.hs'-                                    , 'Language/Haskell/HsColour/LaTeX.hs'-                                    , 'Language/Haskell/HsColour/MIRC.hs'-                                    , 'Language/Haskell/HsColour/Options.hs'-                                    , 'Language/Haskell/HsColour/Output.hs'-                                    , 'Language/Haskell/HsColour/TTY.hs' ],--    'benchmarks/xmonad': [ 'XMonad/StackSet.hs' ],--    'include': [ 'GHC/List.lhs' ],--    '.': [ 'benchmarks/base-4.5.1.0/Data/List.hs' ]-}--def time(fn):-    start = datetime.now()-    with open(fn+'.log', 'w') as out:-        subprocess.call(['liquid', '--smtsolver', 'z3mem', fn], stdout=out, stderr=out)-    return (datetime.now() - start).total_seconds()--def errors(fn):-    with open(fn+'.log') as fd:-        log = fd.readlines()-    unsafes = [l for l in log if l.startswith('**** UNSAFE:')]-    return unsafes--def sloc(scripts,fn):-    return int(subprocess.check_output(-        '%s/haskell_count %s | tail -n1' % (scripts, fn), shell=True))--def lines(anns):-    return sum(map(lambda x:(1+x.count('\n')), anns))--def recs(fn):-    out = subprocess.check_output('liquid-count-binders %s 2>/dev/null' % fn, shell=True)-    return [int(n) for n in re.findall('(\d+)', out)]--def find(rx, str):-    return [(str[a.start():(3+string.find(str,"@-}", a.start()))])-            for a in list(re.finditer(rx, str))]--qualif_re = '{-@ qualif'-other = 'import|include|invariant|embed|Decrease|LAZYVAR|Strict|Lazy'-other_re = '{-@ (%s)' % other-spec_re = '{-@ (?!(%s|qualif|LIQUID))' % other-dec_re = '{-@ Decrease'-div_re = '{-@ (Strict|Lazy)'-wit_re = '{- LIQUID WITNESS'-mod_re = '^module ([\w\.]+)'--def combine(x, y):-    return {k:x[k] + y[k] for k in y.keys()}--def texify(fn, metrics):-    return '\\texttt{%s} & %d & %d / %d & %d / %d & %d / %d & %d & %d & %d & %d & %d \\\\\n' % (-        fn, metrics['sloc'], metrics['specs'], metrics['specs_lines'],-        metrics['others'], metrics['others_lines'],-        metrics['qualifs'], metrics['qualifs_lines'],-        metrics['funs'], metrics['recfuns'], metrics['divs'],-        metrics['hints'], metrics['time'])--def texify_term(fn, metrics):-    return '\\texttt{%s} & %d & %d & %d & %d & %d & %d & %d \\\\\n' % (-        fn, metrics['sloc'], metrics['errs'],-        metrics['funs'], metrics['recfuns'], metrics['divs'],-        metrics['hints'], metrics['time'])--def main():-    if len(sys.argv) >= 2 and sys.argv[1] == '--only-term':-        print 'ONLY COLLECTING TERMINATION DATA!'-        colformat = '|l|rr|rrrr|r|'-        headers = ['Module', 'LOC', 'Err', 'Fun', 'Rec', 'Div', 'Hint', 'Time']-        pptex = texify_term-    else:-        colformat = '|l|rrrr|rrrr|r|'-        headers = ['Module', 'LOC', 'Specs', 'Annot', 'Qualif',-                   'Fun', 'Rec', 'Div', 'Hint', 'Time']-        pptex = texify-    results = {}-    pwd = os.getcwd()-    for d, fs in benchmarks.iteritems():-        os.chdir(d)-        results[d] = {}-        for fn in fs:-            print fn-            f_res = {}-            f_res['time'] = time(fn)-            f_res['sloc'] = sloc(os.path.join(pwd,'scripts'),fn)-            [fs,rs,rfs] = recs(fn)-            f_res['funs'] = fs-            f_res['recs'] = rs-            f_res['recfuns'] = rfs--            errs = set(errors(fn))-            import pprint-            pprint.pprint(errs)-            f_res['errs'] = len(errs)--            str = (open(fn, 'r')).read()-            mod = re.search(mod_re, str, re.M).group(1)--            specs = find(spec_re, str)-            f_res['specs'] = len(specs)-            f_res['specs_lines'] = lines(specs)--            qualifs = find(qualif_re, str)-            f_res['qualifs'] = len(qualifs)-            f_res['qualifs_lines'] = lines(qualifs)--            others = find(other_re, str)-            f_res['others'] = len(others)-            f_res['others_lines'] = lines(others)--            f_res['divs'] = len(re.findall(div_re, str))-            f_res['hints'] = len(re.findall(wit_re, str)) + len(re.findall(dec_re, str))-            results[d][mod] = f_res--        os.chdir(pwd)--    with open('metrics.tex', 'w') as out:-        out.write('\\begin{tabular}{%s}\n' % colformat)-        out.write('\\hline\n')-        out.write(' & '.join('\\textbf{%s}' % h for h in headers) + '\\\\\n')-        out.write('\\hline\\hline\n')-        totals = defaultdict(int)-        for d, fs in results.iteritems():-            dirtotals = defaultdict(int)-            for fn, metrics in sorted(fs.iteritems()):-                out.write(pptex(fn, metrics))-                dirtotals = combine(dirtotals, metrics)-            out.write(pptex(d, dirtotals))-            out.write('\\hline\n\n')-            totals = combine(totals, dirtotals)-        out.write(pptex('Total', totals))-        out.write('\\hline\n\\end{tabular}\n')--if __name__ == '__main__':-    main()
− scripts/performance/cleanup.bash 
@@ -1,26 +0,0 @@-#!/bin/bash--SCRIPT_DIR=`dirname $0`;-SCRIPT_LOGS="$SCRIPT_DIR/logs";-FAILURES_OCCURRED=false;--function notify_if_failed {-    local EXIT_CODE=$?;-    if [ $EXIT_CODE != 0 ]-    then-        echo $1;-        echo "Exit code was: $EXIT_CODE";-        $FAILURES_OCCURRED=true;-    fi-}--echo "Deleting $SCRIPT_LOGS...";-rm -rf $SCRIPT_LOGS;-notify_if_failed "Failed to delete $SCRIPT_LOGS...";--if [ $FAILURES_OCCURRED = true ]-then-    echo "Cleanup failures occurred, please investigate...";-else-    echo "Cleanup completed successfully!";-fi
− scripts/performance/generate.bash 
@@ -1,248 +0,0 @@-#!/bin/bash--GIT=`which git`;-MAKE=`which make`;-CABAL=`which cabal`;-ALL_FOUND=true;--SCRIPT_DIR=`dirname $0`;--SCRIPT_LOGS="$SCRIPT_DIR/logs";-SCRIPT_REPO="$SCRIPT_LOGS/repository";-SCRIPT_FIXPOINT="$SCRIPT_REPO/liquid-fixpoint";-REPO_TEST="$SCRIPT_REPO/dist/build/test/test";-REPO_TEST_ARGS=" --timeout 10m";-REPO_LOG="$SCRIPT_REPO/tests/logs/cur/summary.csv";--ALL_GIT_TAGS="$GIT show-ref --tags | grep liquidhaskell | cut -c -40";-ALL_GIT_HASHES="$GIT log --format=%H";--START=0;-END=0;-FORCE=false;-MAX_LOGS=-1;-DONE_LOGS=0;--START_FOUND=false;-END_FOUND=false;--function refresh_repo {-    cd $SCRIPT_REPO;-    abort_if_failed "Couldn't change to $SCRIPT_REPO...";--    $GIT pull origin master;--    if [ $END != 0 ]-    then-        $GIT checkout master;-        $GIT submodule update;-    fi--    abort_if_failed "Couldn't pull Liquid Haskell from remote...";--    $GIT reset;-    abort_if_failed "Couldn't reset the the liquid-haskell repository...";--    $GIT checkout .;-    abort_if_failed "Couldn't discard changes to liquid-haskell...";--    $GIT submodule foreach 'git reset ; git checkout . ;';-    abort_if_failed "Couldn't reset and discard changes to submodules...";-}--function generate_log {-    local HASH=$1;-    local RESULT=$SCRIPT_LOGS/$HASH.csv;-    local SHOULD_GEN=true;--    if [ -e $RESULT ]-    then-        if [ $FORCE = false ]-        then-            SHOULD_GEN=false;-        fi-    fi--    if [ $SHOULD_GEN = true ]-    then-        DONE_LOGS=`expr $DONE_LOGS + 1`-        $GIT checkout $HASH;-        $GIT submodule update;-        $MAKE clean;-        if [ $? != 0 ]-        then-            return 1;-        fi--        rm -rf .cabal-sandbox;-        rm cabal.sandbox.config;--        $CABAL sandbox init;-        if [ $? != 0 ]-        then-            return 1;-        fi--        $CABAL sandbox add-source $SCRIPT_FIXPOINT;--        $CABAL install --enable-tests;-        if [ $? != 0 ]-        then-            return 1;-        fi--        $CABAL configure --enable-tests --disable-library-profiling -O2;-        if [ $? != 0 ]-        then-            return 1;-        fi--        $CABAL build;-        if [ $? != 0 ]-        then-            return 1;-        fi--        $CABAL exec $REPO_TEST -- $REPO_TEST_ARGS;-        # Not testing for failure; failed tests shouldn't prevent the site from-        # being generated.--        cp $REPO_LOG $RESULT-        if [ $? != 0 ]-        then-            return 1;-        fi-    fi--    return 0;-}--function abort_if_failed {-    local EXIT_CODE=$?;-    if [ $EXIT_CODE != 0 ]-    then-        echo $1;-        exit $EXIT_CODE;-    fi-}--function usage {-    echo "$0 -s [START HASH] -e [END HASH] -f -n [MAX LOGS TO GENERATE]"-    echo "   -s - hash to start generating logs at";-    echo "   -e - hash to end generating logs at";-    echo "   -f - If passed, will force re-creation of all logs. This will take an extremely long time!";-    echo "   -n - Only generate n logs (useful for cron jobs and such)"-    exit 1;-}--# Get options--while getopts ":s:e:n:f" OPT; do-    case $OPT in-        s)-            START=$OPTARG;;-        e)-            END=$OPTARG;;-        f)-            FORCE=true;;-        n)-            MAX_LOGS=$OPTARG;;-        *)-            usage;;-    esac-done--# Check dependencies--if [ $GIT = "" ]-then-    echo "Git not found...";-    ALL_FOUND=false;-fi--if [ $MAKE = "" ]-then-    echo "Make not found...";-    ALL_FOUND=false;-fi--if [ $CABAL = "" ]-then-    echo "Cabal not found...";-    ALL_FOUND=false;-else-    cabal sandbox --help &> /dev/null;-    if [ $? != 0 ]-    then-        echo "Cabal sandboxes not supported...";-        CABAL_VER=`cabal --numeric-version`;-        echo "Found Cabal version: $CABAL_VER, need 1.18 or greater..."-        ALL_FOUND=false;-    fi-fi--if [ $ALL_FOUND = true ]-then-    echo "All dependencies met...";-else-    echo "Some dependencies are unmet...";-    exit 1;-fi--$CABAL update;-abort_if_failed "Couldn't perform cabal update...";--# generate logs--if [ ! -e $SCRIPT_LOGS ]-then-    mkdir $SCRIPT_LOGS;-    abort_if_failed "$SCRIPT_LOGS doesn't exist and couldn't be created...";-fi--# Refresh the repo prior to working-refresh_repo;--if [ $END = 0 ]-then-    END_FOUND=true;-fi--for CURR in `$ALL_GIT_HASHES`-do-    if [ $START_FOUND = false ]-    then-        if [ $END_FOUND = false ]-        then-            if [ $CURR = $END ]-            then-                END_FOUND=true;-            fi-        fi--        if [ $END_FOUND = true ]-        then-            echo "Processing: $CURR";-            generate_log $CURR;-        fi--        if [ ! $? = 0 ]-        then-            echo "Log generation for $CURR failed...";-        fi--        if [ $CURR = $START ]-        then-            START_FOUND=true;-        fi--        if [ $MAX_LOGS = $DONE_LOGS  ]-        then-            START_FOUND=true;-        fi--        rm -rf /tmp/ghc*;-        rm -rf /tmp/cabal*;-    fi--done
− scripts/performance/initialize.bash 
@@ -1,77 +0,0 @@-#!/bin/bash--GIT=`which git`;-CABAL=`which cabal`;-GHC=`which ghc`;-ALL_FOUND=true;--SCRIPT_DIR=`dirname $0`;-SCRIPT_LOGS="$SCRIPT_DIR/logs";-SCRIPT_REPO="$SCRIPT_LOGS/repository";--LIQUID_URL="https://github.com/ucsd-progsys/liquidhaskell.git";--function abort_if_failed {-    local EXIT_CODE=$?;-    if [ $EXIT_CODE != 0 ]-    then-        echo $1;-        exit $EXIT_CODE;-    fi-}--# Check dependencies--if [ $GIT = "" ]-then-    echo "Git not found...";-    ALL_FOUND=false;-fi--if [ $CABAL = "" ]-then-    echo "Cabal not found...";-    ALL_FOUND=false;-else-    cabal sandbox --help &> /dev/null;-    if [ $? != 0 ]-    then-        echo "Cabal sandboxes not supported...";-        CABAL_VER=`cabal --numeric-version`;-        echo "Found Cabal version: $CABAL_VER, need 1.18 or greater..."-        ALL_FOUND=false;-    fi-fi--if [ $GHC = "" ]-then-    echo "GHC not found...";-    ALL_FOUND=false;-fi--if [ $ALL_FOUND = true ]-then-    echo "All dependencies met...";-else-    echo "Some dependencies are unmet...";-    exit 1;-fi--if [ -e $SCRIPT_LOGS ]-then-    echo "$SCRIPT_LOGS already exists, aborting..."-    exit 1;-fi--# clone repos--$GIT clone $LIQUID_URL $SCRIPT_REPO-abort_if_failed "Unable to clone Liquid Haskell...";--cd $SCRIPT_REPO;-abort_if_failed "Unable to change to $SCRIPT_REPO...";--$GIT submodule update --init;-abort_if_failed "Unable to initialize the git submodules...";--echo "Initialization completed successfully!";
− scripts/plot-benchmarks/README.md 
@@ -1,51 +0,0 @@-Plot-Benchmarks-===============--Overview-----------Plot-Benchmarks is a tool designed to ingest a directory full of LiquidHaskell test suite logs and generate graphs of performance data over time.--Usage--------```-  -l --logdir=ITEM            The directory that contains the logs-  -o --outputdir=ITEM         The diretory to output graphs to-     --plotcompare=ITEM,ITEM  Pairs of benchmarks to compare-     --plot=ITEM              Benchmarks to plot-  -? --help                   Display help message-  -V --version                Print version information-     --numeric-version        Print just the version number-```--* `logdir`: The directory that contains log files to be considered. Defaults to the current directory (`./`).--* `outputdir`: The directory to write resulting graphs to. Defaults to the current directory (`./`).--* `plot`: A benchmark to plot. This is drawn from the first column of the LiquidHaskell log file and takes the form of `/intermediate/suite/container/TestFile.hs`. For each benchmark, one .svg file will be produced in the output directory.--* `plotcompare`: Two benchmarks to plot against each other. This is drawn from the first column of the LiquidHaskell log file and takes the form of `/intermediate/suite/container/TestFileLHS.hs,/some/other/suite/TestFileRHS.hs`. For each pair of benchmarks, one .svg file will be produced in the output directory.--Prerequisites----------------This program relies on a special header being present in the test suite output. This header is implemented in the master branch as of commit `29d72f62fd7f2d90574ad0d587185101ad960b23`. For any log file created prior to this commit, the following header can be prepended to the log file:--```-Epoch Timestamp: 1454554725----------------------------------------------------------------------------------```--This timestamp is required for plot-benchmarks to properly order each log. This time should be the *commiter* date of the git commit. An appropriate timestamp will be produced by git using the following command: `git show --format="%ct" --quiet`--Examples-----------* `plot-benchmarks --plot Tests/Unit/pos/PointDist.hs --plotcompare Tests/Unit/pos/vector0.hs,Tests/Unit/neg/vector0.hs`--This will produce two .svg files in the current directory: one that plots the results of `Tests/Unit/pos/PointDist.hs`, and one that plots both `Tests/Unit/pos/vector0.hs` and `Tests/Unit/neg/vector0.hs`.--* `plot-benchmarks --logdir /tmp --plot Tests/Unit/pos/PointDist.hs --outputdir /tmp/results`--This will read log data from `/tmp` and create one .svg file for `Tests/Unit/pos/PointDist.hs` in `/tmp/results`
− scripts/plot-benchmarks/Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
− scripts/plot-benchmarks/plot-benchmarks.cabal 
@@ -1,36 +0,0 @@--- Initial plot-benchmarks.cabal generated by cabal init.  For further--- documentation, see http://haskell.org/cabal/users-guide/--name:                plot-benchmarks-version:             0.2.0.0-synopsis:            Plot benchmarks in .csv format over time-license:             BSD3-license-file:        ../../LICENSE-author:              Chris Tetreault-maintainer:          ctetreau@ucsd.edu-copyright:           University of California, San Diego.-category:            Graphics-build-type:          Simple--- extra-source-files:-cabal-version:       >=1.10--executable plot-benchmarks-  main-is:             Main.hs-  -- other-modules:-  -- other-extensions:-  build-depends:       base-                     , Chart-                     , Chart-diagrams -                     , cassava-                     , bytestring -                     , vector-                     , containers -                     , time -                     , process -                     , directory -                     , unordered-containers-                     , colour -                     , cmdargs -                     , filepath -  hs-source-dirs:      src-  default-language:    Haskell2010
− scripts/plot-benchmarks/src/Benchmark.hs 
@@ -1,56 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}--module Benchmark where--import Data.Csv-import qualified Data.Map as Map-import Data.Foldable-import Data.Time.LocalTime--data Benchmark =-   Benchmark { benchName :: String,-               benchTimestamp :: LocalTime,-               benchTime :: Double,-               benchPass :: Bool-               }-   deriving (Eq)--instance Ord Benchmark where-   compare lhs rhs = compare (benchTimestamp lhs) (benchTimestamp rhs)--unionAppend :: Map.Map String [Benchmark]-               -> Map.Map String Benchmark-               -> Map.Map String [Benchmark]-unionAppend l r = Map.unionWith (++) l r'-   where-      r' = fmap (\a -> [a]) r--toBenchMap :: (Foldable f)-              => f Benchmark-              -> Map.Map String Benchmark-toBenchMap f = foldl' fn Map.empty f-   where-      fn m b = Map.insert (benchName b) b m--instance FromRecord Benchmark where-   parseRecord r = Benchmark-                   <$> r .! 0-                   <*> pure (error ("Shouldn't be evaluated until after"-                                    ++ " reassignment!"))-                   <*> r .! 1-                   <*> do asStr <- r .! 2-                          return $ read asStr {- Since the test suite-   generates this field by calling show, this read Should Be Safe (TM) -}--csvOutName = "Name"-csvOutDate = "Committer Date"-csvOutTime = "Time (Seconds)"-csvOutPass = "Success"--instance ToNamedRecord (LocalTime, Benchmark) where-   toNamedRecord (_, bm) = namedRecord [csvOutName .= benchName bm,-                                   csvOutDate .= (show $ benchTimestamp bm),-                                   csvOutTime .= (benchTime bm),-                                   csvOutPass .= (show $ benchPass bm)]
− scripts/plot-benchmarks/src/Config.hs 
@@ -1,50 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--module Config where--import System.Console.CmdArgs-import System.Directory--data OutputType =-   Svg-   | Csv-     deriving (Eq, Data, Typeable, Show)--data Config =-   Config { logDir :: FilePath,-            outputDir :: FilePath,-            outputType :: OutputType,-            plotCompare :: [(String, String)],-            plot :: [String]-          } deriving (Eq, Data, Typeable, Show)--pwd :: FilePath-pwd = "."--instance Default Config where-   def = Config { logDir = pwd,-                  outputDir = pwd,-                  outputType = Csv,-                  plotCompare = def,-                  plot = def-                }--config :: Config-config = Config-            { logDir = pwd &= help "The directory that contains the logs",-              outputDir = pwd &= help "The diretory to output graphs to",-              outputType = Csv &= help "The type of output to produce",-              plotCompare = def &= help "Pairs of benchmarks to compare",-              plot = def &= help "Benchmarks to plot"-            }-            &= program "plot-benchmarks"-            &= summary ("plot-benchmarks - Copyright 2016 Regents of"-                        ++ "the University of California.")-            &= details ["Plot LiquidHaskell benchmarks over time"]--getConfig :: IO Config-getConfig = do-   conf <- cmdArgs config-   ld <- makeAbsolute $ logDir conf-   od <- makeAbsolute $ outputDir conf-   return $ conf {logDir = ld, outputDir = od}
− scripts/plot-benchmarks/src/Main.hs 
@@ -1,30 +0,0 @@-module Main where--import Plot-import Config-import Parse--main :: IO ()-main = do-   conf <- getConfig-   case (outputType conf) of-      Csv -> do-         csvData <- getAllData-                       (logDir conf)-                       (plot conf)-         dumpLogs-            (outputDir conf)-            csvData-      Svg -> do-         timeData <- getTimeData-                        (logDir conf)-                        (plot conf)-         plotTimeData-            (outputDir conf)-            timeData-         compareTimeData <- getCompareTimeData-                               (logDir conf)-                               (plotCompare conf)-         plotCompareTimeData-            (outputDir conf)-            compareTimeData
− scripts/plot-benchmarks/src/Parse.hs 
@@ -1,80 +0,0 @@-module Parse where--import Benchmark-import Data.Csv-import Data.List-import System.Directory-import Data.Either-import qualified Data.Vector as V-import qualified Data.ByteString.Lazy.Char8 as BS-import Data.Time.Clock.POSIX-import Data.Time.LocalTime-import System.FilePath--gulpLogs :: FilePath -> IO [V.Vector Benchmark]-gulpLogs f = do-   conts <- getDirectoryContents f-   let justCsv = filter (isSuffixOf ".csv") conts-   let noHidden = filter (\a -> not (isPrefixOf "." a)) justCsv-   let toGulp = fmap (\a -> f </> a) noHidden-   logs <- sequence $ fmap parseLog toGulp-   return $ rights logs--parseLog :: FilePath -> IO (Either String (V.Vector Benchmark))-parseLog p = do-   file <- BS.readFile p-   let (hdr, csv) = splitHeader file delimiter-   timezone <- getCurrentTimeZone-   case (getEpochTime hdr) of-      Nothing -> return $ Left "missing timestamp!"-      Just ts -> case (decode HasHeader csv) of-         Right bm ->-            return $ Right $ fmap-               (\a -> a {benchTimestamp = utcToLocalTime-                                             timezone-                                             $ posixSecondsToUTCTime-                                               $ realToFrac ts})-               bm--delimiter :: String-delimiter = take 80 $ repeat '-'--getEpochTime :: [String] -> Maybe Int-getEpochTime s = do-   elm <- find (isPrefixOf "Epoch Timestamp:") s-   elm' <- stripPrefix "Epoch Timestamp:" elm-   return (read elm' :: Int)--splitHeader :: BS.ByteString -> String -> ([String], BS.ByteString)-splitHeader msg delim = (hdr, BS.pack $ unlines csv)-   where-      (hdr, csv) = let ((hdrr, csvr), _) = foldl' foldFn initAcc lns in-         (reverse hdrr, reverse csvr)-      lns = lines $ BS.unpack msg-      initAcc = (([],[]), False)-      foldFn ((ls, rs), True) e = ((ls, e:rs), True)-      foldFn ((ls, rs), False) e = if e == delim-                                      then-                                      ((ls, rs), True)-                                      else-                                      ((e:ls, rs), False)--dumpLogs :: FilePath -> [(String, [(LocalTime, Benchmark)])] -> IO ()-dumpLogs out dps = sequence_ $ fmap dumpLog dps-   where-      dumpLog :: (String, [(LocalTime, Benchmark)]) -> IO ()-      dumpLog (n, dps') = do-         let n' = specToUscore n-         let dps'' = encodeByName-                        (V.fromList [csvOutName,-                                     csvOutDate,-                                     csvOutTime,-                                     csvOutPass])-                        dps'-         BS.writeFile (out </> n' ++ ".csv") dps''-      specToUscore s = fmap mapper s-         where-            mapper c = case c of-               '/' -> '_'-               '.' -> '_'-               c' -> c'
− scripts/plot-benchmarks/src/Plot.hs 
@@ -1,161 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts #-}--module Plot where--import Benchmark-import Parse-import qualified Data.Map as Map-import Data.Foldable-import Data.List-import Graphics.Rendering.Chart.Easy-import Graphics.Rendering.Chart.Backend.Diagrams-import Data.Time.LocalTime-import Data.Colour ()-import Data.Colour.Names ()-import System.FilePath--fileOptions :: FileOptions-fileOptions = def-- (def {_fo_size = (1024, 768)} :: FileOptions)--lineColor1 :: AlphaColour Double-lineColor1 = withOpacity darkred 0.5--pointColor1 :: AlphaColour Double-pointColor1 = opaque red--lineColor2 :: AlphaColour Double-lineColor2 = withOpacity darkgreen 0.5--pointColor2 :: AlphaColour Double-pointColor2 = opaque green--plotData :: (Default r, ToRenderable r)-            => FilePath-            -> [(String, [(LocalTime, a)])]-            -> (String -> [(LocalTime, a)] -> EC r ())-            -> IO ()-plotData out dps with = sequence_ $ fmap plotDp dps-   where-      plotDp (n, dps') = do-         let n' = specToUscore n-         let options = fileOptions-         toFile options (out </> n' ++ ".svg") $ with n dps'-      specToUscore s = fmap mapper s-         where-            mapper c = case c of-               '/' -> '_'-               '.' -> '_'-               c' -> c'--plotCompareData :: (Default r, ToRenderable r)-                   => FilePath-                   -> [((String, [(LocalTime, a)]),(String, [(LocalTime, a)]))]-                   -> (String-                       -> String-                       -> ([(LocalTime, a)],[(LocalTime, a)]) -> EC r ())-                   -> IO ()-plotCompareData out dps with = sequence_ $ fmap plotDp dps-   where-      plotDp ((ln, ldps'), (rn, rdps')) = do-         let ln' = specToUscore ln-         let rn' = specToUscore rn-         let dps' = (ldps', rdps')-         let options = fileOptions-         toFile-            options-            (out </> ln' ++ "_vs_" ++ rn' ++ ".svg")-            $ with ln rn dps'-      specToUscore s = fmap mapper s-         where-            mapper c = case c of-               '/' -> '_'-               '.' -> '_'-               c' -> c'--plotCompareTimeData :: FilePath-                       -> [((String, [(LocalTime, Double)]),-                            (String, [(LocalTime, Double)]))]-                       -> IO ()-plotCompareTimeData out dps = plotCompareData out dps with-   where-      with ln rn (ldps, rdps) = do-         layoutlr_title .= ln ++ " vs. " ++ rn ++ " Times"-         setColors [lineColor1, lineColor2, pointColor1, pointColor2]-         setShapes [PointShapeCircle, PointShapeCircle]-         plotLeft $ line "" [ldps]-         plotRight $ line "" [rdps]-         plotLeft $ points ln ldps-         plotRight $ points rn rdps--plotTimeData :: FilePath -> [(String, [(LocalTime, Double)])] -> IO ()-plotTimeData out dps = plotData out dps with-   where-      with n' dps' = do-            layout_title .= n' ++ " Times"-            setColors [lineColor1, pointColor1]-            plot $ line "" [dps']-            plot $ points n' dps'--getCompareData :: ([Benchmark] -> [(LocalTime, a)])-                  -> FilePath-                  -> [(String, String)]-                  -> IO [((String, [(LocalTime, a)]),-                          (String, [(LocalTime, a)]))]-getCompareData mapper f bps = sequence $ fmap pairUp bps-   where-      pairUp (l, r) = do-         [l'] <- getData mapper f [l]-         [r'] <- getData mapper f [r]-         return (l', r')--getData :: ([Benchmark] -> [(LocalTime, a)])-                -> FilePath-                -> [String]-                -> IO [(String, [(LocalTime, a)])]-getData mapper f bs = do-   logs <- gulpLogs f-   let logMaps = fmap toBenchMap logs-   let combined = foldl' unionAppend Map.empty logMaps-   let onlyBs = Map.filterWithKey (\k _ -> k `elem` bs) combined-   let dataPs = Map.toList $ fmap mapper onlyBs-   let sorted =  fmap sortMapper dataPs-   return sorted-   where-      comparator (tsl, _) (tsr, _) = compare tsl tsr-      sortMapper (name, dps) = (name, sortBy comparator dps)--getTimeData :: FilePath -> [String] -> IO [(String, [(LocalTime, Double)])]-getTimeData = getData timeDataMapper---getCompareTimeData :: FilePath-                   -> [(String, String)]-                   -> IO [((String, [(LocalTime, Double)]),-                           (String, [(LocalTime, Double)]))]-getCompareTimeData = getCompareData timeDataMapper--timeDataMapper :: [Benchmark] -> [(LocalTime, Double)]-timeDataMapper bs' = [(benchTimestamp x, benchTime x) | x <- bs' ]----getSuccessData :: FilePath -> [String] -> IO [(String, [(LocalTime, Bool)])]-getSuccessData = getData mapper-   where-      mapper bs' = [(benchTimestamp x, benchPass x) | x <- bs' ]--plotSuccessData :: FilePath -> [(String, [(LocalTime, Bool)])] -> IO ()-plotSuccessData out dps = plotData out dps with-   where-      dps'' v = fmap (\(l, r) -> case r of-                                  True -> (l, (1 :: Integer))-                                  False -> (l, 0)) v-      with n' dps' = do-         layout_title .= n' ++ " Test Result"-         plot (line n' [dps'' dps'])--getAllData :: FilePath -> [String] -> IO [(String, [(LocalTime, Benchmark)])]-getAllData = getData mapper-   where-      mapper bs' = [(benchTimestamp x, x) | x <- bs']
− scripts/plot-benchmarks/stack.yaml 
@@ -1,11 +0,0 @@-resolver: lts-4.0--packages:-- .--extra-deps:-- Chart-diagrams-1.5.4 -- SVGFonts-1.5.0.0-- tuple-0.3.0.2-- OneTuple-0.2.1-- lucid-svg-0.5.0.0
− scripts/travis 
@@ -1,162 +0,0 @@-#!/bin/bash--set -eu-set -o pipefail--## Helper Functions--function loud {-  echo "$ $@"-  $@-}--function stack {-  $HOME/.local/bin/stack --no-terminal "$@"-}--# Source: https://github.com/travis-ci/travis-build/blob/fc4ae8a2ffa1f2b3a2f62533bbc4f8a9be19a8ae/lib/travis/build/script/templates/header.sh#L104-L123-RED="\033[31;1m"-GREEN="\033[32;1m"-RESET="\033[0m"-function travis_retry {-  local result=0-  local count=1-  while [ $count -le 3 ]; do-    [ $result -ne 0 ] && {-      echo -e "\n${RED}The command \"$@\" failed. Retrying, $count of 3.${RESET}\n" >&2-    }-    set +e-    "$@"-    result=$?-    set -e-    [ $result -eq 0 ] && break-    count=$(($count + 1))-    sleep 1-  done--  [ $count -eq 4 ] && {-    echo "\n${RED}The command \"$@\" failed 3 times.${RESET}\n" >&2-  }--  return $result-}--function prevent_timeout {-  local cmd="$@"--  $cmd &-  local cmd_pid=$!--  poke_stdout &-  local poke_pid=$!--  wait $cmd_pid-  exit_code=$?--  kill $poke_pid-  (wait $poke_pid 2>/dev/null) || true--  return $exit_code-}--function poke_stdout {-  # Print an invisible character every minute-  while true; do-    echo -ne "\xE2\x80\x8B"-    sleep 60-  done-}--function pastebin {-  curl -s -F 'clbin=<-' https://clbin.com-}--## Setup Stages--function install_smt {-  local smt="$1"--  mkdir -p "${HOME}/.local/bin"-  loud curl "http://goto.ucsd.edu/~gridaphobe/$smt" -o "${HOME}/.local/bin/$smt"-  loud chmod a+x "${HOME}/.local/bin/$smt"-}--function install_stack {-  local stack_version="$1"--  mkdir -p "${HOME}/.local/bin"-  mkdir -p '/tmp/stack'--  pushd '/tmp/stack'--  local dir_name="stack-${stack_version}-x86_64-linux"-  local archive_name="${dir_name}.tar.gz"-  local stack_url="https://github.com/commercialhaskell/stack/releases/download/v${stack_version}/${archive_name}"--  loud wget "${stack_url}"-  loud tar -xzvf "./${archive_name}"-  loud cp "./${dir_name}/stack" "${HOME}/.local/bin/stack"-  loud chmod a+x "${HOME}/.local/bin/stack"--  popd-}--function configure_stack {-  local ghc_version="$1"--  echo "Configuring stack.yaml for ${ghc_version}..."--  cat << EOF > 'stack.yaml'-resolver: ${ghc_version}--packages:-- ./liquid-fixpoint-- .-EOF--  loud cat stack.yaml-}--function setup_ghc {-  loud stack setup-  loud stack ghc -- --version-}--function install_dependencies {-  echo "Solving dependency constraints..."-  loud stack update-  loud stack solver --update-config--  echo "Installing dependencies..."-  loud stack build liquidhaskell --only-dependencies --test --no-run-tests --no-haddock-deps-}--## Building & Testing Stages--function do_build {-  loud stack build liquidhaskell --test --no-run-tests --haddock --no-haddock-deps --flag liquidhaskell:devel-}--function do_test {-  local tests="$1"-  local smt="$2"--  local test_runner="$(stack path --dist-dir)/build/test/test"--  loud prevent_timeout stack exec -- "${test_runner}" --pattern "$tests/" --smtsolver "$smt" -j2 +RTS -N2 -RTS-}--function dump_fail_logs {-  find tests/logs/cur -type f -name '*log.fail' -print0 | while IFS= read -r -d $'\0' file; do-    echo "${file}:"-    echo "    $(pastebin < "${file}")"-  done-}--## Run Test Stage--stage="$1"-shift--$stage "$@"-
− src/Gradual.hs 
@@ -1,86 +0,0 @@-{-# LANGUAGE TupleSections #-}---- module Main where--import Language.Haskell.Liquid.Liquid (liquidConstraints)--import Language.Haskell.Liquid.Types (GhcInfo(..), Cinfo)-import Language.Haskell.Liquid.Constraint.Types (CGInfo(..)) -- , FixWfC, SubC(..), CGEnv(..))-import Language.Haskell.Liquid.UX.Config (Config(..))-import Language.Haskell.Liquid.UX.CmdLine (getOpts)-import Language.Haskell.Liquid.Constraint.ToFixpoint (cgInfoFInfo, fixConfig)--import qualified Language.Fixpoint.Types as F-import qualified Language.Fixpoint.Types.Config as F-import           Language.Fixpoint.Solver       (simplifyFInfo)-import           Language.Fixpoint.Solver.Solve (solve)-import qualified Language.Fixpoint.Solver.GradualSolution as GS-import           Language.Fixpoint.Misc         (mapSnd)-import           Language.Fixpoint.Graph.Partition (partition')--import System.Exit                    (exitWith, exitSuccess, exitFailure)-import System.Environment             (getArgs)-import System.Console.CmdArgs.Verbosity-import Control.Monad (when)--import qualified Data.List as L--import Gradual.Concretize-import Gradual.Types-import Gradual.Misc (mapSndM, mapMWithLog)-import Gradual.Uniquify-import Gradual.Refinements-import Gradual.PrettyPrinting-import qualified Gradual.GUI as GUI-import qualified Gradual.Trivial as T--main :: IO a-main = do-  cfg <- getArgs >>= getOpts-  css <- quietly $ liquidConstraints (cfg{gradual=True})-  case css of-    Left cgis -> mapM (runGradual (cfg{gradual=True})) cgis >> exitSuccess-    Right e   -> exitWith e---runGradual :: Config -> CGInfo -> IO [(GSub F.GWInfo,F.Result (Integer, Cinfo))]-runGradual cfg cgi = do-  let fname    = target (ghcI cgi)-  let fcfg     = fixConfig fname cfg-  finfo       <- quietly $ cgInfoFInfo (ghcI cgi) cgi-  sinfo <- (uniquify . T.simplify) <$> (quietly $ simplifyFInfo fcfg finfo)-  let (gsis, sis) = L.partition F.isGradual $ partition' Nothing (snd sinfo)-  let gcfg     = (makeGConfig cfg) {pNumber = length gsis}-  sol <- mconcat <$> (quietly $ mapM (solve fcfg) sis)-  let gcfgs = setPId gcfg <$> [1..(length gsis)]-  when (not $ F.isSafe sol) $ do-    putStrLn "The static part cannot be satisfied: UNSAFE"-    exitFailure-  whenLoud $ putStrLn ("\nNumber of Gradual Partitions : " ++ show (length gsis) ++"\n")-  solss <- mapMWithLog "Running Partition" (uncurry $ solveSInfo fcfg) (zip gcfgs gsis)-  GUI.render gcfg (fst sinfo) solss-  exitSuccess----solveSInfo :: F.Config  -> GConfig -> F.SInfo Cinfo -> IO [GSub F.GWInfo]-solveSInfo fcfg gcfg sinfo = do-  gmap     <- makeGMap gcfg fcfg sinfo $ GS.init fcfg sinfo-  let allgs = concretize gmap sinfo-  putStrLn ("Total number of concretizations: " ++ show (length $ map snd allgs))-  res   <- quietly $ mapM (mapSndM (solve fcfg)) allgs-  case filter (F.isSafe . snd) res of-    (x:xs) -> do putStrLn ( "["++ show (1 + length xs) ++ "/" ++ (show $ length res) ++ "] Solutions Found!" ++ if length xs > 0 then " e.g.," else "")-                 putStrLn (pretty $ (map (mapSnd snd) $ fromGSub $ fst x))-                 return (fst <$> (x:xs))-    _     -> do putStrLn ("[0/" ++ (show $ length res) ++ "] Solutions. UNSAFE!\n")-                whenLoud $ putStrLn ("UNSAFE PARTITION: " ++ show sinfo)-                return [mempty]--quietly :: IO a -> IO a-quietly act = do-  vb <- getVerbosity-  setVerbosity Quiet-  r  <- act-  setVerbosity vb-  return r
− src/Gradual/GUI/Names.hs 
@@ -1,4 +0,0 @@-module Gradual.GUI.Names where--buttonPrefix :: String -buttonPrefix = "button-"
− src/Gradual/GUI/Render.hs 
src/Gradual/Uniquify.hs view
@@ -31,7 +31,7 @@ import Gradual.Types (GSpan)  ---------------------------------------------------------------------------------- |  Make each gradual appearence unique -------------------------------------+-- |  Make each gradual appearance unique ------------------------------------- -------------------------------------------------------------------------------  uniquify :: (NFData a, Fixpoint a, Loc a) => SInfo a -> (GSpan, SInfo a)@@ -143,7 +143,7 @@   setChange   cached <- cache <$> get   case M.lookup k cached of-    {- OPTIMIZATION: Only create one fresh occurence of ? per constraint environment. -}+    {- OPTIMIZATION: Only create one fresh occurrence of ? per constraint environment. -}     Just k' -> return  k'     Nothing -> freshK'' k 
− src/LHi.hs 
@@ -1,35 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}--import           System.Environment      (getArgs)-import           System.Daemon-import           Control.Concurrent.MVar ( newMVar )-import           Data.Default ( def )-import           Language.Haskell.Liquid.Interactive.Types-import qualified Language.Haskell.Liquid.Interactive.Handler as H-import           Language.Haskell.Liquid.UX.CmdLine (getOpts)-import           Language.Haskell.Liquid.UX.Config  (port)--daemonName :: String-daemonName = "lhi0"--main :: IO ()-main = do-  st  <- newMVar H.initial-  cmd <- command-  ensureDaemonRunning daemonName (options cmd) (H.handler st)-  res <- client cmd-  print res--options :: Command -> DaemonOptions-options cmd = def { daemonPort = port cmd }--client :: Command -> IO (Maybe Response)-client cmd = runClient "localhost" (port cmd) cmd-------------------------------------------------------------------------------------- | Parsing Command Line ------------------------------------------------------------------------------------------------------------------------------------------command :: IO Command---------------------------------------------------------------------------------command = getOpts =<< getArgs
src/Language/Haskell/Liquid/Bare.hs view
@@ -8,20 +8,22 @@  -- | This module contains the functions that convert /from/ descriptions of --   symbols, names and types (over freshly parsed /bare/ Strings),---   /to/ representations connected to GHC vars, names, and types.+--   /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`+--   in 'RefType' -- they are different instances of 'RType'.  module Language.Haskell.Liquid.Bare (-    GhcSpec(..)-  , makeGhcSpec+  -- * Creating a TargetSpec+  -- $creatingTargetSpecs+    makeTargetSpec -  -- * Lifted Spec+  -- * Loading and Saving lifted specs from/to disk   , loadLiftedSpec   , saveLiftedSpec   ) where  import           Prelude                                    hiding (error)+import           Optics import           Control.Monad                              (unless) import qualified Control.Exception                          as Ex import qualified Data.Binary                                as B@@ -30,15 +32,17 @@ 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             +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 Language.Haskell.Liquid.GHC.Misc           as GM import qualified Language.Haskell.Liquid.GHC.API            as Ghc +import           Language.Haskell.Liquid.GHC.Types          (StableName) import           Language.Haskell.Liquid.Types import           Language.Haskell.Liquid.WiredIn import qualified Language.Haskell.Liquid.Measure            as Ms@@ -57,7 +61,7 @@ import           Control.Arrow                    (second)  ----------------------------------------------------------------------------------- | De/Serializing Spec files -------------------------------------------------+-- | De/Serializing Spec files --------------------------------------------------------------------------------  loadLiftedSpec :: Config -> FilePath -> IO (Maybe Ms.BareSpec)@@ -82,45 +86,102 @@ errMissingSpec srcF specF = ErrNoSpec Ghc.noSrcSpan (text srcF) (text specF)  -- saveLiftedSpec :: FilePath -> ModName -> Ms.BareSpec -> IO ()-saveLiftedSpec :: GhcSrc -> GhcSpec -> IO () -saveLiftedSpec src sp = do+saveLiftedSpec :: FilePath -> Ms.BareSpec -> IO () +saveLiftedSpec srcF lspec = do   ensurePath specF   B.encodeFile specF lspec   -- print (errorP "DIE" "HERE" :: String)    where-    srcF  = giTarget src -    lspec = gsLSpec  sp      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+               -> Either Diagnostics ([Warning], TargetSpec, LiftedSpec)+makeTargetSpec cfg lmap targetSrc bareSpec dependencies = do+  let depsDiagnostics     = mapM (uncurry Bare.checkBareSpec) legacyDependencies+  let bareSpecDiagnostics = Bare.checkBareSpec (giTargetMod targetSrc) legacyBareSpec+  case depsDiagnostics >> bareSpecDiagnostics of+   Left d | noErrors d -> secondPhase (allWarnings d)+   Left d              -> Left  d+   Right ()            -> secondPhase mempty+  where+    secondPhase :: [Warning] -> Either Diagnostics ([Warning], TargetSpec, LiftedSpec)+    secondPhase phaseOneWarns = do+      (warns, ghcSpec) <- makeGhcSpec cfg (review targetSrcIso targetSrc) lmap (allSpecs legacyBareSpec)+      let (targetSpec, liftedSpec) = view targetSpecGetter ghcSpec+      pure (phaseOneWarns <> warns, targetSpec, liftedSpec)++    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 . 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@ invokes @makeGhcSpec0@ to construct the @GhcSpec@ and then+--   validates it using @checkGhcSpec@. --------------------------------------------------------------------------------------makeGhcSpec :: Config -> GhcSrc ->  LogicMap -> [(ModName, Ms.BareSpec)] -> GhcSpec+makeGhcSpec :: Config+            -> GhcSrc+            -> LogicMap+            -> [(ModName, Ms.BareSpec)]+            -> Either Diagnostics ([Warning], GhcSpec) --------------------------------------------------------------------------------------makeGhcSpec cfg src lmap mspecs0  -           = checkThrow (Bare.checkGhcSpec mspecs src renv cbs sp)-  where -    mspecs =  [ (m, checkThrow $ Bare.checkBareSpec m sp) | (m, sp) <- mspecs0, isTarget m ] -           ++ [ (m, sp) | (m, sp) <- mspecs0, not (isTarget m)]-    sp     = makeGhcSpec0 cfg src lmap mspecs -    renv   = ghcSpecEnv sp -    cbs    = giCbs src--checkThrow :: Ex.Exception e => Either e c -> c-checkThrow = either Ex.throw id +makeGhcSpec cfg src lmap validatedSpecs = do+  case diagnostics of+    Left e | noErrors e -> pure (allWarnings e, sp)+    Left e              -> Left e+    Right ()            -> pure (mempty, sp)+  where+    diagnostics = Bare.checkTargetSpec (map snd validatedSpecs)+                                       (view targetSrcIso src)+                                       renv+                                       cbs+                                       (fst . view targetSpecGetter $ sp)+    sp          = makeGhcSpec0 cfg src lmap validatedSpecs+    renv        = ghcSpecEnv sp+    cbs         = _giCbs src  ghcSpecEnv :: GhcSpec -> SEnv SortedReft ghcSpecEnv sp = fromListSEnv binds   where-    emb       = gsTcEmbeds (gsName sp)+    emb       = gsTcEmbeds (_gsName sp)     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,        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       ]+                 , [(x, RR s mempty)    | (x, s)         <- _gsImps sp       ]                  ]     vSort     = Bare.varSortedReft emb     rSort     = rTypeSortedReft    emb@@ -136,36 +197,51 @@ makeGhcSpec0 :: Config -> GhcSrc ->  LogicMap -> [(ModName, Ms.BareSpec)] -> GhcSpec ------------------------------------------------------------------------------------- makeGhcSpec0 cfg src lmap mspecs = SP -  { gsConfig = cfg -  , gsImps   = makeImports mspecs-  , gsSig    = addReflSigs refl sig -  , gsRefl   = refl -  , gsLaws   = laws -  , gsData   = sData -  , gsQual   = qual -  , gsName   = makeSpecName env     tycEnv measEnv   name -  , gsVars   = makeSpecVars cfg src mySpec env measEnv-  , gsTerm   = makeSpecTerm cfg     mySpec env       name    -  , gsLSpec  = makeLiftedSpec   src env refl sData sig qual myRTE lSpec1 {-                   impSigs   = makeImports mspecs,-                   expSigs   = [ (F.symbol v, F.sr_sort $ Bare.varSortedReft embs v) | v <- gsReflects refl ],-                   dataDecls = dataDecls mySpec2 -                   } +  { _gsConfig = cfg +  , _gsImps   = makeImports mspecs+  , _gsSig    = addReflSigs refl sig +  , _gsRefl   = refl +  , _gsLaws   = laws +  , _gsData   = sData +  , _gsQual   = qual +  , _gsName   = makeSpecName env     tycEnv measEnv   name +  , _gsVars   = makeSpecVars cfg src mySpec env measEnv+  , _gsTerm   = makeSpecTerm cfg     mySpec env       name    +  , _gsLSpec  = finalLiftedSpec+              { impSigs   = makeImports mspecs+              , expSigs   = [ (F.symbol v, F.sr_sort $ Bare.varSortedReft embs v) | v <- gsReflects refl ]+              , dataDecls = dataDecls mySpec2+              , 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+    finalLiftedSpec = makeLiftedSpec src env refl sData sig qual myRTE lSpec1     -- build up spec components      myRTE    = myRTEnv       src env sigEnv rtEnv       qual     = makeSpecQual cfg env tycEnv measEnv rtEnv specs      sData    = makeSpecData  src env sigEnv measEnv sig specs -    refl     = makeSpecRefl  src measEnv specs env name sig tycEnv +    refl     = makeSpecRefl  cfg src measEnv specs env name sig tycEnv      laws     = makeSpecLaws env sigEnv (gsTySigs sig ++ gsAsmSigs sig) measEnv specs -    sig      = makeSpecSig cfg name specs env sigEnv   tycEnv measEnv (giCbs src)+    sig      = makeSpecSig cfg name specs env sigEnv   tycEnv measEnv (_giCbs src)     measEnv  = makeMeasEnv      env tycEnv sigEnv       specs      -- build up environments     specs    = M.insert name mySpec iSpecs2     mySpec   = mySpec2 <> lSpec1      lSpec1   = lSpec0 <> makeLiftedSpec1 cfg src tycEnv lmap mySpec1 -    sigEnv   = makeSigEnv  embs tyi (gsExports src) rtEnv +    sigEnv   = makeSigEnv  embs tyi (_gsExports src) rtEnv      tyi      = Bare.tcTyConMap   tycEnv      tycEnv   = makeTycEnv   cfg name env embs mySpec2 iSpecs2      mySpec2  = Bare.qualifyExpand env name rtEnv l [] mySpec1    where l = F.dummyPos "expand-mySpec2"@@ -178,7 +254,7 @@     env      = Bare.makeEnv cfg src lmap mspecs       (mySpec0, iSpecs0) = splitSpecs name mspecs      -- check barespecs -    name     = F.notracepp ("ALL-SPECS" ++ zzz) $ giTargetMod  src +    name     = F.notracepp ("ALL-SPECS" ++ zzz) $ _giTargetMod  src      zzz      = F.showpp (fst <$> mspecs)  splitSpecs :: ModName -> [(ModName, Ms.BareSpec)] -> (Ms.BareSpec, Bare.ModSpecs) @@ -196,7 +272,7 @@  makeEmbeds :: GhcSrc -> Bare.Env -> [(ModName, Ms.BareSpec)] -> F.TCEmb Ghc.TyCon  makeEmbeds src env -  = Bare.addClassEmbeds (gsCls src) (gsFiTcs src) +  = Bare.addClassEmbeds (_gsCls src) (_gsFiTcs src)    . mconcat    . map (makeTyConEmbeds env) @@ -240,12 +316,20 @@   { Ms.ealiases  = lmapEAlias . snd <$> Bare.makeHaskellInlines 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)+    tcs          = uniqNub (_gsTcs src ++ refTcs)     refTcs       = reflectedTyCons cfg embs cbs  mySpec-    cbs          = giCbs       src-    name         = giTargetMod src+    cbs          = _giCbs       src+    name         = _giTargetMod src  uniqNub :: (Ghc.Uniquable a) => [a] -> [a] uniqNub xs = M.elems $ M.fromList [ (index x, x) | x <- xs ]@@ -293,7 +377,7 @@   , gsLvars      = S.map (Bare.lookupGhcVar env name "gs-lvars"  ) (Ms.lvars   mySpec)   , gsCMethods   = snd3 <$> Bare.meMethods measEnv    }-  where name     = giTargetMod src +  where name     = _giTargetMod src   qualifySymbolic :: (F.Symbolic a) => ModName -> a -> F.Symbol  qualifySymbolic name s = GM.qualifySymbol (F.symbol name) (F.symbol s)@@ -371,6 +455,7 @@ ------------------------------------------------------------------------------------------ makeSpecTerm cfg mySpec env name = SpTerm    { gsLazy       = S.insert dictionaryVar (lazies `mappend` sizes)+  , gsFail       = makeFail     env name mySpec    , gsStTerm     = sizes   , gsAutosize   = autos    , gsDecr       = makeDecrs env name mySpec@@ -395,6 +480,20 @@ makeLazy env name spec =    S.map (Bare.lookupGhcVar env name "Var") (Ms.lazy spec) +makeFail :: Bare.Env -> ModName -> Ms.BareSpec -> S.HashSet (Located Ghc.Var)+makeFail env name spec = +  S.map (\x -> x{ val = Bare.lookupGhcVar env name "Var" x}) (Ms.fails spec)++makeRewrite :: Bare.Env -> ModName -> Ms.BareSpec -> S.HashSet (Located Ghc.Var)+makeRewrite env name spec = +  S.map (\x -> x{ val = Bare.lookupGhcVar env name "Var" x}) (Ms.rewrites spec)++makeRewriteWith :: Bare.Env -> ModName -> Ms.BareSpec -> M.HashMap Ghc.Var [Ghc.Var]+makeRewriteWith env name spec = +  M.fromList [ (lu x, lu <$> xs) | (x,xs) <- M.toList $ Ms.rewriteWith spec]+    where lu = Bare.lookupGhcVar env name "Var"  ++ makeAutoSize :: Bare.Env -> ModName -> Ms.BareSpec -> S.HashSet Ghc.TyCon makeAutoSize env name spec =   S.map (Bare.lookupGhcTyCon env name "TyCon") (Ms.autosize spec) @@ -421,25 +520,30 @@   }  -------------------------------------------------------------------------------------------makeSpecRefl :: GhcSrc -> Bare.MeasEnv -> Bare.ModSpecs -> Bare.Env -> ModName -> GhcSpecSig -> Bare.TycEnv +makeSpecRefl :: Config -> GhcSrc -> Bare.MeasEnv -> Bare.ModSpecs -> Bare.Env -> ModName -> GhcSpecSig -> Bare.TycEnv               -> GhcSpecRefl  -------------------------------------------------------------------------------------------makeSpecRefl src menv specs env name sig tycEnv = SpRefl +makeSpecRefl cfg src menv specs env name sig tycEnv = SpRefl    { gsLogicMap   = lmap    , gsAutoInst   = makeAutoInst env name mySpec    , gsImpAxioms  = concatMap (Ms.axeqs . snd) (M.toList specs)   , gsMyAxioms   = F.notracepp "gsMyAxioms" myAxioms -  , gsReflects   = F.notracepp "gsReflects" (lawMethods ++ filter (isReflectVar rflSyms) sigVars)+  , gsReflects   = F.notracepp "gsReflects" (lawMethods ++ filter (isReflectVar rflSyms) sigVars ++ wReflects)   , gsHAxioms    = F.notracepp "gsHAxioms" xtes +  , gsWiredReft  = wReflects+  , gsRewrites   = makeRewrite env name mySpec+  , gsRewritesWith = makeRewriteWith env name mySpec   }   where+    wReflects    = Bare.wiredReflects cfg env name sig     lawMethods   = F.notracepp "Law Methods" $ concatMap Ghc.classMethods (fst <$> Bare.meCLaws menv)      mySpec       = M.lookupDefault mempty name specs -    xtes         = Bare.makeHaskellAxioms src env tycEnv name lmap sig mySpec+    xtes         = Bare.makeHaskellAxioms cfg src env tycEnv name lmap sig mySpec     myAxioms     = [ Bare.qualifyTop env name (F.loc lt) (e {eqName = symbol x}) | (x, lt, e) <- xtes]       rflSyms      = S.fromList (getReflects specs)     sigVars      = F.notracepp "SIGVARS" $ (fst3 <$> xtes)            -- reflects                                         ++ (fst  <$> gsAsmSigs sig)   -- assumes+                                        ++ (fst  <$> gsRefSigs sig)                                       -- ++ (fst  <$> gsTySigs  sig)   -- measures       lmap         = Bare.reLMap env@@ -460,9 +564,12 @@ ------------------------------------------------------------------------------------------ addReflSigs :: GhcSpecRefl -> GhcSpecSig -> GhcSpecSig -------------------------------------------------------------------------------------------addReflSigs refl sig = sig { gsAsmSigs = reflSigs ++ gsAsmSigs sig }+addReflSigs refl sig = sig { gsRefSigs = reflSigs, gsAsmSigs = wreflSigs ++ filter notReflected (gsAsmSigs sig) }   where -    reflSigs         = [ (x, t) | (x, t, _) <- gsHAxioms refl ]   +    (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 -> M.HashMap Ghc.Var (Maybe Int) makeAutoInst env name spec = Misc.hashMapMapKeys (Bare.lookupGhcVar env name "Var") (Ms.autois spec)@@ -474,6 +581,7 @@ makeSpecSig cfg name specs env sigEnv tycEnv measEnv cbs = SpSig    { gsTySigs   = F.notracepp "gsTySigs"  tySigs    , gsAsmSigs  = F.notracepp "gsAsmSigs" asmSigs+  , gsRefSigs  = []    , gsDicts    = dicts    , gsMethods  = if noclasscheck cfg then [] else Bare.makeMethodTypes dicts (Bare.meClasses  measEnv) cbs    , gsInSigs   = mempty -- TODO-REBARE :: ![(Var, LocSpecType)]  @@ -486,7 +594,7 @@     asmSigs    = Bare.tcSelVars tycEnv                ++ makeAsmSigs env sigEnv name specs                ++ [ (x,t) | (_, x, t) <- concat $ map snd (Bare.meCLaws measEnv)]-    tySigs     = strengthenSigs . concat $+    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 @@ -664,7 +772,7 @@     goOne (x, RIAssumed t) = Just (fmap (F.symbol . (".$c" ++ ) . F.symbolString) x, t)     goOne (_, RISig _)     = Nothing -makeSigEnv :: F.TCEmb Ghc.TyCon -> Bare.TyConMap -> Ghc.NameSet -> BareRTEnv -> Bare.SigEnv +makeSigEnv :: F.TCEmb Ghc.TyCon -> Bare.TyConMap -> S.HashSet StableName -> BareRTEnv -> Bare.SigEnv  makeSigEnv embs tyi exports rtEnv = Bare.SigEnv   { sigEmbs     = embs    , sigTyRTyMap = tyi @@ -717,11 +825,11 @@     ms1          = M.elems (Ms.measMap measuresSp)     ms2          =          Ms.imeas   measuresSp     mySpec       = M.lookupDefault mempty name specs-    name         = giTargetMod      src+    name         = _giTargetMod      src     (minvs,usI)  = makeMeasureInvariants env name sig mySpec     invs         = minvs ++ concat (makeInvariants env sigEnv <$> M.toList specs) -makeIAliases :: Bare.Env -> Bare.SigEnv -> (ModName, BareSpec) -> [(LocSpecType, LocSpecType)]+makeIAliases :: Bare.Env -> Bare.SigEnv -> (ModName, Ms.BareSpec) -> [(LocSpecType, LocSpecType)] makeIAliases env sigEnv (name, spec)   = [ z | Right z <- mkIA <$> Ms.ialiases spec ]   where @@ -773,7 +881,7 @@     isSimpleADT _               = False   mkInvariant :: LocSymbol -> Symbol -> SpecType -> SpecType -> SpecType-mkInvariant x z t tr = strengthen (top <$> t) (MkUReft reft mempty mempty)+mkInvariant x z t tr = strengthen (top <$> t) (MkUReft reft mempty)       where         reft  = Mb.maybe mempty Reft mreft         mreft = mkReft x z t tr @@ -806,7 +914,7 @@   where      datacons, cls :: [DataConP]     datacons   = Bare.tcDataCons tycEnv -    cls        = F.tracepp "meClasses" $ Bare.meClasses measEnv +    cls        = F.notracepp "meClasses" $ Bare.meClasses measEnv      tycons     = Bare.tcTyCons   tycEnv   @@ -840,7 +948,7 @@     dm            = Bare.dataConMap adts     dcSelectors   = concatMap (Bare.makeMeasureSelectors cfg dm) datacons     recSelectors  = Bare.makeRecordSelectorSigs env myName       datacons-    fiTcs         = gsFiTcs (Bare.reSrc env)+    fiTcs         = _gsFiTcs (Bare.reSrc env)     knownWiredDataCons :: Bare.Env -> ModName -> [Located DataConP]  knownWiredDataCons env name = filter isKnown wiredDataCons @@ -883,7 +991,7 @@     name          = Bare.tcName        tycEnv     dms           = Bare.makeDefaultMethods env mts       (cls, mts)    = Bare.makeClasses        env sigEnv name specs-    laws          = F.notracepp "LAWS" $ Bare.makeCLaws env sigEnv name specs+    laws          = Bare.makeCLaws env sigEnv name specs  ----------------------------------------------------------------------------------------- -- | @makeLiftedSpec@ is used to generate the BareSpec object that should be serialized @@ -908,19 +1016,33 @@   , Ms.qualifiers = filter (isLocInFile srcF) (gsQualifiers qual)   }   where-    mkSigs xts    = [ toBare (x, t) | (x, t) <- xts,  S.member x sigVars && (isExportedVar src 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]+    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 +    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 == (locFile lx) +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 @@ -943,8 +1065,8 @@     tAs                      = myAliases typeAliases      eAs                      = myAliases exprAliases      myAliases fld            = filter (isLocInFile srcF) . M.elems . fld $ rtEnv -    srcF                     = giTarget    src-    name                     = giTargetMod src+    srcF                     = _giTarget    src+    name                     = _giTargetMod src    mkRTE :: [Located (RTAlias x a)] -> [Located (RTAlias F.Symbol F.Expr)] -> RTEnv x a  mkRTE tAs eAs   = RTE @@ -955,7 +1077,7 @@  normalizeBareAlias :: Bare.Env -> Bare.SigEnv -> ModName -> Located BareRTAlias                     -> Located BareRTAlias -normalizeBareAlias env sigEnv name lx = fixRTA <$> lx +normalizeBareAlias env sigEnv name lx = fixRTA <$> lx   where      fixRTA  :: BareRTAlias -> BareRTAlias      fixRTA  = mapRTAVars fixArg . fmap fixBody 
src/Language/Haskell/Liquid/Bare/Axiom.hs view
@@ -6,7 +6,7 @@ -- | This module contains the code that DOES reflection; i.e. converts Haskell --   definitions into refinements. -module Language.Haskell.Liquid.Bare.Axiom ( makeHaskellAxioms ) where+module Language.Haskell.Liquid.Bare.Axiom ( makeHaskellAxioms, wiredReflects ) where  import Prelude hiding (error) import Prelude hiding (mapM)@@ -23,6 +23,7 @@ import qualified Language.Haskell.Liquid.Measure as Ms import qualified Language.Fixpoint.Types as F import qualified Language.Haskell.Liquid.GHC.API as Ghc +import qualified Language.Haskell.Liquid.GHC.Misc as GM  import           Language.Haskell.Liquid.Types.RefType import           Language.Haskell.Liquid.Transforms.CoreToLogic import           Language.Haskell.Liquid.GHC.Misc@@ -31,14 +32,17 @@ import           Language.Haskell.Liquid.Bare.Resolve as Bare import           Language.Haskell.Liquid.Bare.Types   as Bare ++import IdInfo+import BasicTypes+ ------------------------------------------------------------------------------------------------makeHaskellAxioms :: GhcSrc -> Bare.Env -> Bare.TycEnv -> ModName -> LogicMap -> GhcSpecSig -> Ms.BareSpec +makeHaskellAxioms :: Config -> GhcSrc -> Bare.Env -> Bare.TycEnv -> ModName -> LogicMap -> GhcSpecSig -> Ms.BareSpec                    -> [(Ghc.Var, LocSpecType, F.Equation)] ------------------------------------------------------------------------------------------------makeHaskellAxioms src env tycEnv name lmap spSig +makeHaskellAxioms cfg src env tycEnv name lmap spSig spec    = fmap (makeAxiom env tycEnv name lmap) -  . getReflectDefs src spSig-+         (wiredDefs cfg env name spSig ++ getReflectDefs src spSig spec)   getReflectDefs :: GhcSrc -> GhcSpecSig -> Ms.BareSpec                 -> [(LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr)]@@ -46,7 +50,7 @@   where     sigs                    = gsTySigs sig      xs                      = S.toList (Ms.reflects spec)-    cbs                     = giCbs src+    cbs                     = _giCbs src  findVarDefType :: [Ghc.CoreBind] -> [(Ghc.Var, LocSpecType)] -> LocSymbol                -> (LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr)@@ -79,18 +83,19 @@ makeAssumeType tce lmap dm x mbT v def   = (x {val = aty at `strengthenRes` F.subst su ref},  F.mkEquation (val x) xts (F.subst su le) out)   where-    t     = Mb.fromMaybe (ofType $ Ghc.varType v) mbT+    t     = Mb.fromMaybe (ofType τ) mbT+    τ     = Ghc.varType v     at    = axiomType x t     out   = rTypeSort tce $ ares at      xArgs = (F.EVar . fst) <$> aargs at     _msg  = unwords [showpp x, showpp mbT]-    le    = case runToLogicWithBoolBinds bbs tce lmap dm mkErr (coreToLogic def') of+    le    = case runToLogicWithBoolBinds bbs tce lmap dm mkErr (coreToLogic  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 x) (pprint $ val x) (PJ.text s)     bbs        = filter isBoolBind xs-    (xs, def') = grabBody (normalize def)+    (xs, def') = grabBody (Ghc.expandTypeSynonyms τ) $ normalize def     su         = F.mkSubst  $ zip (F.symbol     <$> xs) xArgs                            ++ zip (simplesymbol <$> xs) xArgs     xts        = [(F.symbol x, rTypeSortExp tce t) | (x, t) <- aargs at]@@ -98,18 +103,36 @@ rTypeSortExp :: F.TCEmb Ghc.TyCon -> SpecType -> F.Sort rTypeSortExp tce = typeSort tce . Ghc.expandTypeSynonyms . toType -grabBody :: Ghc.CoreExpr -> ([Ghc.Var], Ghc.CoreExpr)-grabBody (Ghc.Lam x e)  = (x:xs, e') where (xs, e') = grabBody e-grabBody (Ghc.Tick _ e) = grabBody e-grabBody e              = ([], e)+grabBody :: Ghc.Type -> Ghc.CoreExpr -> ([Ghc.Var], Ghc.CoreExpr)+grabBody (Ghc.ForAllTy _ t) e +  = grabBody t e +grabBody (Ghc.FunTy { Ghc.ft_arg = tx, Ghc.ft_res = t}) e | Ghc.isClassPred tx +  = grabBody t e +grabBody (Ghc.FunTy { Ghc.ft_res = t}) (Ghc.Lam x e) +  = (x:xs, e') where (xs, e') = grabBody t e+grabBody t (Ghc.Tick _ e) +  = grabBody t e+grabBody t@(Ghc.FunTy {}) e               +  = (txs++xs, e') +   where (ts,tr)  = splitFun t +         (xs, e') = grabBody tr (foldl Ghc.App e (Ghc.Var <$> txs))+         txs      = [ stringVar ("ls" ++ show i) t |  (t,i) <- zip ts [1..]]+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 t r = go t    where -    go (RAllT a t)     = RAllT a $ go t +    go (RAllT a t r)   = RAllT a (go t) r       go (RAllP p t)     = RAllP p $ go t     go (RFun x tx t r) = RFun x tx (go t) r      go t               =  t `strengthen` F.ofReft r @@ -153,7 +176,7 @@ axiomType s t = AT to (reverse xts) res     where     (to, (_,xts, Just res)) = runState (go t) (1,[], Nothing)-    go (RAllT a t) = RAllT a <$> go t+    go (RAllT a t r) = RAllT a <$> go t <*> return r      go (RAllP p t) = RAllP p <$> go t      go (RFun x tx t r) | isClassType tx = (\t' -> RFun x tx t' r) <$> go t     go (RFun x tx t r) = do @@ -163,7 +186,7 @@       t' <- go t        return $ RFun x' tx t' r      go t = do -      (i,bs,res) <- get +      (i,bs,_) <- get        let ys = reverse $ map fst bs       let t' = strengthen t (singletonApp s ys)       put (i, bs, Just t')@@ -175,6 +198,61 @@   | otherwise          = F.symbol ("lq" ++ show i)  singletonApp :: F.Symbolic a => LocSymbol -> [a] -> UReft F.Reft-singletonApp s ys = MkUReft r mempty mempty+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 +              -> [Ghc.Var]+wiredReflects cfg env name sigs = [v | (_, _, v, _) <- wiredDefs cfg env name sigs ]+++wiredDefs :: Config -> Bare.Env -> ModName -> GhcSpecSig +          -> [(LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr)]+wiredDefs cfg env name spSig+  | reflection cfg +  = [ functionCompositionDef ]+  | otherwise+  = []+  where +    functionCompositionDef = (x, fmap F.val $ lookup v (gsTySigs spSig), v, makeCompositionExpression v)+    x = F.dummyLoc functionComposisionSymbol+    v = Bare.lookupGhcVar env name "wiredAxioms" x++-------------------------------------------------------------------------------+-- | Expression Definitions of Prelude Functions ------------------------------+-- | NV: Currently Just Hacking Composition       -----------------------------+-------------------------------------------------------------------------------+++makeCompositionExpression :: Ghc.Id -> Ghc.CoreExpr +makeCompositionExpression x +  =  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 x ++ +      "\n realIdUnfolding = " ++ GM.showPpr (Ghc.realIdUnfolding x) ++ +      "\n maybeUnfoldingTemplate . realIdUnfolding = " ++ GM.showPpr (Ghc.maybeUnfoldingTemplate $ Ghc.realIdUnfolding x ) ++ +      "\n inl_src . inlinePragInfo . Ghc.idInfo = "    ++ GM.showPpr (inl_src $ inlinePragInfo $ Ghc.idInfo x) ++ +      "\n inl_inline . inlinePragInfo . Ghc.idInfo = " ++ GM.showPpr (inl_inline $ inlinePragInfo $ Ghc.idInfo x) ++ +      "\n inl_sat . inlinePragInfo . Ghc.idInfo = "    ++ GM.showPpr (inl_sat $ inlinePragInfo $ Ghc.idInfo x) ++ +      "\n inl_act . inlinePragInfo . Ghc.idInfo = "    ++ GM.showPpr (inl_act $ inlinePragInfo $ Ghc.idInfo x) ++ +      "\n inl_rule . inlinePragInfo . Ghc.idInfo = "   ++ GM.showPpr (inl_rule $ inlinePragInfo $ Ghc.idInfo x) ++ +      "\n inl_rule rule = " ++ GM.showPpr (inl_rule $ inlinePragInfo $ Ghc.idInfo x) ++ +      "\n inline spec = " ++ GM.showPpr (inl_inline $ inlinePragInfo $ Ghc.idInfo x)  +     ) x +   where  +    go (Ghc.ForAllTy a (Ghc.ForAllTy b (Ghc.ForAllTy c (Ghc.FunTy { Ghc.ft_arg = tf, Ghc.ft_res = Ghc.FunTy { Ghc.ft_arg = tg, Ghc.ft_res = tx}}))))+      = let f = stringVar "f" tf +            g = stringVar "g" tg+            x = stringVar "x" tx +        in Ghc.Lam (Ghc.binderVar a) $ +           Ghc.Lam (Ghc.binderVar b) $ +           Ghc.Lam (Ghc.binderVar c) $ +           Ghc.Lam f $ Ghc.Lam g $ Ghc.Lam x $ Ghc.App (Ghc.Var f) (Ghc.App (Ghc.Var g) (Ghc.Var x))+    go _ = error "Axioms.go"
src/Language/Haskell/Liquid/Bare/Check.hs view
@@ -6,17 +6,17 @@ {-# LANGUAGE OverloadedStrings   #-}  module Language.Haskell.Liquid.Bare.Check -  ( checkGhcSpec+  ( checkTargetSpec   , checkBareSpec   ) where +import           Language.Haskell.Liquid.Constraint.ToFixpoint import           Language.Haskell.Liquid.GHC.API          as Ghc hiding (Located) -import           Language.Haskell.Liquid.GHC.TypeRep (Type(TyConApp, TyVarTy)) import           Control.Applicative                       ((<|>)) import           Control.Arrow                             ((&&&)) import           Data.Maybe import           Data.Function                             (on)-import           Text.PrettyPrint.HughesPJ+import           Text.PrettyPrint.HughesPJ                 hiding ((<>)) import qualified Data.List                                 as L import qualified Data.HashMap.Strict                       as M import qualified Data.HashSet                              as S@@ -26,9 +26,6 @@ import qualified Language.Fixpoint.Types                   as F  import qualified Language.Haskell.Liquid.GHC.Misc          as GM  import           Language.Haskell.Liquid.Misc              (condNull, snd4)-import           Language.Haskell.Liquid.Types.PredType    (pvarRType)-import           Language.Haskell.Liquid.Types.PrettyPrint (pprintSymbol)-import           Language.Haskell.Liquid.Types.RefType     (classBinds, ofType, rTypeSort, rTypeSortedReft, subsTyVars_meet, toType) import           Language.Haskell.Liquid.Types import           Language.Haskell.Liquid.WiredIn import           Language.Haskell.Liquid.LawInstances      (checkLawInstances)@@ -36,28 +33,30 @@ 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           Debug.Trace (trace) + ---------------------------------------------------------------------------------------------- -- | Checking BareSpec ------------------------------------------------------------------------ -----------------------------------------------------------------------------------------------checkBareSpec :: ModName -> Ms.BareSpec -> Either [Error] Ms.BareSpec -checkBareSpec _ sp = Misc.applyNonNull (Right sp) Left $ concat -  [ checkUnique   "measure"    measures -  , checkUnique   "field"      fields -  , checkDisjoints             [ inlines-                               , hmeasures-                               , S.fromList measures-                               , reflects-                               , S.fromList fields -                               ]  -  ] -  where -    inlines   = Ms.inlines    sp -    hmeasures = Ms.hmeas      sp -    reflects  = Ms.reflects   sp -    measures  = msName    <$> Ms.measures sp -    fields    = concatMap dataDeclFields (Ms.dataDecls sp) +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) @@ -73,8 +72,8 @@ isGadt :: DataCtor -> Bool  isGadt = isJust . dcResult  -checkUnique :: String -> [F.LocSymbol] -> [Error]-checkUnique _ = checkUnique' F.val GM.fSrcSpan +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]@@ -85,65 +84,69 @@     dups                   = [ z      | z@(_, _:_:_) <- Misc.groupList nts       ]      nts                    = [ (n, l) | t <- ts, let n = nameF t, let l = locF t ] -checkDisjoints :: [S.HashSet F.LocSymbol] -> [Error]-checkDisjoints []     = [] -checkDisjoints [_]    = [] -checkDisjoints (s:ss) = checkDisjoint s (S.unions ss) -                     ++ checkDisjoints ss +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 -> [Error]-checkDisjoint s1 s2 = checkUnique "disjoint" (S.toList s1 ++ S.toList s2) +checkDisjoint :: S.HashSet F.LocSymbol -> S.HashSet F.LocSymbol -> Diagnostics+checkDisjoint s1 s2 = checkUnique "disjoint" (S.toList s1 ++ S.toList s2)  ------------------------------------------------------------------------------------------------- | Checking GhcSpec ------------------------------------------------------------------------+-- | Checking TargetSpec ---------------------------------------------------------------------------------------------- -checkGhcSpec :: [(ModName, Ms.BareSpec)]-             -> GhcSrc-             -> F.SEnv F.SortedReft-             -> [CoreBind]-             -> GhcSpec-             -> Either [Error] GhcSpec--checkGhcSpec specs src env cbs sp = Misc.applyNonNull (Right sp) Left errors+checkTargetSpec :: [Ms.BareSpec]+                -> TargetSrc+                -> F.SEnv F.SortedReft+                -> [CoreBind]+                -> TargetSpec+                -> Either Diagnostics ()+checkTargetSpec specs src env cbs sp+  | diagnostics == emptyDiagnostics = Right ()+  | otherwise                       = Left diagnostics   where-    errors           =  mapMaybe (checkBind allowHO "measure"      emb tcEnv env) (gsMeas       (gsData sp))-                     ++ condNull noPrune -                        (mapMaybe (checkBind allowHO "constructor"  emb tcEnv env) (txCtors $ gsCtors      (gsData sp)))-                     ++ mapMaybe (checkBind allowHO "assume"       emb tcEnv env) (gsAsmSigs    (gsSig sp))-                     ++ checkTySigs         allowHO cbs            emb tcEnv env                (gsSig sp)-                     -- ++ mapMaybe (checkTerminationExpr             emb       env) (gsTexprs     (gsSig  sp)) -                     ++ mapMaybe (checkBind allowHO "class method" emb tcEnv env) (clsSigs      (gsSig sp))-                     ++ mapMaybe (checkInv allowHO emb tcEnv env)                 (gsInvariants (gsData sp))-                     ++ checkIAl allowHO emb tcEnv env                            (gsIaliases   (gsData sp))-                     ++ checkMeasures emb env ms-                     ++ checkClassMeasures                                        (gsMeasures (gsData sp))-                     ++ checkClassMethods (gsCls src) (gsCMethods (gsVars sp)) (gsTySigs     (gsSig sp))-                     ++ mapMaybe checkMismatch                     sigs-                     ++ checkDuplicate                                            (gsTySigs     (gsSig sp))+    diagnostics      :: Diagnostics+    diagnostics      =  foldMap (checkBind allowHO bsc "measure"      emb tcEnv env) (gsMeas       (gsData sp))+                     <> condNull noPrune+                        (foldMap (checkBind allowHO bsc "constructor"  emb tcEnv env) (txCtors $ gsCtors      (gsData sp)))+                     <> foldMap (checkBind allowHO bsc "assume"       emb tcEnv env) (gsAsmSigs    (gsSig sp))+                     <> foldMap (checkBind allowHO bsc "reflect"      emb tcEnv env) (gsRefSigs    (gsSig sp))+                     <> checkTySigs         allowHO bsc cbs            emb tcEnv env                (gsSig sp)+                     -- ++ mapMaybe (checkTerminationExpr             emb       env) (gsTexprs     (gsSig  sp))+                     <> foldMap (checkBind allowHO bsc "class method" emb tcEnv env) (clsSigs      (gsSig sp))+                     <> foldMap (checkInv allowHO bsc emb tcEnv env)                 (gsInvariants (gsData sp))+                     <> checkIAl allowHO bsc emb tcEnv env                            (gsIaliases   (gsData sp))+                     <> checkMeasures emb env ms+                     <> checkClassMeasures                                        (gsMeasures (gsData sp))+                     <> checkClassMethods (gsCls src) (gsCMethods (gsVars sp)) (gsTySigs     (gsSig sp))+                     <> foldMap checkMismatch sigs+                     <> checkDuplicate                                            (gsTySigs     (gsSig sp))                      -- TODO-REBARE ++ checkQualifiers env                                       (gsQualifiers (gsQual sp))-                     ++ checkDuplicate                                            (gsAsmSigs    (gsSig sp))-                     ++ checkDupIntersect                                         (gsTySigs (gsSig sp)) (gsAsmSigs (gsSig sp))-                     ++ checkRTAliases "Type Alias" env            tAliases-                     ++ checkRTAliases "Pred Alias" env            eAliases+                     <> checkDuplicate                                            (gsAsmSigs    (gsSig sp))+                     <> checkDupIntersect                                         (gsTySigs (gsSig sp)) (gsAsmSigs (gsSig sp))+                     <> 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 sp))-                     ++ checkPlugged (catMaybes [ fmap (F.dropSym 2 $ GM.simplesymbol x,) (getMethodType t) | (x, t) <- gsMethods (gsSig sp) ])-                     ++ checkLawInstances (gsLaws sp)+                     <> checkSizeFun emb env                                      (gsTconsP (gsName sp))+                     <> checkPlugged (catMaybes [ fmap (F.dropSym 2 $ GM.simplesymbol x,) (getMethodType t) | (x, t) <- gsMethods (gsSig sp) ])+                     <> checkLawInstances (gsLaws sp)+                     <> checkRewrites sp -    _rClasses         = concatMap (Ms.classes   . snd) specs-    _rInsts           = concatMap (Ms.rinstance . snd) specs-    tAliases          = concat [Ms.aliases sp  | (_, sp) <- specs]-    eAliases          = concat [Ms.ealiases sp | (_, sp) <- specs]+    _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 sp)     tcEnv            = gsTyconEnv (gsName sp)     ms               = gsMeasures (gsData sp)     clsSigs sp       = [ (v, t) | (v, t) <- gsTySigs sp, isJust (isClassOpId_maybe v) ]     sigs             = gsTySigs (gsSig sp) ++ gsAsmSigs (gsSig sp) ++ gsCtors (gsData sp)     allowHO          = higherOrderFlag sp+    bsc              = bscope (getConfig sp)     noPrune          = not (pruneFlag sp)     txCtors ts       = [(v, fmap (fmap (fmap (F.filterUnMatched temps))) t) | (v, t) <- ts]     temps            = F.makeTemplates $ gsUnsorted $ gsData sp@@ -153,49 +156,53 @@   -checkPlugged :: PPrint v => [(v, LocSpecType)] -> [Error] -checkPlugged xs = mkErr <$> filter (hasHoleTy . val . snd) xs -  where -    mkErr (x,t) = ErrBadData (GM.sourcePosSrcSpan $ loc t) (pprint x) msg +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 -> [CoreBind] -> F.TCEmb TyCon -> Bare.TyConMap -> F.SEnv F.SortedReft +checkTySigs :: Bool+            -> BScope+            -> [CoreBind]+            -> F.TCEmb TyCon+            -> Bare.TyConMap+            -> F.SEnv F.SortedReft             -> GhcSpecSig-            -> [Error]+            -> Diagnostics ---------------------------------------------------------------------------------checkTySigs allowHO cbs emb tcEnv env sig-                   = 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 env [] cbs -  where -    check env      = checkSigTExpr allowHO emb tcEnv env+checkTySigs allowHO bsc cbs emb tcEnv env sig+                   = mconcat (map (check env) topTs)+                     -- (mapMaybe   (checkT env) [ (x, t)     | (x, (t, _)) <- topTs])+                     -- ++ (mapMaybe   (checkE env) [ (x, t, es) | (x, (t, Just es)) <- topTs])+                  <> coreVisitor checkVisitor env emptyDiagnostics cbs+  where+    check env      = checkSigTExpr allowHO bsc emb tcEnv env     locTm          = M.fromList locTs-    (locTs, topTs) = Bare.partitionLocalBinds vtes +    (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 ] +    vExprs         = M.fromList  [ (x, es) | (x, _, es) <- gsTexprs sig ] -    checkVisitor  :: CoreVisitor (F.SEnv F.SortedReft) [Error]-    checkVisitor   = CoreVisitor -                       { envF  = \env v     -> F.insertSEnv (F.symbol v) (vSort v) env -                       , bindF = \env acc v -> errs env v ++ acc -                       , exprF = \_   acc _ -> acc -                       }  +    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 -> [] +                         Nothing -> emptyDiagnostics                          Just t  -> check env (v, t)  -checkSigTExpr :: Bool -> F.TCEmb TyCon -> Bare.TyConMap -> F.SEnv F.SortedReft -              -> (Var, (LocSpecType, Maybe [Located F.Expr])) -              -> [Error]-checkSigTExpr allowHO emb tcEnv env (x, (t, es)) -           = catMaybes [mbErr1, mbErr2] -   where -    mbErr1 = checkBind allowHO empty emb tcEnv env (x, t) -    mbErr2 = checkTerminationExpr emb env . (x, t,) =<< es +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  _checkQualifiers :: F.SEnv F.SortedReft -> [F.Qualifier] -> [Error] _checkQualifiers = mapMaybe . checkQualifier@@ -206,20 +213,31 @@     γ                = 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) -checkSizeFun :: F.TCEmb TyCon -> F.SEnv F.SortedReft -> [TyConP] -> [Error]-checkSizeFun emb env tys = mkError <$> mapMaybe go tys+-- | 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." $+$   msg)+                                 (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   -> checkWFSize (szFun f) tcp+               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@@ -255,56 +273,88 @@                 | otherwise = go (x:xs)     go _                    = Nothing -checkInv :: Bool -> F.TCEmb TyCon -> Bare.TyConMap -> F.SEnv F.SortedReft -> (Maybe Var, LocSpecType) -> Maybe Error-checkInv allowHO emb tcEnv env (_, t) = checkTy allowHO err emb tcEnv env t+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 -> F.TCEmb TyCon -> Bare.TyConMap -> F.SEnv F.SortedReft -> [(LocSpecType, LocSpecType)] -> [Error]-checkIAl allowHO emb tcEnv env ials = catMaybes $ concatMap (checkIAlOne allowHO emb tcEnv env) ials+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)-            -> [Maybe (TError SpecType)]-checkIAlOne allowHO emb tcEnv env (t1, t2) = checkEq : (tcheck <$> [t1, t2])+            -> Diagnostics+checkIAlOne allowHO bsc emb tcEnv env (t1, t2) = mconcat $ checkEq : (tcheck <$> [t1, t2])   where-    tcheck t = checkTy allowHO (err t) emb tcEnv env t+    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 Nothing else Just errmis+    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)] -> [Error]+checkRTAliases :: String -> t -> [Located (RTAlias s a)] -> Diagnostics checkRTAliases msg _ as = err1s   where     err1s               = checkDuplicateRTAlias msg as -checkBind :: (PPrint v) => Bool -> Doc -> F.TCEmb TyCon -> Bare.TyConMap -> F.SEnv F.SortedReft -> (v, LocSpecType) -> Maybe Error-checkBind allowHO s emb tcEnv env (v, t) = checkTy allowHO msg emb tcEnv env t+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]) -> Maybe Error+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 _ t, les)-            = (mkErr "ill-sorted" <$> go les) <|> (mkErr "non-numeric" <$> go' les)+            = (mkErr "ill-sorted" $ go les) <> (mkErr "non-numeric" $ go' les)   where     -- es      = val <$> les-    mkErr k = uncurry (\ e d -> ErrTermSpec (GM.sourcePosSrcSpan l) (pprint v) k e t d)+    mkErr :: Doc -> Maybe (F.Expr, Doc) -> Diagnostics+    mkErr _ Nothing = emptyDiagnostics+    mkErr k (Just e) =+      mkDiagnostics mempty [uncurry (\ e d -> ErrTermSpec (GM.sourcePosSrcSpan l) (pprint v) k e t d) e]     -- 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 mkClass $ zip (ty_binds trep) (ty_args trep)     trep    = toRTypeRep t@@ -315,41 +365,53 @@     rSort   = rTypeSortedReft emb     cmpZero e = F.PAtom F.Le (F.expr (0 :: Int)) (val e) -checkTy :: Bool -> (Doc -> Error) -> F.TCEmb TyCon -> Bare.TyConMap -> F.SEnv F.SortedReft -> LocSpecType -> Maybe Error-checkTy allowHO mkE emb tcEnv env t = mkE <$> checkRType allowHO emb env (Bare.txRefSort tcEnv emb t)+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)] -> [Error]-checkDupIntersect xts asmSigs = concatMap mkWrn {- trace msg -} dups+checkDupIntersect     :: [(Var, LocSpecType)] -> [(Var, LocSpecType)] -> Diagnostics+checkDupIntersect xts asmSigs =+  mkDiagnostics (map mkWrn {- trace msg -} dups) mempty   where-    mkWrn (x, t)     = pprWrn x (GM.sourcePosSrcSpan $ loc t)-    dups             = L.intersectBy ((==) `on` fst) asmSigs xts-    pprWrn v l       = trace ("WARNING: Assume Overwrites Specifications for "++ show v ++ " : " ++ GM.showPpr l) []+    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)] -> [Error]-checkDuplicate = checkUnique' fst (GM.fSrcSpan . snd)+checkDuplicate :: [(Var, LocSpecType)] -> Diagnostics+checkDuplicate = mkDiagnostics mempty . checkUnique' fst (GM.fSrcSpan . snd) -checkClassMethods :: Maybe [ClsInst] -> [Var] ->  [(Var, LocSpecType)] -> [Error]-checkClassMethods Nothing      _   _   = [] -checkClassMethods (Just clsis) cms xts = [ErrMClass (GM.sourcePosSrcSpan $ loc t) (pprint x)| (x,t) <- dups ]-  where -    dups = F.notracepp "DPS" $ filter ((`elem` ms) . fst) xts' +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   +    xts' = F.notracepp "XTS" $ filter (not . (`elem` cls) . fst) xts+    cls  = F.notracepp "CLS" cms  -- checkDuplicate xts = mkErr <$> dups   -- where     -- mkErr (x, ts) = ErrDupSpecs (getSrcSpan x) (pprint x) (GM.fSrcSpan <$> ts)     -- dups          = [z | z@(_, _:_:_) <- M.toList $ group xts ] -checkDuplicateRTAlias :: String -> [Located (RTAlias s a)] -> [Error]-checkDuplicateRTAlias s tas = mkErr <$> dups+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)@@ -359,19 +421,19 @@     dups                    = [z | z@(_:_:_) <- L.groupBy ((==) `on` (rtName . val)) tas]  -checkMismatch        :: (Var, LocSpecType) -> Maybe Error-checkMismatch (x, t) = if ok then Nothing else Just err+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         = F.notracepp msg (lqT == hsT)+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+    _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@@ -384,12 +446,12 @@ ------------------------------------------------------------------------------------------------ -- | @checkRType@ determines if a type is malformed in a given environment --------------------- -------------------------------------------------------------------------------------------------checkRType :: Bool -> F.TCEmb TyCon -> F.SEnv F.SortedReft -> LocSpecType -> Maybe Doc+checkRType :: Bool -> BScope -> F.TCEmb TyCon -> F.SEnv F.SortedReft -> LocSpecType -> Maybe Doc -------------------------------------------------------------------------------------------------checkRType allowHO emb env lt+checkRType allowHO bsc emb env lt   =   checkAppTys t   <|> checkAbstractRefs t-  <|> efoldReft farg cb (tyToBind emb) (rTypeSortedReft emb) f insertPEnv env Nothing t+  <|> efoldReft farg bsc cb (tyToBind emb) (rTypeSortedReft emb) f insertPEnv env Nothing t   where     t                  = val lt     cb c ts            = classBinds emb (rRCls c ts)@@ -401,15 +463,14 @@ 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      = []+    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 (RAllT _ t _)    = go t     go (RAllP _ t)      = go t-    go (RAllS _ t)      = go t     go (RApp rtc ts _ _)       = checkTcArity rtc (length ts) <|>         L.foldl' (\merr t -> merr <|> go t) Nothing ts@@ -433,26 +494,8 @@   | otherwise     = Nothing   where-    expectedArity = tyConArity tc+    expectedArity = tyConRealArity tc -{--checkFunRefs t = go t-  where-    go (RAllT _ t)      = go t-    go (RAllP _ t)      = go t-    go (RAllS _ t)      = go t-    go (RApp _ ts _ _)  = foldl (\merr t -> merr <|> go t) Nothing ts-    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 _)     = Nothing-    go (RHole _)        = Nothing-    go (RFun _ t1 t2 r)-      | isTauto r       = go t1 <|> go t2-      | otherwise       = Just $ text "Function types cannot have refinements:" <+> (pprint r)--}  checkAbstractRefs   :: (PPrint t, F.Reftable t, SubsTy RTyVar RSort t, F.Reftable (RTProp RTyCon RTyVar (UReft t))) =>@@ -461,9 +504,8 @@   where     penv = mkPEnv t -    go (RAllT _ t)        = go t+    go t@(RAllT _ t1 r)   = check (toRSort t :: RSort) r <|>  go t1     go (RAllP _ t)        = go t-    go (RAllS _ 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@@ -497,7 +539,7 @@      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+    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"@@ -509,9 +551,9 @@                  | otherwise                  = Nothing -    mkPEnv (RAllT _ t) = mkPEnv t-    mkPEnv (RAllP p t) = p:mkPEnv t-    mkPEnv _           = []+    mkPEnv (RAllT _ t _) = mkPEnv t+    mkPEnv (RAllP p t)   = p:mkPEnv t+    mkPEnv _             = []     pvType' p          = Misc.safeHead (showpp p ++ " not in env of " ++ showpp t) [pvType q | q <- penv, pname p == pname q]  @@ -537,13 +579,13 @@ --------------------------------------------------------------------------------------------------- -- | @checkMeasures@ determines if a measure definition is wellformed ----------------------------- ----------------------------------------------------------------------------------------------------checkMeasures :: F.TCEmb TyCon -> F.SEnv F.SortedReft -> [Measure SpecType DataCon] -> [Error]+checkMeasures :: F.TCEmb TyCon -> F.SEnv F.SortedReft -> [Measure SpecType DataCon] -> Diagnostics ----------------------------------------------------------------------------------------------------checkMeasures emb env = concatMap (checkMeasure emb env)+checkMeasures emb env = foldMap (checkMeasure emb env) -checkMeasure :: F.TCEmb TyCon -> F.SEnv F.SortedReft -> Measure SpecType DataCon -> [Error]+checkMeasure :: F.TCEmb TyCon -> F.SEnv F.SortedReft -> Measure SpecType DataCon -> Diagnostics checkMeasure emb γ (M name@(Loc src _ n) sort body _ _)-  = [ txerror e | Just e <- checkMBody γ emb name sort <$> body ]+  = mkDiagnostics mempty [ txerror e | Just e <- checkMBody γ emb name sort <$> body ]   where     txerror = ErrMeas (GM.sourcePosSrcSpan src) (pprint n) @@ -558,7 +600,7 @@   where     sp    = F.srcSpan m     γ'    = L.foldl' (\γ (x, t) -> F.insertSEnv x t γ) γ xts-    xts   = zip (fst <$> bs) $ rTypeSortedReft emb . subsTyVars_meet su <$> ty_args trep+    xts   = zip (fst <$> bs) $ rTypeSortedReft emb . subsTyVars_meet su <$> filter (not . isClassType) (ty_args trep)     trep  = toRTypeRep ct     su    = checkMBodyUnify (ty_res trep) (last txs)     txs   = snd4 $ bkArrowDeep sort@@ -596,8 +638,78 @@     trep = toRTypeRep t  -checkClassMeasures :: [Measure SpecType DataCon] -> [Error]-checkClassMeasures ms = mapMaybe checkOne byTyCon+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 ++ if cannotInstantiate then+        [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"]+        else []+    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 ms = mkDiagnostics mempty (mapMaybe checkOne byTyCon)   where   byName = L.groupBy ((==) `on` (val . msName)) ms 
src/Language/Haskell/Liquid/Bare/Class.hs view
@@ -20,6 +20,7 @@  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 Language.Haskell.Liquid.GHC.Misc           as GM@@ -32,9 +33,13 @@ 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  + ------------------------------------------------------------------------------- makeMethodTypes :: DEnv Ghc.Var LocSpecType -> [DataConP] -> [Ghc.CoreBind] -> [(Ghc.Var, MethodType LocSpecType)] -------------------------------------------------------------------------------@@ -63,13 +68,53 @@       subst ((a,ta):su) t = subsTyVar_meet' (a,ofType ta) (subst su t)  addCC :: Ghc.Var -> LocSpecType -> LocSpecType-addCC x t = t{val = go (ofType $ Ghc.varType x) (val t)} +addCC x zz@(Loc l l' st0) +  = Loc l l' +  . addForall hst  +  . mkArrow [] ps' [] [] +  . makeCls cs' +  . mapExprReft (\_ -> F.applyCoSub coSub) +  . subts su +  $ st     where-    go :: SpecType -> SpecType -> SpecType-    go (RAllT (RTVar a1 _) t1) (RAllT a2 t2) = RAllT a2 (go (subsTyVar_meet' (a1,RVar a1 mempty) t1) t2)-    go (RFun x1 t11 t12 r) t | isClassType t11 = (RFun x1 t11 (go t12 t) r) -    go _ t = t +    hst           = ofType (Ghc.expandTypeSynonyms t0) :: SpecType+    t0            = Ghc.varType x +    tyvsmap       = case Bare.runMapTyVars 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 cs t  = foldr (uncurry rFun) t cs+    err hsT lqT   = ErrMismatch (GM.fSrcSpan zz) (pprint x) +      (text "makeMethodTypes")+      (pprint $ Ghc.expandTypeSynonyms t0)+      (pprint $ toRSort st0)+      (Just (hsT, lqT))+      (Ghc.getSrcSpan x) ++    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 t1' t2' r)+      = RFun x (addForall t1 t1') (addForall t2 t2') r  +    addForall _ t +      = t ++ splitDictionary :: Ghc.CoreExpr -> Maybe (Ghc.Var, [Ghc.Type], [Ghc.Var]) splitDictionary = go [] []    where @@ -124,7 +169,7 @@     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) t False (F.symbol name) l'+    let dcp = DataConP l dc αs [] (val <$> ss') (reverse sts) t False (F.symbol name) l'     return  $ F.notracepp msg (dcp, vts)   where     c      = btc_tc cc@@ -140,11 +185,11 @@ mkConstr :: Bare.Env -> Bare.SigEnv -> ModName -> LocBareType -> Either UserError LocSpecType      mkConstr env sigEnv name = fmap (fmap dropUniv) . Bare.cookSpecTypeE env sigEnv name Bare.GenTV    where -    dropUniv t           = t' where (_, _, _, t') = bkUniv t+    dropUniv t           = t' where (_, _, t') = bkUniv t     --FIXME: cleanup this code unClass :: SpecType -> SpecType -unClass = snd . bkClass . fourth4 . bkUniv+unClass = snd . bkClass . thrd3 . bkUniv  makeMethod :: Bare.Env -> Bare.SigEnv -> ModName -> (LocSymbol, LocBareType)           -> Either UserError (ModName, PlugTV Ghc.Var, LocSpecType)@@ -176,10 +221,21 @@                       -> RInstance LocBareType                        -> (F.Symbol, M.HashMap F.Symbol (RISig LocSpecType)) makeSpecDictionaryOne env sigEnv name (RI x t xts)-         = makeDictionary $ RI x (mkTy <$> t) [(x, mkLSpecIType t) | (x, t) <- xts ] +         = makeDictionary $ F.notracepp "RI" $ RI x ts [(x, mkLSpecIType t) | (x, t) <- xts ]    where+    ts      = mkTy' <$> t+    as      = 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 = Bare.cookSpecType env sigEnv name Bare.GenTV+    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` as) vs       mkLSpecIType :: RISig LocBareType -> RISig LocSpecType     mkLSpecIType t = fmap mkTy t
src/Language/Haskell/Liquid/Bare/DataType.hs view
@@ -300,7 +300,7 @@ makeDataDecl tce tc dd ctors   = F.DDecl       { F.ddTyCon = ftc-      , F.ddVars  = length                $  tycTyVars dd+      , F.ddVars  = length                $  GM.tyConTyVarsDef tc       , F.ddCtors = makeDataCtor tce ftc <$> ctors       }   where@@ -350,14 +350,13 @@ meetDataConSpec :: F.TCEmb Ghc.TyCon -> [(Ghc.Var, SpecType)] -> [DataConP]                  -> [(Ghc.Var, SpecType)] ---------------------------------------------------------------------------------meetDataConSpec emb xts dcs  = -- F.notracepp "meetDataConSpec" $-                               M.toList $ snd <$> L.foldl' upd dcm0 xts+meetDataConSpec emb xts dcs  = M.toList $ snd <$> L.foldl' upd dcm0 xts   where     dcm0                     = M.fromList (dataConSpec' dcs)     upd dcm (x, t)           = M.insert x (Ghc.getSrcSpan x, tx') dcm                                 where                                   tx' = maybe t (meetX x t) (M.lookup x dcm)-    meetX x t (sp', t')      = F.notracepp (_msg x t t') $ meetVarTypes emb (pprint x) (Ghc.getSrcSpan x, t) (sp', 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' :: [DataConP] -> [(Ghc.Var, (Ghc.SrcSpan, SpecType))]@@ -455,11 +454,12 @@ --   elsewhere. [e.g. tests/errors/BadDataDecl.hs]  checkDataDecl :: Ghc.TyCon -> DataDecl -> Bool-checkDataDecl c d = F.notracepp _msg (cN == dN || null (tycDCons d))+checkDataDecl c d = F.notracepp _msg (isGADT || cN == dN || null (tycDCons d))   where-    _msg          = printf "checkDataDecl: c = %s, cN = %d, dN = %d" (show c) cN dN+    _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 -> Ghc.TyCon getDnTyCon env name dn = Mb.fromMaybe ugh (Bare.lookupGhcDnTyCon env name "ofBDataDecl-1" dn)@@ -469,7 +469,7 @@ -- FIXME: ES: why the maybes? ofBDataDecl :: Bare.Env -> ModName -> Maybe DataDecl -> (Maybe (LocSymbol, [Variance]))             -> ( (ModName, TyConP, Maybe DataPropDecl), [Located DataConP])-ofBDataDecl env name (Just dd@(DataDecl tc as ps ls cts pos sfun pt _)) maybe_invariance_info+ofBDataDecl env name (Just dd@(DataDecl tc as ps cts pos sfun pt _)) maybe_invariance_info   | not (checkDataDecl tc' dd)   = uError err   | otherwise@@ -478,14 +478,14 @@     πs         = Bare.ofBPVar env name pos <$> ps     tc'        = getDnTyCon env name tc     -- cts        = checkDataCtors env name tc' cts0-    cts'       = ofBDataCtor env name lc lc' tc' αs ps ls πs <$> cts+    cts'       = ofBDataCtor env name lc lc' tc' αs ps πs <$> cts     pd         = Bare.ofBareType env name lc (Just []) <$> pt     tys        = [t | dcp <- cts', (_, t) <- dcpTyArgs dcp]     initmap    = zip (RT.uPVar <$> πs) [0..]     varInfo    = L.nub $  concatMap (getPsSig initmap True) tys     defPs      = varSignToVariance varInfo <$> [0 .. (length πs - 1)]     (tvi, pvi) = f defPs-    tcp          = TyConP lc tc' αs πs ls tvi pvi sfun+    tcp          = TyConP lc tc' αs πs tvi pvi sfun     err          = ErrBadData (GM.fSrcSpan tc) (pprint tc) "Mismatch in number of type variables" :: UserError     αs           = RTV . GM.symbolTyVar <$> as     n            = length αs@@ -495,7 +495,7 @@                      Just (_,is) -> (take n is, if null (drop n is) then defPs else (drop n is))  ofBDataDecl env name Nothing (Just (tc, is))-  = ((name, TyConP srcpos tc' [] [] [] tcov tcontr Nothing, Nothing), [])+  = ((name, TyConP srcpos tc' [] [] tcov tcontr Nothing, Nothing), [])   where     tc'            = Bare.lookupGhcTyCon env name "ofBDataDecl-2" tc     (tcov, tcontr) = (is, [])@@ -512,16 +512,14 @@             -> Ghc.TyCon             -> [RTyVar]             -> [PVar BSort]-            -> [F.Symbol]             -> [PVar RSort]             -> DataCtor             -> DataConP-ofBDataCtor env name l l' tc αs ps ls πs _ctor@(DataCtor c as _ xts res) = DataConP +ofBDataCtor env name l l' tc αs ps πs _ctor@(DataCtor c as _ xts res) = DataConP    { dcpLoc        = l                   , dcpCon        = c'                   , dcpFreeTyVars = RT.symbolRTyVar <$> as    , dcpFreePred   = πs                 -  , dcpFreeLabels = ls                   , dcpTyConstrs  = cs                   , dcpTyArgs     = zts                    , dcpTyRes      = ot                @@ -564,8 +562,8 @@                                 _        -> Bivariant  getPsSig :: [(UsedPVar, a)] -> Bool -> SpecType -> [(a, Bool)]-getPsSig m pos (RAllT _ t)-  = getPsSig m pos t+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@@ -585,7 +583,7 @@ getPsSigPs m pos (RProp _ t) = getPsSig m pos t  addps :: [(UsedPVar, a)] -> b -> UReft t -> [(a, b)]-addps m pos (MkUReft _ ps _) = (flip (,)) pos . f  <$> pvars ps+addps m pos (MkUReft _ ps) = (flip (,)) pos . f  <$> pvars ps   where      f = Mb.fromMaybe (panic Nothing "Bare.addPs: notfound") . (`L.lookup` m) . RT.uPVar @@ -672,7 +670,7 @@       fls = Ghc.dataConFieldLabels dc       fs  = Bare.lookupGhcNamedVar env name . Ghc.flSelector <$> fls        ts :: [ LocSpecType ]-      ts = [ Loc l l' (mkArrow (makeRTVar <$> dcpFreeTyVars dcp) [] (dcpFreeLabels dcp)+      ts = [ Loc l l' (mkArrow (zip (makeRTVar <$> dcpFreeTyVars dcp) (repeat mempty)) []                                  [] [(z, res, mempty)]                                  (dropPreds (F.subst su t `RT.strengthen` mt)))              | (x, t) <- reverse args -- NOTE: the reverse here is correct@@ -689,4 +687,4 @@       -- 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 ss) -> MkUReft r mempty ss)+      dropPreds = fmap (\(MkUReft r _ps) -> MkUReft r mempty)
src/Language/Haskell/Liquid/Bare/Expand.hs view
@@ -72,8 +72,8 @@ --   hidden inside @RExprArg@ or as strange type parameters.  renameRTArgs :: BareRTEnv -> BareRTEnv  renameRTArgs rte = RTE -  { typeAliases = M.map (fmap (renameVV . renameRTVArgs)) (typeAliases rte) -  , exprAliases = M.map (fmap (           renameRTVArgs)) (exprAliases 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 @@ -81,6 +81,17 @@   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 = subts (rtBody rt) (zip xs ys) }+  where +    xs    = rtTArgs rt +    ys    = (`F.suffixSymbol` rtName rt) <$> xs+    subts = foldl (flip subt)++ renameVV :: RTAlias F.Symbol BareType -> RTAlias F.Symbol BareType  renameVV rt = rt { rtBody = RT.shiftVV (rtBody rt) (F.vv (Just 0)) } @@ -202,9 +213,8 @@     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 (RAllT _ t _)    = go t     go (RAllP _ t)      = go t-    go (RAllS _ t)      = go t     go (RVar _ _)       = []     go (RExprArg _)     = []     go (RHole _)        = []@@ -329,7 +339,7 @@     , body  = expand rtEnv l (body  d)      }  -instance Expand BareSpec where +instance Expand Ms.BareSpec where    expand = expandBareSpec  instance Expand a => Expand (F.Located a) where @@ -347,7 +357,7 @@ instance Expand a => Expand (M.HashMap k a) where    expand rtEnv l = fmap (expand rtEnv l)  -expandBareSpec :: BareRTEnv -> F.SourcePos -> BareSpec -> 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)@@ -369,9 +379,8 @@     go (RAppTy t1 t2 r)  = RAppTy (go t1) (go t2) r     go (RImpF x t1 t2 r) = RImpF x (go t1) (go t2) r      go (RFun  x t1 t2 r) = RFun  x (go t1) (go t2) r -    go (RAllT a t)       = RAllT a (go t) +    go (RAllT a t r)     = RAllT a (go t) r     go (RAllP a t)       = RAllP a (go t) -    go (RAllS x t)       = RAllS x (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)@@ -380,86 +389,6 @@     go t@(RExprArg {})   = t      goRef (RProp ss t)   = RProp ss (go t) ---{- TODO-REBARE-ofBRType :: (PPrint r, UReftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, SubsTy BTyVar BSort r, F.Reftable (RTProp RTyCon RTyVar r), F.Reftable (RTProp BTyCon BTyVar r))-         => (SourcePos -> RTAlias RTyVar SpecType -> [BRType r] -> r -> BareM (RRType r))-         -> (r -> BareM r)-         -> BRType r-         -> BareM (RRType r)-ofBRType appRTAlias resolveReft !t-  = go t-  where-    go t@(RApp _ _ _ _)-      = do aliases <- (typeAliases . rtEnv) <$> get-           goRApp aliases t-    go (RAppTy t1 t2 r)-      = RAppTy <$> go t1 <*> go t2 <*> resolveReft r-    go (RImpF x t1 t2 r)-      =  do env <- get-            goRImpF (bounds env) x t1 t2 r-    go (RFun x t1 t2 r)-      =  do env <- get-            goRFun (bounds env) x t1 t2 r-    go (RVar a r)-      = RVar (bareRTyVar a) <$> resolveReft r-    go (RAllT a t)-      = RAllT (dropTyVarInfo $ mapTyVarValue bareRTyVar a) <$> go t-    go (RAllP a t)-      = RAllP <$> ofBPVar a <*> go t-    go (RAllS x t)-      = RAllS x <$> 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 <$> mapM (secondM go) e <*> resolveReft r <*> pure o <*> go t-    go (RHole r)-      = RHole <$> resolveReft r-    go (RExprArg (Loc l l' e))-      = RExprArg . Loc l l' <$> resolve l e-    go_ref (RProp ss (RHole r))-      = rPropP <$> mapM go_syms ss <*> resolveReft r-    go_ref (RProp ss t)-      = RProp <$> mapM go_syms ss <*> go t-    go_syms-      = secondM ofBSort--    goRImpF bounds _ (RApp c ps' _ _) t _-      | Just bnd <- M.lookup (btc_tc c) bounds-      = do let (ts', ps) = splitAt (length $ tyvars bnd) ps'-           ts <- mapM go ts'-           makeBound bnd ts [x | RVar (BTV x) _ <- ps] <$> go t-    goRImpF _ x t1 t2 r-      = RImpF x <$> (rebind x <$> go t1) <*> go t2 <*> resolveReft r--    goRFun bounds _ (RApp c ps' _ _) t _-      | Just bnd <- M.lookup (btc_tc c) bounds-      = do let (ts', ps) = splitAt (length $ tyvars bnd) ps'-           ts <- mapM go ts'-           makeBound bnd ts [x | RVar (BTV x) _ <- ps] <$> go t-    goRFun _ x t1 t2 r-      = RFun x <$> (rebind x <$> go t1) <*> go t2 <*> resolveReft r--    rebind x t = F.subst1 t (x, F.EVar $ rTypeValueVar t)--    goRApp aliases !(RApp tc ts _ r)-      | Loc l _ c <- btc_tc tc-      , Just rta <- M.lookup c aliases-      = appRTAlias l rta ts =<< resolveReft r-    goRApp _ !(RApp tc ts rs r)-      =  do let lc = btc_tc tc-            let l = loc lc-            r'  <- resolveReft r-            lc' <- Loc l l <$> matchTyCon lc (length ts)-            rs' <- mapM go_ref rs-            ts' <- mapM go ts-            bareTCApp r' lc' rs' ts'-    goRApp _ _ = impossible Nothing "goRApp failed through to final case"-- -} lookupRTEnv :: BTyCon -> BareRTEnv -> Maybe (Located BareRTAlias) lookupRTEnv c rtEnv = M.lookup (F.symbol c) (typeAliases rtEnv) @@ -556,7 +485,7 @@   . fmap (fmap (addTyConInfo   embs tyi))   . fmap (Bare.txRefSort tyi embs)        . fmap (fmap txExpToBind)      -- What does this function DO-  . fmap (specExpandType rtEnv)                         +  . fmap (specExpandType rtEnv)                           . fmap (fmap (generalizeWith x))   . fmap (maybePlug       sigEnv name x)   . fmap (Bare.qualifyTop    env name l) @@ -579,7 +508,7 @@ generalizeWith _             t = RT.generalize t   generalizeVar :: Ghc.Var -> SpecType -> SpecType -generalizeVar v t = mkUnivs as [] [] t +generalizeVar v t = mkUnivs (zip as (repeat mempty)) [] t    where      as            = filter isGen (freeTyVars t)     (vas,_)       = Ghc.splitForAllTys (GM.expandVarType v) @@ -757,12 +686,11 @@   = do t1' <- expToBindT t1        t2' <- expToBindT t2        expToBindRef r >>= addExists . RFun x t1' t2'-expToBindT (RAllT a t)-  = liftM (RAllT a) (expToBindT t)+expToBindT (RAllT a t r)+  = do t' <- expToBindT t +       expToBindRef r >>= addExists . RAllT a t'  expToBindT (RAllP p t)   = liftM (RAllP p) (expToBindT t)-expToBindT (RAllS s t)-  = liftM (RAllS s) (expToBindT t) expToBindT (RApp c ts rs r)   = do ts' <- mapM expToBindT ts        rs' <- mapM expToBindReft rs@@ -802,8 +730,8 @@     r                = F.exprReft e  expToBindRef :: UReft r -> State ExSt (UReft r)-expToBindRef (MkUReft r (Pr p) l)-  = mapM expToBind p >>= return . (\p -> MkUReft r p l). Pr+expToBindRef (MkUReft r (Pr p))+  = mapM expToBind p >>= return . (MkUReft r) . Pr  expToBind :: UsedPVar -> State ExSt UsedPVar expToBind p = do 
src/Language/Haskell/Liquid/Bare/Measure.hs view
@@ -55,7 +55,7 @@           = Bare.measureToBare <$> ms   where      ms    = makeMeasureDefinition tycEnv lmap cbs <$> mSyms -    cbs   = nonRecCoreBinds   (giCbs src) +    cbs   = nonRecCoreBinds   (_giCbs src)      mSyms = S.toList (Ms.hmeas spec)    makeMeasureDefinition :: Bare.TycEnv -> LogicMap -> [Ghc.CoreBind] -> LocSymbol @@ -79,8 +79,8 @@     ta = go $ Ghc.expandTypeSynonyms t      go (Ghc.ForAllTy _ t) = go t -    go (Ghc.FunTy p t) | Ghc.isClassPred p = go t -    go (Ghc.FunTy t _)    = t +    go (Ghc.FunTy { Ghc.ft_arg = p, Ghc.ft_res = t}) | Ghc.isClassPred 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@@ -111,7 +111,7 @@ makeHaskellInlines src embs lmap spec           = makeMeasureInline embs lmap cbs <$> inls    where-    cbs  = nonRecCoreBinds (giCbs src) +    cbs  = nonRecCoreBinds (_giCbs src)      inls = S.toList        (Ms.inlines spec)  makeMeasureInline :: F.TCEmb Ghc.TyCon -> LogicMap -> [Ghc.CoreBind] -> LocSymbol@@ -205,7 +205,6 @@       { tycName   = dn       , tycTyVars = F.symbol <$> GM.tyConTyVarsDef tc       , tycPVars  = []-      , tycTyLabs = []       , tycDCons  = decls tc       , tycSrcPos = GM.getSourcePos tc       , tycSFun   = szF@@ -278,11 +277,11 @@     checkT   = dataConSel dc n Check  dataConSel :: Ghc.DataCon -> Int -> DataConSel -> SpecType-dataConSel dc n Check    = mkArrow as [] [] [] [xt] bareBool+dataConSel dc n Check    = mkArrow (zip as (repeat mempty)) [] [] [xt] bareBool   where     (as, _, xt)          = {- traceShow ("dataConSel: " ++ show dc) $ -} bkDataCon dc n -dataConSel dc n (Proj i) = mkArrow as [] [] [] [xt] (mempty <$> ti)+dataConSel 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 dc n@@ -295,8 +294,8 @@     ts                = RT.ofType <$> Misc.takeLast nFlds _ts     t                 = -- Misc.traceShow ("bkDataConResult" ++ GM.showPpr (dc, _t, _t0)) $                           RT.ofType  $ Ghc.mkTyConApp tc tArgs'-    as                = makeRTVar . RT.rTyVar <$> αs-    ((αs,_,_,_,_ts,_t), _t0) = hammer dc+    as                = makeRTVar . RT.rTyVar <$> (αs ++ αs')+    ((αs,αs',_,_,_ts,_t), _t0) = hammer dc     tArgs'            = take (nArgs - nVars) tArgs ++ (Ghc.mkTyVarTy <$> αs)     nVars             = length αs     nArgs             = length tArgs
src/Language/Haskell/Liquid/Bare/Misc.hs view
@@ -13,17 +13,10 @@   , isKind   ) where -import           Name import           Prelude                               hiding (error)-import           TysWiredIn -import           Id-import           Type-import           Kind                                  (classifiesTypeWithValues) -import           Language.Haskell.Liquid.GHC.TypeRep-import           Var+import           Language.Haskell.Liquid.GHC.API       as Ghc  hiding (Located) --- import           DataCon import           Control.Monad.Except                  (MonadError, throwError) import           Control.Monad.State import qualified Data.Maybe                            as Mb --(fromMaybe, isNothing)@@ -54,7 +47,7 @@     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 (FunTy _ tx t)   = isBaseTy tx && hasBasicArgs t       hasBasicArgs _              = True  -} @@ -77,7 +70,7 @@ 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) (\_ _ -> []) (\_ -> []) (const ()) f (const id) F.emptySEnv [] (val ty)+    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 @@ -95,9 +88,12 @@ mapTyVars :: Type -> SpecType -> StateT MapTyVarST (Either Error) () mapTyVars t (RImpF _ _ t' _)    = mapTyVars t t'-mapTyVars (FunTy τ τ') (RFun _ t t' _)+mapTyVars (FunTy { ft_arg = τ, ft_res = τ'}) t +  | isClassPred τ+  = mapTyVars τ' t+mapTyVars (FunTy { ft_arg = τ, ft_res = τ'}) (RFun _ t t' _)    = mapTyVars τ t >> mapTyVars τ' t'-mapTyVars τ (RAllT _ t)+mapTyVars τ (RAllT _ t _)   = mapTyVars τ t mapTyVars (TyConApp _ τs) (RApp _ ts _ _)    = zipWithM_ mapTyVars τs (matchKindArgs' τs ts)@@ -107,8 +103,6 @@         put s' mapTyVars τ (RAllP _ t)   = mapTyVars τ t-mapTyVars τ (RAllS _ t)-  = mapTyVars τ t mapTyVars τ (RAllE _ _ t)   = mapTyVars τ t mapTyVars τ (RRTy _ _ _ t)@@ -185,6 +179,6 @@  hasBoolResult :: Type -> Bool hasBoolResult (ForAllTy _ t) = hasBoolResult t-hasBoolResult (FunTy _ t)    | eqType boolTy t = True-hasBoolResult (FunTy _ t)    = hasBoolResult t+hasBoolResult (FunTy { ft_res = t} )    | eqType boolTy t = True+hasBoolResult (FunTy { ft_res = t} )    = hasBoolResult t hasBoolResult _              = False
src/Language/Haskell/Liquid/Bare/Plugged.hs view
@@ -14,12 +14,15 @@ 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 Language.Haskell.Liquid.GHC.Misc  as GM  import qualified Language.Haskell.Liquid.GHC.API   as Ghc -import           Language.Haskell.Liquid.Types.RefType (updateRTVar, addTyConInfo, ofType, rTyVar, subts, toType, uReft)+import           Language.Haskell.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@@ -45,7 +48,7 @@ --   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 :: ModName -> F.TCEmb Ghc.TyCon -> TyConMap -> Ghc.NameSet+makePluggedSig :: ModName -> F.TCEmb Ghc.TyCon -> TyConMap -> S.HashSet StableName                -> Bare.PlugTV Ghc.Var -> LocSpecType                -> LocSpecType @@ -85,23 +88,30 @@   | mismatchFlds      = Ex.throw (err "fields")   | mismatchTyVars    = Ex.throw (err "type variables")   | otherwise         = F.atLoc ldcp $ F.notracepp "makePluggedDataCon" $ dcp -                          { dcpTyArgs     = reverse tArgs +                          { dcpFreeTyVars = dcVars+                          , dcpTyArgs     = reverse tArgs                            , dcpTyRes      = tRes                            }   where      (tArgs, tRes)     = plugMany       embs tyi ldcp (das, dts, dt) (dcVars, dcArgs, dcpTyRes dcp)     (das, _, dts, dt) = {- F.notracepp ("makePluggedDC: " ++ F.showpp dc) $ -} Ghc.dataConSig dc-    dcArgs            = reverse (dcpTyArgs dcp)-    dcVars            = dcpFreeTyVars dcp +    dcArgs            = filter (not . isClassType . snd) $ reverse (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@. @@ -126,9 +136,8 @@                      = F.notracepp msg (drop nTyVars (zip xs ts), t)    where      (_,(xs,ts,_), t) = bkArrow (val pT) -    -- pRep             = toRTypeRep (val pT)     pT               = plugHoles (Bare.LqTV dcName) embs tyi (const killHoles) hsT (F.atLoc ldcp lqT)-    hsT              = foldr Ghc.mkFunTy    hsRes hsArgs' +    hsT              = foldr (Ghc.mkFunTy Ghc.VisArg) hsRes hsArgs'      lqT              = foldr (uncurry rFun) lqRes lqArgs'      hsArgs'          = [ Ghc.mkTyVarTy a               | a <- hsAs] ++ hsArgs      lqArgs'          = [(F.dummySymbol, RVar a mempty) | a <- lqAs] ++ lqArgs @@ -149,27 +158,27 @@ -- NOTE: this use of toType is safe as rt' is derived from t. plugHoles_old tce tyi x f t0 zz@(Loc l l' st0)      = Loc l l' -    . mkArrow (updateRTVar <$> αs) ps' (ls1 ++ ls2) [] [] +    . 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 (toType rt) st err of+    tyvsmap      = case Bare.runMapTyVars (toType 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) <- cs ] -    (αs,_,ls1,cs,rt)  = bkUnivClass (F.notracepp "hs-spec" $ ofType (Ghc.expandTypeSynonyms t0) :: SpecType)-    (_,ps,ls2,_ ,st)  = bkUnivClass (F.notracepp "lq-spec" st0)-    -- msg i             = "plugHoles_old: " ++ F.showpp x ++ " " ++ i +    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 ] +    (αs', rs)    = unzip αs+    (αs,_,cs,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) t cs-    err hsT lqT       = ErrMismatch (GM.fSrcSpan zz) (pprint x) +    makeCls cs t = foldr (uncurry rFun) t cs+    err hsT lqT  = ErrMismatch (GM.fSrcSpan zz) (pprint x)                            (text "Plugged Init types old")                           (pprint $ Ghc.expandTypeSynonyms t0)                           (pprint $ toRSort st0)@@ -179,23 +188,24 @@  plugHoles_new tce tyi x f t0 zz@(Loc l l' st0)      = Loc l l' -    . mkArrow (updateRTVar <$> as') ps (ls1 ++ ls2) [] [] +    . mkArrow (zip (updateRTVar <$> as'') rs) ps [] []      . makeCls cs'      . goPlug tce tyi err f rt'      $ st    where -    rt'               = tx rt-    as'               = subRTVar su <$> as-    cs'               = [ (F.dummySymbol, ct) | (c, t) <- cs, let ct = tx (RApp c t [] mempty) ]-    tx                = subts su-    su                = case Bare.runMapTyVars (toType rt) st err of+    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 (toType rt) st err of                           Left e  -> Ex.throw e                            Right s -> [ (rTyVar x, y) | (x, y) <- Bare.vmap s]-    (as,_,ls1,cs,rt)  = bkUnivClass (ofType (Ghc.expandTypeSynonyms t0) :: SpecType)-    (_,ps,ls2,_ ,st)  = bkUnivClass st0+    (as,_,cs,rt) = bkUnivClass (ofType (Ghc.expandTypeSynonyms t0) :: SpecType)+    (_,ps,_ ,st) = bkUnivClass st0 -    makeCls cs t      = foldr (uncurry rFun) t cs-    err hsT lqT       = ErrMismatch (GM.fSrcSpan zz) (pprint x) +    makeCls cs t = foldr (uncurry rFun) t cs+    err hsT lqT  = ErrMismatch (GM.fSrcSpan zz) (pprint x)                            (text "Plugged Init types new")                           (pprint $ Ghc.expandTypeSynonyms t0)                           (pprint $ toRSort st0)@@ -205,14 +215,6 @@ subRTVar :: [(RTyVar, RTyVar)] -> SpecRTVar -> SpecRTVar  subRTVar su a@(RTVar v i) = Mb.maybe a (`RTVar` i) (lookup v su) ---bkUnivClass :: SpecType -> ([SpecRTVar],[PVar RSort], [F.Symbol], [(RTyCon, [SpecType])], SpecType )-bkUnivClass t        = (as, ps, ls, cs, t2) -  where -    (as, ps, ls, t1) = bkUniv  t-    (cs, t2)         = bkClass t1- goPlug :: F.TCEmb Ghc.TyCon -> Bare.TyConMap -> (Doc -> Doc -> Error) -> (SpecType -> RReft -> RReft) -> SpecType -> SpecType        -> SpecType goPlug tce tyi err f = go @@ -230,10 +232,9 @@     go (RVar _ _)       v@(RVar _ _)       = v     go t'               (RImpF x i o r)    = RImpF x i  (go t' o)             r     go (RFun _ i o _)   (RFun x i' o' r)   = RFun x     (go i i')   (go o o') r-    go (RAllT _ t)      (RAllT a t')       = RAllT a    (go t t')-    go (RAllT a t)      t'                 = RAllT a    (go t t')+    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                (RAllS s t')       = RAllS s    (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')@@ -256,7 +257,7 @@     RApp c' _ ps _ = addTyConInfo tce tyi (RApp c ts [] r) addRefs _ _ t  = t -maybeTrue :: Ghc.NamedThing a => a -> ModName -> Ghc.NameSet -> SpecType -> RReft -> RReft+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@@ -265,7 +266,7 @@   where     inTarget    = Ghc.moduleName (Ghc.nameModule name) == getModName target     name        = Ghc.getName x-    notExported = not (Ghc.getName x `Ghc.elemNameSet` exports)+    notExported = not (mkStableName (Ghc.getName x) `S.member` exports)  -- killHoles r@(U (Reft (v, rs)) _ _) = r { ur_reft = Reft (v, filter (not . isHole) rs) } 
src/Language/Haskell/Liquid/Bare/Resolve.hs view
@@ -57,6 +57,7 @@ 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 @@ -69,7 +70,8 @@ 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.Types.Specs +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   @@ -87,8 +89,8 @@   , reSyms      = syms    , _reSubst    = makeVarSubst   src    , _reTyThings = makeTyThingMap src -  , reQualImps  = gsQualImps     src-  , reAllImps   = gsAllImps      src+  , reQualImps  = _gsQualImps     src+  , reAllImps   = _gsAllImps      src   , reLocalVars = makeLocalVars  src    , reSrc       = src   , reGlobSyms  = S.fromList     globalSyms @@ -109,7 +111,7 @@     mbName = F.val . msName  makeLocalVars :: GhcSrc -> LocalVars -makeLocalVars = localVarMap . localBinds . giCbs+makeLocalVars = localVarMap . localBinds . _giCbs  -- TODO: rewrite using CoreVisitor localBinds :: [Ghc.CoreBind] -> [Ghc.Var]@@ -152,7 +154,7 @@                        , v        <- Mb.maybeToList (okUnqualified me mxs)                         , not (isWiredInName x)                    ] -    me           = F.symbol (giTargetMod src) +    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. @@ -208,7 +210,7 @@  srcThings :: GhcSrc -> [Ghc.TyThing]  srcThings src = myTracepp "SRCTHINGS" -              $ Misc.hashNubWith F.showpp (gsTyThings src ++ mySrcThings src) +              $ Misc.hashNubWith F.showpp (_gsTyThings src ++ mySrcThings src)   mySrcThings :: GhcSrc -> [Ghc.TyThing]  mySrcThings src = [ Ghc.AnId   x | x <- vars ] @@ -222,9 +224,9 @@  srcTyCons :: GhcSrc -> [Ghc.TyCon] srcTyCons src = concat -  [ gsTcs     src -  , gsFiTcs   src -  , gsPrimTcs src+  [ _gsTcs     src +  , _gsFiTcs   src +  , _gsPrimTcs src   , srcVarTcs src    ] @@ -240,7 +242,7 @@     tops     = Mb.maybeToList . Ghc.tyConAppTyCon_maybe     inners   = concatMap typeTyCons . snd . Ghc.splitAppTys  --- | We prioritize the @Ghc.Var@ in @srcVars@ because @giDefVars@ and @gsTyThings@ +-- | 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@@ -249,11 +251,11 @@  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 ]+  [ 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)@@ -411,12 +413,11 @@ substEnv env name l bs = F.substa (qualifySymbol env name l bs)   instance Qualify SpecType where -  qualify = substFreeEnv           +  qualify x1 x2 x3 x4 x5 = emapReft (substFreeEnv x1 x2 x3) x4 x5              instance Qualify BareType where -  qualify = substFreeEnv +  qualify x1 x2 x3 x4 x5 = emapReft (substFreeEnv x1 x2 x3) x4 x5  --- Do not substitute variables bound e.g. by function types 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)  @@ -518,7 +519,7 @@ ------------------------------------------------------------------------------- class ResolveSym a where    resolveLocSym :: Env -> ModName -> String -> LocSymbol -> Either UserError a -  + instance ResolveSym Ghc.Var where    resolveLocSym = resolveWith "variable" $ \case                      Ghc.AnId x -> Just x @@ -534,11 +535,68 @@                     Ghc.AConLike (Ghc.RealDataCon x) -> Just x                      _                                -> Nothing -instance ResolveSym F.Symbol where -  resolveLocSym env name _ lx = case resolveLocSym env name "Var" lx of -    Left _               -> Right (val lx)-    Right (v :: Ghc.Var) -> Right (F.symbol v) +{- 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              -> Either UserError a  resolveWith kind f env name str lx =@@ -599,8 +657,8 @@   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)+    tgtFile = _giTarget (reSrc env)+    incDir  = _giIncDir (reSrc env)     fileMb  = Errors.srcSpanFileMb (GM.fSrcSpan lx)   lookupThings :: Env -> F.Symbol -> [(F.Symbol, Ghc.TyThing)] @@ -622,10 +680,33 @@      && 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          = []  +     | otherwise          = []      where -       isExt              = allowExt && any (`F.isPrefixOfSym` defName) ms+       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 @@ -767,11 +848,10 @@     go bs (RImpF x t1 t2 r) = goRImpF bs x t1 t2 r      go bs (RFun  x t1 t2 r) = goRFun  bs x t1 t2 r      go bs (RVar a r)        = RVar (RT.bareRTyVar a) <$> goReft bs r-    go bs (RAllT a t)       = RAllT a' <$> go bs t +    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 (RAllS x t)       = RAllS x  <$> go bs t     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@@ -906,7 +986,7 @@       t  = ofRSort (pvType p) `RT.strengthen` r       xs = spliceArgs "addSymSortRef 1" s p -addSymSortRef' sp rc i p (RProp _ (RHole r@(MkUReft _ (Pr [up]) _)))+addSymSortRef' sp rc i p (RProp _ (RHole r@(MkUReft _ (Pr [up]))))   | length xs == length ts   = RProp xts (RHole r)   | otherwise@@ -948,7 +1028,7 @@     (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)+    cbs                    = _giCbs (reSrc env)  replaceVisitor :: CoreVisitor SymMap SigMap  replaceVisitor = CoreVisitor 
src/Language/Haskell/Liquid/Bare/ToBare.hs view
@@ -54,9 +54,8 @@   where     -- go :: RType c1 tv1 r -> RType c2 tv2 r     go (RVar α r)          = RVar  (vF α) r-    go (RAllT α t)         = RAllT (goRTV α) (go t)+    go (RAllT α t r)       = RAllT (goRTV α) (go t) r     go (RAllP π t)         = RAllP (goPV  π) (go t)-    go (RAllS s t)         = RAllS s         (go t)     go (RImpF x t t' r)     = RImpF  x         (go t) (go t') r     go (RFun x t t' r)     = RFun  x         (go t) (go t') r     go (RAllE x t t')      = RAllE x         (go t) (go t')
src/Language/Haskell/Liquid/Bare/Types.hs view
@@ -35,9 +35,10 @@ 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 +import           Language.Haskell.Liquid.Types.Types+import           Language.Haskell.Liquid.Types.Specs   hiding (BareSpec) import           Language.Haskell.Liquid.GHC.API       as Ghc hiding (Located) +import           Language.Haskell.Liquid.GHC.Types     (StableName)   type ModSpecs = M.HashMap ModName Ms.BareSpec@@ -97,7 +98,7 @@ data SigEnv = SigEnv    { sigEmbs       :: !(F.TCEmb Ghc.TyCon)    , sigTyRTyMap   :: !RT.TyConMap -  , sigExports    :: !Ghc.NameSet+  , sigExports    :: !(S.HashSet StableName)   , sigRTEnv      :: !BareRTEnv   } @@ -152,4 +153,4 @@               else Nothing   isTargetModName :: Env -> ModName -> Bool -isTargetModName env name = name == giTargetMod (reSrc env) +isTargetModName env name = name == _giTargetMod (reSrc env) 
+ src/Language/Haskell/Liquid/Cabal.hs view
@@ -0,0 +1,21 @@+{- | This module provides a drop-in replacement for Cabal's 'defaultMain', to be used inside 'Setup.hs'+     modules of packages that wants to use the \"dev mode\". For more information, visit the documentation,+     especially the \"Developers' guide\".+-}++{-# LANGUAGE LambdaCase #-}+module Language.Haskell.Liquid.Cabal (liquidHaskellMain) where++import Distribution.Simple+import System.Environment++liquidHaskellMain :: IO ()+liquidHaskellMain = do+  mbDevMode <- lookupEnv "LIQUID_DEV_MODE"+  defaultMainWithHooks (devModeHooks mbDevMode)++devModeHooks :: Maybe String -> UserHooks+devModeHooks = \case+  Nothing               -> simpleUserHooks+  Just x | x == "false" -> simpleUserHooks+  Just _                -> simpleUserHooks { buildHook = \_ _ _ _ -> return () }
src/Language/Haskell/Liquid/Constraint/Env.hs view
@@ -189,11 +189,12 @@   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+    => CGEnv -> F.Templates -> RRType r -> F.SortedReft rTypeSortedReft' γ t    = pruneUnsortedReft (feEnv $ fenv γ) t . f-  where-    f         = rTypeSortedReft (emb γ)+   where+   f         = rTypeSortedReft (emb γ)+  normalize :: Integer -> SpecType -> SpecType normalize idx = normalizeVV idx . normalizePds
src/Language/Haskell/Liquid/Constraint/Fresh.hs view
@@ -106,7 +106,7 @@        | otherwise  = {- F.tracepp ("addKuts: " ++ showpp _x) -} ks'  specTypeKVars :: SpecType -> [F.KVar]-specTypeKVars = foldReft (\ _ r ks -> (kvars $ ur_reft r) ++ ks) []+specTypeKVars = foldReft False (\ _ r ks -> (kvars $ ur_reft r) ++ ks) []  -------------------------------------------------------------------------------- trueTy  :: Type -> CG SpecType@@ -129,7 +129,7 @@   = exprRefType_ (bindRefType_ γ b) e  exprRefType_ γ (Lam α e) | isTyVar α-  = RAllT (makeRTVar $ rTyVar α) (exprRefType_ γ e)+  = RAllT (makeRTVar $ rTyVar α) (exprRefType_ γ e) mempty  exprRefType_ γ (Lam x e)   = rFun (F.symbol x) (ofType $ varType x) (exprRefType_ γ e)
src/Language/Haskell/Liquid/Constraint/Generate.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP                       #-} {-# LANGUAGE DeriveFoldable            #-} {-# LANGUAGE DeriveTraversable         #-} {-# LANGUAGE StandaloneDeriving        #-}@@ -18,8 +19,12 @@ -- | 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 ) where+module Language.Haskell.Liquid.Constraint.Generate ( generateConstraints, generateConstraintsWithEnv, caseEnv, consE ) where +#if !MIN_VERSION_base(4,14,0)+import Control.Monad.Fail+#endif+ import           Outputable                                    (Outputable) import           Prelude                                       hiding (error) import           GHC.Stack@@ -35,17 +40,13 @@ import           TyCon import           CoAxiom import           PrelNames-import           Language.Haskell.Liquid.GHC.TypeRep-import           Class                                         (className)-import           Var+import           Language.Haskell.Liquid.GHC.API               as Ghc hiding (exprType)+import           Language.Haskell.Liquid.GHC.TypeRep           () import           IdInfo-import           Name        hiding (varName)-import           FastString (fastStringToByteString) import           Unify import           UniqSet (mkUniqSet) import           Text.PrettyPrint.HughesPJ hiding ((<>))  import           Control.Monad.State-import           Control.Monad.Fail  import           Data.Maybe                                    (fromMaybe, catMaybes, isJust) import qualified Data.HashMap.Strict                           as M import qualified Data.HashSet                                  as S@@ -57,7 +58,6 @@ import           Language.Fixpoint.Types.Visitor import qualified Language.Fixpoint.Types                       as F import qualified Language.Fixpoint.Types.Visitor               as F--- import           Language.Fixpoint.Solver.Instantiate import           Language.Haskell.Liquid.Constraint.Fresh import           Language.Haskell.Liquid.Constraint.Init import           Language.Haskell.Liquid.Constraint.Env@@ -67,57 +67,49 @@ import           Language.Haskell.Liquid.GHC.Play          (isHoleVar)  import qualified Language.Haskell.Liquid.GHC.Resugar           as Rs import qualified Language.Haskell.Liquid.GHC.SpanStack         as Sp-import           Language.Haskell.Liquid.Types                 hiding (binds, Loc, loc, Def)-import           Language.Haskell.Liquid.Types.Names       (anyTypeSymbol)--- import           Language.Haskell.Liquid.Types.Strata--- import qualified Language.Haskell.Liquid.Types.RefType         as RT--- import           Language.Haskell.Liquid.Types.PredType        hiding (freeTyVars)--- import           Language.Haskell.Liquid.Types.Literals import qualified Language.Haskell.Liquid.GHC.Misc         as GM -- ( isInternal, collectArguments, tickSrcSpan, showPpr ) import           Language.Haskell.Liquid.Misc--- NOPROVER import           Language.Haskell.Liquid.Constraint.Axioms 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) import           Language.Haskell.Liquid.Bare.DataType (makeDataConChecker) +import           Language.Haskell.Liquid.Types hiding (binds, Loc, loc, Def)+ -------------------------------------------------------------------------------- -- | Constraint Generation: Toplevel ------------------------------------------- ---------------------------------------------------------------------------------generateConstraints      :: GhcInfo -> CGInfo+generateConstraints      :: TargetInfo -> CGInfo -------------------------------------------------------------------------------- generateConstraints info = {-# SCC "ConsGen" #-} execState act $ initCGI cfg info   where-    act                  = consAct cfg info+    act                  = do { γ <- initEnv info; consAct γ cfg info }     cfg                  = getConfig   info -consAct :: Config -> GhcInfo -> CG ()-consAct cfg info = do-  γ       <- initEnv      info-  sflag   <- scheck   <$> get+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)   mapM (consClass γ) (gsMethods $ gsSig $ giSpec info) -  hcs    <- hsCs  <$> get-  hws    <- hsWfs <$> get-  scss   <- sCs   <$> get-  annot  <- annotMap <$> get-  scs    <- if sflag then concat <$> mapM splitS (hcs ++ scss)-                    else return []-  let smap = if sflag then solveStrata scs else []-  let hcs' = if sflag then subsS smap hcs else hcs-  fcs <- concat <$> mapM splitC (subsS smap hcs')+  hcs <- hsCs  <$> get+  hws <- hsWfs <$> get+  fcs <- concat <$> mapM splitC hcs   fws <- concat <$> mapM splitW hws-  let annot' = if sflag then subsS smap <$> annot else annot   modify $ \st -> st { fEnv     = feEnv (fenv γ)                      , cgLits   = litEnv   γ                      , cgConsts = (cgConsts st) `mappend` (constEnv γ)                      , fixCs    = fcs-                     , fixWfs   = fws-                     , annotMap = annot' }+                     , fixWfs   = fws }   @@ -182,7 +174,7 @@         xts  = zip (ty_binds trep) (ty_args trep)         trep = toRTypeRep $ unOCons t -checkIndex :: (NamedThing t, PPrint t, PPrint [a])+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)@@ -205,20 +197,20 @@ makeRecType autoenv t vs dxs is   = mergecondition t $ fromRTypeRep $ trep {ty_binds = xs', ty_args = ts'}   where-    (xs', ts') = unzip $ replaceN (last is) (makeDecrType autoenv vdxs) xts+    (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)        = RAllT v $ unOCons t+unOCons (RAllT v t r)      = RAllT v (unOCons t) r  unOCons (RAllP p t)        = RAllP p $ unOCons t unOCons (RFun x tx t r)    = RFun x (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)               = RAllT v (mergecondition t1 t2)+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 t21 t22 r2) = RFun x2 (mergecondition t11 t21) (mergecondition t12 t22) r2@@ -229,7 +221,7 @@   | n >= length ls = addWarning err >> return Nothing   | otherwise      = return $ Just $ ls !! n -checkHint :: (NamedThing a, PPrint a, PPrint [a1])+checkHint :: (NamedThing a, PPrint a, PPrint a1)           => a -> [a1] -> (a1 -> Bool) -> Maybe [Int] -> CG (Maybe [Int]) checkHint _ _ _ Nothing   = return Nothing@@ -243,7 +235,7 @@ checkHint x ts f (Just ns)   = (mapM (checkValidHint x ts f) ns) >>= (return . Just . catMaybes) -checkValidHint :: (NamedThing a, PPrint a, PPrint [a1])+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@@ -271,7 +263,7 @@ -------------------------------------------------------------------------------- -- | Constraint Generation: Corebind ------------------------------------------- ---------------------------------------------------------------------------------consCBTop :: Config -> GhcInfo -> CGEnv -> CoreBind -> CG CGEnv+consCBTop :: Config -> TargetInfo -> CGEnv -> CoreBind -> CG CGEnv -------------------------------------------------------------------------------- consCBTop cfg info γ cb   | all (trustVar cfg info) xs@@ -296,10 +288,10 @@       topBind (Rec [(v,_)]) = Just v       topBind _             = Nothing -trustVar :: Config -> GhcInfo -> Var -> Bool+trustVar :: Config -> TargetInfo -> Var -> Bool trustVar cfg info x = not (checkDerived cfg) && derivedVar (giSrc info) x -derivedVar :: GhcSrc -> Var -> Bool+derivedVar :: TargetSrc -> Var -> Bool derivedVar src x = S.member x (giDerVars src)  doTermCheck :: Config -> Bind Var -> CG Bool@@ -317,16 +309,11 @@ -- RJ: AAAAAAARGHHH!!!!!! THIS CODE IS HORRIBLE!!!!!!!!! consCBSizedTys :: CGEnv -> [(Var, CoreExpr)] -> CG CGEnv consCBSizedTys γ xes-  = do xets''    <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))-       sflag     <- scheck <$> get-       autoenv   <- autoSize <$> get-       let cmakeFinType = if sflag then makeFinType else id-       let cmakeFinTy   = if sflag then makeFinTy   else snd-       let xets = mapThd3 (fmap cmakeFinType) <$> xets''-       ts'      <- mapM (T.mapM refreshArgs) $ (thd3 <$> xets)-       let vs    = zipWith collectArgs ts' es-       is       <- mapM makeDecrIndex (zip3 xs ts' vs) >>= checkSameLens-       let ts = cmakeFinTy  <$> zip is ts'+  = do xets     <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))+       autoenv  <- autoSize <$> get+       ts       <- mapM (T.mapM refreshArgs) $ (thd3 <$> xets)+       let vs    = zipWith collectArgs ts es+       is       <- mapM makeDecrIndex (zip3 xs ts vs) >>= checkSameLens        let xeets = (\vis -> [(vis, x) | x <- zip3 xs is $ map unTemplate ts]) <$> (zip vs is)        (L.transpose <$> mapM checkIndex (zip4 xs vs ts is)) >>= checkEqTypes        let rts   = (recType autoenv <$>) <$> xeets@@ -354,12 +341,9 @@  consCBWithExprs :: CGEnv -> [(Var, CoreExpr)] -> CG CGEnv consCBWithExprs γ xes-  = do xets'     <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))+  = do xets     <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))        texprs    <- termExprs <$> get        let xtes   = catMaybes $ (`lookup` texprs) <$> xs-       sflag     <- scheck <$> get-       let cmakeFinType = if sflag then makeFinType else id-       let xets  = mapThd3 (fmap cmakeFinType) <$> xets'        let ts    = safeFromAsserted err . thd3 <$> xets        ts'      <- mapM refreshArgs ts        let xts   = zip xs (Asserted <$> ts')@@ -373,16 +357,6 @@                    | otherwise              = Nothing         err      = "Constant: consCBWithExprs" -makeFinTy :: (Eq a, Functor f, Num a, Foldable t)-          => (t a, f SpecType)-          -> f SpecType-makeFinTy (ns, t) = fmap go t-  where-    go t = fromRTypeRep $ trep {ty_args = args'}-      where-        trep = toRTypeRep t-        args' = mapNs ns makeFinType $ ty_args trep- makeTermEnvs :: CGEnv -> [(Var, [F.Located F.Expr])] -> [(Var, CoreExpr)]              -> [SpecType] -> [SpecType]              -> [CGEnv]@@ -404,9 +378,9 @@     err x        = "Constant: makeTermEnvs: no terminating expression for " ++ GM.showPpr x  addObligation :: Oblig -> SpecType -> RReft -> SpecType-addObligation o t r  = mkArrow αs πs ls yts xts $ RRTy [] r o t2+addObligation o t r  = mkArrow αs πs yts xts $ RRTy [] r o t2   where-    (αs, πs, ls, t1) = bkUniv t+    (αs, πs, t1) = bkUniv t     ((xs',ts',rs'),(xs, ts, rs), t2) = bkArrow t1     xts              = zip3 xs ts rs     yts              = zip3 xs' ts' rs'@@ -432,10 +406,7 @@  -- 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)-       sflag     <- scheck <$> get-       let mkDivT = if sflag then makeDivType else id-       let xets   = mapThd3 (fmap mkDivT) <$> xets'+  = 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@@ -460,6 +431,9 @@        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@@ -470,13 +444,13 @@        t        <- trueTy (varType x)        extender γ' (x, Assumed t)    where-    f t' (RAllT α te) = subsTyVar_meet' (ty_var_value α, t') te+    f t' (RAllT α te _) = subsTyVar_meet' (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 (addRankNBind γ x e) (x, to')+       extender γ (x, makeSingleton γ (simplify e) <$> to')  grepDictionary :: CoreExpr -> Maybe (Var, Type) grepDictionary (App (Var w) (Type t)) = Just (w, t)@@ -491,8 +465,8 @@   = return $ F.notracepp ("TYPE FOR SELECTOR " ++ show x) $ Assumed t  consBind isRec γ (x, e, Asserted spect)-  = do let γ'         = γ `setBind` x-           (_,πs,_,_) = bkUniv spect+  = do let γ'       = γ `setBind` x+           (_,πs,_) = bkUniv spect        γπ    <- foldM addPToEnv γ' πs         -- take implcits out of the function's SpecType and into the env@@ -508,8 +482,8 @@        return $ Asserted spect  consBind isRec γ (x, e, Internal spect)-  = do let γ'         = γ `setBind` x-           (_,πs,_,_) = bkUniv spect+  = do let γ'       = γ `setBind` x+           (_,πs,_) = bkUniv spect        γπ    <- foldM addPToEnv γ' πs        let γπ' = γπ {cerr = Just $ ErrHMeas (getLocation γπ) (pprint x) (text explanation)}        cconsE γπ' e spect@@ -671,20 +645,21 @@  cconsE' γ (Case e x _ cases) t   = do γ'  <- consCBLet γ (NonRec x e)-       forM_ cases $ cconsCase (addArgument γ' x) x t nonDefAlts+       forM_ cases $ cconsCase γ' x t nonDefAlts     where        nonDefAlts = [a | (a, _, _) <- cases, a /= DEFAULT]        _msg = "cconsE' #nonDefAlts = " ++ show (length (nonDefAlts)) -cconsE' γ (Lam α e) (RAllT α' t) | isTyVar α+cconsE' γ (Lam α e) (RAllT α' t r) | isTyVar α   = do γ' <- updateEnvironment γ α+       addForAllConstraint γ' α e (RAllT α' t r)        cconsE γ' e $ subsTyVar_meet' (ty_var_value α', rVar α) t  cconsE' γ (Lam x e) (RFun y ty t r)   | not (isTyVar x)   = do γ' <- γ += ("cconsE", x', ty)-       cconsE (addArgument γ' x) e t'-       addFunctionConstraint (addArgument γ x) x e (RFun x' ty t' r')+       cconsE γ' e t'+       addFunctionConstraint γ x e (RFun x' ty t' r')        addIdA x (AnnDef ty)   where     x'  = F.symbol x@@ -701,26 +676,40 @@  cconsE' γ e@(Cast e' c) t   = do t' <- castTy γ (exprType e) e' c-       addC (SubC γ t' t) ("cconsE Cast: " ++ GM.showPpr e)+       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: " ++ GM.showPpr e)+  = 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 -> UReft F.Reft lambdaSingleton γ tce x e   | higherOrderFlag γ, Just e' <- lamExpr γ e   = uTop $ F.exprReft $ F.ELam (F.symbol x, sx) e'   where-    sx = typeSort tce $ varType x+    sx = typeSort tce $ Ghc.expandTypeSynonyms $ varType x lambdaSingleton _ _ _ _   = mempty +addForAllConstraint :: CGEnv -> Var -> CoreExpr -> SpecType -> CG ()+addForAllConstraint γ _ _ (RAllT a t r)+  | F.isTauto r +  = return ()+  | otherwise+  = do t'       <- true t+       let truet = RAllT a $ unRAllP t'+       addC (SubC γ (truet mempty) $ truet r) "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 ty t r)   = do ty'      <- true ty@@ -786,20 +775,7 @@ instantiatePreds _ _ t0   = return t0 ----------------------------------------------------------------------- | @instantiateStrata@ generates fresh @Strata@ vars and substitutes---   them inside the body of the type.-------------------------------------------------------------------- -instantiateStrata :: (F.Subable b, Freshable f Integer) => [F.Symbol] -> b -> f b-instantiateStrata ls t = substStrata t ls <$> mapM (\_ -> fresh) ls--substStrata :: F.Subable a => a -> [F.Symbol] -> [F.Symbol] -> a-substStrata t ls ls'   = F.substa f t-  where-    f x                = fromMaybe x $ L.lookup x su-    su                 = zip ls ls'- ------------------------------------------------------------------- cconsLazyLet :: CGEnv              -> CoreExpr@@ -825,25 +801,13 @@   , 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.-consE γ e'@(App e@(Var x) (Type τ)) | M.member x (aenv γ)-  = do RAllT α te <- checkAll ("Non-all TyApp with expr", e) γ <$> consE γ e-       t          <- {- PLE-OPT -} if isGeneric γ (ty_var_value α) te && not (isPLETerm γ) -                                     then freshTy_type TypeInstE e τ -                                     else trueTy τ-       addW        $ WfC γ t-       t'         <- refreshVV t-       tt00       <- instantiatePreds γ e' $ subsTyVar_meet' (ty_var_value α, t') te-       let tt      = subsTyReft γ (ty_var_value α) τ tt00-       return      $ strengthenMeet tt (singletonReft (M.lookup x $ aenv γ) x)---- NV END HACK- consE γ (Var x)   = do t <- varRefType γ x        addLocA (Just x) (getLocation γ) (varAnn γ x t)@@ -853,42 +817,43 @@   = refreshVV $ uRType $ literalFRefType c  consE γ e'@(App e a@(Type τ))-  = do RAllT α te <- checkAll ("Non-all TyApp with expr", e) γ <$> consE γ e-       t          <- if isGeneric γ (ty_var_value α) te then freshTy_type TypeInstE e τ else trueTy τ-       addW        $ WfC γ t-       t'         <- refreshVV t-       tt0        <- instantiatePreds γ e' (subsTyVar_meet' (ty_var_value α, t') te)-       let tt      = subsTyReft γ (ty_var_value α) τ tt0-       -- NV TODO: embed this step with subsTyVar_meet'+  = do RAllT α te _ <- checkAll ("Non-all TyApp with expr", e) γ <$> consE γ e+       t            <- if not (nopolyinfer (getConfig γ)) && isPos α && isGenericVar (ty_var_value α) te +                         then freshTy_type TypeInstE e τ +                         else trueTy τ+       addW          $ WfC γ t+       t'           <- refreshVV t+       tt0          <- instantiatePreds γ e' (subsTyVar_meet' (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)+      Just riSig -> return $ fromRISig riSig       _          -> do-        ([], πs, ls, te) <- bkUniv <$> consE γ e-        te0              <- instantiatePreds γ e' $ foldr RAllP te πs-        te'              <- instantiateStrata ls te0-        (γ', te''')      <- dropExists γ te'-        te''             <- dropConstraints γ te'''+        ([], π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''-        pushConsBind      $ cconsE γ' a tx+        cconsE γ' a tx         addPost γ'        $ maybe (checkUnbound γ' e' x t a) (F.subst1 t . (x,)) (argExpr γ a)  consE γ e'@(App e a)-  = do ([], πs, ls, te) <- bkUniv <$> consE γ ({- GM.tracePpr ("APP-EXPR: " ++ GM.showPpr (exprType e)) -} e)-       te0              <- instantiatePreds γ e' $ foldr RAllP te πs-       te'              <- instantiateStrata ls te0-       (γ', te''')      <- dropExists γ te'-       te''             <- dropConstraints γ te'''+  = do ([], πs, te) <- bkUniv <$> consE γ ({- GM.tracePpr ("APP-EXPR: " ++ GM.showPpr (exprType e)) -} e)+       te'          <- instantiatePreds γ e' $ foldr RAllP te πs+       (γ', te''')  <- dropExists γ te'+       te''         <- dropConstraints γ te'''        updateLocA (exprLoc e) te''        (hasGhost, γ'', te''')     <- instantiateGhosts γ' te''        let RFun x tx t _ = checkFun ("Non-fun App with caller ", e') γ te'''-       pushConsBind      $ cconsE γ'' a tx-       tout <- makeSingleton γ'' e' <$> (addPost γ'' $ maybe (checkUnbound γ'' e' x t a) (F.subst1 t . (x,)) (argExpr γ a))+       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   <- freshTy_type ImplictE e' $ exprType e'@@ -899,7 +864,8 @@  consE γ (Lam α e) | isTyVar α   = do γ' <- updateEnvironment γ α-       liftM (RAllT (makeRTVar $ rTyVar α)) (consE γ' e)+       t' <- consE γ' e+       return $ RAllT (makeRTVar $ rTyVar α) t' mempty  consE γ  e@(Lam x e1)   = do tx      <- freshTy_type LamE (Var x) τx@@ -908,9 +874,9 @@        addIdA x $ AnnDef tx        addW     $ WfC γ tx        tce     <- tyConEmbed <$> get-       return   $ RFun (F.symbol x) tx t1 $ lambdaSingleton (addArgument γ x) tce x e1+       return   $ RFun (F.symbol x) tx t1 $ lambdaSingleton γ tce x e1     where-      FunTy τx _ = exprType e+      FunTy { ft_arg = τx } = exprType e  consE γ e@(Let _ _)   = cconsFreshE LetE γ e@@ -1072,9 +1038,17 @@   = castTy' γ t e  -castTy' _ τ (Var x)+castTy' γ τ (Var x)   = do t <- trueTy τ-       return (t `strengthen` (uTop $ F.uexprReft $ F.expr x))+       -- tx <- varRefType γ x -- NV HERE: the refinements of the var x do not get into the +       --                      -- environment. Check +       let ce = 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@@ -1201,17 +1175,14 @@   tdc             <- (γ ??= (dataConWorkId c) >>= refreshVV)   let (rtd,yts',_) = unfoldR tdc xt ys   yts             <- projectTypes pIs yts'-  let ys''         = F.symbol <$> filter (not . GM.isPredVar) ys+  let ys''         = F.symbol <$> filter (not . 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') (xt0 : yts)   cγ'             <- addBinders γ   x' cbs-  cγ              <- addBinders cγ' x' [(x', xt)]-  return           $ addArguments cγ ys-  -- where-    -- ys'' = F.symbol <$> (filter (not . isClassPred . varType) ys)-+  addBinders cγ' x' [(x', xt)]+   caseEnv γ x acs a _ _ = do    let x'  = F.symbol x   xt'    <- (`strengthen` uTop (altReft γ acs a)) <$> (γ ??= x)@@ -1261,8 +1232,8 @@ instantiateTys :: SpecType -> [SpecType] -> SpecType instantiateTys = L.foldl' go   where -    go (RAllT α tbody) t = subsTyVar_meet' (ty_var_value α, t) tbody-    go _ _               = panic Nothing "Constraint.instantiateTy"+    go (RAllT α tbody _) t = subsTyVar_meet' (ty_var_value α, t) tbody+    go _ _                 = panic Nothing "Constraint.instantiateTy"  instantiatePvs :: SpecType -> [SpecProp] -> SpecType instantiatePvs           = L.foldl' go@@ -1279,7 +1250,7 @@ checkFun x g t                = checkErr x g t  checkAll :: (Outputable a) => (String, a) -> CGEnv -> SpecType -> SpecType-checkAll _ _ t@(RAllT _ _)    = t+checkAll _ _ t@(RAllT _ _ _)  = t checkAll x g t                = checkErr x g t  checkErr :: (Outputable a) => (String, a) -> CGEnv -> SpecType -> SpecType@@ -1309,27 +1280,13 @@   ----------------------------------------------------------------------------------- | Helpers: Keep track of polymorphic let bindings  -------------------------------------------------------------------------------------------------------------addRankNBind :: CGEnv -> Var -> CoreExpr -> CGEnv     -addRankNBind γ x e -  | rankNTypes (getConfig γ)-  , isForAllTy (varType x)-  , Just e' <- forallExpr γ e -  = γ {forallcb = M.insert x e' (forallcb γ)}-addRankNBind γ _ _  -  = γ----------------------------------------------------------------------------------- -- | Helpers: Creating Refinement Types For Various Things --------------------- -------------------------------------------------------------------------------- argType :: Type -> Maybe F.Expr argType (LitTy (NumTyLit i))   = mkI i argType (LitTy (StrTyLit s))-  = mkS $ fastStringToByteString s+  = mkS $ bytesFS s argType (TyVarTy x)   = Just $ F.EVar $ F.symbol $ varName x argType t@@ -1340,20 +1297,16 @@   argExpr :: CGEnv -> CoreExpr -> Maybe F.Expr-argExpr γ (Var v)     | M.member v $ aenv γ, higherOrderFlag γ-                      = F.EVar <$> (M.lookup v $ aenv γ)-argExpr _ (Var vy)    = Just $ F.eVar vy+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   -- NIKI TODO: merge arg/lam/fun-Expr lamExpr :: CGEnv -> CoreExpr -> Maybe F.Expr-lamExpr γ (Var v)     | M.member v $ aenv γ-                      = F.EVar <$> (M.lookup v $ aenv γ)-lamExpr γ (Var v)     | S.member v (fargs γ)-                      =  Just $ F.eVar v+lamExpr _ (Var v)     =  Just $ F.eVar v lamExpr γ (Lit c)     = snd  $ literalConst (emb γ) c lamExpr γ (Tick _ e)  = lamExpr γ e lamExpr γ (App e (Type _)) = lamExpr γ e@@ -1362,31 +1315,14 @@                                                  -> Just $ F.EApp p1 p2                               (Just p1, Just _ ) -> Just p1                               _  -> Nothing-lamExpr γ (Let (NonRec x ex) e) = case (lamExpr γ ex, lamExpr (addArgument γ x) e) of+lamExpr γ (Let (NonRec x ex) e) = case (lamExpr γ ex, lamExpr γ e) of                                        (Just px, Just p) -> Just (p `F.subst1` (F.symbol x, px))                                        _  -> Nothing-lamExpr γ (Lam x e)   = case lamExpr (addArgument γ x) e of-                            Just p -> Just $ F.ELam (F.symbol x, typeSort (emb γ) $ varType x) p+lamExpr γ (Lam x e)   = case lamExpr γ e of+                            Just p -> Just $ F.ELam (F.symbol x, typeSort (emb γ) $ Ghc.expandTypeSynonyms $ varType x) p                             _ -> Nothing lamExpr _ _           = Nothing ---forallExpr :: CGEnv -> CoreExpr -> Maybe F.Expr-forallExpr γ (Var v)          | M.member v $ aenv γ, higherOrderFlag γ-                              = F.EVar <$> (M.lookup v $ aenv γ)-forallExpr _ (Var vy)         = Just $ F.eVar vy-forallExpr γ (Lit c)          = snd  $ literalConst (emb γ) c-forallExpr γ (Lam a e)        | isTyVar a -                              = forallExpr γ e -forallExpr γ (Tick _ e)       = forallExpr γ e-forallExpr γ (App e (Type _)) = forallExpr γ e-forallExpr γ (App e1 e2)      = case (forallExpr γ e1, forallExpr γ e2) of-                                  (Just p1, Just p2) -> Just $ F.EApp p1 p2 -                                  _                  -> Nothing -forallExpr _ _                = Nothing-- -------------------------------------------------------------------------------- (??=) :: (?callStack :: CallStack) => CGEnv -> Var -> CG SpecType --------------------------------------------------------------------------------@@ -1413,7 +1349,7 @@   | otherwise   = strengthen t' xr   where-    xr = singletonReft (M.lookup x $ aenv γ) x+    xr = singletonReft x     x' = F.symbol x     strengthen       | higherOrderFlag γ@@ -1430,8 +1366,12 @@                  | not (GM.isPredExpr x) -- (isClassPred $ exprType x)                  -> strengthenMeet t (uTop $ F.exprReft (F.EApp f' x'))       (Just f', Just _)-                 -> strengthenMeet t (uTop $ F.exprReft f' )+                 -> strengthenMeet t (uTop $ F.exprReft f')       _ -> t+  | rankNTypes (getConfig γ)+  = case argExpr γ (simplify e) of +       Just e' -> strengthenMeet t $ (uTop $ F.exprReft e')+       _       -> t     | otherwise   = t   where @@ -1443,14 +1383,10 @@       = argExpr γ e  -funExpr :: CGEnv -> CoreExpr -> Maybe F.Expr --- reflectefd functions-funExpr γ (Var v) | M.member v $ aenv γ-  = F.EVar <$> (M.lookup v $ aenv γ)+funExpr :: CGEnv -> CoreExpr -> Maybe F.Expr --- local function arguments-funExpr γ (Var v) | S.member v (fargs γ) || GM.isDataConId v+funExpr _ (Var v)    = Just $ F.EVar (F.symbol v)  funExpr γ (App e1 e2)@@ -1468,12 +1404,12 @@ 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, F.Symbolic a1) => Maybe a -> a1 -> UReft F.Reft-singletonReft (Just x) _ = uTop $ F.symbolReft x-singletonReft Nothing  v = uTop $ F.symbolReft $ F.symbol v+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@@ -1483,6 +1419,7 @@ strengthenTop (RVar a r) r'        = RVar a       $ F.meet r r' strengthenTop (RFun b t1 t2 r) r'  = RFun b 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!@@ -1491,7 +1428,7 @@ strengthenMeet (RVar a r) r'        = RVar a       (r `F.meet` r') strengthenMeet (RFun b t1 t2 r) r'  = RFun b t1 t2 (r `F.meet` r') strengthenMeet (RAppTy t1 t2 r) r'  = RAppTy t1 t2 (r `F.meet` r')-strengthenMeet (RAllT a t) r'       = RAllT a $ strengthenMeet t 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@@ -1508,16 +1445,6 @@ isType :: Expr CoreBndr -> Bool isType (Type _)                 = True isType a                        = eqType (exprType a) predType---- | @isGeneric@ determines whether the @RTyVar@ CAN and SHOULD be instantiated in a refined manner.-isGeneric :: CGEnv -> RTyVar -> SpecType -> Bool-isGeneric γ α t = isGenericVar α t && not (isPLETerm γ)---- | @isPLETerm γ@ returns @True@ if the "currrent" top-level binder in γ has PLE enabled.-isPLETerm :: CGEnv -> Bool  -isPLETerm γ -  | Just x <- cgVar γ = {- F.tracepp ("isPLEVar:" ++ F.showpp x) $ -} isPLEVar (giSpec . cgInfo $ γ) x -  | otherwise         = False   -- | @isGenericVar@ determines whether the @RTyVar@ has no class constraints isGenericVar :: RTyVar -> SpecType -> Bool
src/Language/Haskell/Liquid/Constraint/Init.hs view
@@ -23,7 +23,6 @@ import           TyCon import           Var import           Id                                           -- hiding (isExportedId)--- import           IdInfo import           Name        hiding (varName) import           Control.Monad.State import           Data.Maybe                                    (isNothing, fromMaybe, catMaybes)@@ -33,28 +32,20 @@ import           Data.Bifunctor import qualified Language.Fixpoint.Types                       as F -import           Language.Haskell.Liquid.UX.Config (terminationCheck) 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 Language.Haskell.Liquid.GHC.SpanStack         as Sp--- import           Language.Haskell.Liquid.GHC.Interface         (isExportedVar)-import           Language.Haskell.Liquid.Types                 hiding (binds, Loc, loc, freeTyVars, Def)--- import           Language.Haskell.Liquid.Types.Names--- import           Language.Haskell.Liquid.Types.RefType--- import           Language.Haskell.Liquid.Types.Visitors        hiding (freeVars)--- import           Language.Haskell.Liquid.Types.Meet--- import           Language.Haskell.Liquid.Types.Literals import           Language.Haskell.Liquid.GHC.Misc             ( idDataConM, hasBaseTypeVar, isDataConId) -- dropModuleNames, simplesymbol) import           Language.Haskell.Liquid.Misc import           Language.Fixpoint.Misc import           Language.Haskell.Liquid.Constraint.Types --- import Debug.Trace (trace)+import           Language.Haskell.Liquid.Types hiding (binds, Loc, loc, freeTyVars, Def)  ---------------------------------------------------------------------------------initEnv :: GhcInfo -> CG CGEnv+initEnv :: TargetInfo -> CG CGEnv -------------------------------------------------------------------------------- initEnv info   = do let tce   = gsTcEmbeds (gsName sp)@@ -71,24 +62,24 @@        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       <- refreshArgs' $ vals gsAsmSigs (gsSig sp)                  -- assumed refinedments     (with `assume`)+       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)-       sflag    <- scheck <$> get-       let senv  = if sflag then f2 else []-       let tx    = mapFst F.symbol . addRInv ialias . strataUnify senv . predsUnify sp+       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     <- F.toListSEnv . cgLits <$> get        let lt2s  = [ (F.symbol x, rTypeSort tce t) | (x, t) <- f1' ]        let tcb   = mapSnd (rTypeSort tce) <$> concat bs        let cbs   = giCbs . giSrc $ info-       let γ0    = measEnv sp (head bs) cbs tcb lt1s lt2s (bs!!3) (bs!!5) hs info-       γ  <- globalize <$> foldM (+=) γ0 ( [("initEnv", x, y) | (x, y) <- concat $ tail bs])+       rTrue   <- mapM (mapSndM true) 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     sp           = giSpec info@@ -97,7 +88,17 @@     mapSndM f    = \(x,y) -> ((x,) <$> f y)     makeExactDc dcs = if exactDCFlag info then map strengthenDataConType dcs else dcs     is autoinv   = mkRTyConInv    (gsInvariants (gsData sp) ++ ((Nothing,) <$> autoinv))+    addPolyInfo' = if reflection (getConfig info) then map (mapSnd addPolyInfo) else id  +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 :: Var -> CG (Var, SpecType) makeDataConTypes x = (x,) <$> (trueTy $ varType x) @@ -114,7 +115,7 @@       = []      simplify invs = dummyLoc . (`strengthen` invariant) .  fmap (\_ -> mempty) <$> L.nub invs-    invariant = MkUReft (F.Reft (F.vv_, F.PAtom F.Ge (lenOf F.vv_) (F.ECon $ F.I 0)) ) mempty mempty+    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@@ -128,7 +129,7 @@       x      = dataConWorkId x'       t      = fromMaybe (impossible Nothing "makeSizedDataCons: this should never happen") $ L.lookup x dcts       trep   = toRTypeRep t-      tres   = ty_res trep `strengthen` MkUReft (F.Reft (F.vv_, F.PAtom F.Eq (lenOf F.vv_) computelen)) mempty mempty+      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)@@ -148,19 +149,14 @@ refreshArgs' :: [(a, SpecType)] -> CG [(a, SpecType)] refreshArgs' = mapM (mapSndM refreshArgs) -strataUnify :: [(Var, SpecType)] -> (Var, SpecType) -> (Var, SpecType)-strataUnify senv (x, t) = (x, maybe t (mappend t) pt)-  where-    pt                  = fmap (\(MkUReft _ _ l) -> MkUReft mempty mempty l) <$> L.lookup x senv - -- | 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 :: GhcSpec -> (Var, RRType RReft) -> (Var, RRType RReft)+predsUnify :: TargetSpec -> (Var, RRType RReft) -> (Var, RRType RReft) predsUnify sp = second (addTyConInfo tce tyi) -- needed to eliminate some @RPropH@   where     tce            = gsTcEmbeds (gsName sp)@@ -168,7 +164,7 @@   ---------------------------------------------------------------------------------measEnv :: GhcSpec+measEnv :: TargetSpec         -> [(F.Symbol, SpecType)]         -> [CoreBind]         -> [(F.Symbol, F.Sort)]@@ -177,7 +173,7 @@         -> [(F.Symbol, SpecType)]         -> [(F.Symbol, SpecType)]         -> [F.Symbol]-        -> GhcInfo+        -> TargetInfo         -> CGEnv -------------------------------------------------------------------------------- measEnv sp xts cbs _tcb lt1s lt2s asms itys hs info = CGE@@ -189,7 +185,6 @@   , fenv     = initFEnv $ filterHO (tcb' ++ lts ++ (second (rTypeSort tce . val) <$> gsMeas (gsData sp)))   , denv     = dmapty val $ gsDicts (gsSig sp)   , recs     = S.empty-  , fargs    = S.empty   , invs     = mempty   , rinvs    = mempty   , ial      = mkRTyConIAl (gsIaliases (gsData sp))@@ -204,7 +199,6 @@   , forallcb = M.empty   , holes    = fromListHEnv hs   , lcs      = mempty-  , aenv     = axEnv (gsRefl sp)   , cerr     = Nothing   , cgInfo   = info   , cgVar    = Nothing@@ -214,43 +208,41 @@       filterHO xs = if higherOrderFlag sp then xs else filter (F.isFirstOrder . snd) xs       lts         = lt1s ++ lt2s       tcb'        = []-      axEnv sp    = M.union (M.mapWithKey (fromMaybe . F.symbol) $ lmVarSyms $ gsLogicMap sp)-                            (M.fromList [(v, F.symbol v) | v <- gsReflects sp])  -assm :: GhcInfo -> [(Var, SpecType)]+assm :: TargetInfo -> [(Var, SpecType)] assm = assmGrty (giImpVars . giSrc) -grty :: GhcInfo -> [(Var, SpecType)]+grty :: TargetInfo -> [(Var, SpecType)] grty = assmGrty (giDefVars . giSrc)  -assmGrty :: (GhcInfo -> [Var]) -> GhcInfo -> [(Var, SpecType)]+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 :: GhcInfo -> CG [(Var, SpecType)]+recSelectorsTy :: TargetInfo -> CG [(Var, SpecType)] recSelectorsTy info = forM topVs $ \v -> (v,) <$> trueTy (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 ++ gsInSigs sp]+    sigVs        = S.fromList [v | (v,_) <- gsTySigs sp ++ gsAsmSigs sp ++ gsRefSigs sp ++ gsInSigs sp]     sp           = gsSig . giSpec $ info       -grtyTop :: GhcInfo -> CG [(Var, SpecType)]+grtyTop :: TargetInfo -> CG [(Var, SpecType)] grtyTop info     = forM topVs $ \v -> (v,) <$> trueTy (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 ++ gsInSigs sp]+    sigVs        = S.fromList [v | (v,_) <- gsTySigs sp ++ gsAsmSigs sp ++ gsRefSigs sp ++ gsInSigs sp]     sp           = gsSig . giSpec $ info  -infoLits :: (GhcSpec -> [(F.Symbol, LocSpecType)]) -> (F.Sort -> Bool) -> GhcInfo -> F.SEnv F.Sort+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@@ -259,14 +251,12 @@     tce       = gsTcEmbeds (gsName spc)     mkSort    = mapSnd (F.sr_sort . rTypeSortedReft tce . val) -initCGI :: Config -> GhcInfo -> CGInfo+initCGI :: Config -> TargetInfo -> CGInfo initCGI cfg info = CGInfo {     fEnv       = F.emptySEnv   , hsCs       = []-  , sCs        = []   , hsWfs      = []   , fixCs      = []-  , isBind     = []   , fixWfs     = []   , freshIndex = 0   , dataConTys = []@@ -288,7 +278,6 @@   , specLazy   = dictionaryVar `S.insert` (gsLazy tspc)   , specTmVars = gsNonStTerm tspc   , tcheck     = terminationCheck cfg-  , scheck     = strata cfg   , pruneRefs  = pruneUnsorted cfg   , logErrors  = []   , kvProf     = emptyKVProf@@ -307,7 +296,7 @@     nspc       = gsName spc     notFn      = isNothing . F.functionSort -coreBindLits :: F.TCEmb TyCon -> GhcInfo -> [(F.Symbol, F.Sort)]+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
src/Language/Haskell/Liquid/Constraint/Monad.hs view
@@ -15,7 +15,6 @@ import           Outputable hiding (showPpr, panic, (<>), showSDoc, text)  import qualified TyCon as TC-import           Text.PrettyPrint.HughesPJ (text)  import qualified Data.HashMap.Strict as M import qualified Data.Text           as T@@ -23,45 +22,23 @@ import           Control.Monad import           Control.Monad.State (get, modify) import           Language.Haskell.Liquid.Types hiding (loc)--- import           Language.Haskell.Liquid.Types.RefType import           Language.Haskell.Liquid.Constraint.Types import           Language.Haskell.Liquid.Constraint.Env import           Language.Fixpoint.Misc hiding (errorstar)--- import qualified Language.Fixpoint.Types.PrettyPrint as F  import           Language.Haskell.Liquid.GHC.Misc -- (concatMapM) import           Language.Haskell.Liquid.GHC.SpanStack (srcSpan)-import qualified Language.Haskell.Liquid.GHC.API            as Ghc  ----------------------------------------------------------------------------------- RJ: What is this `isBind` business?----------------------------------------------------------------------------------pushConsBind :: CG a -> CG a----------------------------------------------------------------------------------pushConsBind act-  = do modify $ \s -> s { isBind = False : isBind s }-       z <- act-       modify $ \s -> s { isBind = tail (isBind s) }-       return z---------------------------------------------------------------------------------- -- | `addC` adds a subtyping constraint into the global pool. -------------------------------------------------------------------------------- addC :: SubC -> String -> CG () -------------------------------------------------------------------------------- addC c@(SubC γ t1 t2) _msg   | toType t1 /= toType t2-  = panic (Just $ getLocation γ) $ "addC: malformed constraint:\n" ++ showpp t1 ++ "\n <: \n" ++ showpp t2 -  --     ++ "\n\n" ++ showTy (toType t1) ++ "\n /=\n" ++ showTy (toType t2)+  = panic (Just $ getLocation γ) $ "addC: malformed constraint:\n" ++ _msg ++ showpp t1 ++ "\n <: \n" ++ showpp t2    | otherwise-  = do modify $ \s -> s { hsCs  = c : (hsCs s) }-       bflag <- headDefault True . isBind <$> get-       sflag <- scheck                    <$> get-       if bflag && sflag-         then modify $ \s -> s {sCs = (SubC γ t2 t1) : (sCs s) }-         else return ()-  where-    headDefault a []    = a-    headDefault _ (x:_) = x+  = modify $ \s -> s { hsCs  = c : (hsCs s) }+   addC c _msg   = modify $ \s -> s { hsCs  = c : hsCs s }@@ -73,17 +50,20 @@ -------------------------------------------------------------------------------- addPost γ (RRTy e r OInv t)   = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("addPost", x,t)) γ e-       addC (SubR γ' OInv r) "precondition" >> return t+       addC (SubR γ' OInv r) "precondition-oinv" >> return t  addPost γ (RRTy e r OTerm t)   = do γ' <- foldM (\γ (x, t) -> γ += ("addPost", x, t)) γ e-       addC (SubR γ' OTerm r) "precondition" >> return t--addPost _ (RRTy _ _ OCons t)-  = return t+       addC (SubR γ' OTerm r) "precondition-oterm" >> return t -addPost _ t-  = return t+addPost γ (RRTy cts _ OCons t)+  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ xts+       addC (SubC  γ' t1 t2)  "precondition-ocons"+       addPost γ t+  where+    (xts, t1, t2) = envToSub cts+addPost _ t +  = return t   -------------------------------------------------------------------------------- -- | Add Well formedness Constraint@@ -120,14 +100,16 @@ -- | Used for annotating holes   addHole :: Var -> SpecType -> CGEnv -> CG () -addHole x t γ = do -  modify $ \s -> s {holesMap = M.insertWith (<>) x hinfo $ holesMap s}-  addWarning $ ErrHole loc ("hole found") (reGlobal env <> reLocal env) x' t +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]+      hinfo = HoleInfo t loc env       loc   = srcSpan $ cgLoc γ       env   = mconcat [renv γ, grtys γ, assms γ, intys γ]-      x'    = text $ showSDoc $ Ghc.pprNameUnqualified $ Ghc.getName x  -------------------------------------------------------------------------------- -- | Update annotations for a location, due to (ghost) predicate applications@@ -154,3 +136,15 @@ lookupNewType :: TC.TyCon -> CG (Maybe SpecType) lookupNewType tc   = M.lookup tc . newTyEnv <$> get+++--------------------------------------------------------------------------------+{-@ envToSub :: {v:[(a, b)] | 2 <= len v} -> ([(a, b)], b, b) @-}+envToSub :: [(a, b)] -> ([(a, b)], b, b)+--------------------------------------------------------------------------------+envToSub = go []+  where+    go _   []              = impossible Nothing "This cannot happen: envToSub on 0 elems"+    go _   [(_,_)]         = impossible Nothing "This cannot happen: envToSub on 1 elem"+    go ack [(_,l), (_, r)] = (reverse ack, l, r)+    go ack (x:xs)          = go (x:ack) xs
src/Language/Haskell/Liquid/Constraint/Qualifier.hs view
@@ -21,16 +21,16 @@ import           Language.Fixpoint.Types                  hiding (panic, mkQual) import qualified Language.Fixpoint.Types.Config as FC import           Language.Fixpoint.SortCheck-import           Language.Haskell.Liquid.Bare import           Language.Haskell.Liquid.Types.RefType import           Language.Haskell.Liquid.GHC.Misc         (getSourcePos) import           Language.Haskell.Liquid.Misc             (condNull) import           Language.Haskell.Liquid.Types.PredType-import           Language.Haskell.Liquid.Types  +import           Language.Haskell.Liquid.Types + ---------------------------------------------------------------------------------giQuals :: GhcInfo -> SEnv Sort -> [Qualifier]+giQuals :: TargetInfo -> SEnv Sort -> [Qualifier] -------------------------------------------------------------------------------- giQuals info lEnv   =  notracepp ("GI-QUALS: " ++ showpp lEnv)@@ -70,7 +70,7 @@ needQuals = (FC.None == ) . eliminate . getConfig  ---------------------------------------------------------------------------------alsQualifiers :: GhcInfo -> SEnv Sort -> [Qualifier]+alsQualifiers :: TargetInfo -> SEnv Sort -> [Qualifier] -------------------------------------------------------------------------------- alsQualifiers info lEnv   = [ q | a <- gsRTAliases . gsQual . giSpec $ info@@ -90,7 +90,7 @@   ---------------------------------------------------------------------------------sigQualifiers :: GhcInfo -> SEnv Sort -> [Qualifier]+sigQualifiers :: TargetInfo -> SEnv Sort -> [Qualifier] -------------------------------------------------------------------------------- sigQualifiers info lEnv   = [ q | (x, t) <- specBinders info@@ -105,7 +105,7 @@       tce = gsTcEmbeds . gsName . giSpec $ info       qbs = qualifyingBinders info -qualifyingBinders :: GhcInfo -> S.HashSet Var+qualifyingBinders :: TargetInfo -> S.HashSet Var qualifyingBinders info = S.difference sTake sDrop   where     sTake              = S.fromList $ giDefVars src ++ giUseVars src ++ scrapeVars cfg src @@ -116,23 +116,24 @@ -- 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 -> GhcSrc -> [Var]+scrapeVars :: Config -> TargetSrc -> [Var] scrapeVars cfg src    | cfg `hasOpt` scrapeUsedImports = giUseVars src    | cfg `hasOpt` scrapeImports     = giImpVars src    | otherwise                      = [] -specBinders :: GhcInfo -> [(Var, LocSpecType)]+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 :: GhcInfo -> [Var]+specAxiomVars :: TargetInfo -> [Var] specAxiomVars =  gsReflects . gsRefl . giSpec  -- GRAVEYARD: scraping quals from imports kills the system with too much crap@@ -162,7 +163,7 @@     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 γ (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'@@ -194,9 +195,9 @@                      $ 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+    [ 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 γ
src/Language/Haskell/Liquid/Constraint/Split.hs view
@@ -15,9 +15,6 @@   -- * Split Well-formedness Constraints   , splitW -  -- * Split Strata Constraints-  , splitS-   -- * ???   , envToSub @@ -30,9 +27,8 @@   import           Text.PrettyPrint.HughesPJ hiding (first, parens)-import qualified TyCon  as TC -import           Data.Maybe          (fromMaybe) -- catMaybes, fromJust, isJust)+import           Data.Maybe          (fromMaybe)  import           Control.Monad import           Control.Monad.State (get) import qualified Control.Exception as Ex@@ -45,16 +41,11 @@ import qualified Language.Haskell.Liquid.UX.CTags       as Tg import           Language.Haskell.Liquid.Types hiding (loc) --- import           Language.Haskell.Liquid.Types.Variance--- import           Language.Haskell.Liquid.Types.Strata--- import           Language.Haskell.Liquid.Types.PredType         hiding (freeTyVars)--- import           Language.Haskell.Liquid.Types.RefType  import           Language.Haskell.Liquid.Constraint.Types import           Language.Haskell.Liquid.Constraint.Env--- import           Language.Haskell.Liquid.Constraint.Fresh-import           Language.Haskell.Liquid.Constraint.Monad import           Language.Haskell.Liquid.Constraint.Constraint+import           Language.Haskell.Liquid.Constraint.Monad (envToSub)  -------------------------------------------------------------------------------- splitW ::  WfC -> CG [FixWfC]@@ -80,23 +71,21 @@         ws'' <- splitW (WfC γ t2)         return $ ws ++ ws' ++ ws'' -splitW (WfC γ (RAllT a r))-  = do γ' <- updateEnv γ a-       splitW (WfC γ' r)-+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 γ (RAllS _ r))-  = splitW (WfC γ r)- splitW (WfC γ t@(RVar _ _))   = bsplitW γ t  splitW (WfC γ t@(RApp _ ts rs _))   =  do ws    <- bsplitW γ t-        γ'    <- γ `extendEnvWithVV` t+        γ'    <- if bscope (getConfig γ) then γ `extendEnvWithVV` t else return γ         ws'   <- concat <$> mapM (splitW . WfC γ') ts         ws''  <- concat <$> mapM (rsplitW γ)       rs         return $ ws ++ ws' ++ ws''@@ -147,146 +136,6 @@     r'                = rTypeSortedReft' γ temp t     ci                = Ci (getLocation γ) Nothing (cgVar γ) ----------------------------------------------------------------------------------splitS  :: SubC -> CG [([Stratum], [Stratum])]-bsplitS :: SpecType -> SpecType -> CG [([Stratum], [Stratum])]----------------------------------------------------------------------------------splitS (SubC γ (REx x _ t1) (REx x2 _ t2)) | x == x2-  = splitS (SubC γ t1 t2)--splitS (SubC γ t1 (REx _ _ t2))-  = splitS (SubC γ t1 t2)--splitS (SubC γ (REx _ _ t1) t2)-  = splitS (SubC γ t1 t2)--splitS (SubC γ (RAllE x _ t1) (RAllE x2 _ t2)) | x == x2-  = splitS (SubC γ t1 t2)--splitS (SubC γ (RAllE _ _ t1) t2)-  = splitS (SubC γ t1 t2)--splitS (SubC γ t1 (RAllE _ _ t2))-  = splitS (SubC γ t1 t2)--splitS (SubC γ (RRTy _ _ _ t1) t2)-  = splitS (SubC γ t1 t2)--splitS (SubC γ t1 (RRTy _ _ _ t2))-  = splitS (SubC γ t1 t2)--splitS (SubC γ t1@(RFun x1 r1 r1' _) t2@(RFun x2 r2 r2' _))-  =  do cs       <- bsplitS t1 t2-        cs'      <- splitS  (SubC γ r2 r1)-        γ'       <- γ += ("splitS1", x2, r2)-        let r1x2' = r1' `F.subst1` (x1, F.EVar x2)-        cs''     <- splitS  (SubC γ' r1x2' r2')-        return    $ cs ++ cs' ++ cs''--splitS (SubC γ t1@(RImpF x1 r1 r1' _) t2@(RImpF x2 r2 r2' _))-  =  do cs       <- bsplitS t1 t2-        cs'      <- splitS  (SubC γ r2 r1)-        γ'       <- γ += ("splitS1", x2, r2)-        let r1x2' = r1' `F.subst1` (x1, F.EVar x2)-        cs''     <- splitS  (SubC γ' r1x2' r2')-        return    $ cs ++ cs' ++ cs''---splitS (SubC γ t1@(RAppTy r1 r1' _) t2@(RAppTy r2 r2' _))-  =  do cs    <- bsplitS t1 t2-        cs'   <- splitS  (SubC γ r1 r2)-        cs''  <- splitS  (SubC γ r1' r2')-        cs''' <- splitS  (SubC γ r2' r1')-        return $ cs ++ cs' ++ cs'' ++ cs'''--splitS (SubC γ t1 (RAllP p t))-  = splitS $ SubC γ t1 t'-  where-    t' = fmap (replacePredsWithRefs su) t-    su = (uPVar p, pVartoRConc p)--splitS (SubC _ t1@(RAllP _ _) t2)-  = panic Nothing $ "Predicate in lhs of constrain:" ++ showpp t1 ++ "\n<:\n" ++ showpp t2---splitS (SubC γ (RAllT α1 t1) (RAllT α2 t2))-  |  α1 ==  α2-  = do γ' <- updateEnv γ α2-       splitS $ SubC γ' t1 (F.subst su t2)-  | otherwise-  = do γ' <- updateEnv γ α2-       splitS $ SubC γ' t1 (F.subst su t2')-  where-    t2' = subsTyVar_meet' (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 []---splitS (SubC _ (RApp c1 _ _ _) (RApp c2 _ _ _)) | isClass c1 && c1 == c2-  = return []---splitS (SubC γ t1@(RApp {}) t2@(RApp {}))-  = do (t1',t2') <- unifyVV t1 t2-       cs    <- bsplitS t1' t2'-       γ'    <- γ `extendEnvWithVV` t1'-       let RApp c t1s r1s _ = t1'-       let RApp _ t2s r2s _ = t2'-       let isapplied = TC.tyConArity (rtc_tc c) == length t1s-       let tyInfo = rtc_info c-       csvar  <-  splitsSWithVariance           γ' t1s t2s $ varianceTyArgs tyInfo-       csvar' <- rsplitsSWithVariance isapplied γ' r1s r2s $ variancePsArgs tyInfo-       return $ cs ++ csvar ++ csvar'--splitS (SubC _ t1@(RVar a1 _) t2@(RVar a2 _))-  | a1 == a2-  = bsplitS t1 t2--splitS (SubC _ t1 t2)-  = panic Nothing $ "(Another Broken Test1!!!) splitS unexpected: " ++ showpp t1 ++ "\n\n" ++ showpp t2--splitS (SubR _ _ _)-  = return []--splitsSWithVariance :: CGEnv-                    -> [SpecType]-                    -> [SpecType]-                    -> [Variance]-                    -> CG [([Stratum], [Stratum])]-splitsSWithVariance γ t1s t2s variants-  = concatMapM (\(t1, t2, v) -> splitfWithVariance (\s1 s2 -> splitS (SubC γ s1 s2)) t1 t2 v) (zip3 t1s t2s variants)--rsplitsSWithVariance :: Bool-                     -> CGEnv-                     -> [Ref t (RType RTyCon RTyVar RReft)]-                     -> [Ref t (RType RTyCon RTyVar RReft)]-                     -> [Variance]-                     -> CG [([Stratum], [Stratum])]-rsplitsSWithVariance False _ _ _ _-  = return []--rsplitsSWithVariance _ γ t1s t2s variants-  = concatMapM (\(t1, t2, v) -> splitfWithVariance (rsplitS γ) t1 t2 v) (zip3 t1s t2s variants)--bsplitS t1 t2-  = return $ [(s1, s2)]-  where [s1, s2]   = getStrata <$> [t1, t2]--rsplitS :: CGEnv-        -> Ref t (RType RTyCon RTyVar RReft)-        -> Ref t1 (RType RTyCon RTyVar RReft)-        -> CG [([Stratum], [Stratum])]-rsplitS _ (RProp _ (RHole _)) _-   = panic Nothing "rsplitS RProp _ (RHole _)"--rsplitS _ _ (RProp _ (RHole _))-   = panic Nothing "rsplitS RProp _ (RHole _)"--rsplitS γ (RProp s1 r1) (RProp s2 r2)-  = splitS (SubC γ (F.subst su r1) r2)-  where su = F.mkSubst [(x, F.EVar y) | ((x,_), (y,_)) <- zip s1 s2]- splitfWithVariance :: Applicative f                    => (t -> t -> f [a]) -> t -> t -> Variance -> f [a] splitfWithVariance f t1 t2 Invariant     = (++) <$> f t1 t2 <*> f t2 t1@@ -384,15 +233,19 @@ splitC (SubC γ t1@(RAllP _ _) t2)   = panic (Just $ getLocation γ) $ "Predicate in lhs of constraint:" ++ showpp t1 ++ "\n<:\n" ++ showpp t2 -splitC (SubC γ (RAllT α1 t1) (RAllT α2 t2))+splitC (SubC γ t1'@(RAllT α1 t1 _) t2'@(RAllT α2 t2 _))   |  α1 ==  α2-  = do γ' <- updateEnv γ α2-       splitC $ SubC γ' t1 (F.subst su t2)+  = do γ'  <- updateEnv γ α2+       cs  <- bsplitC γ t1' t2'+       cs' <- splitC $ SubC γ' t1 (F.subst su t2)+       return (cs ++ cs')   | otherwise-  = do γ' <- updateEnv γ α2-       splitC $ SubC γ' t1 (F.subst su t2')+  = do γ'  <- updateEnv γ α2+       cs  <- bsplitC γ t1' t2'+       cs' <- splitC $ SubC γ' t1 (F.subst su t2'')+       return (cs ++ cs')   where-    t2' = subsTyVar_meet' (ty_var_value α2, RVar (ty_var_value α1) mempty) t2+    t2'' = subsTyVar_meet' (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 []@@ -403,7 +256,7 @@ splitC (SubC γ t1@(RApp _ _ _ _) t2@(RApp _ _ _ _))   = do (t1',t2') <- unifyVV t1 t2        cs    <- bsplitC γ t1' t2'-       γ'    <- γ `extendEnvWithVV` t1'+       γ'    <- 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@@ -440,8 +293,7 @@ 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 (RAllS _ t)     = parens ("RAllS " ++ traceTy t)-traceTy (RAllT _ t)     = parens ("RAllT " ++ 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))@@ -483,7 +335,6 @@         -> SpecType         -> CG [F.SubC Cinfo] bsplitC γ t1 t2 = do-  checkStratum γ t1 t2   temp   <- getTemplates   isHO   <- allowHO   <$> get   t1'    <- addLhsInv γ <$> refreshVV t1@@ -497,16 +348,6 @@     rE'       = insertREnv v t (renv γ)     v         = rTypeValueVar t -checkStratum :: CGEnv-             -> RType t t1 (UReft r)-             -> RType t t1 (UReft r)-             -> CG ()-checkStratum γ t1 t2-  | s1 <:= s2 = return ()-  | otherwise = addWarning wrn-  where-    [s1, s2]  = getStrata <$> [t1, t2]-    wrn       =  ErrOther (getLocation γ) (text $ "Stratum Error : " ++ show s1 ++ " > " ++ show s2)  bsplitC' :: CGEnv -> SpecType -> SpecType -> F.Templates -> Bool -> [F.SubC Cinfo] bsplitC' γ t1 t2 tem isHO@@ -588,7 +429,7 @@                      -> Maybe ([F.Symbol], [SpecType], [RReft], SpecType) forallExprReftLookup γ x = snap <$> F.lookupSEnv x (syenv γ)   where-    snap     = mapFourth4 ignoreOblig . (\(_,(a,b,c),t)->(a,b,c,t)) . bkArrow . fourth4 . bkUniv . lookup+    snap     = mapFourth4 ignoreOblig . (\(_,(a,b,c),t)->(a,b,c,t)) . bkArrow . thd3 . bkUniv . lookup     lookup z = fromMaybe (panicUnbound γ z) (γ ?= F.symbol z)  @@ -597,17 +438,6 @@ -------------------------------------------------------------------------------- getTag γ = maybe Tg.defaultTag (`Tg.getTag` tgEnv γ) (tgKey γ) -----------------------------------------------------------------------------------{-@ 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  -------------------------------------------------------------------------------- -- | Constraint Generation Panic -----------------------------------------------
src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs view
@@ -2,6 +2,8 @@ module Language.Haskell.Liquid.Constraint.ToFixpoint   ( cgInfoFInfo   , fixConfig+  , refinementEQs+  , canRewrite   ) where  import           Prelude hiding (error)@@ -9,51 +11,61 @@ 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.Types hiding     ( binds ) 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 (coreDeps, dependsOn) import qualified Language.Haskell.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           Var import           TyCon                             (TyCon) +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.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.etaElim                  = not (exactDC cfg) && extensionality cfg -- SEE: https://github.com/ucsd-progsys/liquidhaskell/issues/1601+  , FC.extensionality           = extensionality    cfg +  , FC.oldPLE                   = oldPLE cfg+  , FC.maxRWOrderingConstraints = maxRWOrderingConstraints cfg+  , FC.rwTerminationCheck       = rwTerminationCheck cfg   }  -cgInfoFInfo :: GhcInfo -> CGInfo -> IO (F.FInfo Cinfo)+cgInfoFInfo :: TargetInfo -> CGInfo -> IO (F.FInfo Cinfo) cgInfoFInfo info cgi = return (targetFInfo info cgi) -targetFInfo :: GhcInfo -> CGInfo -> F.FInfo Cinfo+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@@ -73,16 +85,88 @@     ax               = makeAxiomEnvironment info (dataConTys cgi) (F.cm fi)     -- msg              = show . map F.symbol . M.keys . tyConInfo -makeAxiomEnvironment :: GhcInfo -> [(Var, SpecType)] -> M.HashMap F.SubcId (F.SubC Cinfo) -> F.AxiomEnv+makeAxiomEnvironment :: TargetInfo -> [(Var, SpecType)] -> M.HashMap F.SubcId (F.SubC Cinfo) -> F.AxiomEnv makeAxiomEnvironment info xts fcs-  = F.AEnv (makeEquations sp ++ [specTypeEq emb x t | (x, t) <- xts]) +  = F.AEnv eqs              (concatMap makeSimplify xts)            (doExpand sp cfg <$> fcs)+           (makeRewrites info <$> fcs)   where+    eqs      = if (oldPLE cfg) +                then (makeEquations 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) (subVar sub)++    rws        =+      if isGlobalRw+      then S.empty+      else S.difference+        (S.union localRws globalRws)+        (Mb.maybe S.empty forbiddenRWs (subVar sub))++    allDeps         = coreDeps $ giCbs $ giSrc info+    forbiddenRWs sv =+      S.insert sv $ dependsOn allDeps [sv]++    localRws = Mb.fromMaybe S.empty $ do+      var    <- subVar sub+      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))@@ -94,7 +178,7 @@     (ts, t)   = Ghc.splitFunTys . snd . Ghc.splitForAllTys . Ghc.varType $ x  -doExpand :: GhcSpec -> Config -> F.SubC Cinfo -> Bool+doExpand :: TargetSpec -> Config -> F.SubC Cinfo -> Bool doExpand sp cfg sub = Config.allowGlobalPLE cfg                    || (Config.allowLocalPLE cfg && maybe False (isPLEVar sp) (subVar sub)) @@ -116,18 +200,24 @@     bExp           = F.eApps (F.eVar f) (F.EVar <$> xs)  makeSimplify :: (Var, SpecType) -> [F.Rewrite]-makeSimplify (x, t) = go $ specTypeToResultRef (F.eApps (F.EVar $ F.symbol x) (F.EVar <$> ty_binds (toRTypeRep t))) t+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] @@ -139,11 +229,11 @@     fromEVar (F.EVar x) = x     fromEVar _ = impossible Nothing "makeSimplify.fromEVar" -makeEquations :: GhcSpec -> [F.Equation]+makeEquations :: TargetSpec -> [F.Equation] makeEquations sp = [ F.mkEquation f xts (equationBody (F.EVar f) xArgs e mbT) t                       | F.Equ f xts e t _ <- axioms -                      , let mbT            = M.lookup f sigs                       , let xArgs          = F.EVar . fst <$> xts+                      , let mbT            = if null xArgs then Nothing else M.lookup f sigs                    ]   where     axioms       = gsMyAxioms refl ++ gsImpAxioms refl 
src/Language/Haskell/Liquid/Constraint/Types.hs view
@@ -52,8 +52,6 @@    , removeInvariant, restoreInvariant, makeRecInvariants -  , addArgument, addArguments-   , getTemplates   ) where @@ -72,19 +70,17 @@ import           Control.DeepSeq import           Data.Maybe               (catMaybes, isJust) import           Control.Monad.State--- import           Control.Monad.Fail   import           Language.Haskell.Liquid.GHC.SpanStack-import           Language.Haskell.Liquid.Types hiding   (binds)--- import           Language.Haskell.Liquid.Types.Strata-import           Language.Haskell.Liquid.Misc           (fourth4)--- import           Language.Haskell.Liquid.Types.RefType  (shiftVV, toType)+import           Language.Haskell.Liquid.Misc           (thrd3) import           Language.Haskell.Liquid.WiredIn        (wiredSortedSyms) import qualified Language.Fixpoint.Types            as F-import Language.Fixpoint.Misc+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@@ -96,7 +92,6 @@   , constEnv :: !(F.SEnv F.Sort)   -- ^ Distinct literals   , fenv   :: !FEnv              -- ^ Fixpoint Environment   , recs   :: !(S.HashSet Var)   -- ^ recursive defs being processed (for annotations)-  , fargs  :: !(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@@ -111,10 +106,8 @@   , forallcb :: !(M.HashMap Var F.Expr)              -- ^ Polymorhic let bindings    , holes  :: !HEnv                                  -- ^ Types with holes, will need refreshing   , lcs    :: !LConstraint                           -- ^ Logical Constraints-  , aenv   :: !(M.HashMap Var F.Symbol)              -- ^ axiom environment maps reflected Haskell functions to the logical functions   , cerr   :: !(Maybe (TError SpecType))             -- ^ error that should be reported at the user-  -- , cgCfg  :: !Config                                -- ^ top-level config options-  , cgInfo :: !GhcInfo                               -- ^ top-level GhcInfo+  , cgInfo :: !TargetInfo                            -- ^ top-level TargetInfo   , cgVar  :: !(Maybe Var)                           -- ^ top level function being checked   } -- deriving (Data, Typeable) @@ -175,10 +168,6 @@   pprintTidy k (WfC _ r) = {- pprintTidy k w <> text -} "<...> |-" <+> pprintTidy k r  -instance SubStratum SubC where-  subS su (SubC γ t1 t2) = SubC γ (subS su t1) (subS su t2)-  subS _  c              = c- -------------------------------------------------------------------------------- -- | Generation: Types --------------------------------------------------------- --------------------------------------------------------------------------------@@ -186,15 +175,13 @@   { fEnv       :: !(F.SEnv F.Sort)             -- ^ top-level fixpoint env   , hsCs       :: ![SubC]                      -- ^ subtyping constraints over RType   , hsWfs      :: ![WfC]                       -- ^ wellformedness constraints over RType-  , sCs        :: ![SubC]                      -- ^ additional stratum constrains for let bindings   , fixCs      :: ![FixSubC]                   -- ^ subtyping over Sort (post-splitting)-  , isBind     :: ![Bool]                      -- ^ tracks constraints that come from let-bindings   , fixWfs     :: ![FixWfC]                    -- ^ wellformedness constraints over Sort (post-splitting)   , freshIndex :: !Integer                     -- ^ counter for generating fresh KVars   , binds      :: !F.BindEnv                   -- ^ set of environment binders   , ebinds     :: ![F.BindId]                  -- ^ existentials   , annotMap   :: !(AnnInfo (Annot SpecType))  -- ^ source-position annotation map-  , holesMap   :: !(M.HashMap Var [HoleInfo SpecType])    -- ^ information for ghc hole expressions+  , 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 TC.TyCon SpecType)        -- ^ Mapping of new type type constructors with their refined types.@@ -210,14 +197,13 @@   , 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 (?)-  , scheck     :: !Bool                        -- ^ Check Strata (?)   , 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       :: !GhcInfo+  , ghcI       :: !TargetInfo   , dataConTys :: ![(Var, SpecType)]           -- ^ Refined Types of Data Constructors   , unsorted   :: !F.Templates                 -- ^ Potentially unsorted expressions   }@@ -277,27 +263,12 @@ type RTyConInv = M.HashMap RTyCon [RInv] type RTyConIAl = M.HashMap RTyCon [RInv] --addArgument :: CGEnv -> Var -> CGEnv-addArgument γ v- | higherOrderFlag γ- = γ {fargs = S.insert v (fargs γ) }- | otherwise- = γ--addArguments :: CGEnv -> [Var] -> CGEnv-addArguments γ vs- | higherOrderFlag γ- = foldl addArgument γ vs- | otherwise- = γ- -------------------------------------------------------------------------------- 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 (fourth4 . bkUniv . val)+    strip = mapSnd (thrd3 . bkUniv . val)     go ts | generic (toRSort <$> ts) = []           | otherwise                = toRSort <$> ts @@ -388,7 +359,7 @@      guard (RApp c ts rs r)       | Just f <- szFun <$> sizeFunction (rtc_info c)-      = RApp c ts rs (MkUReft (ref f $ F.toReft r) mempty mempty)+      = RApp c ts rs (MkUReft (ref f $ F.toReft r) mempty)       | otherwise       = RApp c ts rs mempty     guard t@@ -432,7 +403,7 @@   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 _ _ _ _ _ _ _ _ _ _ _ _)+  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
− src/Language/Haskell/Liquid/GHC.hs 
@@ -1,6 +0,0 @@--- | This module re-exports the GHC API as a single blob.--module Language.Haskell.Liquid.GHC (module X) where--import Language.Haskell.Liquid.GHC.Interface as X-import Language.Haskell.Liquid.GHC.Misc      as X
src/Language/Haskell/Liquid/GHC/API.hs view
@@ -1,47 +1,232 @@ -- | This module re-exports a bunch of the GHC API. -module Language.Haskell.Liquid.GHC.API (module Ghc) where +{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE BangPatterns #-} -import GHC            as Ghc+module Language.Haskell.Liquid.GHC.API (+    module Ghc++#ifdef MIN_VERSION_GLASGOW_HASKELL+#if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) && !MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)+  , VarBndr+  , AnonArgFlag(..)+  , pattern Bndr+  , pattern FunTy+  , pattern AnonTCB+  , pattern LitString+  , pattern LitFloat+  , pattern LitDouble+  , pattern LitChar+  , ft_af, ft_arg, ft_res+  , bytesFS+  , mkFunTy+  , isEvVarType+  , isEqPrimPred+#endif+#endif++  , tyConRealArity+  , dataConExTyVars++  ) where++import Avail          as Ghc+import GHC            as Ghc hiding (Warning) import ConLike        as Ghc import Var            as Ghc import Module         as Ghc import DataCon        as Ghc-import TysWiredIn     as Ghc  -import BasicTypes     as Ghc -import CoreSyn        as Ghc hiding (AnnExpr, AnnExpr' (..), AnnRec, AnnCase) -import TyCon          as Ghc +import TysWiredIn     as Ghc+import BasicTypes     as Ghc+import CoreSyn        as Ghc hiding (AnnExpr, AnnExpr' (..), AnnRec, AnnCase) import NameSet        as Ghc-import InstEnv        as Ghc -import Type           as Ghc hiding (typeKind) -import TyCoRep        as Ghc +import InstEnv        as Ghc+import Literal        as Ghc+import TcType         as Ghc (isClassPred) import Class          as Ghc import Unique         as Ghc import RdrName        as Ghc-import SrcLoc         as Ghc -import Name           as Ghc hiding (varName) +import SrcLoc         as Ghc+import Name           as Ghc hiding (varName)+import TysPrim        as Ghc+import HscTypes       as Ghc+import HscMain        as Ghc+import Id             as Ghc hiding (lazySetIdInfo, setIdExported, setIdNotExported)+import ErrUtils       as Ghc+import DynFlags       as Ghc +--+-- Compatibility layer for different GHC versions.+-- --- import TyCon          as Ghc --- import DataCon        as Ghc +--+-- Specific imports for GHC 8.6.5+--+#ifdef MIN_VERSION_GLASGOW_HASKELL+#if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) && !MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) -import TysPrim        as Ghc-import HscTypes       as Ghc-import HscMain        as Ghc -import Id             as Ghc hiding (lazySetIdInfo, setIdExported, setIdNotExported) +import                   Binary+import                   Data.ByteString (ByteString)+import                   Data.Data (Data)+import                   Outputable+import Kind              as Ghc (classifiesTypeWithValues)+import FastString        as Ghc hiding (bytesFS, LitString)+import TyCoRep           as Ghc hiding (Type (FunTy), mkFunTy)+import TyCon             as Ghc hiding (TyConBndrVis(AnonTCB))+import Type              as Ghc hiding (typeKind, mkFunTy)+import qualified Type    as Ghc+import qualified TyCoRep as Ty+import qualified Literal as Lit+import qualified TyCon   as Ty+import qualified Var     as Var+import qualified GHC.Real --- import qualified CoreSyn   as Ghc--- import qualified Unique--- import qualified GHC       as Ghc--- import           Id--- import           NameSet--- -- import           Name--- import           TyCon--- import           Var--- import           TysWiredIn--- import           DataCon                                    (DataCon)--- import           InstEnv--- import           FamInstEnv--- import           TcRnDriver (runTcInteractive)--- import           FamInst    (tcGetFamInstEnvs)+#endif+#endif +--+-- Specific imports for GHC 8.10+--+#ifdef MIN_VERSION_GLASGOW_HASKELL+#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)+import Type           as Ghc hiding (typeKind , isPredTy)+import TyCon          as Ghc+import TyCoRep        as Ghc+import FastString     as Ghc+import Predicate      as Ghc (isEqPred, getClassPredTys_maybe, isEvVarType, isEqPrimPred)+import Data.Foldable  (asum)+#endif+#endif++--+-- GHC-specific functions and pattern synonyms+--+#ifdef MIN_VERSION_GLASGOW_HASKELL+#if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) && !MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)++-- | The non-dependent version of 'ArgFlag'.++-- Appears here partly so that it's together with its friend ArgFlag,+-- but also because it is used in IfaceType, rather early in the+-- compilation chain+-- See Note [AnonArgFlag vs. ForallVisFlag]+data AnonArgFlag+  = VisArg    -- ^ Used for @(->)@: an ordinary non-dependent arrow.+              --   The argument is visible in source code.+  | InvisArg  -- ^ Used for @(=>)@: a non-dependent predicate arrow.+              --   The argument is invisible in source code.+  deriving (Eq, Ord, Data)++instance Outputable AnonArgFlag where+  ppr VisArg   = text "[vis]"+  ppr InvisArg = text "[invis]"++instance Binary AnonArgFlag where+  put_ bh VisArg   = putByte bh 0+  put_ bh InvisArg = putByte bh 1++  get bh = do+    h <- getByte bh+    case h of+      0 -> return VisArg+      _ -> return InvisArg++bytesFS :: FastString -> ByteString+bytesFS = fastStringToByteString++mkFunTy :: AnonArgFlag -> Type -> Type -> Type+mkFunTy _ = Ty.FunTy++pattern Bndr :: var -> argf -> Var.TyVarBndr var argf+pattern Bndr var argf <- TvBndr var argf where+    Bndr var argf = TvBndr var argf++type VarBndr = TyVarBndr++pattern FunTy :: AnonArgFlag -> Type -> Type -> Type+pattern FunTy { ft_af, ft_arg, ft_res } <- ((VisArg,) -> (ft_af, Ty.FunTy ft_arg ft_res)) where+    FunTy _ft_af ft_arg ft_res = Ty.FunTy ft_arg ft_res++pattern AnonTCB :: AnonArgFlag -> Ty.TyConBndrVis+pattern AnonTCB af <- ((VisArg,) -> (af, Ty.AnonTCB)) where+    AnonTCB _af = Ty.AnonTCB++pattern LitString :: ByteString -> Lit.Literal+pattern LitString bs <- Lit.MachStr bs where+    LitString bs = Lit.MachStr bs++pattern LitFloat :: GHC.Real.Ratio Integer -> Lit.Literal+pattern LitFloat f <- Lit.MachFloat f where+    LitFloat f = Lit.MachFloat f++pattern LitDouble :: GHC.Real.Ratio Integer -> Lit.Literal+pattern LitDouble d <- Lit.MachDouble d where+    LitDouble d = Lit.MachDouble d++pattern LitChar :: Char -> Lit.Literal+pattern LitChar c <- Lit.MachChar c where+    LitChar c = Lit.MachChar c++-- See NOTE [tyConRealArity].+tyConRealArity :: TyCon -> Int+tyConRealArity = tyConArity++-- See NOTE [isEvVarType].+isEvVarType :: Type -> Bool+isEvVarType = Ghc.isPredTy++isEqPrimPred :: Type -> Bool+isEqPrimPred = Ghc.isPredTy++#endif++{- | [NOTE:tyConRealArity]++The semantics of 'tyConArity' changed between GHC 8.6.5 and GHC 8.10, mostly due to the+Visible Dependent Quantification (VDQ). As a result, given the following:++data family EntityField record :: * -> *++Calling `tyConArity` on this would yield @2@ for 8.6.5 but @1@ an 8.10, so we try to backport+the old behaviour in 8.10 by \"looking\" at the 'Kind' of the input 'TyCon' and trying to recursively+split the type apart with either 'splitFunTy_maybe' or 'splitForAllTy_maybe'.++-}++{- | [NOTE:isEvVarType]++For GHC < 8.10.1 'isPredTy' is effectively the same as the new 'isEvVarType', which covers the cases+for coercion types and \"normal\" type coercions. The 8.6.5 version of 'isPredTy' had a special case to+handle a 'TyConApp' in the case of type equality (i.e. ~ ) which was removed in the implementation+for 8.10.1, which essentially calls 'tcIsConstraintKind' straight away.+-}++--+-- Support for GHC >= 8.10.0+--++#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)++-- See NOTE [tyConRealArity].+tyConRealArity :: TyCon -> Int+tyConRealArity tc = go 0 (tyConKind tc)+  where+    go :: Int -> Kind -> Int+    go !acc k =+      case asum [fmap snd (splitFunTy_maybe k), fmap snd (splitForAllTy_maybe k)] of+        Nothing -> acc+        Just ks -> go (acc + 1) ks++dataConExTyVars :: DataCon -> [TyVar]+dataConExTyVars = dataConExTyCoVars++#endif++--+-- End of compatibility shim.+--+#endif
+ src/Language/Haskell/Liquid/GHC/GhcMonadLike.hs view
@@ -0,0 +1,293 @@+{-# 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 Language.Haskell.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+  ) where++import Control.Monad+import Control.Monad.IO.Class+import Control.Exception (throwIO)++import Data.IORef (readIORef)++import qualified Language.Haskell.Liquid.GHC.API   as Ghc+import           Language.Haskell.Liquid.GHC.API   hiding ( ModuleInfo+                                                          , findModule+                                                          , desugarModule+                                                          , typecheckModule+                                                          , parseModule+                                                          , lookupName+                                                          , lookupGlobalName+                                                          , getModSummary+                                                          , getModuleGraph+                                                          , modInfoLookupName+                                                          , lookupModule+                                                          , TypecheckedModule+                                                          , tm_parsed_module+                                                          , tm_renamed_source+                                                          )+import qualified CoreMonad+import qualified EnumSet+import TcRnMonad+import Outputable+import UniqFM+import Maybes+import Panic+import GhcMake+import Finder+import Exception (ExceptionMonad)++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 $ \e w -> pure (e, w)++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 = liftM 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 <- liftM hsc_mod_graph askHscEnv+   let mods_by_name = [ ms | ms <- mgModSummaries mg+                      , ms_mod_name ms == mdl+                      , not (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)++lookupModSummary :: GhcMonadLike m => ModuleName -> m (Maybe ModSummary)+lookupModSummary mdl = do+   mg <- liftM hsc_mod_graph askHscEnv+   let mods_by_name = [ ms | ms <- mgModSummaries mg+                      , ms_mod_name ms == mdl+                      , not (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.+data ModuleInfo = ModuleInfo { minf_type_env :: UniqFM 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
src/Language/Haskell/Liquid/GHC/Interface.hs view
@@ -2,18 +2,22 @@ {-# LANGUAGE TypeSynonymInstances       #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE LambdaCase                 #-} {-# LANGUAGE TupleSections              #-} {-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE PartialTypeSignatures      #-}+{-# LANGUAGE ViewPatterns               #-}  module Language.Haskell.Liquid.GHC.Interface (    -- * Determine the build-order for target files    realTargets +  , getInterfaceDynFlags+   -- * Extract all information needed for verification-  , getGhcInfos+  , getTargetInfos   , runLiquidGhc    -- * Printer@@ -22,6 +26,31 @@   -- * 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)@@ -34,6 +63,7 @@  import qualified Language.Haskell.Liquid.GHC.API as Ghc import Annotations+import Avail import Class import CoreMonad import CoreSyn@@ -71,6 +101,7 @@  import qualified Data.HashSet        as S import qualified Data.Map            as M+import qualified Data.HashMap.Strict as HM  import System.Console.CmdArgs.Verbosity hiding (Loud) import System.Directory@@ -82,7 +113,10 @@ import qualified Language.Fixpoint.Misc as Misc import Language.Haskell.Liquid.Bare import Language.Haskell.Liquid.GHC.Misc+import Language.Haskell.Liquid.GHC.Types (MGIModGuts(..), miModGuts) import Language.Haskell.Liquid.GHC.Play+import qualified Language.Haskell.Liquid.GHC.GhcMonadLike as GhcMonadLike+import Language.Haskell.Liquid.GHC.GhcMonadLike (GhcMonadLike, askHscEnv) import Language.Haskell.Liquid.WiredIn (isDerivedInstance)  import qualified Language.Haskell.Liquid.Measure  as Ms import qualified Language.Haskell.Liquid.Misc     as Misc@@ -92,13 +126,15 @@ -- import Language.Haskell.Liquid.Types.PrettyPrint -- import Language.Haskell.Liquid.Types.Visitors import Language.Haskell.Liquid.UX.CmdLine-import Language.Haskell.Liquid.UX.Config (totalityCheck) import Language.Haskell.Liquid.UX.QuasiQuoter import Language.Haskell.Liquid.UX.Tidy import Language.Fixpoint.Utils.Files +import Optics+ import qualified Debug.Trace as Debug  + -------------------------------------------------------------------------------- {- | @realTargets mE cfg targets@ uses `Interface.configureGhcTargets` to       return a list of files@@ -125,6 +161,9 @@     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@@ -151,21 +190,21 @@ -- | GHC Interface Pipeline ---------------------------------------------------- -------------------------------------------------------------------------------- -getGhcInfos :: Maybe HscEnv -> Config -> [FilePath] -> IO ([GhcInfo], HscEnv)-getGhcInfos hscEnv cfg tgtFiles' = do+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 (getGhcInfos' cfg logicMap tgtFiles)+  runLiquidGhc hscEnv cfg (getTargetInfos' cfg logicMap tgtFiles)  checkFilePresent :: FilePath -> IO () checkFilePresent f = do   b <- doesFileExist f   unless b $ panic Nothing ("Cannot find file: " ++ f) -getGhcInfos' :: Config -> LogicMap -> [FilePath] -> Ghc ([GhcInfo], HscEnv)-getGhcInfos' cfg logicMap tgtFiles = do+getTargetInfos' :: Config -> LogicMap -> [FilePath] -> Ghc ([TargetInfo], HscEnv)+getTargetInfos' cfg logicMap tgtFiles = do   _           <- compileCFiles cfg   homeModules <- configureGhcTargets tgtFiles   depGraph    <- buildDepGraph homeModules@@ -288,25 +327,25 @@ mkDepGraphNode modSummary =    DigraphNode () (ms_mod modSummary) <$> (filterM isHomeModule =<< modSummaryImports modSummary) -isHomeModule :: Module -> Ghc Bool+isHomeModule :: GhcMonadLike m => Module -> m Bool isHomeModule mod = do-  homePkg <- thisPackage <$> getSessionDynFlags+  homePkg <- thisPackage <$> getDynFlags   return   $ moduleUnitId mod == homePkg -modSummaryImports :: ModSummary -> Ghc [Module]+modSummaryImports :: GhcMonadLike m => ModSummary -> m [Module] modSummaryImports modSummary =   mapM (importDeclModule (ms_mod modSummary))        (ms_textual_imps modSummary) -importDeclModule :: Module -> (Maybe FastString,  GHC.Located ModuleName) -> Ghc Module+importDeclModule :: GhcMonadLike m => Module -> (Maybe FastString,  GHC.Located ModuleName) -> m Module importDeclModule fromMod (pkgQual, locModName) = do-  hscEnv <- getSession+  hscEnv <- askHscEnv   let modName = unLoc locModName   result <- liftIO $ findImportedModule hscEnv modName pkgQual   case result of     Finder.Found _ mod -> return mod     _ -> do-      dflags <- getSessionDynFlags+      dflags <- getDynFlags       liftIO $ throwGhcExceptionIO $ ProgramError $         O.showPpr dflags (moduleName fromMod) ++ ": " ++         O.showSDoc dflags (cannotFindModule dflags modName result)@@ -367,7 +406,7 @@  type SpecEnv = ModuleEnv (ModName, Ms.BareSpec) -processModules :: Config -> LogicMap -> [FilePath] -> DepGraph -> ModuleGraph -> Ghc [GhcInfo]+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)@@ -375,7 +414,7 @@     go = processModule cfg logicMap (S.fromList tgtFiles) depGraph  processModule :: Config -> LogicMap -> S.HashSet FilePath -> DepGraph -> SpecEnv -> ModSummary-              -> Ghc (SpecEnv, Maybe GhcInfo)+              -> 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)@@ -383,11 +422,12 @@   let isTarget         = file `S.member` tgtFiles   _                   <- loadDependenciesOf $ moduleName mod   parsed              <- parseModule $ keepRawTokenStream modSummary-  let specComments     = extractSpecComments parsed+  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@@ -398,15 +438,16 @@  updLiftedSpec :: Ms.BareSpec -> Maybe Ms.BareSpec -> Ms.BareSpec  updLiftedSpec s1 Nothing   = s1 -updLiftedSpec s1 (Just s2) = (clear s1) `mappend` s2 -  where -    clear s                = s { sigs = [], aliases = [], ealiases = [], qualifiers = [], dataDecls = [] }+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 :: ModuleName -> Ghc ()+loadDependenciesOf :: GhcMonad m => ModuleName -> m () loadDependenciesOf modName = do   loadResult <- load $ LoadDependenciesOf modName   when (failed loadResult) $ liftIO $ throwGhcExceptionIO $ ProgramError $@@ -425,58 +466,74 @@   processTargetModule :: Config -> LogicMap -> DepGraph -> SpecEnv -> FilePath -> TypecheckedModule -> Ms.BareSpec-                    -> Ghc GhcInfo+                    -> Ghc TargetInfo processTargetModule cfg0 logicMap depGraph specEnv file typechecked bareSpec = do-  cfg        <- liftIO $ withPragmas cfg0 file (Ms.pragmas bareSpec)-  let modSum  = pm_mod_summary (tm_parsed_module typechecked)-  ghcSrc     <- makeGhcSrc    cfg file     typechecked modSum-  bareSpecs  <- makeBareSpecs cfg depGraph specEnv     modSum bareSpec-  let ghcSpec = makeGhcSpec   cfg ghcSrc   logicMap           bareSpecs  -  _          <- liftIO $ saveLiftedSpec ghcSrc ghcSpec -  return      $ GI ghcSrc ghcSpec+  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++  case makeTargetSpec cfg logicMap targetSrc (view bareSpecIso bareSpec) dependencies 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+ --------------------------------------------------------------------------------------- -- | @makeGhcSrc@ builds all the source-related information needed for consgen  ---------------------------------------------------------------------------------------  makeGhcSrc :: Config -> FilePath -> TypecheckedModule -> ModSummary -> Ghc GhcSrc  makeGhcSrc cfg file typechecked modSum = do-  desugared         <- desugarModule  typechecked-  let modGuts        = makeMGIModGuts desugared   -  let modGuts'       = dm_core_module desugared+  modGuts'          <- GhcMonadLike.desugarModule modSum typechecked++  let modGuts        = makeMGIModGuts modGuts'   hscEnv            <- getSession-  -- _                 <- liftIO $ whenLoud $ dumpRdrEnv hscEnv modGuts-  -- _                 <- liftIO $ whenLoud $ dumpTypeEnv typechecked    coreBinds         <- liftIO $ anormalize cfg hscEnv modGuts'   _                 <- liftIO $ whenNormal $ Misc.donePhase Misc.Loud "A-Normalization"   let dataCons       = concatMap (map dataConWorkId . tyConDataCons) (mgi_tcs modGuts)-  -- let defVs          = definedVars coreBinds-  (fiTcs, fiDcs)    <- liftIO $ makeFamInstEnv hscEnv -  things            <- lookupTyThings hscEnv typechecked modGuts -  -- _                 <- liftIO $ print (showpp things)+  (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       = mgi_tcs      modGuts-    , gsCls       = mgi_cls_inst modGuts -    , gsFiTcs     = fiTcs -    , gsFiDcs     = fiDcs-    , gsPrimTcs   = TysPrim.primTyCons-    , gsQualImps  = qualifiedImports typechecked -    , gsAllImps   = allImports       typechecked-    , gsTyThings  = {- impThings impVars -} [ t | (_, Just t) <- things ] +    { _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   = TysPrim.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@@ -484,15 +541,15 @@     ok (AnId x) = S.member x vs       ok _        = True  -allImports :: TypecheckedModule -> S.HashSet Symbol -allImports tm = case tm_renamed_source tm of -  Nothing           -> Debug.trace "WARNING: Missing RenamedSource" mempty -  Just (_,imps,_,_) -> S.fromList (symbol . unLoc . ideclName . unLoc <$> imps) +allImports :: [LImportDecl GhcRn] -> S.HashSet Symbol +allImports = \case+  []-> Debug.trace "WARNING: Missing RenamedSource" mempty +  imps -> S.fromList (symbol . unLoc . ideclName . unLoc <$> imps) -qualifiedImports :: TypecheckedModule -> QImports -qualifiedImports tm = case tm_renamed_source tm of -  Nothing           -> Debug.trace "WARNING: Missing RenamedSource" (qImports mempty) -  Just (_,imps,_,_) -> qImports [ (qn, n) | i         <- 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) @@ -511,17 +568,40 @@ --   for this module; we will use this to create our name-resolution environment  --   (see `Bare.Resolve`)                                           ----------------------------------------------------------------------------------------lookupTyThings :: HscEnv -> TypecheckedModule -> MGIModGuts -> Ghc [(Name, Maybe TyThing)] -lookupTyThings hscEnv tcm mg =-  forM (mgNames 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+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  = fmap Ghc.gre_name . Ghc.globalRdrEnvElts $ tcg_rdr_env 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)+ -- lookupName        :: GhcMonad m => Name -> m (Maybe TyThing)  -- hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing) -- modInfoLookupName :: GhcMonad m => ModuleInfo -> Name -> m (Maybe TyThing)  @@ -557,20 +637,43 @@ mgNames  = fmap Ghc.gre_name . Ghc.globalRdrEnvElts .  mgi_rdr_env   ------------------------------------------------------------------------------------------ | @makeBareSpecs@ loads BareSpec for target and imported modules +-- | @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. ----------------------------------------------------------------------------------------makeBareSpecs :: Config -> DepGraph -> SpecEnv -> ModSummary -> Ms.BareSpec -              -> Ghc [(ModName, Ms.BareSpec)]-makeBareSpecs cfg depGraph specEnv modSum tgtSpec = do -  let paths     = nub $ idirs cfg ++ importPaths (ms_hspp_opts modSum)+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-  let impSpecs  = specSpecs ++ homeSpecs-  let tgtMod    = ModName Target (moduleName (ms_mod modSum))-  return        $ (tgtMod, tgtSpec) : impSpecs +  -- 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) = +      toStableModule (Module (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@@ -585,7 +688,7 @@     lookupBareSpec m         = fromMaybe (err m) (lookupModuleEnv specEnv m)     err m                    = impossible Nothing ("lookupBareSpec: missing module " ++ showPpr m) -checkFilePragmas :: [Located String] -> Ghc ()+checkFilePragmas :: GhcMonadLike m => [Located String] -> m () checkFilePragmas = Misc.applyNonNull (return ()) throw . mapMaybe err   where     err pragma@@ -601,12 +704,11 @@ -------------------------------------------------------------------------------- -- | Family instance information ---------------------------------------------------------------------------------makeFamInstEnv :: HscEnv -> IO ([GHC.TyCon], [(Symbol, DataCon)])-makeFamInstEnv env = do-  famInsts <- getFamInstances env+makeFamInstEnv :: [FamInst] -> ([GHC.TyCon], [(Symbol, DataCon)])+makeFamInstEnv famInsts =   let fiTcs = [ tc            | FamInst { fi_flavor = DataFamilyInst tc } <- famInsts ]-  let fiDcs = [ (symbol d, d) | tc <- fiTcs, d <- tyConDataCons tc ]-  return (fiTcs, fiDcs)+      fiDcs = [ (symbol d, d) | tc <- fiTcs, d <- tyConDataCons tc ]+  in (fiTcs, fiDcs)  getFamInstances :: HscEnv -> IO [FamInst] getFamInstances env = do@@ -616,12 +718,11 @@ -------------------------------------------------------------------------------- -- | Extract Specifications from GHC ------------------------------------------- ---------------------------------------------------------------------------------extractSpecComments :: ParsedModule -> [(SourcePos, String)]+extractSpecComments :: ApiAnns -> [(SourcePos, String)] extractSpecComments = mapMaybe extractSpecComment                     . concat                     . M.elems                     . snd-                    . pm_annotations   -- | 'extractSpecComment' pulls out the specification part from a full comment@@ -641,17 +742,20 @@ extractSpecComment _ = Nothing  extractSpecQuotes :: TypecheckedModule -> [BPspec]-extractSpecQuotes typechecked = mapMaybe extractSpecQuote anns+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) $-           tcg_anns $ fst $ tm_internals_ typechecked+           getAnns a -    isOurModTarget (ModuleTarget mod1) = mod1 == mod+    isOurModTarget (ModuleTarget mod1) = mod1 == thisModule a     isOurModTarget _ = False -    mod = ms_mod $ pm_mod_summary $ tm_parsed_module typechecked- extractSpecQuote :: AnnPayload -> Maybe BPspec extractSpecQuote payload =    case fromSerialized deserializeWithData payload of@@ -670,58 +774,61 @@  -- | Handle Spec Files --------------------------------------------------------- -findAndParseSpecFiles :: Config-                      -> [FilePath]+findAndParseSpecFiles :: GhcMonadLike m+                      => Config+                      -> S.HashSet FilePath                       -> ModSummary                       -> [Module]-                      -> Ghc [(ModName, Ms.BareSpec)]+                      -> m [(ModName, Ms.BareSpec)] findAndParseSpecFiles cfg paths modSummary reachable = do-  impSumms <- mapM getModSummary (moduleName <$> reachable)+  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'      <- moduleFiles Spec paths 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  <- getPatSpec paths  $ totalityCheck cfg-  rlSpec   <- getRealSpec paths $ not (linear cfg)+  patSpec  <- liftIO $ getPatSpec  modGraph paths $ totalityCheck cfg+  rlSpec   <- liftIO $ getRealSpec modGraph paths $ not (linear cfg)   let fs    = patSpec ++ rlSpec ++ fs'-  transParseSpecs paths mempty mempty fs+  liftIO $ transParseSpecs modGraph paths mempty mempty fs   where     m2s = moduleNameString . moduleName -getPatSpec :: [FilePath] -> Bool -> Ghc [FilePath]-getPatSpec paths totalitycheck- | totalitycheck = moduleFiles Spec paths [patErrorName]+getPatSpec :: ModuleGraph -> S.HashSet FilePath -> Bool -> IO [FilePath]+getPatSpec modGraph paths totalitycheck+ | totalitycheck = moduleFiles modGraph Spec paths [patErrorName]  | otherwise     = return []  where   patErrorName   = "PatErr" -getRealSpec :: [FilePath] -> Bool -> Ghc [FilePath]-getRealSpec paths freal-  | freal     = moduleFiles Spec paths [realSpecName]-  | otherwise = moduleFiles Spec paths [notRealSpecName]+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 :: [FilePath]+transParseSpecs :: ModuleGraph+                -> S.HashSet FilePath                 -> S.HashSet FilePath                  -> [(ModName, Ms.BareSpec)]                 -> [FilePath]-                -> Ghc [(ModName, Ms.BareSpec)]-transParseSpecs _ _ specs [] = return specs-transParseSpecs paths seenFiles specs newFiles = do+                -> 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 Spec paths $ specsImports newSpecs+  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 paths seenFiles' specs' newFiles'+  transParseSpecs modGraph paths seenFiles' specs' newFiles'   where     specsImports ss = nub $ concatMap (map symbolString . Ms.imports . snd) ss @@ -733,56 +840,40 @@  -- 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'+-- _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 :: Ext -> [FilePath] -> [String] -> Ghc [FilePath]-moduleFiles ext paths names = catMaybes <$> mapM (moduleFile ext paths) names+moduleFiles :: ModuleGraph -> Ext -> S.HashSet FilePath -> [String] -> IO [FilePath]+moduleFiles modGraph ext paths names = catMaybes <$> mapM (moduleFile modGraph ext paths) names -moduleFile :: Ext -> [FilePath] -> String -> Ghc (Maybe FilePath)-moduleFile ext paths name+moduleFile :: ModuleGraph -> Ext -> S.HashSet FilePath -> String -> IO (Maybe FilePath)+moduleFile modGraph ext (S.toList -> paths) name   | ext `elem` [Hs, LHs] = do-    graph <- mgModSummaries <$> getModuleGraph+    let graph = mgModSummaries modGraph     case find (\m -> not (isBootSummary m) &&                      name == moduleNameString (ms_mod_name m)) graph of-      Nothing -> liftIO $ getFileInDirs (extModuleName name ext) paths+      Nothing -> getFileInDirs (extModuleName name ext) paths       Just ms -> return $ normalise <$> ml_hs_file (ms_location ms)-  | otherwise = liftIO $ getFileInDirs (extModuleName name ext) paths--specIncludes :: Ext -> [FilePath] -> [FilePath] -> Ghc [FilePath]-specIncludes ext paths reqs = do-  let libFile = extFileNameR ext $ symbolString preludeName-  let incFiles = catMaybes $ reqFile ext <$> reqs-  liftIO $ forM (libFile : incFiles) $ \f -> do-    mfile <- getFileInDirs f paths-    case mfile of-      Just file -> return file-      Nothing   -> panic Nothing $ "cannot find " ++ f ++ " in " ++ show paths--reqFile :: Ext -> FilePath -> Maybe FilePath-reqFile ext s-  | isExtFile ext s = Just s-  | otherwise = Nothing+  | otherwise = getFileInDirs (extModuleName name ext) paths  -------------------------------------------------------------------------------- -- Assemble Information for Spec Extraction ------------------------------------ -------------------------------------------------------------------------------- -makeMGIModGuts :: DesugaredModule -> MGIModGuts-makeMGIModGuts desugared = miModGuts deriv modGuts+makeMGIModGuts :: ModGuts -> MGIModGuts+makeMGIModGuts modGuts = miModGuts deriv modGuts   where-    modGuts = coreModule desugared     deriv   = Just $ instEnvElts $ mg_inst_env modGuts  makeLogicMap :: IO LogicMap@@ -809,7 +900,7 @@ -- | Pretty Printing ----------------------------------------------------------- -------------------------------------------------------------------------------- -instance PPrint GhcSpec where+instance PPrint TargetSpec where   pprintTidy k spec = vcat     [ "******* Target Variables ********************"     , pprintTidy k $ gsTgtVars (gsVars spec)@@ -822,20 +913,20 @@     , "******* Measure Specifications **************"     , pprintLongList k (gsMeas (gsData spec))       ] -instance PPrint GhcInfo where+instance PPrint TargetInfo where   pprintTidy k info = vcat     [ -- "*************** Imports *********************"       -- , intersperse comma $ text <$> imports info       -- , "*************** Includes ********************"       -- , intersperse comma $ text <$> includes info       "*************** Imported Variables **********"-    , pprDoc $ giImpVars (giSrc info)+    , pprDoc $ _giImpVars (review targetSrcIso $ giSrc info)     , "*************** Defined Variables ***********"-    , pprDoc $ giDefVars (giSrc info)+    , pprDoc $ _giDefVars (review targetSrcIso $ giSrc info)     , "*************** Specification ***************"     , pprintTidy k $ giSpec info     , "*************** Core Bindings ***************"-    , pprintCBs $ giCbs (giSrc info)                ]+    , pprintCBs $ _giCbs (review targetSrcIso $ giSrc info) ]  -- RJ: the silly guards below are to silence the unused-var checker pprintCBs :: [CoreBind] -> Doc@@ -846,7 +937,7 @@     pprintCBsTidy    = pprDoc . tidyCBs     pprintCBsVerbose = text . O.showSDocDebug unsafeGlobalDynFlags . O.ppr . tidyCBs -instance Show GhcInfo where+instance Show TargetInfo where   show = showpp  instance PPrint TargetVars where
+ src/Language/Haskell/Liquid/GHC/Logging.hs view
@@ -0,0 +1,65 @@+{- | 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 Language.Haskell.Liquid.GHC.Logging (+    fromPJDoc+  , putLogMsg+  , putWarnMsg+  , putErrMsg+  , putErrMsg'+  , mkLongErrAt+  ) where++import Data.Maybe++import qualified TcRnMonad as GHC++import qualified Language.Haskell.Liquid.GHC.API as GHC+import qualified Text.PrettyPrint.HughesPJ as PJ+import qualified Outputable as O++-- Unfortunately we need the import below to bring in scope 'PPrint' instances.+import Language.Haskell.Liquid.Types.Errors ()++fromPJDoc :: PJ.Doc -> O.SDoc+fromPJDoc = O.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 O.PprStyle+          -> PJ.Doc+          -> IO ()+putLogMsg dynFlags reason sev srcSpan mbStyle =+  GHC.putLogMsg dynFlags reason sev srcSpan style' . O.text . PJ.render+  where+    style' :: O.PprStyle+    style' = fromMaybe (O.defaultErrStyle dynFlags) mbStyle++putWarnMsg :: GHC.DynFlags -> GHC.SrcSpan -> PJ.Doc -> IO ()+putWarnMsg dynFlags srcSpan doc =+  putLogMsg dynFlags GHC.NoReason GHC.SevWarning srcSpan (Just $ O.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 'putErrMsg', but it uses GHC's internal 'Doc'. This can be very convenient when logging things+-- which comes directly from GHC rather than LiquidHaskell.+putErrMsg' :: GHC.DynFlags -> GHC.SrcSpan -> O.SDoc -> IO ()+putErrMsg' dynFlags srcSpan =+  GHC.putLogMsg dynFlags GHC.NoReason GHC.SevError srcSpan (O.defaultErrStyle dynFlags)++-- | Like GHC's 'mkLongErrAt', but it builds the final 'ErrMsg' out of two \"HughesPJ\"'s 'Doc's.+mkLongErrAt :: GHC.SrcSpan -> PJ.Doc -> PJ.Doc -> GHC.TcRn GHC.ErrMsg+mkLongErrAt srcSpan msg extra = GHC.mkLongErrAt srcSpan (fromPJDoc msg) (fromPJDoc extra)
src/Language/Haskell/Liquid/GHC/Misc.hs view
@@ -16,49 +16,30 @@  module Language.Haskell.Liquid.GHC.Misc where -import           Class                                      (classKey) import           Data.String import qualified Data.List as L import           PrelNames                                  (fractionalClassKeys)-import           FamInstEnv import           Debug.Trace--- import qualified ConLike                                    as Ghc  import qualified CoreUtils import qualified DataCon                                    -- (dataConInstArgTys, isTupleDataCon) import           Prelude                                    hiding (error)-import           Avail                                      (availsToNameSet)-import           BasicTypes                                 (Arity, noOccInfo) import           CoreSyn                                    hiding (Expr, sourceName) import qualified CoreSyn                                    as Core import           CostCentre-import           GHC                                        hiding (L)-import           HscTypes                                   (ModGuts(..), HscEnv(..), FindResult(..),-                                                             Dependencies(..))-import           TysWiredIn                                 (anyTy)-import           NameSet                                    (NameSet)-import           SrcLoc                                     hiding (L)+import           Language.Haskell.Liquid.GHC.API            as Ghc hiding (L, sourceName) import           Bag-import           ErrUtils import           CoreLint import           CoreMonad  import           Text.Parsec.Pos                            (incSourceColumn, sourceName, sourceLine, sourceColumn, newPos) -import           Name-import           Module                                     (moduleNameFS)-import           Unique import           Finder                                     (findImportedModule, cannotFindModule) import           Panic                                      (throwGhcException)-import           FastString import           TcRnDriver -- import           TcRnTypes  -import           RdrName-import           Type                                       (expandTypeSynonyms, isClassPred, isEqPred, liftedTypeKind)-import           TyCoRep-import           Var import           IdInfo import qualified TyCon                                      as TC import           Data.Char                                  (isLower, isSpace, isUpper)@@ -73,7 +54,6 @@ import           Control.Monad                              ((>=>)) import           Outputable                                 (Outputable (..), text, ppr) import qualified Outputable                                 as Out-import           DynFlags 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@@ -81,14 +61,11 @@ import           Language.Haskell.Liquid.Misc               (keyDiff)  import           Control.DeepSeq import           Language.Haskell.Liquid.Types.Errors--- import           Language.Haskell.Liquid.Desugar.HscMain-import           HscMain-import           Id                                         (isExportedId, idOccInfo, setIdInfo)   isAnonBinder :: TC.TyConBinder -> Bool-isAnonBinder (TvBndr _ TC.AnonTCB) = True-isAnonBinder (TvBndr _ _)          = False+isAnonBinder (Bndr _ (AnonTCB _)) = True+isAnonBinder (Bndr _ _)           = False  mkAlive :: Var -> Id mkAlive x@@ -98,44 +75,7 @@   = x  - ----------------------------------------------------------------------------------- | 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   :: !NameSet-  , 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  = mg_dir_imps mg-  , mgi_rdr_env   = mg_rdr_env mg-  , mgi_tcs       = mg_tcs mg-  , mgi_fam_insts = mg_fam_insts mg-  , mgi_exports   = availsToNameSet $ mg_exports mg-  , mgi_cls_inst  = cls-  }-  where _z        = showPpr (zing <$> mg_fam_insts mg)-        zing fi   = (fi_fam fi, fi_tcs fi, fi_tvs fi, fi_rhs fi)--mg_dir_imps :: ModGuts -> [ModuleName]-mg_dir_imps m = fst <$> (dep_mods $ mg_deps m)--mgi_namestring :: MGIModGuts -> String-mgi_namestring = moduleNameString . moduleName . mgi_module---------------------------------------------------------------------------------- -- | Encoding and Decoding Location -------------------------------------------- -------------------------------------------------------------------------------- srcSpanTick :: Module -> SrcSpan -> Tickish a@@ -180,7 +120,7 @@ -- same as Constraint isBase isBaseType :: Type -> Bool isBaseType (ForAllTy _ _)  = False-isBaseType (FunTy t1 t2)   = isBaseType t1 && isBaseType t2+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@@ -447,8 +387,8 @@ kindTCArity :: TyCon -> Arity kindTCArity = go . tyConKind   where-    go (FunTy _ res) = 1 + go res-    go _             = 0+    go (FunTy { ft_res = res}) = 1 + go res+    go _               = 0   kindArity :: Kind -> Arity@@ -546,7 +486,7 @@   symbol = symbol . fastStringText  fastStringText :: FastString -> T.Text-fastStringText = T.decodeUtf8With TE.lenientDecode . fastStringToByteString+fastStringText = T.decodeUtf8With TE.lenientDecode . bytesFS  tyConTyVarsDef :: TyCon -> [TyVar] tyConTyVarsDef c@@ -758,7 +698,7 @@ synTyConRhs_maybe :: TyCon -> Maybe Type synTyConRhs_maybe = TC.synTyConRhs_maybe -tcRnLookupRdrName :: HscEnv -> GHC.Located RdrName -> IO (Messages, Maybe [Name])+tcRnLookupRdrName :: HscEnv -> Ghc.Located RdrName -> IO (Messages, Maybe [Name]) tcRnLookupRdrName = TcRnDriver.tcRnLookupRdrName  showCBs :: Bool -> [CoreBind] -> String@@ -807,7 +747,6 @@ --   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 . CoreUtils.exprType @@ -817,7 +756,7 @@     msg     =  "isGoodCaseBind v = " ++ show v  isPredType :: Type -> Bool-isPredType = anyF [ isClassPred, isEqPred ]+isPredType = anyF [ isClassPred, isEqPred, isEqPrimPred ]  anyF :: [a -> Bool] -> a -> Bool anyF ps x = or [ p x | p <- ps ]@@ -826,13 +765,17 @@ -- | '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, [Type])]+defaultDataCons :: Type -> [AltCon] -> Maybe [(DataCon, [TyVar], [Type])] defaultDataCons (TyConApp tc argτs) ds = do    allDs     <- TC.tyConDataCons_maybe tc   let seenDs = [d | DataAlt d <- ds ]   let defDs  = keyDiff showPpr allDs seenDs -  return [ (d, DataCon.dataConInstArgTys d argτs) | d <- defDs ] +  return [ (d, Ghc.dataConExTyVars d, DataCon.dataConInstArgTys d argτs) | d <- defDs ]   defaultDataCons _ _ =    Nothing +++isEvVar :: Id -> Bool +isEvVar x = isPredVar x || isTyVar x || isCoVar x
src/Language/Haskell/Liquid/GHC/Play.hs view
@@ -10,21 +10,36 @@ import GHC import CoreSyn import Var-import TyCoRep hiding (substTysWith) import DataCon  import TyCon-import Type      (tyConAppArgs_maybe, tyConAppTyCon_maybe, binderVar) import PrelNames (isStringClassName)  import           Control.Arrow       ((***)) import qualified Data.HashMap.Strict as M import qualified Data.List           as L +import Language.Haskell.Liquid.GHC.API as Ghc hiding (substTysWith) import Language.Haskell.Liquid.GHC.Misc () import Language.Haskell.Liquid.Types.Errors  +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) @@ -92,14 +107,14 @@  subTy     = substTysWith  substTysWith :: M.HashMap Var Type -> Type -> Type-substTysWith s tv@(TyVarTy v)  = M.lookupDefault tv v s-substTysWith s (FunTy t1 t2)   = FunTy (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 +substTysWith s tv@(TyVarTy v)    = M.lookupDefault tv v s+substTysWith s (FunTy aaf t1 t2) = FunTy aaf (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 @@ -120,17 +135,19 @@ 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 t1 t2)   = f $ FunTy (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 +    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 t1 t2)  = f $ FunTy aaf (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
+ src/Language/Haskell/Liquid/GHC/Plugin.hs view
@@ -0,0 +1,518 @@+-- | This module provides a GHC 'Plugin' that allows LiquidHaskell to be hooked directly into GHC's+-- compilation pipeline, facilitating its usage and adoption.++{-# LANGUAGE MultiWayIf                 #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE ViewPatterns               #-}++module Language.Haskell.Liquid.GHC.Plugin (++  plugin++  ) where++import qualified Outputable                              as O+import           GHC                               hiding ( Target+                                                          , Located+                                                          , desugarModule+                                                          )++import           Plugins                                 as GHC+import           TcRnTypes                               as GHC+import           TcRnMonad                               as GHC++import qualified Language.Haskell.Liquid.GHC.Misc        as LH+import qualified Language.Haskell.Liquid.UX.CmdLine      as LH+import qualified Language.Haskell.Liquid.GHC.Interface   as LH+import qualified Language.Haskell.Liquid.Liquid          as LH+import qualified Language.Haskell.Liquid.Types.PrettyPrint as LH (reportErrors)+import qualified Language.Haskell.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           Language.Haskell.Liquid.GHC.Types       (MGIModGuts(..), miModGuts)+import qualified Language.Haskell.Liquid.GHC.GhcMonadLike+                                                         as GhcMonadLike+import           Language.Haskell.Liquid.GHC.GhcMonadLike ( GhcMonadLike+                                                          , askHscEnv+                                                          )+import           CoreMonad+import           DataCon+import           DynFlags+import           HscTypes                          hiding ( Target )+import           InstEnv+import           Module+import           FamInstEnv+import qualified TysPrim+import           GHC.LanguageExtensions++import           Control.Monad+import           Control.Exception                        (evaluate)++import           Data.Coerce+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 ( 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+++---------------------------------------------------------------------------------+-- | 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 = typecheckHook+  , dynflagsPlugin        = customDynFlags+  , pluginRecompile       = purePlugin+  }++--------------------------------------------------------------------------------+-- | 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++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 :: *+  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 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 = []+                                                              }+                   }++-- | Partially calls into LiquidHaskell's GHC API.+liquidHaskellCheck :: PipelineData -> ModSummary -> TcGblEnv -> TcM TcGblEnv+liquidHaskellCheck pipelineData modSummary tcGblEnv = do+  cfg <- liftIO getConfig++  -- 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 :: BareSpec <- getLiquidSpec thisModule (pdSpecComments pipelineData) specQuotes++  debugLog $ " Input spec: \n" ++ show inputSpec+  debugLog $ "Relevant ===> \n" ++ (unlines $ map 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+      }++  ProcessModuleResult{..} <- processModule lhContext++  -- Call into the existing Liquid interface+  out <- liftIO $ LH.checkTargetInfo pmrTargetInfo++  -- Report the outcome of the checking+  LH.reportResult errorLogger cfg [giTarget (giSrc pmrTargetInfo)] out+  case o_result out of+    Safe _stats -> pure ()+    _           -> failM++  let serialisedSpec = Util.serialiseLiquidLib pmrClientLib thisModule+  debugLog $ "Serialised annotation ==> " ++ (O.showSDocUnsafe . O.ppr $ serialisedSpec)++  pure $ tcGblEnv { tcg_anns = serialisedSpec : tcg_anns tcGblEnv }+  where+    thisModule :: Module+    thisModule = tcg_mod tcGblEnv++    modGuts :: ModGuts+    modGuts = fromUnoptimised . pdUnoptimisedCore $ pipelineData++    errorLogger :: OutputResult -> TcM ()+    errorLogger outputResult = do+      errs <- forM (LH.orMessages outputResult) $ \(spn, e) -> mkLongErrAt spn (LH.fromPJDoc e) O.empty+      GHC.reportErrors errs+++--------------------------------------------------------------------------------+-- | 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 . fst) . filter (not . snd) . dep_mods $ deps++    deps :: Dependencies+    deps = mg_deps modGuts++    thisModule :: Module+    thisModule = mg_module modGuts++    toModule :: ModuleName -> Module+    toModule = Module (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 :: Module -> [SpecComment] -> [BPspec] -> TcM BareSpec+getLiquidSpec thisModule specComments specQuotes = do++  let commSpecE :: Either [Error] (ModName, Spec LocBareType LocSymbol)+      commSpecE = hsSpecificationP (moduleName thisModule) (coerce specComments) specQuotes+  case commSpecE of+    Left errors -> do+      LH.reportErrors Full errors+      failM+    Right (view bareSpecIso . snd -> commSpec) -> do+      res <- SpecFinder.findCompanionSpec thisModule+      case res of+        SpecFound _ _ companionSpec -> do+          debugLog $ "Companion spec found for " ++ renderModule thisModule+          pure $ commSpec <> companionSpec+        _ -> pure commSpec++processModule :: LiquidHaskellContext -> TcM 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)++  moduleCfg           <- liftIO $ withPragmas lhGlobalCfg file (Ms.pragmas $ review bareSpecIso bareSpec)+  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 <-+    (liftIO $ evaluate (makeTargetSpec moduleCfg lhModuleLogicMap targetSrc bareSpec dependencies))+      `gcatch` (\(e :: UserError) -> LH.reportErrors Full [e] >> failM)+      `gcatch` (\(e :: Error)     -> LH.reportErrors Full [e] >> failM)++  case result of+    -- Print warnings and errors, aborting the compilation.+    Left diagnostics -> do+      liftIO $ mapM_ (printWarning dynFlags)    (allWarnings diagnostics)+      LH.reportErrors Full (allErrors diagnostics)+      failM++    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 result++  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 $ "defVars  => " ++ show (L.nub $ dataCons ++ (letVars coreBinds) ++ tcAvailableVars 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   = TysPrim.primTyCons+    , gsQualImps  = tcQualifiedImports tcData+    , gsAllImps   = tcAllImports       tcData+    , gsTyThings  = [ t | (_, Just t) <- things ]+    }+  where+    mgiModGuts :: MGIModGuts+    mgiModGuts = miModGuts deriv modGuts+      where+        deriv   = Just $ instEnvElts $ mg_inst_env modGuts++getFamInstances :: ModGuts -> [FamInst]+getFamInstances guts = famInstEnvElts (mg_fam_inst_env guts)
+ src/Language/Haskell/Liquid/GHC/Plugin/SpecFinder.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes   #-}++module Language.Haskell.Liquid.GHC.Plugin.SpecFinder+    ( findRelevantSpecs+    , findCompanionSpec+    , SpecFinderResult(..)+    , SearchLocation(..)+    , configToRedundantDependencies+    ) where++import           Language.Haskell.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 Outputable                              as O+import           GHC                                     hiding (lookupModule)+import           HscTypes+import           CoreMonad                                ( getDynFlags )+import           Finder                                   ( findExposedPackageModule+                                                          )++import           Data.Bifunctor+import           Data.Foldable+import           Data.Maybe++import           Control.Exception+import           Control.Monad.IO.Class+import           Control.Monad.Trans                      ( lift )+import           Control.Monad.Trans.Maybe++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 in the input 'SpecEnv', by updating it. The update will happen only if necessary,+-- i.e. if the spec is not already present.+findRelevantSpecs :: forall m. GhcMonadLike m +                  => ExternalPackageState+                  -> HomePackageTable+                  -> [Module]+                  -- ^ Any relevant module fetched during dependency-discovery.+                  -> m [SpecFinderResult]+findRelevantSpecs eps hpt mods = do+  res  <- foldlM loadRelevantSpec mempty mods+  pure res+  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 parsingError -> do+      dynFlags <- lift getDynFlags+      let errMsg = O.text "Error when parsing " +             O.<+> O.text (specFile file) O.<+> O.text ":"+             O.<+> O.text (show parsingError)+      lift $ pluginAbort (O.showSDoc dynFlags errMsg)+    Right (_, spec) -> do+      let bareSpec = view bareSpecIso spec+      pure $ SpecFound thisModule DiskLocation bareSpec+  where+    specFile :: FilePath -> FilePath+    specFile fp = withExt fp Spec++-- | Returns a list of 'StableModule's which can be filtered out of the dependency list, because they are+-- selectively \"toggled\" on and off by the LiquidHaskell's configuration, which granularity can be+-- /per module/.+configToRedundantDependencies :: forall m. GhcMonadLike m => Config -> m [StableModule]+configToRedundantDependencies cfg = do+  env <- askHscEnv+  catMaybes <$> mapM (lookupModule env . first ($ cfg)) configSensitiveDependencies+  where+    lookupModule :: HscEnv -> (Bool, ModuleName) -> m (Maybe StableModule)+    lookupModule env (fetchModule, modName)+      | fetchModule = liftIO $ lookupLiquidBaseModule env modName+      | otherwise   = pure Nothing++    lookupLiquidBaseModule :: HscEnv -> ModuleName -> IO (Maybe StableModule)+    lookupLiquidBaseModule env mn = do+      res <- liftIO $ findExposedPackageModule env mn (Just "liquid-base")+      case res of+        Found _ mdl -> pure $ Just (toStableModule mdl)+        _           -> pure Nothing++-- | Static associative map of the 'ModuleName' that needs to be filtered from the final 'TargetDependencies'+-- due to some particular configuration options.+--+-- Modify this map to add any extra special case. Remember that the semantic is not which module will be+-- /added/, but rather which one will be /removed/ from the final list of dependencies.+--+configSensitiveDependencies :: [(Config -> Bool, ModuleName)]+configSensitiveDependencies = [+    (not . totalityCheck, mkModuleName "Liquid.Prelude.Totality")+  , (not . linear, mkModuleName "Liquid.Prelude.NotReal")+  , (linear, mkModuleName "Liquid.Prelude.Real")+  ]
+ src/Language/Haskell/Liquid/GHC/Plugin/Tutorial.hs view
@@ -0,0 +1,236 @@++module Language.Haskell.Liquid.GHC.Plugin.Tutorial (++  -- * Introduction and Requirements+  -- $introduction++  -- * Your first package+  -- $firstPackage++  -- * Using GHCi+  -- $usingGHCi++  -- * Passing options+  -- $passingOptions++  -- * Understanding LiquidHaskell Spec resolution strategies+  -- $specResolutionStrategies++  -- * Providing specifications for existing packages+  -- $specForExisting++) where++{- $introduction++This tutorial describes the general approach of using LiquidHaskell using the new compiler plugin. Due+to some recent changes and improvements to the compiler plugin API (which LiquidHaskell requires) the+__minimum supported version of GHC is 8.10.1.__++-}++{- $firstPackage++Generally speaking, in order to integrate LiquidHaskell (/LH/ for brevity from now on) with your existing+(or brand new) project, we need a few things:++* We need to tell GHC that we want to __use the LH plugin__, and it can be done by adding the+  @-fplugin=LiquidHaskell@ option in the @ghc-options@ of your Cabal manifest;++* We need to tell LH where to find the /specs/ (i.e. the refinements) for the types in @base@. To do this,+  we need to depend on a special, __drop-in replacement__ for @base@ called @liquid-base@.++If we do all the above, our Cabal manifest should look similar to this:++@+cabal-version: 1.12++name:           toy-package-a+version:        0.1.0.0+description:    This is a toy example.+homepage:+bug-reports:+author:         Author name here+maintainer:     example@example.com+copyright:      2019 Author name here+license:        BSD3+license-file:   LICENSE+build-type:     Simple++library+  exposed-modules:+      Toy.A+  hs-source-dirs:+      src+  build-depends:+        liquid-base                    -- Add this!+      , liquidhaskell+  default-language: Haskell2010+  ghc-options: -fplugin=LiquidHaskell  -- Add this!+@++Let's now define a very simple module called 'Toy.A':++@+module Toy.A ( notThree, one, two) where++\{\-\@ one :: {v:Int | v = 1 } \@\-\}+one :: Int+one = 1++\{\-\@ assume notThree :: {v : Nat | v != 3 } \@\-\}+notThree :: Int+notThree = 4++\{\-\@ two :: Nat \@\-\}+two :: Int+two = one + one+@++Now, if we build the package with (for example) @cabal v2-build toy-package-a@, we should see something+like this:++@+Resolving dependencies...+Build profile: -w ghc-8.10.1 -O1+In order, the following will be built (use -v for more details):+ - toy-package-a-0.1.0.0 (lib) (configuration changed)+Configuring library for toy-package-a-0.1.0.0..+Warning: The 'license-file' field refers to the file 'LICENSE' which does not+exist.+Preprocessing library for toy-package-a-0.1.0.0..+Building library for toy-package-a-0.1.0.0..++[3 of 3] Compiling Toy.A            ( src\/Toy\/A.hs, ... )++**** LIQUID: SAFE (7 constraints checked) **************************************+@++The \"SAFE\" banner here is LH's way of saying "all is well". What happens if we try to violate a+refinement? Let's find out. If change @one@ to look like this:++@+{-@ one :: {v:Int | v = 1 } @-}+one :: Int+one = 2+@++Upon next recompilation, GHC (or rather, /LH/) will bark at us:++@+Building library for toy-package-a-0.1.0.0..+[3 of 3] Compiling Toy.A            ( src\/Toy\/A.hs, ... )++**** LIQUID: UNSAFE ************************************************************++src\/Toy\/A.hs:36:1: error:+    Liquid Type Mismatch+    .+    The inferred type+      VV : {v : GHC.Types.Int | v == 2}+    .+    is not a subtype of the required type+      VV : {VV : GHC.Types.Int | VV == 1}+    .+   |+36 | one = 2+   | ^^^^^^^+@++-}++{- $passingOptions++Passing options to /LH/ is possible and works using the standard mechanism the plugin system already provides.+For example let's image we want to skip verification of our 'Toy.A' module. At this point, we have two options:++1. We can add the option directly in the module, as a \"pragma\":++    @+    \{\-\@ LIQUID "--compilespec" \@\-\}+    module Toy.A ( notThree, one, two) where+    ...+    @++2. We can add this \"globally\" (if that's really what we want), like this:++    @+    cabal-version: 1.12+    name:           toy-package-a+      ..+      default-language: Haskell2010+      ghc-options: -fplugin=LiquidHaskell -fplugin-opt=LiquidHaskell:--compilespec+    @++-}++{- $usingGHCi++Using GHCi is supported out of the box, and it will work as expected.++-}++{- $specResolutionStrategies++Let's revisit our 'Toy.A' module. There are two different ways to annotate an existing Haskell module,+and they are the following:++1. __(Recommended)__ Add the /LH/ annotations directly inside the Haskell file (like in the example above).+   This has the advantage that any changes to the annotations trigger recompilation, and ensure the specs+   will never get stale and go out-of-sync. The disadvantage of this approach is that it can clutter quite a+   bit the target 'Module'.++2. Add the specifications as a separate __companion__ @.spec@ file to be placed alongside the Haskell one.+   To rehash the example above, we could have also added a new @Toy/A.spec@ file living in the same folder+   of our @A.hs@ file, with a content like this:++   @+   module spec Toy.A where++   one :: {v:Int | v = 1 }+   assume notThree :: {v : Nat | v != 3 }+   two :: Nat+   @++   This has the advantage of being more compartmentalised, but it's also a weakness as it might not be+   immediately obvious that a Haskell module has associated refinements.++-}++{- $specForExisting++If you have control over the package or project you would like to annotate with /LH/ refinements, all is well.+But what about packages you don't own or maintain? Typically, one solution would be to convince the+project's maintainers to get on board and to add /LH/ annotations to the code themselves, but this might not+be so easy, for a number of reasons:++* The package you are trying to \"refine\" is not maintained anymore, or the maintainer is very difficult+  to reach;++* The package is fairly important in the Haskell ecosystem and making changes to it might not be so easy,+  especially for packages which come as part of a GHC installation (think @base@, for example).++The designed workflow in these cases is to create a __brand new package__ (that we can call \"mirror\" package),+which would re-export /everything/ from the \"mirrored\" package while adding all the required /LH/+annotations. This is what we have done for things like @base@, @ghc-prim@ and @containers@, for example, by+providing @liquid-containers@, @liquid-ghc-prim@ and @liquid-base@, the latter being what we have used in+the tutorial to get started.++There are some very simple guidelines to drive this process:++1. Typically you want to clearly identify this package as part of the /LH ecosystem/ by using an+   appropriate prefix for your package name, something like @liquid-foo@ where @foo@ is the original+   package you are adding annotations for;++2. You need to abide to a set of PVP rules, like tracking the version of the upstream package first and+   in case of changes to either the LH language or the specs in the mirror package, bump the last two+   digits of the version scheme, in a format like this:++   @liquid-\<package-name\>-A.B.C.D.X.Y@++   Where @A.B.C.D@ would be used to track the upstream package version and @X.Y@ would enumerate the+   versions of this mirror package. Bumping @X@ would signify there was a breaking change in the /LH/+   language that required a new release of this plugin, whereas bumping @Y@ would mean something changed+   in the __specs__ provided as part of this mirror package (e.g. more refinements were added, bugs were+   fixed etc).+-}
+ src/Language/Haskell/Liquid/GHC/Plugin/Types.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# 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           Outputable                        hiding ( (<>) )+import           GHC.Generics                      hiding ( moduleName )+import           HscTypes                                 (ModGuts)+import           GHC                                      ( Name+                                                          , TyThing+                                                          , TyCon+                                                          , LImportDecl+                                                          , GhcRn+                                                          )+import           Var                                      ( Var )+import           Module                                   ( Module, moduleStableString )++import qualified Data.HashSet        as HS+import           Data.Hashable++import           Language.Fixpoint.Types.Spans+import           Language.Haskell.Liquid.Types.Specs+import qualified Language.Haskell.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 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 (StableModule 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 (StableModule m) _) = moduleStableString m++cachedSpecModule :: CachedSpec -> Module+cachedSpecModule (CachedSpec (StableModule m) _) = m++fromCached :: CachedSpec -> (StableModule, LiftedSpec)+fromCached (CachedSpec sm s) = (sm, s)++---+--- A Liquid spec and its (many) flavours+---++data InputSpec+data CompanionSpec++data LiquidSpec t where+    MkInputSpec     :: BareSpec   -> LiquidSpec InputSpec+    MkCompanionSpec :: BareSpec   -> LiquidSpec CompanionSpec++deriving instance Show (LiquidSpec InputSpec)+deriving instance Show (LiquidSpec CompanionSpec)++mkInputSpec :: BareSpec -> LiquidSpec InputSpec+mkInputSpec = MkInputSpec++mkCompanionSpec :: BareSpec -> LiquidSpec CompanionSpec+mkCompanionSpec = MkCompanionSpec++downcastSpec :: LiquidSpec t -> BareSpec+downcastSpec = \case+  MkInputSpec s    -> s+  MkCompanionSpec s -> s++-- | Merges a 'InputSpec' with its 'CompanionSpec'. Here duplicates are not checked as it's+-- user's responsibility to make sure there are no duplicates between the in-module annotations and the+-- companion spec.+mergeInputWithCompanion :: LiquidSpec InputSpec -> LiquidSpec CompanionSpec -> LiquidSpec InputSpec+mergeInputWithCompanion (MkInputSpec s1) (MkCompanionSpec s2) = MkInputSpec (s1 <> s2)++-- | Just a small wrapper around the 'SourcePos' and the text fragment of a LH spec comment.+newtype SpecComment =+    SpecComment (SourcePos, String)+    deriving (Show, Data)++newtype Unoptimised a = Unoptimised { fromUnoptimised :: a }++toUnoptimised :: a -> Unoptimised a+toUnoptimised = Unoptimised++--+-- Passing data between stages of the pipeline+--+-- The plugin architecture doesn't provide a default system to \"thread\" data across stages of the+-- compilation pipeline, which means that plugin implementors have two choices:+--+-- 1. Serialise any data they want to carry around inside annotations, but this can be potentially costly;+-- 2. Pass data inside IORefs.++data PipelineData = PipelineData {+    pdUnoptimisedCore :: Unoptimised ModGuts+  , pdTcData :: TcData+  , pdSpecComments :: [SpecComment]+  }++-- | Data which can be \"safely\" passed to the \"Core\" stage of the pipeline.+-- The notion of \"safely\" here is a bit vague: things like imports are somewhat+-- guaranteed not to change, but things like identifiers might, so they shouldn't+-- land here.+data TcData = TcData {+    tcAllImports       :: HS.HashSet Symbol+  , tcQualifiedImports :: QImports+  , tcResolvedNames    :: [(Name, Maybe TyThing)]+  , tcAvailableTyCons  :: [GHC.TyCon]+  -- ^ Sometimes we might be in a situation where we have \"wrapper\" modules that+  -- simply re-exports everything from the original module, and therefore when LH+  -- tries to resolve the GHC identifier associated to a data constructor in scope+  -- (from the call to 'lookupTyThings') we might not be able to find a match because+  -- the 'mg_tcs' for the input 'ModGuts' is empty (because the type constructor are not+  -- defined in the /wrapper/ module, but rather in the /wrapped/ module itself). This is+  -- why we look at the 'ModGuts' 's 'AvailInfo' to extract any re-exported 'TyCon' out of that.+  , tcAvailableVars    :: [Var]+  -- ^ Ditto as for 'reflectedTyCons', but for identifiers.+  }++instance Outputable TcData where+    ppr (TcData{..}) =+          text "TcData { imports     = " <+> text (show $ HS.toList tcAllImports)+      <+> text "       , qImports    = " <+> text (show tcQualifiedImports)+      <+> text "       , names       = " <+> ppr tcResolvedNames+      <+> text "       , availTyCons = " <+> ppr tcAvailableTyCons+      <+> text " }"++-- | Constructs a 'TcData' out of a 'TcGblEnv'.+mkTcData :: [LImportDecl GhcRn]+         -> [(Name, Maybe TyThing)]+         -> [TyCon]+         -> [Var]+         -> TcData+mkTcData imps resolvedNames availTyCons availVars = TcData {+    tcAllImports       = LH.allImports       imps+  , tcQualifiedImports = LH.qualifiedImports imps+  , tcResolvedNames    = resolvedNames+  , tcAvailableTyCons  = availTyCons+  , tcAvailableVars    = availVars+  }
+ src/Language/Haskell/Liquid/GHC/Plugin/Util.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}+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           GhcPlugins                              as GHC+import           UniqDFM+import           IfaceSyn+import           Panic                                    ( throwGhcExceptionIO, GhcException(..) )+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           Language.Haskell.Liquid.GHC.Plugin.Types ( SpecComment+                                                          , LiquidLib+                                                          )+++pluginAbort :: MonadIO m => String -> m a+pluginAbort = liftIO . throwGhcExceptionIO . ProgramError++-- | Courtesy of [inspection testing](https://github.com/nomeata/inspection-testing/blob/master/src/Test/Inspection/Plugin.hs)+partitionMaybe :: (a -> Maybe b) -> [a] -> ([a], [b])+partitionMaybe f = partitionEithers . map (\x -> maybe (Left x) Right (f x))++-- | Extracts the spec comments from the Core 'Annotation's. It returns a+-- "cleaned" 'ModGuts' which doesn't contain the deserialised 'Annotation's.+-- This also means that these 'Annotation's /won't/ land into an interface file,+-- and we won't be able to retrieve them back later on.+extractSpecComments :: ModGuts -> (ModGuts, [SpecComment])+extractSpecComments = extractModuleAnnotations++-- | Tries to deserialise the 'Annotation's in the input 'ModGuts', pruning the latter+-- upon successful deserialisation.+extractModuleAnnotations :: forall a. (Typeable a, Data a) => ModGuts -> (ModGuts, [a])+extractModuleAnnotations guts = (guts', extracted)+  where+    thisModule = mg_module guts+    (anns_clean, extracted) = partitionMaybe tryDeserialise (mg_anns guts)+    guts' = guts { mg_anns = anns_clean }++    tryDeserialise :: Annotation -> Maybe a+    tryDeserialise (Annotation (ModuleTarget m) payload)+        | thisModule == m = fromSerialized deserializeWithData payload+        | otherwise       = Nothing+    tryDeserialise (Annotation (NamedTarget _) payload) --NOTE(adn) What is the correct behaviour here?+        | Just a <- fromSerialized deserializeWithData payload+        = Just a+    tryDeserialise _+        = Nothing++--+-- Serialising and deserialising Specs+--++deserialiseBinaryObject :: forall a. (Typeable a, Binary a)+                        => Module+                        -> ExternalPackageState+                        -> HomePackageTable+                        -> Maybe a+deserialiseBinaryObject thisModule eps hpt = asum [extractFromHpt, extractFromEps]+  where+    extractFromEps :: Maybe a+    extractFromEps = listToMaybe $ findAnns deserialise (eps_ann_env eps) (ModuleTarget thisModule)++    extractFromHpt :: Maybe a+    extractFromHpt = do+      modInfo <- lookupUDFM hpt (moduleName thisModule)+      guard (thisModule == (mi_module . hm_iface $ modInfo))+      xs <- mapM (fromSerialized deserialise . ifAnnotatedValue) (mi_anns . hm_iface $ modInfo)+      listToMaybe xs++    deserialise :: [B.Word8] -> a+    deserialise payload = B.decode (B.pack payload)++serialiseBinaryObject :: forall a. (Binary a, Typeable a) => a -> Module -> Annotation+serialiseBinaryObject obj thisModule = serialised+  where+    serialised :: Annotation+    serialised = Annotation (ModuleTarget thisModule) (toSerialized (B.unpack . B.encode) obj)++-- | Serialise a 'LiquidLib', removing the termination checks from the target.+serialiseLiquidLib :: LiquidLib -> Module -> Annotation+serialiseLiquidLib lib = serialiseBinaryObject @LiquidLib lib++deserialiseLiquidLib :: Module -> ExternalPackageState -> HomePackageTable -> Maybe LiquidLib+deserialiseLiquidLib thisModule = deserialiseBinaryObject @LiquidLib thisModule
src/Language/Haskell/Liquid/GHC/TypeRep.hs view
@@ -14,26 +14,22 @@ -- | This module contains a wrappers and utility functions for -- accessing GHC module information. It should NEVER depend on module Language.Haskell.Liquid.GHC.TypeRep (-  module TyCoRep, -   mkTyArg,     showTy   ) where -import TyCoRep import Coercion import CoAxiom-import Type -import Var  import           Language.Haskell.Liquid.GHC.Misc (showPpr)+import           Language.Haskell.Liquid.GHC.API as Ghc hiding (mkTyArg) import           Language.Fixpoint.Types (symbol)  -- e368f3265b80aeb337fbac3f6a70ee54ab14edfd  mkTyArg :: TyVar -> TyVarBinder-mkTyArg v = TvBndr v Required+mkTyArg v = Bndr v Required  instance Eq Type where   t1 == t2 = eqType' t1 t2@@ -45,9 +41,9 @@   = c1 == c2   eqType'(CastTy t1 c1) (CastTy t2 c2)    = eqType' t1 t2 && c1 == c2 -eqType' (FunTy t11 t12) (FunTy t21 t22)-  = eqType' t11 t21 && eqType' t12 t22  -eqType' (ForAllTy (TvBndr v1 _) t1) (ForAllTy (TvBndr v2 _) t2) +eqType' (FunTy a1 t11 t12) (FunTy a2 t21 t22)+  = a1 == a2 && 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 @@ -59,7 +55,7 @@   = False   -deriving instance (Eq tyvar, Eq argf) => Eq (TyVarBndr tyvar argf)+deriving instance (Eq tyvar, Eq argf) => Eq (VarBndr tyvar argf)  instance Eq Coercion where   _ == _ = True @@ -69,8 +65,8 @@ 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 (TvBndr v _) t)  = "ForAllTy " ++ show (symbol v) ++ ". (" ++  showTy t ++ ")"-showTy (FunTy t1 t2)   = "FunTy " ++ showTy t1 ++ ". (" ++  showTy t2 ++ ")"+showTy (ForAllTy (Bndr v _) t)  = "ForAllTy " ++ show (symbol v) ++ ". (" ++  showTy t ++ ")"+showTy (FunTy af t1 t2) = "FunTy " ++ showPpr af ++ " " ++ showTy t1 ++ ". (" ++  showTy t2 ++ ")" showTy (CastTy _ _)    = "CastTy" showTy (CoercionTy _)  = "CoercionTy" showTy (LitTy _)       = "LitTy"@@ -103,9 +99,9 @@   = tx    | otherwise   = TyVarTy y -substType x tx (FunTy t1 t2)-  = FunTy (subst x tx t1) (subst x tx t2)-substType x tx f@(ForAllTy b@(TvBndr y _) t)  +substType x tx (FunTy aaf t1 t2)+  = FunTy aaf (subst x tx t1) (subst x tx t2)+substType x tx f@(ForAllTy b@(Bndr y _) t)     | symbol x == symbol y    = f   | otherwise @@ -122,8 +118,6 @@   subst = substCoercion  substCoercion :: TyVar -> Type -> Coercion -> Coercion-substCoercion x tx (Refl r t)-  = Refl (subst x tx r) (subst x tx t) substCoercion x tx (TyConAppCo r c cs)   = TyConAppCo (subst x tx r) c (subst x tx <$> cs) substCoercion x tx (AppCo c1 c2)@@ -153,14 +147,26 @@   = LRCo i (subst x tx c) substCoercion x tx (InstCo c1 c2)   = InstCo (subst x tx c1) (subst x tx c2)-substCoercion x tx (CoherenceCo c1 c2)-  = CoherenceCo (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)-substCoercion _ _ (HoleCo _)-  = error "substCoercion: TODO handle HoleCo"+#ifdef MIN_VERSION_GLASGOW_HASKELL+#if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) && !MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)+substCoercion x tx (Refl r t)+  = Refl (subst x tx r) (subst x tx t)+substCoercion x tx (CoherenceCo c1 c2)+  = CoherenceCo (subst x tx c1) (subst x tx c2)+#endif+#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)+substCoercion x tx (Refl t)+  = Refl (subst x tx t)+substCoercion x tx (GRefl r t co) -- FIXME(adn) Is this a correct substitution?+  = GRefl r (subst x tx t) co     -- FIXME(adn) Is this a correct substitution?+substCoercion _x _tx (HoleCo cH)+  = HoleCo cH                     -- FIXME(adn) Is this a correct substitution?+#endif+#endif  instance SubstTy Role where instance SubstTy (CoAxiom Branched) where
+ src/Language/Haskell/Liquid/GHC/Types.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE DeriveGeneric #-}+module Language.Haskell.Liquid.GHC.Types where++import           Data.HashSet (HashSet, fromList)+import           Data.Hashable+import           FamInstEnv+import           GHC.Generics hiding (moduleName)+import           Language.Haskell.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  = mg_dir_imps 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++mg_dir_imps :: ModGuts -> [ModuleName]+mg_dir_imps m = fst <$> (dep_mods $ mg_deps m)++mgi_namestring :: MGIModGuts -> String+mgi_namestring = moduleNameString . moduleName . mgi_module
src/Language/Haskell/Liquid/LawInstances.hs view
@@ -3,52 +3,58 @@  import qualified Data.List                                  as L import qualified Data.Maybe                                 as Mb-import           Text.PrettyPrint.HughesPJ +import           Text.PrettyPrint.HughesPJ                  hiding ((<>))  import           Language.Haskell.Liquid.Types import           Language.Haskell.Liquid.Types.Equality-import           Language.Haskell.Liquid.GHC.API            +import           Language.Haskell.Liquid.GHC.API import qualified Language.Fixpoint.Types                     as F -checkLawInstances :: GhcSpecLaws -> [Error]    -checkLawInstances speclaws = concatMap go (gsLawInst speclaws) -  where go l = checkOneInstance (lilName l) (Mb.fromMaybe [] $ L.lookup (lilName l) (gsLawDefs speclaws)) l +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 -> [Error]-checkOneInstance c laws li -  = checkExtra c li ((fst <$> laws) ++ classMethods c) (lilEqus li) ++ concatMap (\l -> checkOneLaw c l li) laws+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))] -> [Error]-checkExtra c li _laws insts = mkError <$> ({- (msgExtra <$> extra) ++ -}  (msgUnfoundLaw <$> unfoundLaws) ++ (msgUnfoundInstance <$> unfoundInstances))-    where -        unfoundInstances = [ x | (_, (Right x,_)) <- insts] -        unfoundLaws = [ x | (Right x, _) <- insts] +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) +        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 -> [Error]-checkOneLaw c (x, t) li -  | Just (Left _, Just ti) <- lix +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-  = [mkError (text "is not found.")]+  = mkDiagnostics mempty [mkError (text "is not found.")]   | otherwise-  = [mkError (text "is not defined.")]-  where +  = 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 +    pprintXs [l] = pprint l+    pprintXs xs  = pprint xs -unify :: (Doc -> Error) -> Class -> LawInstance -> LocSpecType -> LocSpecType -> [Error]-unify mkError c li t1 t2 -  = if t11 =*= t22 then [] else err-  where -    err = [mkError (text "is invalid:\nType" <+> pprint t1 <+> text "\nis different than\n" <+> pprint t2+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 @@ -73,12 +79,12 @@     esubst1 = zip  (fst <$> args1) ((F.EVar . fst) <$> args2)      tsubst = reverse $ zip ((\(RTV v) -> v) <$> (findTyVars tc1 ++ (ty_var_value <$> concat argVars)))-                 (toType <$> (argBds ++ (((`RVar` mempty) . ty_var_value) <$>ty_vars trep2)))+                 (toType <$> (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) +    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 ]
src/Language/Haskell/Liquid/Liquid.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE NamedFieldPuns      #-} {-# LANGUAGE TupleSections       #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards     #-}  {-@ LIQUID "--diff"     @-} @@ -16,6 +17,9 @@     -- * Liquid Constraint Generation    , liquidConstraints++   -- * Checking a single module+  , checkTargetInfo   ) where  import           Prelude hiding (error)@@ -28,16 +32,17 @@ import           HscTypes                         (SourceError) import           GHC (HscEnv) import           System.Console.CmdArgs.Verbosity (whenLoud, whenNormal)-import           Control.Monad (when)+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.Fixpoint.Types.Config as FC 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.Types.RefType (applySolution)+import           Language.Haskell.Liquid.Synthesize (synthesize) import           Language.Haskell.Liquid.UX.Errors import           Language.Haskell.Liquid.UX.CmdLine import           Language.Haskell.Liquid.UX.Tidy@@ -46,20 +51,18 @@ import           Language.Haskell.Liquid.Constraint.Generate import           Language.Haskell.Liquid.Constraint.ToFixpoint import           Language.Haskell.Liquid.Constraint.Types--- import           Language.Haskell.Liquid.Model--- import           Language.Haskell.Liquid.Transforms.Rec import           Language.Haskell.Liquid.UX.Annotate (mkOutput) import qualified Language.Haskell.Liquid.Termination.Structural as ST+import qualified Language.Haskell.Liquid.GHC.Misc          as GM   type MbEnv = Maybe HscEnv -- -------------------------------------------------------------------------------- liquid :: [String] -> IO b -------------------------------------------------------------------------------- liquid args = do    cfg     <- getOpts args +  printLiquidHaskellBanner   (ec, _) <- runLiquid Nothing cfg   exitWith ec @@ -67,7 +70,7 @@ liquidConstraints :: Config -> IO (Either [CGInfo] ExitCode)  -------------------------------------------------------------------------------- liquidConstraints cfg = do -  z <- actOrDie $ second Just <$> getGhcInfos Nothing cfg (files cfg)+  z <- actOrDie $ second Just <$> getTargetInfos Nothing cfg (files cfg)   case z of     Left e -> do       exitWithResult cfg (files cfg) $ mempty { o_result = e }@@ -80,14 +83,14 @@ -------------------------------------------------------------------------------- runLiquid mE cfg  = do    reals <- realTargets mE cfg (files cfg)-  putStrLn $ showpp (text "Targets:" <+> vcat (text <$> reals))+  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 colorPhaseLn Loud ("[Checking: " ++ f ++ "]") ""+    go env (f:fs) = do whenLoud $ colorPhaseLn Loud ("[Checking: " ++ f ++ "]") ""                        (ec, env') <- runLiquidTargets env cfg [f]                         case ec of                           ExitSuccess -> go env' fs@@ -103,7 +106,7 @@ runLiquidTargets :: MbEnv -> Config -> [FilePath] -> IO (ExitCode, MbEnv) -------------------------------------------------------------------------------- runLiquidTargets mE cfg targetFiles = do-  z <- actOrDie $ second Just <$> getGhcInfos mE cfg targetFiles+  z <- actOrDie $ second Just <$> getTargetInfos mE cfg targetFiles   case z of     Left e -> do       exitWithResult cfg targetFiles $ mempty { o_result = e }@@ -115,22 +118,25 @@     ec = resultExit . o_result  ---------------------------------------------------------------------------------checkMany :: Config -> Output Doc -> [GhcInfo] -> IO (Output Doc)+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 [] =+checkMany _ d [] =   return d  ---------------------------------------------------------------------------------checkOne :: Config -> GhcInfo -> IO (Output Doc)+checkOne :: Config -> TargetInfo -> IO (Output Doc) -------------------------------------------------------------------------------- checkOne cfg g = do   z <- actOrDie $ liquidOne g   case z of-    Left  e -> exitWithResult cfg [giTarget (giSrc g)] $ mempty { o_result = e }+    Left  e -> do+      let out = mempty { o_result = e }+      exitWithResult cfg [giTarget (giSrc g)] out+      pure out     Right r -> return r  @@ -146,12 +152,24 @@ handle = return . Left . result  ---------------------------------------------------------------------------------liquidOne :: GhcInfo -> IO (Output Doc)+liquidOne :: TargetInfo -> IO (Output Doc) ---------------------------------------------------------------------------------liquidOne info+liquidOne info = do+  out' <- checkTargetInfo info+  unless (compileSpec cfg) $ DC.saveResult tgt out'+  exitWithResult cfg [tgt] out'+  pure out'+  where+    cfg  = getConfig info+    tgt  = giTarget (giSrc info)++--------------------------------------------------------------------------------+checkTargetInfo :: TargetInfo -> IO (Output Doc)+--------------------------------------------------------------------------------+checkTargetInfo info   | compileSpec cfg = do      donePhase Loud "Only compiling specifications [skipping verification]"-    exitWithResult cfg [tgt] (mempty { o_result = F.Safe })+    pure mempty { o_result = F.Safe mempty }   | otherwise = do     whenNormal $ donePhase Loud "Extracted Core using GHC"     -- whenLoud  $ do putStrLn $ showpp info@@ -163,16 +181,14 @@                    putStrLn $ showCBs (untidyCore cfg) cbs'                    -- putStrLn $ render $ pprintCBs cbs'                    -- putStrLn $ showPpr cbs'-    edcs <- newPrune      cfg cbs' tgt info-    out' <- liquidQueries cfg      tgt info edcs-    DC.saveResult       tgt  out'-    exitWithResult cfg [tgt] out'+    edcs <- newPrune cfg cbs' tgt info+    liquidQueries cfg tgt info edcs   where      cfg  = getConfig info     tgt  = giTarget (giSrc info)-    cbs' = giCbs (giSrc info) +    cbs' = giCbs (giSrc info) -newPrune :: Config -> [CoreBind] -> FilePath -> GhcInfo -> IO (Either [CoreBind] [DC.DiffCheck])+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]@@ -184,27 +200,27 @@     sp            = giSpec       info     expVars       = exportedVars (giSrc info) -exportedVars :: GhcSrc -> [Var]+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 -> GhcInfo -> Either [CoreBind] [DC.DiffCheck] -> IO (Output Doc)+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 -> GhcInfo -> Either [CoreBind] DC.DiffCheck -> IO (Output Doc)+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   = updGhcInfoTermVars info2 +  let info3   = updTargetInfoTermVars info2    let cgi     = {-# SCC "generateConstraints" #-} generateConstraints $! info3    when False (dumpCs cgi)   -- whenLoud $ mapM_ putStrLn [ "****************** CGInfo ********************"@@ -212,14 +228,13 @@   out        <- timedAction names $ solveCs cfg tgt cgi info3 names   return      $ mconcat [oldOut, out] -updGhcInfoTermVars    :: GhcInfo -> GhcInfo -updGhcInfoTermVars i  = updInfo i  (ST.terminationVars i) +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 *******************************"@@ -232,24 +247,64 @@ pprintMany :: (PPrint a) => [a] -> Doc pprintMany xs = vcat [ F.pprint x $+$ text " " | x <- xs ] -instance Show Cinfo where-  show = show . F.toFix--solveCs :: Config -> FilePath -> CGInfo -> GhcInfo -> Maybe [String] -> IO (Output Doc)+solveCs :: Config -> FilePath -> CGInfo -> TargetInfo -> Maybe [String] -> IO (Output Doc) solveCs cfg tgt cgi info names = do   finfo            <- cgInfoFInfo info cgi-  F.Result r sol _ <- solve (fixConfig tgt cfg) finfo+  let fcfg          = fixConfig tgt cfg+  F.Result r0 sol _ <- solve fcfg finfo+  let failBs        = gsFail $ gsTerm $ giSpec info+  let (r,rf)        = splitFails (S.map val failBs) r0    let resErr        = applySolution sol . cinfoError . snd <$> r   -- resModel_        <- fmap (e2u cfg sol) <$> getModels info cfg resErr   let resModel_     = e2u cfg sol <$> resErr-  let resModel      = resModel_  `addErrors` (e2u cfg sol <$> logErrors cgi)+  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  -- 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         = [v | Just v <- (ci_var <$> cis) ]++splitFails :: S.HashSet Var -> F.FixResult (a, Cinfo) -> (F.FixResult (a, Cinfo),  [Cinfo])+splitFails _ r@(F.Crash _ _) = (r,mempty)+splitFails _ r@(F.Safe _)    = (r,mempty)+splitFails fs (F.Unsafe s xs)  = (mkRes r, snd <$> rfails)+  where +    (rfails,r) = L.partition (Mb.maybe False (`S.member` fs) . ci_var . snd) xs +    mkRes [] = F.Safe s+    mkRes ys = F.Unsafe s ys ++  
src/Language/Haskell/Liquid/Measure.hs view
@@ -27,26 +27,26 @@ import           Outputable                             (Outputable) import           Prelude                                hiding (error) import           Text.PrettyPrint.HughesPJ              hiding ((<>)) -import           Type-import           Var -- import           Data.Binary                            as B -- import           GHC.Generics import qualified Data.HashMap.Strict                    as M-import qualified Data.HashSet                           as S import qualified Data.List                              as L import qualified Data.Maybe                             as Mb -- (fromMaybe, isNothing)  import           Language.Fixpoint.Misc-import           Language.Fixpoint.Types                hiding (panic, R, DataDecl, SrcSpan)+import           Language.Fixpoint.Types                hiding (panic, R, DataDecl, SrcSpan, LocSymbol)+import           Language.Haskell.Liquid.GHC.API        as Ghc hiding (Expr) import           Language.Haskell.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 +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@@ -80,96 +80,7 @@       dups       = M.filter ((1 <) . length) gms       err m ms   = ErrDupMeas (fSrcSpan m) (pprint (val m)) (fSrcSpan <$> ms) --- MOVE TO TYPES-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-           , termexprs  =           termexprs  s1 ++ termexprs  s2-           , rinstance  =           rinstance  s1 ++ rinstance  s2-           , ilaws      =               ilaws  s1 ++ ilaws      s2 -           , dvariance  =           dvariance  s1 ++ dvariance  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)-        -- , axioms     = S.union   (axioms s1) (axioms 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-           , autois     = M.empty-           , hmeas      = S.empty-           -- , axioms     = S.empty-           , reflects   = S.empty-           , hbounds    = S.empty-           , inlines    = S.empty-           , ignores    = S.empty-           , autosize   = S.empty-           , pragmas    = []-           , cmeasures  = []-           , imeasures  = []-           , classes    = []-           , claws      = [] -           , termexprs  = []-           , rinstance  = []-           , ilaws      = [] -           , dvariance  = []-           , axeqs      = []-           , bounds     = M.empty-           , defs       = M.empty-           }- dataConTypes :: MSpec (RRType Reft) DataCon -> ([(Var, RRType Reft)], [(LocSymbol, RRType Reft)]) dataConTypes  s = (ctorTys, measTys)   where@@ -180,7 +91,7 @@ makeDataConType []   = [] makeDataConType ds | Mb.isNothing (dataConWrapId_maybe dc)-  = notracepp _msg [(woId, {- notracepp _msg $ -} combineDCTypes "cdc0" t ts)]+  = notracepp _msg [(woId, notracepp _msg $ combineDCTypes "cdc0" t ts)]   where     dc   = ctor (head ds)     woId = dataConWorkId dc@@ -273,14 +184,14 @@ -- should constructors have implicits? probably not defRefType :: Type -> Def (RRType Reft) DataCon -> RRType Reft defRefType tdc (Def f dc mt xs body)-                    = generalize $ mkArrow as [] [] [] xts t'+                    = generalize $ mkArrow as' [] [] xts t'   where-    xts             = notracepp ("STITCHARGS" ++ showpp (dc, xs, ts)) -                    $ stitchArgs (fSrcSpan f) dc xs ts +    xts             = stitchArgs (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, ts, tr)@@ -299,18 +210,18 @@                       ++ zipWith g xs (ofType <$> ts)   | otherwise          = panicFieldNumMismatch sp dc nXs nTs     where-      (pts, ts)        = L.partition (\t -> notracepp ("isPredTy: " ++ showpp t) $ isPredTy t) allTs+      (pts, ts)        = L.partition (\t -> notracepp ("isPredTy: " ++ showpp t) $ Ghc.isEvVarType t) allTs       (_  , xs)        = L.partition (coArg . snd) allXs       nXs              = length xs       nTs              = length ts       g (x, Just t) _  = (x, t, mempty)       g (x, _)      t  = (x, t, mempty)       coArg Nothing    = False-      coArg (Just t)   = isPredTy . toType $ t+      coArg (Just t)   = Ghc.isEvVarType . toType $ t  panicFieldNumMismatch :: (PPrint a, PPrint a1, PPrint a3)                       => SrcSpan -> a3 -> a1 -> a -> a2-panicFieldNumMismatch sp dc nXs nTs = panicDataCon sp dc msg+panicFieldNumMismatch sp dc nXs nTs  = panicDataCon sp dc msg   where     msg = "Requires" <+> pprint nTs <+> "fields but given" <+> pprint nXs 
src/Language/Haskell/Liquid/Misc.hs view
@@ -56,6 +56,11 @@ 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@@ -72,6 +77,10 @@ snd4 :: (t, t1, t2, t3) -> t1 snd4 (_,b,_,_) = b +thrd3 :: (t1, t2, t3) -> t3+thrd3 (_,_,c) = c++ mapFourth4 :: (t -> t4) -> (t1, t2, t3, t) -> (t1, t2, t3, t4) mapFourth4 f (x, y, z, w) = (x, y, z, f w) @@ -291,8 +300,8 @@     return ()  -condNull :: Bool -> [a] -> [a]-condNull c xs = if c then xs else []+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
src/Language/Haskell/Liquid/Parse.hs view
@@ -69,10 +69,15 @@     (errs, _) ->       Left errs   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 (errs, specs) _ []       = (reverse errs, reverse specs)     go (errs, specs) pstate ((pos, specComment):xs)-      = case parseWithError pstate specP pos specComment of+      = -- 'specP' parses a single spec comment, i.e., a single LH directive+        case parseWithError pstate specP pos specComment of           Left err        -> go (err:errs, specs) pstate xs           Right (st,spec) -> go (errs,spec:specs) st xs @@ -80,9 +85,11 @@  initPStateWithList :: PState initPStateWithList -  = initPState { empList  = Just (EVar ("GHC.Types.[]" :: Symbol))-               , singList = Just (\e -> EApp (EApp (EVar ("GHC.Types.:"  :: Symbol)) e) (EVar ("GHC.Types.[]" :: Symbol)))+  = (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  -------------------------------------------------------------------------- specSpecificationP  :: SourceName -> String -> Either Error (ModName, Measure.BareSpec)@@ -258,6 +265,13 @@             PC _ t2 <- btP             -- TODO:AZ return an error if s == PcExplicit             return $ PC sb $ foldr (rFun dummySymbol) t2 (getClasses t1))+         <|> +          (do +             spaces +             b <- locParserP infixSymbolP+             spaces+             PC _ t2 <- btP +             return $ PC sb $ (RApp (mkBTyCon b) [t1,t2] [] mempty))          <|> return c)  @@ -280,7 +294,7 @@   = angles $ do       PC sb t <- parens btP       p       <- monoPredicateP-      return   $ PC sb (t `strengthen` MkUReft mempty p mempty)+      return   $ PC sb (t `strengthen` MkUReft mempty p)  holePC :: Parser ParamComp holePC = do@@ -451,7 +465,7 @@  <|> liftM2 bLst (brackets (maybeP bareTypeP)) predicatesP  <|> liftM2 bTup (parens $ sepBy (maybeBind bareTypeP) comma) predicatesP  <|> try parseHelper  -- starts with lower- <|> liftM5 bCon bTyConP stratumP predicatesP (sepBy bareTyArgP blanks) mmonoPredicateP+ <|> liftM4 bCon bTyConP predicatesP (sepBy bareTyArgP blanks) mmonoPredicateP            -- starts with "'" or upper case char  <?> "bbaseP"  where@@ -468,12 +482,13 @@ lowerIdTail :: Symbol -> Parser (Reft -> BareType) lowerIdTail l =      (    (liftM2 bAppTy (return $ bTyVar l) (sepBy1 bareTyArgP blanks))-      <|> (liftM3 bRVar  (return $ bTyVar l) stratumP monoPredicateP))+      <|> (liftM2 bRVar  (return $ bTyVar l) monoPredicateP))  bTyConP :: Parser BTyCon bTyConP   =  (reservedOp "'" >> (mkPromotedBTyCon <$> locUpperIdP))  <|> mkBTyCon <$> locUpperIdP+ <|> (reserved "*" >> (return $ mkBTyCon (dummyLoc $ symbol ("*" :: String))))  <?> "bTyConP"  mkPromotedBTyCon :: LocSymbol -> BTyCon@@ -485,24 +500,13 @@ mkClassBTyCon :: LocSymbol -> BTyCon mkClassBTyCon x = BTyCon x True False -stratumP :: Parser Strata-stratumP-  = do reservedOp "^"-       bstratumP- <|> return mempty- <?> "stratumP"--bstratumP :: Parser [Stratum]-bstratumP-  = ((:[]) . SVar) <$> symbolP- bbaseNoAppP :: Parser (Reft -> BareType) bbaseNoAppP   =  holeRefP  <|> liftM2 bLst (brackets (maybeP bareTypeP)) predicatesP  <|> liftM2 bTup (parens $ sepBy (maybeBind bareTypeP) comma) predicatesP- <|> try (liftM5 bCon bTyConP stratumP predicatesP (return []) (return mempty))- <|> liftM3 bRVar (bTyVar <$> lowerIdP) stratumP monoPredicateP+ <|> try (liftM4 bCon bTyConP predicatesP (return []) (return mempty))+ <|> liftM2 bRVar (bTyVar <$> lowerIdP) monoPredicateP  <?> "bbaseNoAppP"  maybeP :: ParsecT s u m a -> ParsecT s u m (Maybe a)@@ -530,7 +534,7 @@        reservedOp "<:"        t2  <- bareTypeP        return $ fromRTypeRep $ RTypeRep [] [] []-                                        [] [] []+                                        [] []                                          ((val . fst <$> xts) ++ [dummySymbol])                                         (replicate (length xts + 1) mempty)                                         ((snd <$> xts) ++ [t1]) t2@@ -556,18 +560,16 @@ bareAllP :: Parser BareType bareAllP = do   as <- tyVarDefsP-  vs <- angles inAngles-        <|> (return $ Right [])+  ps <- angles inAngles+        <|> (return [])   dot   t <- bareTypeP-  case vs of-    Left ss  -> return $ foldr RAllS t ss-    Right ps -> return $ foldr RAllT (foldr RAllP t ps) (makeRTVar <$> as)+  return $ foldr rAllT (foldr RAllP t ps) (makeRTVar <$> as)   where+    rAllT a t = RAllT a t mempty     inAngles =       (-       (try  (Right <$> sepBy  predVarDefP comma))-        <|> ((Left  <$> sepBy1 symbolP     comma))+       (try  (sepBy  predVarDefP comma))        )  tyVarDefsP :: Parser [BTyVar]@@ -776,15 +778,15 @@ bRProp :: [((Symbol, τ), Symbol)]        -> Expr -> Ref τ (RType c BTyVar (UReft Reft)) bRProp []    _    = panic Nothing "Parse.bRProp empty list"-bRProp syms' expr = RProp ss $ bRVar (BTV dummyName) mempty mempty r+bRProp syms' expr = RProp ss $ bRVar (BTV dummyName) mempty r   where     (ss, (v, _))  = (init syms, last syms)     syms          = [(y, s) | ((_, s), y) <- syms']     su            = mkSubst [(x, EVar y) | ((x, _), y) <- syms']     r             = su `subst` Reft (v, expr) -bRVar :: tv -> Strata -> Predicate -> r -> RType c tv (UReft r)-bRVar α s p r             = RVar α (MkUReft r p s)+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)]@@ -817,13 +819,12 @@ -- 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-     -> Strata      -> [RTProp c tv (UReft r)]      -> [RType c tv (UReft r)]      -> Predicate      -> r      -> RType c tv (UReft r)-bCon b s rs            ts p r = RApp b ts rs $ MkUReft r p s+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)@@ -832,10 +833,10 @@     ts'        = foldl' (\a b -> RAppTy a b mempty) (RVar v mempty) ts  reftUReft :: r -> UReft r-reftUReft r    = MkUReft r mempty mempty+reftUReft r    = MkUReft r mempty  predUReft :: Monoid r => Predicate -> UReft r-predUReft p    = MkUReft dummyReft p mempty+predUReft p    = MkUReft dummyReft p  dummyReft :: Monoid a => a dummyReft      = mempty@@ -849,6 +850,7 @@  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)@@ -872,6 +874,9 @@   | 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@@ -944,6 +949,12 @@   = "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) <+> pprintTidy k (val <$> lxs) +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) @@ -1024,8 +1035,24 @@                          -- , 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]@@ -1059,6 +1086,9 @@   , 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]@@ -1124,6 +1154,9 @@     <|> (reserved "lazyvar"       >> liftM LVars  lazyVarP  )      <|> (reserved "lazy"          >> liftM Lazy   lazyVarP  )+    <|> (reserved "rewrite"       >> liftM Rewrite   rewriteVarP )+    <|> (reserved "rewriteWith"   >> liftM Rewritewith   rewriteWithP )+    <|> (reserved "fail"          >> liftM Fail   failVarP  )     <|> (reserved "ple"           >> liftM Insts autoinstP  )     <|> (reserved "automatic-instances" >> liftM Insts autoinstP  )     <|> (reserved "LIQUID"        >> liftM Pragma pragmaP   )@@ -1157,6 +1190,20 @@ lazyVarP :: Parser LocSymbol lazyVarP = locParserP binderP ++rewriteVarP :: Parser LocSymbol+rewriteVarP = locParserP binderP++rewriteWithP :: Parser (LocSymbol, [LocSymbol])+rewriteWithP = do s  <- locParserP binderP +                  spaces+                  ss <- brackets $ sepBy1 (locParserP binderP) comma+                  spaces+                  return (s, ss)++failVarP :: Parser LocSymbol+failVarP = locParserP binderP+ axiomP :: Parser LocSymbol axiomP = locParserP binderP @@ -1396,7 +1443,7 @@       Just bt | isPropBareType bt                 -> P <$> predP       _         -> E <$> exprP-    where outTy (RAllT _ t)    = outTy t+    where outTy (RAllT _ t _)  = outTy t           outTy (RAllP _ t)    = outTy t           outTy (RImpF _ _ t _)= Just t           outTy (RFun _ _ t _) = Just t@@ -1438,9 +1485,10 @@   where     idP p  = many1 (satisfy (not . p))     badc c = (c == ':') || (c == ',') || bad c-    bad c  = isSpace c || c `elem` ("(,)" :: String)+    bad c  = isSpace c || c `elem` ("(,)[]" :: String)     pwr s  = symbol $ "(" `mappend` s `mappend` ")" + grabs :: ParsecT s u m a -> ParsecT s u m [a] grabs p = try (liftM2 (:) p (grabs p))        <|> return []@@ -1531,7 +1579,7 @@   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 ty_vars tr of +tRepVars as tr = case fst <$> ty_vars tr of    [] -> as    vs -> symbol . ty_var_value <$> vs  @@ -1563,7 +1611,7 @@  emptyDecl :: LocSymbol -> SourcePos -> Maybe SizeFun -> DataDecl emptyDecl x pos fsize@(Just _)-  = DataDecl (DnName x) [] [] [] [] pos fsize Nothing DataUser+  = DataDecl (DnName x) [] [] [] pos fsize Nothing DataUser emptyDecl x pos _   = uError (ErrBadData (sourcePosSrcSpan pos) (pprint (val x)) msg)   where@@ -1577,7 +1625,7 @@   (pTy, dcs) <- dataCtorsP as   let dn      = dataDeclName pos x vanilla dcs   whiteSpace-  return      $ DataDecl dn as ps [] dcs pos fsize pTy DataUser+  return      $ DataDecl dn as ps dcs pos fsize pTy DataUser  dataDeclName :: SourcePos -> LocSymbol -> Bool -> [DataCtor] -> DataName dataDeclName _ x True  _     = DnName x               -- vanilla data    declaration@@ -1594,7 +1642,8 @@   return (pTy, Misc.sortOn (val . dcName) dcs)  noWhere :: Parser Symbol-noWhere = try $ do+noWhere = +  try $ do   s <- tyVarIdP   if s == "where"     then parserZero
+ src/Language/Haskell/Liquid/Synthesize.hs view
@@ -0,0 +1,186 @@+{-# 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           CoreSyn (CoreExpr)+import qualified CoreSyn as GHC+import           Var +import           TyCon+import           DataCon+import           Text.PrettyPrint.HughesPJ (text, ($+$))+import           Control.Monad.State.Lazy+import qualified Data.HashMap.Strict as M +import           Data.Maybe+import           CoreUtils (exprType)+import           TyCoRep++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 . 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 . 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 senv tx xtop ttop foralls st2+ = evalSM (go tx) ctx senv 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 t)+                  if null ts  then modify (\s -> s { sUGoalTy = Nothing } )+                              else modify (\s -> s { sUGoalTy = Just ts } )+                  modify (\s -> s {sForalls = (foralls, [])})+                  emem0 <- insEMem0 senv+                  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 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_ (\y -> addDecrTerm y []) 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 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 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 _ ts) c = locally $ do+  ts <- liftCG $ mapM trueTy τ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 ts+makeAlt _ _ _ = error "makeAlt.bad argument "
+ src/Language/Haskell/Liquid/Synthesize/Check.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE BangPatterns #-}+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           Language.Haskell.Liquid.Misc   ( mapThd3 )+import           CoreSyn+import           Var+import           Control.Monad.State.Lazy+import           System.Console.CmdArgs.Verbosity+import           CoreUtils+import           Language.Haskell.Liquid.GHC.TypeRep+import           Language.Haskell.Liquid.Types+import           MkCore+import           DynFlags++hasType :: SpecType -> CoreExpr -> SM Bool+hasType t !e' = notrace (" [ Check ] " ++ show e') $ do +  x  <- freshVar t +  st <- get +  let tpOfE = exprType e'+      ht    = toType 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 $ 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 t))) errorInt+      errorInt  = mkIntExprInt unsafeGlobalDynFlags 42+  b <- hasType t errorExpr+  if b +    then return $ Just errorExpr+    else return Nothing++quietly :: IO a -> IO a+quietly act = do+  vb <- getVerbosity+  setVerbosity Quiet+  r  <- act+  setVerbosity vb+  return r++
+ src/Language/Haskell/Liquid/Synthesize/Env.hs view
@@ -0,0 +1,47 @@+module Language.Haskell.Liquid.Synthesize.Env where ++import           Language.Fixpoint.Types+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           DataCon+import           TyCon+import           Var+import           Data.List ++initSSEnv :: SpecType -> CGInfo -> SSEnv -> (SSEnv, [Var])+initSSEnv rt info senv = (M.union senv (M.fromList foralls), vs)+  where foralls = filter iNeedIt (mkElem <$> prims)+        vs = map (snd . snd) foralls+        dataCons = typeToCons rt +        mkElem (v, lt) = (symbol v, (val lt, v))+        prims = gsCtors $ gsData $ giSpec $ ghcI info+        iNeedIt (_, (_, v)) = v `elem` (dataConWorkId <$> dataCons)++-- | For algebraic datatypes: Find (in the refinement type) +--   all the datatypes that are used and +--   get their constructors.+tpToCons :: SpecType -> [DataCon] +tpToCons (RAllT _a t _x)  +  = tpToCons t +tpToCons (RApp c args _ _r) +  = tyConDataCons (rtc_tc c) ++ concatMap tpToCons args+tpToCons (RFun _sym rt0 rt1 _reft)+  = tpToCons rt0 ++ tpToCons rt1+tpToCons RVar{} +  = []+tpToCons (RAllP _ t)+  = tpToCons t+tpToCons (RRTy _ _ _ t)+  = tpToCons t+tpToCons _ +  = []++typeToCons :: SpecType -> [DataCon]+typeToCons rt = S.toList $ S.fromList (tpToCons rt)++rmMeasures :: [Symbol] -> [(Symbol, SpecType)] -> [(Symbol, SpecType)]+rmMeasures meas = filter (\(s,_) -> case find (== s) meas of  Nothing -> True+                                                              Just _  -> False)
+ src/Language/Haskell/Liquid/Synthesize/GHC.hs view
@@ -0,0 +1,433 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE CPP #-}+module Language.Haskell.Liquid.Synthesize.GHC where++import qualified CoreSyn                       as GHC+import qualified Language.Fixpoint.Types       as F+import           Language.Haskell.Liquid.Types+import           Var+import           TyCoRep+import           CoreSyn+import           IdInfo+import           OccName+import           Unique+import           Name+import           TysPrim+import           Data.Default+import           Data.Maybe                     ( fromMaybe )+import           Language.Haskell.Liquid.GHC.TypeRep+import           Language.Fixpoint.Types+import qualified Data.HashMap.Strict           as M+import           TyCon+import           TysWiredIn++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.+#if __GLASGOW_HASKELL__ >= 810+goalType τ (FunTy _ _ t'') +  | t'' == τ  = True+  | otherwise = goalType τ t''+#else+goalType τ (FunTy _ t'') +  | t'' == τ  = True+  | otherwise = goalType τ t''+#endif+goalType τ                 t +  | τ == t    = True+  | otherwise = False++-- Subgoals are function's arguments.+createSubgoals :: Type -> [Type] +createSubgoals (ForAllTy _ htype) = createSubgoals htype+#if __GLASGOW_HASKELL__ >= 810+createSubgoals (FunTy _ t1 t2)      = t1 : createSubgoals t2+#else+createSubgoals (FunTy t1 t2)      = t1 : createSubgoals t2+#endif+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+  = if isTyVar b+      then pprintFormals i v e cnt vs+      else  if cnt > 0 +              then  pprintFormals i v e (cnt - 1) (b:vs)+              else  " " ++ 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 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 (\cb -> isInCB cb tlVar) cp of+    [cb] -> varsCB cb f+    _    -> error " Every top-level corebind must be unique! "++isInCB :: GHC.CoreBind -> Var -> Bool+isInCB (GHC.NonRec b _) tlVar = b == tlVar +isInCB (GHC.Rec recs) tlVar   = foldr ((\v b -> v == tlVar && b) . fst) True recs++varsCB :: GHC.CoreBind -> (GHC.CoreExpr -> [Var]) -> [Var]+varsCB (GHC.NonRec _ e) f = f e+varsCB (GHC.Rec _) _ = notrace " [ symbolToVarCB ] Rec " []++varsE :: GHC.CoreExpr -> [Var]+varsE (GHC.Lam a e) = a : varsE e+varsE (GHC.Let (GHC.NonRec b _) e) = b : varsE e+varsE (GHC.Case _ b _ alts) = foldr (\(_, vars, e) res -> vars ++ varsE e ++ res) [b] alts+varsE (GHC.Tick _ e) = varsE e+varsE _ = []++caseVarsE :: GHC.CoreExpr -> [Var] +caseVarsE (GHC.Lam _ e) = caseVarsE e +caseVarsE (GHC.Let (GHC.NonRec _ _) e) = caseVarsE e+caseVarsE (GHC.Case _ b _ alts) = foldr (\(_, _, e) res -> caseVarsE e ++ res) [b] alts +caseVarsE (GHC.Tick _ e) = caseVarsE e +caseVarsE _ = [] ++instance Default Var where+  def = alphaTyVar++symbolToVar :: GHC.CoreProgram -> Var -> M.HashMap Symbol SpecType -> SSEnv+symbolToVar cp tlBndr renv = +  let vars = [(F.symbol x, x) | x <- varsP cp tlBndr varsE]+      casevars = [F.symbol x | x <- varsP cp tlBndr caseVarsE]+      tlVars = [(F.symbol x, x) | x <- getTopLvlBndrs cp]+      lookupErrorMsg x = " [ symbolToVar ] impossible lookup for x = " ++ show x+      symbolVar x = fromMaybe (fromMaybe (error (lookupErrorMsg x)) $ lookup x tlVars) $ lookup x vars+      renv' = foldr M.delete renv casevars+  in  M.fromList [ (s, (t, symbolVar s)) | (s, t) <- M.toList renv']++argsP :: GHC.CoreProgram -> Var -> [Var] +argsP []         tlVar = error $ " [ argsP ] " ++ show tlVar+argsP (cb : cbs) tlVar +  | isInCB cb tlVar = argsCB cb+  | otherwise = argsP cbs tlVar++argsCB :: GHC.CoreBind -> [Var]+argsCB (GHC.NonRec _ e) = argsE e+argsCB _                = error " [ argsCB ] "++argsE :: GHC.CoreExpr -> [Var]+argsE (GHC.Lam a e) = a : argsE e +argsE (GHC.Let (GHC.NonRec _ _) e) = argsE e+argsE _ = [] ++notrace :: String -> a -> a +notrace _ a = a
+ src/Language/Haskell/Liquid/Synthesize/Generate.hs view
@@ -0,0 +1,256 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE BangPatterns #-}++module Language.Haskell.Liquid.Synthesize.Generate where++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           CoreSyn                        ( CoreExpr )+import qualified CoreSyn                       as GHC+import           Data.Maybe+import           Control.Monad.State.Lazy+import           Language.Haskell.Liquid.Constraint.Fresh+                                                ( trueTy )+import           Data.List+import           CoreUtils (exprType)+import           Var+import           Data.Tuple.Extra+import           Debug.Trace+import           Language.Fixpoint.Types.PrettyPrint (tracepp)+import           TyCoRep++-- 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 specTy) goalTys of +        Nothing -> modify (\s -> s { sGoalTys = (toType specTy) : sGoalTys s })+        Just _  -> return ()+      fixEMem specTy +      fnTys <- functionCands (toType 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 t) goalTys of +        Nothing -> do modify (\s -> s { sGoalTys = toType t : sGoalTys s }) +                      fixEMem t +                      fnTys <- functionCands (toType 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 (filter (not . isFunction) subGs)+            mapM_ genArgs specSubGs+            em <- sExprMem <$> get+            let argCands  = map (withSubgoal em) subGs+                toGen    = foldr (\x b -> (not . null) x && b) True argCands+            newExprs <- do  curExprId <- sExprId <$> get +                            if toGen +                              then prune curExprId c (tracepp (" [ fill " ++ show curExprId ++ " ] For c = " ++ show (snd3 c) ++ " argCands ") argCands)+                              else return []+            curExprId <- sExprId <$> get+            let nextEm = map (resTy, , curExprId + 1) newExprs+            modify (\s -> s {sExprMem = nextEm ++ sExprMem s }) +            let accExprs' = newExprs ++ accExprs+            fill i depth cs accExprs' ++-------------------------------------------------------------------------------------------+-- |                       Pruning terms for function application                      | --+-------------------------------------------------------------------------------------------+type Depth = Int++feasible :: Depth -> (CoreExpr, Int) -> Bool+feasible d c = snd c >= d++feasibles :: Depth -> Int -> [(CoreExpr, Int)] -> [Int]+feasibles _ _ []+  = []+feasibles d i (c:cs) +  = if feasible d c +      then i : feasibles d (i+1) cs+      else feasibles d (i+1) cs++isFeasible :: Depth -> [[(CoreExpr, Int)]] -> [[Int]]+isFeasible d =  map (feasibles d 0)++findFeasibles :: Depth -> [[(CoreExpr, Int)]] -> ([[Int]], [Int])+findFeasibles d cs = (fs, ixs)+  where fs  = isFeasible d cs+        ixs = [i | (i, f) <- zip [0..] fs, not (null f)]++toExpr :: [Int] ->                    --  Produced from @isFeasible@.+                                      --   Assumed in increasing order.+          [(GHC.CoreExpr, Int)] ->    --  The candidate expressions.+          ([(GHC.CoreExpr, Int)],     --  Expressions from 2nd argument.+           [(GHC.CoreExpr, Int)])     --  The rest of the expressions+toExpr ixs args = ( [ args !! i | (ix, i) <- is, ix == i ], +                    [ args !! i | (ix, i) <- is, ix /= i ])+    where is = zip [0..] ixs++fixCands :: Int -> [Int] -> [[(CoreExpr, Int)]] -> ([[(CoreExpr, Int)]], [[(CoreExpr, Int)]])+fixCands i ixs args +  = let cs = args !! i+        (cur, next)    = toExpr ixs cs+        (args0, args1) = (replace (i+1) cur args, replace (i+1) next args)+    in  (args0, args1)++-- | The first argument should be an 1-based index.+replace :: Int -> a -> [a] -> [a]+replace i x l+  = left ++ [x] ++ right+    where left  = take (i-1) l+          right = drop i l++repeatFix :: [Int] -> [[Int]] -> (Type, CoreExpr, Int) -> [[(CoreExpr, Int)]] -> [CoreExpr] -> SM [CoreExpr]+repeatFix [ ] _ _ _ es +  = return es+repeatFix (i:is) ixs toFill args es+  = do  let (args0, args1) = fixCands i (ixs !! i) args+        es0 <- fillOne toFill args0+        es1 <- structuralCheck es0+        es2 <- (++ es) <$> filterM isWellTyped es1+        repeatFix is ixs toFill args1 es2++prune :: Depth -> (Type, CoreExpr, Int) -> [[(CoreExpr, Int)]] -> SM [CoreExpr]+prune d toFill args +  = do  let (ixs, is) = findFeasibles d args +        repeatFix is ixs toFill args []+++----------------------------------------------------------------------------+--  | Term generation: Perform type and term application for functions. | --+----------------------------------------------------------------------------++fillOne :: (Type, GHC.CoreExpr, Int) -> [[(CoreExpr, Int)]] -> SM [CoreExpr]+fillOne _ [] +  = return []+fillOne (t, e, _) cs +  = applyTerms [e] cs ((snd . fromJust . subgoals) t)++applyTerm :: [GHC.CoreExpr] -> [(CoreExpr, Int)] -> Type -> SM [CoreExpr]+applyTerm es args t = do+  es1 <- mapM (\x -> applyArg es x t) args+  return (concat es1)++applyArg :: [GHC.CoreExpr] -> (CoreExpr, Int) -> Type -> SM [CoreExpr]+applyArg es (arg, _) t +  = do  !idx <- incrSM+        return  [ case arg of GHC.Var _ -> GHC.App e arg+                              _         ->  let letv = mkVar (Just ("x" ++ show idx)) idx t+                                            in  GHC.Let (GHC.NonRec letv arg) (GHC.App e (GHC.Var letv))+                | e <- es +                ]++applyTerms :: [GHC.CoreExpr] -> [[(CoreExpr, Int)]] -> [Type] -> SM [CoreExpr]+applyTerms es []     []      +  = return es+applyTerms es0 (c:cs) (t:ts) +  = do  es1 <- applyTerm es0 c t+        applyTerms es1 cs ts+applyTerms _es _cs _ts +  = error "[ applyTerms ] Wildcard. " ++--------------------------------------------------------------------------------------+prodScrutinees :: [(Type, CoreExpr, Int)] -> [[[(CoreExpr, Int)]]] -> SM [CoreExpr]+prodScrutinees []     []     = return []+prodScrutinees (c:cs) (a:as) = do +  es <- fillOne c a+  (++ es) <$> prodScrutinees cs as+prodScrutinees _ _ = error " prodScrutinees "++synthesizeScrutinee :: [Var] -> SM [CoreExpr]+synthesizeScrutinee vars = do+  s <- get+  let foralls = (fst . sForalls) s+      insVs = sUniVars s+      fix   = sFix s+      -- Assign higher priority to function candidates that return tuples+      fnCs0 = filter returnsTuple foralls +      fnCs  = if returnsTuple fix then fix : fnCs0 else fnCs0++      fnEs  = map GHC.Var fnCs+      fnCs' = map (\e -> instantiate e (Just insVs)) fnEs+      sGs   = map ((snd . fromJust) . subgoals . exprType) fnCs'+      argCands = map (map (withSubgoal vs)) sGs+      fnCs'' = map (\e -> (exprType e, e, 0)) fnCs'+      +      vs' = filter ((not . isFunction) . varType) vars+      vs  = map (\v -> (varType v, GHC.Var v, 0)) vs'+  prodScrutinees fnCs'' argCands
+ src/Language/Haskell/Liquid/Synthesize/Misc.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE BangPatterns #-}++module Language.Haskell.Liquid.Synthesize.Misc where++import qualified Language.Fixpoint.Types        as F +import           Control.Monad.State.Lazy+import           CoreSyn+import           TyCoRep +import           Text.PrettyPrint.HughesPJ (text, Doc, vcat, ($+$))+import           Language.Haskell.Liquid.Synthesize.GHC+import           Language.Haskell.Liquid.GHC.TypeRep+import           Language.Fixpoint.Types+++isFunction :: Type -> Bool+isFunction FunTy{}    = True +isFunction ForAllTy{} = True+isFunction _          = False++(<$$>) :: (Functor m, Functor n) => (a -> b) -> m (n a) -> m (n b)+(<$$>) = fmap . fmap++filterElseM :: Monad m => (a -> m Bool) -> [a] -> m [a] -> m [a]+filterElseM f as ms = do+    rs <- filterM f as+    if null rs then+        ms+    else+        return rs++-- Replaces    | old w   | new  | symbol name in expr.+substInFExpr :: F.Symbol -> F.Symbol -> F.Expr -> F.Expr+substInFExpr pn nn e = F.subst1 e (pn, F.EVar nn)+++findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)+findM _ []     = return Nothing+findM p (x:xs) = do b <- p x ; if b then return (Just x) else findM p xs +++composeM :: Monad m => (a -> m b) -> (b -> c) -> a -> m c+composeM f g x = do +    mx <- f x+    return (g mx)++----------------------------------------------------------------------------+----------------------------Printing----------------------------------------+----------------------------------------------------------------------------+solDelim :: String+solDelim = "*********************************************"++-- pprintMany :: (F.PPrint a) => [a] -> Doc+-- pprintMany xs = vcat [ F.pprint x $+$ text solDelim | x <- xs ]++pprintMany :: [String] -> Doc+pprintMany xs = vcat [ text x $+$ text solDelim | x <- xs ]++showGoals :: [[String]] -> String+showGoals []             = ""+showGoals (goal : goals) = +    show goal        ++ +    "\n"             ++ +    replicate 12 ' ' ++ +    showGoals goals++showEmem :: (Show a1, Show a2) => [(Type, a1, a2)] -> String+showEmem  emem = show $ showEmem' emem++showEmem' :: (Show a1, Show a2) => [(Type, a1, a2)] -> [(String, String, String)]+showEmem' emem = map (\(t, e, i) -> (show e, showTy t, show i)) emem++exprmemToExpr :: [(a2, CoreExpr, Int)] -> String+exprmemToExpr em = show $ map (\(_, e, i) -> show (fromAnf e, i) ++ " * ") em ++showCand :: (a, (Type, b)) -> (String, b)+showCand (_, (t, v)) = (showTy t, v)++showCands :: [(a, (Type, b))] -> [(String, b)]+showCands = map showCand++notrace :: String -> a -> a +notrace _ a = a ++instance PPrint AltCon++showCoreAlt :: CoreAlt -> String+showCoreAlt (DataAlt altCon, vars, expr) = +  " For " ++ show altCon ++ " vars " ++ show vars ++ " expr " ++ show expr+showCoreAlt _ = " No! "++showCoreAlts :: [CoreAlt] -> String+showCoreAlts alts = concatMap showCoreAlt alts
+ src/Language/Haskell/Liquid/Synthesize/Monad.hs view
@@ -0,0 +1,428 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}++module Language.Haskell.Liquid.Synthesize.Monad where+++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           CoreSyn                        ( CoreExpr )+import qualified CoreSyn                       as GHC+import           Var+import           Control.Monad.State.Lazy+import qualified Data.HashMap.Strict           as M+import           Data.Maybe+import           Data.List+import           CoreUtils                      ( exprType )+import           Data.Tuple.Extra+import           TyCon+import           TyCoRep++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 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 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++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 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 -> case applyTy tys e of +                  Nothing -> e+                  Just e0 -> e0++-- | 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 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 -> case apply tyVars e of +                      Nothing -> e+                      Just e' -> e'++-----------------------------------------------------------------------------------------------------++withTypeEs :: SpecType -> SM [CoreExpr] +withTypeEs t = do +    em <- sExprMem <$> get +    return (map snd3 (filter (\x -> fst3 x == toType 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+  return $ B.lookupGhcVar env name "Var" (dummyLoc $ symbol "Language.Haskell.Liquid.Synthesize.Error.err")++toGhcSrc :: TargetSrc -> GhcSrc +toGhcSrc a = Src+      { _giIncDir    = giIncDir a+      , _giTarget    = giTarget a+      , _giTargetMod = giTargetMod a+      , _giCbs       = giCbs a+      , _gsTcs       = gsTcs a+      , _gsCls       = gsCls a+      , _giDerVars   = giDerVars a+      , _giImpVars   = giImpVars a+      , _giDefVars   = giDefVars a+      , _giUseVars   = giUseVars a+      , _gsExports   = gsExports a+      , _gsFiTcs     = gsFiTcs a+      , _gsFiDcs     = gsFiDcs a+      , _gsPrimTcs   = gsPrimTcs a+      , _gsQualImps  = gsQualImps a+      , _gsAllImps   = gsAllImps a+      , _gsTyThings  = gsTyThings a+      }
+ src/Language/Haskell/Liquid/Synthesize/Termination.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# 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           Var++decrType :: Var -> SpecType -> [Var] -> [(F.Symbol, SpecType)] -> SpecType+decrType _x ti xs _xts =+  go xs ti +  where+    go (v:_) (RFun x tx t r) +      | isDecreasing mempty mempty tx  = let Left (x', tx') = R.makeDecrType mempty [(v,(x,tx))] +                                         in  RFun x' tx' t r +    go (_:vs) (RFun x tx t r) = RFun x tx (go vs t) r+    go vs (RAllT a t x) = RAllT a (go vs t) x+    go _     t = t 
src/Language/Haskell/Liquid/Termination/Structural.hs view
@@ -4,7 +4,7 @@  module Language.Haskell.Liquid.Termination.Structural (terminationVars) where -import Language.Haskell.Liquid.Types hiding (terminationCheck, isDecreasing)+import Language.Haskell.Liquid.Types hiding (isDecreasing) import Language.Haskell.Liquid.GHC.Misc (showPpr)  import CoreSyn@@ -24,10 +24,10 @@ import Control.Monad (liftM, ap) import Data.Foldable (fold) -terminationVars :: GhcInfo -> [Var]+terminationVars :: TargetInfo -> [Var] terminationVars info = failingBinds info >>= allBoundVars -failingBinds :: GhcInfo -> [CoreBind]+failingBinds :: TargetInfo -> [CoreBind] failingBinds info = filter (hasErrors . checkBind) structBinds   where      structCheckWholeProgram = structuralTerm info
src/Language/Haskell/Liquid/Transforms/ANF.hs view
@@ -19,19 +19,13 @@ import           DsMonad                          (initDsWithModGuts) import           GHC                              hiding (exprType) import           HscTypes-import           OccName                          (OccName, mkVarOccFS)-import           Id                               (mkUserLocal) import           Literal import           MkCore                           (mkCoreLets) import           Outputable                       (trace)-import           Var                              (varType, setVarType) import           Language.Haskell.Liquid.GHC.TypeRep-import           Type                             (mkForAllTys, substTy, mkForAllTys, mkTvSubstPrs, isTyVar)-import           TyCon                            (tyConDataCons_maybe)--- import           DataCon                          (dataConInstArgTys)+import           Language.Haskell.Liquid.GHC.API  hiding (exprType, mkTyArg) import           VarEnv                           (VarEnv, emptyVarEnv, extendVarEnv, lookupWithDefaultVarEnv) import           UniqSupply                       (MonadUnique, getUniqueM)-import           Unique                           (getKey) import           Control.Monad.State.Lazy import           System.Console.CmdArgs.Verbosity (whenLoud) import qualified Language.Fixpoint.Misc     as F@@ -188,7 +182,7 @@  shouldNormalize :: Literal -> Bool shouldNormalize (LitNumber {})  = True -shouldNormalize (MachStr {})    = True +shouldNormalize (LitString {})    = True  shouldNormalize _               = False  add :: [CoreBind] -> DsMW ()@@ -210,6 +204,10 @@   , 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'@@ -242,6 +240,11 @@   = 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@@ -331,10 +334,10 @@ expandDefaultCase' _ _ z    = return z  -cloneCase :: AnfEnv -> e -> (DataCon, [Type]) -> DsM (AltCon, [Id], e)-cloneCase γ e (d, ts) = do +cloneCase :: AnfEnv -> e -> (DataCon, [TyVar], [Type]) -> DsM (AltCon, [Id], e)+cloneCase γ e (d, as, ts) = do    xs  <- mapM (freshNormalVar γ) ts -  return (DataAlt d, xs, e)+  return (DataAlt d, as ++ xs, e)  sortCases :: [(AltCon, b, c)] -> [(AltCon, b, c)] sortCases = sortBy (cmpAltCon `on` F.fst3) 
src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs view
@@ -19,10 +19,9 @@   ) where  import           Data.ByteString                       (ByteString)-import           GHC                                   hiding (Located, exprType) import           Prelude                               hiding (error)-import           Type-import           Language.Haskell.Liquid.GHC.TypeRep+import           Language.Haskell.Liquid.GHC.TypeRep   () -- needed for Eq 'Type'+import           Language.Haskell.Liquid.GHC.API       hiding (Expr, Located) -- import qualified Id  import qualified Var import qualified TyCon @@ -30,7 +29,6 @@ import qualified Pair -- import qualified Text.Printf as Printf import qualified CoreSyn                               as C-import           Literal import           IdInfo import qualified Data.List                             as L import           Data.Maybe                            (listToMaybe) @@ -39,8 +37,6 @@ import qualified Text.Printf as Printf  import           Data.Text.Encoding import           Data.Text.Encoding.Error-import           TysWiredIn-import           Name                                  (getSrcSpan) import           Control.Monad.State import           Control.Monad.Except import           Control.Monad.Identity@@ -73,7 +69,7 @@ inlineSpecType :: Var -> SpecType inlineSpecType v = fromRTypeRep $ rep {ty_res = res `strengthen` r , ty_binds = xs}   where-    r              = MkUReft (mkR (mkEApp f (mkA <$> vxs))) mempty mempty+    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]@@ -96,12 +92,12 @@   where      mkR | boolRes   = propReft          | otherwise = exprReft  -    mkT xs          = MkUReft (mkR $ mkEApp f (EVar <$> reverse xs)) mempty mempty+    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)      = RAllT a $ go f args i 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 t1 t2 r)      | isClassType t1           = RFun x t1 (go f args i t2) r@@ -184,10 +180,11 @@      -- 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) +      = 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))) +      . (`subst1` (F.symbol dx, F.mkEApp (GM.namedLocSymbol d) (F.eVar <$> xs')))       <$> coreToLg e+      where xs' = filter (not . GM.isEvVar) xs     mkAlt _ _ _ _ alt        = throw $ "Bad alternative" ++ GM.showPpr alt @@ -195,7 +192,7 @@       eDef   <- ctor <$> coreToLg e       -- let ys  = toArgs id args       let dxt = Just (varRType dx)-      return  [ Def x {- ys -} d dxt (defArgs x ts) eDef | (d, ts) <- dtss ]+      return  [ Def x {- ys -} d dxt (defArgs x ts) eDef | (d, _, ts) <- dtss ]          mkDef _ _ _ _ _ _ =        return [] @@ -345,7 +342,7 @@ altToLg de (a@(C.DataAlt d), xs, e) = do    p  <- coreToLg e   dm <- gets lsDCMap-  let su = mkSubst $ concat [ dataConProj dm de d x i | (x, i) <- zip xs [1..]]+  let su = mkSubst $ concat [ dataConProj dm de d x i | (x, i) <- zip (filter (not . GM.isEvVar) xs) [1..]]   return (a, subst su p)  altToLg _ (a, _, e)@@ -384,13 +381,23 @@       = PAnd <$> mapM coreToLg [e1, e2]       | f == symbol ("==>" :: String)       = PImp <$> coreToLg e1 <*> coreToLg e2-    go (Just f, es)+    go (Just f, [es])       | f == symbol ("or" :: String)-      = POr  <$> mapM coreToLg es+      = POr  . deList <$> coreToLg es       | f == symbol ("and" :: String)-      = PAnd <$> mapM coreToLg es+      = PAnd . deList <$> coreToLg es     go (_, _)       = toLogicApp 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 :: C.CoreExpr -> LogicM Expr toLogicApp e = do@@ -435,7 +442,7 @@  isCst :: Type -> Bool isCst (ForAllTy _ t) = isCst t-isCst (FunTy _ _)    = False+isCst (FunTy _ _ _)    = False isCst _              = True  @@ -453,11 +460,14 @@                   , (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 :: C.Expr t -> (C.Expr t, [C.Arg t]) splitArgs e = (f, reverse es)@@ -493,10 +503,10 @@ -- mkLit (MachWord   n)    = mkI n -- mkLit (MachWord64 n)    = mkI n -- mkLit (LitInteger n _)  = mkI n-mkLit (MachFloat  n)    = mkR n-mkLit (MachDouble n)    = mkR n-mkLit (MachStr    s)    = mkS s-mkLit (MachChar   c)    = mkC c +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
src/Language/Haskell/Liquid/Transforms/Rec.hs view
@@ -23,32 +23,24 @@ import           Data.Hashable import           Id import           IdInfo+import           Language.Haskell.Liquid.GHC.API      hiding (exprType) import           Language.Haskell.Liquid.GHC.Misc import           Language.Haskell.Liquid.GHC.Play import           Language.Haskell.Liquid.Misc         (mapSndM) import           Language.Fixpoint.Misc               (mapSnd) -- , traceShow) import           Language.Haskell.Liquid.Types.Errors import           MkCore                               (mkCoreLams)-import           Name                                 (isSystemName)--- import           Outputable                           (SDoc) import           Prelude                              hiding (error)-import           SrcLoc-import           Type                                 (mkForAllTys, splitForAllTys)-import           TyCoRep-import           Unique                               hiding (deriveUnique)-import           Var --- import qualified Data.List                            (foldl', isInfixOf)- import qualified Data.List                            as L   transformRecExpr :: CoreProgram -> CoreProgram transformRecExpr cbs = pg-  -- TODO-REBARE wierd GHC crash on Data/Text/Array.hs | isEmptyBag $ filterBag isTypeError e-  -- TODO-REBARE wierd GHC crash on Data/Text/Array.hs = pg-  -- TODO-REBARE wierd GHC crash on Data/Text/Array.hs | otherwise-  -- TODO-REBARE wierd GHC crash on Data/Text/Array.hs = panic Nothing ("Type-check" ++ showSDoc (pprMessageBag e))+  -- 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@@ -223,11 +215,11 @@ mkFreshIds tvs ids x   = do ids'  <- mapM fresh ids        let ids'' = map setIdTRecBound ids'-       let t  = mkForAllTys ((`TvBndr` Required) <$> tvs) $ mkType (reverse ids'') $ varType x+       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 (varType x) t) ty ids+    mkType ids ty = foldl (\t x -> FunTy VisArg (varType x) t) ty ids -- FIXME(adinapoli): Is 'VisArg' OK here?  -- NOTE [Don't choose transform-rec binders as decreasing params] -- --------------------------------------------------------------
src/Language/Haskell/Liquid/Transforms/RefSplit.hs view
@@ -39,15 +39,13 @@         (tx1, tx2) = splitRType f tx         (t1,  t2)  = splitRType f t         (r1,  r2)  = splitRef   f r-splitRType f (RAllT v t) = (RAllT v t1, RAllT v t2)+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 (RAllS s t) = (RAllS s t1, RAllS s 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)@@ -88,7 +86,7 @@         (t1, t2) = splitRType x t  splitRef :: Symbol -> UReft Reft -> (UReft Reft, UReft Reft)-splitRef f (MkUReft r p s) = (MkUReft r1 p1 s, MkUReft r2 p2 s)+splitRef f (MkUReft r p) = (MkUReft r1 p1, MkUReft r2 p2)         where                 (r1, r2) = splitReft f r                 (p1, p2) = splitPred f p
src/Language/Haskell/Liquid/Transforms/Rewrite.hs view
@@ -25,15 +25,13 @@   ) where  import           CoreSyn-import           Type-import           Language.Haskell.Liquid.GHC.TypeRep-import           TyCon+import           Language.Haskell.Liquid.GHC.API+import           Language.Haskell.Liquid.GHC.TypeRep () import qualified CoreUtils import qualified Var import qualified MkCore import           Data.Maybe     (fromMaybe)-import           Control.Monad  (msum)-import Control.Monad.State hiding (lift)+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)@@ -41,7 +39,6 @@ import           Language.Haskell.Liquid.GHC.Resugar import           Language.Haskell.Liquid.GHC.Misc (unTickExpr, isTupleId, showPpr, mkAlive) -- , showPpr, tracePpr) import           Language.Haskell.Liquid.UX.Config  (Config, noSimplifyCore)--- import           Debug.Trace import qualified Data.List as L import qualified Data.HashMap.Strict as M 
src/Language/Haskell/Liquid/Types.hs view
@@ -8,11 +8,8 @@ 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.Strata         as Types import Language.Haskell.Liquid.Types.Variance       as Types import Language.Haskell.Liquid.Types.Bounds         as Types--- import Language.Haskell.Liquid.Types.Errors         as Types--- import Language.Haskell.Liquid.Types.Annotations    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
− src/Language/Haskell/Liquid/Types/Annotations.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--module Language.Haskell.Liquid.Types.Annotations (-  ) where--import Data.Data-import Data.Typeable--import Language.Haskell.TH.Syntax-
src/Language/Haskell/Liquid/Types/Bounds.hs view
@@ -103,9 +103,9 @@     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) 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) mempty)+                                                (Pr $ M.lookupDefault [] (val x) ps))     tq t x  = ofRSort t `strengthen` makeRef penv x q      (ps, rs) = partitionPs penv qs@@ -147,13 +147,13 @@ -- 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 mempty)+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 mempty)+  | isPApp penv rr       = ofUReft (MkUReft (F.Reft(val v, mempty)) r)   where     r                    = Pr [toUsedPVar penv rr] 
src/Language/Haskell/Liquid/Types/Dictionaries.hs view
@@ -59,7 +59,7 @@ makeDicTypeName sp t               = panic (Just sp) ("makeDicTypeName: called with invalid type " ++ show t)  dropUniv :: SpecType -> SpecType -dropUniv t = t' where (_,_,_,t') = bkUniv t +dropUniv t = t' where (_,_,t') = bkUniv t   -------------------------------------------------------------------------------- -- | Dictionary Environment ----------------------------------------------------
src/Language/Haskell/Liquid/Types/Equality.hs view
@@ -26,9 +26,10 @@      (res, vs) = runWriter (go i1 i2)     go :: SpecType -> SpecType -> Writer [(RTyVar, RTyVar)] Bool  -    go (RAllT x1 t1) (RAllT x2 t2)+    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) @@ -44,9 +45,6 @@     go (RAllP x1 t1) (RAllP x2 t2)       | x1 == x2        = go t1 t2 -    go (RAllS x1 t1) (RAllS 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) @@ -73,7 +71,7 @@     (RProp _ t1) =*= (RProp _ t2) = t1 =*= t2   instance REq (UReft F.Reft) where-  (MkUReft r1 p1 _) =*= (MkUReft r2 p2 _)+  (MkUReft r1 p1) =*= (MkUReft r2 p2)      = r1 =*= r2 && p1 == p2    instance REq F.Reft where 
src/Language/Haskell/Liquid/Types/Errors.hs view
@@ -6,6 +6,8 @@ {-# LANGUAGE DeriveDataTypeable  #-} {-# LANGUAGE DeriveFunctor       #-} {-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE DerivingStrategies  #-}+{-# LANGUAGE DerivingVia         #-}  -- | This module contains the *types* related creating Errors. --   It depends only on Fixpoint and basic haskell libraries,@@ -37,9 +39,8 @@    -- * Printing Errors   , ppError-  , ppError'   , ppTicks-  +   -- * SrcSpan Helpers   , realSrcSpan   , unpackRealSrcSpan@@ -47,7 +48,7 @@   ) where  import           Prelude                      hiding (error)-import           SrcLoc                      +import           SrcLoc import           FastString import           HscTypes (srcErrorMessages, SourceError) import           ErrUtils@@ -61,18 +62,20 @@ 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 qualified Data.List                    as L import           System.Directory import           System.FilePath-import           Text.PrettyPrint.HughesPJ +import           Text.PrettyPrint.HughesPJ import           Text.Parsec.Error            (ParseError) import           Text.Parsec.Error            (errorMessages, showErrorMessages)  import           Language.Fixpoint.Types      (pprint, showpp, Tidy (..), PPrint (..), Symbol, Expr) import qualified Language.Fixpoint.Misc       as Misc-import qualified Language.Haskell.Liquid.Misc     as Misc +import qualified Language.Haskell.Liquid.Misc     as Misc import           Language.Haskell.Liquid.Misc ((<->))+import           Language.Haskell.Liquid.Types.Generics  instance PPrint ParseError where   pprintTidy _ e = vcat $ tail $ text <$> ls@@ -98,14 +101,14 @@ -------------------------------------------------------------------------------- errorsWithContext :: [TError Doc] -> IO [CtxError Doc] ---------------------------------------------------------------------------------errorsWithContext es -  = Misc.concatMapM fileErrors +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) +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))@@ -118,7 +121,7 @@   = empty  srcSpanInfo :: SrcSpan -> Maybe (Int, Int, Int, Int)-srcSpanInfo (RealSrcSpan s) +srcSpanInfo (RealSrcSpan s)               = Just (l, c, l', c')   where      l        = srcSpanStartLine s@@ -128,14 +131,14 @@ srcSpanInfo _ = Nothing  getFileLines :: FileBody -> Int -> Int -> [String]-getFileLines fb i j = slice (i - 1) (j - 1) fb +getFileLines fb i j = slice (i - 1) (j - 1) fb  getFileBody :: Maybe FilePath -> IO FileBody-getFileBody Nothing  = +getFileBody Nothing  =   return []-getFileBody (Just f) = do -  b <- doesFileExist f -  if b then lines <$> Misc.sayReadFile f +getFileBody (Just f) = do+  b <- doesFileExist f+  if b then lines <$> Misc.sayReadFile f        else return []  type FileBody = [String]@@ -176,7 +179,8 @@   = OTerm -- ^ Obligation that proves termination   | OInv  -- ^ Obligation that proves invariants   | OCons -- ^ Obligation that proves subtyping constraints-  deriving (Generic, Data, Typeable)+  deriving (Eq, Generic, Data, Typeable)+  deriving Hashable via Generically Oblig  instance B.Binary Oblig instance Show Oblig where@@ -223,13 +227,18 @@                , texp :: !t                } -- ^ liquid type error -  | ErrHole    { pos :: !SrcSpan-               , msg :: !Doc-               , ctx :: !(M.HashMap Symbol t)-               , var :: !Doc -               , thl :: !t -               } -- ^ hole type +  | 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@@ -346,7 +355,7 @@                 , kind :: !Doc                 , var  :: !Doc                 , msg  :: !Doc-                } -- ^ Name resolution error +                } -- ^ Name resolution error    | ErrMismatch { pos   :: !SrcSpan -- ^ haskell type location                 , var   :: !Doc@@ -431,15 +440,28 @@                 , msg :: !Doc                 } -  | ErrNoSpec   { pos  :: !SrcSpan -                , srcF :: !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+                }+   | ErrOther    { pos   :: SrcSpan                 , msg   :: !Doc                 } -- ^ Sigh. Other.-  +   deriving (Typeable, Generic , Functor )  errDupSpecs :: Doc -> Misc.ListNE SrcSpan -> TError t@@ -564,18 +586,17 @@ -------------------------------------------------------------------------------- ppError :: (PPrint a, Show a) => Tidy -> Doc -> TError a -> Doc ---------------------------------------------------------------------------------ppError k dCtx e = ppError' k dSp dCtx e-  where-    dSp          = pprint (pos e) <-> text ": Error:"+ppError k dCtx e = ppError' k dCtx e -nests :: Foldable t => Int -> t Doc -> Doc-nests n      = foldr (\d acc -> nest n (d $+$ acc)) empty+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 " "+blankLine = sizedText 5 "."  ppFull :: Tidy -> Doc -> Doc ppFull Full  d = d@@ -584,21 +605,21 @@ ppReqInContext :: PPrint t => Tidy -> t -> t -> M.HashMap Symbol t -> Doc ppReqInContext td tA tE c   = sepVcat blankLine-      [ nests 2 [ text "Inferred type"+      [ nests 2 [ text "The inferred type"                 , text "VV :" <+> pprintTidy td tA]-      , nests 2 [ text "not a subtype of Required type"+      , nests 2 [ text "is not a subtype of the required type"                 , text "VV :" <+> pprintTidy td tE]-      , ppContext td c +      , ppContext td c       ] -ppContext :: PPrint t => Tidy -> M.HashMap Symbol t -> Doc +ppContext :: PPrint t => Tidy -> M.HashMap Symbol t -> Doc ppContext td c-  | 0 < length xts = nests 2 [ text "In Context"+  | 0 < length xts = nests 2 [ text "in the context"                              , vsep (map (uncurry (pprintBind td)) xts)                              ]-  | otherwise      = empty -  where -    xts            = M.toList c +  | 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@@ -607,11 +628,11 @@   :: (PPrint t) => Tidy -> WithModel t -> t -> (M.HashMap Symbol (WithModel t)) -> Doc ppReqModelInContext td tA tE c   = sepVcat blankLine-      [ nests 2 [ text "Inferred type"+      [ nests 2 [ text "The inferred type"                 , pprintModel td "VV" tA]-      , nests 2 [ text "not a subtype of Required type"+      , nests 2 [ text "is not a subtype of the required type"                 , pprintModel td "VV" (NoModel tE)]-      , nests 2 [ text "In Context"+      , nests 2 [ text "in the context"                 , vsep (map (uncurry (pprintModel td)) (M.toList c))                 ]       ]@@ -673,7 +694,7 @@  srcSpanFileMb :: SrcSpan -> Maybe FilePath srcSpanFileMb (RealSrcSpan s) = Just $ unpackFS $ srcSpanFile s-srcSpanFileMb _               = Nothing +srcSpanFileMb _               = Nothing   instance ToJSON SrcSpan where@@ -693,7 +714,7 @@  instance (PPrint a, Show a) => ToJSON (TError a) where   toJSON e = object [ "pos" .= (pos e)-                    , "msg" .= (render $ ppError' Full empty empty e)+                    , "msg" .= (render $ ppError' Full empty e)                     ]  instance FromJSON (TError a) where@@ -707,173 +728,187 @@     n : m        = lines body  -totalityType :: PPrint a =>  Tidy -> a -> Bool +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 +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 (ErrBadGADT {})  = Just "Use the hole '_' to specify the type of the constructor" +    go (ErrBadGADT {})  = Just "Use the hole '_' to specify the type of the constructor"     go (ErrSubType {})  = Just "Use \"--no-totality\" to deactivate totality checking."     go (ErrNoSpec {})   = Just "Run 'liquid' on the source file first."-    go _                = Nothing +    go _                = Nothing  ---------------------------------------------------------------------------------ppError' :: (PPrint a, Show a) => Tidy -> Doc -> Doc -> TError a -> Doc+ppError' :: (PPrint a, Show a) => Tidy -> Doc -> TError a -> Doc ---------------------------------------------------------------------------------ppError' td dSp dCtx (ErrAssType _ o _ c p)-  = dSp <+> pprintTidy td o+ppError' td dCtx (ErrAssType _ o _ c p)+  = pprintTidy td o         $+$ dCtx         $+$ (ppFull td $ ppPropInContext td p c) -ppError' td dSp dCtx err@(ErrSubType _ _ _ _ tE)+ppError' td dCtx err@(ErrSubType _ _ _ _ tE)   | totalityType td tE-  = dSp <+> text "Totality Error"+  = text "Totality Error"         $+$ dCtx-        $+$ text "Your function is not total: not all patterns are defined." +        $+$ text "Your function is not total: not all patterns are defined."         $+$ hint err -- "Hint: Use \"--no-totality\" to deactivate totality checking." -ppError' _td dSp _dCtx (ErrHole _ _ _ x t)-  = dSp <+> "Hole Found"-        $+$ pprint x <+> "::" <+> pprint t +ppError' _td _dCtx (ErrHoleCycle _ holes)+  = "Cycle of holes found"+        $+$ pprint holes -ppError' td dSp dCtx (ErrSubType _ _ c tA tE)-  = dSp <+> text "Liquid Type Mismatch"-        $+$ dCtx-        $+$ (ppFull td $ ppReqInContext td tA tE c)+ppError' _td _dCtx (ErrHole _ msg _ x t)+  = "Hole Found"+        $+$ pprint x <+> "::" <+> pprint t+        $+$ msg -ppError' td dSp dCtx (ErrSubTypeModel _ _ c tA tE)-  = dSp <+> text "Liquid Type Mismatch"-        $+$ dCtx-        $+$ (ppFull td $ ppReqModelInContext td tA tE c)+ppError' td dCtx (ErrSubType _ _ c tA tE)+  = text "Liquid Type Mismatch"+    $+$ nest 4 (blankLine +                $+$ dCtx+                $+$ (ppFull td $ ppReqInContext td tA tE c)) -ppError' td  dSp dCtx (ErrFCrash _ _ c tA tE)-  = dSp <+> text "Fixpoint Crash on Constraint"+ppError' td dCtx (ErrSubTypeModel _ _ c tA tE)+  = text "Liquid Type Mismatch"+        $+$ nest 4 (dCtx+                    $+$ (ppFull td $ ppReqModelInContext td tA tE c))++ppError' td  dCtx (ErrFCrash _ _ c tA tE)+  = text "Fixpoint Crash on Constraint"         $+$ dCtx         $+$ (ppFull td $ ppReqInContext td tA tE c) -ppError' _ dSp dCtx (ErrParse _ _ e)-  = dSp <+> text "Cannot parse specification:"+ppError' _ dCtx (ErrParse _ _ e)+  = text "Cannot parse specification:"         $+$ dCtx         $+$ (nest 4 $ pprint e) -ppError' _ dSp dCtx (ErrTySpec _ _k v t s)-  = dSp <+> ("Illegal type specification for" <+> ppTicks v) --  <-> ppKind k <-> ppTicks v)+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                          ])-    where -      _ppKind Nothing  = empty +    where+      _ppKind Nothing  = empty       _ppKind (Just d) = d <-> " " -ppError' _ dSp dCtx (ErrLiftExp _ v)-  = dSp <+> text "Cannot lift" <+> ppTicks v <+> "into refinement logic"+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' _ dSp dCtx (ErrBadData _ v s)-  = dSp <+> text "Bad Data Specification"+ppError' _ dCtx (ErrBadData _ v s)+  = text "Bad Data Specification"         $+$ dCtx         $+$ (pprint s <+> "for" <+> ppTicks v) -ppError' _ dSp dCtx err@(ErrBadGADT _ v s)-  = dSp <+> text "Bad GADT specification for" <+> ppTicks v+ppError' _ dCtx err@(ErrBadGADT _ v s)+  = text "Bad GADT specification for" <+> ppTicks v         $+$ dCtx         $+$ pprint s-        $+$ hint err +        $+$ hint err -ppError' _ dSp dCtx (ErrDataCon _ d s)-  = dSp <+> "Malformed refined data constructor" <+> ppTicks d+ppError' _ dCtx (ErrDataCon _ d s)+  = "Malformed refined data constructor" <+> ppTicks d         $+$ dCtx         $+$ s -ppError' _ dSp dCtx (ErrBadQual _ n d)-  = dSp <+> text "Illegal qualifier specification for" <+> ppTicks n+ppError' _ dCtx (ErrBadQual _ n d)+  = text "Illegal qualifier specification for" <+> ppTicks n         $+$ dCtx         $+$ pprint d -ppError' _ dSp dCtx (ErrTermSpec _ v msg e t s)-  = dSp <+> text "Illegal termination specification for" <+> ppTicks v+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' _ dSp _ (ErrInvt _ t s)-  = dSp <+> text "Bad Invariant Specification"+ppError' _ _ (ErrInvt _ t s)+  = text "Bad Invariant Specification"         $+$ (nest 4 $ text "invariant " <+> pprint t $+$ pprint s) -ppError' _ dSp _ (ErrIAl _ t s)-  = dSp <+> text "Bad Using Specification"+ppError' _ _ (ErrIAl _ t s)+  = text "Bad Using Specification"         $+$ (nest 4 $ text "as" <+> pprint t $+$ pprint s) -ppError' _ dSp _ (ErrIAlMis _ t1 t2 s)-  = dSp <+> text "Incompatible Using Specification"+ppError' _ _ (ErrIAlMis _ t1 t2 s)+  = text "Incompatible Using Specification"         $+$ (nest 4 $ (text "using" <+> pprint t1 <+> text "as" <+> pprint t2) $+$ pprint s) -ppError' _ dSp _ (ErrMeas _ t s)-  = dSp <+> text "Bad Measure Specification"+ppError' _ _ (ErrMeas _ t s)+  = text "Bad Measure Specification"         $+$ (nest 4 $ text "measure " <+> pprint t $+$ pprint s) -ppError' _ dSp dCtx (ErrHMeas _ t s)-  = dSp <+> text "Cannot lift Haskell function" <+> ppTicks t <+> text "to logic"+ppError' _ dCtx (ErrHMeas _ t s)+  = text "Cannot lift Haskell function" <+> ppTicks t <+> text "to logic"         $+$ dCtx         $+$ (nest 4 $ pprint s) -ppError' _ dSp dCtx (ErrDupSpecs _ v ls)-  = dSp <+> text "Multiple specifications for" <+> ppTicks v <+> colon+ppError' _ dCtx (ErrDupSpecs _ v ls)+  = text "Multiple specifications for" <+> ppTicks v <+> colon         $+$ dCtx         $+$ ppSrcSpans ls --ppError' _ dSp dCtx (ErrDupIMeas _ v t ls)-  = dSp <+> text "Multiple instance measures" <+> ppTicks v <+> text "for type" <+> ppTicks t+ppError' _ dCtx (ErrDupIMeas _ v t ls)+  = text "Multiple instance measures" <+> ppTicks v <+> text "for type" <+> ppTicks t         $+$ dCtx         $+$ ppSrcSpans ls -ppError' _ dSp dCtx (ErrDupMeas _ v ls)-  = dSp <+> text "Multiple measures named" <+> ppTicks v+ppError' _ dCtx (ErrDupMeas _ v ls)+  = text "Multiple measures named" <+> ppTicks v         $+$ dCtx         $+$ ppSrcSpans ls -ppError' _ dSp dCtx (ErrDupField _ dc x)-  = dSp <+> text "Malformed refined data constructor" <+> dc+ppError' _ dCtx (ErrDupField _ dc x)+  = text "Malformed refined data constructor" <+> dc         $+$ dCtx         $+$ (nest 4 $ text "Duplicated definitions for field" <+> ppTicks x) -ppError' _ dSp dCtx (ErrDupNames _ x ns)-  = dSp <+> text "Ambiguous specification symbol" <+> ppTicks x+ppError' _ dCtx (ErrDupNames _ x ns)+  = text "Ambiguous specification symbol" <+> ppTicks x         $+$ dCtx         $+$ ppNames ns -ppError' _ dSp dCtx (ErrDupAlias _ k v ls)-  = dSp <+> text "Multiple definitions of" <+> pprint k <+> ppTicks v+ppError' _ dCtx (ErrDupAlias _ k v ls)+  = text "Multiple definitions of" <+> pprint k <+> ppTicks v         $+$ dCtx         $+$ ppSrcSpans ls -ppError' _ dSp dCtx (ErrUnbound _ x)-  = dSp <+> text "Unbound variable" <+> pprint x+ppError' _ dCtx (ErrUnbound _ x)+  = text "Unbound variable" <+> pprint x         $+$ dCtx -ppError' _ dSp dCtx (ErrUnbPred _ p)-  = dSp <+> text "Cannot apply unbound abstract refinement" <+> ppTicks p+ppError' _ dCtx (ErrUnbPred _ p)+  = text "Cannot apply unbound abstract refinement" <+> ppTicks p         $+$ dCtx -ppError' _ dSp dCtx (ErrGhc _ s)-  = dSp <+> text "GHC Error"+ppError' _ dCtx (ErrGhc _ s)+  = text "GHC Error"         $+$ dCtx         $+$ (nest 4 $ pprint s) -ppError' _ dSp dCtx (ErrResolve _ kind v msg)-  = dSp <+> (text "Unknown" <+> kind <+> ppTicks v) +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' _ dSp dCtx (ErrPartPred _ c p i eN aN)-  = dSp <+> text "Malformed predicate application"+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@@ -884,8 +919,8 @@                         , nest 4 "https://github.com/ucsd-progsys/liquidhaskell/issues/594"                         ]) -ppError' _ dSp dCtx e@(ErrMismatch _ x msg τ t cause hsSp)-  = dSp <+> "Specified type does not refine Haskell type for" <+> ppTicks x <+> parens msg+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"@@ -893,19 +928,19 @@               , "is inconsistent with the Haskell type"               , nest 4 τ               , "defined at" <+> pprint hsSp-              , maybe empty ppCause cause +              , 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 -              ] +    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' _ dSp dCtx (ErrAliasCycle _ acycle)-  = dSp <+> text "Cyclic type alias definition for" <+> ppTicks n0+ppError' _ dCtx (ErrAliasCycle _ acycle)+  = text "Cyclic type alias definition for" <+> ppTicks n0         $+$ dCtx         $+$ (nest 4 $ sepVcat blankLine (hdr : map describe acycle))   where@@ -913,63 +948,63 @@     describe (p, n) = text "*" <+> ppTicks n <+> parens (text "defined at:" <+> pprint p)     n0              = snd . head $ acycle -ppError' _ dSp dCtx (ErrIllegalAliasApp _ dn dl)-  = dSp <+> text "Refinement type alias cannot be used in this context"+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' _ dSp dCtx (ErrAliasApp _ name dl s)-  = dSp <+> text "Malformed application of type alias" <+> ppTicks name+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' _ dSp dCtx (ErrSaved _ name s)-  = dSp <+> name -- <+> "(saved)"+ppError' _ dCtx (ErrSaved _ name s)+  = name -- <+> "(saved)"         $+$ dCtx         $+$ {- nest 4 -} s -ppError' _ dSp dCtx (ErrFilePragma _)-  = dSp <+> text "Illegal pragma"+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)+ppError' _ _ err@(ErrNoSpec _ srcF bspecF)   =   vcat [ text "Cannot find .bspec file "-           , nest 4 bspecF +           , nest 4 bspecF            , text "for the source file "-           , nest 4 srcF -           , hint err +           , nest 4 srcF+           , hint err            ] -ppError' _ dSp dCtx (ErrOther _ s)-  = dSp <+> text "Uh oh."+ppError' _ dCtx (ErrOther _ s)+  = text "Uh oh."         $+$ dCtx         $+$ nest 4 s -ppError' _ dSp dCtx (ErrTermin _ xs s)-  = dSp <+> text "Termination Error"+ppError' _ dCtx (ErrTermin _ xs s)+  = text "Termination Error"         $+$ dCtx         <+> (hsep $ L.intersperse comma xs) $+$ s -ppError' _ dSp dCtx (ErrStTerm _ x s)-  = dSp <+> text "Structural Termination Error"+ppError' _ dCtx (ErrStTerm _ x s)+  = text "Structural Termination Error"         $+$ dCtx         <+> (text "Cannot prove termination for size" <+> x) $+$ s-ppError' _ dSp dCtx (ErrILaw _ c i s)-  = dSp <+> text "Law Instance Error"+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' _ dSp dCtx (ErrMClass _ v)-  = dSp <+> text "Standalone class method refinement"+ppError' _ dCtx (ErrMClass _ v)+  = text "Standalone class method refinement"     $+$ dCtx-    $+$ (text "Invalid type specification for" <+> v) +    $+$ (text "Invalid type specification for" <+> v)     $+$ (text "Use class or instance refinements instead.")-      -ppError' _ dSp _ (ErrRClass p0 c is)-  = dSp <+> text "Refined classes cannot have refined instances"++ppError' _ _ (ErrRClass p0 c is)+  = text "Refined classes cannot have refined instances"     $+$ (nest 4 $ sepVcat blankLine $ describeCls : map describeInst is)   where     describeCls@@ -979,20 +1014,25 @@       =   text "Refined instance for:" <+> t       $+$ text "Defined at:" <+> pprint p -ppError' _ dSp dCtx (ErrTyCon _ msg ty)-  = dSp <+> text "Illegal data refinement for" <+> ppTicks ty+ppError' _ dCtx (ErrTyCon _ msg ty)+  = text "Illegal data refinement for" <+> ppTicks ty         $+$ dCtx         $+$ nest 4 msg -ppError' _ dSp dCtx (ErrParseAnn _ msg)-  = dSp <+> text "Malformed annotation"+ppError' _ dCtx (ErrRewrite _ msg )+  = text "Rewrite error"         $+$ dCtx         $+$ nest 4 msg +ppError' _ dCtx (ErrParseAnn _ msg)+  = text "Malformed annotation"+        $+$ dCtx+        $+$ nest 4 msg+ ppTicks :: PPrint a => a -> Doc-ppTicks = ticks . pprint +ppTicks = ticks . pprint -ticks :: Doc -> Doc +ticks :: Doc -> Doc ticks d = text "`" <-> d <-> text "`"  ppSrcSpans :: [SrcSpan] -> Doc
src/Language/Haskell/Liquid/Types/Fresh.hs view
@@ -68,15 +68,8 @@  instance Freshable m Integer => Freshable m RReft where   fresh             = panic Nothing "fresh RReft"-  true (MkUReft r _ s)    = MkUReft <$> true r    <*> return mempty <*> true s-  refresh (MkUReft r _ s) = MkUReft <$> refresh r <*> return mempty <*> refresh s--instance Freshable m Integer => Freshable m Strata where-  fresh      = (:[]) . SVar <$> fresh-  true []    = fresh-  true s     = return s-  refresh [] = fresh-  refresh s  = return s+  true (MkUReft r _)    = MkUReft <$> true r    <*> return mempty+  refresh (MkUReft r _) = MkUReft <$> refresh r <*> return mempty  instance (Freshable m Integer, Freshable m r, F.Reftable r ) => Freshable m (RRType r) where   fresh   = panic Nothing "fresh RefType"@@ -86,8 +79,8 @@ ----------------------------------------------------------------------------------------------- trueRefType :: (Freshable m Integer, Freshable m r, F.Reftable r) => RRType r -> m (RRType r) ------------------------------------------------------------------------------------------------trueRefType (RAllT α t)-  = RAllT α <$> true t+trueRefType (RAllT α t r)+  = RAllT α <$> true t <*> true r   trueRefType (RAllP π t)   = RAllP π <$> true t@@ -128,9 +121,6 @@ trueRefType t@(RHole _)   = return t -trueRefType (RAllS _ t)-  = RAllS <$> fresh <*> true t- trueRef :: (F.Reftable r, Freshable f r, Freshable f Integer)         => Ref τ (RType RTyCon RTyVar r) -> f (Ref τ (RRType r)) trueRef (RProp _ (RHole _)) = panic Nothing "trueRef: unexpected RProp _ (RHole _))"@@ -140,8 +130,8 @@ ----------------------------------------------------------------------------------------------- refreshRefType :: (Freshable m Integer, Freshable m r, F.Reftable r) => RRType r -> m (RRType r) ------------------------------------------------------------------------------------------------refreshRefType (RAllT α t)-  = RAllT α <$> refresh t+refreshRefType (RAllT α t r)+  = RAllT α <$> refresh t <*> true r  refreshRefType (RAllP π t)   = RAllP π <$> refresh t@@ -199,8 +189,8 @@ -------------------------------------------------------------------------------- refreshVV :: FreshM m => SpecType -> m SpecType ---------------------------------------------------------------------------------refreshVV (RAllT a t) = -  RAllT a <$> refreshVV t+refreshVV (RAllT a t r) = +  RAllT a <$> refreshVV t <*> return r   refreshVV (RAllP p t) =    RAllP p <$> refreshVV t@@ -294,4 +284,4 @@          | otherwise = return r  noHoles :: (F.Reftable r, TyConable c) => RType c tv r -> Bool-noHoles = and . foldReft (\_ r bs -> not (hasHole r) : bs) []+noHoles = and . foldReft False (\_ r bs -> not (hasHole r) : bs) []
+ src/Language/Haskell/Liquid/Types/Generics.hs view
@@ -0,0 +1,62 @@+{- | Geriving instances, generically.+   This module shares some of the underlying ideas and implementations of the+   [generic-data](https://hackage.haskell.org/package/generic-data-0.8.1.0/docs/Generic-Data.html)+   package, allowing us to derive a bunch of instances using the underlying 'Generic' implementation,+   but in a more declarative way.++   In particular we introduc the 'Generically' newtype wrapper to be used with '-XDerivingVia' to make+   derivation explicit. For example:++@+  data Foo = Foo+       deriving Generic+       deriving Eq via Generically Foo+@++-}++{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}++module Language.Haskell.Liquid.Types.Generics where++import GHC.Generics+import Data.Hashable+import Data.Binary+import Data.Hashable.Generic+import Data.Function++newtype Generically a = Generically a deriving Generic++-- * 'Hashable'++instance (Generic a, GHashable Zero (Rep a)) => Hashable (Generically a) where+  hashWithSalt s (Generically a) = genericHashWithSalt s a++-- * 'Binary'++instance (Generic a, GBinaryPut (Rep a), GBinaryGet (Rep a)) => Binary (Generically a) where+  get = Generically . to' <$> gget+  put (Generically a) = gput (from' a)++-- * 'Eq'++-- | Generic @('==')@.+--+-- @+-- instance 'Eq' MyType where+--   ('==') = 'geq'+-- @+geq :: (Generic a, Eq (Rep a ())) => a -> a -> Bool+geq = (==) `on` from'++instance (Generic a, Eq (Rep a ())) => Eq (Generically a) where+  (Generically a) == (Generically b) = geq a b++-- | A helper for better type inference.+from' :: Generic a => a -> Rep a ()+from' = from++to' :: Generic a => Rep a () -> a+to' = to
src/Language/Haskell/Liquid/Types/Literals.hs view
@@ -8,8 +8,8 @@   ) where  import Prelude hiding (error)-import Language.Haskell.Liquid.GHC.TypeRep-import Literal+import Language.Haskell.Liquid.GHC.TypeRep ()+import Language.Haskell.Liquid.GHC.API import qualified TyCon  as TC  import Language.Haskell.Liquid.Types.Types
src/Language/Haskell/Liquid/Types/Names.hs view
@@ -1,5 +1,5 @@ module Language.Haskell.Liquid.Types.Names-  (lenLocSymbol, anyTypeSymbol) where+  (lenLocSymbol, anyTypeSymbol, functionComposisionSymbol) where  import Language.Fixpoint.Types @@ -9,3 +9,8 @@  anyTypeSymbol :: Symbol anyTypeSymbol = symbol ("GHC.Prim.Any" :: String)+++--  defined in include/GHC/Base.hs+functionComposisionSymbol :: Symbol+functionComposisionSymbol = symbol ("GHC.Base.." :: String)
src/Language/Haskell/Liquid/Types/PredType.hs view
@@ -31,13 +31,9 @@  import           Prelude                         hiding (error) import           DataCon-import           Name                            (getSrcSpan) import           Text.PrettyPrint.HughesPJ--- import qualified TyCon                           as TC--- import qualified Var-import           Type-import           Var-import           Language.Haskell.Liquid.GHC.TypeRep+import           Language.Haskell.Liquid.GHC.API+import           Language.Haskell.Liquid.GHC.TypeRep () import           Data.Hashable import qualified Data.HashMap.Strict             as M import qualified Data.Maybe                                 as Mb @@ -75,7 +71,7 @@   ]   mkRTyCon ::  TyConP -> RTyCon-mkRTyCon (TyConP _ tc αs' ps _ tyvariance predvariance size)+mkRTyCon (TyConP _ tc αs' ps tyvariance predvariance size)   = RTyCon tc pvs' (mkTyConInfo tc tyvariance predvariance size)   where     τs   = [rVar α :: RSort |  α <- tyConTyVarsDef tc]@@ -89,7 +85,7 @@ ------------------------------------------------------------------------------- dataConPSpecType :: DataConP -> [(Var, SpecType)] --------------------------------------------------------------------------------dataConPSpecType dcp    = F.notracepp "dataConPSpecType" [ (workX, workT), (wrapX, wrapT) ]+dataConPSpecType dcp    = [(workX, workT), (wrapX, wrapT) ]   where     workT | isVanilla   = wrapT           | otherwise   = dcWorkSpecType   dc wrapT@@ -151,7 +147,7 @@ meetWorkWrapRep c workR wrapR   | 0 <= pad   = workR { ty_binds = xs ++ (ty_binds wrapR)-          , ty_args  = ts ++ zipWith strengthenRType ts' (ty_args 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           }@@ -169,9 +165,9 @@ strengthenRType wkT wrT = maybe wkT (strengthen wkT) (stripRTypeBase wrT)  dcWrapSpecType :: DataCon -> DataConP -> SpecType-dcWrapSpecType dc (DataConP _ _ vs ps ls cs yts rt _ _ _)+dcWrapSpecType dc (DataConP _ _ vs ps cs yts rt _ _ _)   = {- F.tracepp ("dcWrapSpecType: " ++ show dc ++ " " ++ F.showpp rt) $ -}-    mkArrow makeVars ps ls [] ts' rt'+    mkArrow makeVars' ps [] ts' rt'   where     (xs, ts) = unzip (reverse yts)     mkDSym z = (F.symbol z) `F.suffixSymbol` (F.symbol dc)@@ -185,12 +181,12 @@     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) -                           <+> ppComm     k (tcpFreeLabelTy  tc)       --  (parens $ hsep (punctuate comma (pprintTidy k <$> vs))) <+>       -- (parens $ hsep (punctuate comma (pprintTidy k <$> ps))) <+>       -- (parens $ hsep (punctuate comma (pprintTidy k <$> ls)))@@ -205,11 +201,10 @@  show = showpp -- showSDoc . ppr  instance PPrint DataConP where-  pprintTidy k (DataConP _ dc vs ps ls cs yts t isGadt mname _)+  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 <$> ls)))     <+> (parens $ hsep (punctuate comma (pprintTidy k <$> cs)))     <+> (parens $ hsep (punctuate comma (pprintTidy k <$> yts)))     <+> (pprintTidy k isGadt)@@ -224,10 +219,10 @@           -> Type -> RType RTyCon RTyVar r dataConTy m (TyVarTy v)   = M.lookupDefault (rVar v) (RTV v) m-dataConTy m (FunTy t1 t2)+dataConTy m (FunTy _ t1 t2)   = rFun F.dummySymbol (dataConTy m t1) (dataConTy m t2)-dataConTy m (ForAllTy (TvBndr α _) t) -- α :: TyVar-  = RAllT (makeRTVar (RTV α)) (dataConTy m t)+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 _ _@@ -238,8 +233,8 @@ ---------------------------------------------------------------------------- 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) s)-  = MkUReft (F.Reft (v, rs'')) (Pr ps2) s+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@@ -335,7 +330,7 @@   | p /= q                      = RAllP q $ substPred msg (p, tp) t   | otherwise                   = RAllP q t -substPred msg su (RAllT a t)    = RAllT a (substPred msg su t)+substPred msg su (RAllT a t r)  = RAllT a (substPred msg su t) r  substPred msg su@(π,prop) (RFun x t t' r) --                        = RFun x (substPred msg su t) (substPred msg su t') r@@ -392,7 +387,7 @@      su = F.mkSubst $ zipWith (\s1 s2 -> (s1, F.EVar s2)) (rvs t1) (rvs t2) -    rvs      = foldReft (\_ r acc -> rvReft r : acc) []+    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)@@ -422,7 +417,7 @@   splitRPvar :: PVar t -> UReft r -> (UReft r, [UsedPVar])-splitRPvar pv (MkUReft x (Pr pvs) s) = (MkUReft x (Pr pvs') s, epvs)+splitRPvar pv (MkUReft x (Pr pvs)) = (MkUReft x (Pr pvs'), epvs)   where     (epvs, pvs')               = L.partition (uPVar pv ==) pvs @@ -434,10 +429,8 @@   = 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)-  = freeArgsPs p t-freeArgsPs p (RAllS _ t)-  = freeArgsPs p t+freeArgsPs p (RAllT _ t r)+  = L.nub $  freeArgsPs p t ++ freeArgsPsRef p r freeArgsPs p (RAllP p' t)   | p == p'   = []   | otherwise = freeArgsPs p t@@ -457,7 +450,7 @@   = 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]+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)}
src/Language/Haskell/Liquid/Types/PrettyPrint.hs view
@@ -7,6 +7,8 @@ {-# LANGUAGE TupleSections        #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MonoLocalBinds       #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances    #-}  module Language.Haskell.Liquid.Types.PrettyPrint   ( -- * Printable RTypes@@ -20,25 +22,31 @@   , pprintLongList   , pprintSymbol +  -- * Printing diagnostics+  , printWarning+  , printError++  -- * Reporting errors in the typechecking phase+  , reportErrors+   ) where +import           Control.Monad+ import qualified Data.HashMap.Strict              as M import qualified Data.List                        as L                               -- (sort) import           Data.String-import           ErrUtils                         (ErrMsg)-import           GHC                              (Name, Class)-import           HscTypes                         (SourceError)+import qualified TcRnMonad                        as Ghc+import qualified CoreSyn as GHC import           Language.Fixpoint.Misc-import qualified Language.Fixpoint.Types          as F +import qualified Language.Fixpoint.Types          as F+import           Language.Haskell.Liquid.GHC.API  as Ghc hiding (maybeParen, LM)+import           Language.Haskell.Liquid.GHC.Logging (putErrMsg, mkLongErrAt) import           Language.Haskell.Liquid.GHC.Misc import           Language.Haskell.Liquid.Misc-import           Language.Haskell.Liquid.Types.Types    +import           Language.Haskell.Liquid.Types.Types import           Prelude                          hiding (error)-import           SrcLoc import           Text.PrettyPrint.HughesPJ        hiding ((<>))-import           TyCon                            (TyCon)-import           Language.Haskell.Liquid.GHC.TypeRep  hiding (maybeParen)-import           Var                              (Var)  -------------------------------------------------------------------------------- pprManyOrdered :: (PPrint a, Ord a) => F.Tidy -> String -> [a] -> [Doc]@@ -69,6 +77,12 @@ 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 @@ -175,12 +189,10 @@ -------------------------------------------------------------------------------- ppr_rtype :: (OkRT c tv r) => PPEnv -> Prec -> RType c tv r -> Doc ---------------------------------------------------------------------------------ppr_rtype bb p t@(RAllT _ _)-  = ppr_forall bb p t+ppr_rtype bb p t@(RAllT _ _ r)+  = F.ppTy r $ ppr_forall bb p t ppr_rtype bb p t@(RAllP _ _)   = ppr_forall bb p t-ppr_rtype bb p t@(RAllS _ _)-  = ppr_forall bb p t ppr_rtype _ _ (RVar a r)   = F.ppTy r $ pprint a ppr_rtype bb p t@(RImpF _ _ _ _)@@ -325,17 +337,17 @@  ppr_forall :: (OkRT c tv r) => PPEnv -> Prec -> RType c tv r -> Doc ppr_forall bb p t = maybeParen p funPrec $ sep [-                      ppr_foralls (ppPs bb) (ty_vars trep) (ty_preds trep) (ty_labels trep)+                      ppr_foralls (ppPs bb) (fst <$> ty_vars trep) (ty_preds trep)                     , ppr_clss cls                     , ppr_rtype bb topPrec t'                     ]   where     trep          = toRTypeRep t-    (cls, t')     = bkClass $ fromRTypeRep $ trep {ty_vars = [], ty_preds = [], ty_labels = []}+    (cls, t')     = bkClass $ fromRTypeRep $ trep {ty_vars = [], ty_preds = []} -    ppr_foralls False _ _  _  = empty-    ppr_foralls _    [] [] [] = empty-    ppr_foralls True αs πs ss = text "forall" <+> dαs αs <+> dπs (ppPs bb) πs <+> ppr_symbols ss <-> dot+    ppr_foralls False _ _  = empty+    ppr_foralls _    [] [] = empty+    ppr_foralls True αs πs = text "forall" <+> dαs αs <+> dπs (ppPs bb) πs <-> dot      ppr_clss []               = empty     ppr_clss cs               = (parens $ hsep $ punctuate comma (uncurry (ppr_cls bb p) <$> cs)) <+> text "=>"@@ -350,10 +362,6 @@ ppr_rtvar_def :: (PPrint tv) => [RTVar tv (RType c tv ())] -> Doc ppr_rtvar_def = sep . map (pprint . ty_var_value) -ppr_symbols :: [F.Symbol] -> Doc-ppr_symbols [] = empty-ppr_symbols ss = angleBrackets $ intersperse comma $ pprint <$> ss- ppr_cls   :: (OkRT c tv r, PPrint a, PPrint (RType c tv r),       PPrint (RType c tv ()))@@ -398,9 +406,22 @@ dot                = char '.'  instance (PPrint r, F.Reftable r) => PPrint (UReft r) where-  pprintTidy k (MkUReft r p _)+  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.+reportErrors :: (Show e, F.PPrint e) => F.Tidy -> [TError e] -> Ghc.TcRn ()+reportErrors k errs =+  forM errs (\err -> mkLongErrAt (pos err) (ppError k empty err) mempty) >>= Ghc.reportErrors
src/Language/Haskell/Liquid/Types/RefType.hs view
@@ -13,6 +13,7 @@ {-# LANGUAGE PatternGuards             #-} {-# LANGUAGE ImplicitParams            #-} {-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE ViewPatterns              #-}  -- | Refinement Types. Mostly mirroring the GHC Type definition, but with --   room for refinements of various sorts.@@ -82,23 +83,22 @@   , isBaseTy   , updateRTVar, isValKind, kindToRType   , rTVarInfo+  +  , tyVarsPosition, Positions(..) +  , isNumeric+   ) where  -- import           GHC.Stack-import TyCoRep import Prelude hiding (error) -- import qualified Prelude import WwLib import FamInstEnv (emptyFamInstEnv) import Name             hiding (varName) import Var-import GHC              hiding (Located) import DataCon import qualified TyCon  as TC-import Type             (splitFunTys, expandTypeSynonyms, substTyWith, isClassPred, isEqPred, isNomEqPred)-import TysWiredIn       (listTyCon, intDataCon, trueDataCon, falseDataCon,-                         intTyCon, charTyCon, typeNatKind, typeSymbolKind, stringTy, intTy) import           Data.Maybe               (fromMaybe, isJust, fromJust) import           Data.Hashable import qualified Data.HashMap.Strict  as M@@ -119,10 +119,10 @@ import           Language.Haskell.Liquid.Misc import           Language.Haskell.Liquid.Types.Names import qualified Language.Haskell.Liquid.GHC.Misc as GM-import           Language.Haskell.Liquid.GHC.Play (mapType, stringClassArg) -- , dataConImplicitIds)-import qualified Language.Haskell.Liquid.GHC.API        as Ghc --import Data.List (sort, foldl')+import           Language.Haskell.Liquid.GHC.Play (mapType, stringClassArg, isRecursivenewTyCon)+import           Language.Haskell.Liquid.GHC.API        as Ghc hiding (Expr, Located, mapType, tyConName)+import           Language.Haskell.Liquid.GHC.TypeRep () -- Eq Type instance+import Data.List (foldl')   @@ -133,7 +133,7 @@ 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 mempty+    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@@ -147,40 +147,10 @@ dataConArgs trep = unzip [ (x, t) | (x, t) <- zip xs ts, isValTy t]   where     xs           = ty_binds trep-    -- xs           = zipWith (\_ i -> (symbol ("x" ++ show i))) (ty_args trep) [1..]     ts           = ty_args trep-    isValTy      = not . GM.isPredType . toType+    isValTy      = not . Ghc.isEvVarType . toType --- RJ: AAAAAAARGHHH: this is duplicate of RT.strengthenDataConType-{--makeDataConCtor :: Var -> SpecType-makeDataConCtor x = (dummyLoc . fromRTypeRep $ trep {ty_res = res, ty_binds = xs})-  where-    tres     = F.tracepp _msg $ ty_res trep `strengthen` MkUReft (exprReft expr) mempty mempty-    trep     = toRTypeRep . ofType . varType $ x-    _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) -makeDataConCtor :: Var -> (Var, LocSpecType)-makeDataConCtor x = (x, dummyLoc . fromRTypeRep $ trep {ty_res = res, ty_binds = xs})-  where-    t    :: SpecType-    t    = ofType $ varType x-    trep = toRTypeRep t-    xs   = zipWith (\_ i -> (symbol ("x" ++ show i))) (ty_args trep) [1..]--    res  = ty_res trep `strengthen` MkUReft ref mempty mempty-    vv   = vv_-    x'   = symbol x-    ref  = Reft (vv, PAtom Eq (EVar vv) eq)-    eq   | null (ty_vars trep) && null xs = EVar x'-         | otherwise = mkEApp (dummyLoc x') (EVar <$> xs)--}- pdVar :: PVar t -> Predicate pdVar v        = Pr [uPVar v] @@ -208,7 +178,7 @@ uReft           = uTop . Reft  uTop            ::  r -> UReft r-uTop r          = MkUReft r mempty mempty+uTop r          = MkUReft r mempty  -------------------------------------------------------------------- -------------- (Class) Predicates for Valid Refinement Types -------@@ -426,25 +396,24 @@ -- Eq Instances ------------------------------------------------------  -- MOVE TO TYPES-instance (Eq c, Eq tv, Hashable tv) => Eq (RType c tv ()) where+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)-        => M.HashMap k k -> RType a k t -> RType a k t1 -> Bool+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 (RAllS _ t) (RAllS _ t')-  = eqRSort m t t' eqRSort m (RAllP _ t) t'   = eqRSort m t t'-eqRSort m (RAllT a t) (RAllT a' 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 (RAllT _ t _) t'   = eqRSort m t t'-eqRSort m t (RAllT _ 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'@@ -465,17 +434,6 @@ -- | Wrappers for GHC Type Elements -------------------------------------------- -------------------------------------------------------------------------------- -instance Eq Predicate where-  (==) = eqpd--eqpd :: Predicate -> Predicate -> Bool-eqpd (Pr vs) (Pr ws)-  = and $ (length vs' == length ws') : [v == w | (v, w) <- zip vs' ws']-    where-      vs' = sort vs-      ws' = sort ws-- instance Eq RTyVar where   -- FIXME: need to compare unique and string because we reuse   -- uniques in stringTyVar and co.@@ -526,6 +484,7 @@   { 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@@ -580,7 +539,7 @@                   mempty  pdVarReft :: PVar t -> UReft Reft-pdVarReft = (\p -> MkUReft mempty p mempty) . pdVar+pdVarReft = (\p -> MkUReft mempty p) . pdVar  tyConRTyCon :: TyCon -> RTyCon tyConRTyCon c = RTyCon c [] (mkTyConInfo c [] [] Nothing)@@ -597,8 +556,8 @@  addPds :: Foldable t        => t (PVar (RType c tv ())) -> RType c tv r -> RType c tv r-addPds ps (RAllT v t) = RAllT v $ addPds ps t-addPds ps t           = foldl' (flip rPred) t ps+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 _ _ )@@ -615,13 +574,11 @@  = (RAppTy t1' t2' r, ps ++ ps1 ++ ps2)   where (t1', ps1) = nlzP [] t1         (t2', ps2) = nlzP [] t2-nlzP ps (RAllT v t )- = (RAllT v t', ps ++ ps')+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 (RAllS _ t)- = (t, ps) nlzP ps (RAllP p t)  = (t', [p] ++ ps ++ ps')   where (t', ps') = nlzP [] t@@ -659,7 +616,7 @@ strengthenRefTypeGen t1 t2 = strengthenRefType_ f t1 t2   where     f (RVar v1 r1) t  = RVar v1 (r1 `meet` fromMaybe mempty (stripRTypeBase t))-    f t (RVar v1 r1)  = 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]"                          (pprt_raw t1) (showpp (toRSort t1)) (pprt_raw t2) (showpp (toRSort t2)) @@ -692,15 +649,15 @@ _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) (RAllT a2 t2)-  = RAllT a1 $ strengthenRefType_ f t1 (subsTyVar_meet (ty_var_value a2, toRSort t, t) t2)+strengthenRefType_ f (RAllT a1 t1 r1) (RAllT a2 t2 r2)+  = RAllT a1 (strengthenRefType_ f t1 (subsTyVar_meet (ty_var_value a2, toRSort t, t) t2)) (r1 `meet` r2)   where t = RVar (ty_var_value a1) mempty -strengthenRefType_ f (RAllT a t1) t2-  = RAllT a $ strengthenRefType_ f t1 t2+strengthenRefType_ f (RAllT a t1 r1) t2+  = RAllT a (strengthenRefType_ f t1 t2) r1 -strengthenRefType_ f t1 (RAllT a t2)-  = RAllT a $ strengthenRefType_ f t1 t2+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@@ -711,12 +668,6 @@ strengthenRefType_ f t1 (RAllP p t2)   = RAllP p $ strengthenRefType_ f t1 t2 -strengthenRefType_ f (RAllS s t1) t2-  = RAllS s $ strengthenRefType_ f t1 t2--strengthenRefType_ f t1 (RAllS s t2)-  = RAllS s $ 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 @@ -762,16 +713,18 @@ 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 t1 t2 r) r'  = RImpF b t1 t2 (r `F.meet` r')+strengthen (RImpF b t1 t2 r) r' = RImpF b t1 t2 (r `F.meet` r') strengthen (RFun b t1 t2 r) r'  = RFun b 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 :: Eq tv => [RTVar tv (RType c tv ())] -> RType c tv r -> RType c tv r-quantifyRTy tvs ty = foldr RAllT ty tvs+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 :: Eq tv => RType c tv r -> RType c tv r+quantifyFreeRTy :: (Monoid r, Eq tv) => RType c tv r -> RType c tv r quantifyFreeRTy ty = quantifyRTy (freeTyVars ty) ty  @@ -874,7 +827,7 @@ 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.tyConArity c, toType <$> ts)+    _msg  = "appRTyCon-family: " ++ showpp (Ghc.isFamilyTyCon c, Ghc.tyConRealArity c, toType <$> ts)     resTc = RTyCon c ps'' (rtc_info rc'')     c     = rtc_tc rc    @@ -921,7 +874,7 @@                      $ Just (c', take (length ts - cArity) ts)      Nothing       -> Nothing     where -      cArity      = Ghc.tyConArity c+      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)) @@ -948,7 +901,7 @@ -- RJ: The code of `isNumeric` is incomprehensible. -- Please fix it to use intSort instead of intFTyCon isNumeric :: TCEmb TyCon -> RTyCon -> Bool-isNumeric tce c = mySort == FTC F.intFTyCon || mySort == F.FInt+isNumeric tce c = F.isNumeric mySort    where     -- mySort      = M.lookupDefault def rc tce     mySort      = maybe def fst (F.tceLookup rc tce)@@ -960,19 +913,18 @@   = c {rtc_info = (rtc_info c) {sizeFunction = Just IdSizeFun } }  -generalize :: (Eq tv) => RType c tv r -> RType c tv r-generalize t = mkUnivs (freeTyVars t) [] [] t+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 t = sortNub . fmap ty_var_value $ vs ++ vs'   where-    vs      = fst4 . bkUniv $ t+    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 (RAllS _ t)     = freeTyVars t-freeTyVars (RAllT α t)     = freeTyVars t L.\\ [α]+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@@ -987,8 +939,7 @@  tyClasses :: (OkRT RTyCon tv r) => RType RTyCon tv r -> [(Class, [RType RTyCon tv r])] tyClasses (RAllP _ t)     = tyClasses t-tyClasses (RAllS _ t)     = tyClasses t-tyClasses (RAllT _ 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'@@ -1089,13 +1040,11 @@   -> (tv, RType c tv (), RType c tv r)   -> RType c tv r   -> RType c tv r-subsFree m s z (RAllS l t)-  = RAllS l (subsFree m s z t) subsFree m s z@(α, τ,_) (RAllP π t)   = RAllP (subt (α, τ) π) (subsFree m s z t)-subsFree m s z@(a, τ, _) (RAllT α 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+  = RAllT (subt (a, τ) α) (subsFree m (ty_var_value α `S.insert` s) z t) (subt (a, τ) r) subsFree m s z@(α, τ, _) (RImpF x t t' r)   = RImpF x (subsFree m s z t) (subsFree m s z t') (subt (α, τ) r) subsFree m s z@(α, τ, _) (RFun x t t' r)@@ -1157,7 +1106,7 @@  -- | @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` +--    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] @@ -1198,7 +1147,7 @@         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 +     case `FunTy _` representation thus, so that we are not stuck with incompatible       representations e.g.           thing -> thing                                                  ... (using RFun)@@ -1281,7 +1230,29 @@ 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 t1 t2 r)  = RFun x (subt su t1) (subt su t2) r +  subt su (RImpF x t1 t2 r) = RImpF x (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)@@ -1373,7 +1344,7 @@   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 s) = MkUReft r (subvPredicate f p) s+subvUReft f (MkUReft r p) = MkUReft r (subvPredicate f p)  subvPredicate :: (UsedPVar -> UsedPVar) -> Predicate -> Predicate subvPredicate f (Pr pvs) = Pr (f <$> pvs)@@ -1405,10 +1376,10 @@   where     go (TyVarTy α)       = tcFVar tx α-    go (FunTy τ τ')+    go (FunTy _ τ τ')       = rFun dummySymbol (go τ) (go τ')-    go (ForAllTy (TvBndr α _) τ)-      = RAllT (tcFTVar tx α) $ go τ+    go (ForAllTy (Bndr α _) τ)+      = RAllT (tcFTVar tx α) (go τ) mempty     go (TyConApp c τs)       | Just (αs, τ) <- TC.synTyConDefn_maybe c       = go (substTyWith αs τs τ)@@ -1477,7 +1448,7 @@ isBaseTy (TyVarTy _)     = True isBaseTy (AppTy _ _)     = False isBaseTy (TyConApp _ ts) = and $ isBaseTy <$> ts-isBaseTy (FunTy _ _)     = False+isBaseTy (FunTy  _ _ _)  = False isBaseTy (ForAllTy _ _)  = False isBaseTy (LitTy _)       = True isBaseTy (CastTy _ _)    = False@@ -1503,13 +1474,11 @@ toType (RImpF x t t' r)  = toType (RFun x t t' r) toType (RFun _ t t' _)-  = FunTy (toType t) (toType t')-toType (RAllT a t) | RTV α <- ty_var_value a-  = ForAllTy (TvBndr α Required) (toType t)+  = FunTy VisArg (toType t) (toType t') -- FIXME(adinapoli) Is 'VisArg' correct here?+toType (RAllT a t _) | RTV α <- ty_var_value a+  = ForAllTy (Bndr α Required) (toType t) toType (RAllP _ t)   = toType t-toType (RAllS _ t)-  = toType t toType (RVar (RTV α) _)   = TyVarTy α toType (RApp (RTyCon {rtc_tc = c}) ts _ _)@@ -1583,7 +1552,7 @@ -------------------------------------------------------------------------------- applySolution = fmap . fmap . mapReft . appSolRefa   where-    mapReft f (MkUReft (Reft (x, z)) p s) = MkUReft (Reft (x, f z)) p s+    mapReft f (MkUReft (Reft (x, z)) p) = MkUReft (Reft (x, f z)) p  appSolRefa :: Visitable t            => M.HashMap KVar Expr -> t -> t@@ -1636,10 +1605,15 @@ typeSort tce = go   where     go :: Type -> Sort-    go t@(FunTy _ _)    = typeSortFun tce t+    go t@(FunTy  _ _ _) = typeSortFun tce t     go τ@(ForAllTy _ _) = typeSortForAll tce τ     -- go (TyConApp c τs)  = fApp (tyConFTyCon tce c) (go <$> τs)-    go (TyConApp c τs)  = 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@@ -1686,7 +1660,7 @@     τs            = grabArgs [] t  grabArgs :: [Type] -> Type -> [Type]-grabArgs τs (FunTy τ1 τ2)+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)@@ -1697,7 +1671,7 @@   = reverse (τ:τs)  isNonValueTy :: Type -> Bool-isNonValueTy t = {- Ghc.isPredTy -} isClassPred t || isEqPred t+isNonValueTy = GM.isPredType   expandProductType :: (PPrint r, Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, Reftable (RTProp RTyCon RTyVar r))@@ -1734,52 +1708,16 @@ classBinds emb (RApp c [_, _, (RVar a _), t] _ _)   | isEqual c   = [(symbol a, rTypeSortedReft emb t)]-classBinds  emb (RApp c [_, (RVar a _), t] _ _)-  | showpp c == "Data.Type.Equality.~<[]>"  -- see [NOTE:type-equality-hack]+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 t, isEqualityConstr t)) [] -{- | [NOTE:type-equality-hack]--God forgive me for this AWFUL HACK.--How can I “test for” (i.e. write a function of type `Type -> Bool`)--that returns `True` for values (i.e. `Type`s) that print out as:-- ```-     typ ~ GHC.Types.Int- ```-- or with, which some more detail, looks like-- ```-    (~ (TYPE LiftedRep) typ GHC.Types.Int)- ```-- and which are generated from Haskell source that looks like-- ```- instance PersistEntity Blob where-    data EntityField Blob typ-       = typ ~ Int => BlobXVal |-         typ ~ Int => BlobYVal- ```-- see tests/neg/BinahUpdateLib1.hs-- I would have thought that `Type.isEqPred` or `Type.isNomEqPred` described here-- https://downloads.haskell.org/~ghc/8.2.1/docs/html/libraries/ghc-8.2.1/src/Type.html#isEqPred-- and which is what `isEqualityConstr` below is doing, but alas it doesn't work.--}- isEqualityConstr :: SpecType -> Bool-isEqualityConstr = (isEqPred  .||. isNomEqPred) . toType+isEqualityConstr (toType -> ty) = Ghc.isEqPred ty || Ghc.isEqPrimPred ty  -------------------------------------------------------------------------------- -- | Termination Predicates ----------------------------------------------------@@ -1804,7 +1742,7 @@ makeDecrType :: Symbolic a              => S.HashSet TyCon              -> [(a, (Symbol, RType RTyCon t (UReft Reft)))]-             -> (Symbol, RType RTyCon t (UReft Reft))+             -> Either (Symbol, RType RTyCon t (UReft Reft)) String  makeDecrType autoenv = mkDType autoenv [] []  mkDType :: Symbolic a@@ -1812,9 +1750,9 @@         -> [(Symbol, Symbol, Symbol -> Expr)]         -> [Expr]         -> [(a, (Symbol, RType RTyCon t (UReft Reft)))]-        -> (Symbol, RType RTyCon t (UReft Reft))+        -> Either (Symbol, RType RTyCon t (UReft Reft)) String  mkDType autoenv xvs acc [(v, (x, t))]-  = (x, ) $ t `strengthen` tr+  = Left ((x, ) $ t `strengthen` tr)   where     tr = uTop $ Reft (vv, pOr (r:acc))     r  = cmpLexRef xvs (v', vv, f)@@ -1831,7 +1769,7 @@   mkDType _ _ _ _-  = panic Nothing "RefType.mkDType called on invalid input"+  = Right "RefType.mkDType called on invalid input"  isSizeable  :: S.HashSet TyCon -> TyCon -> Bool isSizeable autoenv tc = S.member tc autoenv --   TC.isAlgTyCon tc -- && TC.isRecursiveTyCon tc@@ -1900,7 +1838,7 @@      goDCon dc = concatMap (go True) (DataCon.dataConOrigArgTys dc) -    go pos (FunTy t1 t2)   = go (not pos) t1 ++ go pos t2+    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@@ -1932,7 +1870,7 @@ dataConsOfTyCon = dcs S.empty   where     dcs vis c               = mconcat $ go vis <$> [t | dc <- TC.tyConDataCons c, t <- DataCon.dataConOrigArgTys dc]-    go  vis (FunTy t1 t2)   = go vis t1 `S.union` go vis t2+    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@@ -1993,3 +1931,40 @@ instance PPrint (RTProp c tv r) => Show (RTProp c tv r) where   show = showpp ++-------------------------------------------------------------------------------+-- | tyVarsPosition t returns the type variables appearing +-- | (in positive positions, in negative positions, in undetermined positions)+-- | undetermined positions are due to type constructors and type application+-------------------------------------------------------------------------------+tyVarsPosition :: RType RTyCon tv r -> Positions tv +tyVarsPosition = go (Just True)+  where +    go p (RVar t _)        = report p t+    go p (RFun _ t1 t2 _)  = go (flip p) t1 <> go p t2 +    go p (RImpF _ t1 t2 _) = go (flip p) t1 <> go p t2 +    go p (RAllT _ t _)     = go p t +    go p (RAllP _ t)       = go p t +    go p (RApp c ts _ _)   = mconcat (zipWith go (getPosition p <$> varianceTyArgs (rtc_info c)) ts)+    go p (RAllE _ t1 t2)   = go p t1 <> go p t2 +    go p (REx _ t1 t2)     = go p t1 <> go p t2+    go _ (RExprArg _)      = mempty+    go p (RAppTy t1 t2 _)  = go p t1 <> go p t2 +    go p (RRTy _ _ _ t)    = go p t +    go _ (RHole _)         = mempty++    getPosition :: Maybe Bool -> Variance -> Maybe Bool+    getPosition b Contravariant = not <$> b +    getPosition b _             = b  ++    report Nothing v      = (Pos [] [] [v])+    report (Just True) v  = (Pos [v] [] [])+    report (Just False) v = (Pos [] [v] [])+    flip = fmap not++data Positions a = Pos {ppos :: [a], pneg ::  [a], punknown :: [a]}++instance Monoid (Positions a) where +  mempty = Pos [] [] []+instance Semigroup (Positions a) where +  (Pos x1 x2 x3) <> (Pos y1 y2 y3) = Pos (x1 ++ y1) (x2 ++ y2) (x3 ++ y3)
src/Language/Haskell/Liquid/Types/Specs.hs view
@@ -5,79 +5,206 @@ {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE DerivingVia                #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards            #-} -module Language.Haskell.Liquid.Types.Specs where +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+  , StableModule(..)+  , toStableModule+  , renderModule+  , 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+  ) where  -import           GHC.Generics-import qualified Data.Binary             as B+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           Language.Haskell.Liquid.GHC.API +import           Language.Haskell.Liquid.GHC.Types import           Text.PrettyPrint.HughesPJ              (text, (<+>))  ----------------------------------------------------------------------------- | GHC Information:  Code & Spec ---------------------------------------------------------------------------------------------------------------- --- | The following is the overall type for /specifications/ obtained from--- parsing the target source and dependent libraries+{- $differentSpecTypes -data GhcInfo = GI-  { giSrc       :: !GhcSrc  -  , giSpec      :: !GhcSpec               -- ^ All specification information for module+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.   } -data GhcSrc = Src +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   :: !(S.HashSet Var)       -- ^ Binders created by GHC eg dictionaries+  , 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   :: !NameSet               -- ^ `Name`s exported by the module being verified+  , 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+  , 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.+-- | '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 -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  :: !BareSpec               -- ^ Lifted specification for the target module+-- $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 GhcSpec where+instance HasConfig TargetSpec where   getConfig = gsConfig -instance HasConfig GhcInfo where-  getConfig = getConfig . giSpec-+-- | 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)@@ -88,12 +215,12 @@ 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)-  -- REBARE: , giHqFiles   :: ![FilePath]         -- ^ Imported .hqual files   }  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 @@ -114,7 +241,6 @@   { 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-  -- REBARE: == gsMeas , gsLits       :: ![(F.Symbol, LocSpecType)]    -- ^ Literals/Constants e.g. datacons: EQ, GT, string lits: "zombie",...   , 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@@ -124,17 +250,21 @@   { 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    }  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+  { 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]   }  data GhcSpecLaws = SpLaws @@ -151,13 +281,28 @@   }    type VarOrLocSymbol = Either Var LocSymbol-type BareSpec      = Spec    LocBareType F.LocSymbol type BareMeasure   = Measure LocBareType F.LocSymbol type BareDef       = Def     LocBareType F.LocSymbol type SpecMeasure   = Measure LocSpecType DataCon-    -instance B.Binary BareSpec +-- $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, Semigroup, Monoid, Binary)++-- | 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@@ -179,6 +324,9 @@   , 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@@ -201,17 +349,455 @@   , 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+           , termexprs  =           termexprs  s1 ++ termexprs  s2+           , rinstance  =           rinstance  s1 ++ rinstance  s2+           , ilaws      =               ilaws  s1 ++ ilaws      s2 +           , dvariance  =           dvariance  s1 ++ dvariance  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)+           } -isExportedVar :: GhcSrc -> Var -> Bool-isExportedVar info v = n `elemNameSet` ns+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      = [] +           , termexprs  = []+           , rinstance  = []+           , ilaws      = [] +           , dvariance  = []+           , 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)+  , 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 +++-- $trackingDeps++-- | 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 :: Module } +  deriving Generic++-- | Converts a 'Module' into a 'StableModule'.+toStableModule :: Module -> StableModule+toStableModule = StableModule++renderModule :: Module -> String+renderModule m =    "Module { unitId = " <> show (moduleUnitId m)+                 <> ", name = " <> show (moduleName m) +                 <> " }"++instance Hashable StableModule where+  hashWithSalt s (StableModule mdl) = hashWithSalt s (moduleStableString mdl)++instance Ord StableModule where+  (StableModule m1) `compare` (StableModule m2) = stableModuleCmp m1 m2++instance Eq StableModule where+  (StableModule m1) == (StableModule m2) = (m1 `stableModuleCmp` m2) == EQ++instance Show StableModule where+    show (StableModule mdl) = "Stable" ++ renderModule mdl++instance Binary StableModule where++    put (StableModule mdl) = do+      put (unitIdString . moduleUnitId $ mdl)+      put (moduleNameString . moduleName $ mdl)++    get = do+      uidStr <- get+      mnStr  <- get+      pure $ StableModule (Module (stringToUnitId uidStr) (mkModuleName mnStr))++-- | The /target/ dependencies that concur to the creation of a 'TargetSpec' and a 'LiftedSpec'.+newtype TargetDependencies =+  TargetDependencies { getDependencies :: HashMap StableModule LiftedSpec }+  deriving (Eq, Show, Semigroup, Monoid, Generic)+  deriving Binary via Generically TargetDependencies++-- | 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 info+    ns               = gsExports src -isPLEVar :: GhcSpec -> Var -> Bool -isPLEVar sp x = M.member x (gsAutoInst (gsRefl sp)) +--+-- $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++{- +instance HasConfig GhcInfo where+  getConfig = getConfig . _giSpec+-}++{- $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+      , 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+  , 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+  , bounds     = liftedBounds a+  , defs       = liftedDefs a+  , axeqs      = S.toList . liftedAxeqs $ a+  }
− src/Language/Haskell/Liquid/Types/Strata.hs 
@@ -1,79 +0,0 @@-{-# LANGUAGE TypeSynonymInstances      #-}-{-# LANGUAGE FlexibleInstances         #-}--module Language.Haskell.Liquid.Types.Strata (-    SubStratum(..)-  , solveStrata-  , (<:=)-  ) where--import Prelude hiding (error)--import Language.Fixpoint.Types (Symbol)-import Language.Haskell.Liquid.Types.Types hiding (Def, Loc)--(<:=) :: (Foldable t, Foldable t1) => t Stratum -> t1 Stratum -> Bool-s1 <:= s2-  | any (==SDiv) s1 && any (==SFin) s2 = False-  | otherwise                          = True--solveStrata :: [([Stratum], [Stratum])] -> [(Symbol, Stratum)]-solveStrata = go True [] []-  where go False solved _   [] = solved-        go True  solved acc [] = go False solved [] $ {-traceShow ("OLD \n" ++ showMap solved acc ) $ -} subsS solved <$> acc-        go mod   solved acc (([], _):ls) = go mod solved acc ls-        go mod   solved acc ((_, []):ls) = go mod solved acc ls-        go mod   solved acc (l:ls) | allSVars l  = go mod solved (l:acc) ls-                                   | noSVar   l  = go mod solved acc ls-                                   | noUpdate l  = go mod solved (l:acc) ls-                                   | otherwise   = go True (solve l ++ solved) (l:acc) ls---allSVars :: ([Stratum], [Stratum]) -> Bool-allSVars (xs, ys) = all isSVar $ xs ++ ys--noSVar :: ([Stratum], [Stratum]) -> Bool-noSVar   (xs, ys) = all (not . isSVar) (xs ++ ys)--noUpdate :: (Foldable t, Foldable t1) => (t1 Stratum, t Stratum) -> Bool-noUpdate (xs, ys) = (not $ updateFin(xs, ys)) && (not $ updateDiv (xs, ys))--updateFin :: (Foldable t, Foldable t1) => (t1 Stratum, t Stratum) -> Bool-updateFin (xs, ys) = any (==SFin) ys && any isSVar   xs--updateDiv :: (Foldable t, Foldable t1) => (t1 Stratum, t Stratum) -> Bool-updateDiv (xs, ys) = any isSVar   ys && any (==SDiv) xs--solve :: ([Stratum], [Stratum]) -> [(Symbol, Stratum)]-solve (xs, ys)-  | any (== SDiv) xs = [(l, SDiv) | SVar l <- ys]-  | any (== SFin) ys = [(l, SFin) | SVar l <- xs]-  | otherwise        = []---class SubStratum a where-  subS  :: (Symbol, Stratum) -> a -> a-  subsS :: [(Symbol, Stratum)] -> a -> a--  subsS su x = foldr subS x su--instance SubStratum Stratum where-  subS (x, s) (SVar y) | x == y    = s-                       | otherwise = (SVar y)-  subS _      s        = s---instance (SubStratum a, SubStratum b) => SubStratum (a, b) where-  subS su (x, y) = (subS su x, subS su y)--instance (SubStratum a) => SubStratum [a] where-  subS su xs = subS su <$> xs--instance SubStratum (Annot SpecType) where-  subS su (AnnUse t) = AnnUse $ subS su t-  subS su (AnnDef t) = AnnDef $ subS su t-  subS su (AnnRDf t) = AnnRDf $ subS su t-  subS _  (AnnLoc s) = AnnLoc s--instance SubStratum SpecType where-  subS su t = (\r -> r {ur_strata = subS su (ur_strata r)}) <$> t
src/Language/Haskell/Liquid/Types/Types.hs view
@@ -15,6 +15,8 @@ {-# LANGUAGE ConstraintKinds            #-} {-# LANGUAGE BangPatterns               #-} {-# LANGUAGE TupleSections              #-}+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE DerivingVia                #-}  -- | This module should contain all the global type definitions and basic instances. @@ -74,6 +76,7 @@   , RTVar (..), RTVInfo (..)   , makeRTVar, mapTyVarValue   , dropTyVarInfo, rTVarToBind+  , setRtvPol    -- * Predicate Variables   , PVar (PV, pname, parg, ptype, pargs), isPropPV, pvType@@ -112,7 +115,7 @@   -- * Constructing & Destructing RTypes   , RTypeRep(..), fromRTypeRep, toRTypeRep   , mkArrow, bkArrowDeep, bkArrow, safeBkArrow-  , mkUnivs, bkUniv, bkClass+  , mkUnivs, bkUniv, bkClass, bkUnivClass   , rImpF, rFun, rCls, rRCls    -- * Manipulating `Predicates`@@ -176,10 +179,19 @@   , RTEnv (..), BareRTEnv, SpecRTEnv, BareRTAlias, SpecRTAlias   -- , mapRT, mapRE -  -- * Errors and Error Messages+  -- * 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 (..)@@ -192,6 +204,9 @@   , Def (..)   , Body (..)   , MSpec (..)+  +  -- * Scoping Info+  , BScope    -- * Type Classes   , RClass (..)@@ -206,12 +221,6 @@   , mapRTAVars   , insertsSEnv -  -- * Strata-  , Stratum(..), Strata-  , isSVar-  , getStrata-  , makeDivType, makeFinType-   -- * CoreToLogic   , LogicMap(..), toLogicMap, eAppWithMap, LMap(..) @@ -228,35 +237,21 @@   , Axiom(..), HAxiom    -- , rtyVarUniqueSymbol, tyVarUniqueSymbol-  , rtyVarType+  , rtyVarType, tyVarVar   )   where --- import qualified ConLike                                as Ghc--- import           InstEnv-import           Class-import           CoreSyn                                (CoreExpr)+import           Language.Haskell.Liquid.GHC.API hiding (Expr, Target, isFunTy, LM) import           Data.String-import           DataCon-import           GHC                                    (ModuleName, moduleNameString) import           GHC.Generics-import           Module                                 (moduleNameFS)--- import           NameSet import           PrelInfo                               (isNumericClass) import           Prelude                          hiding  (error) import qualified Prelude-import           SrcLoc                                 (SrcSpan) import           TyCon-import           Type                                   (getClassPredTys_maybe)-import           Language.Haskell.Liquid.GHC.TypeRep    hiding  (maybeParen)-import           TysPrim                                (eqReprPrimTyCon, eqPrimTyCon)-import           TysWiredIn                             (listTyCon, boolTyCon)-import           Var  import           Control.Monad                          (liftM, liftM2, liftM3, liftM4) import           Control.DeepSeq import           Data.Bifunctor---import           Data.Bifunctor.TH import           Data.Typeable                          (Typeable) import           Data.Generics                          (Data) import qualified Data.Binary                            as B@@ -264,9 +259,10 @@ 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                             (fromMaybe, mapMaybe) import           Data.Function                          (on)-import           Data.List                              (foldl', nub)+import           Data.List                              as L (foldl', nub, null) import           Data.Text                              (Text) import           Text.PrettyPrint.HughesPJ              hiding (first, (<>))  import           Text.Printf@@ -274,14 +270,26 @@  import qualified Language.Fixpoint.Types as F +import           Language.Haskell.Liquid.Types.Generics import           Language.Haskell.Liquid.GHC.Misc+import           Language.Haskell.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 @@ -296,9 +304,8 @@ -----------------------------------------------------------------------------  data PPEnv = PP -  { ppPs    :: Bool -- ^ print "foralls" and abstract-predicates +  { ppPs    :: Bool -- ^ print abstract-predicates    , ppTyVar :: Bool -- ^ print the unique suffix for each tyvar-  , ppSs    :: Bool -- ^ print the strata (?)    , ppShort :: Bool -- ^ print the tycons without qualification    , ppDebug :: Bool -- ^ gross with full info   }@@ -315,7 +322,7 @@  -}  ppEnvDef :: PPEnv-ppEnvDef = PP False False False False False+ppEnvDef = PP False False False False  ppEnvShort :: PPEnv -> PPEnv ppEnvShort pp = pp { ppShort = True }@@ -388,7 +395,6 @@   , tcpCon          :: !TyCon   , tcpFreeTyVarsTy :: ![RTyVar]   , tcpFreePredTy   :: ![PVar RSort]-  , tcpFreeLabelTy  :: ![Symbol]   , tcpVarianceTs   :: !VarianceInfo   , tcpVariancePs   :: !VarianceInfo   , tcpSizeFun      :: !(Maybe SizeFun)@@ -404,7 +410,6 @@   , dcpCon        :: !DataCon                -- ^ Corresponding GHC DataCon    , dcpFreeTyVars :: ![RTyVar]               -- ^ Type parameters   , dcpFreePred   :: ![PVar RSort]           -- ^ Abstract Refinement parameters-  , dcpFreeLabels :: ![Symbol]               -- ^ ? strata stuff   , dcpTyConstrs  :: ![SpecType]             -- ^ ? Class constraints (via `dataConStupidTheta`)   , dcpTyArgs     :: ![(Symbol, SpecType)]   -- ^ Value parameters   , dcpTyRes      :: !SpecType               -- ^ Result type@@ -479,8 +484,19 @@  type UsedPVar      = PVar () -newtype Predicate  = Pr [UsedPVar] deriving (Generic, Data, Typeable)+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@@ -494,10 +510,10 @@   p <> p' = pdAnd [p, p']  instance Semigroup a => Semigroup (UReft a) where-  MkUReft x y z <> MkUReft x' y' z' = MkUReft (x <> x') (y <> y') (z <> z')+  MkUReft x y <> MkUReft x' y' = MkUReft (x <> x') (y <> y')  instance (Monoid a) => Monoid (UReft a) where-  mempty  = MkUReft mempty mempty mempty+  mempty  = MkUReft mempty mempty   mappend = (<>)  @@ -563,6 +579,7 @@   , btc_prom  :: !Bool           -- ^ Is Promoted Data Con?   }   deriving (Generic, Data, Typeable)+  deriving Hashable via Generically BTyCon  instance B.Binary BTyCon @@ -586,6 +603,11 @@ 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 @@ -699,6 +721,7 @@   | RAllT {       rt_tvbind :: !(RTVU c tv) -- RTVar tv (RType c tv ()))     , rt_ty     :: !(RType c tv r)+    , rt_ref    :: !r     }    -- | "forall x y <z :: Nat, w :: Int> . TYPE"@@ -708,13 +731,6 @@     , rt_ty     :: !(RType c tv r)     } -  -- | "forall <z w> . TYPE"-  --           ^^^^^ (rt_sbind)-  | RAllS {-      rt_sbind  :: !(Symbol)-    , 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 `[]`.@@ -754,7 +770,8 @@    | RHole r -- ^ let LH match against the Haskell type and add k-vars, e.g. `x:_`             --   see tests/pos/Holes.hs-  deriving (Generic, Data, Typeable, Functor)+  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)@@ -767,8 +784,7 @@ dropImplicits (RImpF _ _ o _) = dropImplicits o dropImplicits (RFun  x i o r) = RFun x (dropImplicits i) (dropImplicits o) r dropImplicits (RAllP p t) = RAllP p (dropImplicits t)-dropImplicits (RAllT p t) = RAllT p (dropImplicits t)-dropImplicits (RAllS p t) = RAllS 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')@@ -781,7 +797,7 @@   makeRTVar :: tv -> RTVar tv s-makeRTVar a = RTVar a RTVNoInfo+makeRTVar a = RTVar a (RTVNoInfo True)  instance (Eq tv) => Eq (RTVar tv s) where   t1 == t2 = (ty_var_value t1) == (ty_var_value t2)@@ -790,21 +806,29 @@   { 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}+dropTyVarInfo v = v{ty_var_info = RTVNoInfo True }  data RTVInfo s-  = RTVNoInfo+  = 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@@ -815,8 +839,8 @@ ty_var_is_val = rtvinfo_is_val . ty_var_info  rtvinfo_is_val :: RTVInfo s -> Bool-rtvinfo_is_val RTVNoInfo      = False-rtvinfo_is_val (RTVInfo {..}) = rtv_is_val+rtvinfo_is_val (RTVNoInfo {..}) = False+rtvinfo_is_val (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)@@ -835,7 +859,8 @@ data Ref τ t = RProp   { rf_args :: [(Symbol, τ)]   , rf_body :: t -- ^ Abstract refinement associated with `RTyCon`-  } deriving (Generic, Data, Typeable, Functor)+  } 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)@@ -863,9 +888,9 @@ data UReft r = MkUReft   { ur_reft   :: !r   , ur_pred   :: !Predicate-  , ur_strata :: !Strata   }-  deriving (Generic, Data, Typeable, Functor, Foldable, Traversable)+  deriving (Eq, Generic, Data, Typeable, Functor, Foldable, Traversable)+  deriving Hashable via Generically (UReft r)  instance B.Binary r => B.Binary (UReft r) @@ -897,22 +922,6 @@ type SpecRTAlias = RTAlias RTyVar SpecType  -data Stratum    = SVar Symbol | SDiv | SWhnf | SFin-                  deriving (Generic, Data, Typeable, Eq)--instance NFData   Stratum-instance B.Binary Stratum--type Strata = [Stratum]--isSVar :: Stratum -> Bool-isSVar (SVar _) = True-isSVar _        = False--instance {-# OVERLAPPING #-} Monoid Strata where-  mempty        = []-  mappend s1 s2 = nub $ s1 ++ s2- class SubsTy tv ty a where   subt :: (tv, ty) -> a -> a @@ -1019,6 +1028,9 @@ 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)@@ -1050,7 +1062,8 @@   { riclass :: BTyCon   , ritype  :: [t]   , risigs  :: [(F.LocSymbol, RISig t)]-  } deriving (Generic, Functor, Data, Typeable, Show)+  } deriving (Eq, Generic, Functor, Data, Typeable, Show)+    deriving Hashable via Generically (RInstance t)  data RILaws ty = RIL   { rilName    :: BTyCon@@ -1058,10 +1071,12 @@   , rilTyArgs  :: [ty]   , rilEqus    :: [(F.LocSymbol, F.LocSymbol)]   , rilPos     :: F.Located ()-  } deriving (Show, Functor, Data, Typeable, Generic)+  } deriving (Eq, Show, Functor, Data, Typeable, Generic)+    deriving Hashable via Generically (RILaws ty)  data RISig t = RIAssumed t | RISig t-  deriving (Generic, Functor, Data, Typeable, Show)+  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) @@ -1124,13 +1139,13 @@   { tycName   :: DataName              -- ^ Type  Constructor Name   , tycTyVars :: [Symbol]              -- ^ Tyvar Parameters   , tycPVars  :: [PVar BSort]          -- ^ PVar  Parameters-  , tycTyLabs :: [Symbol]              -- ^ PLabel  Parameters   , tycDCons  :: [DataCtor]            -- ^ Data Constructors   , 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@@ -1146,18 +1161,21 @@   , 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"@@ -1257,7 +1275,8 @@   , rtVArgs :: [Symbol]           -- ^ value parameters   , rtBody  :: a                  -- ^ what the alias expands to   -- , rtMod   :: !ModName           -- ^ module where alias was defined-  } deriving (Data, Typeable, Generic, Functor)+  } 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)@@ -1273,9 +1292,8 @@ -- | Constructor and Destructors for RTypes ------------------------------------ -------------------------------------------------------------------------------- data RTypeRep c tv r = RTypeRep-  { ty_vars   :: [RTVar tv (RType c tv ())]+  { ty_vars   :: [(RTVar tv (RType c tv ()), r)]   , ty_preds  :: [PVar (RType c tv ())]-  , ty_labels :: [Symbol]   , ty_ebinds  :: [Symbol]   , ty_erefts  :: [r]   , ty_eargs   :: [RType c tv r]@@ -1287,35 +1305,33 @@  fromRTypeRep :: RTypeRep c tv r -> RType c tv r fromRTypeRep (RTypeRep {..})-  = mkArrow ty_vars ty_preds ty_labels earrs arrs ty_res+  = mkArrow ty_vars ty_preds earrs arrs ty_res   where-    arrs = safeZip3WithError ("fromRTypeRep: " ++ show (length ty_binds, length ty_args, length ty_refts)) ty_binds ty_args ty_refts+    arrs  = safeZip3WithError ("fromRTypeRep: " ++ show (length ty_binds, length ty_args, length ty_refts)) ty_binds ty_args ty_refts     earrs = safeZip3WithError ("fromRTypeRep: " ++ show (length ty_ebinds, length ty_eargs, length ty_erefts)) ty_ebinds ty_eargs ty_erefts  -------------------------------------------------------------------------------- toRTypeRep           :: RType c tv r -> RTypeRep c tv r ---------------------------------------------------------------------------------toRTypeRep t         = RTypeRep αs πs ls xs' rs' ts' xs rs ts t''+toRTypeRep t         = RTypeRep αs πs xs' rs' ts' xs rs ts t''   where-    (αs, πs, ls, t')  = bkUniv  t+    (αs, πs, t')  = bkUniv  t     ((xs',ts',rs'),(xs, ts, rs), t'') = bkArrow t' -mkArrow :: [RTVar tv (RType c tv ())]+mkArrow :: [(RTVar tv (RType c tv ()), r)]         -> [PVar (RType c tv ())]-        -> [Symbol]         -> [(Symbol, RType c tv r, r)]         -> [(Symbol, RType c tv r, r)]         -> RType c tv r         -> RType c tv r-mkArrow αs πs ls yts xts = mkUnivs αs πs ls . mkArrs RImpF yts. mkArrs RFun xts+mkArrow αs πs yts xts = mkUnivs αs πs . mkArrs RImpF yts. mkArrs RFun xts   where     mkArrs f xts t  = foldr (\(b,t1,r) t2 -> f b t1 t2 r) t xts  -- Do I need to keep track of implicits here too? bkArrowDeep :: RType t t1 a -> ([Symbol], [RType t t1 a], [a], RType t t1 a)-bkArrowDeep (RAllT _ t)     = bkArrowDeep t+bkArrowDeep (RAllT _ t _)   = bkArrowDeep t bkArrowDeep (RAllP _ t)     = bkArrowDeep t-bkArrowDeep (RAllS _ t)     = bkArrowDeep t bkArrowDeep (RImpF x t t' r)= bkArrowDeep (RFun x t t' r) bkArrowDeep (RFun x t t' r) = let (xs, ts, rs, t'') = bkArrowDeep t'  in (x:xs, t:ts, r:rs, t'') bkArrowDeep t               = ([], [], [], t)@@ -1341,25 +1357,29 @@             => RType t t1 a -> ( ([Symbol], [RType t t1 a], [a])                                , ([Symbol], [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 (RAllS _ t)   = safeBkArrow t-safeBkArrow t             = bkArrow t+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, Foldable t2)-        => t  (RTVar tv (RType c tv ()))+mkUnivs :: (Foldable t, Foldable t1)+        => t  (RTVar tv (RType c tv ()), r)         -> t1 (PVar (RType c tv ()))-        -> t2 Symbol         -> RType c tv r         -> RType c tv r-mkUnivs αs πs ls t = foldr RAllT (foldr RAllP (foldr RAllS t ls) πs) αs+mkUnivs αs πs t = foldr (\(a,r) t -> RAllT a t r) (foldr RAllP t πs) αs -bkUniv :: RType tv c r -> ([RTVar c (RType tv c ())], [PVar (RType tv c ())], [Symbol], RType tv c r)-bkUniv (RAllT α t) = let (αs, πs, ls, t') = bkUniv t in (α:αs, πs, ls, t')-bkUniv (RAllP π t) = let (αs, πs, ls, t') = bkUniv t in (αs, π:πs, ls, t')-bkUniv (RAllS s t) = let (αs, πs, ss, t') = bkUniv t in (αs, πs, s:ss, t')-bkUniv t           = ([], [], [], t)+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)+ 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@@ -1401,32 +1421,9 @@  ------------------------------------------- -instance F.Subable Stratum where-  syms (SVar s) = [s]-  syms _        = []-  subst su (SVar s) = SVar $ F.subst su s-  subst _ s         = s-  substf f (SVar s) = SVar $ F.substf f s-  substf _ s        = s-  substa f (SVar s) = SVar $ F.substa f s-  substa _ s        = s--instance F.Reftable Strata where-  isTauto []         = True-  isTauto _          = False--  ppTy _             = panic Nothing "ppTy on Strata"-  toReft _           = mempty-  params s           = [l | SVar l <- s]-  bot _              = []-  top _              = []--  ofReft = todo Nothing "TODO: Strata.ofReft"-- class F.Reftable r => UReftable r where   ofUReft :: UReft F.Reft -> r-  ofUReft (MkUReft r _ _) = F.ofReft r+  ofUReft (MkUReft r _) = F.ofReft r   instance UReftable (UReft F.Reft) where@@ -1436,13 +1433,13 @@    ofUReft _ = mempty  instance (F.PPrint r, F.Reftable r) => F.Reftable (UReft r) where-  isTauto                 = isTauto_ureft-  ppTy                    = ppTy_ureft-  toReft (MkUReft r ps _) = F.toReft r `F.meet` F.toReft ps-  params (MkUReft r _ _)  = F.params r-  bot (MkUReft r _ s)     = MkUReft (F.bot r) (Pr []) (F.bot s)-  top (MkUReft r p s)     = MkUReft (F.top r) (F.top p) s-  ofReft r                = MkUReft (F.ofReft r) mempty mempty+  isTauto               = isTauto_ureft+  ppTy                  = ppTy_ureft+  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@@ -1450,27 +1447,23 @@   isTauto_ureft :: F.Reftable r => UReft r -> Bool-isTauto_ureft u      = F.isTauto (ur_reft u) && F.isTauto (ur_pred u) -- && (isTauto $ ur_strata u)+isTauto_ureft u      = F.isTauto (ur_reft u) && F.isTauto (ur_pred u)   ppTy_ureft :: F.Reftable r => UReft r -> Doc -> Doc-ppTy_ureft u@(MkUReft r p s) d+ppTy_ureft u@(MkUReft r p) d   | isTauto_ureft  u  = d-  | otherwise         = ppr_reft r (F.ppTy p d) s+  | otherwise         = ppr_reft r (F.ppTy p d) -ppr_reft :: (F.PPrint [t], F.Reftable r) => r -> Doc -> [t] -> Doc-ppr_reft r d s       = braces (F.pprint v <+> colon <+> d <-> ppr_str s <+> text "|" <+> F.pprint r')+ppr_reft :: (F.Reftable r) => r -> Doc -> Doc+ppr_reft r d = braces (F.pprint v <+> colon <+> d <+> text "|" <+> F.pprint r')   where     r'@(F.Reft (v, _)) = F.toReft r -ppr_str :: F.PPrint [t] => [t] -> Doc-ppr_str [] = empty-ppr_str s  = text "^" <-> F.pprint s- instance F.Subable r => F.Subable (UReft r) where-  syms (MkUReft r p _)     = F.syms r ++ F.syms p-  subst s (MkUReft r z l)  = MkUReft (F.subst s r)  (F.subst s z)  (F.subst s l)-  substf f (MkUReft r z l) = MkUReft (F.substf f r) (F.substf f z) (F.substf f l)-  substa f (MkUReft r z l) = MkUReft (F.substa f r) (F.substa f z) (F.substa f l)+  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@@ -1486,7 +1479,7 @@   instance (F.Subable r, F.Reftable r, TyConable c) => F.Subable (RType c tv r) where-  syms        = foldReft    (\_ r acc -> F.syms r ++ acc) []+  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@@ -1527,19 +1520,18 @@ mapExprReft :: (Symbol -> Expr -> Expr) -> RType c tv RReft -> RType c tv RReft mapExprReft f = mapReft g   where-    g (MkUReft (F.Reft (x, e)) p s) = MkUReft (F.Reft (x, f x e)) p s+    g (MkUReft (F.Reft (x, e)) p) = MkUReft (F.Reft (x, f x e)) p  isTrivial :: (F.Reftable r, TyConable c) => RType c tv r -> Bool-isTrivial t = foldReft (\_ r b -> F.isTauto r && b) True t+isTrivial t = foldReft False (\_ r b -> F.isTauto r && b) True t  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)         = RAllT α (emapReft f γ t)+emapReft f γ (RAllT α t r)       = RAllT α (emapReft f γ t) (f γ r) emapReft f γ (RAllP π t)         = RAllP π (emapReft f γ t)-emapReft f γ (RAllS p t)         = RAllS p (emapReft f γ t) emapReft f γ (RImpF x t t' r)    = RImpF  x (emapReft f γ t) (emapReft f (x:γ) t') (f (x:γ) r) emapReft f γ (RFun x t t' r)     = RFun  x (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)@@ -1559,9 +1551,8 @@   where     go _ t@(RVar {})        = t     go _ t@(RHole {})       = t-    go γ (RAllT α t)        = RAllT α (go γ t)+    go γ (RAllT α t r)      = RAllT α (go γ t) r      go γ (RAllP π t)        = RAllP π (go γ t)-    go γ (RAllS p t)        = RAllS p (go γ t)     go γ (RImpF x t t' r)   = RImpF x (go γ t) (go (x:γ) t') r     go γ (RFun x t t' r)    = RFun  x (go γ t) (go (x:γ) t') r     go γ (RApp c ts rs r)   = RApp  c (go γ <$> ts) (mo γ <$> rs) r@@ -1582,9 +1573,8 @@     go a (RVar {})          = a     go a (RHole {})         = a     go a (RExprArg {})      = a-    go a (RAllT _ t)        = step a t+    go a (RAllT _ t _)      = step a t     go a (RAllP _ t)        = step a t-    go a (RAllS _ 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']@@ -1603,11 +1593,11 @@ -- isBase _ = True  isBase :: RType t t1 t2 -> Bool-isBase (RAllT _ t)      = isBase t+isBase (RAllT _ t _)    = isBase t isBase (RAllP _ t)      = isBase t isBase (RVar _ _)       = True isBase (RApp _ ts _ _)  = all isBase ts-isBase (RImpF _ _ _ _)   = False+isBase (RImpF _ _ _ _)  = False isBase (RFun _ _ _ _)   = False isBase (RAppTy t1 t2 _) = isBase t1 && isBase t2 isBase (RRTy _ _ _ t)   = isBase t@@ -1617,9 +1607,8 @@  hasHoleTy :: RType t t1 t2 -> Bool hasHoleTy (RVar _ _)       = False -hasHoleTy (RAllT _ t)      = hasHoleTy t +hasHoleTy (RAllT _ t _)    = hasHoleTy t  hasHoleTy (RAllP _ t)      = hasHoleTy t-hasHoleTy (RAllS _ 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 @@ -1634,8 +1623,7 @@  isFunTy :: RType t t1 t2 -> Bool isFunTy (RAllE _ _ t)    = isFunTy t-isFunTy (RAllS _ t)      = isFunTy t-isFunTy (RAllT _ t)      = isFunTy t+isFunTy (RAllT _ t _)    = isFunTy t isFunTy (RAllP _ t)      = isFunTy t isFunTy (RImpF _ _ _ _)  = True isFunTy (RFun _ _ _ _)   = True@@ -1644,10 +1632,9 @@  mapReftM :: (Monad m) => (r1 -> m r2) -> RType c tv r1 -> m (RType c tv r2) mapReftM f (RVar α r)         = liftM   (RVar  α)   (f r)-mapReftM f (RAllT α t)        = liftM   (RAllT α)   (mapReftM f t)+mapReftM f (RAllT α t r)      = liftM2  (RAllT α)   (mapReftM f t)          (f r) mapReftM f (RAllP π t)        = liftM   (RAllP π)   (mapReftM f t)-mapReftM f (RAllS s t)        = liftM   (RAllS s)   (mapReftM f t)-mapReftM f (RImpF x t t' r)   = liftM3  (RImpF x)    (mapReftM f t)          (mapReftM f t')       (f r)+mapReftM f (RImpF x t t' r)   = liftM3  (RImpF x)   (mapReftM f t)          (mapReftM f t')       (f r) mapReftM f (RFun x t t' r)    = liftM3  (RFun x)    (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')@@ -1662,10 +1649,9 @@  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)        = liftM   (RAllT α)   (mapPropM f t)+mapPropM f (RAllT α t r)      = liftM2  (RAllT α)   (mapPropM f t)          (return r) mapPropM f (RAllP π t)        = liftM   (RAllP π)   (mapPropM f t)-mapPropM f (RAllS s t)        = liftM   (RAllS s)   (mapPropM f t)-mapPropM f (RImpF x t t' r)   = liftM3  (RImpF x)    (mapPropM f t)          (mapPropM f t') (return r)+mapPropM f (RImpF x t t' r)   = liftM3  (RImpF x)    (mapPropM f t)         (mapPropM f t') (return r) mapPropM f (RFun x t t' r)    = liftM3  (RFun x)    (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')@@ -1682,30 +1668,33 @@ -- foldReft f = efoldReft (\_ _ -> []) (\_ -> ()) (\_ _ -> f) (\_ γ -> γ) emptyF.SEnv  ---------------------------------------------------------------------------------foldReft :: (F.Reftable r, TyConable c) => (F.SEnv (RType c tv r) -> r -> a -> a) -> a -> RType c tv r -> a+foldReft :: (F.Reftable r, TyConable c) => BScope -> (F.SEnv (RType c tv r) -> r -> a -> a) -> a -> RType c tv r -> a ---------------------------------------------------------------------------------foldReft  f = foldReft' (\_ _ -> False) id (\γ _ -> f γ)+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 g f = efoldReft logicBind-                            (\_ _ -> [])-                            (\_ -> [])-                            g-                            (\γ t r z -> f γ t r z)-                            (\_ γ -> γ)-                            F.emptySEnv+foldReft' logicBind bsc g f +  = efoldReft logicBind bsc +              (\_ _ -> [])+              (\_ -> [])+              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)@@ -1715,15 +1704,14 @@           -> b           -> RType c tv r           -> b-efoldReft logicBind cb dty g f fp = go+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 (RAllT a t)-       | ty_var_is_val a                = go (insertsSEnv γ (dty a)) z t-       | otherwise                      = go γ z t+    go γ z me@(RAllT a t r)+       | ty_var_is_val 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 (RAllS _ t)                  = go γ z t     go γ z (RImpF x t t' r)             = go γ z (RFun x t t' r)     go γ z me@(RFun _ (RApp c ts _ _) t' r)        | isClass c                      = f γ (Just me) r (go (insertsSEnv γ (cb c ts)) (go' γ z ts) t')@@ -1732,11 +1720,12 @@        | 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' (insertSEnv (rTypeValueVar me) (g me) γ) z ts) rs)+    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 [] 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@@ -1755,9 +1744,8 @@     envtoType xts = foldr (\(x,t1) t2 -> rFun x t1 t2) (snd $ last xts) (init xts)  mapBot :: (RType c tv r -> RType c tv r) -> RType c tv r -> RType c tv r-mapBot f (RAllT α t)       = RAllT α (mapBot f t)+mapBot f (RAllT α t r)     = RAllT α (mapBot f t) r mapBot f (RAllP π t)       = RAllP π (mapBot f t)-mapBot f (RAllS s t)       = RAllS s (mapBot f t) mapBot f (RImpF x t t' r)  = RImpF x (mapBot f t) (mapBot f t') r mapBot f (RFun x t t' r)   = RFun x (mapBot f t) (mapBot f t') r mapBot f (RAppTy t t' r)   = RAppTy (mapBot f t) (mapBot f t') r@@ -1773,9 +1761,8 @@ 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)      = RAllT α (mapBind f t)+mapBind f (RAllT α t r)    = RAllT α (mapBind f t) r mapBind f (RAllP π t)      = RAllP π (mapBind f t)-mapBind f (RAllS s t)      = RAllS s (mapBind f t) mapBind f (RImpF b t1 t2 r)= RImpF (f b)  (mapBind f t1) (mapBind f t2) r mapBind f (RFun b t1 t2 r) = RFun (f b)  (mapBind f t1) (mapBind f t2) r mapBind f (RApp c ts rs r) = RApp c (mapBind f <$> ts) (mapBindRef f <$> rs) r@@ -1801,9 +1788,8 @@ toRSort = stripAnnotations . mapBind (const F.dummySymbol) . fmap (const ())  stripAnnotations :: RType c tv r -> RType c tv r-stripAnnotations (RAllT α t)      = RAllT α (stripAnnotations t)+stripAnnotations (RAllT α t r)    = RAllT α (stripAnnotations t) r stripAnnotations (RAllP _ t)      = stripAnnotations t-stripAnnotations (RAllS _ t)      = stripAnnotations t stripAnnotations (RAllE _ _ t)    = stripAnnotations t stripAnnotations (REx _ _ t)      = stripAnnotations t stripAnnotations (RImpF x t t' r) = RImpF x (stripAnnotations t) (stripAnnotations t') r@@ -1841,6 +1827,8 @@   = Just x stripRTypeBase (RAppTy _ _ x)   = Just x+stripRTypeBase (RAllT _ _ x)+  = Just x  stripRTypeBase _   = Nothing @@ -1855,39 +1843,10 @@ mapRBase f (RAppTy t1 t2 r) = RAppTy t1 t2 $ f r mapRBase _ t                = t --makeLType :: Stratum -> SpecType -> SpecType-makeLType l t = fromRTypeRep trep{ty_res = mapRBase f $ ty_res trep}-  where trep = toRTypeRep t-        f (MkUReft r p _) = MkUReft r p [l]---makeDivType :: SpecType -> SpecType-makeDivType = makeLType SDiv--makeFinType :: SpecType -> SpecType-makeFinType = makeLType SFin--getStrata :: RType t t1 (UReft r) -> [Stratum]-getStrata = maybe [] ur_strata . stripRTypeBase- ----------------------------------------------------------------------------- -- | F.PPrint ----------------------------------------------------------------- ----------------------------------------------------------------------------- -instance Show Stratum where-  show SFin = "Fin"-  show SDiv = "Div"-  show SWhnf = "Whnf"-  show (SVar s) = show s--instance F.PPrint Stratum where-  pprintTidy _ = text . show--instance {-# OVERLAPPING #-} F.PPrint Strata where-  pprintTidy _ [] = empty-  pprintTidy k ss = hsep (F.pprintTidy k <$> nub ss)- instance F.PPrint (PVar a) where   pprintTidy _ = ppr_pvar @@ -1934,6 +1893,52 @@   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 ----------------------------------------------------------- -------------------------------------------------------------------------------- @@ -2049,6 +2054,7 @@   | 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@@ -2057,6 +2063,7 @@   , 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@@ -2064,7 +2071,8 @@   , msEqns :: [Def ty ctor]   , msKind :: !MeasureKind    , msUnSorted :: !UnSortedExprs -- potential unsorted expressions used at measure denifinitions-  } deriving (Data, Typeable, Generic, Functor)+  } deriving (Eq, Data, Typeable, Generic, Functor)+    deriving Hashable via Generically (Measure ty ctor)  type UnSortedExprs = [UnSortedExpr] -- mempty = [] type UnSortedExpr  = ([F.Symbol], F.Expr)@@ -2078,6 +2086,7 @@   | 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@@ -2178,7 +2187,8 @@   , rcSupers  :: [ty]   , rcTyVars  :: [BTyVar]   , rcMethods :: [(F.LocSymbol, ty)]-  } deriving (Show, Functor, Data, Typeable, Generic)+  } deriving (Eq, Show, Functor, Data, Typeable, Generic)+    deriving Hashable via Generically (RClass ty)   instance F.PPrint t => F.PPrint (RClass t) where @@ -2227,15 +2237,15 @@ -- | Var Hole Info ----------------------------------------------------- ------------------------------------------------------------------------ -data HoleInfo t = HoleInfo {htype :: t, hloc :: SrcSpan, henv :: AREnv t }+data HoleInfo i t = HoleInfo {htype :: t, hloc :: SrcSpan, henv :: AREnv t, info :: i } -instance Functor HoleInfo where +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 t) where+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 enviornment uncomment the following+  -- to print the hole environment uncomment the following   --                     <+> text "\n env:" <+> F.pprintTidy k (henv hinfo)  ------------------------------------------------------------------------
src/Language/Haskell/Liquid/Types/Variance.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}  module Language.Haskell.Liquid.Types.Variance ( Variance(..), VarianceInfo ) where @@ -9,13 +11,17 @@ import Data.Data import GHC.Generics import Data.Binary+import Data.Hashable import Text.PrettyPrint.HughesPJ import qualified Language.Fixpoint.Types as F +import Language.Haskell.Liquid.Types.Generics+ type VarianceInfo = [Variance]  data Variance = Invariant | Bivariant | Contravariant | Covariant-              deriving (Data, Typeable, Show, Generic)+              deriving (Eq, Data, Typeable, Show, Generic)+              deriving Hashable via Generically Variance  instance Binary Variance instance NFData Variance
src/Language/Haskell/Liquid/Types/Visitors.hs view
@@ -18,18 +18,14 @@   ) where  import           CoreSyn-import           TysPrim                          (intPrimTy) import           Data.Hashable import           DataCon-import           Literal-import           FastString                       (fastStringToByteString)-import           Var  import           Data.List                        (foldl', (\\), delete) import qualified Data.HashSet                     as S import           Prelude                          hiding (error) import           Language.Fixpoint.Misc-import           Language.Haskell.Liquid.GHC.TypeRep+import           Language.Haskell.Liquid.GHC.API import           Language.Haskell.Liquid.GHC.Misc ()  @@ -132,7 +128,7 @@     go' _                  = []  -    tyLitToLit (StrTyLit fs) = MachStr (fastStringToByteString fs)+    tyLitToLit (StrTyLit fs) = LitString (bytesFS fs)     tyLitToLit (NumTyLit i)  = LitNumber LitNumInt (fromIntegral i) intPrimTy  
src/Language/Haskell/Liquid/UX/Annotate.hs view
@@ -45,7 +45,8 @@  import           System.Exit                                  (ExitCode (..)) import           System.FilePath                              (takeFileName, dropFileName, (</>))-import           System.Directory                             (findExecutable, copyFile)+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@@ -120,8 +121,15 @@ mkBots (AI m) = [ src | (src, (Just _, t) : _) <- sortBy (compare `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 (`copyFile` tgtFile) (tgtFile `appendFile`)+writeFilesOrStrings tgtFile = mapM_ $ either (`copyFileCreateParentDirIfMissing` tgtFile) (tgtFile `appendFile`)  generateHtml :: FilePath -> FilePath -> ACSS.AnnMap -> IO () generateHtml srcF htmlF annm@@ -129,7 +137,7 @@        let lhs  = isExtFile LHs srcF        let body = {-# SCC "hsannot" #-} ACSS.hsannot False (Just tokAnnot) lhs (src, annm)        cssFile <- getCssPath-       copyFile cssFile (dropFileName htmlF </> takeFileName cssFile)+       copyFileCreateParentDirIfMissing cssFile (dropFileName htmlF </> takeFileName cssFile)        renderHtml lhs htmlF srcF (takeFileName cssFile) body  renderHtml :: Bool -> FilePath -> String -> String -> String -> IO ()@@ -235,17 +243,17 @@                              }  mkStatus :: FixResult t -> ACSS.Status-mkStatus (Safe)          = ACSS.Safe-mkStatus (Unsafe _)      = ACSS.Unsafe+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 ls-mkAnnMapErr _            = []+mkAnnMapErr (Unsafe _ ls) = mapMaybe cinfoErr ls+mkAnnMapErr (Crash ls _)  = mapMaybe cinfoErr ls+mkAnnMapErr _             = []  cinfoErr :: PPrint (TError t) => TError t -> Maybe (Loc, Loc, String) cinfoErr e = case pos e of
src/Language/Haskell/Liquid/UX/CmdLine.hs view
@@ -4,6 +4,9 @@ {-# LANGUAGE TemplateHaskell           #-} {-# LANGUAGE TupleSections             #-} {-# LANGUAGE TypeSynonymInstances      #-}+{-# LANGUAGE NamedFieldPuns            #-}+{-# LANGUAGE MultiWayIf                #-}+{-# LANGUAGE ViewPatterns              #-} {-# OPTIONS_GHC -fno-cse #-}  -- | This module contains all the code needed to output the result which@@ -14,7 +17,7 @@  module Language.Haskell.Liquid.UX.CmdLine (    -- * Get Command Line Configuration-     getOpts, mkOpts, defConfig+     getOpts, mkOpts, defConfig, config     -- * Update Configuration With Pragma    , withPragmas@@ -26,15 +29,23 @@    , 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.Aeson (encode) import qualified Data.ByteString.Lazy.Char8 as B@@ -46,8 +57,9 @@ 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 GitHash  import Data.List                           (nub) @@ -59,17 +71,20 @@ 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.GHC.Misc import Language.Haskell.Liquid.Misc-import Language.Haskell.Liquid.Types.PrettyPrint+import Language.Haskell.Liquid.Types.PrettyPrint () import Language.Haskell.Liquid.Types       hiding (typ) import qualified Language.Haskell.Liquid.UX.ACSS as ACSS +import qualified Language.Haskell.Liquid.GHC.API as GHC + import Text.Parsec.Pos                     (newPos)-import Text.PrettyPrint.HughesPJ           hiding (Mode)+import Text.PrettyPrint.HughesPJ           hiding (Mode, (<>))   @@ -85,7 +100,13 @@ --------------------------------------------------------------------------------- config :: Mode (CmdArgs Config) config = cmdArgsMode $ Config {-   files+  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@@ -106,10 +127,10 @@     = def           &= help "Allow higher order binders into the logic" - , smtTimeout + , smtTimeout     = def-          &= help "Timeout of smt queries in msec"    -      +          &= help "Timeout of smt queries in msec"+  , higherorderqs     = def           &= help "Allow higher order qualifiers to get automatically instantiated"@@ -134,27 +155,31 @@           &= name "prune-unsorted"   , notermination-    = def +    = def           &= help "Disable Termination Check"           &= name "no-termination-check" - , rankNTypes + , rankNTypes     = def &= help "Adds precise reasoning on presence of rankNTypes"-          &= name "rankNTypes" +          &= name "rankNTypes"   , noclasscheck-    = def +    = def           &= help "Disable Class Instance Check"           &= name "no-class-check"   , nostructuralterm     = def &= name "no-structural-termination"-          &= help "Disable structural termination check" -          +          &= 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")@@ -180,13 +205,10 @@     = def &= help "Check GHC generated binders (e.g. Read, Show instances)"           &= name "check-derived" - , caseExpandDepth + , caseExpandDepth     = 2   &= help "Maximum depth at which to expand DEFAULT in case-of (default=2)"           &= name "max-case-expand" - , strata-    = def &= help "Enable Strata Analysis"-  , notruetypes     = def &= help "Disable Trueing Top Level Types"           &= name "no-true-types"@@ -323,37 +345,74 @@           -- PLE-OPT &= name "automatic-instances"    , proofLogicEval-    = def  +    = def         &= help "Enable Proof-by-Logical-Evaluation"         &= name "ple" +  , oldPLE+    = def+        &= help "Enable Proof-by-Logical-Evaluation"+        &= name "oldple"+   , proofLogicEvalLocal-    = def  +    = def         &= help "Enable Proof-by-Logical-Evaluation locally, per function"         &= name "ple-local" +  , extensionality+    = def+        &= help "Enable extensional interpretation of function equality"+        &= name "extensionality" -  , reflection -    = def -        &= help "Enable reflection of Haskell functions and theorem proving" +  , 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 +  , compileSpec+    = def         &= name "compile-spec"-        &= help "Only compile specifications (into .bspec file); skip verification" +        &= help "Only compile specifications (into .bspec file); skip verification"    , noCheckImports-    = def +    = def         &= name "no-check-imports"-        &= help "Do not check the transitive imports; only check the target files." +        &= help "Do not check the transitive imports; only check the target files."    , typedHoles-    = def +    = def         &= name "typed-holes"         &= help "Use (refinement) typed-holes [currently warns on '_x' variables]"-  } &= verbosity-    &= program "liquid"+  , 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"+  ,+    maxRWOrderingConstraints+    = def+        &= name "max-rw-ordering-constraints"+        &= help (   "Maximium number of symbols to compare for rewrite termination. " +                 ++ "Lower values can speedup verification, but rewriting may terminate prematurely. "+                 ++ "Leave empty to consider all symbols." )+  ,+    rwTerminationCheck+    = def+        &= name "rw-termination-check"+        &= help (   "Enable the rewrite divergence checker. " +                 ++ "Can speed up verification if rewriting terminates, but can also cause divergence."+                )+  } &= program "liquid"     &= help    "Refinement Types for Haskell"     &= summary copyright     &= details [ "LiquidHaskell is a Refinement Type based verifier for Haskell"@@ -375,10 +434,14 @@                                 }                          as   cfg    <- fixConfig cfg1+  setVerbosity (loggingVerbosity cfg)   when (json cfg) $ setVerbosity Quiet-  whenNormal $ putStrLn copyright   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@@ -462,7 +525,7 @@     msg    = case giTry of                Left _   -> " no git information"                Right gi -> gitMsg gi-    + gitMsg :: GitInfo -> String gitMsg gi = concat   [ " [", giBranch gi, "@", giHash gi@@ -519,106 +582,125 @@ parsePragma = withPragma defConfig  defConfig :: Config-defConfig = Config -  { 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 -  , rankNTypes        = False -  , noclasscheck      = False -  , gradual           = False-  , gdepth            = 1-  , ginteractive      = False-  , totalHaskell      = def -- True -  , nowarnings        = def-  , noannotations     = def-  , checkDerived      = False-  , caseExpandDepth   = 2 -  , strata            = def-  , notruetypes       = def-  , nototality        = False-  , pruneUnsorted     = def-  , exactDC           = def-  , noADT             = def-  , 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+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+  , 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+  , 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-  , proofLogicEvalLocal = False-  , reflection        = False-  , compileSpec       = False-  , noCheckImports    = False-  , typedHoles        = False+  , noslice                  = False+  , noLiftedImport           = False+  , proofLogicEval           = False+  , oldPLE                   = False+  , proofLogicEvalLocal      = False+  , reflection               = False+  , extensionality           = False+  , nopolyinfer              = False+  , compileSpec              = False+  , noCheckImports           = False+  , typedHoles               = False+  , maxMatchDepth            = 4+  , maxAppDepth              = 2+  , maxArgsDepth             = 1+  , maxRWOrderingConstraints = Nothing+  , rwTerminationCheck       = False   } ---------------------------------------------------------------------------- | Exit Function ------------------------------------------------------------------------------------------------------------------------------ --------------------------------------------------------------------------exitWithResult :: Config -> [FilePath] -> Output Doc -> IO (Output Doc)--------------------------------------------------------------------------exitWithResult cfg targets out = do-  annm <- {-# SCC "annotate" #-} annotate cfg targets out-  whenNormal $ donePhase Loud "annotate"-  -- let r = o_result out -- `addErrors` o_errors out-  consoleResult cfg out annm-  return out -- { o_result = r }+-- | Writes the annotations (i.e. the files in the \".liquid\" hidden folder) and report the result+-- of the checking using a supplied function.+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  -> liftIO $ reportResultJson annm+     | otherwise -> 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+  pure ()+  where+    tidy :: F.Tidy+    tidy = if shortErrors cfg then F.Lossy else F.Full -consoleResult :: Config -> Output a -> ACSS.AnnMap -> IO ()-consoleResult cfg-  | json cfg  = consoleResultJson cfg-  | otherwise = consoleResultFull cfg+    printHeader :: Moods -> Doc -> IO ()+    printHeader mood d = colorPhaseLn mood "" (render d) -consoleResultFull :: Config -> Output a -> t -> IO ()-consoleResultFull cfg out _ = do-   let r = o_result out-   writeCheckVars $ o_vars out-   cr <- resultWithContext r-   writeResult cfg (colorResult r) cr -consoleResultJson :: t -> t1 -> ACSS.AnnMap -> IO ()-consoleResultJson _ _ annm = do-  putStrLn "RESULT"+------------------------------------------------------------------------+exitWithResult :: Config -> [FilePath] -> Output Doc -> IO ()+------------------------------------------------------------------------+exitWithResult cfg = reportResult writeResultStdout cfg++reportResultJson :: ACSS.AnnMap -> IO ()+reportResultJson annm = do+  putStrLn "LIQUID"   B.putStrLn . encode . annErrors $ annm  resultWithContext :: F.FixResult UserError -> IO (FixResult CError)-resultWithContext (F.Unsafe es)   = F.Unsafe      <$> errorsWithContext es-resultWithContext (F.Crash  es s) = (`F.Crash` s) <$> errorsWithContext es-resultWithContext (F.Safe)        = return F.Safe +resultWithContext (F.Unsafe s es)  = F.Unsafe s    <$> errorsWithContext es+resultWithContext (F.Crash  es s)  = (`F.Crash` s) <$> errorsWithContext es+resultWithContext (F.Safe   stats) = return (F.Safe stats)  instance Show (CtxError Doc) where   show = showpp@@ -626,26 +708,47 @@ writeCheckVars :: Symbolic a => Maybe [a] -> IO () writeCheckVars Nothing     = return () writeCheckVars (Just [])   = colorPhaseLn Loud "Checked Binders: None" ""-writeCheckVars (Just ns)   = colorPhaseLn Loud "Checked Binders:" "" +writeCheckVars (Just ns)   = colorPhaseLn Loud "Checked Binders:" ""                           >> forM_ ns (putStrLn . symbolString . dropModuleNames . symbol)  type CError = CtxError Doc -writeResult :: Config -> Moods -> F.FixResult CError -> IO ()-writeResult cfg c          = mapM_ (writeDoc c) . zip [0..] . resDocs tidy-  where-    tidy                   = if shortErrors cfg then F.Lossy else F.Full-    writeDoc c (i, d)      = writeBlock c i $ lines $ render d-    writeBlock _ _ []      = return ()-    writeBlock c 0 ss      = forM_ ss (colorPhaseLn c "")-    writeBlock _  _ ss     = forM_ ("\n" : ss) putStrLn+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 $ pprint sSpan <> (text ": error: " <+> doc)) -resDocs :: F.Tidy -> F.FixResult CError -> [Doc]-resDocs _ F.Safe           = [text "RESULT: SAFE"]-resDocs k (F.Crash xs s)   = text "RESULT: ERROR"  : text s : pprManyOrdered k "" (errToFCrash <$> xs)-resDocs k (F.Unsafe xs)    = text "RESULT: UNSAFE" : pprManyOrdered k "" (nub xs)+-- | 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 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 :: CtxError a -> CtxError a errToFCrash ce = ce { ctErr    = tx $ ctErr ce}   where@@ -657,10 +760,10 @@ 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 errs        = Unsafe errs-addErrors (Unsafe xs) errs = Unsafe (xs ++ errs)-addErrors r  _             = r+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 . resDocs F.Full+  toFix = vcat . map snd . orMessages . resDocs F.Full
src/Language/Haskell/Liquid/UX/Config.hs view
@@ -10,94 +10,98 @@    , patternFlag    , higherOrderFlag    , pruneFlag-   , maxCaseExpand +   , maxCaseExpand    , exactDCFlag    , hasOpt    , totalityCheck-   , terminationCheck +   , terminationCheck    , structuralTerm    ) where  import Prelude hiding (error)-import Data.Serialize ( Serialize ) import Language.Fixpoint.Types.Config hiding (Config)--- import qualified Language.Fixpoint.Types as F import GHC.Generics import System.Console.CmdArgs  -- NOTE: adding strictness annotations breaks the help message-data Config = Config -  { 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-  , 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-  , 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. -  , strata         :: Bool       -- ^ enable strata analysis-  , 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)-  , 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 , autoInstantiate :: 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-  , proofLogicEvalLocal  :: Bool   -- ^ Enable proof-by-logical-evaluation locally, per function-  , 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"+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+  , 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)+  , 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+  , oldPLE                   :: Bool       -- ^ Enable proof-by-logical-evaluation+  , 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"+  , maxMatchDepth            :: Int+  , maxAppDepth              :: Int+  , maxArgsDepth             :: Int+  , maxRWOrderingConstraints :: Maybe Int+  , rwTerminationCheck       :: Bool   } deriving (Generic, Data, Typeable, Show, Eq) -instance Serialize SMTSolver-instance Serialize Config- allowPLE :: Config -> Bool allowPLE cfg-  =  allowGlobalPLE cfg +  =  allowGlobalPLE cfg   || allowLocalPLE cfg  allowGlobalPLE :: Config -> Bool@@ -116,19 +120,19 @@ patternFlag = not . noPatternInline . getConfig  higherOrderFlag :: (HasConfig t) => t -> Bool-higherOrderFlag x = higherorder cfg || reflection cfg -  where +higherOrderFlag x = higherorder cfg || reflection cfg+  where     cfg           = getConfig x  exactDCFlag :: (HasConfig t) => t -> Bool-exactDCFlag x = exactDC cfg || reflection cfg -  where +exactDCFlag x = exactDC cfg || reflection cfg+  where     cfg       = getConfig x  pruneFlag :: (HasConfig t) => t -> Bool pruneFlag = pruneUnsorted . getConfig -maxCaseExpand :: (HasConfig t) => t -> Int +maxCaseExpand :: (HasConfig t) => t -> Int maxCaseExpand = caseExpandDepth . getConfig  hasOpt :: (HasConfig t) => t -> (Config -> Bool) -> Bool@@ -144,8 +148,8 @@ totalityCheck' cfg = (not (nototality cfg)) || totalHaskell cfg  terminationCheck' :: Config -> Bool-terminationCheck' cfg = (totalHaskell cfg || not (notermination cfg)) +terminationCheck' cfg = (totalHaskell cfg || not (notermination cfg)) -structuralTerm :: (HasConfig a) => a -> Bool +structuralTerm :: (HasConfig a) => a -> Bool structuralTerm = not . nostructuralterm . getConfig 
src/Language/Haskell/Liquid/UX/DiffCheck.hs view
@@ -26,6 +26,8 @@     -- * CoreBinds defining given set of Var    , filterBinds+   , coreDeps+   , dependsOn    )    where @@ -46,9 +48,9 @@ import qualified Data.HashMap.Strict                    as M import qualified Data.List                              as L import           System.Directory                       (copyFile, doesFileExist)-import           Language.Fixpoint.Types                (atLoc, PPrint (..), FixResult (..), Located (..))+import           Language.Fixpoint.Types                (atLoc, FixResult (..)) import           Language.Fixpoint.Utils.Files-import           Language.Haskell.Liquid.Types          hiding (Def, LMap) -- (LocSpecType, ErrorResult, GhcSpecSig (..), GhcSpecData (..), GhcSpec (..), AnnInfo (..),  Output (..)) +import           Language.Fixpoint.Solver.Stats         as Solver import           Language.Haskell.Liquid.Misc           (ifM, mkGraph) import           Language.Haskell.Liquid.GHC.Misc -- import           Language.Haskell.Liquid.Types.Visitors@@ -58,6 +60,8 @@ import qualified Data.ByteString                        as B import qualified Data.ByteString.Lazy                   as LB                                                +import           Language.Haskell.Liquid.Types          hiding (Def, LMap)+ -------------------------------------------------------------------------------- -- | Data Types ---------------------------------------------------------------- --------------------------------------------------------------------------------@@ -65,7 +69,7 @@ -- | Main type of value returned for diff-check. data DiffCheck = DC { newBinds  :: [CoreBind]                     , oldOutput :: !(Output Doc)-                    , newSpec   :: !GhcSpec+                    , newSpec   :: !TargetSpec                     }  instance PPrint DiffCheck where@@ -104,7 +108,7 @@ --    file which correspond to top-level binders whose code has changed --    and their transitive dependencies. ---------------------------------------------------------------------------------slice :: FilePath -> [CoreBind] -> GhcSpec -> IO (Maybe DiffCheck)+slice :: FilePath -> [CoreBind] -> TargetSpec -> IO (Maybe DiffCheck) -------------------------------------------------------------------------------- slice target cbs sp = ifM (doesFileExist savedFile)                           doDiffCheck@@ -113,7 +117,7 @@     savedFile       = extFileName Saved target     doDiffCheck     = sliceSaved target savedFile cbs sp -sliceSaved :: FilePath -> FilePath -> [CoreBind] -> GhcSpec -> IO (Maybe DiffCheck)+sliceSaved :: FilePath -> FilePath -> [CoreBind] -> TargetSpec -> IO (Maybe DiffCheck) sliceSaved target savedFile coreBinds spec = do   (is, lm) <- lineDiff target savedFile   result   <- loadResult target@@ -136,7 +140,7 @@ -- | Add the specified signatures for vars-with-preserved-sigs, --   whose bodies have been pruned from [CoreBind] into the "assumes" -assumeSpec :: M.HashMap Var LocSpecType -> GhcSpec -> GhcSpec+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) @@ -154,12 +158,12 @@       | i > end d    = go (i:is) ds       | otherwise    = binder d : go (i:is) ds -sigVars :: FilePath -> [Int] -> GhcSpec -> M.HashMap Var LocSpecType+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] -> GhcSpec -> Bool+globalDiff :: FilePath -> [Int] -> TargetSpec -> Bool globalDiff srcF ls gspec = measDiff || invsDiff || dconsDiff   where     measDiff  = any (isDiff srcF ls) (snd <$> gsMeas spec)@@ -187,7 +191,7 @@  -}  ---------------------------------------------------------------------------------thin :: [CoreBind] -> GhcSpec -> [Var] -> DiffCheck+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'@@ -249,14 +253,14 @@   ---------------------------------------------------------------------------------specDefs :: FilePath -> GhcSpec -> [Def]+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 :: GhcSpec -> [(Var, LocSpecType)]+specSigs :: TargetSpec -> [(Var, LocSpecType)] specSigs sp = gsTySigs  (gsSig  sp)             ++ gsAsmSigs (gsSig  sp)             ++ gsCtors   (gsData sp)@@ -422,12 +426,12 @@                                               , Just sp' <- [adjustSrcSpan lm cm sp]]  adjustResult :: LMap -> ChkItv -> ErrorResult -> ErrorResult-adjustResult lm cm (Unsafe es)    = errorsResult Unsafe      $ adjustErrors lm cm es+adjustResult lm cm (Unsafe s es)  = errorsResult (Unsafe s)  $ adjustErrors lm cm es adjustResult lm cm (Crash es z)   = errorsResult (`Crash` z) $ adjustErrors lm cm es adjustResult _  _  r              = r  errorsResult :: ([a] -> FixResult b) -> [a] -> FixResult b-errorsResult _ []                 = Safe+errorsResult _ []                 = Safe mempty errorsResult f es                 = f es  adjustErrors :: LMap -> ChkItv -> [TError a] -> [TError a]@@ -503,6 +507,11 @@                                 <*> v .: "sourceLine"                                 <*> v .: "sourceColumn"   parseJSON _          = mempty++instance ToJSON Solver.Stats where+  toJSON = genericToJSON defaultOptions+  toEncoding = genericToEncoding defaultOptions+instance FromJSON Solver.Stats  instance ToJSON ErrorResult where   toJSON = genericToJSON defaultOptions
src/Language/Haskell/Liquid/UX/QuasiQuoter.hs view
@@ -4,13 +4,15 @@ {-# LANGUAGE TupleSections      #-} {-# LANGUAGE OverloadedStrings  #-} -module Language.Haskell.Liquid.UX.QuasiQuoter (-    -- * LiquidHaskell Specification QuasiQuoter-    lq+module Language.Haskell.Liquid.UX.QuasiQuoter +-- (+--     -- * LiquidHaskell Specification QuasiQuoter+--     lq -    -- * QuasiQuoter Annotations-  , LiquidQuote(..)-  ) where+--     -- * QuasiQuoter Annotations+--   , LiquidQuote(..)+--   ) +  where  import SrcLoc (SrcSpan) @@ -45,7 +47,8 @@   , quoteDec  = lqDec   }   where-    bad = fail "`lq` quasiquoter can only be used as a top-level declaration"+    -- 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@@ -136,8 +139,6 @@  simplifyBareType'' s(RAllP _ t) =   simplifyBareType'' s t-simplifyBareType'' s (RAllS _ t) =-  simplifyBareType'' s t simplifyBareType'' s (RAllE _ _ t) =   simplifyBareType'' s t simplifyBareType'' s (REx _ _ t) =@@ -147,7 +148,7 @@  simplifyBareType'' (tvs, cls) (RFun _ i o _)   | isClassType i = simplifyBareType'' (tvs, i : cls) o-simplifyBareType'' (tvs, cls) (RAllT tv t) =+simplifyBareType'' (tvs, cls) (RAllT tv t _) =   simplifyBareType'' (ty_var_value tv : tvs, cls) t  simplifyBareType'' (tvs, cls) t =
− src/Language/Haskell/Liquid/UX/Server.hs 
@@ -1,58 +0,0 @@-module Language.Haskell.Liquid.UX.Server (getType) where--import           Prelude hiding (error)---- import           Control.Monad ((<<))-import           Language.Haskell.Liquid.Types (Output(..))-import qualified Language.Haskell.Liquid.UX.ACSS as A-import           Text.PrettyPrint.HughesPJ    hiding (Mode)-import           Language.Fixpoint.Utils.Files-import           System.Directory-import           Data.Time.Clock (UTCTime)-import qualified Control.Exception as Ex-import           Data.Aeson-import qualified Data.ByteString.Lazy   as B---- data Time = TimeTodo deriving (Eq, Ord, Show)--getType :: IO (Output Doc) -> FilePath -> Int -> Int -> IO String-getType k srcF line col = do-  act <- action srcF-  case act of-    Reuse    -> getTypeInfo line col <$>       getAnnMap srcF-    Rebuild  -> getTypeInfo line col <$> (k >> getAnnMap srcF)-    NoSource -> return "Missing Source"------------------------------------------------------------------------------------- | How to Get Info-----------------------------------------------------------------------------------data Action = Rebuild | Reuse | NoSource--action :: FilePath -> IO Action-action srcF = timeAction <$> modificationTime srcF <*> modificationTime jsonF-  where-    jsonF   = extFileName Json srcF--timeAction :: Maybe UTCTime -> Maybe UTCTime -> Action-timeAction (Just srcT) (Just jsonT)-  | srcT < jsonT  = Reuse-timeAction (Just _) _ = Rebuild-timeAction Nothing _  = NoSource--modificationTime :: FilePath -> IO (Maybe UTCTime)-modificationTime f = (Just <$> getModificationTime f) `Ex.catch` handler-  where-    handler :: IOError -> IO (Maybe UTCTime)-    handler = const (return Nothing)------------------------------------------------------------------------------------getTypeInfo :: Int -> Int -> Maybe A.AnnMap -> String-getTypeInfo _ _ Nothing     = "ERROR: corrupt annotation info"-getTypeInfo l c (Just info) = error "TODO: getTypeInfo"--getAnnMap :: FilePath -> IO (Maybe A.AnnMap)-getAnnMap srcF = decode <$> B.readFile jsonF-  where-    jsonF      = extFileName Json srcF
src/Language/Haskell/Liquid/UX/Tidy.hs view
@@ -109,15 +109,13 @@ shortSymbol _     = id   tidyLocalRefas   :: Tidy -> SpecType -> SpecType-tidyLocalRefas k = mapReft (txStrata . txReft' k)+tidyLocalRefas k = mapReft (txReft' k)   where     txReft' Full                  = id     txReft' Lossy                 = txReft-    txStrata (MkUReft r p l)      = MkUReft r p (txStr l)     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_"]-    txStr                         = filter (not . isSVar)  tidyEqual :: SpecType -> SpecType tidyEqual = mapReft txReft@@ -162,8 +160,7 @@  tyVars :: RType c tv r -> [tv] tyVars (RAllP _ t)     = tyVars t-tyVars (RAllS _ t)     = tyVars t-tyVars (RAllT α t)     = ty_var_value α : 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'@@ -187,14 +184,13 @@ subsTyVarsAll ats = go   where     abm            = M.fromList [(a, b) | (a, _, RVar b _) <- ats]-    go (RAllT a t) = RAllT (makeRTVar $ M.lookupDefault (ty_var_value a) (ty_var_value a) abm) (go t)+    go (RAllT a t r) = RAllT (makeRTVar $ M.lookupDefault (ty_var_value a) (ty_var_value a) abm) (go t) r     go t           = subsTyVars_meet ats t   funBinds :: RType t t1 t2 -> [Symbol]-funBinds (RAllT _ t)      = funBinds t+funBinds (RAllT _ t _)    = funBinds t funBinds (RAllP _ t)      = funBinds t-funBinds (RAllS _ 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
src/Language/Haskell/Liquid/WiredIn.hs view
@@ -41,7 +41,7 @@ -- import TyCon import TysWiredIn -import Language.Haskell.Liquid.GHC.TypeRep+import Language.Haskell.Liquid.GHC.TypeRep () import CoreSyn hiding (mkTyArg)  -- | Horrible hack to support hardwired symbols like@@ -64,7 +64,7 @@ isWiredInName x = x `S.member` wiredInNames  wiredInNames :: S.HashSet F.Symbol-wiredInNames = S.fromList [ "head", "tail", "fst", "snd", "len" ]+wiredInNames = S.fromList [ "head", "tail", "fst", "snd", "len"]  isWiredInShape :: F.LocSymbol -> Bool isWiredInShape x = any (`F.isPrefixOfSym` (val x)) [F.anfPrefix, F.tempPrefix, dcPrefix]@@ -82,13 +82,13 @@ --------------------------------------------------------------------------------  dictionaryVar :: Var-dictionaryVar   = stringVar "tmp_dictionary_var" (ForAllTy (TvBndr dictionaryTyVar Required) $ TyVarTy dictionaryTyVar)+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 $ TyVarTy a))]+dictionaryBind = Rec [(v, Lam a $ App (Var v) (Type $ Ghc.TyVarTy a))]   where    v = dictionaryVar    a = dictionaryTyVar@@ -123,9 +123,9 @@     (tcs, dcs)  = unzip $ listTyDataCons : map tupleTyDataCons [2..maxArity]  listTyDataCons :: ([TyConP] , [DataConP])-listTyDataCons   = ( [(TyConP l0 c [RTV tyv] [p] [] [Covariant] [Covariant] (Just fsize))]-                   , [(DataConP l0 nilDataCon  [RTV tyv] [p] [] [] []    lt False wiredInName l0)-                     ,(DataConP l0 consDataCon [RTV tyv] [p] [] [] cargs lt False wiredInName l0)])+listTyDataCons   = ( [(TyConP l0 c [RTV tyv] [p] [Covariant] [Covariant] (Just fsize))]+                   , [(DataConP l0 nilDataCon  [RTV tyv] [p] [] []    lt False wiredInName l0)+                     ,(DataConP l0 consDataCon [RTV tyv] [p] [] cargs lt False wiredInName l0)])     where       l0         = F.dummyPos "LH.Bare.listTyDataCons"       c          = listTyCon@@ -146,8 +146,8 @@ 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)])+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
− src/Liquid.hs 
@@ -1,6 +0,0 @@-import Language.Haskell.Liquid.Liquid (liquid)-import System.Environment             (getArgs)--- import GhcTest --main :: IO a-main = liquid =<< getArgs
src/LiquidHaskell.hs view
@@ -1,7 +1,20 @@+{-# LANGUAGE CPP #-}+ module LiquidHaskell (     -- * LiquidHaskell Specification QuasiQuoter     lq+#ifdef MIN_VERSION_GLASGOW_HASKELL+#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)+    -- * LiquidHaskell as a compiler plugin+  , plugin+#endif+#endif   ) where  import Language.Haskell.Liquid.UX.QuasiQuoter +#ifdef MIN_VERSION_GLASGOW_HASKELL+#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)+import Language.Haskell.Liquid.GHC.Plugin (plugin)+#endif+#endif
− src/Target.hs 
@@ -1,29 +0,0 @@-{-# LANGUAGE LambdaCase #-}--- module Main where--import Language.Haskell.Interpreter-import System.Environment-import System.Exit-import System.IO-import Test.Target-import Text.Printf--main :: IO ()-main = do-  [src, binder] <- getArgs-  r <- runInterpreter $ do-    loadModules [src]-    mods <- getLoadedModules-    -- liftIO $ print mods-    setImportsQ $ map (\m -> (m,Nothing)) mods-                             ++ [("Test.Target", Nothing), ("Prelude", Nothing)]-    set [languageExtensions := [TemplateHaskell]]-    let expr = printf "$(targetResultTH '%s \"%s\")" binder src-    -- liftIO $ putStrLn expr-    interpret expr (as :: IO Result)-  case r of-    Left e -> hPrint stderr e >> exitWith (ExitFailure 2)-    Right x -> x >>= \case-      Errored e -> hPutStrLn stderr e >> exitWith (ExitFailure 2)-      Failed s  -> printf "Found counter-example: %s\n" s >> exitWith (ExitFailure 1)-      Passed n  -> printf "OK! Passed %d tests.\n" n >> exitSuccess
− stack.yaml 
@@ -1,24 +0,0 @@-resolver: lts-13.20--packages:-- liquid-fixpoint-- '.'--extra-deps:-- csv-table-0.1.0.1-- dotgen-0.4.2-- fgl-visualize-0.1.0.1-- intern-0.9.2-- located-base-0.1.1.1-- text-format-0.3.2-- tasty-rerun-1.1.14--flags:-  liquidhaskell:-    devel: true--extra-package-dbs: []--ghc-options:-  hscolour: -w -
− syntax/.DS_Store 
binary file changed (6148 → absent bytes)
− syntax/._.DS_Store 
binary file changed (120 → absent bytes)
− syntax/hsannot.css 
@@ -1,51 +0,0 @@--.hs-keyglyph, .hs-layout {color: red;}-.hs-keyword {color: blue;}-.hs-comment, .hs-comment a {color: green;}-.hs-str, .hs-chr {color: teal;}-.hs-keyword,.hs-conid, .hs-varid, .hs-conop, .hs-varop, .hs-num, .hs-cpp, .hs-sel, .hs-definition {}--/*-a.annot{-    position:relative; -    color:#000;-    text-decoration:none-  }--a.annot:hover{z-index:25; background-color:#ff0}--a.annot span{display: none}--a.annot:hover span{ -    display:block;-    position:absolute;-    top:2em; -    left:2em; -    border:5px solid #b4eeb4; -    background-color: #b4eeb4;-    color:#000;-    text-align: left -  }-*/--.annot{-    position:relative; -    color:#000;-    text-decoration:none-  }--.annot:hover{z-index:25; background-color:#ff0}--.anntitle {display: none}--.annot:hover span{ /*the span will display just on :hover state*/-    display:block;-    position:absolute;-    top:2em; -    left:2em; -    border:5px solid #b4eeb4; -    background-color: #b4eeb4;-    color:#000;-    text-align: left -  }-
− syntax/hscolour.css 
@@ -1,46 +0,0 @@-.hs-keyglyph, .hs-layout {color: red;}-.hs-keyword {color: blue;}-.hs-comment, .hs-comment a {color: green;}-.hs-str, .hs-chr {color: teal;}-.hs-keyword,.hs-conid, .hs-varid, .hs-conop, .hs-varop, .hs-num, .hs-cpp, .hs-sel, .hs-definition {}--a.annot{-    position:relative; -    color:#000;-    text-decoration:none-  }--a.annot:hover{z-index:25; background-color:#ff0}--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); --  display:block;-  position: absolute; -  left: 1em; top: 2em; -  z-index: 99;-  margin-left: 5; -  background: #FFFFAA; -  border: 2px solid #FFAD33;-  padding: 0.8em 1em;-}--/* -.classic { padding: 0.8em 1em; }-.custom { padding: 0.5em 0.8em 0.8em 2em; }-* html a:hover { background: transparent; }-.classic {background: #FFFFAA; border: 1px solid #FFAD33; }-.critical { background: #FFCCAA; border: 1px solid #FF3334;	}-.help { background: #9FDAEE; border: 1px solid #2BB0D7;	}-.info { background: #9FDAEE; border: 1px solid #2BB0D7;	}-.warning { background: #FFFFAA; border: 1px solid #FFAD33; }-*/
− syntax/liquidBody.css 
@@ -1,145 +0,0 @@-html {-    font-family: "helvetica";-}--code {-   /* font-weight: bold; */-   background-color: rgb(250, 250, 250); -   border: 1px solid rgb(200, 200, 200);-   padding-left: 4px;-   padding-right: 4px;-}--/* pygments */--pre {-	background-color: #f0f0f0;-	border-top: 1px solid #ccc;-	border-bottom: 1px solid #ccc;-	padding: 5px;-	font-size: 13px;-	font-family: Bitstream Vera Sans Mono,monospace;-}--/********************** Links **************************************/--a:hover { -  color: black; /* #1d4c77; */-  /* text-decoration:underline */-}---/********************** General Divs ********************************/--div#navigation {-    text-align: center;-    border-bottom: 4px solid black;-}--div#navigation a {-    color: white;-    text-decoration: none;-    background-color: black;-    padding: 3px 10px 3px 10px;-    margin: 0px 10px 0px 10px;-}--body {-    width: 700px;-    /* width: 900px; */-    margin: 0px auto 0px auto;-}--div#header {-    height: 32px;-    padding: 20px 0px 20px 60px;-}--div#header img {-    display: inline;-    vertical-align: middle;-}--div#header h1 {-    padding-left: 10px;-    display: inline;-    text-transform: uppercase;-    vertical-align: middle;-}--div#main {-    margin: 0px auto 0px auto;-    width: 760px;-}--div#sidebar {-    margin-right: 30px;-    width: 160px;-    float: left;-    text-align: right;-}--div#sidebar a {-    display: block;-    font-size: 110%;-    text-decoration: none;-    margin-bottom: 10px;-    text-transform: uppercase;-}--div#content {-    width: 570px;-    float: right;-}--div#footer {-    padding-top: 30px;-    clear: both;-    font-size: 90%;-    text-align: center;-}---h2 {-    font-size: 120%;-    text-transform: uppercase;-}--h3 {-    font-size: 100%;-    text-transform: uppercase;-}--div.column {-    width: 50%;-    float: left;-}--div.column p {-    padding-right: 15px;-}--img {-    display: block;-    margin: 10px auto 10px auto;-    border: none;-}--ul {-    list-style-type: square;-    padding-left: 1em;-    margin-left: 1em;-}----p.caption {-    display: none;-}--img {-  border:0px;-  margin-left:auto;-  margin-right:auto;-  display:block-}
− syntax/liquid_dark_blog.css 
@@ -1,101 +0,0 @@-.hs-linenum {-  color: #666666; //CCCCCC;-  font-style: italic;-}--.hs-error {-  background-color: #B80000 ;-}--.hs-keyglyph, .hs-layout { /* color: red; */ -  color: white;-}--.hs-keyword {-  color: #75D075 ; -  //font-weight: bold;-}--.hs-comment, .hs-comment a {color: green;}--.hs-str, .hs-chr {color: #7FFFD4;}--.hs-conid { -  color: #00FFFF; -  //font-weight: bold; -}--.hs-definition { -  color: #FFFFFF;   /* #ADFF2F; */-  // font-weight: bold; -}--.hs-varid, .hs-varop {-  color: white; /* #BDDEFF; */-}--.hs-num, .hs-conop {-  color: aquamarine;-}--.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:#585858;-//   /* background-color:#ff0  */-// }--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: 9999;-  margin-left: 5; -  padding: 0.8em 1em;-  border: 3px solid #6495ED ; // #5F9EA0; #FFAD33;-  background: #EBF5FF; // #C3F6FA  #F7F8FD  #C1CDCD #FFFFAA; -}--code {-   /* font-weight: bold; */-   background-color: rgb(250, 250, 250); -   border: 1px solid rgb(200, 200, 200);-   padding-left: 4px;-   padding-right: 4px;-}--pre {-  border-radius: 5px 5px;-  // font-family: Bitstream Vera Sans Mono,monospace;-  font-size: 100%;-  // color: rgb(255, 255, 255);-  // background-color: rgb(0, 0, 0);-  // margin-bottom: 2em;-  padding: 8px;-  display: block;-  overflow: visible; -}-
− syntax/liquid_light_blog.css 
@@ -1,106 +0,0 @@-.hs-linenum {-  color: #CCCCCC;-  font-style: italic;-}---.hs-error {-  background-color: #FF8585 ;-}--.hs-keyglyph {-  color: #007020-}--.hs-keyword {-  color: #007020;-  // font-weight: bold;-}--.hs-comment, .hs-comment a {color: green;}--.hs-str, .hs-chr {color: teal;}--.hs-conid { -  color: #902000;   /* color: #00FFFF; color: #0E84B5; */-  //font-weight: bold;  -}--.hs-definition { -  color: #06287E -  /* font-weight: bold; */ -}--.hs-varid, .hs-varop, .hs-layout {-  color: black; -}--.hs-num {-  color: #40A070;-}--.hs-conop {-  color: #902000; -}--.hs-cpp {-  color: orange;-}--.hs-sel  {}--a.annot {-  position:relative; -  color:#000;-  text-decoration:none; -  white-space: pre; -}--a.annot:hover { -  z-index:25; -  background-color: #D8D8D8;-}--a.annot span.annottext{display: none}--a.annot:hover span.annottext{ -  -  border-radius: 5px 5px;-  -  -moz-border-radius: 5px; -  -webkit-border-radius: 5px; -  -  box-shadow: 5px 5px 5px rgba(0, 0, 0, 0.1); -  -webkit-box-shadow: 5px 5px rgba(0, 0, 0, 0.1);-  -moz-box-shadow: 5px 5px rgba(0, 0, 0, 0.1); --  white-space:pre;-  display:block;-  position: absolute; -  left: 1em; top: 2em; -  z-index: 99;-  margin-left: 5; -  background: #FFFFAA; -  border: 3px solid #FFAD33;-  padding: 0.8em 1em;-}--code {-   /* font-weight: bold; */-   background-color: rgb(250, 250, 250); -   border: 1px solid rgb(200, 200, 200);-   padding-left: 4px;-   padding-right: 4px;-}--pre {-  background-color: #f0f0f0;-  border-top: 1px solid #ccc;-  border-bottom: 1px solid #ccc;-  padding: 5px;-  font-size: 120%;-  // font-family: Bitstream Vera Sans Mono,monospace;-  display: block;-  overflow: visible;-}-
− tests/.DS_Store 
binary file changed (6148 → absent bytes)
− tests/._.DS_Store 
binary file changed (120 → absent bytes)
+ tests/Parser.hs view
@@ -0,0 +1,529 @@+{-# 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           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           Text.Parsec.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 =  defaultMainWithIngredients (+                antXMLRunner:defaultIngredients+              ) tests++tests :: TestTree+tests =+  testGroup "ParserTests"+    [ testSucceeds+    , testSpecP+    , testReservedAliases+    , testFails+    , testErrorReporting+    ]++-- ---------------------------------------------------------------------++-- Test that the top level production works, each of the sub-elements will be tested separately+testSpecP :: TestTree+testSpecP =+  testGroup "specP"+    [ testCase "assume" $+       parseSingleSpec "assume foo :: a -> a " @?==+          "assume foo :: lq_tmp$db##0:a -> a"++    , testCase "assert" $+       parseSingleSpec "assert myabs :: Int -> PosInt" @?==+          "assert myabs :: lq_tmp$db##0:Int -> PosInt"++    , testCase "autosize" $+       parseSingleSpec "autosize List" @?==+            "autosize List"++    , testCase "local" $+       parseSingleSpec "local foo :: Nat -> Nat" @?==+            "local assert foo :: lq_tmp$db##0:Nat -> Nat"++    , testCase "axiomatize" $+       parseSingleSpec "axiomatize fibA" @?==+            "reflect fibA"++    , testCase "reflect" $+       parseSingleSpec "reflect map" @?==+            "reflect map"++    , testCase "measure HMeas" $+       parseSingleSpec "measure isAbs" @?==+          "measure isAbs"++    , testCase "measure Meas" $+       parseSingleSpec "measure fv :: Expr -> (Set Bndr)" @?==+          "measure fv :: lq_tmp$db##0:Expr -> (Set Bndr)"++    , testCase "define" $+       parseSingleSpec "define $ceq = eqN" @?==+          "define $ceq = eqN"++    , testCase "infixl" $+       parseSingleSpec "infixl 9 +++" @?==+            "fixity"++    , testCase "infixr" $+       parseSingleSpec "infixr 9 +++" @?==+            "fixity"++    , testCase "infix" $+       parseSingleSpec "infix 9 +++" @?==+            "fixity"++    , testCase "inline" $+       parseSingleSpec "inline eqelems" @?==+            "inline eqelems"++    , testCase "bound PBound" $+       parseSingleSpec "bound Foo = true" @?==+          "bound Foo forall [] . [] =  true"++    , testCase "bound HBound" $+       parseSingleSpec "bound step" @?==+            "bound step"++    , testCase "class measure" $+       parseSingleSpec "class measure sz :: forall a. a -> Int" @?==+            "class measure sz :: forall a . lq_tmp$db##0:a -> Int"++    , testCase "instance measure" $+       parseSingleSpec "instance measure sz :: MList a -> Int" @?==+            "instance  measure sz :: lq_tmp$db##0:(MList a) -> Int"++    , testCase "instance" $+       parseSingleSpec "instance VerifiedNum Int where\n  - :: x:Int -> y:Int -> OkInt {x - y} " @?==+          "instance (VerifiedNum Int) where\n    - :: x:Int -> y:Int -> (OkInt {x - y})"++    , testCase "class" $+       parseSingleSpec "class Sized s where\n  size :: forall a. x:s a -> {v:Nat | v = sz x}" @?==+            "class  (Sized s) where\n    size :: forall a . x:s a -> {v : Nat | v == sz x}"++    , testCase "import" $+       parseSingleSpec "import Foo" @?==+          "import Foo"++    , testCase "data variance" $+       parseSingleSpec "data variance IO bivariant" @?==+          "data variance IO Bivariant"++    , testCase "data" $+       parseSingleSpec "data Bob = B {foo :: Int}" @?==+          "data Bob  [] =\n    | B :: forall . foo : Int -> *"++    , testCase "newtype" $+       parseSingleSpec "newtype Foo = Bar {x :: Nat}" @?==+          "newtype data Foo  [] =\n            | Bar :: forall . x : Nat -> *"++    , testCase "include" $+       parseSingleSpec "include <listSet.hquals>" @?==+            "include <listSet.hquals>"++    , testCase "invariant" $+       parseSingleSpec "invariant {v:Tree a | 0 <= ht v}" @?==+            "invariant {v : (Tree a) | 0 <= ht v}"++    , testCase "using" $+       parseSingleSpec "using (Tree a) as  {v:Tree a   | 0 <= height v}" @?==+            "using (Tree a) as {v : (Tree a) | 0 <= height v}"++    , testCase "type" $+       parseSingleSpec "type PosInt = {v: Int | v >= 0}" @?==+            "type PosInt  =  {v : Int | v >= 0}"++    , testCase "predicate" $+       parseSingleSpec "predicate Pos X  = X > 0" @?==+            "predicate Pos X  =  X > 0"++    , testCase "expression" $+       parseSingleSpec "expression Avg Xs = ((sumD Xs) / (lenD Xs))" @?==+          "predicate Avg Xs  =  sumD Xs / lenD Xs"++    , testCase "embed" $+       parseSingleSpec "embed Set as Set_Set" @?==+          "embed Set as Set_Set"++    , testCase "qualif" $+       parseSingleSpec "qualif Foo(v:Int): v < 0" @?==+          "qualif Foo defined at \"<test>\" (line 1, column 8)"++    , testCase "decrease" $+       parseSingleSpec "decrease insert 3" @?==+          "decreasing insert [2]"++    , testCase "lazyvar" $+       parseSingleSpec "lazyvar z" @?==+          "lazyvar z"++    , testCase "lazy" $+       parseSingleSpec "lazy eval" @?==+          "lazy eval"++    , testCase "default parser (Asrts)" $+       parseSingleSpec " assumeIndices :: t:ByteStringNE -> s:BS.ByteString -> [OkPos t s]" @?==+            "assumeIndices :: t:ByteStringNE -> s:BS.ByteString -> [(OkPos t s)]"+    ]++-- ---------------------------------------------------------------------++-- Test that haskell functions having the same name as liquidhaskell keywords are parsed correctly+testReservedAliases :: TestTree+testReservedAliases =+  testGroup "reserved aliases"+    [ testCase "assume" $+       parseSingleSpec "assume :: Int -> Bool " @?==+            "assume :: lq_tmp$db##0:Int -> Bool"++    , testCase "assert" $+       parseSingleSpec "assert :: Int -> Bool " @?==+            "assert :: lq_tmp$db##0:Int -> Bool"++    , testCase "autosize" $+       parseSingleSpec "autosize :: Int -> Bool " @?==+            "autosize :: lq_tmp$db##0:Int -> Bool"++    , testCase "axiomatize" $+       parseSingleSpec "axiomatize :: Int -> Bool " @?==+            "axiomatize :: lq_tmp$db##0:Int -> Bool"++    , testCase "reflect" $+       parseSingleSpec "reflect :: Int -> Bool " @?==+            "reflect :: lq_tmp$db##0:Int -> Bool"++    , testCase "measure" $+       parseSingleSpec "measure :: Int -> Bool " @?==+            "measure :: lq_tmp$db##0:Int -> Bool"++    , testCase "define 1" $+       parseSingleSpec "define :: Int -> Bool " @?==+            "define :: lq_tmp$db##0:Int -> Bool"++    , testCase "define 2" $+       parseSingleSpec "define GHC.Types.True = (true)" @?==+            "define GHC.Types.True = (true)"++    , testCase "defined" $+       parseSingleSpec "defined :: Int -> Bool " @?==+            "defined :: lq_tmp$db##0:Int -> Bool"++    , testCase "inline" $+       parseSingleSpec "inline :: Int -> Bool " @?==+            "inline :: lq_tmp$db##0:Int -> Bool"++    , testCase "bound" $+       parseSingleSpec "bound :: Int -> Bool " @?==+            "bound :: lq_tmp$db##0:Int -> Bool"++    , testCase "invariant" $+       parseSingleSpec "invariant :: Int -> Bool " @?==+            "invariant :: lq_tmp$db##0:Int -> Bool"++    , testCase "predicate" $+       parseSingleSpec "predicate :: Int -> Bool " @?==+            "predicate :: lq_tmp$db##0:Int -> Bool"++    , testCase "expression" $+       parseSingleSpec "expression :: Int -> Bool " @?==+            "expression :: lq_tmp$db##0:Int -> Bool"++    , testCase "embed" $+       parseSingleSpec "embed :: Int -> Bool " @?==+            "embed :: lq_tmp$db##0:Int -> Bool"++    , testCase "qualif" $+       parseSingleSpec "qualif :: Int -> Bool " @?==+            "qualif :: lq_tmp$db##0:Int -> Bool"+    ]++-- ---------------------------------------------------------------------++testSucceeds :: TestTree+testSucceeds =+  testGroup "Should succeed"+    [ testCase "x :: Int" $+       (parseSingleSpec "x :: Int") @?==+          "x :: Int" ++    , testCase "x :: a" $+       (parseSingleSpec "x :: a") @?==+          "x :: a" ++    , testCase "x :: a -> a" $+       (parseSingleSpec "x :: a -> a") @?==+          "x :: lq_tmp$db##0:a -> a"++    , testCase "x :: Int -> Int" $+       (parseSingleSpec "x :: Int -> Int") @?==+          "x :: lq_tmp$db##0:Int -> Int"++    , testCase "k:Int -> Int" $+       (parseSingleSpec "x :: k:Int -> Int") @?==+          "x :: k:Int -> Int"++    , testCase "type spec 1 " $+       parseSingleSpec "type IncrListD a D = [a]<{\\x y -> (x+D) <= y}>" @?==+          "type IncrListD a D  =  [a]<\\x##2 VV -> {y##3 : LIQUID$dummy | x##2 + D <= y##3}>"++    , testCase "type spec 2 " $+       parseSingleSpec "takeL :: Ord a => x:a -> [a] -> [{v:a|v<=x}]" @?==+          "takeL :: (Ord a) -> x:a -> lq_tmp$db##1:[a] -> [{v : a | v <= x}]"++    , testCase "type spec 3" $+       parseSingleSpec "bar :: t 'Nothing" @?==+          "bar :: t Nothing"++    , testCase "type spec 4" $+       parseSingleSpec "mapKeysWith :: (Ord k2) => (a -> a -> a) -> (k1->k2) -> OMap k1 a -> OMap k2 a" @?==+          "mapKeysWith :: (Ord k2) -> lq_tmp$db##2:(lq_tmp$db##3:a -> lq_tmp$db##4:a -> a) -> lq_tmp$db##6:(lq_tmp$db##7:k1 -> k2) -> lq_tmp$db##9:(OMap k1 a) -> (OMap k2 a)"++    , testCase "type spec 5 " $+       parseSingleSpec (unlines $+         [ "data Tree [ht] a = Nil"+         , "            | Tree { key :: a"+         , "                   , l   :: Tree {v:a | v < key }"+         , "                   , r   :: Tree {v:a | key < v }"+         , "                   }" ])+        @?==+    --      "data Tree [ht] [a] =\n    | Tree :: forall a . key : a ->l : (Tree {v : a | v < key}) ->r : (Tree {v : a | key < v}) -> *\n    | Nil :: forall a . -> *"+          "data Tree [ht] [a] = \ +           \     | Nil :: forall a . -> * \+           \     | Tree :: forall a . key : a ->l : (Tree {v : a | v < key}) ->r : (Tree {v : a | key < v}) -> *"    ++    , testCase "type spec 6" $+       parseSingleSpec "type AVLL a X    = AVLTree {v:a | v < X}" @?==+         "type AVLL a X  =  (AVLTree {v : a | v < X})"++    , testCase "type spec 7" $+       parseSingleSpec "type AVLR a X    = AVLTree {v:a |X< v} " @?==+         "type AVLR a X  =  (AVLTree {v : a | X < v})"++    , testCase "type spec 8 " $+       parseSingleSpec (unlines $+      [ "assume (++) :: forall <p :: a -> Bool, q :: a -> Bool, r :: a -> Bool>."+      , "  {x::a<p> |- a<q> <: {v:a| x <= v}} "+      , "  {a<p> <: a<r>} "+      , "  {a<q> <: a<r>} "+      , "  Ord a => OList (a<p>) -> OList (a<q>) -> OList a<r> "])+        @?==+          "assume (++) :: forall <p :: a -> Bool, q :: a -> Bool, r :: a -> Bool> .\n               (Ord a) =>\n               {x :: {VV : a<p> | true} |- {VV : a<q> | true} <: {v : a | x <= v}} =>\n               {|- {VV : a<p> | true} <: {VV : a<r> | true}} =>\n               {|- {VV : a<q> | true} <: {VV : a<r> | true}} =>\n               lq_tmp$db##13:(OList {VV : a<p> | true}) -> lq_tmp$db##15:(OList {VV : a<q> | true}) -> (OList {VV : a<r> | true})"++    , testCase "type spec 9" $+       parseSingleSpec (unlines $+          [ "data AstF f <ix :: AstIndex -> Bool>"+          , "  = Lit Int    (i :: AstIndex<ix>)"+          , "  | Var String (i :: AstIndex<ix>)"+          , "  | App (fn :: f) (arg :: f)"+          , "  | Paren (ast :: f)" ])+          @?==+            "data AstF [f] =    \+            \   | App :: forall f . fn : f ->arg : f -> * \+            \   | Lit :: forall f . lq_tmp$db##2 : (Int (AstIndex <{VV : _<ix> | true}>)) -> *  \+            \   | Paren :: forall f . ast : f -> * \+            \   | Var :: forall f . lq_tmp$db##5 : (String (AstIndex <{VV : _<ix> | true}>)) -> *"++    , testCase "type spec 10" $+       parseSingleSpec "assume     :: b:_ -> a -> {v:a | b} " @?==+          "assume :: b:{VV : _ | $HOLE} -> lq_tmp$db##0:a -> {v : a | b}"++    , testCase "type spec 11" $+       parseSingleSpec (unlines $+          [ "app :: forall <p :: Int -> Bool, q :: Int -> Bool>. "+          , "       {Int<q> <: Int<p>}"+          , "       {x::Int<q> |- {v:Int| v = x + 1} <: Int<q>}"+          , "       (Int<p> -> ()) -> x:Int<q> -> ()" ])+          @?==+            "app :: forall <p :: Int -> Bool, q :: Int -> Bool> .\n       {|- (Int <{VV : _<q> | true}>) <: (Int <{VV : _<p> | true}>)} =>\n       {x :: (Int <{VV : _<q> | true}>) |- {v : Int | v == x + 1} <: (Int <{VV : _<q> | true}>)} =>\n       lq_tmp$db##8:(lq_tmp$db##9:(Int <{VV : _<p> | true}>) -> ()) -> x:(Int <{VV : _<q> | true}>) -> ()"++    , testCase "type spec 12" $+       parseSingleSpec (unlines $+          [ " ssum :: forall<p :: a -> Bool, q :: a -> Bool>. "+          , "         {{v:a | v == 0} <: a<q>}"+          , "         {x::a<p> |- {v:a | x <= v} <: a<q>}"+          , "         xs:[{v:a<p> | 0 <= v}] -> {v:a<q> | len xs >= 0 && 0 <= v } "])+          @?==+            "ssum :: forall <p :: a -> Bool, q :: a -> Bool> .\n        {|- {v : a | v == 0} <: {VV : a<q> | true}} =>\n        {x :: {VV : a<p> | true} |- {v : a | x <= v} <: {VV : a<q> | true}} =>\n        xs:[{v : a<p> | 0 <= v}] -> {v : a<q> | len xs >= 0\n                                                && 0 <= v}"++    , testCase "type spec 13" $+       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)) "])+          @?==+          "predicate ValidChunk V  XS  N  =  (len XS == 0 => len V == 0)\n                                  && (not (len XS == 0) => (1 < len XS\n                                                            && 1 < N => len V < len XS)\n                                                           && (len XS <= N => len V == 1))"+++    , testCase "type spec 14" $+       parseSingleSpec "assume (=*=.) :: Arg a => f:(a -> b) -> g:(a -> b) -> (r:a -> {f r == g r}) -> {v:(a -> b) | f == g}" @?==+            "assume (=*=.) :: (Arg a) -> f:(lq_tmp$db##1:a -> b) -> g:(lq_tmp$db##3:a -> b) -> lq_tmp$db##5:(r:a -> {VV : _ | f r == g r}) -> lq_tmp$db##6:a -> b"++    , testCase "type spec 15" $+       parseSingleSpec "sort :: (Ord a) => xs:[a] -> OListN a {len xs}" @?==+           "sort :: (Ord a) -> xs:[a] -> (OListN a {len xs})"++    , testCase "type spec 16" $+       parseSingleSpec " ==. :: x:a -> y:{a| x == y} -> {v:b | v ~~ x && v ~~ y } " @?==+            "==. :: x:a -> y:{y : a | x == y} -> {v : b | v ~~ x\n                                             && v ~~ y}"++    , testCase "type spec 17" $+       parseSingleSpec "measure snd :: (a,b) -> b" @?==+            "measure snd :: lq_tmp$db##0:(a, b) -> b"++    , testCase "type spec 18" $+       parseSingleSpec "returnST :: xState:a \n             -> ST <{\\xs xa v -> (xa = xState)}> a s " @?==+           "returnST :: xState:a -> (ST <\\xs##1 xa##2 VV -> {v##3 : LIQUID$dummy | xa##2 == xState}> a s)"++    , testCase "type spec 19" $+       parseSingleSpec "makeq :: l:_ -> r:{ _ | size r <= size l + 1} -> _ " @?==+           "makeq :: l:{VV : _ | $HOLE} -> r:{r : _ | size r <= size l + 1} -> {VV : _ | $HOLE}"++    , testCase "type spec 21" $+       parseSingleSpec "newRGRef :: forall <p :: a -> Bool, r :: a -> a -> Bool >.\n   e:a<p> ->\n  e2:a<r e> ->\n  f:(x:a<p> -> y:a<r x> -> {v:a<p> | (v = y)}) ->\n IO (RGRef <p, r> a)" @?==+            "newRGRef :: forall <p :: a -> Bool, r :: a a -> Bool> .\n            e:{VV : a<p> | true} -> e2:{VV : a<r e> | true} -> f:(x:{VV : a<p> | true} -> y:{VV : a<r x> | true} -> {v : a<p> | v == y}) -> (IO (RGRef <{VV : _<p> | true}, {VV : _<r> | true}> a))"++    , testCase "type spec 21" $+       parseSingleSpec "cycle        :: {v: [a] | len(v) > 0 } -> [a]" @?==+            "cycle :: v:{v : [a] | len v > 0} -> [a]"++    , testCase "type spec 22" $+       parseSingleSpec "cons :: x:a -> _ -> {v:[a] | hd v = x} " @?==+         "cons :: x:a -> lq_tmp$db##0:{VV : _ | $HOLE} -> {v : [a] | hd v == x}"++    , testCase "type spec 23" $+       parseSingleSpec "set :: a:Vector a -> i:Idx a -> a -> {v:Vector a | vlen v = vlen a}" @?==+         "set :: a:(Vector a) -> i:(Idx a) -> lq_tmp$db##0:a -> {v : (Vector a) | vlen v == vlen a}"++    , testCase "type spec 24" $+       parseSingleSpec "assume GHC.Prim.+#  :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v: GHC.Prim.Int# | v = x + y}" @?==+         "assume GHC.Prim.+# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v : GHC.Prim.Int# | v == x + y}"++    , testCase "type spec 25" $+       parseSingleSpec " measure isEVar " @?==+         "measure isEVar"++    , testCase "type spec 26" $+       parseSingleSpec (unlines $+         [ "data List a where"+         , "    Nil  :: List a "+         , "  | Cons :: listHead:a -> listTail:List a -> List a  "])+        @?==+            "data List  [a] =\n    | Cons :: forall a . listHead : a ->listTail : (List a) -> (List a)\n    | Nil :: forall a . -> (List a)"++    , testCase "type spec 27" $+       parseSingleSpec (unlines $+         [ "data List2 a b <p :: a -> Bool> where"+         , "    Nil2  :: List2 a "+         , "  | Cons2 :: listHead:a -> listTail:List a -> List2 a b"])+        @?== +           "data List2  [a, b] = \ +            \  | Cons2 :: forall a b . listHead : a ->listTail : (List a) -> (List2 a b) \+            \  | Nil2 :: forall a b . -> (List2 a)"++    , testCase "type spec 28" $+       parseSingleSpec (unlines $+         [ "data Ev :: Peano -> Prop where"+         , "  EZ  :: Prop (Ev Z)"+         , "| ESS :: n:Peano -> Prop (Ev n) -> Prop (Ev (S (S n)))"+         ])+        @?==+            "data Ev  [] =\n    | ESS :: forall . n : Peano ->lq_tmp$db##4 : (Prop (Ev n)) -> (Prop (Ev (S (S n))))\n    | EZ :: forall . -> (Prop (Ev Z))"++    , testCase "type spec 29" $+       parseSingleSpec (unlines $+         [ "measure fst :: (a,b) -> a"+         , "fst (a,b) = a"+         ])+        @?==+            "measure fst :: lq_tmp$db##0:(a, b) -> a\n        fst ((,)a b) = a"+    ]++-- ---------------------------------------------------------------------++testFails :: TestTree+testFails =+  testGroup "Does fail"+    [ testCase "Maybe k:Int -> Int" $+          parseSingleSpec "x :: Maybe k:Int -> Int" @?==+            "Cannot parse specification:\n    unexpected ':'\n    expecting monoPredicateP, bareTyArgP, mmonoPredicateP, white space, \"->\", \"~>\", \"=>\", \"/\" or end of input"+    ]+++-- ---------------------------------------------------------------------++testErrorReporting :: TestTree+testErrorReporting =+  testGroup "Error reporting"+    [ testCase "assume mallocForeignPtrBytes :: n:Nat -> IO (ForeignPtrN a n " $+          parseSingleSpec "assume mallocForeignPtrBytes :: n:Nat -> IO (ForeignPtrN a n " @?==+            "Cannot parse specification:\n    unexpected end of input\n    expecting bareTyArgP"++    , testCase "Missing |" $+          parseSingleSpec "ff :: {v:Nat  v >= 0 }" @?==+          -- parseSingleSpec "ff :: {v :  }" @?==+            "Cannot parse specification:\n    unexpected \":\"\n    expecting operator, white space or \"}\""+    ]++-- ---------------------------------------------------------------------++-- | Parse a single type signature containing LH refinements. To be+-- used in the REPL.+parseSingleSpec :: String -> String+parseSingleSpec src = deSpace $ +  case LH.singleSpecP (initialPos "<test>") src of+    Left err  -> show 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)++(@?==) :: String -> String -> Assertion +s1 @?== s2 = (deSpace s1) @?= (deSpace s2)++------------------------------------------------------------------------++dummyLocs :: (Data a) => a -> a+dummyLocs = everywhere (mkT posToDummy)+  where+    posToDummy :: SourcePos -> SourcePos+    posToDummy _ = dummyPos "Fixpoint.Types.dummyLoc"++-- ---------------------------------------------------------------------
+ tests/Synthesis.hs view
@@ -0,0 +1,149 @@+{-# 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 bin    = "stack exec -- liquid " +        inFile = synthesisTestsDir </> tgt+        log    = logDir </> (dropExtension tgt <.> ".log")+    withFile log WriteMode $ \h -> do+        (_, _, _, ph) <- createProcess $ (shell (bin ++ inFile)) { std_out = UseHandle h, std_err = UseHandle h }+        exitCode      <- waitForProcess ph+        (exitCode, ) <$> T.readFile log+++getSolutions :: FilePath -> IO T.Text+getSolutions tgt = do+    let file = outputsDir </> tgt+    T.readFile file+    +mkTgt :: FilePath -> FilePath+mkTgt t = addExtension t ".hs"++++-- | Get solution from outputs line by line in order to compare+lineFile :: T.Text -> T.Text -> [T.Text]+lineFile progName file = +    dropWhile (\x -> not (startsWith (progName `T.append` (T.pack " ")) x) || +                     startsWith (progName `T.append` (T.pack " ::")) x) (T.lines file)++clean :: [T.Text] -> [T.Text]+clean ls = filter (not . T.null) (map T.strip ls)++processAnswers :: [(FilePath, T.Text, [[T.Text]])] -> [(FilePath, [[T.Text]], [T.Text])]+processAnswers = map processAnswer ++processAnswer :: (FilePath, T.Text, [[T.Text]]) -> (FilePath, [[T.Text]], [T.Text])+processAnswer (fp, prog, ts) = +    let file = unsafePerformIO (getSolutions (mkTgt fp))+        fileLines = lineFile prog file+        cleanLines = clean fileLines+    in  (fp, ts, cleanLines) ++compareLines :: [T.Text] -> [T.Text] -> Bool+compareLines [] [] = True+compareLines (t:ts) (l:ls) = t == l && compareLines ts ls+compareLines _ _ = False++buildTestCase :: (FilePath, [[T.Text]], [T.Text]) -> TestTree+buildTestCase (fp, ls, ts) +    = testCase +        fp +        ((foldr (\l b -> compareLines ts l || b) False ls) @?= True)++tests :: [(FilePath, T.Text, [[T.Text]])] -> TestTree+tests inputs = +    let answers = processAnswers inputs+        units   = map buildTestCase answers+    in  testGroup " Tests for synthesis " units+
− tests/TestCommits.hs 
@@ -1,115 +0,0 @@-#!/usr/bin/env runhaskell--{- GeneralizedNewtypeDeriving -}--import System.Environment   (getArgs)-import System.Process       (system)-import Text.Printf          (printf)-import Data.List            (isSuffixOf, stripPrefix)-import Data.Maybe           (fromMaybe)--{- | Run this script as:--     $ ./TestCommit.hs commits.txt--     where commits.txt is a file with a single git commit on each line, OR--     $ ./TestCommit.hs NUMBER--     which will get the last N(UMBER) of commits from the `branch`-- -}------------------------------------------------------------------------------------- | Configuration parameters-----------------------------------------------------------------------------------project :: String-project = "liquidhaskell"--- project = "liquidhaskell --fast --test-arguments=\"-p Peano\""--branch :: String-branch = "develop"--tmpFile :: FilePath-tmpFile = "/tmp/commits"--summaryPath :: FilePath-summaryPath = "/Users/rjhala/research/stack/lh-test/tests/logs/cur/summary.csv"-----------------------------------------------------------------------------------main :: IO ()----------------------------------------------------------------------------------main = do-  p <- strParam . head <$> getArgs-  case p of-    File f -> testCommits f-    Size n -> makeCommits n--makeCommits :: Int -> IO ()-makeCommits n = do-  system (genCommand n)-  putStrLn $ "Wrote commits into: " ++ tmpFile--testCommits :: FilePath -> IO ()-testCommits f = do-  is <- readCommits f-  putStrLn "Generating test summaries for:"-  mapM_ (putStrLn . ("  " ++)) is-  runCmd setupCmd-  mapM_ runCommit is-  runCmd setupCmd--strParam :: String -> Param-strParam s-  | ".txt" `isSuffixOf` s = File s-  | otherwise             = Size (read s)------------------------------------------------------------------------------------- | Types----------------------------------------------------------------------------------data Param = File FilePath-           | Size Int--type CommitId = String-type Command  = [String]------------------------------------------------------------------------------------_commits :: Param -> IO [CommitId]----------------------------------------------------------------------------------_commits (File f) = readCommits f-_commits (Size n) = system (genCommand n) >> readCommits tmpFile--genCommand :: Int -> String-genCommand n = printf "git log -n %d --walk-reflogs %s | grep \"commit \" > %s"-                 n branch tmpFile--readCommits :: FilePath -> IO [CommitId]-readCommits f = map strCommit . lines <$> readFile f--strCommit :: String -> CommitId-strCommit s = fromMaybe s (stripPrefix "commit " s)------------------------------------------------------------------------------------runCommit :: CommitId -> IO ()----------------------------------------------------------------------------------runCommit i = do-  putStrLn ("Running commit: " ++ i)-  runCmd (commitCmd i)--runCmd :: Command -> IO ()-runCmd = mapM_ system--setupCmd :: Command-setupCmd = [ printf "git checkout %s" branch ]--commitCmd :: CommitId -> Command-commitCmd i =-  [ printf "git checkout %s"       i-  ,        "git submodule update"-  , printf "stack test %s"         project-  , printf "cp %s ~/tmp/summary-%s.csv" summaryPath i-  ]-
+ tests/errors/AmbiguousInline.hs view
@@ -0,0 +1,220 @@+{-@ LIQUID "--scrape-used-imports" @-}+{-@ LIQUID "--short-names" @-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module MatchIdxs where++import qualified Data.ByteString as BS+-- RJ import qualified Data.ByteString.Search as BS+import Data.Char+-- RJ import Data.List.Split(chunksOf)++import Data.Monoid+import Data.Proxy+import Debug.Trace+import GHC.TypeLits++import Language.Haskell.Liquid.Prelude (liquidAssert)+-- FIX import Prelude hiding (min, max)+import Prelude hiding (max)++junk = BS.head+++traceMsg msg x = trace (msg ++ show x) x++{-@ chunksBS :: Int -> b:BS.ByteString -> [BS.ByteString] / [(bLength b)] @-}+chunksBS n' xs | BS.null xs = []+               | otherwise = x : chunksBS n xs'+    where (x,xs') = BS.splitAt  (liquidAssert (n > 0) n) xs+          n       = max 1 n'++bsToString :: BS.ByteString -> String+bsToString = map (chr . fromIntegral) . BS.unpack++stringToBS :: String -> BS.ByteString+stringToBS = BS.pack . map (fromIntegral . ord)++-- | get the (proxied and existentially boxed) type level Symbol for a bytestring+someSymbolValBS :: BS.ByteString -> SomeSymbol+someSymbolValBS = someSymbolVal . bsToString++-- | get the bytestring corresponding to a type level Symbol+mkTarg :: forall t . KnownSymbol t => Proxy t -> BS.ByteString+mkTarg = stringToBS . symbolVal+++-- | Naive specification of string matching (from Bird)+{-@ indicesSpec :: t:ByteStringNE -> s:BS.ByteString -> [OkPos t s] @-}+-- indicesSpec targ = map ((BS.length targ -) . BS.length) . filter (targ `BS.isSuffixOf`) . BS.inits+indicesSpec targ s = [ BS.length s' - BS.length targ | s' <- BS.inits s+                                                     , targ `BS.isSuffixOf` s' ]++indicesSpec :: BS.ByteString -> BS.ByteString -> [Int]++++-- | Datatype to name string matching algorithms; will use it's lifted+-- version put choice in type.+data Alg = BM  -- ^ Boyer-Moore from stringsearch package+         | Spec  -- ^ Naive spec++{-@ indices :: Alg -> t:ByteStringNE -> s:BS.ByteString -> [OkPos t s] @-}+indices BM   = assumeIndices -- RJ BS.indices+indices Spec = indicesSpec+++-- | Monoid+--+-- 'MatchIdxs alg targ' denotes the result of running string matching+-- algorithm 'alg' search for target 'targ' in some input. In addition+-- to the match indices, information needed to combine this result+-- with similar results on input to the left and right are also+-- included.+--+-- We'd like to prove that the invariants in the comments hold (|x|+-- denotes the length of x).+data MatchIdxs+    = Small { targ :: BS.ByteString+            , bs   :: BS.ByteString+            }+    | MatchIdxs { targ    :: BS.ByteString+                , input   :: Int+                , left    :: BS.ByteString+                , matches :: [Int]+                , right   :: BS.ByteString+                }+  deriving (Eq, Show)++{-@ data MatchIdxs+      = Small { targ    :: ByteStringNE+              , bs      :: {v:BS.ByteString | bLength v < bLength targ}+              }++      | MatchIdxs+              { targ    :: ByteStringNE+              , input   :: {v : Int | v >= bLength targ}+              , left    :: {v : BS.ByteString | bLength v == bLength targ - 1}+              , matches :: [{v:Int | v <= input - bLength targ}]+              , right   :: {v : BS.ByteString | bLength v == bLength targ - 1}+              }+  @-}+++matchIdxsIs :: MatchIdxs -> [Int]+matchIdxsIs (Small _ _) = []+matchIdxsIs (MatchIdxs _ _ _ is _) = is++-- | create a 'MatchIdxs'+{-@ myIndices :: Alg -> t:ByteStringNE -> BS.ByteString -> MatchIdxsT t @-}+myIndices alg t bs+  | BS.length bs > fringeLen = let right1 = BS.drop (BS.length bs - fringeLen) bs in+                                MatchIdxs t (BS.length bs) left is right1+  | otherwise = Small t bs+  where+    is        = indices alg t bs+    fringeLen = BS.length t - 1+    left      = BS.take fringeLen bs+    -- right1    = BS.drop (BS.length bs - fringeLen) bs++-- ISSUE: get contextual output with --diff+-- ISSUE: why does lazyvar right1 not work? it drops the output type on right1!++{- lazyvar right1 -}++{-@ type OkPos Targ Str = {v:Nat | v <= bLength Str - bLength Targ} @-}+{-@ type ByteStringNE   = {v:BS.ByteString | bLength v > 0 }   @-}+{-@ type ByteStringN N  = {v:BS.ByteString | bLength v == N}   @-}+{-@ type MatchIdxsT T   = {v:MatchIdxs | targ v == T}          @-}++{-@ assume BS.isSuffixOf :: targ:_ -> s:_ -> {v:_ | v => (bLength targ <= bLength s) } @-}+{-@ assume BS.length  :: b:BS.ByteString -> {v:Nat | v == bLength b}  @-}+{-@ assume BS.empty   :: {v:BS.ByteString | bLength v == 0}    @-}+{-@ assume BS.take    :: n:Nat -> b:BS.ByteString -> ByteStringN {min n (bLength b)} @-}+{-@ assume BS.drop    :: n:Nat -> b:{BS.ByteString | n <= bLength b} -> ByteStringN {bLength b - n} @-}+{-@ assume BS.inits   :: b:BS.ByteString -> [{v:BS.ByteString | bLength v <= bLength b}] @-}+{-@ assume BS.append  :: b1:BS.ByteString -> b2:BS.ByteString -> ByteStringN {bLength b1 + bLength b2} @-}+{-@ assume BS.null    :: b:BS.ByteString -> {v:Bool | v <=> (bLength b == 0)} @-}+{-@ assume BS.splitAt :: n:Nat -> b:BS.ByteString -> (ByteStringN {min n (bLength b)}, ByteStringN {max 0 (bLength b - n)}) @-}+{-@ assume BS.head    :: BS.ByteString -> _ @-}++{-@ measure target @-}+target :: MatchIdxs -> BS.ByteString+target (Small t _)           = t+target (MatchIdxs t _ _ _ _) = t++{-@ inline min @-}+min :: Int -> Int -> Int+min x y = if x <= y then x else y++{-@ inline max @-}+max :: Int -> Int -> Int+max x y = if x <= y then y else x++-- RJ instance (KnownSymbol t, StringMatch alg) => Monoid (MatchIdxs alg t) where+{-@ mmempty :: t:ByteStringNE -> MatchIdxsT t @-}+mmempty t = Small t BS.empty++{-@ mmconcat :: (Foldable t) => Alg -> tg:ByteStringNE -> t (MatchIdxsT tg) -> (MatchIdxsT tg) @-}+mmconcat alg t = foldr (mmappend alg t) (mmempty t)++{-@ qualif BB(v:Int, n:Int, d:Int, b:BS.ByteString): v <= (n + d) - bLength b @-}++{-@ mmappend :: Alg -> t:ByteStringNE -> MatchIdxsT t -> MatchIdxsT t -> MatchIdxsT t @-}+mmappend alg t mx my =+  let fringeLen = BS.length t - 1+      idxFun    = indices alg t+  in+  case (mx, my) of+    (Small tx x, Small _ y) -> myIndices alg tx (x <> y)+    (Small tx x, MatchIdxs _ yLen ly iy rt) -> MatchIdxs tx xyLen lt is rt+       where+         xyLen = xLen + yLen+         xLen  = BS.length x+         xly   = BS.append x ly+         lt    = BS.take fringeLen xly+         is    = idxFun xly ++ map (+ xLen) iy+    (MatchIdxs tx xLen lt ix rx, Small ty y) -> MatchIdxs tx xyLen lt (ix ++ is) rt+       where+         xyLen = xLen + yLen+         yLen  = BS.length y+         is    = map (+ (xLen - fringeLen)) (idxFun rxy)+         rt    = BS.drop (BS.length rxy - fringeLen) rxy+         rxy   = BS.append rx y+    (MatchIdxs tx xLen lt ix rx, MatchIdxs ty yLen ly iy rt) -> MatchIdxs tx xyLen lt (ix ++ is) rt+       where+         xyLen = xLen + yLen+         is    = ixy ++ map (+ xLen) iy+         ixy   = map (+ (xLen - fringeLen)) $ idxFun (BS.append rx ly)++-- | Example applications+--+-- The bufLen and chunkSz arguments are there to exercise the monoid,+-- though they also foreshadow a parallel implementation.+{-@ indicesBS' :: Alg -> Int -> Int -> ByteStringNE -> BS.ByteString -> [Int] @-}+indicesBS' alg bufLen chunkSz t bs =+  let si = mmconcat alg t . map (mmconcat alg t) . chunksOf bufLen . map (myIndices alg t) $ chunksBS chunkSz bs in+  matchIdxsIs si++{-@ indicesBS, indicesNaive :: Int -> Int -> ByteStringNE -> BS.ByteString -> [Int] @-}+indicesBS    = indicesBS' BM   -- RJ (Proxy :: Proxy BM)+indicesNaive = indicesBS' Spec -- RJ (Proxy :: Proxy Spec)++{-@ isInfixOfBS :: Int -> Int -> ByteStringNE -> BS.ByteString -> Bool @-}+isInfixOfBS bufLen chunkSz t = not . null . indicesBS bufLen chunkSz t++------------------------------------------------------------------------------------------+{-@ invariant {v:BS.ByteString | 0 <= bLength v } @-}+{-@ measure bLength :: BS.ByteString -> Int @-}+{-@ type LNat N = {v:Nat | v < N} @-}++chunksOf :: Int -> [a] -> [[a]]+chunksOf = undefined++{-@ assumeIndices :: t:ByteStringNE -> s:BS.ByteString -> [OkPos t s] @-}+assumeIndices :: BS.ByteString -> BS.ByteString -> [Int]+assumeIndices = undefined
+ tests/errors/AmbiguousReflect.hs view
@@ -0,0 +1,18 @@+{-@ LIQUID "--reflection"  @-}++module StringIndexing where++-- ISSUE: Uncomment the below to make this test pass+--+--    import Prelude hiding (mappend)+-- +-- LH should give an error message indicating the above.++data D = D Int Int ++{-@ reflect mappend @-}+mappend :: D -> D -> D ++{-@ mappend :: x:D -> D -> {v:D | v == x} @-}+mappend x@(D i1 i2) (D i3 i4) = x+
+ tests/errors/BadAliasApp.hs view
@@ -0,0 +1,7 @@+module BadExprArg where++{-@ type ListN a N = {v:[a] | len v = N} @-}++{-@ foo :: ListN 0 0 @-}+foo :: [a]+foo = undefined
+ tests/errors/BadAnnotation.hs view
@@ -0,0 +1,5 @@+module Zoo where++{-@ incr :: x:Int -> {v:Int | x < v } -}+incr :: Int -> Int+incr x = x - 1
+ tests/errors/BadAnnotation1.hs view
@@ -0,0 +1,7 @@+module Zoo where++{-@ incr :: x:Int +         -> {v:Int | x < v } +  -}+incr :: Int -> Int+incr x = x - 1
+ tests/errors/BadData1.hs view
@@ -0,0 +1,35 @@+{-@ LIQUID "--no-adt"         @-}+{-@ LIQUID "--exact-data-con" @-}++{-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-}++class PersistEntity record where+    data EntityField record :: * -> *++instance PersistEntity Blob where+    {-@ data EntityField record typ where+           BlobXVal :: EntityField Blob {v:Int | v >= 0}+         | BlobYVal :: EntityField Blob Int+    @-}+    data EntityField Blob typ where+        BlobXVal :: EntityField Blob Int+        BlobYVal :: EntityField Blob Int+++{-@ data Blob  = B { xVal :: {v:Int | v >= 0}, yVal :: Int } @-}+data Blob = B { xVal :: Int, yVal :: Int }++{-@ blobXVal :: EntityField Blob {v:Int | v >= 0} @-}+blobXVal :: EntityField Blob Int+blobXVal = BlobXVal++-- OK+-- testUpdateQuery :: () -> Update Blob Int+-- testUpdateQuery () = createUpdate blobXVal 3++-- BAD+-- testUpdateQueryFail :: () -> Update Blob Int+-- testUpdateQueryFail () = createUpdate blobXVal (-1)++main :: IO ()+main = pure ()
+ tests/errors/BadData2.hs view
@@ -0,0 +1,13 @@+{-@ LIQUID "--exact-data-cons" @-}++module Boo where++{-@ data Hog where  +      Cuthb :: Nat -> T +  @-}++data Hog = H Int ++data T = Cuthb { fldX :: Int }++zoink = Cuthb (-1)
+ tests/errors/BadDataCon2.hs view
@@ -0,0 +1,5 @@+module Boo where++{-@ data T = Cuthb { fldX :: Int, fldY :: Int } @-}++data T = Cuthb { fldX :: Int }
+ tests/errors/BadDataConType.hs view
@@ -0,0 +1,5 @@+module Boo where++{-@ data T = C { fldX :: Int, fldY :: Bool } @-}++data T = C { fldX :: Int, fldY :: Int }
+ tests/errors/BadDataConType1.hs view
@@ -0,0 +1,5 @@+module Boo where++{-@ data T = C { fldX :: Int, fldY :: String } @-}++data T = C { fldX :: Int, fldY :: Int }
+ tests/errors/BadDataConType2.hs view
@@ -0,0 +1,5 @@+module Boo where++{-@ data T = C { fldX :: Int } @-}++data T = C { fldX :: Int, fldY :: Int }
+ tests/errors/BadDataDeclTyVars.hs view
@@ -0,0 +1,24 @@+-- | 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 MonoidList where++{-@ data L = Emp | Cons {x::a, xs:: (L a)} @-}+--       ^ whoops, missing a tyvar!++data L a = Emp | Cons a (L a)++{-@ reflect sz @-}+sz :: L a -> Int+sz Emp         = 0+sz (Cons _ xs) = 1 + sz xs++{-@ test :: {(sz (Cons 1 Emp)) = 1} @-}+test :: ()+test = ()
+ tests/errors/BadGADT.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE GADTs #-}++{-@ 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 <p :: a -> Bool> where+       Nil2  :: List2 a+     | Cons2 :: listHead:a -> listTail:List a -> List2 a b+@-}+++data List a where+  Nil  :: List a+  Cons :: a -> List a -> List a+++data List1 a b where+  Nil1  :: List1 a b+  Cons1 :: a -> List a -> List1 a b++data List2 a b where+  Nil2  :: List2 a b+  Cons2 :: a -> List a -> List2 a b++test :: List a -> Int+test Nil = 1+test (Cons x xs) = 1 + test xs++main :: IO ()+main = pure ()
+ tests/errors/BadPragma0.hs view
@@ -0,0 +1,7 @@+{-@ LIQUID "--idirs=.." @-}++module Bad where ++i :: Int+i = 1+
+ tests/errors/BadPragma1.hs view
@@ -0,0 +1,7 @@+{-@ LIQUID "--c-files=./wow.c" @-}++module Bad where ++i :: Int+i = 1+
+ tests/errors/BadPragma2.hs view
@@ -0,0 +1,7 @@+{-@ LIQUID "--ghc-option=-O0" @-}++module Bad where ++i :: Int+i = 1+
+ tests/errors/BadPredApp.hs view
@@ -0,0 +1,7 @@+module Boo where++{-@ data X <q :: Int -> Int -> Bool> = X (x0 :: Int) (x1 :: Int<q x0>) @-}  +data X = X Int Int  ++{-@ data T <p :: Int -> Int -> Int -> Int -> Bool> = C { x :: Int, y :: Int, z :: X<p x y> } @-}+data T = C { x :: Int, y :: Int, z :: X }  
+ tests/errors/BadQualifier.hs view
@@ -0,0 +1,10 @@+module RG where+data RGRef a+{-@ measure tv :: RGRef a -> a @-}+{-@ qualif TERMINALVALUE(r:RGRef a): (tv r) @-}+++data A+data B++{-@ qualif Foo(x:A, y:B): (x == y) @-}
+ tests/errors/BadSig0.hs view
@@ -0,0 +1,8 @@+module Zoo where++{-@ measure prop :: a -> b @-}+{-@ type Prop E = {v:_ | pro v = E} @-}++foo :: Int -> Int +{-@ foo :: n:Int -> Prop 10 @-}+foo x = x + 1
+ tests/errors/BadSig1.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE GADTs #-}++{-@ LIQUID "--exact-data-con" @-}++module Ev where++data Peano where+  Z :: Peano+  S :: Peano -> Peano++-- AUTO+data EvProp where+  Ev :: Peano -> EvProp++data Ev where+  EZ  :: Ev+  ESS :: Peano -> Ev -> Ev++-- AUTO/PRELUDE+{-@ measure prop :: a -> b @-}++{-@ type Prop E = {v:_ | pro v = E} @-}++      -- {v:Ev | prop v = Ev Z}+{-@ data Ev where+        EZ  :: Prop (Ev Z)+      | ESS :: evn:Peano -> {evpf:Ev | prop evpf = Ev evn} -> {zing : Ev | prop zing = Ev (S (S evn)) }+  @-}++{-@ test :: n:Peano -> {v:Ev | prop v = Ev (S (S n))} -> {v:Ev | prop v = Ev n} @-}+test :: Peano -> Ev -> Ev+test n (ESS m q) = q++-- G := p : {prop p  = Even (S (S n)) /\ prop p = Even (S (S m))}+--        ; q : {prop q = Even m}+--        ==> n = m+--        ==> prop q = Even n
+ tests/errors/BadSyn1.hs view
@@ -0,0 +1,9 @@+module Zoo where++type Foo = Int++{-@ type Fooz = {v:Int | 1 < v} @-}++{-@ bob :: Fooz 1000 @-}+bob = 10 :: Int+
+ tests/errors/BadSyn2.hs view
@@ -0,0 +1,7 @@+module Zoo where++type Foo = Int++{-@ bob :: Foo 1000 @-}+bob = 10 :: Int+
+ tests/errors/BadSyn3.hs view
@@ -0,0 +1,7 @@+module Zoo where++type Foo = Int++{-@ bob :: Foo String @-}+bob = 10 :: Int+
+ tests/errors/BadSyn4.hs view
@@ -0,0 +1,8 @@+module Foo where++type List a = [a]+type Point  = List Double++{-@ foo :: n:Nat -> Point n @-}+foo :: Int -> List Double+foo _ = []
+ tests/errors/CyclicExprAlias0.hs view
@@ -0,0 +1,4 @@+module Test0 () where++{-@ expression CyclicA1 Q = CyclicA1 Q @-}+
+ tests/errors/CyclicExprAlias1.hs view
@@ -0,0 +1,5 @@+module Test2 () where++{-@ expression CyclicB1 Q = CyclicB2 Q @-}+{-@ expression CyclicB2 Q = CyclicB1 Q @-}+
+ tests/errors/CyclicExprAlias2.hs view
@@ -0,0 +1,7 @@+module Test3 () where++{-@ expression CyclicC1 Q = (CyclicC2 Q) && (CyclicC3 Q) @-}+{-@ expression CyclicC2 Q = CyclicC1 Q @-}+{-@ expression CyclicC3 Q = CyclicC1 Q @-}++
+ tests/errors/CyclicExprAlias3.hs view
@@ -0,0 +1,6 @@+module Test3 () where++{-@ expression CyclicD1 Q = CyclicD2 Q @-}+{-@ expression CyclicD2 Q = CyclicD3 Q @-}+{-@ expression CyclicD3 Q = CyclicD1 Q @-}+
+ tests/errors/CyclicPredAlias0.hs view
@@ -0,0 +1,4 @@+module Test0 () where++{-@ predicate CyclicA1 Q = CyclicA1 Q @-}+
+ tests/errors/CyclicPredAlias1.hs view
@@ -0,0 +1,5 @@+module Test1 () where++{-@ predicate CyclicB1 Q = CyclicB2 Q @-}+{-@ predicate CyclicB2 Q = CyclicB1 Q @-}+
+ tests/errors/CyclicPredAlias2.hs view
@@ -0,0 +1,6 @@+module Test2 () where++{-@ predicate CyclicC1 Q = CyclicC2 Q && CyclicC3 Q @-}+{-@ predicate CyclicC2 Q = CyclicC1 Q @-}+{-@ predicate CyclicC3 Q = CyclicC1 Q @-}+
+ tests/errors/CyclicPredAlias3.hs view
@@ -0,0 +1,6 @@+module Test3 () where++{-@ predicate CyclicD1 Q = CyclicD2 Q @-}+{-@ predicate CyclicD2 Q = CyclicD3 Q @-}+{-@ predicate CyclicD3 Q = CyclicD1 Q @-}+
+ tests/errors/CyclicTypeAlias0.hs view
@@ -0,0 +1,5 @@+module Test0 () where++{-@ type CyclicA1 = CyclicA2 @-}+{-@ type CyclicA2 = CyclicA1 @-}+
+ tests/errors/CyclicTypeAlias1.hs view
@@ -0,0 +1,6 @@+module Test1 () where++{-@ type CyclicB1 = CyclicB2 @-}+{-@ type CyclicB2 = CyclicB3 @-}+{-@ type CyclicB3 = CyclicB1 @-}+
+ tests/errors/CyclicTypeAlias2.hs view
@@ -0,0 +1,4 @@+module Test2 () where++{-@ type CyclicC = [CyclicC] @-}+
+ tests/errors/CyclicTypeAlias3.hs view
@@ -0,0 +1,6 @@+module Test3 () where++{-@ type CyclicD1 = CyclicD2 @-}+{-@ type CyclicD2 = CyclicD3 @-}+{-@ type CyclicD3 = CyclicD2 @-}+
+ tests/errors/DupAlias.hs view
@@ -0,0 +1,17 @@+module Goo () where++import Language.Haskell.Liquid.Prelude++{-@ type BoundedNat N = {v:Nat | v < N } @-}+{-@ predicate Foo V N = V < N            @-}++-- TODO: Test fails when this second alias is ALSO defined.+-- FIX: should WARN that there are duplicate aliases!++{-@ type BoundedNat N = {v:Nat | v <= N } @-}+{-@ predicate Foo V N = V <= N            @-}+++{-@ foo :: n:Int -> m:(BoundedNat n) -> Nat @-}+foo :: Int -> Int -> Int+foo n m = liquidAssert (m < n) m
+ tests/errors/DupData.hs view
@@ -0,0 +1,24 @@+-- | See https://github.com/ucsd-progsys/liquidhaskell/issues/1175++module BadVec where++data OVec a = ONil+            | (:>>) {oHd :: a, oTl :: OVec a}+infixr 5 :>>++{-@ data OVec a = ONil+               | (:>>) {oHd :: a,+                        oTl :: OVec {v:a | v >= oHd}} @-}+++{-@ data OVec [mylen] @-}+{-@ measure mylen @-}+{-@ mylen :: OVec a -> Nat @-}+mylen :: OVec a -> Int+mylen ONil       = 0+mylen (_ :>> xs) = 1 + mylen xs++{-@ badVec :: OVec Int @-}+badVec :: OVec Int+badVec = 1 :>> 3 :>> 2 :>> ONil+
+ tests/errors/DupFunSigs.hs view
@@ -0,0 +1,25 @@+-- See https://github.com/ucsd-progsys/liquidhaskell/issues/1137++import Data.List++{-@ type WeekDayNum = { i:Int | 0 < i && i <= 7 } @-}+type WeekDayNum = Int -- Mon == 1, ..., Sun == 7++data WeekDay = Mon | Tue | Wed | Thu | Fri | Sat | Sun+  deriving (Read, Show, Eq, Bounded)++{-@ weekdays :: { wd:[WeekDay] | len wd == 7 } @-}+weekdays :: [WeekDay]+weekdays = [Mon, Tue, Wed, Thu, Fri, Sat, Sun]++{-@ fromWeekDayNum :: WeekDayNum -> WeekDay @-}+fromWeekDayNum :: WeekDayNum -> WeekDay+fromWeekDayNum i = weekdays !! (i-1)++{-@ fromWeekDayNum :: WeekDay -> WeekDayNum @-}+toWeekDayNum :: WeekDay -> WeekDayNum+toWeekDayNum wd = case wd `elemIndex` weekdays of+        Just i -> i + 1++main :: IO ()+main = pure ()
+ tests/errors/DupMeasure.hs view
@@ -0,0 +1,17 @@+module DuplicateMeasures where +++{-@ measure lenA :: [a] -> Int +    lenA [] = 0+    lenA (x:xs) = 1 + lenA xs +  @-}++{-@ measure lenA :: [a] -> Int +    lenA [] = 0+    lenA (x:xs) = 1 + lenA xs +  @-}++{-@ zorg :: {v:[Int] | lenA v == 3} @-}+zorg :: [Int]+zorg = [1,2,3]+
+ tests/errors/ElabLocation.hs view
@@ -0,0 +1,13 @@+-- | 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` ++module ElabLocation where++import Data.Ratio ++foo :: Ratio Int -> Bool+foo x = y == y +  where +    y = 10 / x
+ tests/errors/EmptyData.hs view
@@ -0,0 +1,6 @@+-- | see: https://github.com/ucsd-progsys/liquidhaskell/issues/1169++module Bar where++{-@ data A @-}+data A = B
+ tests/errors/EmptySig.hs view
@@ -0,0 +1,6 @@++module Blank where++{-@  :: foo -> x:Int -> {v:Int | v > x} @-}+foo :: Int -> Int +foo x = x - 1
+ tests/errors/ErrLocation.hs view
@@ -0,0 +1,10 @@++module ErrLocation where++{-@ inc :: Nat -> Nat @-}+inc :: Int -> Int +inc x = x + 1++bar :: Int -> Int +bar x = inc (x - 1)+
+ tests/errors/ErrLocation2.hs view
@@ -0,0 +1,12 @@++module ErrLocation2 where++{-@ inc :: Nat -> Nat @-}+inc :: Int -> Int +inc x = x + 1++bar :: Int -> Int +bar x + | x > 0    = inc (x - 1) + | otherwise = inc x +
+ tests/errors/ExportMeasure0.hs view
@@ -0,0 +1,17 @@+-- FIX: module ExportMeasure (llen) where+    +module ExportMeasure () where++{-@ data LL [llen] @-}+data LL a = N | C a (LL a)++{-@ invariant {v:LL a | (llen v) >= 0} @-}++{-@ measure llen @-}+llen :: (LL a) -> Int +llen(N)      = 0+llen(C x xs) = 1 + (llen xs)++{-@ lmap :: (a -> b) -> xs:(LL a) -> {v: LL b | llen v = llen xs } @-} +lmap f N = N+lmap f (C x xs) = C (f x) (lmap f xs)
+ tests/errors/ExportReflect0.hs view
@@ -0,0 +1,28 @@+-- LH issue #1023++{-@ LIQUID "--exactdc"     @-}+{-@ LIQUID "--higherorder" @-}++module Bug (foo, zogbert) where++import Language.Haskell.Liquid.ProofCombinators++{-@ reflect identity @-}+identity :: a -> a+identity x = x++{-@ reflect identity2 @-}+identity2 :: a -> a+identity2 x = x++{-@ reflect identity3 @-}+identity3 :: a -> a+identity3 x = x++{-@ foo :: x:a -> { identity x == x } @-}+foo :: a -> Proof+foo x = identity x === x *** QED++{-@ reflect zogbert @-}+zogbert :: a -> a+zogbert x = x
+ tests/errors/Fractional.hs view
@@ -0,0 +1,9 @@+module Crash where++{-@ f :: (Num a) => {v:a | v > 0.0} -> a @-}+f :: (Num a) => a -> a+f a = a + 1++{-@ g :: (Num a) => {v:a | v > 0.0} -> a @-}+g :: (Num a) => a -> a+g = f
+ tests/errors/HigherOrderBinder.hs view
@@ -0,0 +1,6 @@+{-@ foo :: a: Int -> f: (Int -> Int) -> {v : Int | v = 123 + (f a) } @-}+foo :: Int -> (Int -> Int) -> Int+foo a f = f a++main :: IO ()+main = pure ()
+ tests/errors/HintMismatch.hs view
@@ -0,0 +1,14 @@++{-# LANGUAGE DataKinds #-}++module HintMismatch where++newtype Offset struct member = Offset { unOffset :: Int }++type OffsetN t = Offset (t 'Nothing)++foo = Nothing ++{-@ bar :: t 'Nothing @-}+bar :: t 'Nothing+bar = undefined 
+ tests/errors/HoleCrash1.hs view
@@ -0,0 +1,7 @@+module ListDemo where++data Poo a = C { t :: Poo a }++{-@ type Geq N = {v:_ | N <= v} @-}++{-@ data Poo a = C { t :: Poo (Geq 0) } @-}
+ tests/errors/HoleCrash2.hs view
@@ -0,0 +1,7 @@+module ListDemo where++data Poo a = C { t :: Poo a }++{-@ type Geq a N = {v:a | N <= v} @-}++{-@ data Poo a = C { t :: Poo (Geq 0) } @-}
+ tests/errors/HoleCrash3.hs view
@@ -0,0 +1,18 @@+module ListDemo where++data List a = E | (:::) { h :: a, t :: List a }++infixr  9 ::: ++{-@ countUp :: n:Int -> List Int @-}+countUp n  = n ::: countUp (n + 1)++++++++++
+ tests/errors/Inconsistent0.hs view
@@ -0,0 +1,61 @@+-- FAILING TEST: this test SHOULD FAIL BUT DOESN'T+-- issue #519++{-# 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 <ix :: AstIndex -> Bool>+    = Lit {l1 :: Int, i :: AstIndex<ix>}+    | Var {v1 :: String, i :: AstIndex<ix>}+    | App (fn :: f) (arg :: f)+    | Paren (ast :: f)+  @-}++{-@ type AstFE = AstF <{\ix -> isExprIndex ix}> @-}+{-@ type AstFT = AstF <{\ix -> isTypeIndex ix}> @-}+++-- Now lets tie the knot!++newtype Fix f = In { out :: f (Fix f) }++type Ast = Fix AstF++{-@ type AstE = Fix AstFE @-}+{-@ type AstT = Fix AstFT @-}++{-@ astExpr :: AstE  @-}+astExpr :: Ast+astExpr = In (Lit 10 IxExpr) ++{-@ astType :: AstT @-}+astType :: Ast +astType = In (Lit 10 IxType)++{-@ app :: forall <p :: AstIndex -> Bool>. Fix (AstF<p>) -> Fix (AstF<p>) -> Fix (AstF<p>) @-}+app f x = In $ App f x++{-@ id1 :: forall <p :: AstIndex -> Bool>. Fix (AstF p) -> Fix (AstF p)  @-}+id1 :: Fix AstF -> Fix AstF+id1 z = z++{-@ wrong :: AstT @-}+wrong = id1 astExpr
+ tests/errors/Inconsistent1.hs view
@@ -0,0 +1,5 @@+module Boo where++{-@ incr :: Int -> Bool @-}+incr :: Int -> Int +incr x = x + 1
+ tests/errors/Inconsistent2.hs view
@@ -0,0 +1,5 @@+module Mismatch where++{-@ foo :: Nat @-}+foo :: Bool+foo = True
+ tests/errors/InlineSubExp0.hs view
@@ -0,0 +1,21 @@++-- https://github.com/ucsd-progsys/liquidhaskell/issues/1258++{-@ LIQUID "--reflection"  @-}+{-@ LIQUID "--short-names" @-} ++module T1258 where ++import Language.Haskell.Liquid.ProofCombinators ++data Foo = A | B+data Bar = C | D+data Baz = E | F++{-@ reflect f @-}+f :: Foo -> Bar -> Baz+f B C = F+f _ _ = E++{-@ prop :: {f B C == F} @-}+prop = f B C === E *** QED  
+ tests/errors/InlineSubExp1.hs view
@@ -0,0 +1,26 @@++-- https://github.com/ucsd-progsys/liquidhaskell/issues/1258++{-@ LIQUID "--reflection"  @-}+{-@ LIQUID "--short-names" @-}++module T1258 where ++import Language.Haskell.Liquid.ProofCombinators ++data Foo = A | B+data Bar = C | D+data Baz = E | F | G ++{-@ reflect f @-}+f :: Foo -> Bar -> Baz+f B C = F+f A D = E+f _ _ = G ++{-@ reflect g @-}+g :: Foo -> Bar +g A = C +g _ = D ++test = f B (g A) === f A D *** QED  
+ tests/errors/LiftMeasureCase.hs view
@@ -0,0 +1,16 @@+module Measures where++llen :: [a] -> Int+llen [] = 0+llen (x:xs) = 1 + llen xs++{-@ measure foo @-}+foo :: a -> a +foo x = x++{-@ measure lllen @-}++{-@ lllen :: xs:[a] -> {v:Int| (lllen xs) = v} @-}+lllen :: [a] -> Int	+lllen [] = 0+lllen (x:xs) = 1 + lllen xs
+ tests/errors/LocalHole.hs view
@@ -0,0 +1,11 @@+{-@ LIQUID "--no-termination" @-}++module LocalHole where++mysum xs = go 0 0+  where+    n = length xs+    {-@ go :: i:{Nat | i <= nowhere} -> _ -> _ @-}+    go i acc+      | i >= n    = acc+      | otherwise = go (i+1) (acc + xs !! i)
+ tests/errors/MissingAssume.hs view
@@ -0,0 +1,22 @@+module OverWrite where++import qualified Data.Set++{-@ type UList a = {v:[a] | ListUnique v} @-}++{-@ assume goober :: Nat -> Nat @-} ++{-@ assume reverse :: xs:(UList a) -> {v: UList a | EqElts v xs}  @-}++{-@ predicate ListUnique LS = (Set_emp (listDup LS)) @-}++{-@ predicate EqElts X Y    = ((listElts X) = (listElts Y)) @-}++{-@+  measure listDup :: [a] -> (Data.Set.Set a)+  listDup([])   = {v | Set_emp v }+  listDup(x:xs) = {v | v = if (Set_mem x (listElts xs)) then (Set_cup (Set_sng x) (listDup xs)) else (listDup xs) }+  @-}++{-@ foo :: xs:(UList a) -> {v: UList a | EqElts v xs} @-}+foo  = reverse 
+ tests/errors/MissingField1.hs view
@@ -0,0 +1,6 @@+-- TODO-REBARE: LH _should_ (?) complain: "Unknown field `goober` in refined definition of `Foo`"++data Foo = F Int ++{-@ data Foo = F { goober :: Int } @-}+
+ tests/errors/MissingField2.hs view
@@ -0,0 +1,17 @@+-- TODO-REBARE: LH _should_ (?) complain: "Unknown field `fxx` in refined definition of `F`"++module Invariant where++data F a = F {fx :: a, fy :: a, fzz :: a} | G {fx :: a}++{-@ data F a = F { fxx :: a, fy :: a, fz :: a}+             | G { fxx :: a } +  @-}++{-@ fooG :: x:a -> {v : F a | (fxx v) > x} @-}+fooG :: a -> F a+fooG x = G x ++{-@ foo :: x:a -> {v : F a | (fxx v) > x} @-}+foo :: a -> F a+foo x = F x x x
+ tests/errors/MissingReflect.hs view
@@ -0,0 +1,20 @@+{-@ LIQUID "--reflection"                     @-}+{-@ LIQUID "--ple"                                @-}++import Language.Haskell.Liquid.ProofCombinators ++-- | This fails with an error as `foo` is unbound sans the `reflect` annotation. ++{- reflect foo -}++{-@ foo  :: Nat ->  xs: [Nat] -> Nat -> Bool / [len xs ]@-}+foo :: Int ->  [Int] -> Int -> Bool+foo lo [] hi     = (lo<=hi)+foo lo (x:xs) hi = (lo<=hi) && foo lo xs x++{-@ empty_foo :: lo:Nat -> hi:{Nat | lo <= hi } -> {foo lo [] hi} @-}+empty_foo :: Int -> Int -> Proof+empty_foo lo hi = (foo lo [] hi) ==. (lo <= hi) ==.True  *** QED++main :: IO ()+main = pure ()
+ tests/errors/MissingSizeFun.hs view
@@ -0,0 +1,15 @@+{-@ LIQUID "--nostruct" @-}++module MissingSizeFun where++{-@ data List [llen] a = N | C {lhead :: a, ltail :: List a} @-}+data List a = N | C a (List a)++{-@ measure llen @-}+llen :: List a -> Bool +llen N = True  +llen (C _ xs) = False -- 1 + llen xs+++{-@ data List2 [llen2] a = N2 | C2 {lhead2 :: a, ltail2 :: List2 a} @-}+data List2 a = N2 | C2 a (List2 a)
+ tests/errors/MultiInstMeasures.hs view
@@ -0,0 +1,31 @@+module Blank where++import Data.Word+import GHC.Ptr++{-@ class measure sizeOf :: forall a . Ptr a -> Int @-}++{-@+instance measure sizeOf :: (Ptr GHC.Word.Word16) -> Int+sizeOf (Ptr x) = 2+@-}++{-@+instance measure sizeOf :: (Ptr GHC.Word.Word32) -> Int+sizeOf (Ptr y) = 4+@-}++{-@+bar :: { p : Ptr Word32 | plen p >= (sizeOf p) }+    -> ()+@-}+bar :: Ptr Word32 -> ()+bar (Ptr unused) = ()++{-@+qux :: { p : Ptr Word32 | plen p >= 0 }+    -> ()+@-}+qux :: Ptr Word32 -> ()+qux (Ptr addr) = let x = Ptr addr in bar x+
+ tests/errors/MultiRecSels.hs view
@@ -0,0 +1,22 @@+{-@ LIQUID "--no-termination" @-}+module RedBlack  where++data RBTree a = Leaf+              | Node Color a !(RBTree a) !(RBTree a)++data Color = B | R++{-@ ok :: { v: RBTree Int | false} @-}+ok = Node R (2 :: Int)+         (Node B 1 Leaf Leaf)+         (Node B 3 Leaf Leaf)++-- LH should give an error message that the field names are duplicates.++{-@ data RBTree a = Leaf+                  | Node { c     :: Color+                         , key   :: a+                         , left  :: RBTree ({v:a | v < key})+                         , left  :: RBTree ({v:a | key < v})+                         }+  @-}
+ tests/errors/ParseBind.hs view
@@ -0,0 +1,7 @@+-- We should reject the below to disallow uppercase binders++module NoUpperCaseBinders where++{-@ id :: Foo:Int -> Int  @-}+id :: Int -> Int+id x = x
+ tests/errors/ParseClass.hs view
@@ -0,0 +1,17 @@+module Crash where++class Foo a where+{-@ class Foo where+      foo :: x:a -> {v:a | v = x}+  @-}+  foo :: a -> a       ++instance Foo Int where+  {-@ instance Foo Int where+       foo :: x:Int -> {v:Int | v = x + 1 == 9} @-}+  foo x = x + 1++instance Foo Integer where+  {-@ instance Foo Integer where+       foo :: x:Integer -> {v:Integer | v = x + 1} @-}+  foo x = x + 1
+ tests/errors/ReWrite5.hs view
@@ -0,0 +1,26 @@+module ReWrite5 where++{-@ LIQUID "--reflection" @-}+{-@ LIQUID "--ple" @-}+{-@ infix ++ @-}++import Prelude hiding (filter)++{-@ reflect lt5 @-}+lt5 :: Int -> Bool+lt5 x = x < 5++{-@ reflect filter @-}+filter _ []     = []+filter p (x:xs) = if p x then x:(filter p xs) else filter p xs++-- Reject inner refinements+{-@ rw :: xs :  [{ v: Int | v > 5 }] -> { filter lt5 xs = [] } @-}+rw :: [Int] -> ()+rw []     = ()+rw (_:xs) = rw xs++{-@ rewriteWith bad [rw] @-}+{-@ bad :: xs : [Int] -> { filter lt5 xs = [] } @-}+bad :: [Int] -> ()+bad _ = ()
+ tests/errors/ReWrite6.hs view
@@ -0,0 +1,7 @@+module ReWrite6 where++-- Reject non equalities+{-@ rewrite bad @-}+{-@ bad :: {1 < 2} @-}+bad :: ()+bad = ()
+ tests/errors/ReWrite7.hs view
@@ -0,0 +1,16 @@+module ReWrite7 where+{-@ LIQUID "--reflection" @-}+{-@ LIQUID "--ple" @-}++{-@ reflect f @-}+f :: [Int] -> Bool+f []      = True+f (x:xs) = f xs++-- Reject both sides with free vars+{-@ rewrite bad @-}+{-@ bad :: x : [Int] -> y : [Int] -> { f x = f y } @-}+bad :: [Int] -> [Int] -> ()+bad [] []        = ()+bad (x:xs) ys    = bad xs ys+bad []    (y:ys) = bad [] ys
+ tests/errors/ReWrite8.hs view
@@ -0,0 +1,40 @@+module ReWrite8 where++{-@ LIQUID "--reflection" @-}+{-@ LIQUID "--ple" @-}+{-@ infix ++ @-}++import Prelude hiding ((++), length, head)++{-@ measure length @-}+length :: [a] -> Int+length (_:xs) = 1 + length xs+length     [] = 0++{-@ reflect head @-}+{-@ head :: {xs : [a] | length xs >= 1} -> a @-}+head (x:_) = x++{-@ rewrite singleProof @-}+{-@ assume singleProof :: +          { xs : [a] | True } +      ->  { ys : [a] | True } +      ->  { xs = ys ++ [] } @-}+singleProof :: [a] -> [a] -> ()+singleProof _ _ = ()++-- Reject both sides free vars (assumed fn)+{-@ sp :: +          { xs : [a] | True } +      ->  { ys : [a] | True } +      ->  { xs = ys ++ [] } @-}+sp :: [a] -> [a] -> ()+sp _ _ = ()+++{-@ reflect ++ @-}+(++)::[a] -> [a] -> [a]+[]     ++ ys = ys +(x:xs) ++ ys = x:(xs ++ys)++
+ tests/errors/ShadowFieldInline.hs view
@@ -0,0 +1,17 @@+{-@ LIQUID "--exactdc" @-}++module Range where++-- LH should give an error message that the field selectors `pig`+-- is shadowed and should be renamed.++{-@ data Zig = Zonk { pig :: Int } @-}+data Zig = Zonk Int ++{-@ prop :: z:Zig -> {v:Int | v = pig z} @-}+prop :: Zig -> Int+prop (Zonk n) = n++{-@ inline pig @-}+pig :: Int -> Int+pig a = a + 1
+ tests/errors/ShadowFieldReflect.hs view
@@ -0,0 +1,17 @@+{-@ LIQUID "--exactdc" @-}++module Range where++-- LH should give an error message that the field selectors `pig`+-- is shadowed and should be renamed.++{-@ data Zig = Zonk { pig :: Int } @-}+data Zig = Zonk Int++{-@ prop :: z:Zig -> {v:Int | v = pig z} @-}+prop :: Zig -> Int+prop (Zonk n) = n++{-@ reflect pig @-}+pig :: Int -> Int+pig a = a + 1
+ tests/errors/ShadowMeasure.hs view
@@ -0,0 +1,21 @@++-- 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 Shadow where++data Poo = Poo Int++{-@ measure shadow :: Poo -> Int+    shadow (Poo n) = n+  @-}++{-@ test :: p:Poo -> {v:Int | v = shadow p} @-}+test :: Poo -> Int+test (Poo n) = n++{-@ measure shadow @-}+shadow :: [a] -> Int+shadow [] = 0+shadow (x:xs) = 0
+ tests/errors/ShadowMeasureVar.hs view
@@ -0,0 +1,17 @@+-- REJECT this program as the measure has the same name as another binder.++module Shadow where++data Poo = Poo Int++{-@ measure shadow :: Poo -> Int+    shadow (Poo n) = n+  @-}++{-@ test :: p:Poo -> {v:Int | v = shadow p} @-}+test :: Poo -> Int+test (Poo n) = n++shadow :: Int+shadow = 121+
+ tests/errors/T1140.hs view
@@ -0,0 +1,11 @@++module Blank where +	+data Label = Label Int ++type Proof = () ++{-@ foo :: Label -> Label -> Label -> Proof @-} +foo :: Label -> Label -> Label -> Proof -> Proof +foo a b c v = ()+
+ tests/errors/T1498.hs view
@@ -0,0 +1,12 @@+module T1498 where ++class A a where+  f :: a -> Int++instance A Int where+  {-@ f :: _ -> {x : Int | 0 < x} @-}+  f n = n++{-@ x :: {x : Int | 0 < x} @-}+x :: Int+x = f ((-1) :: Int)
+ tests/errors/T1498A.hs view
@@ -0,0 +1,10 @@+module T1498A where++class A a where+  f :: a -> Int+  +instance A Int where+{-@ instance A Int where+      f :: _ -> {x : Int | 0 < x}+  @-}+  f n = (-1)
+ tests/errors/T773.hs view
@@ -0,0 +1,11 @@+-- | 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 LiquidR where++{-@ measure goober :: String -> Int @-}++{-@ incr :: x:Int -> {v:Bool | goober x == 0} @-}+incr :: Int -> Bool+incr = undefined
+ tests/errors/T774.hs view
@@ -0,0 +1,10 @@++-- | Why does this NOT fail?! Clearly there is a sort error?!++module LiquidR where++{-@ measure goober :: String -> Int @-}++{-@ incr :: x:Int -> y:Int -> {v:Bool | goober x == goober y} @-}+incr :: Int -> Int -> Bool+incr = undefined
+ tests/errors/TODOUnboundAbsRef.hs view
@@ -0,0 +1,43 @@+-- 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 ListRange () where++import Language.Haskell.Liquid.Prelude++{-@ LIQUID "--no-termination" @-}+++{-@+data List [llen] a <p :: x0:a -> x1:a -> Bool>+  = Nil+  | Cons { lHd :: a, lTl :: List <p> (a <p mickeymouse>) }+@-}++{-@ measure llen :: (List a) -> Int+    llen(Nil)       = 0+    llen(Cons x xs) = 1 + (llen xs)+  @-}++{-@ invariant {v:(List a) | ((llen v) >= 0)} @-}++data List a = Nil | Cons a (List a)++{-+low, high :: Int+low  = 0+high = 10+-}++range l h =+  if l <= h then Cons l (range (l+1) h) else Nil++chk y =+  case y of+   Nil -> True+   Cons x1 xs -> case xs of+                 Nil -> True+                 Cons x2 xs2 -> liquidAssertB (x1 <= x2) && chk xs2++prop3 = chk $ range 1 100
+ tests/errors/TODOVarInTypeAlias.hs view
@@ -0,0 +1,84 @@+-- VS.hs+{-@ LIQUID "--higherorder"    @-}+{-@ LIQUID "--totality"       @-}+{-@ LIQUID "--exactdc"        @-}++module RL1015 where++import Language.Haskell.Liquid.ProofCombinators++{-@ data VerifiedSemigroup a = VerifiedSemigroup { sappend :: a -> a -> a } @-}+data VerifiedSemigroup a = VerifiedSemigroup { sappend :: a -> a -> a }++infixr 6 `sappend`++-- ISSUE: UNBOUND VARIABLE IN TYPE ALIAS!!!! gR should be GR+{-@ type VSappendAssoc a GR = x:a -> y:a -> z:a+                           -> { v: Proof | sappend GR x (sappend GR y z) == sappend GR (sappend gR x y) z }+  @-}+type SappendAssoc a = a -> a -> a -> Proof++{-@ axiomatize sappendInv @-}+sappendInv :: (a -> a -> a)+           -> (a -> b) -> (b -> a)+           -> b -> b -> b+sappendInv sappendA f g x y = f (sappendA (g x) (g y))+{-# INLINE sappendInv #-}++{-@ sappendInvAssoc :: sappendA:(a -> a -> a)+                    -> sappendAAssoc:(i:a -> j:a -> k:a -> { sappendA i (sappendA j k) == sappendA (sappendA i j) k })+                    -> f:(a -> b)+                    -> g:(b -> a)+                    -> gof:(z:a -> { g (f z) == z })+                    -> x:b+                    -> y:b+                    -> z:b+                    -> { sappendInv sappendA f g x (sappendInv sappendA f g y z) == sappendInv sappendA f g (sappendInv sappendA f g x y) z }+@-}+sappendInvAssoc :: (a -> a -> a)+                -> (a -> a -> a -> Proof)+                -> (a -> b)+                -> (b -> a)+                -> (a -> Proof)+                -> b -> b -> b+                -> Proof+sappendInvAssoc sappendA sappendAAssoc f g gof x y z+  =   sappendInv sappendA f g x (sappendInv sappendA f g y z)+  ==. sappendInv sappendA f g x (f (sappendA (g y) (g z)))+  ==. f (sappendA (g x) (g (f (sappendA (g y) (g z)))))+  ==. f (sappendA (g x) (sappendA (g y) (g z))) ? gof (sappendA (g y) (g z))+  ==. f (sappendA (sappendA (g x) (g y)) (g z)) ? sappendAAssoc (g x) (g y) (g z)+  ==. f (sappendA (g (f (sappendA (g x) (g y)))) (g z)) ? gof (sappendA (g x) (g y))+  ==. f (sappendA (g (sappendInv sappendA f g x y)) (g z))+  ==. sappendInv sappendA f g (sappendInv sappendA f g x y) z+  *** QED++{-@ reflect vsemigroupInv @-}+{-@ vsemigroupInv :: f:(a -> b)+                  -> g:(b -> a)+                  -> gof:(x:a -> { g (f x) == x })+                  -> VerifiedSemigroup a+                  -> VerifiedSemigroup b+@-}+vsemigroupInv :: (a -> b) -> (b -> a) -> (a -> Proof)+              -> VerifiedSemigroup a -> VerifiedSemigroup b+vsemigroupInv f g gof (VerifiedSemigroup sappendA)+  = VerifiedSemigroup (sappendInv sappendA f g)+++{-@ vsgiAssoc :: f:(a -> b)+              -> g:(b -> a)+              -> gof:(x:a -> { g (f x) == x })+              -> poopa:(VerifiedSemigroup a)+              -> VSappendAssoc a poopa+              -> SappendAssoc b++  @-}+vsgiAssoc :: (a -> b) -> (b -> a) -> (a -> Proof) -> VerifiedSemigroup a+          -> SappendAssoc a+          -> SappendAssoc b+vsgiAssoc f g gof (VerifiedSemigroup sappendA) sappendAAssoc+  = sappendInvAssoc sappendA sappendAAssoc f g gof++              -- -> VSappendAssoc a va+              -- -> VSappendAssoc b {vsemigroupInv f g gof va}
+ tests/errors/TerminationExprNum.hs view
@@ -0,0 +1,8 @@+module TerminationExpr where++{-@ showSep :: _ -> xs:_ -> _ / [xs] @-} -- use xs as reducing param+showSep :: String -> [String] -> String+showSep sep []     = ""+showSep sep [x]    = x+showSep sep (x:xs) = x ++ sep ++ showSep sep xs+
+ tests/errors/TerminationExprSort.hs view
@@ -0,0 +1,8 @@+module TerminationExpr where++{-@ showSep :: _ -> xs:_ -> _ / [len ys] @-} -- use xs as reducing param+showSep :: String -> [String] -> String+showSep sep []     = ""+showSep sep [x]    = x+showSep sep (x:xs) = x ++ sep ++ showSep sep xs+
+ tests/errors/TerminationExprUnb.hs view
@@ -0,0 +1,11 @@+module LocalTermExpr where++{- assume (!!) :: xs:[a] -> {v:Nat | v < len xs} -> a @-}++mysum xs = go 0 0+  where+    n = length xs+    {-@ go :: i:_ -> _ -> _ / [nn - i] @-}+    go i acc+      | i >= n    = acc+      | otherwise = go (i+1) (acc + xs !! i)
+ tests/errors/UnboundAbsRef.hs view
@@ -0,0 +1,10 @@++-- ISSUE: this "crashes" without a decent source location+-- You can fix this with the signature `ide :: forall <p :: a -> Prop>. a<p> -> a<p>`+-- but it would be nice to have an error message that pinpoints the location.+-- https://github.com/ucsd-progsys/liquidhaskell/issues/655++module Ide where++{-@ ide :: a<p> -> a<p> @-}+ide x = x
+ tests/errors/UnboundCheckVar.hs view
@@ -0,0 +1,7 @@+{-@ LIQUID "--checks=ink" @-}++module UnboundCheckVar where ++inc :: Int -> Int +inc x = x + 1+
+ tests/errors/UnboundFunInSpec.hs view
@@ -0,0 +1,9 @@+module Goo () where++cnt   :: Int -> Int+cnt 0 = 0+cnt i = 1 + cnt (i-1)++{-@ three :: {v:Int | (cnt v) = 3} @-}+three :: Int+three = 15
+ tests/errors/UnboundFunInSpec1.hs view
@@ -0,0 +1,4 @@+module Goo where++{-@ foo :: xs:_ -> {v:_ | this = rubbish } @-}+foo _ _ = 0
+ tests/errors/UnboundFunInSpec2.hs view
@@ -0,0 +1,5 @@+module Goo where++{-@ foo :: Num a => { z : (xs:t -> {v : (t -> a) | this = rubbish }) | wow = hi } @-}+foo :: Num a => t -> t -> a+foo _ _ = 0
+ tests/errors/UnboundVarInAssume.hs view
@@ -0,0 +1,5 @@+module Assume where++{-@ assume incr :: Int -> {v : Int | v == x} @-}+incr :: Int -> Int+incr x = x + 1
+ tests/errors/UnboundVarInLocSig.hs view
@@ -0,0 +1,8 @@+module Local02 where ++{-@ foo :: x:_ -> y:_ -> {v:Int | v = x + y} @-} +foo :: Int -> Int -> Int +foo arg0 = bar +  where +    {-@ bar :: x:_ -> {v:Int | v = x + barg0} @-} +    bar arg1 = arg0 + arg1 
+ tests/errors/UnboundVarInReflect.hs view
@@ -0,0 +1,8 @@+module UnboundVarInReflect where++-- see GH #1708++{-@ LIQUID "--reflection" @-}+{-@ reflect frog @-}+frog :: () -> Bool+frog () = undefined
+ tests/errors/UnboundVarInSpec.hs view
@@ -0,0 +1,7 @@+module Fixme where+++{-@ foo :: forall <p :: s -> s -> Bool>.+                   xs:s<p y> -> s<p xs> @-}+foo :: s -> s+foo s = s
+ tests/ffi-include/foo.c view
@@ -0,0 +1,4 @@+#include "foo.h"+int foo(int x) {+  return x;+}
+ tests/ffi-include/foo.h view
@@ -0,0 +1,1 @@+int foo(int);
+ tests/import/client/CliAliasGen00.hs view
@@ -0,0 +1,5 @@+module CliAliasGen00 where ++import LibAliasGen00 ++bar = foo 10
+ tests/import/client/CliRedBlue.hs view
@@ -0,0 +1,7 @@+module CliRedBlue where ++import           LibBlue +import qualified LibRedBlue as RB ++{-@ yumyum :: _ -> Nat @-}+yumyum = RB.foo
+ tests/import/client/Client0.hs view
@@ -0,0 +1,6 @@+module Client0 where ++    import Client1 +    +    a :: Eq a => B a -> Bool +    a (B x y) = x == y 
+ tests/import/client/Client1.hs view
@@ -0,0 +1,8 @@+module Client1 where ++    import Client2+    +    data B a = B {b1 :: a, b2 :: a }+    {-@ data B a = B {b1 :: a, b2 :: {v:a | cProp b1 v } } @-}++
+ tests/import/client/Client2.hs view
@@ -0,0 +1,8 @@+module Client2 where ++    {-@ reflect cProp @-}+    +    cProp :: Eq a => a -> a -> Bool +    cProp x y = x == y ++
+ tests/import/client/ExactGADT9.hs view
@@ -0,0 +1,13 @@+{-@ LIQUID "--reflection" @-}+{-@ LIQUID "--no-adt"     @-}++{-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-}++module ExactGADT9 where++import ExactGADT8++{-@ reflect bar @-}+bar :: RefinedFilter Blob typ -> Bool+bar (RefinedFilter BlobXVal) = True+bar (RefinedFilter BlobYVal) = True
+ tests/import/client/FunClashLibLibClient.hs view
@@ -0,0 +1,12 @@+-- TEST: the "transitively" imported name `FunClashLibLib.incr` is fully qualified and so +-- SHOULD NOT get resolved to `FunClashLibLibClient.incr`; we allow this for "re-exported" names,+-- e.g. to let `Data.Vector.Vector` get resolved to `Data.Vector.Generic.Vector` ... +-- but SOMEHOW block this. [Current workaround: make sure you import-qualified `FunClashLibLib` +-- so that the name "attaches" properly. sigh.++module FunClashLibLibClient where  ++import FunClashLib++incr :: Bool -> Bool+incr = not 
+ tests/import/client/LibRedBlue.hs view
@@ -0,0 +1,8 @@+module LibRedBlue where ++import LibRed +import qualified LibBlue as Blue ++{-@ foo :: Thing -> Nat @-}+foo :: Thing -> Int  +foo _ = 10 
+ tests/import/client/LiquidArrayInit.hs view
@@ -0,0 +1,71 @@+{-@ LIQUID "--no-termination" @-}++module LiquidArrayInit () where++import Language.Haskell.Liquid.Prelude+import LiquidArray++{-@ zero ::+      i: {v: Int | v >= 0} ->+      n: Int ->+      a: (j: {v: Int | (0 <= v && v < i)} -> {v: Int | v = 0}) ->+      (k: {v: Int | (0 <= v && v < n)} -> {v: Int | v = 0}) @-}+zero :: Int -> Int -> (Int -> Int) -> (Int -> Int)+zero i n a = if i >= n then a+                       else zero (i + 1) n (set i 0 a)++{-@ tenZeroes :: i: {v: Int | (0 <= v && v < 10)} -> {v: Int | v = 0} @-}+tenZeroes = zero 0 10 empty++{-@ zeroBackwards ::+      i: Int ->+      n: {v: Int | v > i} ->+      a: (j: {v: Int | (i < v && v < n)} -> {v: Int | v = 0}) ->+      (k: {v: Int | (0 <= v && v < n)} -> {v: Int | v = 0}) @-}+zeroBackwards :: Int -> Int -> (Int -> Int) -> (Int -> Int)+zeroBackwards i n a = if i < 0 then a+                               else zeroBackwards (i - 1) n (set i 0 a)++{-@ tenZeroes' :: i: {v: Int | (0 <= v && v < 10)} -> {v: Int | v = 0} @-}+tenZeroes' = zeroBackwards 9 10 empty++{-@ zeroEveryOther ::+      i: {v: Int | (v >= 0 && v mod 2 = 0)} ->+      n: Int ->+      a: (j: {v: Int | (0 <= v && v < i && v mod 2 = 0)} -> {v: Int | v = 0}) ->+      (k: {v: Int | (0 <= v && v < n && v mod 2 = 0)} -> {v: Int | v = 0}) @-}+zeroEveryOther :: Int -> Int -> (Int -> Int) -> (Int -> Int)+zeroEveryOther i n a = if i >= n then a+                       else zeroEveryOther (i + 2) n (set i 0 a)++{-@ stridedZeroes ::+      j: {v: Int | (v mod 2 = 0 && 0 <= v && v < 10)} -> {v: Int | v = 0} @-}+stridedZeroes = zeroEveryOther 0 10 empty++{-@ initArray :: forall a <p :: x0: Int -> x1: a -> Bool>.+      f: (z: Int -> a<p z>) ->+      i: {v: Int | v >= 0} ->+      n: Int ->+      a: (j: {v: Int | (0 <= v && v < i)} -> a<p j>) ->+      (k: {v: Int | (0 <= v && v < n)} -> a<p k>) @-}+initArray f i n a = if i >= n then a+                              else initArray f (i + 1) n (set i (f i) a)++{-@ zeroInitArray ::+      i: {v: Int | v >= 0} ->+      n: Int ->+      a: (j: {v: Int | (0 <= v && v < i)} -> {v: Int | v = 0}) ->+      (k: {v: Int | (0 <= v && v < n)} -> {v: Int | v = 0}) @-}+zeroInitArray :: Int -> Int -> (Int -> Int) -> (Int -> Int)+zeroInitArray = initArray (const 0)++{-@ tenZeroes'' :: i: {v: Int | (0 <= v && v < 10)} -> {v: Int | v = 0} @-}+tenZeroes'' = zeroInitArray 0 10 empty++{-@ initid ::+      i: {v: Int | v >= 0} ->+      n: Int ->+      a: (j: {v: Int | (0 <= v && v < i)} -> {v: Int | v = j}) ->+      (k: {v: Int | (0 <= v && v < n)} -> {v: Int | v = k}) @-}+initid :: Int -> Int -> (Int -> Int) -> (Int -> Int)+initid = initArray id
+ tests/import/client/LiquidArrayNullTerm.hs view
@@ -0,0 +1,23 @@+{-@ LIQUID "--no-termination" @-}++module LiquidArrayNullTerm () where++import Language.Haskell.Liquid.Prelude++import LiquidArray++upperCaseString' :: Int -> Int -> (Int -> Int) -> (Int -> Int)+upperCaseString' n i s =+  let c = get i s in+  if c == 0 then s+            else upperCaseString' n (i + 1) (set i (c + 32) s)++{-@ upperCaseString ::+      n: {v: Int | v > 0} ->+      s: (j: {v : Int | (0 <= v && v < n)} ->+          {v: Int | (j = n - 1 => v = 0)}) ->+      (j: {v : Int | (0 <= v && v < n)} ->+       {v: Int | (j = n - 1 => v = 0)})+@-}+upperCaseString :: Int -> (Int -> Int) -> (Int -> Int)+upperCaseString n s = upperCaseString' n 0 s
+ tests/import/client/ListClient.hs view
@@ -0,0 +1,37 @@+-- | A "client" that uses the reflected definitions.++{-@ LIQUID "--reflection" @-}+{-@ LIQUID "--ple"        @-} ++module ListClient where++import Prelude hiding (concat, filter, foldr, map)+import ListLib++{-@ reflect incr @-}+incr :: Int -> Int+incr x = x + 1++{-@ reflect isPos @-}+isPos :: Int -> Bool +isPos x = x > 0 ++{-@ reflect ints0 @-}+ints0 :: [Int] +ints0 = [0, 1, 2] ++{-@ reflect ints1 @-}+ints1 :: [Int] +ints1 = [1, 2, 3] ++{-@ reflect ints2 @-}+ints2 :: [Int] +ints2 = [1, 2] ++{-@ mapProp :: () -> { map incr ints0 == ints1 } @-}+mapProp () = ()++{-@ filterProp :: () -> { filter isPos ints0 == ints2 } @-}+filterProp () = ()++
+ tests/import/client/NameClashClient.hs view
@@ -0,0 +1,11 @@+module NameClashClient where ++import qualified NameClashLib as Lib ++data Foo = FooClient Int++{-@ bar :: FooAlias -> Nat @-}+bar :: Lib.Foo -> Int +bar _ = 20 ++baz = Lib.foo
+ tests/import/client/RC1015.hs view
@@ -0,0 +1,12 @@+{-@ LIQUID "--exactdc" @-}+{-@ LIQUID "--higherorder" @-}++module RC1015 where++import RL1015++{-@ car :: f:Foo -> { v: a | fooFirst f 0 == 10 } -> Int @-}+car :: Foo -> a -> Int+car f _ = 10++zag = car (Foo bling 10) (bling 0)
+ tests/import/client/ReflectClient0.hs view
@@ -0,0 +1,11 @@+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
+ tests/import/client/ReflectClient1.hs view
@@ -0,0 +1,7 @@+module ReflectClient0 where++import ReflectLib1++{-@ myHead :: {v:[a] | not (isNull v) } -> a @-}+myHead :: [a] -> a+myHead (x:_) = x
+ tests/import/client/ReflectClient2.hs view
@@ -0,0 +1,8 @@+{-@ LIQUID "--higherorder" @-}++module ReflectClient2 where++import ReflectLib2++{-@ proof :: a -> { v: Int | incr 5 == 6 } @-}+proof _ = incr 5
+ tests/import/client/ReflectClient3.hs view
@@ -0,0 +1,23 @@+{-@ LIQUID "--reflection" @-} +{-@ LIQUID "--ple"        @-} ++module ReflectClient3 where++import Language.Haskell.Liquid.ProofCombinators++import ReflectLib3++-- THIS IS NEEDED TO BRING THE NAMES INTO SCOPE FOR GHC ...+forceImports = [ undefined next+               , undefined lDay+               ]++-- THIS WORKS+{-@ test2 :: { next Mon == Tue } @-}+test2 = next Mon === Tue *** QED++-- THIS DOES NOT WORK, but it DOES work if we remove the+-- type parameter from `List`. However it DOES work if we+-- put this back into ReflectLib3.hs+{-@ test4 :: { lDay Nil == Mon } @-}+test4 = lDay Nil === Mon *** QED
+ tests/import/client/ReflectClient4.hs view
@@ -0,0 +1,50 @@++{-@ LIQUID "--reflection" @-} +{-@ LIQUID "--ple"        @-} ++module ReflectClient4 where++import Language.Haskell.Liquid.ProofCombinators++import ReflectLib4++-- THIS IS NEEDED TO BRING THE NAMES INTO SCOPE FOR GHC ...+forceImports = [ ]++{-@ test1 :: {v:List a | v = Nil} @-}+test1 :: List a+test1 = Nil+++{-@ test2 :: {v:Proof | llen (Cons 1 Nil) = 1} @-}+test2 :: Proof+test2 =  llen (Cons 1 Nil)+      === 1 + llen Nil+      === 1+      *** QED++{-@ test3 :: {v:Proof | llen (Cons 1 (Cons 2 Nil)) = 2} @-}+test3 :: Proof+test3 =  llen (Cons 1 (Cons 2 Nil))+      === 1 + llen (Cons 2 Nil)+      === 1 + 1 + llen Nil+      *** QED++{-@ zen :: xs:List a -> {v:Nat | v = llen xs} @-}+zen :: List a -> Int+zen Nil        = 0+zen (Cons h t) = 1 + zen t++{-@ test5 :: { app (Cons 1 Nil) (Cons 2 (Cons 3 Nil)) = Cons 1 (Cons 2 (Cons 3 Nil)) } @-}+test5 =   app (Cons 1 Nil) (Cons 2 (Cons 3 Nil))+      === Cons 1 (app Nil (Cons 2 (Cons 3 Nil)))+      === Cons 1 (Cons 2 (Cons 3 Nil))+      *** QED++{-@ thmAppLen :: xs:List a -> ys:List a -> { llen (app xs ys) == llen xs + llen ys} @-}+thmAppLen :: List a -> List a -> Proof+thmAppLen Nil ys+  =  ()++thmAppLen (Cons x xs) ys+  = thmAppLen xs ys
+ tests/import/client/ReflectClient4a.hs view
@@ -0,0 +1,25 @@+{-@ LIQUID "--reflection" @-} +{-@ LIQUID "--ple"        @-} ++module ReflectClient4a where++import ReflectLib4 ++stupidity = [ undefined gapp ]++{-@ test1 :: { llen Nil == 0 } @-}+test1 = ()++{-@ test2 :: { llen (Cons 2 Nil) == 1 } @-}+test2 = ()++{-@ test3 :: { llen (Cons 1 (Cons 2 Nil)) == 2 } @-}+test3 = ()++{-@ test4 :: { app Nil Nil == Nil } @-}+test4 = () ++{-@ test5 :: { gapp Nil = Nil } @-}+test5 = ()++
+ tests/import/client/ReflectClient5.hs view
@@ -0,0 +1,11 @@+{-@ LIQUID "--reflection" @-} +{-@ LIQUID "--ple"        @-} ++module ReflectClient5 where++-- import Language.Haskell.Liquid.ProofCombinators++import ReflectLib5++{-@ test5 :: { gapp Nil = Nil } @-}+test5 = ()
+ tests/import/client/ReflectClient6.hs view
@@ -0,0 +1,15 @@+{-@ LIQUID "--reflection" @-} +{-@ LIQUID "--ple"        @-} ++module ReflectClient6 where++import Language.Haskell.Liquid.ProofCombinators++import ReflectLib6++{-@ testOK :: { next Mon == Tue } @-}+testOK = next Mon === Tue *** QED++{-@ testFAIL :: { next Tue == Mon } @-}+testFAIL = trivial +
+ tests/import/client/ReflectClient7.hs view
@@ -0,0 +1,30 @@+{-@ LIQUID "--reflection" @-}+{-@ LIQUID "--ple"        @-}++module ReflectClient7 where++import ReflectLib7 ++import Language.Haskell.Liquid.ProofCombinators++data U1 p = U1++{-@ axiomatize fmapU1 @-}+fmapU1 :: (p -> q) -> U1 p -> U1 q+fmapU1 _ _ = U1++{-@ fmapU1Compose :: f:(q -> r)+                  -> g:(p -> q)+                  -> x:U1 p+                  -> { fmapU1 (compose f g) x == compose (fmapU1 f) (fmapU1 g) x }+@-}+fmapU1Compose :: (q -> r) -> (p -> q)+              -> U1 p -> Proof+fmapU1Compose f g x+  = trivial ++  -- =   fmapU1 (compose f g) x+  -- ==. U1+  -- ==. fmapU1 f (fmapU1 g x)+  -- ==. compose (fmapU1 f) (fmapU1 g) x+  -- *** QED
+ tests/import/client/ReflectClient8.hs view
@@ -0,0 +1,36 @@+-- By Zack Grannan at https://github.com/ucsd-progsys/liquidhaskell/pull/1646++{-@ LIQUID "--reflection" @-}+{-@ LIQUID "--ple"        @-}+{-@ LIQUID "--extensionality" @-}++module ReflectClient8 where++import ReflectLib8++{-@ assume extensionality :: f:(a -> b) -> g:(a -> b) -> (x:a -> {f x == g x}) ->  {f == g}  @-}+extensionality :: (a -> b) -> (a -> b) -> (a -> ()) -> ()+extensionality _ _ _ = ()++{-@ refineExt' ::+        f  : (a -> Int)+     -> g  : (a -> Int)+     -> (x : a -> { v : () | Refines (f x) (g x)})+     -> x  : a+     -> {v : () | chooseF f g x = g x}+@-}+refineExt' :: (a -> Int) -> (a -> Int) -> (a -> ()) -> a -> ()+refineExt' _ _ proof x = proof x++{-@ refineExt ::+        f  : (a -> Int)+     -> g  : (a -> Int)+     -> (x : a -> { v : () | Refines (f x) (g x)})+     -> {v : () | RefinesF f g}+@-}+refineExt :: (a -> Int) -> (a -> Int) -> (a -> ()) -> ()+refineExt f g proof =+  extensionality (chooseF f g) g (refineExt' f g proof)++{-@ predicate Refines  M1 M2 = choose   M1 M2 = M2 @-}+{-@ predicate RefinesF F1 F2 = chooseF F1 F2 = F2 @-}
+ tests/import/client/RewriteClient.hs view
@@ -0,0 +1,19 @@+module RewriteClient where++{-@ LIQUID "--reflection" @-}+{-@ LIQUID "--ple" @-}+{-@ LIQUID "--max-rw-ordering-constraints=1" @-}++{-@ infix ++ @-}++import RewriteLib++{-@ rewriteWith assoc2 [assoc] @-}+{-@ assoc2 :: xs:[a] -> ys:[a] -> zs:[a] -> ws:[a]+          -> { xs ++ (ys ++ (zs ++ ws)) == ((xs ++ ys) ++ zs) ++ ws } @-}+assoc2 :: [a] -> [a] -> [a] -> [a] -> ()+assoc2 xs ys zs ws+  = () {-+    assoc xs ys (zs ++ ws)+    `const` assoc (xs ++ ys) zs ws+-}
+ tests/import/client/STClient.hs view
@@ -0,0 +1,45 @@+-- TAG: classes +-- TAG: bounds ++{-@ LIQUID "--no-pattern-inline" @-}+{-@ LIQUID "--higherorder"       @-}++module STClient where++import STLib ++--------------------------------------------------------------------------------++{-@ fresh :: forall <pre :: Int -> Bool>.+                    { zoo::Int |- Int<pre> <: {v:Int | 0 <= v} }+                    ST <pre, {\rv v -> ( 0 <= rv && rv + 1 = v )}> Int (Int<pre>)+  @-}++{- fresh :: ST <{\v -> (0 <= v)}, {\rv v -> ( 0 <= rv && rv + 1 = v )}> Int Nat @-}+fresh :: ST Int Int+fresh = S (\n -> (n, n+1))++--------------------------------------------------------------------------------++{-@ incr0 :: ST <{\v -> (0 <= v)}, {\rv v -> (0 <= rv && 1 <= v)}> Int Int @-}+incr0 :: ST Int Int+incr0 = do+  n <- fresh+  return n++{-@ incr1 :: ST <{\v -> (0 <= v)}, {\rv v -> (0 <= rv && 1 <= v)}> Int Int @-}+incr1 :: ST Int Int+incr1 = fresh >>= return++{-@ incr2 :: ST <{\v -> (0 == v)}, {\rv v -> (4 == v)}> Int Int @-}+incr2 :: ST Int Int+incr2 = do+  n0 <- fresh+  n1 <- fresh+  n2 <- fresh+  n3 <- fresh+  return (checkEq 3 n3)++{-@ checkEq :: x:Int -> y:{Int | y = x} -> {v:Int | v = y} @-}+checkEq :: Int -> Int -> Int+checkEq x y = y
+ tests/import/client/T1096_Foo.hs view
@@ -0,0 +1,8 @@+module T1096_Foo where++import T1096_Types ++{-@ foo  :: f:Foo -> Foo / [size f] @-}+foo  :: Foo -> Foo+foo (A x) = A (foo x)+foo x     = x 
+ tests/import/client/T1104Client.hs view
@@ -0,0 +1,19 @@+module T1104Client where++import T1104Lib ++-- 'bar' should ALSO work but right now, but right now 'twerp' is simpler. ++{- bar :: Foo a b -> Maybe ({v:Foo a b | isFoo v}) @-}+bar :: Foo a b -> Maybe (Foo a b)+bar x | isFoo x   = Just x +      | otherwise = Nothing ++{-@ burp :: (Foo a b) -> Nat @-} +burp :: Foo a b -> Int +burp x = toNat x ++{-@ twerp :: x:(Foo a b) -> {v:Bool | v = isFoo x} @-}+twerp x = g x+  where +    g = isFoo
+ tests/import/client/T1117.hs view
@@ -0,0 +1,25 @@+{-@ LIQUID "--reflection"        @-}++module T1117 where++import T1117Lib ++import Language.Haskell.Liquid.ProofCombinators++{-@ axiomatize leqU1 @-}+leqU1 :: U1 p -> U1 p -> Bool+leqU1 _ _ = True++{-@ leqU1Refl :: x:U1 p -> { leqU1 x x } @-}+leqU1Refl :: U1 p -> Proof+leqU1Refl U1 = leqU1 U1 U1 === True *** QED++{-@ axiomatize leqProd @-}+leqProd :: Eq (f p)+        => (f p -> f p -> Bool) -> (g p -> g p -> Bool)+        -> Product f g p -> Product f g p -> Bool+leqProd leqFP leqGP (Product x1 y1) (Product x2 y2) =+  if x1 == x2+    then leqGP y1 y2+    else leqFP x1 x2+{-# INLINE leqProd #-}
+ tests/import/client/T1118.hs view
@@ -0,0 +1,26 @@+{-@ LIQUID "--reflection" @-}++module T1118 where++import T1118Lib2 +import T1118Lib1++import Language.Haskell.Liquid.ProofCombinators++{-@ reflect leqU1 @-}+leqU1 :: U1 p -> U1 p -> Bool+leqU1 _ _ = True++{-@ leqU1Refl :: x:U1 p -> { leqU1 x x } @-}+leqU1Refl :: U1 p -> Proof+leqU1Refl U1 = leqU1 U1 U1 === True *** QED++{-@ reflect leqProd @-}+leqProd :: Eq (f p)+        => (f p -> f p -> Bool) -> (g p -> g p -> Bool)+        -> Product f g p -> Product f g p -> Bool+leqProd leqFP leqGP (Product x1 y1) (Product x2 y2) =+  if x1 == x2+    then leqGP y1 y2+    else leqFP x1 x2+{-# INLINE leqProd #-}
+ tests/import/client/T1180.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE GADTs #-}++{-@ LIQUID "--exact-data-con" @-}+{-@ LIQUID "--noadt" @-}++module Ev where++import Peano ++pInt :: Peano -> Int +pInt Z     = 0 +pInt (S n) = 1 + pInt n
+ tests/import/client/T1688.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE GADTs #-}++{-@ LIQUID "--reflection"  @-}++module T1688 where++import T1688Lib++data HasFType where+    FTBC   :: Bool -> HasFType++{-@ ftypSize :: HasFType -> { n:Int | n >= 0 } @-}+ftypSize :: HasFType -> Int+ftypSize (FTBC {}) = 1
+ tests/import/client/WrapClient.hs view
@@ -0,0 +1,8 @@+module WrapClient where++import WrapLib+import WrapLibCode ++{-@ bar :: {v:Int | v = 2 } @-}+bar = foo 1+
+ tests/import/lib/ExactGADT8.hs view
@@ -0,0 +1,32 @@+{-@ LIQUID "--reflection" @-}+{-@ LIQUID "--no-adt"     @-}++{-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-}++--------------------------------------------------------------------------------+module ExactGADT8 where++class PersistEntity record where+    data EntityField record :: * -> *++{-@ data Blob  = Bingo { xVal :: Int, yVal :: Int } @-}+data Blob  = Bingo { xVal :: Int, yVal :: Int }++instance PersistEntity Blob where+  data EntityField Blob typ where+    BlobXVal :: EntityField Blob Int+    BlobYVal :: EntityField Blob Int++data RefinedFilter record typ = RefinedFilter+  { refinedFilterField  :: EntityField record typ+  }++evalQBlob :: RefinedFilter Blob typ -> Blob -> Bool+evalQBlob filter blob = case refinedFilterField filter of+  BlobXVal -> True+  BlobYVal -> True++{-@ reflect foo @-}+foo :: RefinedFilter Blob typ -> Blob -> Bool+foo (RefinedFilter BlobXVal) blob = True+foo (RefinedFilter BlobYVal) blob = True
+ tests/import/lib/FunClashLib.hs view
@@ -0,0 +1,8 @@+module FunClashLib (blob) where++import FunClashLibLib ++{-@ blob :: Nat -> Nat @-} +blob :: Int -> Int +blob = incr +
+ tests/import/lib/FunClashLibLib.hs view
@@ -0,0 +1,6 @@++module FunClashLibLib where + +{-@ incr :: Nat -> Nat @-} +incr :: Int -> Int +incr x = x + 1 
+ tests/import/lib/LibAliasGen00.hs view
@@ -0,0 +1,10 @@+-- Tests that we DON'T generalize type aliases before normalizing++module LibAliasGen00 where++{-@ type Floo a N = {v:[a] | len v = N} @-}++{-@ assume foo :: n:Nat -> Floo Int n @-}+foo :: Int -> [Int]+foo _ = undefined+
+ tests/import/lib/LibBlue.hs view
@@ -0,0 +1,8 @@+module LibBlue where ++data Thing = ThingBlue Int ++{-@ foo :: Int -> Thing @-}+foo :: Int -> Thing +foo = ThingBlue +
+ tests/import/lib/LibRed.hs view
@@ -0,0 +1,8 @@+module LibRed where ++data Thing = ThingRed Int ++{-@ foo :: Int -> Thing @-}+foo :: Int -> Thing +foo = ThingRed +
+ tests/import/lib/LiquidArray.hs view
@@ -0,0 +1,20 @@+module LiquidArray where++{-@ set :: forall a <p :: x0: Int -> x1: a -> Bool, r :: x0: Int -> Bool>.+      i: Int<r> ->+      x: a<p i> ->+      a: (j: {v: Int<r> | v != i} -> a<p j>) ->+      (k: Int<r> -> a<p k>) @-}+set :: Int -> a -> (Int -> a) -> (Int -> a)+set i x a = \k -> if k == i then x else a k++{-@ get :: forall a <p :: x0: Int -> x1: a -> Bool, r :: x0: Int -> Bool>.+             i: Int<r> ->+             a: (j: Int<r> -> a<p j>) ->+             a<p i> @-}+get :: Int -> (Int -> a) -> a+get i a = a i++{-@ empty :: i: {v: Int | 0 = 1} -> a @-}+empty :: Int -> a+empty = const undefined 
+ tests/import/lib/ListLib.hs view
@@ -0,0 +1,31 @@+-- | A module with some definitions for Lists+{-@ LIQUID "--reflection" @-}++module ListLib where++import Prelude hiding (concat, filter, foldr, map)++{-@ reflect map @-}+map :: (a -> b) -> [a] -> [b]+map f []     = []+map f (x:xs) = f x : map f xs++{-@ reflect filter @-}+filter :: (a -> Bool) -> [a] -> [a]+filter f []     = []+filter f (x:xs) = if f x then x : filter f xs else filter f xs++{-@ reflect append @-}+append :: [a] -> [a] -> [a]+append []     ys = ys+append (x:xs) ys = x : append xs ys++{-@ reflect concat @-}+concat :: [[a]] -> [a]+concat []     = []+concat (l:ls) = append l (concat ls)++{-@ reflect foldr @-}+foldr :: (a -> b -> b) -> b -> [a] -> b+foldr f i [ ]    = i+foldr f i (x:xs) = f x (foldr f i xs)
+ tests/import/lib/NameClashLib.hs view
@@ -0,0 +1,7 @@+module NameClashLib where ++data Foo = FooLib Int ++{-@ type FooAlias = {v : Foo | False} @-}+foo :: Foo -> Int +foo _ = 10
+ tests/import/lib/Peano.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE GADTs #-}++{-@ LIQUID "--exact-data-con" @-}+{-@ LIQUID "--higherorder"    @-}+{-@ LIQUID "--ple"            @-}+{-@ LIQUID "--noadt"          @-}+++module Peano where++--------------------------------------------------------------------------------+-- | Peano Numbers -------------------------------------------------------------+--------------------------------------------------------------------------------++{-@ data Peano [toNat] @-}+data Peano where+  Z :: Peano+  S :: Peano -> Peano++{-@ measure toNat @-}+{-@ toNat :: Peano -> Nat @-}+toNat :: Peano -> Int+toNat Z     = 0+toNat (S n) = 1 + toNat n++{-@ reflect plus @-}+plus :: Peano -> Peano -> Peano+plus Z     n = n+plus (S m) n = S (plus m n)++{-@ reflect double @-}+double :: Peano -> Peano+double n = plus n n
+ tests/import/lib/RL1015.hs view
@@ -0,0 +1,18 @@+{-@ LIQUID "--exactdc" @-}+{-@ LIQUID "--higherorder" @-}++module RL1015 where++data Foo = Foo { fooFirst :: Int -> Int , fooSnd :: Int}++{-@ data Foo = Foo { fooFirst :: Int -> Int , fooSnd :: Nat } @-}++{-@ bar :: f:Foo -> { v: a | fooFirst f 0 == 10 } -> Int @-}+bar :: Foo -> a -> Int+bar f _ = 10++{-@ reflect bling @-}+bling :: Int -> Int+bling x = 10++bag = bar (Foo bling 10) (bling 0)
+ tests/import/lib/ReflectLib0.hs view
@@ -0,0 +1,8 @@+module ReflectLib0 where++{-@ inline gtThan @-}+gtThan :: Int -> Int -> Bool+gtThan x y = x > y+++{-@ predicate GreaterThanA X Y = X > Y @-}
+ tests/import/lib/ReflectLib1.hs view
@@ -0,0 +1,6 @@+module ReflectLib1 where++{-@ measure isNull @-}+isNull :: [a] -> Bool+isNull []     = True+isNull (x:xs) = False
+ tests/import/lib/ReflectLib2.hs view
@@ -0,0 +1,28 @@+{-@ LIQUID "--higherorder" @-}++module ReflectLib2 where++{-@ reflect incr @-}+incr :: Int -> Int+incr x = x + 1++{-@ reflect incr2 @-}+incr2 :: Int -> Int -> Int+incr2 x y = x + y++{-@ reflect plus @-}+plus :: Int -> Int+plus x = apply incr x++{-@ reflect apply @-}+apply :: (a -> b) -> a -> b+apply f x = f x++{-@ reflect toNat @-}+toNat :: Int -> Int+{-@ toNat :: Nat -> Nat @-}+toNat n = if n == 0 then 0 else (1 + toNat (n - 1))+++{-@ myproof :: a -> { v: Int | incr 5 == 6 } @-}+myproof _ = incr 5
+ tests/import/lib/ReflectLib3.hs view
@@ -0,0 +1,26 @@+{-@ LIQUID "--reflection" @-}+{-@ LIQUID "--ple"        @-} ++module ReflectLib3 where++import Language.Haskell.Liquid.ProofCombinators++-- | Days ---------------------------------------------------------------------++{-@ data Day = Mon | Tue @-}+data Day = Mon | Tue++{-@ reflect next @-}+next :: Day -> Day+next Mon = Tue+next Tue = Mon++-- | Lists ---------------------------------------------------------------------++{-@ data List  a = Nil | Cons {lHd :: a} @-}+data List a = Nil | Cons a++{-@ reflect lDay @-}+lDay :: List a -> Day+lDay Nil      = Mon+lDay (Cons x) = Tue
+ tests/import/lib/ReflectLib4.hs view
@@ -0,0 +1,31 @@+{-@ LIQUID "--reflection" @-}+{-@ LIQUID "--ple"        @-}++module ReflectLib4 where++-- | Lists ---------------------------------------------------------------------++{-@ data List [llen] @-} +data List a = Nil | Cons {lHd :: a, lTl :: List a} ++{-@ measure llen @-}+{-@ llen :: List a -> Nat @-}+llen :: List a -> Int+llen Nil        = 0+llen (Cons h t) = 1 + llen t++-- TODO: make this work WITHOUT the invariant+{- invariant {v:List a | 0 <= llen v} @-}++{-@ reflect app @-}+app :: List a -> List a -> List a+app Nil         ys = ys+app (Cons x xs) ys = Cons x (app xs ys)++{-@ reflect gapp @-}+gapp :: List a -> List a+gapp Nil         = Nil+gapp (Cons x xs) = Nil++{-@ test4 :: { gapp Nil = Nil } @-}+test4 = ()
+ tests/import/lib/ReflectLib5.hs view
@@ -0,0 +1,31 @@+{-@ LIQUID "--reflection" @-}+{-@ LIQUID "--ple"        @-}++module ReflectLib5 where++-- | Days ---------------------------------------------------------------------++{-@ data Day = Mon | Tue @-}+data Day = Mon | Tue++{-@ reflect next @-}+next :: Day -> Day+next Mon = Tue+next Tue = Mon++{-@ reflect lDay @-}+lDay :: List a -> Day+lDay Nil      = Mon+lDay (Cons x) = Tue++-- | Lists ---------------------------------------------------------------------++data List  a = Nil | Cons {lHd :: a}++{-@ reflect gapp @-}+gapp :: List a -> List a+gapp Nil      = Nil+gapp (Cons x) = Cons x++{-@ test4 :: { gapp Nil = Nil } @-}+test4 = ()
+ tests/import/lib/ReflectLib6.hs view
@@ -0,0 +1,14 @@+{-@ LIQUID "--reflection" @-} +{-@ LIQUID "--ple" @-} ++module ReflectLib6 where++data Day = Mon | Tue++{-@ reflect next @-}+next :: Day -> Day+next Mon = Tue+next Tue = Mon++{-@ testFAIL :: { next Mon == Tue } @-}+testFAIL = ()
+ tests/import/lib/ReflectLib7.hs view
@@ -0,0 +1,8 @@+{-@ LIQUID "--higherorder"    @-}+{-@ LIQUID "--exactdc"        @-}++module ReflectLib7 where++{-@ reflect compose @-}+compose :: (b -> c) -> (a -> b) -> a -> c+compose f g x = f (g x)
+ tests/import/lib/ReflectLib8.hs view
@@ -0,0 +1,11 @@+-- By Zack Grannan at https://github.com/ucsd-progsys/liquidhaskell/pull/1646++{-@ LIQUID "--reflection" @-}+module ReflectLib8 where++{-@ reflect choose @-}+choose _ b = b++{-@ reflect chooseF @-}+chooseF f g x =+  choose (f x) (g x)
+ tests/import/lib/RewriteLib.hs view
@@ -0,0 +1,18 @@+{-@ LIQUID "--reflection" @-}+{-@ LIQUID "--ple"        @-}++{-@ infix ++ @-}++module RewriteLib where+import Prelude hiding ((++))++{-@ reflect ++ @-}+(++)::[a] -> [a] -> [a]+[]     ++ ys = ys+(x:xs) ++ ys = x:(xs ++ys)++{-@ assoc :: xs:[a] -> ys:[a] -> zs:[a]+          -> { xs ++ (ys ++ zs) == (xs ++ ys) ++ zs } @-}+assoc :: [a] -> [a] -> [a] -> ()+assoc [] _ _       = ()+assoc (_:xs) ys zs = assoc xs ys zs
+ tests/import/lib/STLib.hs view
@@ -0,0 +1,43 @@+-- TAG: classes +-- TAG: bounds ++{-@ LIQUID "--no-pattern-inline" @-}++module STLib where++data ST s a = S {runSt :: s -> (a, s) }++{-@ data ST s a <pre :: s -> Bool, post :: a -> s -> Bool>+       = S { runSt :: (x:s<pre> -> ((a, s)<post>)) }+  @-}++{-@ apply :: forall <p :: s -> Bool, q :: a -> s -> Bool>.+               ST <p, q> s a -> s<p> -> (a, s)<q>+  @-}+apply :: ST s a -> s -> (a, s)+apply (S f) s = f s++instance Functor (ST s) where+  fmap = undefined++instance Applicative (ST s) where+  pure  = undefined+  (<*>) = undefined++instance Monad (ST s) where+  {-@ instance Monad (ST s) where+        return :: forall <p :: a -> s -> Bool>. x:a -> ST <{v:s<p x>| true}, p, {v:a | true}> s a ;+        >>=    :: forall <pbind :: s -> Bool, qbind :: a -> s -> Bool, rbind :: b -> s -> Bool>.+                                  ST <pbind, qbind> s a+                              -> (xbind:a -> ST <{v:s<qbind xbind> | true}, rbind> s b)+                              -> ST <pbind, rbind> s b;+        >>    :: forall <pbind :: s -> Bool, qbind :: a -> s -> Bool, rbind :: b -> s -> Bool>.+                                 ST <pbind, qbind> s a+                              -> (ST <{v:s| true}, rbind> s b)+                              -> ST <pbind, rbind> s b+    @-}+  return x    = S $ \s -> (x, s)+  (S m) >> k  = S $ \s -> let (a, s') = m s in apply k s'+  (S m) >>= k = S $ \s -> let (a, s') = m s in apply (k a) s'++
+ tests/import/lib/T1096_Types.hs view
@@ -0,0 +1,13 @@+{-@ LIQUID "--no-termination" @-}++module T1096_Types where++data Foo = A Foo | B ++size :: Foo -> Integer ++{-@ measure size @-}+{- invariant {t:Foo | 0 <= size t} @-}+{-@ size :: Foo -> {v:Integer |  0 <= v }  @-}+size (A x) = 1 + size x+size B     = 0 
+ tests/import/lib/T1102_LibX.hs view
@@ -0,0 +1,11 @@+{-@ LIQUID "--exact-data-con" @-}++module T1102_LibX where++import T1102_LibY +-- import T1102_LibZ +-- zink = fooA ++{-@ theorem :: x:Bar -> {bar x = bar x} @-}+theorem :: Bar -> ()+theorem _ = ()
+ tests/import/lib/T1102_LibY.hs view
@@ -0,0 +1,11 @@+{-@ LIQUID "--exact-data-con" @-}++module T1102_LibY where ++import T1102_LibZ ++data Bar = Bar {barFoo :: Foo Int Int} ++{-@ reflect bar @-}+bar :: Bar -> Int +bar (Bar (Foo x _)) = x 
+ tests/import/lib/T1102_LibZ.hs view
@@ -0,0 +1,6 @@+{-@ LIQUID "--exact-data-con" @-}++module T1102_LibZ where++{-@ data Foo a b = Foo { fooA :: a, fooB :: b} @-}+data Foo a b = Foo {fooA :: a, fooB :: b}
+ tests/import/lib/T1104Lib.hs view
@@ -0,0 +1,19 @@+module T1104Lib where ++data Foo a b = Foo {fooA :: a, fooB :: b}  |  Bar++{-@ measure isFoo @-}+isFoo :: Foo a b -> Bool+isFoo (Foo _ _) = True +isFoo Bar       = False ++{-@ measure toNat @-}+{-@ toNat :: Foo a b -> Nat @-} +toNat :: Foo a b -> Int +toNat (Foo _ _) = 10 +toNat Bar       = 20 ++{-@ twerp :: x:(Foo a b) -> {v:Bool | v = isFoo x} @-}+twerp x = g x+  where +    g = isFoo
+ tests/import/lib/T1112.hs view
@@ -0,0 +1,19 @@++{-@ LIQUID "--higherorder"    @-}+{-@ LIQUID "--exact-data-con" @-}++module T1112 where++import T1112Lib++{- data Product @-}++{-@ axiomatize leqProd @-}+leqProd :: Eq (f p)+        => (f p -> f p -> Bool) -> (g p -> g p -> Bool)+        -> Product f g p -> Product f g p -> Bool+leqProd leqFP leqGP (Product x1 y1) (Product x2 y2) =+  if x1 == x2+    then leqGP y1 y2+    else leqFP x1 x2+{-# INLINE leqProd #-}
+ tests/import/lib/T1112Lib.hs view
@@ -0,0 +1,3 @@+module T1112Lib where++data Product f g p = Product (f p) (g p) deriving Eq
+ tests/import/lib/T1117Lib.hs view
@@ -0,0 +1,8 @@+{-@ LIQUID "--higherorder"        @-}+{-@ LIQUID "--exactdc"            @-}++module T1117Lib where++data U1 p = U1++data Product f g p = Product (f p) (g p)
+ tests/import/lib/T1118Lib1.hs view
@@ -0,0 +1,7 @@+{-@ LIQUID "--higherorder"        @-}+{-@ LIQUID "--exactdc"            @-}+module T1118Lib1 where++import T1118Lib2 ++{- data Product @-}
+ tests/import/lib/T1118Lib2.hs view
@@ -0,0 +1,4 @@+module T1118Lib2 where++data U1 p = U1+data Product f g p = Product (f p) (g p)
+ tests/import/lib/T1688Lib.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE GADTs #-}++{-@ LIQUID "--reflection"  @-}++module T1688Lib where++type Vname = Int++{-@ measure propOf :: a -> b @-}+{-@ type ProofOf E = { proofObj:_ | propOf proofObj = E } @-}++data Expr = Bc Bool                   -- True, False+          | Ic Int                    -- 0, 1, 2, ...+          | Lambda Int Expr         -- \x.e          abstractions+          | App Expr Expr             -- e e'          applications++data Basic = TBool         -- Bool+           | TInt          -- Int++data StepProp where+    Step :: Expr -> Expr -> StepProp++data StepProof where+    EFake :: Vname -> Expr -> Expr -> StepProof++{-@ data StepProof where+    EFake :: x:Vname -> e:Expr -> v:_ -> ProofOf( Step (App (Lambda x e) v) e)+  @-}
+ tests/import/lib/WrapLib.hs view
@@ -0,0 +1,6 @@+module WrapLib ( module WrapLibCode ) where ++import WrapLibCode++{-@ assume WrapLibCode.foo :: x:Nat -> {v:Nat | v = x + 1}  @-}+
+ tests/import/lib/WrapLibCode.hs view
@@ -0,0 +1,4 @@+module WrapLibCode (foo) where++foo :: Int -> Int +foo x = x + 1
tests/neg/Automate.hs view
@@ -1,6 +1,5 @@+{-@ LIQUID "--ple-local" @-} module Automate where--{-@ LIQUID "--automatic-instances=smtinstances" @-}  import Language.Haskell.Liquid.ProofCombinators  
tests/neg/CastedTotality.hs view
@@ -1,7 +1,5 @@ module Fixme where -{-@ LIQUID "--totality" @-}- import Language.Haskell.Liquid.Prelude  main = show x
tests/neg/Class1.hs view
@@ -31,8 +31,8 @@  instance Sized List where   {-@ instance measure sz :: List a -> Int-      sz (Nil)       = 0-      sz (Cons x xs) = 1 + (sz xs)+        sz (Nil)       = 0+        sz (Cons x xs) = 1 + (sz xs)     @-}   size = length 
tests/neg/Class2.hs view
@@ -14,8 +14,8 @@  instance Sized [] where   {-@ instance measure sz :: [a] -> Int-      sz ([])   = 0-      sz (x:xs) = 1 + (sz xs)+        sz ([])   = 0+        sz (x:xs) = 1 + (sz xs)     @-}    size []     = 0
tests/neg/Class3.hs view
@@ -19,8 +19,8 @@  instance Sized List where   {-@ instance measure sz :: List a -> Int-      sz (Nil)       = 0-      sz (Cons x xs) = 1 + (sz xs)+        sz (Nil)       = 0+        sz (Cons x xs) = 1 + (sz xs)     @-}   size Nil         = 0   size (Cons x xs) = size xs
tests/neg/ExactADT6.hs view
@@ -3,6 +3,8 @@  {-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-} +module ExactADT6 where+ {-@ data EntityField typ where         BlobXVal :: EntityField {v:Int | v >= 0}       | BlobYVal :: EntityField Int@@ -33,4 +35,3 @@ -- BAD testUpdateQueryFail :: () -> Update Int testUpdateQueryFail () = createUpdate BlobXVal (-1)-
tests/neg/ExactGADT6.hs view
@@ -3,13 +3,15 @@  {-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-} +module ExactGADT6 where+ class PersistEntity record where-    data EntityField record :: * -> *+    data EntityField record typ :: *  instance PersistEntity Blob where     {-@ data EntityField Blob typ where-        BlobXVal :: EntityField Blob {v:Int | v >= 0}-      | BlobYVal :: EntityField Blob Int+           BlobXVal :: EntityField Blob {v:Int | v >= 0}+         | BlobYVal :: EntityField Blob Int     @-}     data EntityField Blob typ where         BlobXVal :: EntityField Blob Int@@ -33,4 +35,3 @@  testUpdateQueryFail :: () -> Update Blob Int testUpdateQueryFail () = createUpdate BlobXVal (-1)-
+ tests/neg/Fail.hs view
@@ -0,0 +1,12 @@+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)
+ tests/neg/Fail1.hs view
@@ -0,0 +1,7 @@+module Fail 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 
tests/neg/FunctionRef.hs view
@@ -1,5 +1,5 @@ {-@ LIQUID "--higherorder"     @-}-{-@ LIQUID "--totality"        @-}+module HigherOrder where  {-@ measure ackF :: Int -> Int -> Int  @-} 
tests/neg/HigherOrder.hs view
@@ -1,4 +1,5 @@ {-@ LIQUID "--higherorder" @-}+module HigherOrder where   {-@ foo :: a: Int -> f: (Int -> Int) -> {v : Int | v = 123 + (f a) } @-}
tests/neg/ListConcat.hs view
@@ -5,8 +5,8 @@ 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) }+      llElts([])   = {v | Set_emp v }+      llElts(x:xs) = {v | v = Set_cup (listElts x) (llElts xs) }   @-}  
tests/neg/ListKeys.hs view
@@ -4,8 +4,8 @@ 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) }+      listKeys([])   = {v | Set_emp v }+      listKeys(x:xs) = {v | v = Set_cup (Set_sng (fst x)) (listKeys xs) }   @-}  
− tests/neg/ListRange.dat 
@@ -1,1 +0,0 @@-data List a << p:a (fld:a)>> = Nil | Cons x:a^True y:List a^p(x) << p(fld) >> --
tests/neg/NoMethodBindingError.hs view
@@ -1,7 +1,5 @@ module Foo where -{-@ LIQUID "--totality" @-}- class Foo a where   foo :: a -> a 
tests/neg/PairMeasure.hs view
@@ -1,5 +1,7 @@ module Foo () where +{-@ LIQUID "--bscope" @-}+ {-@ measure getfst :: (a, b) -> a     getfst (x, y) = x   @-}
+ tests/neg/ReWrite.hs view
@@ -0,0 +1,19 @@+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)
+ tests/neg/ReWrite2.hs view
@@ -0,0 +1,25 @@+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)
+ tests/neg/ReWrite3.hs view
@@ -0,0 +1,24 @@+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)
+ tests/neg/ReWrite4.hs view
@@ -0,0 +1,32 @@+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' _ _ = ()+
tests/neg/StateConstraints0.hs view
@@ -13,7 +13,7 @@ data ST s a = ST {runState :: s -> (a,s)}  {-@ data ST s a <p :: s -> Bool, q :: s -> s -> Bool, r :: s -> a -> Bool>-  = ST (runState :: x:s<p> -> (a<r x>, s<q x>)) @-}+      = ST (runState :: x:s<p> -> (a<r x>, s<q x>)) @-}  {-@ runState :: forall <p :: s -> Bool, q :: s -> s -> Bool, r :: s -> a -> Bool>. ST <p, q, r> s a -> x:s<p> -> (a<r x>, s<q x>) @-} @@ -25,35 +25,35 @@  instance Monad (ST s) where   {-@ instance Monad ST s where-    return :: forall s a <p :: s -> Bool >. x:a -> ST <p, {\s v -> 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<pre> |- a<rg x> <: a<pref0>}-       {x::s<pre>, y::s<postg x> |- b<rf y> <: b<r x>}-       {xx::s<pre>, w::s<postg xx> |- s<postf w> <: s<post xx>}-       {ww::s<pre> |- s<postg ww> <: s<pref>}-       (ST <pre, postg, rg> s a)-    -> (a<pref0> -> ST <pref, postf, rf> s b)-    -> (ST <pre, post, r> 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<pre>, y::s<postg x> |- b<rf y> <: b<r x>}-       {xx::s<pre>, w::s<postg xx> |- s<postf w> <: s<post xx>}-       {ww::s<pre> |- s<postg ww> <: s<pref>}-       (ST <pre, postg, rg> s a)-    -> (ST <pref, postf, rf> s b)-    -> (ST <pre, post, r> s b)+        return :: forall s a <p :: s -> Bool >. x:a -> ST <p, {\s v -> 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<pre> |- a<rg x> <: a<pref0>}+           {x::s<pre>, y::s<postg x> |- b<rf y> <: b<r x>}+           {xx::s<pre>, w::s<postg xx> |- s<postf w> <: s<post xx>}+           {ww::s<pre> |- s<postg ww> <: s<pref>}+           (ST <pre, postg, rg> s a)+          -> (a<pref0> -> ST <pref, postf, rf> s b)+          -> (ST <pre, post, r> 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<pre>, y::s<postg x> |- b<rf y> <: b<r x>}+           {xx::s<pre>, w::s<postg xx> |- s<postf w> <: s<post xx>}+           {ww::s<pre> |- s<postg ww> <: s<pref>}+           (ST <pre, postg, rg> s a)+          -> (ST <pref, postf, rf> s b)+          -> (ST <pre, post, r> s b)      @-}   return x     = ST $ \s -> (x, s)
tests/neg/StateConstraints00.hs view
@@ -9,7 +9,7 @@ data ST s a = ST {runState :: s -> (a,s)}  {-@ data ST s a <r :: a -> Bool>-  = ST (runState :: x:s -> (a<r>, s)) @-}+      = ST (runState :: x:s -> (a<r>, s)) @-}  {-@ runState :: forall <r :: a -> Bool>. ST <r> s a -> x:s -> (a<r>, s) @-} @@ -20,7 +20,7 @@  instance Foo (ST s) where   {-@ instance Foo ST s where-    return :: forall s a. x:a -> ST <{\v -> x == v}> s a+        return :: forall s a. x:a -> ST <{\v -> x == v}> s a     @-}   return x     = ST $ \s -> (x, s) 
− tests/neg/Sumk.hquals 
@@ -1,2 +0,0 @@-qualif PPLUS0(v:int): v >= ~A + ~B-qualif PPLUS1(v:int): v > ~A + ~B
− tests/neg/T1013A.hs 
@@ -1,62 +0,0 @@-{-@ LIQUID "--reflection"  @-}-{-@ LIQUID "--no-adt"      @-} -- TODO: embed HKTs in SMTLIB2 ADTs (e.g. `Rec`)--{-# LANGUAGE RankNTypes #-}--module Bug 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)
tests/neg/T1095C.hs view
@@ -1,4 +1,4 @@-{-@ LIQUID "--no-case-expand" @-}+{-@ LIQUID "--max-case-expand=0" @-} {-@ LIQUID "--no-termination" @-}  module Foo where
tests/neg/T1267.hs view
@@ -1,5 +1,4 @@-{- LIQUID "--max-case-expand=0" @-}-{-@ LIQUID "--no-case-expand" @-}+{-@ LIQUID "--max-case-expand=0" @-}  module NoCaseExpand where 
tests/neg/T1288.hs view
@@ -1,3 +1,4 @@+module T1288 where  {-@ measure foo @-} foo :: () -> Int
− tests/neg/T1440.hs 
@@ -1,11 +0,0 @@-{-@ LIQUID "--typed-holes" @-}--module Hole where --incr :: Int -> Int -{-@ incr :: x:Int -> {v:Int | x < v } @-} -incr = _incr --{-@ mymap :: (a -> b) -> xs:[a] -> {v:[b] | len v == len xs} @-}-mymap :: (a -> b) -> [a] -> [b]-mymap = _map
+ tests/neg/T1490.hs view
@@ -0,0 +1,25 @@+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
+ tests/neg/T1490A.hs view
@@ -0,0 +1,28 @@+module Repro2 () 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
+ tests/neg/T1553.hs view
@@ -0,0 +1,23 @@+{-@ LIQUID "--reflection" @-}++module Example  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 () 
+ tests/neg/T1553A.hs view
@@ -0,0 +1,13 @@+{-@ LIQUID "--reflection"     @-}+{-@ LIQUID "--extensionality" @-}++module Example  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 (\_ -> ())
+ tests/neg/T1555.hs view
@@ -0,0 +1,16 @@+{-@ LIQUID "--reflection" @-}+{-@ LIQUID "--rankNTypes" @-}+{-# LANGUAGE RankNTypes   #-}++module Theorems 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 + 
+ tests/neg/T1577.hs view
@@ -0,0 +1,33 @@+{-@ 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 _ _ = ()
+ tests/neg/T1604.hs view
@@ -0,0 +1,22 @@+{-@ 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 () = ()
+ tests/neg/T1613.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE RankNTypes #-}+{-@ LIQUID "--reflection" @-}+module Subclass2 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
+ tests/neg/T1642A.hs view
@@ -0,0 +1,32 @@+{-@ LIQUID "--reflection" @-} ++{-# LANGUAGE RankNTypes     #-}+{-# LANGUAGE GADTs          #-}+{-# LANGUAGE KindSignatures #-}++module RefinedEquality 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)  
+ tests/neg/T1657.hs view
@@ -0,0 +1,15 @@+module T1657 where++{-@ data I <p :: Int -> Bool> = I _ @-}+data I = I Int++{-@ getI :: forall <p :: Int -> Bool>. +             { {x: Int<p> | True} <: {x:Int | x > 0} }+             I <p>+@-}+getI :: I+getI = I 7  ++{-@ shouldPass :: I<{\z -> true}> @-}+shouldPass :: I+shouldPass = getI
+ tests/neg/T1657A.hs view
@@ -0,0 +1,17 @@+module T1657A where++{-@ data I <pigbert :: Int -> Bool> = I Int @-}++data I = I Int+{-@ getI :: forall <pp :: Int -> Bool>. +             { bloop :: Int <pp> |- {v: Int | v = bloop} <: {v:Int | v > 1984} }+             I <pp>+@-}+getI :: I+getI = undefined ++-- { {v: (Int<p>) | True} <: {v:Int | v > 1984} }++{-@ pleaseFail :: I<{\_ -> True}> @-}+pleaseFail :: I+pleaseFail = getI
+ tests/neg/T1659.hs view
@@ -0,0 +1,30 @@+{-@ 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 = ()
tests/neg/Variance1.hs view
@@ -1,3 +1,5 @@+module Variance1 where+ import Data.Binary  
tests/neg/ex1-unsafe.hs view
@@ -13,8 +13,8 @@ -- | 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)+      llen (Nil)       = 0+      llen (Cons x xs) = 1 + llen(xs)   @-}  
tests/neg/listne.hs view
@@ -1,3 +1,4 @@+module ListNe where  {-@ type ListNE a = {v:[a] | 0 < len v} @-} 
tests/neg/test00c.hs view
@@ -8,7 +8,7 @@   {-@ ok-    :: Int -> Nat+      :: Int -> Nat   @-} ok :: Int -> Int ok x = x + 120
tests/pos/Cat.hs view
@@ -1,6 +1,9 @@ {-@ LIQUID "--no-totality" @-}  {-# LANGUAGE GADTs #-}++module Cat where+ import Control.Category import Prelude hiding ((.), id) 
tests/pos/Chunks.hs view
@@ -8,10 +8,10 @@ {-@ 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))            +      = 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] @-}
tests/pos/ClassReg.hs view
@@ -6,7 +6,7 @@ data ST s a = ST {runState :: s -> (a,s)}  {-@ data ST s b <r :: s -> b -> Bool> -  = ST (runState :: x:s -> (b<r x>, s)) @-}+      = ST (runState :: x:s -> (b<r x>, s)) @-}   class MM m where
tests/pos/CountMonad.hs view
@@ -25,7 +25,6 @@   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-  fail          = error   
tests/pos/DB00.hs view
@@ -5,7 +5,7 @@ module DataBase (values) where  {-@ values :: forall <rr2 :: key -> val -> Bool>.-  k:key -> [Dict <rr2> key val]  -> [val<rr2 k>] @-}+      k:key -> [Dict <rr2> key val]  -> [val<rr2 k>] @-} values :: key -> [Dict key val]  -> [val] values k = map (go k)   where@@ -16,6 +16,6 @@ data Dict key val = D {ddom :: [key], dfun :: key -> val}  {-@ data Dict key val <rr :: key -> val -> Bool>-  = D ( ddom :: [key])-      ( dfun :: i:key -> val<rr i>)+      = D ( ddom :: [key])+          ( dfun :: i:key -> val<rr i>)   @-}
tests/pos/DependentPairsFun.hs view
@@ -2,7 +2,7 @@   {-@ ex :: (y::Int, () -> {v:() | 0 < y } )-  -> (y::Int, {v:() | 0 < y})+      -> (y::Int, {v:() | 0 < y}) @-} ex ::(Int,() -> ()) -> (Int,()) ex (y, pxToqxy) =  (y,pxToqxy ())
− tests/pos/Deptup1.pred 
@@ -1,1 +0,0 @@-assumep mkPair :: forall a b. forAll p:b(fld:a). a -> b -> Pair a b <<p>>
tests/pos/ExactADT6.hs view
@@ -3,6 +3,8 @@  {-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-} +module ExactADT6 where+ {-@ data EntityField typ where         BlobXVal :: EntityField {v:Int | v >= 0}       | BlobYVal :: EntityField Int@@ -15,4 +17,3 @@ {-@ blobXVal :: EntityField {v:Int | v >= 0} @-} blobXVal :: EntityField Int blobXVal = BlobXVal-
tests/pos/ExactGADT6.hs view
@@ -3,13 +3,15 @@  {-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-} +module ExactGADT6 where+ class PersistEntity record where-    data EntityField record :: * -> *+    data EntityField record ty :: *  instance PersistEntity Blob where     {-@ data EntityField Blob typ where-        BlobXVal :: EntityField Blob {v:Int | v >= 0}-      | BlobYVal :: EntityField Blob Int+            BlobXVal :: EntityField Blob {v:Int | v >= 0}+          | BlobYVal :: EntityField Blob Int     @-}     data EntityField Blob typ where         BlobXVal :: EntityField Blob Int
+ tests/pos/Fail.hs view
@@ -0,0 +1,11 @@+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 _ = () 
tests/pos/FingerTree.hs view
@@ -1,4 +1,3 @@-{- LIQUID "--no-termination" @-} {-@ LIQUID "--reflection"     @-} {-@ LIQUID "--no-adt"         @-} {-@ LIQUID "--ple"            @-}
tests/pos/GhcSort2.hs view
@@ -18,9 +18,9 @@ mergesort' xss = mergesort' (merge_pairs xss)  {-@ predicate DLen X Y = -    (if ((len X) > 1) -     then ((len Y) < (len X)) -     else ((len X) = (len 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)} @-}
tests/pos/GoodHMeas.hs view
@@ -11,3 +11,6 @@  {-@ bar :: xs:[(Int, Int)] -> {v:Int | v == foo xs } @-} bar x = foo x++main :: IO ()+main = pure ()
tests/pos/Hutton.hs view
@@ -2,9 +2,8 @@  module Hutton where -{-@ LIQUID "--higherorder"    @-}-{-@ LIQUID "--exact-data-con" @-}-{-@ LIQUID "--ple" @-}+{-@ LIQUID "--reflection" @-}+{-@ LIQUID "--ple"        @-}  import Language.Haskell.Liquid.ProofCombinators 
tests/pos/LambdaDeBruijn.hs view
@@ -38,7 +38,7 @@   {-@ subst :: e:Expr -> su:Subst -> MEVar e su-    / [ (if (isEVar e) then 0 else 1), (if (isRenaming su) then 0 else 1), elen e] @-}+      / [ (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
tests/pos/ListISort-perm.hs view
@@ -36,8 +36,8 @@   | Cons { lHd :: a, lTl :: List a }  {-@ data List [llen] a <p :: x0:a -> x1:a -> Bool>-  = Nil-  | Cons { lHd :: a, lTl :: List <p> (a <p lHd>) }+      = Nil+      | Cons { lHd :: a, lTl :: List <p> (a <p lHd>) }   @-}  -- | List Membership -----------------------------------------------------------@@ -50,12 +50,12 @@   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))+        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))+      | 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 --------------------------------------------------------------@@ -68,11 +68,11 @@   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)+        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)   @-}  
tests/pos/LogicCurry1.hs view
@@ -12,3 +12,5 @@ {-@ bar :: n:Int -> {v:_ | v == ackF n } @-} bar m = ack m +main :: IO ()+main = pure ()
tests/pos/MapFusion.hs view
@@ -1,11 +1,5 @@-{-@ LIQUID "--higherorder"     @-}-{-@ LIQUID "--exact-data-cons" @-}--{-@ LIQUID "--ple" @-}--{-# LANGUAGE IncoherentInstances #-}-{-# LANGUAGE FlexibleContexts    #-}-+{-@ LIQUID "--reflection"     @-}+{-@ LIQUID "--ple"            @-}  module MapFusion where 
tests/pos/MapReduceVerified.hs view
@@ -176,7 +176,7 @@  -- | For input Distribution  {-@ appendTakeDrop :: i:Nat -> xs:{List a | i <= llen xs} -  -> {xs == append (take i xs) (drop i xs) }  @-}+      -> {xs == append (take i xs) (drop i xs) }  @-}  appendTakeDrop :: Int -> List a -> Proof  appendTakeDrop i N 
tests/pos/Measures.hs view
@@ -1,7 +1,7 @@ module Measures where  {-@ data Wrapper a <p :: a -> Bool, r :: a -> a -> Bool > -    = Wrap (rgref_ref :: a<p>) @-}+      = Wrap (rgref_ref :: a<p>) @-} data Wrapper a = Wrap (a)  -- Two measures
tests/pos/Measures1.hs view
@@ -1,7 +1,7 @@ module Measures where  {-@ data Wrapper a <p :: a -> Bool, r :: a -> a -> Bool > -    = Wrap (rgref_ref :: a<p>) @-}+      = Wrap (rgref_ref :: a<p>) @-} data Wrapper a = Wrap (a)  -- Two measures
tests/pos/MutuallyDependentADT.hs view
@@ -12,3 +12,6 @@ {-@ tsize :: Term l -> Nat @-} tsize (TPred _)            = 0 tsize (TTerm _)            = 0++main :: IO ()+main = pure ()
tests/pos/PairMeasure.hs view
@@ -2,6 +2,7 @@ -- TAG: measure  module Foo () where+{-@ LIQUID "--bscope" @-}  {-@ measure getfst :: (a, b) -> a     getfst (x, y) = x
tests/pos/PairMeasure0.hs view
@@ -1,5 +1,7 @@ module Foo () where +{-@ LIQUID "--bscope" @-}+ {-@ measure getfst :: (a, b) -> a     getfst (x, y) = x   @-}
tests/pos/PromotedDataCons.hs view
@@ -1,6 +1,8 @@  {-# LANGUAGE DataKinds #-} +module PromotedDataCons where+ newtype Offset struct member = Offset { unOffset :: Int }  type OffsetN t = Offset (t 'Nothing)
+ tests/pos/ReWrite.hs view
@@ -0,0 +1,45 @@+module ReWrite where ++{-@ LIQUID "--max-rw-ordering-constraints=1" @-}+{-@ 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)
+ tests/pos/ReWrite10.hs view
@@ -0,0 +1,29 @@+module ReWrite10 where++{-@ LIQUID "--reflection" @-}+{-@ LIQUID "--ple" @-}+{-@ LIQUID "--rw-termination-check" @-}+{-@ infix ++ @-}++import Prelude hiding (length, (++))++data N = S N | Z+++{-@ reflect f @-}+f :: N -> N+f x = g x++{-@ 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 _ = ()+
+ tests/pos/ReWrite2.hs view
file too large to diff
+ tests/pos/ReWrite3.hs view
file too large to diff
+ tests/pos/ReWrite4.hs view
file too large to diff
+ tests/pos/ReWrite5.hs view
file too large to diff
+ tests/pos/ReWrite6.hs view
file too large to diff
+ tests/pos/ReWrite7.hs view
file too large to diff
+ tests/pos/ReWrite8.hs view
file too large to diff
+ tests/pos/ReWrite9.hs view
file too large to diff
tests/pos/RefinedADTs.hs view
file too large to diff
tests/pos/StateConstraints.hs view
file too large to diff
tests/pos/StateConstraints0.hs view
file too large to diff
tests/pos/StateConstraints00.hs view
file too large to diff
tests/pos/StructRec.hs view
file too large to diff
+ tests/pos/T1013A.hs view
file too large to diff
− tests/pos/T1045.hs-boot 
file too large to diff
tests/pos/T1074.hs view
file too large to diff
tests/pos/T1085.hs view
file too large to diff
tests/pos/T1092.hs view
file too large to diff
tests/pos/T1100.hs view
file too large to diff
tests/pos/T1126.hs view
file too large to diff
tests/pos/T1288.hs view
file too large to diff
tests/pos/T1289a.hs view
file too large to diff
tests/pos/T1363.hs view
file too large to diff
tests/pos/T1461.hs view
file too large to diff
tests/pos/T1498.hs view
file too large to diff
+ tests/pos/T1547.hs view
file too large to diff
+ tests/pos/T1548.hs view
file too large to diff
+ tests/pos/T1550.hs view
file too large to diff
+ tests/pos/T1555.hs view
file too large to diff
+ tests/pos/T1556.hs view
file too large to diff
+ tests/pos/T1560.hs view
file too large to diff
+ tests/pos/T1560B.hs view
file too large to diff
+ tests/pos/T1567.hs view
file too large to diff
+ tests/pos/T1568.hs view
file too large to diff
+ tests/pos/T1571.hs view
file too large to diff
+ tests/pos/T1577.hs view
file too large to diff
+ tests/pos/T1593.hs view
file too large to diff
+ tests/pos/T1595.hs view
file too large to diff
+ tests/pos/T1597.hs view
file too large to diff
+ tests/pos/T1603.hs view
file too large to diff
+ tests/pos/T1633.hs view
file too large to diff
+ tests/pos/T1634.hs view
file too large to diff
+ tests/pos/T1636.hs view
file too large to diff
+ tests/pos/T1642.hs view
file too large to diff
+ tests/pos/T1642A.hs view
file too large to diff
+ tests/pos/T1647.hs view
file too large to diff
+ tests/pos/T1649MeasuresDef.hs view
file too large to diff
+ tests/pos/T1649WorkTypes.hs view
file too large to diff
+ tests/pos/T1657.hs view
file too large to diff
+ tests/pos/T1660.hs view
file too large to diff
+ tests/pos/T1669.hs view
file too large to diff
+ tests/pos/T1670A.hs view
file too large to diff
+ tests/pos/T1670B.hs view
file too large to diff
+ tests/pos/T1709.hs view
file too large to diff
tests/pos/T385.hs view
file too large to diff
tests/pos/T598.hs view
file too large to diff
tests/pos/T716.hs view
file too large to diff
tests/pos/T819A.hs view
file too large to diff
tests/pos/T820.hs view
file too large to diff
tests/pos/VerifiedNum.hs view
file too large to diff
tests/pos/Words.hs view
file too large to diff
tests/pos/anfbug.hs view
file too large to diff
tests/pos/go_ugly_type.hs view
file too large to diff
tests/pos/maybe4.hs view
file too large to diff
tests/pos/mutrec.hs view
file too large to diff
tests/pos/selfList.hs view
file too large to diff
tests/pos/transpose.hs view
file too large to diff
tests/test.hs view
file too large to diff