packages feed

liquidhaskell 0.8.2.4 → 0.8.6.0

raw patch · 591 files changed

+18428/−34566 lines, 591 filesdep +githashdep +hintdep −Cabaldep −QuickCheckdep −arraydep ~aesondep ~basedep ~bytestringnew-component:exe:gradualnew-component:exe:targetbinary-added

Dependencies added: githash, hint

Dependencies removed: Cabal, QuickCheck, array, bifunctors, exceptions, hpc, located-base, text-format, th-lift

Dependency ranges changed: aeson, base, bytestring, cmdargs, deepseq, ghc, ghc-boot, hscolour, liquid-fixpoint, pretty, process, syb, template-haskell, text, time

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 view

binary file changed (absent → 10244 bytes)

+ ._.DS_Store view

binary file changed (absent → 120 bytes)

+ .circleci/config.yml view
@@ -0,0 +1,46 @@+---+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 view
@@ -0,0 +1,1 @@+:set -isrc
+ .gitignore view
@@ -0,0 +1,51 @@+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 view
@@ -0,0 +1,6 @@+[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,20 +1,32 @@ # Changes -## NEXT +## NEXT 0.8.6.0 +- Automatically check (transitive) dependencies+- Built with GHC 8.6.4+- Structural termination checker (on by default)+- Support for specifying class-laws and that they hold on instances+- Bug fixes for PLE+- Need to run LH on imported libs (with source) first; can use `--compile-spec` to avoid checking.++## 0.8.4.0++- Support for GHC 8.4.3+- Significant restructuring of `Bare` front-end to shrink dependency on GHC-API+ ## 0.8.2.2 -- Support for GHC 8.2.2 +- Support for GHC 8.2.2  - Support for GADTs and TypeFamilies, see-	- `tests/{pos,neg}/ExactGADT*.hs` +	- `tests/{pos,neg}/ExactGADT*.hs` -- Add support for Bags/Multisets, see +- Add support for Bags/Multisets, see 	- `tests/pos/bag.hs` 	- `tests/neg/bag.hs` 	- `tests/pos/ListISort-bag.hs` -- Add support for *inductive predicates* see +- Add support for *inductive predicates* see 	- `tests/pos/IndEven.hs` 	- `tests/pos/IndPerm.hs` 	- `tests/pos/IndStar.hs`
+ CONTRIBUTING.md view
@@ -0,0 +1,7 @@+Contributing+------------++We are thrilled to get PRs. A few notes:++- Pull requests should be created against *develop* branch.+
+ HLint.hs view
@@ -0,0 +1,5 @@+import "hint" HLint.Default+import "hint" HLint.Dollar++ignore "Eta reduce"+ignore "Use ."
+ INSTALL.md view
@@ -0,0 +1,73 @@+# 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 view
@@ -0,0 +1,7 @@+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 view
@@ -0,0 +1,112 @@+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 view
@@ -0,0 +1,67 @@+# 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
@@ -3,10 +3,12 @@   [![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/)@@ -34,6 +36,8 @@ 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@@ -54,14 +58,31 @@  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 use threads to speed up the tests+To pass in specific parameters and run a subset of the tests  -    $ make THREADS=30 test+    $ stack test liquidhaskell --fast  --test-arguments "--liquid-opts --no-termination -p Unit"  Or your favorite number of threads, depending on cores etc. @@ -69,24 +90,21 @@      tests/test.hs -To run the regression test *and* the benchmarks run--    $ make all-test- How to Profile --------------  1. Build with profiling on      ```-    $ make pdeps && make prof+    $ stack build liquidhaskell --fast --profile     ``` + 2. Run with profiling      ```-    $ time liquid range.hs +RTS -hc -p-    $ time liquid range.hs +RTS -hy -p+    $ stack exec -- liquid range.hs +RTS -hc -p+    $ stack exec -- liquid range.hs +RTS -hy -p     ```      Followed by this which shows the stats file@@ -110,7 +128,7 @@ 1. Build with profiling on      ```-    $ make pdeps && make prof+    $ stack build liquidhaskell --fast --profile     ```  2. Run with backtraces@@ -119,6 +137,10 @@     $ liquid +RTS -xc -RTS foo.hs     ``` +    ```+    stack exec -- liquid List00.hs +RTS -p -xc -RTS+    ```+ Working With Submodules ----------------------- @@ -183,56 +205,105 @@ 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+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. @@ -269,7 +340,7 @@  Currently, LiquidHaskell supports -+ [CVC4](http://cvc4.cs.nyu.edu/)++ [CVC4](http://cvc4.cs.stanford.edu/web/) + [MathSat](http://mathsat.fbk.eu/download.html )  To use these solvers, you must install the corresponding binaries@@ -300,7 +371,23 @@      --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 -------------- @@ -358,6 +445,10 @@ 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`@@ -535,30 +626,43 @@   Prune Unsorted Predicates--------------------------+-------------------------- -Consider a measure over lists of integers+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 hack we do right now is to strengthen the polymorphic list with the `sum` information+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, expressions like `x + sum xs` is unsorted causing the logic to crash.-We use the flag `--prune-unsorted` to prune away unsorted expressions (like `x + sum xs`) in the logic.+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@@ -719,7 +823,7 @@   As an alternative, you can refine class instances.-[For example](tests/pos/LiquidClass.hs)+[For example](tests/classes/pos/Inst00.hs)  ~~~~ instance Compare Int where@@ -847,15 +951,32 @@ Apologies for the minimal documentation; see the following examples for details: -* [Even and Odd](https://github.com/ucsd-progsys/liquidhaskell/blob/develop/tests/pos/IndEven.hs)-* [Permutations](https://github.com/ucsd-progsys/liquidhaskell/blob/develop/tests/pos/IndPerm.hs)-* [Transitive Closure](https://github.com/ucsd-progsys/liquidhaskell/blob/develop/tests/pos/IndStar.hs)+* [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 ----------------------- @@ -881,6 +1002,14 @@ - 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  @@ -1011,6 +1140,39 @@         `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 =============== @@ -1079,7 +1241,7 @@  LH lets you locally associate invariants with specific data types. -For example, in [tests/pos/StreamInvariants.hs](tests/pos/StreamInvariants.hs) every+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 @@ -1092,9 +1254,9 @@ will assume that each list element that is created satisfies this invariant. -With this, at the [above](tests/neg/StreamInvariants.hs) test LiquidHaskell+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/neg/StreamInvariants.hs](tests/neg/StreamInvariants.hs) the usage of+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.  @@ -1331,25 +1493,36 @@  + The `A` component shall be updated at the sole discretion of the project owners. -Proof Automation------------------The `liquidinstances` automatically generates proof terms using symbolic evaluation. [See](https://github.com/ucsd-progsys/liquidhaskell/blob/develop/benchmarks/proofautomation/pos/MonoidList.hs).+Updating GHC+============ -```-{-@ LIQUID "--automatic-instances=liquidinstances" @-}+Here's a script to generate the diff for the `desugar` modules.+ ```+export GHCSRC=$HOME/Documents/ghc -This flag is **global** and will symbolically evaluation all the terms that appear in the specifications.+# Checkout GHC-8.2.2+(cd $GHCSRC && git checkout ghc-8.2.2 && git pull) -As an alternative, the `liquidinstanceslocal` flag has local behavior. [See](https://github.com/ucsd-progsys/liquidhaskell/blob/develop/benchmarks/proofautomation/pos/Unification.hs)+# make a patch+diff -ur $GHCSRC/compiler/deSugar src/Language/Haskell/Liquid/Desugar > liquid.patch -```-{-@ LIQUID "--automatic-instances=liquidinstanceslocal" @-}-```+# Checkout GHC-8.4.3+(cd $GHCSRC && git checkout ghc-8.2.2 && git pull) -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+# Copy GHC desugarer to temporary directory+cp -r $GHCSRC/compiler/deSugar . -```-{-@ automatic-instances theorem @-}+# 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 ++
+ Syntax.md view
@@ -0,0 +1,297 @@+## 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 view
@@ -0,0 +1,9 @@+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 view
@@ -0,0 +1,43 @@+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 view
@@ -0,0 +1,13 @@+-- 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 view
@@ -0,0 +1,2 @@+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
include/CoreToLogic.lg view
@@ -6,7 +6,7 @@ define Data.Set.Base.null x           = (Set_emp x) define Data.Set.Base.member x xs      = (Set_mem x xs) define Data.Set.Base.isSubsetOf x y   = (Set_sub x y)-define Data.Set.Base.elems xs         = (listElts xs)+define Data.Set.Base.fromList xs      = (listElts xs)  define Data.Set.Internal.singleton x      = (Set_sng x) define Data.Set.Internal.union x y        = (Set_cup x y)@@ -16,10 +16,14 @@ define Data.Set.Internal.null x           = (Set_emp x) define Data.Set.Internal.member x xs      = (Set_mem x xs) define Data.Set.Internal.isSubsetOf x y   = (Set_sub x y)-define Data.Set.Internal.elems xs         = (listElts xs)+define Data.Set.Internal.fromList xs      = (listElts xs) +define GHC.Real.fromIntegral x = (x)  define GHC.Types.True                 = (true)+define GHC.Real.div x y               = (x / y)+define GHC.Real.mod x y               = (x mod y)+define GHC.Base.$ f x                 = (f x)  define Language.Haskell.Liquid.Bag.get k m   = (Map_select m k) define Language.Haskell.Liquid.Bag.put k m   = (Map_store m k (1 + (Map_select m k)))@@ -34,4 +38,10 @@ define String.stringEmp  = (stringEmp) define Main.mempty       = (mempty) define Language.Haskell.Liquid.ProofCombinators.cast x y = (y)+define ProofCombinators.cast x y = (y) define Control.Parallel.Strategies.withStrategy s x = (x)++define ProofCombinators.cast x y = (y)+define Language.Haskell.Liquid.Equational.eq x y = (y)++define GHC.CString.unpackCString# x = x
include/Data/ByteString.spec view
@@ -10,159 +10,151 @@  empty :: { bs : Data.ByteString.ByteString | bslen bs == 0 } -singleton-    :: Data.Word.Word8 -> { bs : Data.ByteString.ByteString | bslen bs == 1 }+singleton :: _ -> { bs : Data.ByteString.ByteString | bslen bs == 1 } -pack-    :: w8s : [Data.Word.Word8]-    -> { bs : Data.ByteString.ByteString | bslen bs == len w8s }+pack :: w8s : [_]+     -> { bs : Data.ByteString.ByteString | bslen bs == len w8s } -unpack-    :: bs : Data.ByteString.ByteString-    -> { w8s : [Data.Word.Word8] | len w8s == bslen bs }+unpack :: bs : Data.ByteString.ByteString+       -> { w8s : [_] | len w8s == bslen bs } -cons-    :: Data.Word.Word8-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o == bslen i + 1 }+cons :: _+     -> i : Data.ByteString.ByteString+     -> { o : Data.ByteString.ByteString | bslen o == bslen i + 1 } -snoc-    :: i : Data.ByteString.ByteString-    -> Data.Word.Word8-    -> { o : Data.ByteString.ByteString | bslen o == bslen i + 1 }+snoc :: i : Data.ByteString.ByteString+     -> _+     -> { o : Data.ByteString.ByteString | bslen o == bslen i + 1 } -append-    :: l : Data.ByteString.ByteString-    -> r : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o == bslen l + bslen r }+append :: l : Data.ByteString.ByteString+       -> r : Data.ByteString.ByteString+       -> { o : Data.ByteString.ByteString | bslen o == bslen l + bslen r } -head :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> Data.Word.Word8+head :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> _ -unsnoc-    :: i : Data.ByteString.ByteString-    -> Maybe ({ o : Data.ByteString.ByteString | bslen o == bslen i - 1 }, Data.Word.Word8)+unsnoc :: i:Data.ByteString.ByteString +       -> (Maybe ({ o : Data.ByteString.ByteString | bslen o == bslen i - 1 }, _)) -last :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> Data.Word.Word8+last :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> _ -tail :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> Data.Word.Word8+tail :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> _ -init :: {i:Data.ByteString.ByteString | 1 <= bslen i } -     -> {o:Data.ByteString.ByteString | bslen o == bslen i - 1 }+init +  :: {i:Data.ByteString.ByteString | 1 <= bslen i } +  -> {o:Data.ByteString.ByteString | bslen o == bslen i - 1 } -null-    :: bs : Data.ByteString.ByteString-    -> { b : Bool | b <=> bslen bs == 0 }+null +  :: bs : Data.ByteString.ByteString+  -> { b : GHC.Types.Bool | b <=> bslen bs == 0 }  length :: bs : Data.ByteString.ByteString -> { n : Int | bslen bs == n } -map-    :: (Data.Word.Word8 -> Data.Word.Word8)-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o == bslen i }+map +  :: (_ -> _)+  -> i : Data.ByteString.ByteString+  -> { o : Data.ByteString.ByteString | bslen o == bslen i } -reverse-    :: i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o == bslen i }+reverse +  :: i : Data.ByteString.ByteString+  -> { o : Data.ByteString.ByteString | bslen o == bslen i } -intersperse-    :: Data.Word.Word8-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | (bslen i == 0 <=> bslen o == 0) && (1 <= bslen i <=> bslen o == 2 * bslen i - 1) }+intersperse +  :: _+  -> i : Data.ByteString.ByteString+  -> { o : Data.ByteString.ByteString | (bslen i == 0 <=> bslen o == 0) && (1 <= bslen i <=> bslen o == 2 * bslen i - 1) } -intercalate-    :: l : Data.ByteString.ByteString-    -> rs : [Data.ByteString.ByteString]-    -> { o : Data.ByteString.ByteString | len rs == 0 ==> bslen o == 0 }+intercalate +  :: l : Data.ByteString.ByteString+  -> rs : [Data.ByteString.ByteString]+  -> { o : Data.ByteString.ByteString | len rs == 0 ==> bslen o == 0 } -transpose-    :: is : [Data.ByteString.ByteString]-    -> { os : [{ bs : Data.ByteString.ByteString | bslen bs <= len is }] | len is == 0 ==> len os == 0}+transpose +  :: is : [Data.ByteString.ByteString]+  -> { os : [{ bs : Data.ByteString.ByteString | bslen bs <= len is }] | len is == 0 ==> len os == 0} -foldl1-    :: (Data.Word.Word8 -> Data.Word.Word8 -> Data.Word.Word8)-    -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }-    -> Data.Word.Word8+foldl1 +  :: (_ -> _ -> _)+  -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }+  -> _ -foldl1'-    :: (Data.Word.Word8 -> Data.Word.Word8 -> Data.Word.Word8)-    -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }-    -> Data.Word.Word8+foldl1' +  :: (_ -> _ -> _)+  -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }+  -> _ -foldr1-    :: (Data.Word.Word8 -> Data.Word.Word8 -> Data.Word.Word8)-    -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }-    -> Data.Word.Word8+foldr1 +  :: (_ -> _ -> _)+  -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }+  -> _ -foldr1'-    :: (Data.Word.Word8 -> Data.Word.Word8 -> Data.Word.Word8)-    -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }-    -> Data.Word.Word8+foldr1' +  :: (_ -> _ -> _)+  -> { bs : Data.ByteString.ByteString | 1 <= bslen bs }+  -> _ -concat-    :: is : [Data.ByteString.ByteString]-    -> { o : Data.ByteString.ByteString | len is == 0 ==> bslen o }+concat +  :: is : [Data.ByteString.ByteString] +  -> { o : Data.ByteString.ByteString | (len is == 0) ==> (bslen o == 0) } -concatMap-    :: (Data.Word.Word8 -> Data.ByteString.ByteString)-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen i == 0 ==> bslen o == 0 }+concatMap +  :: (_ -> Data.ByteString.ByteString)+  -> i : Data.ByteString.ByteString+  -> { o : Data.ByteString.ByteString | bslen i == 0 ==> bslen o == 0 } -any :: (Data.Word.Word8 -> Bool)-    -> bs : Data.ByteString.ByteString-    -> { b : Bool | bslen bs == 0 ==> not b }+any +  :: (_ -> GHC.Types.Bool)+  -> bs : Data.ByteString.ByteString+  -> { b : GHC.Types.Bool | bslen bs == 0 ==> not b } -all :: (Data.Word.Word8 -> Bool)-    -> bs : Data.ByteString.ByteString-    -> { b : Bool | bslen bs == 0 ==> b }+all +  :: (_ -> GHC.Types.Bool)+  -> bs : Data.ByteString.ByteString+  -> { b : GHC.Types.Bool | bslen bs == 0 ==> b } -maximum-    :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> Data.Word.Word8+maximum :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> _ -minimum-    :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> Data.Word.Word8+minimum :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> _ -scanl-    :: (Data.Word.Word8 -> Data.Word.Word8 -> Data.Word.Word8)-    -> Data.Word.Word8-    -> i : Data.ByteString.ByteString-    -> { o : Data.ByteString.ByteString | bslen o == bslen i }+scanl :: (_ -> _ -> _)+      -> _+      -> i : Data.ByteString.ByteString+      -> { o : Data.ByteString.ByteString | bslen o == bslen i } -scanl1-    :: (Data.Word.Word8 -> Data.Word.Word8 -> Data.Word.Word8)-    -> i : { i : Data.ByteString.ByteString | 1 <= bslen i }-    -> { o : Data.ByteString.ByteString | bslen o == bslen i }+scanl1 :: (_ -> _ -> _)+       -> i : { i : Data.ByteString.ByteString | 1 <= bslen i }+       -> { o : Data.ByteString.ByteString | bslen o == bslen i }  scanr-    :: (Data.Word.Word8 -> Data.Word.Word8 -> Data.Word.Word8)-    -> Data.Word.Word8+    :: (_ -> _ -> _)+    -> _     -> i : Data.ByteString.ByteString     -> { o : Data.ByteString.ByteString | bslen o == bslen i }  scanr1-    :: (Data.Word.Word8 -> Data.Word.Word8 -> Data.Word.Word8)+    :: (_ -> _ -> _)     -> i : { i : Data.ByteString.ByteString | 1 <= bslen i }     -> { o : Data.ByteString.ByteString | bslen o == bslen i }  mapAccumL-    :: (acc -> Data.Word.Word8 -> (acc, Data.Word.Word8))+    :: (acc -> _ -> (acc, _))     -> acc     -> i : Data.ByteString.ByteString     -> (acc, { o : Data.ByteString.ByteString | bslen o == bslen i })  mapAccumR-    :: (acc -> Data.Word.Word8 -> (acc, Data.Word.Word8))+    :: (acc -> _ -> (acc, _))     -> acc     -> i : Data.ByteString.ByteString     -> (acc, { o : Data.ByteString.ByteString | bslen o == bslen i })  replicate     :: n : Int-    -> Data.Word.Word8+    -> _     -> { bs : Data.ByteString.ByteString | bslen bs == n }  unfoldrN     :: n : Int-    -> (a -> Maybe (Data.Word.Word8, a))+    -> (a -> Maybe (_, a))     -> a     -> ({ bs : Data.ByteString.ByteString | bslen bs <= n }, Maybe a) @@ -192,38 +184,38 @@        )  takeWhile-    :: (Data.Word.Word8 -> Bool)+    :: (_ -> GHC.Types.Bool)     -> i : Data.ByteString.ByteString     -> { o : Data.ByteString.ByteString | bslen o <= bslen i }  dropWhile-    :: (Data.Word.Word8 -> Bool)+    :: (_ -> GHC.Types.Bool)     -> i : Data.ByteString.ByteString     -> { o : Data.ByteString.ByteString | bslen o <= bslen i }  span-    :: (Data.Word.Word8 -> Bool)+    :: (_ -> GHC.Types.Bool)     -> i : Data.ByteString.ByteString     -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }        , { r : Data.ByteString.ByteString | bslen r <= bslen i }        )  spanEnd-    :: (Data.Word.Word8 -> Bool)+    :: (_ -> GHC.Types.Bool)     -> i : Data.ByteString.ByteString     -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }        , { r : Data.ByteString.ByteString | bslen r <= bslen i }        )  break-    :: (Data.Word.Word8 -> Bool)+    :: (_ -> GHC.Types.Bool)     -> i : Data.ByteString.ByteString     -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }        , { r : Data.ByteString.ByteString | bslen r <= bslen i }        )  breakEnd-    :: (Data.Word.Word8 -> Bool)+    :: (_ -> GHC.Types.Bool)     -> i : Data.ByteString.ByteString     -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }        , { r : Data.ByteString.ByteString | bslen r <= bslen i }@@ -234,7 +226,7 @@     -> [{ o : Data.ByteString.ByteString | 1 <= bslen o && bslen o <= bslen i }]  groupBy-    :: (Data.Word.Word8 -> Data.Word.Word8 -> Bool)+    :: (_ -> _ -> GHC.Types.Bool)     -> i : Data.ByteString.ByteString     -> [{ o : Data.ByteString.ByteString | 1 <= bslen o && bslen o <= bslen i }] @@ -247,29 +239,29 @@     -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]  split-    :: Data.Word.Word8+    :: _     -> i : Data.ByteString.ByteString     -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]  splitWith-    :: (Data.Word.Word8 -> Bool)+    :: (_ -> GHC.Types.Bool)     -> i : Data.ByteString.ByteString     -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]  isPrefixOf     :: l : Data.ByteString.ByteString     -> r : Data.ByteString.ByteString-    -> { b : Bool | bslen l >= bslen r ==> not b }+    -> { b : GHC.Types.Bool | bslen l >= bslen r ==> not b }  isSuffixOf     :: l : Data.ByteString.ByteString     -> r : Data.ByteString.ByteString-    -> { b : Bool | bslen l > bslen r ==> not b }+    -> { b : GHC.Types.Bool | bslen l > bslen r ==> not b }  isInfixOf     :: l : Data.ByteString.ByteString     -> r : Data.ByteString.ByteString-    -> { b : Bool | bslen l > bslen r ==> not b }+    -> { b : GHC.Types.Bool | bslen l > bslen r ==> not b }  breakSubstring     :: il : Data.ByteString.ByteString@@ -279,77 +271,77 @@        )  elem-    :: Data.Word.Word8+    :: _     -> bs : Data.ByteString.ByteString-    -> { b : Bool | bslen b == 0 ==> not b }+    -> { b : GHC.Types.Bool | bslen bs == 0 ==> not b }  notElem-    :: Data.Word.Word8+    :: _     -> bs : Data.ByteString.ByteString-    -> { b : Bool | bslen b == 0 ==> b }+    -> { b : GHC.Types.Bool | bslen bs == 0 ==> b }  find-    :: (Data.Word.Word8 -> Bool)+    :: (_ -> GHC.Types.Bool)     -> bs : Data.ByteString.ByteString-    -> Maybe { w8 : Data.Word.Word8 | bslen bs /= 0 }+    -> (Maybe { w8 : _ | bslen bs /= 0 })  filter-    :: (Data.Word.Word8 -> Bool)+    :: (_ -> GHC.Types.Bool)     -> i : Data.ByteString.ByteString     -> { o : Data.ByteString.ByteString | bslen o <= bslen i }  partition-    :: (Data.Word.Word8 -> Bool)+    :: (_ -> GHC.Types.Bool)     -> i : Data.ByteString.ByteString     -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }        , { r : Data.ByteString.ByteString | bslen r <= bslen i }        ) -index :: bs : Data.ByteString.ByteString -> { n : Int | 0 <= n && n < bslen bs } -> Data.Word.Word8+index :: bs : Data.ByteString.ByteString -> { n : Int | 0 <= n && n < bslen bs } -> _  elemIndex-    :: Data.Word.Word8+    :: _     -> bs : Data.ByteString.ByteString-    -> Maybe { n : Int | 0 <= n && n < bslen bs }+    -> (Maybe { n : Int | 0 <= n && n < bslen bs })  elemIndices-    :: Data.Word.Word8+    :: _     -> bs : Data.ByteString.ByteString     -> [{ n : Int | 0 <= n && n < bslen bs }]  elemIndexEnd-    :: Data.Word.Word8+    :: _     -> bs : Data.ByteString.ByteString-    -> Maybe { n : Int | 0 <= n && n < bslen bs }+    -> (Maybe { n : Int | 0 <= n && n < bslen bs })  findIndex-    :: (Data.Word.Word8 -> Bool)+    :: (_ -> GHC.Types.Bool)     -> bs : Data.ByteString.ByteString-    -> Maybe { n : Int | 0 <= n && n < bslen bs }+    -> (Maybe { n : Int | 0 <= n && n < bslen bs })  findIndices-    :: (Data.Word.Word8 -> Bool)+    :: (_ -> GHC.Types.Bool)     -> bs : Data.ByteString.ByteString     -> [{ n : Int | 0 <= n && n < bslen bs }]  count-    :: Data.Word.Word8+    :: _     -> bs : Data.ByteString.ByteString     -> { n : Int | 0 <= n && n < bslen bs }  zip     :: l : Data.ByteString.ByteString     -> r : Data.ByteString.ByteString-    -> { o : [(Data.Word.Word8, Data.Word.Word8)] | len o <= bslen l && len o <= bslen r }+    -> { o : [(_, _)] | len o <= bslen l && len o <= bslen r }  zipWith-    :: (Data.Word.Word8 -> Data.Word.Word8 -> a)+    :: (_ -> _ -> a)     -> l : Data.ByteString.ByteString     -> r : Data.ByteString.ByteString     -> { o : [a] | len o <= bslen l && len o <= bslen r }  unzip-    :: i : [(Data.Word.Word8, Data.Word.Word8)]+    :: i : [(_, _)]     -> ( { l : Data.ByteString.ByteString | bslen l == len i }        , { r : Data.ByteString.ByteString | bslen r == len i }        )@@ -363,20 +355,21 @@     -> { o : Data.ByteString.ByteString | bslen o == bslen i }  hGet-    :: System.IO.Handle+    :: _     -> n : { n : Int | 0 <= n }-    -> IO { bs : Data.ByteString.ByteString | bslen bs == n || bslen bs == 0 }+    -> (IO { bs : Data.ByteString.ByteString | bslen bs == n || bslen bs == 0 })  hGetSome-    :: System.IO.Handle+    :: _     -> n : { n : Int | 0 <= n }-    -> IO { bs : Data.ByteString.ByteString | bslen bs <= n }+    -> (IO { bs : Data.ByteString.ByteString | bslen bs <= n })  hGetNonBlocking-    :: System.IO.Handle+    :: _     -> n : { n : Int | 0 <= n }-    -> IO { bs : Data.ByteString.ByteString | bslen bs <= n }+    -> (IO { bs : Data.ByteString.ByteString | bslen bs <= n })  uncons     :: i : Data.ByteString.ByteString-    -> Maybe (Data.Word.Word8, { o : Data.ByteString.ByteString | bslen o == bslen i - 1 })+    -> (Maybe (_, { o : Data.ByteString.ByteString | bslen o == bslen i - 1 }))+
include/Data/ByteString/Char8.spec view
@@ -48,7 +48,7 @@  assume null     :: bs : Data.ByteString.ByteString-    -> { b : Bool | b <=> bslen bs == 0 }+    -> { b : GHC.Types.Bool | b <=> bslen bs == 0 }  assume length :: bs : Data.ByteString.ByteString -> { n : Int | bslen bs == n } @@ -104,13 +104,13 @@     -> i : Data.ByteString.ByteString     -> { o : Data.ByteString.ByteString | bslen i == 0 ==> bslen o == 0 } -assume any :: (Char -> Bool)+assume any :: (Char -> GHC.Types.Bool)     -> bs : Data.ByteString.ByteString-    -> { b : Bool | bslen bs == 0 ==> not b }+    -> { b : GHC.Types.Bool | bslen bs == 0 ==> not b } -assume all :: (Char -> Bool)+assume all :: (Char -> GHC.Types.Bool)     -> bs : Data.ByteString.ByteString-    -> { b : Bool | bslen bs == 0 ==> b }+    -> { b : GHC.Types.Bool | bslen bs == 0 ==> b }  maximum     :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> Char@@ -189,38 +189,38 @@        )  assume takeWhile-    :: (Char -> Bool)+    :: (Char -> GHC.Types.Bool)     -> i : Data.ByteString.ByteString     -> { o : Data.ByteString.ByteString | bslen o <= bslen i }  assume dropWhile-    :: (Char -> Bool)+    :: (Char -> GHC.Types.Bool)     -> i : Data.ByteString.ByteString     -> { o : Data.ByteString.ByteString | bslen o <= bslen i }  assume span-    :: (Char -> Bool)+    :: (Char -> GHC.Types.Bool)     -> i : Data.ByteString.ByteString     -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }        , { r : Data.ByteString.ByteString | bslen r <= bslen i }        )  assume spanEnd-    :: (Char -> Bool)+    :: (Char -> GHC.Types.Bool)     -> i : Data.ByteString.ByteString     -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }        , { r : Data.ByteString.ByteString | bslen r <= bslen i }        )  assume break-    :: (Char -> Bool)+    :: (Char -> GHC.Types.Bool)     -> i : Data.ByteString.ByteString     -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }        , { r : Data.ByteString.ByteString | bslen r <= bslen i }        )  assume breakEnd-    :: (Char -> Bool)+    :: (Char -> GHC.Types.Bool)     -> i : Data.ByteString.ByteString     -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }        , { r : Data.ByteString.ByteString | bslen r <= bslen i }@@ -231,7 +231,7 @@     -> [{ o : Data.ByteString.ByteString | 1 <= bslen o && bslen o <= bslen i }]  assume groupBy-    :: (Char -> Char -> Bool)+    :: (Char -> Char -> GHC.Types.Bool)     -> i : Data.ByteString.ByteString     -> [{ o : Data.ByteString.ByteString | 1 <= bslen o && bslen o <= bslen i }] @@ -249,7 +249,7 @@     -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }]  assume splitWith-    :: (Char -> Bool)+    :: (Char -> GHC.Types.Bool)     -> i : Data.ByteString.ByteString     -> [{ o : Data.ByteString.ByteString | bslen o <= bslen i }] @@ -272,17 +272,17 @@ assume isPrefixOf     :: l : Data.ByteString.ByteString     -> r : Data.ByteString.ByteString-    -> { b : Bool | bslen l >= bslen r ==> not b }+    -> { b : GHC.Types.Bool | bslen l >= bslen r ==> not b }  assume isSuffixOf     :: l : Data.ByteString.ByteString     -> r : Data.ByteString.ByteString-    -> { b : Bool | bslen l > bslen r ==> not b }+    -> { b : GHC.Types.Bool | bslen l > bslen r ==> not b }  assume isInfixOf     :: l : Data.ByteString.ByteString     -> r : Data.ByteString.ByteString-    -> { b : Bool | bslen l > bslen r ==> not b }+    -> { b : GHC.Types.Bool | bslen l > bslen r ==> not b }  assume breakSubstring     :: il : Data.ByteString.ByteString@@ -294,20 +294,20 @@ assume elem     :: Char     -> bs : Data.ByteString.ByteString-    -> { b : Bool | bslen b == 0 ==> not b }+    -> { b : GHC.Types.Bool | bslen bs == 0 ==> not b }  assume notElem     :: Char     -> bs : Data.ByteString.ByteString-    -> { b : Bool | bslen b == 0 ==> b }+    -> { b : GHC.Types.Bool | bslen bs == 0 ==> b }  assume find-    :: (Char -> Bool)+    :: (Char -> GHC.Types.Bool)     -> bs : Data.ByteString.ByteString     -> Maybe { w8 : Char | bslen bs /= 0 }  assume filter-    :: (Char -> Bool)+    :: (Char -> GHC.Types.Bool)     -> i : Data.ByteString.ByteString     -> { o : Data.ByteString.ByteString | bslen o <= bslen i } @@ -332,12 +332,12 @@     -> Maybe { n : Int | 0 <= n && n < bslen bs }  assume findIndex-    :: (Char -> Bool)+    :: (Char -> GHC.Types.Bool)     -> bs : Data.ByteString.ByteString     -> Maybe { n : Int | 0 <= n && n < bslen bs }  assume findIndices-    :: (Char -> Bool)+    :: (Char -> GHC.Types.Bool)     -> bs : Data.ByteString.ByteString     -> [{ n : Int | 0 <= n && n < bslen bs }] @@ -395,7 +395,7 @@     -> IO { bs : Data.ByteString.ByteString | bslen bs <= n }  // assume partition-    // :: (Char -> Bool)+    // :: (Char -> GHC.Types.Bool)     // -> i : Data.ByteString.ByteString     // -> ( { l : Data.ByteString.ByteString | bslen l <= bslen i }        // , { r : Data.ByteString.ByteString | bslen r <= bslen i }
include/Data/ByteString/Lazy.spec view
@@ -1,8 +1,9 @@ module spec Data.ByteString.Lazy where  import Data.String+import Data.ByteString -measure bllen :: Data.ByteString.Lazy.ByteString -> { n : Data.Int.Int64 | 0 <= n }+measure bllen :: Data.ByteString.Lazy.ByteString -> { n : GHC.Int.Int64 | 0 <= n }  invariant { bs : Data.ByteString.Lazy.ByteString | 0 <= bllen bs } @@ -11,15 +12,15 @@ assume empty :: { bs : Data.ByteString.Lazy.ByteString | bllen bs == 0 }  assume singleton-    :: Data.Word.Word8 -> { bs : Data.ByteString.Lazy.ByteString | bllen bs == 1 }+    :: _ -> { bs : Data.ByteString.Lazy.ByteString | bllen bs == 1 }  assume pack-    :: w8s : [Data.Word.Word8]-    -> { bs : Data.ByteString.ByteString | bllen bs == len w8s }+    :: w8s : [_]+    -> { bs : _ | bllen bs == len w8s }  assume unpack     :: bs : Data.ByteString.Lazy.ByteString-    -> { w8s : [Data.Word.Word8] | len w8s == bllen bs }+    -> { w8s : [_] | len w8s == bllen bs }  assume fromStrict     :: i : Data.ByteString.ByteString@@ -38,13 +39,13 @@     -> { os : [{ o : Data.ByteString.ByteString | bslen o <= bllen i}] | len os == 0 <=> bllen i == 0 }  assume cons-    :: Data.Word.Word8+    :: _     -> i : Data.ByteString.Lazy.ByteString     -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i + 1 }  assume snoc     :: i : Data.ByteString.Lazy.ByteString-    -> Data.Word.Word8+    -> _     -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i + 1 }  assume append@@ -52,39 +53,31 @@     -> r : Data.ByteString.Lazy.ByteString     -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen l + bllen r } -head+assume head     :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }-    -> Data.Word.Word8+    -> _  assume uncons     :: i : Data.ByteString.Lazy.ByteString-    -> Maybe (Data.Word.Word8, { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i - 1 })+    -> Maybe (_, { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i - 1 })  assume unsnoc     :: i : Data.ByteString.Lazy.ByteString-    -> Maybe ({ o : Data.ByteString.Lazy.ByteString | bllen o == bllen i - 1 }, Data.Word.Word8)+    -> Maybe ({ o : Data.ByteString.Lazy.ByteString | bllen o == bllen i - 1 }, _) -last-    :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }-    -> Data.Word.Word8+assume last :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs } -> _ -tail-    :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }-    -> Data.Word.Word8+assume tail :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs } -> _ -init-    :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }-    -> Data.Word.Word8+assume init :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs } -> _ -assume null-    :: bs : Data.ByteString.Lazy.ByteString-    -> { b : Bool | b <=> bllen bs == 0 }+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 }+    :: bs : Data.ByteString.Lazy.ByteString -> { n : GHC.Int.Int64 | bllen bs == n }  assume map-    :: (Data.Word.Word8 -> Data.Word.Word8)+    :: (_ -> _)     -> i : Data.ByteString.Lazy.ByteString     -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i } @@ -93,7 +86,7 @@     -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i }  assume intersperse-    :: Data.Word.Word8+    :: _     -> 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) } @@ -106,81 +99,81 @@     :: is : [Data.ByteString.Lazy.ByteString]     -> { os : [{ bs : Data.ByteString.Lazy.ByteString | bllen bs <= len is }] | len is == 0 ==> len os == 0} -foldl1-    :: (Data.Word.Word8 -> Data.Word.Word8 -> Data.Word.Word8)+assume foldl1+    :: (_ -> _ -> _)     -> { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }-    -> Data.Word.Word8+    -> _ -foldl1'-    :: (Data.Word.Word8 -> Data.Word.Word8 -> Data.Word.Word8)+assume foldl1'+    :: (_ -> _ -> _)     -> { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }-    -> Data.Word.Word8+    -> _ -foldr1-    :: (Data.Word.Word8 -> Data.Word.Word8 -> Data.Word.Word8)+assume foldr1+    :: (_ -> _ -> _)     -> { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs }-    -> Data.Word.Word8+    -> _  assume concat     :: is : [Data.ByteString.Lazy.ByteString]-    -> { o : Data.ByteString.Lazy.ByteString | len is == 0 ==> bllen o }+    -> { o : Data.ByteString.Lazy.ByteString | (len is == 0) ==> (bllen o == 0) }  assume concatMap-    :: (Data.Word.Word8 -> Data.ByteString.Lazy.ByteString)+    :: (_ -> Data.ByteString.Lazy.ByteString)     -> i : Data.ByteString.Lazy.ByteString     -> { o : Data.ByteString.Lazy.ByteString | bllen i == 0 ==> bllen o == 0 } -assume any :: (Data.Word.Word8 -> Bool)+assume any :: (_ -> GHC.Types.Bool)     -> bs : Data.ByteString.Lazy.ByteString-    -> { b : Bool | bllen bs == 0 ==> not b }+    -> { b : GHC.Types.Bool | bllen bs == 0 ==> not b } -assume all :: (Data.Word.Word8 -> Bool)+assume all :: (_ -> GHC.Types.Bool)     -> bs : Data.ByteString.Lazy.ByteString-    -> { b : Bool | bllen bs == 0 ==> b }+    -> { b : GHC.Types.Bool | bllen bs == 0 ==> b } -maximum :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs } -> Data.Word.Word8+assume maximum :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs } -> _ -minimum :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs } -> Data.Word.Word8+assume minimum :: { bs : Data.ByteString.Lazy.ByteString | 1 <= bllen bs } -> _  assume scanl-    :: (Data.Word.Word8 -> Data.Word.Word8 -> Data.Word.Word8)-    -> Data.Word.Word8+    :: (_ -> _ -> _)+    -> _     -> i : Data.ByteString.Lazy.ByteString     -> { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i }  assume mapAccumL-    :: (acc -> Data.Word.Word8 -> (acc, Data.Word.Word8))+    :: (acc -> _ -> (acc, _))     -> acc     -> i : Data.ByteString.Lazy.ByteString     -> (acc, { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i })  assume mapAccumR-    :: (acc -> Data.Word.Word8 -> (acc, Data.Word.Word8))+    :: (acc -> _ -> (acc, _))     -> acc     -> i : Data.ByteString.Lazy.ByteString     -> (acc, { o : Data.ByteString.Lazy.ByteString | bllen o == bllen i })  assume replicate-    :: n : Data.Int.Int64-    -> Data.Word.Word8+    :: n : GHC.Int.Int64+    -> _     -> { bs : Data.ByteString.Lazy.ByteString | bllen bs == n }  assume take-    :: n : Data.Int.Int64+    :: n : GHC.Int.Int64     -> i : Data.ByteString.Lazy.ByteString     -> { o : Data.ByteString.Lazy.ByteString | (n <= 0 ==> bllen o == 0) &&                                                ((0 <= n && n <= bllen i) <=> bllen o == n) &&                                                (bllen i <= n <=> bllen o = bllen i) }  assume drop-    :: n : Data.Int.Int64+    :: n : GHC.Int.Int64     -> i : Data.ByteString.Lazy.ByteString     -> { o : Data.ByteString.Lazy.ByteString | (n <= 0 <=> bllen o == bllen i) &&                                                ((0 <= n && n <= bllen i) <=> bllen o == bllen i - n) &&                                                (bllen i <= n <=> bllen o == 0) }  assume splitAt-    :: n : Data.Int.Int64+    :: n : GHC.Int.Int64     -> i : Data.ByteString.Lazy.ByteString     -> ( { l : Data.ByteString.Lazy.ByteString | (n <= 0 <=> bllen l == 0) &&                                                  ((0 <= n && n <= bllen i) <=> bllen l == n) &&@@ -191,24 +184,24 @@        )  assume takeWhile-    :: (Data.Word.Word8 -> Bool)+    :: (_ -> GHC.Types.Bool)     -> i : Data.ByteString.Lazy.ByteString     -> { o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }  assume dropWhile-    :: (Data.Word.Word8 -> Bool)+    :: (_ -> GHC.Types.Bool)     -> i : Data.ByteString.Lazy.ByteString     -> { o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }  assume span-    :: (Data.Word.Word8 -> Bool)+    :: (_ -> 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-    :: (Data.Word.Word8 -> Bool)+    :: (_ -> 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 }@@ -219,7 +212,7 @@     -> [{ o : Data.ByteString.Lazy.ByteString | 1 <= bllen o && bllen o <= bllen i }]  assume groupBy-    :: (Data.Word.Word8 -> Data.Word.Word8 -> Bool)+    :: (_ -> _ -> GHC.Types.Bool)     -> i : Data.ByteString.Lazy.ByteString     -> [{ o : Data.ByteString.Lazy.ByteString | 1 <= bllen o && bllen o <= bllen i }] @@ -232,100 +225,100 @@     -> [{ o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }]  assume split-    :: Data.Word.Word8+    :: _     -> i : Data.ByteString.Lazy.ByteString     -> [{ o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }]  assume splitWith-    :: (Data.Word.Word8 -> Bool)+    :: (_ -> GHC.Types.Bool)     -> i : Data.ByteString.Lazy.ByteString     -> [{ o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }]  assume isPrefixOf     :: l : Data.ByteString.Lazy.ByteString     -> r : Data.ByteString.Lazy.ByteString-    -> { b : Bool | bllen l >= bllen r ==> not b }+    -> { b : GHC.Types.Bool | bllen l >= bllen r ==> not b }  assume isSuffixOf     :: l : Data.ByteString.Lazy.ByteString     -> r : Data.ByteString.Lazy.ByteString-    -> { b : Bool | bllen l >= bllen r ==> not b }+    -> { b : GHC.Types.Bool | bllen l >= bllen r ==> not b }  assume elem-    :: Data.Word.Word8+    :: _     -> bs : Data.ByteString.Lazy.ByteString-    -> { b : Bool | bllen b == 0 ==> not b }+    -> { b : GHC.Types.Bool | (bllen bs == 0) ==> not b }  assume notElem-    :: Data.Word.Word8+    :: _     -> bs : Data.ByteString.Lazy.ByteString-    -> { b : Bool | bllen b == 0 ==> b }+    -> { b : GHC.Types.Bool | (bllen bs == 0) ==> b }  assume find-    :: (Data.Word.Word8 -> Bool)+    :: (_ -> GHC.Types.Bool)     -> bs : Data.ByteString.Lazy.ByteString-    -> Maybe { w8 : Data.Word.Word8 | bllen bs /= 0 }+    -> Maybe { w8 : _ | bllen bs /= 0 }  assume filter-    :: (Data.Word.Word8 -> Bool)+    :: (_ -> GHC.Types.Bool)     -> i : Data.ByteString.Lazy.ByteString     -> { o : Data.ByteString.Lazy.ByteString | bllen o <= bllen i }  assume partition-    :: (Data.Word.Word8 -> Bool)+    :: (_ -> 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+assume index     :: bs : Data.ByteString.Lazy.ByteString-    -> { n : Data.Int.Int64 | 0 <= n && n < bllen bs }-    -> Data.Word.Word8+    -> { n : GHC.Int.Int64 | 0 <= n && n < bllen bs }+    -> _  assume elemIndex-    :: Data.Word.Word8+    :: _     -> bs : Data.ByteString.Lazy.ByteString-    -> Maybe { n : Data.Int.Int64 | 0 <= n && n < bllen bs }+    -> Maybe { n : GHC.Int.Int64 | 0 <= n && n < bllen bs }  assume elemIndices-    :: Data.Word.Word8+    :: _     -> bs : Data.ByteString.Lazy.ByteString-    -> [{ n : Data.Int.Int64 | 0 <= n && n < bllen bs }]+    -> [{ n : GHC.Int.Int64 | 0 <= n && n < bllen bs }]  assume elemIndexEnd-    :: Data.Word.Word8+    :: _     -> bs : Data.ByteString.Lazy.ByteString-    -> Maybe { n : Data.Int.Int64 | 0 <= n && n < bllen bs }+    -> Maybe { n : GHC.Int.Int64 | 0 <= n && n < bllen bs }  assume findIndex-    :: (Data.Word.Word8 -> Bool)+    :: (_ -> GHC.Types.Bool)     -> bs : Data.ByteString.Lazy.ByteString-    -> Maybe { n : Data.Int.Int64 | 0 <= n && n < bllen bs }+    -> Maybe { n : GHC.Int.Int64 | 0 <= n && n < bllen bs }  assume findIndices-    :: (Data.Word.Word8 -> Bool)+    :: (_ -> GHC.Types.Bool)     -> bs : Data.ByteString.Lazy.ByteString-    -> [{ n : Data.Int.Int64 | 0 <= n && n < bllen bs }]+    -> [{ n : GHC.Int.Int64 | 0 <= n && n < bllen bs }]  assume count-    :: Data.Word.Word8+    :: _     -> bs : Data.ByteString.Lazy.ByteString-    -> { n : Data.Int.Int64 | 0 <= n && n < bllen bs }+    -> { n : GHC.Int.Int64 | 0 <= n && n < bllen bs }  assume zip     :: l : Data.ByteString.Lazy.ByteString     -> r : Data.ByteString.Lazy.ByteString-    -> { o : [(Data.Word.Word8, Data.Word.Word8)] | len o <= bllen l && len o <= bllen r }+    -> { o : [(_, _)] | len o <= bllen l && len o <= bllen r }  assume zipWith-    :: (Data.Word.Word8 -> Data.Word.Word8 -> a)+    :: (_ -> _ -> a)     -> l : Data.ByteString.Lazy.ByteString     -> r : Data.ByteString.Lazy.ByteString     -> { o : [a] | len o <= bllen l && len o <= bllen r }  assume unzip-    :: i : [(Data.Word.Word8, Data.Word.Word8)]+    :: i : [(_, _)]     -> ( { l : Data.ByteString.Lazy.ByteString | bllen l == len i }        , { r : Data.ByteString.Lazy.ByteString | bllen r == len i }        )@@ -335,11 +328,11 @@     -> { 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/ByteString/Lazy/Char8.spec view
@@ -0,0 +1,417 @@+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/ByteString/Short.spec view
@@ -8,32 +8,18 @@  invariant { bs : Data.ByteString.Short.ShortByteString | sbslen bs == stringlen bs } -assume toShort-    :: i : Data.ByteString.ByteString-    -> { o : Data.ByteString.Short.ShortByteString | sbslen o == bslen i }+toShort :: i : Data.ByteString.ByteString -> { o : Data.ByteString.Short.ShortByteString | sbslen o == bslen i } -assume fromShort-    :: o : Data.ByteString.Short.ShortByteString-    -> { i : Data.ByteString.ByteString | bslen i == sbslen o }+fromShort :: o : Data.ByteString.Short.ShortByteString -> { i : Data.ByteString.ByteString | bslen i == sbslen o } -assume pack-    :: w8s : [Data.Word.Word8]-    -> { bs : Data.ByteString.Short.ShortByteString | sbslen bs == len w8s }+pack :: w8s : [Data.Word.Word8] -> { bs : Data.ByteString.Short.ShortByteString | sbslen bs == len w8s } -assume unpack-    :: bs : Data.ByteString.Short.ShortByteString-    -> { w8s : [Data.Word.Word8] | len w8s == sbslen bs }+unpack :: bs : Data.ByteString.Short.ShortByteString -> { w8s : [Data.Word.Word8] | len w8s == sbslen bs } -assume empty :: { bs : Data.ByteString.Short.ShortByteString | sbslen bs == 0 }+empty :: { bs : Data.ByteString.Short.ShortByteString | sbslen bs == 0 } -assume null-    :: bs : Data.ByteString.Short.ShortByteString-    -> { b : Bool | b <=> sbslen bs == 0 }+null :: bs : Data.ByteString.Short.ShortByteString -> { b : GHC.Types.Bool | b <=> sbslen bs == 0 } -assume length-    :: bs : Data.ByteString.Short.ShortByteString -> { n : Int | sbslen bs == n }+length :: bs : Data.ByteString.Short.ShortByteString -> { n : Int | sbslen bs == n } -index-    :: bs : Data.ByteString.Short.ShortByteString-    -> { n : Int | 0 <= n && n < sbslen bs }-    -> Data.Word.Word8+index :: bs : Data.ByteString.Short.ShortByteString -> { n : Int | 0 <= n && n < sbslen bs } -> Data.Word.Word8
include/Data/ByteString/Unsafe.spec view
@@ -1,29 +1,29 @@ module spec Data.ByteString.Unsafe where  unsafeHead-    :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> Data.Word.Word8+    :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> _   unsafeTail     :: bs : { v : Data.ByteString.ByteString | bslen v > 0 }     -> { v : Data.ByteString.ByteString | bslen v = bslen bs - 1 }  unsafeInit-    :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> Data.Word.Word8+    :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> _   unsafeLast-    :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> Data.Word.Word8+    :: { bs : Data.ByteString.ByteString | 1 <= bslen bs } -> _   unsafeIndex     :: bs : Data.ByteString.ByteString     -> { n : Int | 0 <= n && n < bslen bs }-    -> Data.Word.Word8+    -> _  -assume unsafeTake+unsafeTake     :: n : { n : Int | 0 <= n }     -> i : { i : Data.ByteString.ByteString | n <= bslen i }     -> { o : Data.ByteString.ByteString | bslen o == n } -assume unsafeDrop+unsafeDrop     :: n : { n : Int | 0 <= n }     -> i : { i : Data.ByteString.ByteString | n <= bslen i }     -> { o : Data.ByteString.ByteString | bslen o == bslen i - n }
+ include/Data/Char.spec view
@@ -0,0 +1,1 @@+module spec Data.Chare where
include/Data/Either.spec view
@@ -1,15 +1,5 @@ module spec Data.Either where -invariant {v:[Data.Either.Either a b] | (lenRight v >= 0) && (lenRight v <= len v)}--measure lenRight :: [Data.Either.Either a b] -> GHC.Types.Int-lenRight (x:xs) = if (isLeft x) then (lenRight xs) else (lenRight xs + 1)-lenRight ([])   = 0--measure isLeftHd :: [Data.Either.Either a b] -> Bool -isLeftHd (x:xs) = (isLeft x)-isLeftHd ([])   = false- measure isLeft :: Data.Either.Either a b -> Bool isLeft (Left x)  = true isLeft (Right x) = false
include/Data/Foldable.spec view
@@ -2,4 +2,4 @@  import GHC.Base -assume length :: Data.Foldable.Foldable f => xs:f a -> {v:Nat | v = len xs}+length :: Data.Foldable.Foldable f => forall a. xs:f a -> {v:Nat | v = len xs}
include/Data/Int.spec view
@@ -1,2 +1,8 @@ module spec Data.Int where +embed Data.Int.Int8  as int+embed Data.Int.Int16 as int+embed Data.Int.Int32 as int+embed Data.Int.Int64 as int++// type Nat64 = {v:Data.Int.Int64 | v >= 0}
− include/Data/List.spec 
@@ -1,11 +0,0 @@-module spec Data.List where--import GHC.Base-import GHC.List-import GHC.Types--assume groupBy :: (a -> a -> GHC.Types.Bool) -> [a] -> [{v:[a] | len(v) > 0}]--assume transpose :: [[a]] -> [{v:[a] | (len v) > 0}]--
+ include/Data/Map.hiddenspec view
@@ -0,0 +1,27 @@+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/Maybe.spec 
@@ -1,8 +0,0 @@-module spec Data.Maybe where--measure isJust :: forall a. Data.Maybe.Maybe a -> Bool-isJust (Data.Maybe.Just x)  = true -isJust (Data.Maybe.Nothing) = false --measure fromJust :: forall a. Data.Maybe.Maybe a -> a-fromJust (Data.Maybe.Just x) = x
+ include/Data/OldList.spec view
@@ -0,0 +1,11 @@+module spec Data.OldList where++import GHC.Base+import GHC.List+import GHC.Types++assume groupBy :: (a -> a -> GHC.Types.Bool) -> [a] -> [{v:[a] | len(v) > 0}]++assume transpose :: [[a]] -> [{v:[a] | (len v) > 0}]++
include/Data/Set.spec view
@@ -1,6 +1,6 @@ module spec Data.Set where -embed Data.Set.Set as Set_Set+embed Data.Set.Internal.Set as Set_Set  // ---------------------------------------------------------------------------------------------- // -- | Logical Set Operators: Interpreted "natively" by the SMT solver -------------------------@@ -8,53 +8,52 @@   // union-measure Set_cup  :: (Data.Set.Set a) -> (Data.Set.Set a) -> (Data.Set.Set a)+measure Set_cup  :: (Data.Set.Internal.Set a) -> (Data.Set.Internal.Set a) -> (Data.Set.Internal.Set a)  // intersection-measure Set_cap  :: (Data.Set.Set a) -> (Data.Set.Set a) -> (Data.Set.Set a)+measure Set_cap  :: (Data.Set.Internal.Set a) -> (Data.Set.Internal.Set a) -> (Data.Set.Internal.Set a)  // difference-measure Set_dif   :: (Data.Set.Set a) -> (Data.Set.Set a) -> (Data.Set.Set a)+measure Set_dif   :: (Data.Set.Internal.Set a) -> (Data.Set.Internal.Set a) -> (Data.Set.Internal.Set a)  // singleton-measure Set_sng   :: a -> (Data.Set.Set a)+measure Set_sng   :: a -> (Data.Set.Internal.Set a)  // emptiness test-measure Set_emp   :: (Data.Set.Set a) -> GHC.Types.Bool+measure Set_emp   :: (Data.Set.Internal.Set a) -> GHC.Types.Bool  // empty set-measure Set_empty :: forall a. GHC.Types.Int -> (Data.Set.Set a)-+measure Set_empty :: forall a. GHC.Types.Int -> (Data.Set.Internal.Set a)  // membership test-measure Set_mem  :: a -> (Data.Set.Set a) -> GHC.Types.Bool+measure Set_mem  :: a -> (Data.Set.Internal.Set a) -> GHC.Types.Bool  // inclusion test-measure Set_sub  :: (Data.Set.Set a) -> (Data.Set.Set a) -> GHC.Types.Bool+measure Set_sub  :: (Data.Set.Internal.Set a) -> (Data.Set.Internal.Set a) -> GHC.Types.Bool  // --------------------------------------------------------------------------------------------- // -- | Refined Types for Data.Set Operations -------------------------------------------------- // --------------------------------------------------------------------------------------------- -isSubsetOf    :: (GHC.Classes.Ord a) => x:(Data.Set.Set a) -> y:(Data.Set.Set a) -> {v:Bool | v <=> Set_sub x y}-member        :: (GHC.Classes.Ord a) => x:a -> xs:(Data.Set.Set a) -> {v:Bool | v <=> Set_mem x xs}-null          :: (GHC.Classes.Ord a) => xs:(Data.Set.Set a) -> {v:Bool | v <=> Set_emp xs}+isSubsetOf    :: (GHC.Classes.Ord a) => x:(Data.Set.Internal.Set a) -> y:(Data.Set.Internal.Set a) -> {v:GHC.Types.Bool | v <=> Set_sub x y}+member        :: (GHC.Classes.Ord a) => x:a -> xs:(Data.Set.Internal.Set a) -> {v:GHC.Types.Bool | v <=> Set_mem x xs}+null          :: (GHC.Classes.Ord a) => xs:(Data.Set.Internal.Set a) -> {v:GHC.Types.Bool | v <=> Set_emp xs} -empty         :: {v:(Data.Set.Set a) | Set_emp v}-singleton     :: x:a -> {v:(Data.Set.Set a) | v = (Set_sng x)}-insert        :: (GHC.Classes.Ord a) => x:a -> xs:(Data.Set.Set a) -> {v:(Data.Set.Set a) | v = Set_cup xs (Set_sng x)}-delete        :: (GHC.Classes.Ord a) => x:a -> xs:(Data.Set.Set a) -> {v:(Data.Set.Set a) | v = Set_dif xs (Set_sng x)}+empty         :: {v:(Data.Set.Internal.Set a) | Set_emp v}+singleton     :: x:a -> {v:(Data.Set.Internal.Set a) | v = (Set_sng x)}+insert        :: (GHC.Classes.Ord a) => x:a -> xs:(Data.Set.Internal.Set a) -> {v:(Data.Set.Internal.Set a) | v = Set_cup xs (Set_sng x)}+delete        :: (GHC.Classes.Ord a) => x:a -> xs:(Data.Set.Internal.Set a) -> {v:(Data.Set.Internal.Set a) | v = Set_dif xs (Set_sng x)} -union         :: GHC.Classes.Ord a => xs:(Data.Set.Set a) -> ys:(Data.Set.Set a) -> {v:(Data.Set.Set a) | v = Set_cup xs ys}-intersection  :: GHC.Classes.Ord a => xs:(Data.Set.Set a) -> ys:(Data.Set.Set a) -> {v:(Data.Set.Set a) | v = Set_cap xs ys}-difference    :: GHC.Classes.Ord a => xs:(Data.Set.Set a) -> ys:(Data.Set.Set a) -> {v:(Data.Set.Set a) | v = Set_dif xs ys}+union         :: GHC.Classes.Ord a => xs:(Data.Set.Internal.Set a) -> ys:(Data.Set.Internal.Set a) -> {v:(Data.Set.Internal.Set a) | v = Set_cup xs ys}+intersection  :: GHC.Classes.Ord a => xs:(Data.Set.Internal.Set a) -> ys:(Data.Set.Internal.Set a) -> {v:(Data.Set.Internal.Set a) | v = Set_cap xs ys}+difference    :: GHC.Classes.Ord a => xs:(Data.Set.Internal.Set a) -> ys:(Data.Set.Internal.Set a) -> {v:(Data.Set.Internal.Set a) | v = Set_dif xs ys} -fromList :: GHC.Classes.Ord a => xs:[a] -> {v:Data.Set.Set a | v = listElts xs}+fromList :: GHC.Classes.Ord a => xs:[a] -> {v:Data.Set.Internal.Set a | v = listElts xs}  // --------------------------------------------------------------------------------------------- // -- | The set of elements in a list ---------------------------------------------------------- // --------------------------------------------------------------------------------------------- -measure listElts :: [a] -> (Data.Set.Set a)+measure listElts :: [a] -> (Data.Set.Internal.Set a) listElts([])   = {v | (Set_emp v)} listElts(x:xs) = {v | v = Set_cup (Set_sng x) (listElts xs) }
include/Data/String.spec view
@@ -5,4 +5,4 @@ Data.String.fromString     ::  forall a. Data.String.IsString a     =>  i : [GHC.Types.Char]-    ->  { o : a | len i == stringlen o }+    ->  { o : a | i ~~ o && len i == stringlen o }
+ include/Data/Text.spec view
@@ -0,0 +1,289 @@+module spec Data.Text where++import Data.String++measure tlen :: Data.Text.Text -> { n : Int | 0 <= n }++invariant { t : Data.Text.Text  | 0 <= tlen t }++invariant { t : Data.Text.Text | tlen t == stringlen t }++empty :: { t : Data.Text.Text | tlen t == 0 }++singleton :: _ -> { t : Data.Text.Text | tlen t == 1 }++pack :: str : [_]+     -> { t : Data.Text.Text | tlen t == len str }++unpack :: t : Data.Text.Text+       -> { str : [_] | len str == tlen t }++cons :: _+     -> i : Data.Text.Text+     -> { o : Data.Text.Text | tlen o == tlen i + 1 }++snoc :: i : Data.Text.Text+     -> _+     -> { o : Data.Text.Text | tlen o == tlen i + 1 }++append :: l : Data.Text.Text+       -> r : Data.Text.Text+       -> { o : Data.Text.Text | tlen o == tlen l + tlen r }++head :: { t : Data.Text.Text | 1 <= tlen t } -> _++unsnoc :: i:Data.Text.Text+       -> (Maybe ({ o : Data.Text.Text | tlen o == tlen i - 1 }, _))++last :: { t : Data.Text.Text | 1 <= tlen t } -> _++tail :: { t : Data.Text.Text | 1 <= tlen t } -> _++init+  :: {i:Data.Text.Text | 1 <= tlen i }+  -> {o:Data.Text.Text | tlen o == tlen i - 1 }++null+  :: t : Data.Text.Text+  -> { b : GHC.Types.Bool | b <=> tlen t == 0 }++length :: t : Data.Text.Text -> { n : Int | tlen t == n }++map+  :: (_ -> _)+  -> i : Data.Text.Text+  -> { o : Data.Text.Text | tlen o == tlen i }++reverse+  :: i : Data.Text.Text+  -> { o : Data.Text.Text | tlen o == tlen i }++intersperse+  :: _+  -> i : Data.Text.Text+  -> { o : Data.Text.Text | (tlen i == 0 <=> tlen o == 0) && (1 <= tlen i <=> tlen o == 2 * tlen i - 1) }++intercalate+  :: l : Data.Text.Text+  -> rs : [Data.Text.Text]+  -> { o : Data.Text.Text | len rs == 0 ==> tlen o == 0 }++transpose+  :: is : [Data.Text.Text]+  -> { os : [{ t : Data.Text.Text | tlen t <= len is }] | len is == 0 ==> len os == 0}++foldl1+  :: (_ -> _ -> _)+  -> { t : Data.Text.Text | 1 <= tlen t }+  -> _++foldl1'+  :: (_ -> _ -> _)+  -> { t : Data.Text.Text | 1 <= tlen t }+  -> _++foldr1+  :: (_ -> _ -> _)+  -> { t : Data.Text.Text | 1 <= tlen t }+  -> _++concat+  :: is : [Data.Text.Text]+  -> { o : Data.Text.Text | (len is == 0) ==> (tlen o == 0) }++concatMap+  :: (_ -> Data.Text.Text)+  -> i : Data.Text.Text+  -> { o : Data.Text.Text | tlen i == 0 ==> tlen o == 0 }++any+  :: (_ -> GHC.Types.Bool)+  -> t : Data.Text.Text+  -> { b : GHC.Types.Bool | tlen t == 0 ==> not b }++all+  :: (_ -> GHC.Types.Bool)+  -> t : Data.Text.Text+  -> { b : GHC.Types.Bool | tlen t == 0 ==> b }++maximum :: { t : Data.Text.Text | 1 <= tlen t } -> _++minimum :: { t : Data.Text.Text | 1 <= tlen t } -> _++scanl :: (_ -> _ -> _)+      -> _+      -> i : Data.Text.Text+      -> { o : Data.Text.Text | tlen o == tlen i }++scanl1 :: (_ -> _ -> _)+       -> i : { i : Data.Text.Text | 1 <= tlen i }+       -> { o : Data.Text.Text | tlen o == tlen i }++scanr+    :: (_ -> _ -> _)+    -> _+    -> i : Data.Text.Text+    -> { o : Data.Text.Text | tlen o == tlen i }++scanr1+    :: (_ -> _ -> _)+    -> i : { i : Data.Text.Text | 1 <= tlen i }+    -> { o : Data.Text.Text | tlen o == tlen i }++mapAccumL+    :: (acc -> _ -> (acc, _))+    -> acc+    -> i : Data.Text.Text+    -> (acc, { o : Data.Text.Text | tlen o == tlen i })++mapAccumR+    :: (acc -> _ -> (acc, _))+    -> acc+    -> i : Data.Text.Text+    -> (acc, { o : Data.Text.Text | tlen o == tlen i })++replicate+    :: n : Int+    -> _+    -> { t : Data.Text.Text | tlen t == n }++unfoldrN+    :: n : Int+    -> (a -> Maybe (_, a))+    -> a+    -> { t : Data.Text.Text | tlen t <= n }++take+    :: n : Int+    -> i : Data.Text.Text+    -> { o : Data.Text.Text | (n <= 0 <=> tlen o == 0) &&+                                          ((0 <= n && n <= tlen i) <=> tlen o == n) &&+                                          (tlen i <= n <=> tlen o = tlen i) }++drop+    :: n : Int+    -> i : Data.Text.Text+    -> { o : Data.Text.Text | (n <= 0 <=> tlen o == tlen i) &&+                                          ((0 <= n && n <= tlen i) <=> tlen o == tlen i - n) &&+                                          (tlen i <= n <=> tlen o == 0) }++splitAt+    :: n : Int+    -> i : Data.Text.Text+    -> ( { l : Data.Text.Text | (n <= 0 <=> tlen l == 0) &&+                                            ((0 <= n && n <= tlen i) <=> tlen l == n) &&+                                            (tlen i <= n <=> tlen l == tlen i) }+       , { r : Data.Text.Text | (n <= 0 <=> tlen r == tlen i) &&+                                            ((0 <= n && n <= tlen i) <=> tlen r == tlen i - n) &&+                                            (tlen i <= n <=> tlen r == 0) }+       )++takeWhile+    :: (_ -> GHC.Types.Bool)+    -> i : Data.Text.Text+    -> { o : Data.Text.Text | tlen o <= tlen i }++dropWhile+    :: (_ -> GHC.Types.Bool)+    -> i : Data.Text.Text+    -> { o : Data.Text.Text | tlen o <= tlen i }++span+    :: (_ -> GHC.Types.Bool)+    -> i : Data.Text.Text+    -> ( { l : Data.Text.Text | tlen l <= tlen i }+       , { r : Data.Text.Text | tlen r <= tlen i }+       )++break+    :: (_ -> GHC.Types.Bool)+    -> i : Data.Text.Text+    -> ( { l : Data.Text.Text | tlen l <= tlen i }+       , { r : Data.Text.Text | tlen r <= tlen i }+       )++group+    :: i : Data.Text.Text+    -> [{ o : Data.Text.Text | 1 <= tlen o && tlen o <= tlen i }]++groupBy+    :: (_ -> _ -> GHC.Types.Bool)+    -> i : Data.Text.Text+    -> [{ o : Data.Text.Text | 1 <= tlen o && tlen o <= tlen i }]++inits+    :: i : Data.Text.Text+    -> [{ o : Data.Text.Text | tlen o <= tlen i }]++tails+    :: i : Data.Text.Text+    -> [{ o : Data.Text.Text | tlen o <= tlen i }]++split+    :: (_ -> GHC.Types.Bool)+    -> i : Data.Text.Text+    -> [{ o : Data.Text.Text | tlen o <= tlen i }]++isPrefixOf+    :: l : Data.Text.Text+    -> r : Data.Text.Text+    -> { b : GHC.Types.Bool | tlen l >= tlen r ==> not b }++isSuffixOf+    :: l : Data.Text.Text+    -> r : Data.Text.Text+    -> { b : GHC.Types.Bool | tlen l > tlen r ==> not b }++isInfixOf+    :: l : Data.Text.Text+    -> r : Data.Text.Text+    -> { b : GHC.Types.Bool | tlen l > tlen r ==> not b }++find+    :: (_ -> GHC.Types.Bool)+    -> t : Data.Text.Text+    -> (Maybe { char : _ | tlen t /= 0 })++filter+    :: (_ -> GHC.Types.Bool)+    -> i : Data.Text.Text+    -> { o : Data.Text.Text | tlen o <= tlen i }++partition+    :: (_ -> GHC.Types.Bool)+    -> i : Data.Text.Text+    -> ( { l : Data.Text.Text | tlen l <= tlen i }+       , { r : Data.Text.Text | tlen r <= tlen i }+       )++index :: t : Data.Text.Text -> { n : Int | 0 <= n && n < tlen t } -> _++findIndex+    :: (_ -> GHC.Types.Bool)+    -> t : Data.Text.Text+    -> (Maybe { n : Int | 0 <= n && n < tlen t })++count+    :: _+    -> t : Data.Text.Text+    -> { n : Int | 0 <= n && n < tlen t }++zip+    :: l : Data.Text.Text+    -> r : Data.Text.Text+    -> { o : [(_, _)] | len o <= tlen l && len o <= tlen r }++zipWith+    :: (_ -> _ -> Char)+    -> l : Data.Text.Text+    -> r : Data.Text.Text+    -> { o : Text | tlen o <= tlen l && tlen o <= tlen r }++copy+    :: i : Data.Text.Text+    -> { o : Data.Text.Text | tlen o == tlen i }++uncons+    :: i : Data.Text.Text+    -> (Maybe (_, { o : Data.Text.Text | tlen o == tlen i - 1 }))+
+ include/Data/Time.spec view
@@ -0,0 +1,3 @@+module spec Data.Time where++import Data.Time.Calendar
+ include/Data/Time/Calendar.spec view
@@ -0,0 +1,11 @@+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/Vector.spec view
@@ -9,16 +9,18 @@  invariant       {v: Data.Vector.Vector a | 0 <= vlen v }  -assume !           :: forall a. x:(Data.Vector.Vector a) -> vec:{v:Nat | v < vlen x } -> a +!           :: forall a. x:(Data.Vector.Vector a) -> vec:{v:Nat | v < vlen x } -> a  -assume unsafeIndex :: forall a. x:(Data.Vector.Vector a) -> vec:{v:Nat | v < vlen x } -> a +unsafeIndex :: forall a. x:(Data.Vector.Vector a) -> vec:{v:Nat | v < vlen x } -> a  -assume fromList  :: forall a. x:[a] -> {v: Data.Vector.Vector a  | vlen v = len x }+fromList  :: forall a. x:[a] -> {v: Data.Vector.Vector a  | vlen v = len x } -assume length    :: forall a. x:(Data.Vector.Vector a) -> {v : Nat | v = vlen x }+length    :: forall a. x:(Data.Vector.Vector a) -> {v : Nat | v = vlen x } -assume replicate :: n:Nat -> a -> {v:Data.Vector.Vector a | vlen v = n} +replicate :: n:Nat -> a -> {v:Data.Vector.Vector a | vlen v = n}  -assume imap :: (Nat -> a -> b) -> x:(Data.Vector.Vector a) -> {y:Data.Vector.Vector b | vlen y = vlen x }+imap :: (Nat -> a -> b) -> x:(Data.Vector.Vector a) -> {y:Data.Vector.Vector b | vlen y = vlen x } -assume map :: (a -> b) -> x:(Data.Vector.Vector a) -> {y:Data.Vector.Vector b | vlen y = vlen x }+map :: (a -> b) -> x:(Data.Vector.Vector a) -> {y:Data.Vector.Vector b | vlen y = vlen x }++head :: forall a. {xs: Data.Vector.Vector a | vlen xs > 0} -> a
include/Data/Word.spec view
@@ -1,6 +1,10 @@ module spec Data.Word where -import GHC.Word+embed Data.Word.Word   as int+embed Data.Word.Word8  as int+embed Data.Word.Word16 as int+embed Data.Word.Word32 as int+embed Data.Word.Word64 as int -invariant {v:GHC.Word.Word32 | 0 <= v }-invariant {v:GHC.Word.Word16 | 0 <= v }+invariant {v : Data.Word.Word32 | 0 <= v }+invariant {v : Data.Word.Word16 | 0 <= v }
include/Foreign/C/String.spec view
@@ -5,5 +5,7 @@ type CStringLen    = ((GHC.Ptr.Ptr Foreign.C.Types.CChar), Nat)<{\p v -> (v <= (plen p))}> type CStringLenN N = ((GHC.Ptr.Ptr Foreign.C.Types.CChar), {v:Nat | v = N})<{\p v -> (v <= (plen p))}> -measure cStringLen :: Foreign.C.String.CStringLen -> GHC.Types.Int+// measure cStringLen :: Foreign.C.String.CStringLen -> GHC.Types.Int++measure cStringLen :: ((GHC.Ptr.Ptr Foreign.C.Types.CChar), GHC.Types.Int) -> GHC.Types.Int  cStringLen (c, n) = n
include/Foreign/ForeignPtr.spec view
@@ -9,8 +9,8 @@  GHC.ForeignPtr.newForeignPtr_     :: p:(GHC.Ptr.Ptr a) -> (GHC.Types.IO (ForeignPtrN a (plen p))) Foreign.Concurrent.newForeignPtr  :: p:(PtrV a) -> GHC.Types.IO () -> (GHC.Types.IO (ForeignPtrN a (plen p)))+Foreign.ForeignPtr.newForeignPtr ::  _ -> p:(PtrV a) -> (GHC.Types.IO (ForeignPtrN a (plen p))) -Foreign.ForeignPtr.newForeignPtr :: Foreign.ForeignPtr.FinalizerPtr a -> p:(PtrV a) -> (GHC.Types.IO (ForeignPtrN a (plen p)))  // this uses `sizeOf (undefined :: a)`, so the ForeignPtr does not necessarily have length `n` // Foreign.ForeignPtr.Imp.mallocForeignPtrArray :: (Foreign.Storable.Storable a) => n:Nat -> IO (ForeignPtrN a n)
include/GHC/Base.spec view
@@ -14,20 +14,27 @@ len []     = 0 len (y:ys) = 1 + len ys - // measure null :: [a] -> Bool // null []     = true  // null (y:ys) = false -measure fst :: (a,b) -> a-fst (a,b) = a+measure fst :: (a, b) -> a+fst (a, b) = a -measure snd :: (a,b) -> b-snd (a,b) = b+measure snd :: (a, b) -> b+snd (a, b) = b -qualif Fst(v:a, y:b): (v = (fst y))-qualif Snd(v:a, y:b): (v = (snd y))+qualif Fst(__v:a, __y:b): (__v = (fst __y))+qualif Snd(__v:a, __y:b): (__v = (snd __y)) +measure isJust :: Maybe a -> Bool+isJust (Just x)  = true+isJust (Nothing) = false++measure fromJust :: Maybe a -> a+fromJust (Just x) = x++ invariant {v: [a] | len v >= 0 } map       :: (a -> b) -> xs:[a] -> {v: [b] | len v == len xs} (++)      :: xs:[a] -> ys:[a] -> {v:[a] | len v == len xs + len ys}@@ -35,5 +42,38 @@ ($)       :: (a -> b) -> a -> b id        :: x:a -> {v:a | v = x} -data variance Text.ParserCombinators.ReadPrec.ReadPrec contravariant+// data variance Text.ParserCombinators.ReadPrec.ReadPrec contravariant++//qualif NonNull(v: [a])        : (? (nonnull v ))+//qualif Null(v: [a])           : (~ (? (nonnull v )))+//qualif EqNull(v:Bool, ~A: [a]): (v <=> (? (nonnull([~A]))))++// qualif IsEmp(v:GHC.Types.Bool, ~A: [a]) : ((v) <=> len([~A]) [ > ;  = ] 0)+// qualif ListZ(v: [a])          : len v  [ = ; >= ; > ] 0 +// qualif CmpLen(v:[a], ~A:[b])  : len v  [= ; >=; >; <=; <] len([~A]) +// qualif EqLen(v:int, ~A: [a])  : v = len([~A]) +// qualif LenEq(v:[a], ~A: int)  : ~A = len v  +// qualif LenAcc(v:int, ~A:[a], ~B: int): v = len([~A]) + ~B+// qualif LenDiff(v:[a], ~A:int): len v  = (~A [ +; - ] 1)++qualif IsEmp(v:GHC.Types.Bool, xs: [a]) : (v <=> (len xs > 0))+qualif IsEmp(v:GHC.Types.Bool, xs: [a]) : (v <=> (len xs = 0))++qualif ListZ(v: [a])          : (len v =  0) +qualif ListZ(v: [a])          : (len v >= 0) +qualif ListZ(v: [a])          : (len v >  0) ++qualif CmpLen(v:[a], xs:[b])  : (len v  =  len xs ) +qualif CmpLen(v:[a], xs:[b])  : (len v  >= len xs ) +qualif CmpLen(v:[a], xs:[b])  : (len v  >  len xs ) +qualif CmpLen(v:[a], xs:[b])  : (len v  <= len xs ) +qualif CmpLen(v:[a], xs:[b])  : (len v  <  len xs ) ++qualif EqLen(v:int, xs: [a])  : (v = len xs ) +qualif LenEq(v:[a], x: int)   : (x = len v ) ++qualif LenDiff(v:[a], x:int)  : (len v  = x + 1)+qualif LenDiff(v:[a], x:int)  : (len v  = x - 1)+qualif LenAcc(v:int, xs:[a], n: int): (v = len xs  + n)+
include/GHC/CString.spec view
@@ -1,8 +1,9 @@ module spec GHC.CString where -import GHC.Prim +import GHC.Prim  measure strLen :: GHC.Base.String -> GHC.Types.Int+ embed GHC.Types.Char as Char  GHC.CString.unpackCString#
+ include/GHC/Exts.spec view
@@ -0,0 +1,10 @@+module spec GHC.Exts where++// embed GHC.Exts.Int#     as int+// embed GHC.Exts.Word#    as int+// embed GHC.Exts.Addr#    as Str+// embed GHC.Exts.Double#  as real+// embed GHC.Exts.Char#    as Char+++
include/GHC/List.spec view
@@ -1,12 +1,11 @@ module spec GHC.List where  -head         :: xs:{v: [a] | len(v) > 0} -> {v:a | v = head xs}--tail         :: xs:{v: [a] | len(v) > 0} -> {v: [a] | len(v) = (len(xs) - 1) && v = tail xs}-last         :: xs:{v: [a] | len(v) > 0} -> a+head         :: xs:{v: [a] | len v > 0} -> {v:a | v = head xs}+tail         :: xs:{v: [a] | len v > 0} -> {v: [a] | len(v) = (len(xs) - 1) && v = tail xs} -init         :: xs:{v: [a] | len(v) > 0} -> {v: [a] | len(v) = len(xs) - 1}-null         :: xs:[a] -> {v: Bool | ((v) <=> len(xs) = 0) }+last         :: xs:{v: [a] | len v > 0} -> a+init         :: xs:{v: [a] | len v > 0} -> {v: [a] | len(v) = len(xs) - 1}+null         :: xs:[a] -> {v: GHC.Types.Bool | ((v) <=> len(xs) = 0) } length       :: xs:[a] -> {v: GHC.Types.Int | v = len(xs)} filter       :: (a -> GHC.Types.Bool) -> xs:[a] -> {v: [a] | len(v) <= len(xs)} scanl        :: (a -> b -> a) -> a -> xs:[b] -> {v: [a] | len(v) = 1 + len(xs) }@@ -26,9 +25,8 @@ cycle        :: {v: [a] | len(v) > 0 } -> [a] lazy cycle -takeWhile    :: (a -> Bool) -> xs:[a] -> {v: [a] | len(v) <= len(xs)}--dropWhile    :: (a -> Bool) -> xs:[a] -> {v: [a] | len(v) <= len(xs)}+takeWhile    :: (a -> GHC.Types.Bool) -> xs:[a] -> {v: [a] | len(v) <= len(xs)}+dropWhile    :: (a -> GHC.Types.Bool) -> xs:[a] -> {v: [a] | len(v) <= len(xs)}  take :: n:GHC.Types.Int      -> xs:[a]@@ -37,12 +35,12 @@      -> xs:[a]      -> {v:[a] | (if (n >= 0) then (len(v) = (if (len(xs) < n) then 0 else len(xs) - n)) else ((len v) = (len xs)))} -splitAt :: n:_ -> x:[a] -> ({v:[a] | (if (n >= 0) then (Min (len v) (len x) n) else ((len v) = 0))},[a])<{\x1 x2 -> (len x2) = (len x) - (len x1)}>-span    :: (a -> Bool) +splitAt :: n:_ -> x:[a] -> ({v:[a] | (if (n >= 0) then (if (len x) < n then (len v) = (len x) else (len v) = n) else ((len v) = 0))},[a])<{\x1 x2 -> (len x2) = (len x) - (len x1)}>+span    :: (a -> GHC.Types.Bool)          -> xs:[a]          -> ({v:[a]|((len v)<=(len xs))}, {v:[a]|((len v)<=(len xs))}) -break :: (a -> Bool) -> xs:[a] -> ([a],[a])<{\x y -> (len xs) = (len x) + (len y)}>+break :: (a -> GHC.Types.Bool) -> xs:[a] -> ([a],[a])<{\x y -> (len xs) = (len x) + (len y)}>  reverse      :: xs:[a] -> {v: [a] | len(v) = len(xs)}
include/GHC/Num.spec view
@@ -1,8 +1,8 @@ module spec GHC.Num where -GHC.Num.fromInteger :: (GHC.Num.Num a)-                    => x:GHC.Integer.Type.Integer-                    -> {v:a | v = x }+embed GHC.Integer.Type.Integer as int ++GHC.Num.fromInteger :: (GHC.Num.Num a) => x:GHC.Integer.Type.Integer -> {v:a | v = x }  GHC.Num.negate :: (GHC.Num.Num a)                => x:a
include/GHC/Prim.spec view
@@ -1,24 +1,6 @@-module spec GHC.Prim where--embed GHC.Prim.Int#  as int-embed GHC.Prim.Word# as int-embed GHC.Prim.Addr# as Str+module spec GHC.Prim where  +embed GHC.Prim.Int#     as int embed GHC.Prim.Double#  as real--measure addrLen :: GHC.Prim.Addr# -> GHC.Types.Int--assume GHC.Types.I# :: x:GHC.Prim.Int# -> {v: GHC.Types.Int | v = (x :: int) }-assume GHC.Prim.+#  :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v: GHC.Prim.Int# | v = x + y}-assume GHC.Prim.-#  :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v: GHC.Prim.Int# | v = x - y}-assume GHC.Prim.==# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int#-                    -> {v:GHC.Prim.Int# | ((v = 1) <=> x = y)}-assume GHC.Prim.>=# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -                    -> {v:GHC.Prim.Int# | ((v = 1) <=> x >= y)}-assume GHC.Prim.<=# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -                    -> {v:GHC.Prim.Int# | ((v = 1) <=> x <= y)}-assume GHC.Prim.<#  :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -                    -> {v:GHC.Prim.Int# | ((v = 1) <=> x < y)}-assume GHC.Prim.>#  :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -                    -> {v:GHC.Prim.Int# | ((v = 1) <=> x > y)}-+embed GHC.Prim.Float#  as real+embed GHC.Prim.Word#    as int
include/GHC/Ptr.spec view
@@ -1,8 +1,8 @@ module spec GHC.Ptr where -measure pbase     :: Foreign.Ptr.Ptr a -> GHC.Types.Int-measure plen      :: Foreign.Ptr.Ptr a -> GHC.Types.Int-measure isNullPtr :: Foreign.Ptr.Ptr a -> Bool +measure pbase     :: GHC.Ptr.Ptr a -> GHC.Types.Int+measure plen      :: GHC.Ptr.Ptr a -> GHC.Types.Int+measure isNullPtr :: GHC.Ptr.Ptr a -> Bool   invariant {v:Foreign.Ptr.Ptr a | 0 <= plen  v } invariant {v:Foreign.Ptr.Ptr a | 0 <= pbase v }
include/GHC/Real.spec view
@@ -7,7 +7,7 @@ class (GHC.Num.Num a) => GHC.Real.Fractional a where   (GHC.Real./)   :: x:a -> y:{v:a | v /= 0} -> {v:a | v == x / y}   GHC.Real.recip :: a -> a-  GHC.Real.fromRational :: GHC.Real.Rational -> a+  GHC.Real.fromRational :: GHC.Real.Ratio Integer -> a  class (GHC.Real.Real a, GHC.Enum.Enum a) => GHC.Real.Integral a where   GHC.Real.quot :: x:a -> y:{v:a | v /= 0} -> {v:a | (v = (x / y)) &&
include/GHC/Types.spec view
@@ -1,5 +1,12 @@ module spec GHC.Types where +embed GHC.Prim.Int#     as int+embed GHC.Prim.Addr#    as Str+embed GHC.Prim.Char#    as Char+embed GHC.Types.Double# as real+embed GHC.Types.Float# as real+embed GHC.Types.Word    as int + // TODO: Drop prefix below // GHC.Types.EQ :: {v:GHC.Types.Ordering | v = (cmp v) } // GHC.Types.LT :: {v:GHC.Types.Ordering | v = (cmp v) }@@ -14,11 +21,21 @@ GHC.Types.True  :: {v:GHC.Types.Bool | v     } GHC.Types.False :: {v:GHC.Types.Bool | (~ v) } --GHC.Types.isTrue#  :: n:_ -> {v:GHC.Types.Bool | ((n = 1) <=> ((v)))}-+GHC.Types.isTrue#  :: n:_ -> {v:GHC.Types.Bool | (n = 1 <=> v)}  GHC.Types.W# :: w:_ -> {v:GHC.Types.Word | v == w } +assume GHC.Types.D# :: x:GHC.Prim.Double# -> {v: GHC.Types.Double | v = (x :: real) }+assume GHC.Types.F# :: x:GHC.Prim.Float# -> {v: GHC.Types.Float | v = (x :: real) }+assume GHC.Types.I# :: x:GHC.Prim.Int# -> {v: GHC.Types.Int | v = (x :: int) }+assume GHC.Types.C# :: x:GHC.Prim.Char# -> {v: GHC.Types.Char | v = (x :: Char) } +assume GHC.Prim.+#  :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v: GHC.Prim.Int# | v = x + y}+assume GHC.Prim.-#  :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v: GHC.Prim.Int# | v = x - y}+assume GHC.Prim.==# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v:GHC.Prim.Int# | v = 1 <=> x = y}+assume GHC.Prim.>=# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v:GHC.Prim.Int# | v = 1 <=> x >= y}+assume GHC.Prim.<=# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v:GHC.Prim.Int# | v = 1 <=> x <= y}+assume GHC.Prim.<#  :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v:GHC.Prim.Int# | v = 1 <=> x < y}+assume GHC.Prim.>#  :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v:GHC.Prim.Int# | v = 1 <=> x > y} +measure addrLen :: GHC.Prim.Addr# -> GHC.Types.Int
include/Language/Haskell/Liquid/Bag.hs view
@@ -1,19 +1,37 @@ module Language.Haskell.Liquid.Bag where -import qualified Data.Map as M+import qualified Data.Map      as M -{-@ embed   M.Map as Map_t                                  @-}-{-@ measure Map_default :: Int -> Bag a                     @-}-{-@ measure Map_union   :: Bag a -> Bag a -> Bag a          @-}-{-@ measure Map_select  :: M.Map k v -> k -> v              @-}-{-@ measure Map_store   :: M.Map k v -> k -> v -> M.Map k v @-}+{-@ embed   Data.Map.Map as Map_t                                         @-} +{-@ measure Map_default :: Int -> Bag a                                   @-}+{-@ measure Map_union   :: Bag a -> Bag a -> Bag a                        @-}+{-@ measure Map_select  :: Data.Map.Map k v -> k -> v                     @-}+{-@ measure Map_store   :: Data.Map.Map k v -> k -> v -> Data.Map.Map k v @-}+{-@ measure bagSize     :: Bag k -> Int                                   @-}++-- if I just write measure fromList the measure definition is not imported+{-@ measure fromList :: [k] -> Bag k+fromList ([])   = (Map_default 0)+fromList (x:xs) = Map_store (fromList xs) x (1 + (Map_select (fromList xs) x))+@-}++ type Bag a = M.Map a Int  {-@ assume empty :: {v:Bag k | v = Map_default 0} @-} empty :: Bag k empty = M.empty +{-@ assume bagSize :: b:Bag k -> {i:Nat | i == bagSize b} @-}+bagSize :: Bag k -> Int +bagSize b = sum (M.elems b) ++{-@ fromList :: (Ord k) => xs:[k] -> {v:Bag k | v == fromList xs } @-} +fromList :: (Ord k) => [k] -> Bag k +fromList []     = empty+fromList (x:xs) = put x (fromList xs)+ {-@ assume get :: (Ord k) => k:k -> b:Bag k -> {v:Nat | v = Map_select b k}  @-} get :: (Ord k) => k -> Bag k -> Int get k m = M.findWithDefault 0 k m@@ -25,3 +43,11 @@ {-@ assume union :: (Ord k) => m1:Bag k -> m2:Bag k -> {v:Bag k | v = Map_union m1 m2} @-} union :: (Ord k) => Bag k -> Bag k -> Bag k union m1 m2 = M.union m1 m2++{-@ thm_emp :: x:k -> xs:Bag k ->  { Language.Haskell.Liquid.Bag.empty /= put x xs }  @-}+thm_emp :: (Ord k) => k -> Bag k -> ()  +thm_emp x xs = const () (get x xs)++{-@ assume thm_size :: xs:[k] ->  { bagSize (fromList xs) == len xs }  @-}+thm_size :: (Ord k) => [k] -> ()  +thm_size _ = ()
+ include/Language/Haskell/Liquid/Equational.hs view
@@ -0,0 +1,55 @@+module Language.Haskell.Liquid.Equational where ++-------------------------------------------------------------------------------+-- | Proof is just unit+-------------------------------------------------------------------------------++type Proof = ()++-------------------------------------------------------------------------------+-- | Casting expressions to Proof using the "postfix" `*** QED` +-------------------------------------------------------------------------------++data QED = QED ++infixl 2 ***+(***) :: a -> QED -> Proof+_ *** QED = () ++-------------------------------------------------------------------------------+-- | Equational Reasoning operators +-- | The `eq` operator is inlined in the logic, so can be used in reflected +-- | functions while ignoring the equality steps. +-------------------------------------------------------------------------------++infixl 3 ==., `eq` +++{-@ (==.) :: x:a -> y:{a | x == y} -> {v:a | v == y && v == x} @-}+(==.) :: a -> a -> a +_ ==. x = x +{-# INLINE (==.) #-} +++{-@ eq :: x:a -> y:{a | x == y} -> {v:a | v == y && v == x} @-}+eq :: a -> a -> a +_ `eq` x = x +{-# INLINE eq #-} ++-------------------------------------------------------------------------------+-- | Explanations+-------------------------------------------------------------------------------++infixl 3 ?++{-@ (?) :: forall a b <pa :: a -> Bool>. a<pa> -> b -> a<pa> @-}+(?) :: a -> b -> a +x ? _ = x +{-# INLINE (?)   #-} ++-------------------------------------------------------------------------------+-- | Using proofs as theorems +-------------------------------------------------------------------------------++withTheorem :: a -> Proof -> a +withTheorem z _ = z
include/Language/Haskell/Liquid/Example.hs view
@@ -3,7 +3,7 @@  module ListExample where -import NewProofCombinators+import ProofCombinators  import Prelude hiding ((++))
− include/Language/Haskell/Liquid/NewProofCombinators.hs 
@@ -1,214 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE IncoherentInstances   #-}--module Language.Haskell.Liquid.NewProofCombinators (--  -- ATTENTION! `Admit` and `(==!)` are UNSAFE: they should not belong the final proof term--  -- * Proof is just a () alias-  Proof--  -- * Proof constructors-  , trivial, unreachable, (***), QED(..)--  -- * Proof certificate constructors-  , (?)--  -- * These two operators check all intermediate equalities-  , (===) -- proof of equality is implicit eg. x === y-  , (==?) -- proof of equality is explicit eg. x ==? y ? p-  , (=<=) -- proof of equality is implicit eg. x <= y-  , (=<=?) -- proof of equality is explicit eg. x <= y-  , (=>=)  -- proof of equality is implicit eg. x =>= y -  , (=>=?) -- proof of equality is explicit eg. x =>=? y ? p---  -- Uncheck operator used only for proof debugging-  , (==!) -- x ==! y always succeds--  -- * The below operator does not check intermediate equalities-  --   but takes optional proof argument.-  , (==.)--  -- * Combining Proofs-  , (&&&)-  , withProof -  , impossible ---) where------------------------------------------------------------------------------------ | Proof is just a () alias -----------------------------------------------------------------------------------------------------------------------------------type Proof = ()------------------------------------------------------------------------------------ | Proof Construction ------------------------------------------------------------------------------------------------------------------------------------------- | trivial is proof by SMT--trivial :: Proof-trivial =  ()---- {-@ unreachable :: {v : Proof | False } @-}-unreachable :: Proof-unreachable =  ()---- All proof terms are deleted at runtime.-{- RULE "proofs are irrelevant" forall (p :: Proof). p = () #-}---- | proof casting--- | `x *** QED`: x is a proof certificate* strong enough for SMT to prove your theorem--- | `x *** Admit`: x is an unfinished proof--infixl 3 ***-{-@ assume (***) :: a -> p:QED -> { if (isAdmit p) then false else true } @-}-(***) :: a -> QED -> Proof-_ *** _ = ()--data QED = Admit | QED--{-@ measure isAdmit :: QED -> Bool @-}-{-@ Admit :: {v:QED | isAdmit v } @-}------------------------------------------------------------------------------------- | * Checked Proof Certificates --------------------------------------------------------------------------------------------------------------------------------- Any (refined) carries proof certificates.--- For example 42 :: {v:Int | v == 42} is a certificate that--- the value 42 is equal to 42.--- But, this certificate will not really be used to proof any fancy theorems.---- Below we provide a number of equational operations--- that constuct proof certificates.---- | Implicit equality---- x === y returns the proof certificate that--- result value is equal to both x and y--- when y == x (as assumed by the operator's precondition)--infixl 3 ===-{-@ (===) :: x:a -> y:{a | y == x} -> {v:a | v == x && v == y} @-}-(===) :: a -> a -> a-x === _  = x--infixl 3 =<=-{-@ (=<=) :: x:a -> y:{a | x <= y} -> {v:a | v == y} @-}-(=<=) :: a -> a -> a-_ =<= y  = y--infixl 3 =>=-{-@ (=>=) :: x:a -> y:{a | x >= y}  -> {v:a | v == y} @-}-(=>=) :: a -> a -> a-_ =>= y  = y-------------------------------------------------------------------------------------- | Explicit equality--- 	`x ==? y ? p`---   returns the proof certificate that result value is equal to both x and y---   when y == x is explicitely asserted by the proof term p----------------------------------------------------------------------------------infixl 3 ==?-{-@ (==?) :: x:a -> y:a -> {v:_ | x == y} -> {v:a | v == x && v == y} @-}-(==?) :: a -> a -> b -> a-(==?) x _ _ = x--infixl 3 =<=?-{-@ (=<=?) :: x:a -> y:a -> {v:_ | x <= y} -> {v:a | v == y} @-}-(=<=?) :: a -> a -> b ->  a-(=<=?) _ y _ = y--infixl 3 =>=?-{-@ (=>=?) :: x:a -> y:a -> {v:_ | x >= y} -> {v:a | v == y} @-}-(=>=?) :: a -> a -> b -> a-(=>=?) _ y _  = y------------------------------------------------------------------------------------ | `?` is basically Haskell's $ and is used for the right precedence----------------------------------------------------------------------------------infixl 3 ?-(?) :: (proof -> a) -> proof -> a-f ? y = f y------------------------------------------------------------------------------------- | Assumed equality--- 	`x ==! y `---   returns the admitted proof certificate that result value is equals x and y----------------------------------------------------------------------------------infixl 3 ==!-{-@ assume (==!) :: x:a -> y:a -> {v:a | v == x && v == y} @-}-(==!) :: a -> a -> a-(==!) x _ = x----- | To summarize:------ 	- (==!) is *only* for proof debuging---	- (===) does not require explicit proof term--- 	- (==?) requires explicit proof term------------------------------------------------------------------------------------ | * Unchecked Proof Certificates ------------------------------------------------------------------------------------------------------------------------------- The above operators check each intermediate proof step.--- The operator `==.` below accepts an optional proof term--- argument, but does not check intermediate steps.--infixl 3 ==.--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------------------------------------------------------------------------------------ | * Combining Proof Certificates ------------------------------------------------------------------------------------------------------------------------------(&&&) :: Proof -> Proof -> Proof-x &&& _ = x---{-@ withProof :: x:a -> b -> {v:a | v = x} @-}-withProof :: a -> b -> a-withProof x y = x--{-@ impossible :: {v:a | false} -> b @-}-impossible :: a -> b-impossible _ = undefined------------------------------------------------------------------------------------ | Convenient Syntax for Inductive Propositions ----------------------------------------------------------------------------------{-@ measure prop :: a -> b           @-}-{-@ type Prop E = {v:_ | prop v = E} @-}---
+ include/Language/Haskell/Liquid/OldProofCombinators.hs view
@@ -0,0 +1,272 @@+{-# 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
@@ -139,3 +139,12 @@ 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
@@ -1,271 +1,183 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE IncoherentInstances   #-}-module Language.Haskell.Liquid.ProofCombinators ( -    (==:), (<=:), (<:), (>:)--  , (==?)--  , (==.), (<=.), (<.), (>.), (>=.)--  , (?), (***)+module Language.Haskell.Liquid.ProofCombinators ( -  , (==>), (&&&), (∵)+  -- ATTENTION! `Admit` and `(==!)` are UNSAFE: they should not belong the final proof term -  , proof, toProof, simpleProof, trivial+  -- * Proof is just a () alias+  Proof+  , toProof  -  , QED(..)+  -- * Proof constructors+  , trivial, unreachable, (***), QED(..) -  , Proof+  -- * Proof certificate constructors+  , (?) -  , byTheorem, castWithTheorem, cast +  -- * These two operators check all intermediate equalities+  , (===) -- proof of equality is implicit eg. x === y+  , (=<=) -- proof of equality is implicit eg. x <= y+  , (=>=)  -- proof of equality is implicit eg. x =>= y  -  -- Function Equality -  , Arg+  -- * This operator does not check intermediate equalities+  , (==.)  -  , (=*=.)+  -- Uncheck operator used only for proof debugging+  , (==!) -- x ==! y always succeds -  -- Conjunction-  , PAnd (..)+  -- * Combining Proofs+  , (&&&)+  , withProof +  , impossible   -  -- Disjunction-  , POr (..)--  ) where+) where +-------------------------------------------------------------------------------+-- | Proof is just a () alias -------------------------------------------------+-------------------------------------------------------------------------------  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-+-------------------------------------------------------------------------------+-- | Proof Construction -------------------------------------------------------+------------------------------------------------------------------------------- -(>:) :: a -> a -> Proof -> a-{-@ (>:) :: x:a -> y:a -> {v:Proof | x > y } -> {v:a | v == y } @-}-(>:) _ y _ = y+-- | trivial is proof by SMT +trivial :: Proof+trivial =  () -(==:) :: a -> a -> Proof -> a-{-@ (==:) :: x:a -> y:a -> {v:Proof| x == y} -> {v:a | v == x && v == y } @-}-(==:) x _ _ = x+-- {-@ unreachable :: {v : Proof | False } @-}+unreachable :: Proof+unreachable =  () +-- All proof terms are deleted at runtime.+{- RULE "proofs are irrelevant" forall (p :: Proof). p = () #-} --- | proof operators with optional proof terms-infixl 3 ==., <=., <., >., >=.+-- | proof casting+-- | `x *** QED`: x is a proof certificate* strong enough for SMT to prove your theorem+-- | `x *** Admit`: x is an unfinished proof +infixl 3 ***+{-@ assume (***) :: a -> p:QED -> { if (isAdmit p) then false else true } @-}+(***) :: a -> QED -> Proof+_ *** _ = () --- | Comparison operators requiring proof terms optionally+data QED = Admit | QED -class ToProve a r where-  (==?) :: a -> a -> r+{-@ measure isAdmit :: QED -> Bool @-}+{-@ Admit :: {v:QED | isAdmit v } @-}  -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-+-------------------------------------------------------------------------------+-- | * Checked Proof Certificates ---------------------------------------------+------------------------------------------------------------------------------- +-- Any (refined) carries proof certificates.+-- For example 42 :: {v:Int | v == 42} is a certificate that+-- the value 42 is equal to 42.+-- But, this certificate will not really be used to proof any fancy theorems. -class OptEq a r where-  (==.) :: a -> a -> r+-- Below we provide a number of equational operations+-- that constuct proof certificates. -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+-- | Implicit equality -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+-- x === y returns the proof certificate that+-- result value is equal to both x and y+-- when y == x (as assumed by the operator's precondition) +infixl 3 ===+{-@ (===) :: x:a -> y:{a | y == x} -> {v:a | v == x && v == y} @-}+(===) :: a -> a -> a+_ === y  = y -class OptLEq a r where-  (<=.) :: a -> a -> r+infixl 3 =<=+{-@ (=<=) :: x:a -> y:{a | x <= y} -> {v:a | v == y} @-}+(=<=) :: a -> a -> a+_ =<= y  = y +infixl 3 =>=+{-@ (=>=) :: x:a -> y:{a | x >= y}  -> {v:a | v == y} @-}+(=>=) :: a -> a -> a+_ =>= y  = y -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+-------------------------------------------------------------------------------+-- | `?` is basically Haskell's $ and is used for the right precedence+-- | `?` lets you "add" some fact into a proof term+------------------------------------------------------------------------------- -instance (a~b) => OptLEq a b where-{-@ instance OptLEq a b where-  <=. :: x:a -> y:{a | x <= y} -> {v:b | v ~~ y }-  @-}-  (<=.) _ y = y+infixl 3 ? -class OptGEq a r where-  (>=.) :: a -> a -> r+{-@ (?) :: forall a b <pa :: a -> Bool, pb :: b -> Bool>. a<pa> -> b<pb> -> a<pa> @-}+(?) :: a -> b -> a +x ? _ = x +{-# INLINE (?)   #-}  -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+-------------------------------------------------------------------------------+-- | Assumed equality+-- 	`x ==! y `+--   returns the admitted proof certificate that result value is equals x and y+------------------------------------------------------------------------------- -instance OptGEq a a where-{-@ instance OptGEq a a where-  >=. :: x:a -> y:{a| x >= y} -> {v:a | v == y  }-  @-}-  (>=.) _ y = y+infixl 3 ==!+{-@ assume (==!) :: x:a -> y:a -> {v:a | v == x && v == y} @-}+(==!) :: a -> a -> a+(==!) _ 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+-- | To summarize:+--+-- 	- (==!) is *only* for proof debugging+--	- (===) does not require explicit proof term+-- 	- (?)   lets you insert "lemmas" as other `Proof` values +-------------------------------------------------------------------------------+-- | * Unchecked Proof Certificates -------------------------------------------+------------------------------------------------------------------------------- -class OptGt a r where-  (>.) :: a -> a -> r+-- | The above operators check each intermediate proof step.+--   The operator `==.` below accepts an optional proof term+--   argument, but does not check intermediate steps.+--   TODO: What is it USEFUL FOR? -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+infixl 3 ==. -instance (a~b) => OptGt a b where-{-@ instance OptGt a b where-  >. :: x:a -> y:{a| x > y} -> {v:b | v ~~ y  }-  @-}-  (>.) _ x = x+{-# DEPRECATED (==.) "Use (===) instead" #-} +{-# INLINE (==.) #-} +(==.) :: a -> a -> a +_ ==. x = x   ------------------------------------------------------------------------------------------  Casting -----------------------------------------------------------+-- | * Combining Proof Certificates ------------------------------------------- ------------------------------------------------------------------------------- -{-@ 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 +(&&&) :: Proof -> Proof -> Proof+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  --}+{-@ withProof :: x:a -> b -> {v:a | v = x} @-}+withProof :: a -> b -> a+withProof x _ = x -class Arg a where +{-@ impossible :: {v:a | false} -> b @-}+impossible :: a -> b+impossible _ = undefined +-------------------------------------------------------------------------------+-- | Convenient Syntax for Inductive Propositions +------------------------------------------------------------------------------- -{-@ 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+{-@ measure prop :: a -> b           @-}+{-@ type Prop E = {v:_ | prop v = E} @-}   -data POr  a b = POrLeft a | POrRight b -data PAnd a b = PAnd a b
+ include/Language/Haskell/Liquid/RTick.hs view
@@ -0,0 +1,440 @@++--+-- Liquidate your assets: reasoning about resource usage in Liquid Haskell.+-- Martin A.T. Handley, Niki Vazou, and Graham Hutton.+--++{-@ LIQUID "--reflection" @-}++module Language.Haskell.Liquid.RTick+  (++  -- Tick datatype:+    Tick(..)+  -- Primitive resource operators:+  , fmap+  , pure+  , (<*>)+  , liftA2+  , return+  , (>>=)+  , (=<<)+  , eqBind+  , leqBind+  , geqBind+  , ap+  , liftM+  , liftM2+  -- Resource modifiers:+  , step+  , wait      -- step 1       . return+  , waitN     -- step (n > 0) . return+  , go        -- step (-1)    . return+  , goN       -- step (n < 0) . return+  , wmap      -- step 1       . fmap f+  , wmapN     -- step (n > 0) . fmap f+  , gmap      -- step (-1)    . fmap f+  , gmapN     -- step (n < 0) . fmap f+  , (</>)     -- step 1       . (f <*>)+  , (<//>)    -- step 2       . (f <*>)+  , (<\>)     -- step (-1)    . (f <*>)+  , (<\\>)    -- step (-2)    . (f <*>)+  , (>/=)     -- step 1       . (>>= f)+  , (=/<)     -- step 1       . (>>= f)+  , (>//=)    -- step 2       . (>>= f)+  , (=//<)    -- step 2       . (>>= f)+  , (>\=)     -- step (-1)    . (>>= f)+  , (=\<)     -- step (-1)    . (>>= f)+  , (>\\=)    -- step (-2)    . (>>= f)+  , (=\\<)    -- step (-2)    . (>>= f)+  -- Memoisation:+  , pay+  , zipWithM+++  ) where++import Prelude hiding ( Functor(..), Applicative(..), Monad(..), (=<<) )++import qualified Control.Applicative as A+import qualified Control.Monad       as M+import qualified Data.Functor        as F++--+-- The 'Tick' datatype and its corresponding resource modifiers.+--+-- See 'ResourceModifiers.hs' for proofs that all resource modifiers+-- can be defined using 'return', '(>>=) 'and 'step'.+--++-------------------------------------------------------------------------------+-- | 'Tick' datatype for recording resource usage:+-------------------------------------------------------------------------------++{-@ data Tick a = Tick { tcost :: Int, tval :: a } @-}+data Tick a = Tick { tcost :: Int, tval :: a }++-------------------------------------------------------------------------------+-- | Primitive resource operators:+-------------------------------------------------------------------------------++instance F.Functor Tick where+  fmap = fmap++{-@ reflect fmap @-}+{-@ fmap :: f:(a -> b) -> t1:Tick a+    -> { t:Tick b | Tick (tcost t1) (f (tval t1)) == t }+@-}+fmap :: (a -> b) -> Tick a -> Tick b+fmap f (Tick m x) = Tick m (f x)++instance A.Applicative Tick where+  pure  = pure+  (<*>) = (<*>)++{-@ reflect pure @-}+{-@ pure :: x:a -> { t:Tick a | x == tval t && 0 == tcost t } @-}+pure :: a -> Tick a+pure x = Tick 0 x++{-@ reflect <*> @-}+{-@ (<*>) :: t1:Tick (a -> b) -> t2:Tick a+    -> { t:Tick b | (tval t1) (tval t2) == tval  t &&+                    tcost t1 + tcost t2 == tcost t }+@-}+infixl 4 <*>+(<*>) :: Tick (a -> b) -> Tick a -> Tick b+Tick m f <*> Tick n x = Tick (m + n) (f x)++{-@ reflect liftA2 @-}+{-@ liftA2 :: f:(a -> b -> c) -> t1:Tick a -> t2:Tick b+    -> { t:Tick c | f (tval t1) (tval t2) == tval  t &&+                      tcost t1 + tcost t2 == tcost t }+@-}+liftA2 :: (a -> b -> c) -> Tick a -> Tick b -> Tick c+liftA2 f (Tick m x) (Tick n y) = Tick (m + n) (f x y)++instance M.Monad Tick where+  return = return+  (>>=)  = (>>=)++{-@ reflect return @-}+{-@ return :: x:a -> { t:Tick a | x == tval t && 0 == tcost t } @-}+return :: a -> Tick a+return x = Tick 0 x++{-@ reflect >>= @-}+{-@ (>>=) :: t1:Tick a -> f:(a -> Tick b)+    -> { t:Tick b | tval (f (tval t1))  == tval  t &&+         tcost t1 + tcost (f (tval t1)) == tcost t }+@-}+infixl 4 >>=+(>>=) :: Tick a -> (a -> Tick b) -> Tick b+Tick m x >>= f = let Tick n y = f x in Tick (m + n) y++{-@ reflect =<< @-}+{-@ (=<<) :: f:(a -> Tick b) -> t1:Tick a+    -> { t:Tick b | tval (f (tval t1))  == tval  t &&+         tcost t1 + tcost (f (tval t1)) == tcost t }+@-}+infixl 4 =<<+(=<<) :: (a -> Tick b) -> Tick a -> Tick b+f =<< Tick m x = let Tick n y = f x in Tick (m + n) y++{-@ reflect ap @-}+{-@ ap :: t1:(Tick (a -> b)) -> t2:Tick a+    -> { t:Tick b | (tval t1) (tval t2) == tval  t &&+                    tcost t1 + tcost t2 == tcost t }+@-}+ap :: Tick (a -> b) -> Tick a -> Tick b+ap (Tick m f) (Tick n x) = Tick (m + n) (f x)++{-@ reflect liftM @-}+{-@ liftM :: f:(a -> b) -> t1:Tick a -> { t:Tick b | tcost t1 == tcost t } @-}+liftM :: (a -> b) -> Tick a -> Tick b+liftM f (Tick m x) = Tick m (f x)++{-@ reflect liftM2 @-}+{-@ liftM2 :: f:(a -> b -> c) -> t1:Tick a -> t2:Tick b+    -> { t:Tick c | f (tval t1) (tval t2) == tval  t &&+                      tcost t1 + tcost t2 == tcost t }+@-}+liftM2 :: (a -> b -> c) -> Tick a -> Tick b -> Tick c+liftM2 f (Tick m x) (Tick n y) = Tick (m + n) (f x y)++-------------------------------------------------------------------------------++{-@ reflect eqBind @-}+{-@ eqBind :: n:Int -> t1:Tick a+    -> f:(a -> { tf:Tick b | n == tcost tf })+    -> { t:Tick b | tval (f (tval t1))  == tval  t &&+                           tcost t1 + n == tcost t }+@-}+eqBind :: Int -> Tick a -> (a -> Tick b) -> Tick b+eqBind _ (Tick m x) f = let Tick n y = f x in Tick (m + n) y++{-@ reflect leqBind @-}+{-@ leqBind :: n:Int -> t1:Tick a+    -> f:(a -> { tf:Tick b | n >= tcost tf })+    -> { t:Tick b | tcost t1 + n >= tcost t }+@-}+leqBind :: Int -> Tick a -> (a -> Tick b) -> Tick b+leqBind _ (Tick m x) f = let Tick n y = f x in Tick (m + n) y++{-@ reflect geqBind @-}+{-@ geqBind :: n:Int -> t1:Tick a+    -> f:(a -> { tf:Tick b | n <= tcost tf })+    -> { t2:Tick b | tcost t1 + n <= tcost t2 }+@-}+geqBind :: Int -> Tick a -> (a -> Tick b) -> Tick b+geqBind _ (Tick m x) f = let Tick n y = f x in Tick (m + n) y++-------------------------------------------------------------------------------+-- | Resource modifiers:+-------------------------------------------------------------------------------++{-@ reflect step @-}+{-@ step :: m:Int -> t1:Tick a+    -> { t:Tick a | tval t1 == tval t && m + tcost t1 == tcost t }+@-}+step :: Int -> Tick a -> Tick a+step m (Tick n x) = Tick (m + n) x++--+-- @wait := step 1 . return@.+--+{-@ reflect wait @-}+{-@ wait :: x:a -> { t:Tick a | x == tval t && 1 == tcost t } @-}+wait :: a -> Tick a+wait x = Tick 1 x++--+-- @waitN (n > 0) := step n . return@.+--+{-@ reflect waitN @-}+{-@ waitN :: n:Nat -> x:a+    -> { t:Tick a | x == tval t && n == tcost t }+@-}+waitN :: Int -> a -> Tick a+waitN n x = Tick n x++--+-- @go := step (-1) . return@.+--+{-@ reflect go @-}+{-@ go :: x:a -> { t:Tick a | x == tval t && (-1) == tcost t } @-}+go :: a -> Tick a+go x = Tick (-1) x++--+-- @goN (n > 0) := step (-n) . return@.+--+{-@ reflect goN @-}+{-@ goN :: { n:Nat | n > 0 } -> x:a+    -> { t:Tick a | x == tval t && (-n) == tcost t }+@-}+goN :: Int -> a -> Tick a+goN n x = Tick (-n) x++--+-- @wmap f := step 1 . fmap f@.+--+{-@ reflect wmap @-}+{-@ wmap :: f:(a -> b) -> t1:Tick a+    -> { t:Tick b | Tick (1 + tcost t1) (f (tval t1)) == t }+@-}+wmap :: (a -> b) -> Tick a -> Tick b+wmap f (Tick m x) = Tick (1 + m) (f x)++--+-- @wmapN (n > 0) f := step n . fmap f@.+--+{-@ reflect wmapN @-}+{-@ wmapN :: { m:Nat | m > 0 } -> f:(a -> b) -> t1:Tick a+    -> { t:Tick b | Tick (m + tcost t1) (f (tval t1)) == t }+@-}+wmapN :: Int -> (a -> b) -> Tick a -> Tick b+wmapN m f (Tick n x) = Tick (m + n) (f x)++--+-- @gmap f := step (-1) . fmap f@.+--+{-@ reflect gmap @-}+{-@ gmap :: f:(a -> b) -> t1:Tick a+    -> { t:Tick b | Tick (tcost t1 - 1) (f (tval t1)) == t }+@-}+gmap :: (a -> b) -> Tick a -> Tick b+gmap f (Tick m x) = Tick (m - 1) (f x)++--+-- @gmapN (n > 0) f := step (-n) . fmap f@.+--+{-@ reflect gmapN @-}+{-@ gmapN :: { m:Nat | m > 0 } -> f:(a -> b) -> t1:Tick a+    -> { t:Tick b | Tick (tcost t1 - m) (f (tval t1)) == t }+@-}+gmapN :: Int -> (a -> b) -> Tick a -> Tick b+gmapN m f (Tick n x) = Tick (n - m) (f x)++--+-- \"wapp\": @(f </>) := step 1 . (f <*>)@.+--+{-@ reflect </> @-}+{-@ (</>) :: t1:(Tick (a -> b)) -> t2:Tick a+    -> { t:Tick b | (tval t1) (tval t2) == tval  t &&+                1 + tcost t1 + tcost t2 == tcost t }+@-}+infixl 4 </>+(</>) :: Tick (a -> b) -> Tick a -> Tick b+Tick m f </> Tick n x = Tick (1 + m + n) (f x)++--+-- \"wwapp\": @(f <//>) := step 2 . (f <*>)@.+--+{-@ reflect <//> @-}+{-@ (<//>) :: t1:(Tick (a -> b)) -> t2:Tick a+    -> { t:Tick b | (tval t1) (tval t2) == tval  t &&+                2 + tcost t1 + tcost t2 == tcost t }+@-}+infixl 4 <//>+(<//>) :: Tick (a -> b) -> Tick a -> Tick b+Tick m f <//> Tick n x = Tick (2 + m + n) (f x)++--+-- \"gapp\": @(f <\>) := step (-1) . (f <*>)@.+--+{-@ reflect <\> @-}+{-@ (<\>) :: t1:(Tick (a -> b)) -> t2:Tick a+    -> { t:Tick b | (tval t1) (tval t2) == tval  t &&+                tcost t1 + tcost t2 - 1 == tcost t }+@-}+infixl 4 <\>+(<\>) :: Tick (a -> b) -> Tick a -> Tick b+Tick m f <\> Tick n x = Tick (m + n - 1) (f x)++--+-- \"ggapp\": @(f <\\>) := step (-2) . (f <*>)@.+--+{-@ reflect <\\> @-}+{-@ (<\\>) :: t1:(Tick (a -> b)) -> t2:Tick a+    -> { t:Tick b | (tval t1) (tval t2) == tval  t &&+                tcost t1 + tcost t2 - 2 == tcost t }+@-}+infixl 4 <\\>+(<\\>) :: Tick (a -> b) -> Tick a -> Tick b+Tick m f <\\> Tick n x = Tick (m + n - 2) (f x)++--+-- \"wbind\": @(>/= f) := step 1 . (>>= f)@.+--+{-@ reflect >/= @-}+{-@ (>/=) :: t1:Tick a -> f:(a -> Tick b)+    -> { t:Tick b | (tval (f (tval t1))      == tval  t) &&+         (1 + tcost t1 + tcost (f (tval t1))) == tcost t }+@-}+infixl 4 >/=+(>/=) :: Tick a -> (a -> Tick b) -> Tick b+Tick m x >/= f = let Tick n y = f x in Tick (1 + m + n) y++--+-- \"wbind\": @(f =/<) := step 1 . (f =<<)@.+--+{-@ reflect =/< @-}+{-@ (=/<) :: f:(a -> Tick b) -> t1:Tick a+    -> { t:Tick b | tval (f (tval t1))      == tval  t &&+         1 + tcost t1 + tcost (f (tval t1)) == tcost t }+@-}+infixl 4 =/<+(=/<) :: (a -> Tick b) -> Tick a -> Tick b+f =/< Tick m x = let Tick n y = f x in Tick (1 + m + n) y++--+-- \"wwbind\": @(>//= f) := step 2 . (>>= f)@.+--+{-@ reflect >//= @-}+{-@ (>//=) :: t1:Tick a -> f:(a -> Tick b)+    -> { t:Tick b | tval (f (tval t1))      == tval  t &&+         2 + tcost t1 + tcost (f (tval t1)) == tcost t }+@-}+infixl 4 >//=+(>//=) :: Tick a -> (a -> Tick b) -> Tick b+Tick m x >//= f = let Tick n y = f x in Tick (2 + m + n) y++--+-- \"wwbind\": @(f =//<) := step 2 . (f =<<)@.+--+{-@ reflect =//< @-}+{-@ (=//<) :: f:(a -> Tick b) -> t1:Tick a+    -> { t:Tick b | tval (f (tval t1))      == tval  t &&+         2 + tcost t1 + tcost (f (tval t1)) == tcost t }+@-}+infixl 4 =//<+(=//<) :: (a -> Tick b) -> Tick a -> Tick b+f =//< Tick m x = let Tick n y = f x in Tick (2 + m + n) y++--+-- \"gbind\": @(>\= f) := step (-1) . (>>= f)@.+--+{-@ reflect >\= @-}+{-@ (>\=) :: t1:Tick a -> f:(a -> Tick b)+    -> { t:Tick b | tval (f (tval t1))      == tval  t &&+         tcost t1 + tcost (f (tval t1)) - 1 == tcost t }+@-}+infixl 4 >\=+(>\=) :: Tick a -> (a -> Tick b) -> Tick b+Tick m x >\= f = let Tick n y = f x in Tick (m + n - 1) y++--+-- \"gbind\": @(f =\<) := step (-1) . (f =<<)@.+--+{-@ reflect =\< @-}+{-@ (=\<) :: f:(a -> Tick b) -> t1:Tick a+    -> { t:Tick b | tval (f (tval t1))      == tval  t &&+         tcost t1 + tcost (f (tval t1)) - 1 == tcost t }+@-}+infixl 4 =\<+(=\<) :: (a -> Tick b) -> Tick a -> Tick b+f =\< Tick m x = let Tick n y = f x in Tick (m + n - 1) y++--+-- \"ggbind\": @(>\= f) := step (-2) . (>>= f)@.+--+{-@ reflect >\\= @-}+{-@ (>\\=) :: t1:Tick a -> f:(a -> Tick b)+    -> { t:Tick b | tval (f (tval t1))      == tval  t &&+         tcost t1 + tcost (f (tval t1)) - 2 == tcost t }+@-}+infixl 4 >\\=+(>\\=) :: Tick a -> (a -> Tick b) -> Tick b+Tick m x >\\= f = let Tick n y = f x in Tick (m + n - 2) y++--+-- \"ggbind\": @(f =\\<) := step (-2) . (f =<<)@.+--+{-@ reflect =\\< @-}+{-@ (=\\<) :: f:(a -> Tick b) -> t1:Tick a+    -> { t:Tick b | tval (f (tval t1))      == tval  t &&+         tcost t1 + tcost (f (tval t1)) - 2 == tcost t }+@-}+infixl 4 =\\<+(=\\<) :: (a -> Tick b) -> Tick a -> Tick b+f =\\< Tick m x = let Tick n y = f x in Tick (m + n - 2) y++-------------------------------------------------------------------------------+-- | Memoisation:+-------------------------------------------------------------------------------++{-@ reflect pay @-}+{-@ pay :: m:Int+    -> { t1:Tick a | m <= tcost t1 }+    -> { t:Tick ({ t2 : Tick a | tcost t1 - m == tcost t2 }) | m == tcost t }+@-}+pay :: Int -> Tick a -> Tick (Tick a)+pay m (Tick n x) = Tick m (Tick (n - m) x)+++{-@ reflect zipWithM @-}+{-@ zipWithM :: f:(a -> b -> Tick c) -> x:Tick a -> y:Tick b+-> {t:Tick c | tcost t == tcost x + tcost y + tcost (f (tval x) (tval y))} @-}+zipWithM :: (a -> b -> Tick c) -> Tick a -> Tick b -> Tick c+zipWithM f (Tick c1 x1) (Tick c2 x2) = let Tick c x = f x1 x2 in Tick (c + c1 + c2) x
+ include/Language/Haskell/Liquid/RTick/Combinators.hs view
@@ -0,0 +1,366 @@++--+-- Liquidate your assets: reasoning about resource usage in Liquid Haskell.+--++{-@ LIQUID "--reflection" @-}++module Language.Haskell.Liquid.RTick.Combinators where +  (++  -- Basic:+    Proof         -- Simply the unit type.+  , QED(..)       -- 'ASS': Signify the end of an /unfinished/ proof.+                  -- 'QED': Signify the end of a /complete/ proof.+  , (&&&)         -- Combine proofs.+  , (***)         -- Discard final result at the end of a proof.+  , (?)           -- Appeal to an external theorem.+  , isAss         -- Check whether a proof is complete.+  , toProof       -- Cast to proof.+  , trivial       -- Trivial proof.+  , withTheorem   -- Appeal to an external theorem.+  -- Equational:+  , (==.)         -- Equality.+  , (==?)         -- Equality (assumption).+  , eq            -- Equality. Note: 'eq' is inlined in the logic.+  -- Inequational:+  , (<.)          -- Less than.+  , (<?)          -- Less than (assumption).+  , (<=.)         -- Less than or equal.+  , (<=?)         -- Less than or equal (assumption).+  , (>.)          -- Greater than.+  , (>?)          -- Greater than (assumption).+  , (>=.)         -- Greater than or equal.+  , (>=?)         -- Greater than or equal (assumption).+  , (<=>.)        -- Cost equivalence.+  , (<=>?)        -- Cost equivalence (assumption)+  , (>~>.)        -- Improvement.+  , (>~>?)        -- Improvement (assumption).+  , (.>==)        -- Quantified improvement.+  , (?>==)        -- Quantified improvement (assumption).+  , (<~<.)        -- Diminishment.+  , (<~<?)        -- Diminishment (assumption).+  , (.<==)        -- Quantified diminishment.+  , (?<==)        -- Quantified diminishment (assumption).+  -- Cost separators:+  , (==>.)        -- Quantified improvement.+  , (==>?)        -- Quantified improvement (assumption).+  , (==<.)        -- Quantified diminishment.+  , (==<?)        -- Quantified diminishment (assumption).+  , (==!)+  , assert+  ) where++import RTick ( Tick(..) )++--+-- Proof combinators for extrinsic cost analysis.+--++-------------------------------------------------------------------------------+-- | Basic:+-------------------------------------------------------------------------------++{-@ assert :: b:{Bool | b} -> {b} @-}+assert :: Bool -> Proof+assert _ = ()++-- unchecked+(==!) :: a -> a -> a+_ ==! x = x+++type Proof = ()+data QED   = QED | ASS++{-@ toProof :: a -> Proof @-}+toProof :: a -> Proof+toProof _ = ()+{-# INLINE toProof #-}++{-@ trivial :: Proof @-}+trivial :: Proof+trivial = ()+{-# INLINE trivial #-}++{-@ measure isAss @-}+isAss :: QED -> Bool+isAss ASS = True+isAss QED = False++{-@ assume (***) :: a -> qed:QED -> { if (isAss qed) then false else true } @-}+infixl 1 ***+(***) :: a -> QED -> Proof+_ *** _ = ()+{-# INLINE (***) #-}++{-@ (?) :: x:a -> Proof -> { v:a | x == v } @-}+infixl 3 ?+(?) :: a -> Proof -> a+x ? _ = x+{-# INLINE (?) #-}++{-@ (&&&) :: Proof -> Proof -> Proof @-}+infixl 3 &&&+(&&&) :: Proof -> Proof -> Proof+x &&& _ = x+{-# INLINE (&&&) #-}++{-@ withTheorem :: x:a -> Proof -> { v:a | x == v } @-}+withTheorem :: a -> Proof -> a+withTheorem x _ = x+{-# INLINE withTheorem #-}++-------------------------------------------------------------------------------+-- | Equational:+-------------------------------------------------------------------------------++--+-- Equality.+--+{-@ (==.) :: x:a -> { y:a | x == y } -> { v:a | x == v && y == v } @-}+infixl 3 ==.+(==.) :: a -> a -> a+_ ==. x = x+{-# INLINE (==.) #-}++{-@ assume (==?) :: x:a -> y:a -> { v:a | x == v && y == v } @-}+infixl 3 ==?+(==?) :: a -> a -> a+_ ==? x = x+{-# INLINE (==?) #-}++--+-- Equality. Note: 'eq' is inlined in the logic, so can be used in+-- reflected functions.+--+{-@ eq :: x:a -> { y:a | x == y } -> { v:a | x == v && y == v } @-}+eq :: a -> a -> a+_ `eq` x = x+{-# INLINE eq #-}++-------------------------------------------------------------------------------+-- | Inequational:+-------------------------------------------------------------------------------++--+-- Less than.+--+{-@ (<.) :: m:a -> { n:a | m < n } -> { o:a | o == n } @-}+infixl 3 <.+(<.) :: a -> a -> a+_ <. n = n+{-# INLINE (<.) #-}++{-@ assume (<?) :: m:a -> n:a -> { o:a | o == n && m < n } @-}+infixl 3 <?+(<?) :: a -> a -> a+_ <? n = n+{-# INLINE (<?) #-}++--+-- Less than or equal.+--+{-@ (<=.) :: m:a -> { n:a | m <= n } -> { o:a | o == n } @-}+infixl 3 <=.+(<=.) :: a -> a -> a+_ <=. n = n+{-# INLINE (<=.) #-}++{-@ assume (<=?) :: m:a -> n:a -> { o:a | o == n && m <= n } @-}+infixl 3 <=?+(<=?) :: a -> a -> a+_ <=? n = n+{-# INLINE (<=?) #-}++--+-- Greater than.+--+{-@ (>.) :: m:a -> { n:a | m > n } -> { o:a | o == n } @-}+infixl 3 >.+(>.) :: a -> a -> a+_ >. y = y+{-# INLINE (>.) #-}++{-@ assume (>?) :: m:a -> n:a -> { o:a | o == n && m > n } @-}+infixl 3 >?+(>?) :: a -> a -> a+_ >? y = y+{-# INLINE (>?) #-}++--+-- Greater than or equal.+--+{-@ (>=.) :: m:a -> { n:a | m >= n } -> { o:a | o == n } @-}+infixl 3 >=.+(>=.) :: a -> a -> a+_ >=. n = n+{-# INLINE (>=.) #-}++{-@ assume (>=?) :: m:a -> n:a -> { o:a | o == n && m >= n } @-}+infixl 3 >=?+(>=?) :: a -> a -> a+_ >=? n = n+{-# INLINE (>=?) #-}++--+-- Cost equivalence.+--+{-@ predicate COSTEQ T1 T2 = tval T1 == tval T2 && tcost T1 == tcost T2 @-}++{-@ (<=>.)+  :: t1:Tick a+  -> { t2:Tick a | COSTEQ t1 t2 }+  -> { t3:Tick a | COSTEQ t1 t2 && COSTEQ t1 t3 && COSTEQ t2 t3 }+@-}+infixl 3 <=>.+(<=>.) :: Tick a -> Tick a -> Tick a+(<=>.) _ t2 = t2+{-# INLINE (<=>.) #-}++{-@ assume (<=>?)+  :: t1:Tick a -> t2:Tick a+  -> { t3:Tick a | COSTEQ t1 t2 && COSTEQ t1 t3 && t2 == t3 }+@-}+infixl 3 <=>?+(<=>?) :: Tick a -> Tick a -> Tick a+(<=>?) _ t2 = t2+{-# INLINE (<=>?) #-}++--+-- Improvement.+--+{-@ predicate IMP T1 T2 = tval T1 == tval T2 && tcost T1 >= tcost T2 @-}++{-@ (>~>.)+  :: t1:Tick a+  -> { t2:Tick a | IMP t1 t2 }+  -> { t3:Tick a | IMP t1 t2 && IMP t1 t3 && t2 == t3 }+@-}+infixl 3 >~>.+(>~>.) :: Tick a -> Tick a -> Tick a+(>~>.) _ t2 = t2+{-# INLINE (>~>.) #-}++{-@ assume (>~>?)+  :: t1:Tick a -> t2:Tick a+  -> { t3:Tick a | IMP t1 t2 && IMP t1 t3 && t2 == t3 }+@-}+infixl 3 >~>?+(>~>?) :: Tick a -> Tick a -> Tick a+(>~>?) _ t2 = t2+{-# INLINE (>~>?) #-}++--+-- Quantified improvement.+--+{-@ predicate QIMP T1 N T2 = tval T1 == tval T2 && tcost T1 == tcost T2 + N @-}++{-@ (.>==)+  :: t1:Tick a+  -> n:Int+  -> { t2:Tick a | QIMP t1 n t2 }+  -> { t3:Tick a | QIMP t1 n t2 && QIMP t1 n t3 && t2 == t3 }+@-}+infixl 3 .>==+(.>==) :: Tick a -> Int -> Tick a -> Tick a+(.>==) _ _ t2 = t2+{-# INLINE (.>==) #-}++{-@ assume (?>==)+  :: t1:Tick a -> n:Nat -> t2:Tick a+  -> { t3:Tick a | QIMP t1 n t2 && QIMP t1 n t3 && t2 == t3 }+@-}+infixl 3 ?>==+(?>==) :: Tick a -> Int -> Tick a -> Tick a+(?>==) _ _ t2 = t2+{-# INLINE (?>==) #-}++--+-- Diminishment.+--+{-@ predicate DIM T1 T2 = tval T1 == tval T2 && tcost T1 <= tcost T2 @-}++{-@ (<~<.)+  :: t1:Tick a+  -> { t2:Tick a | DIM t1 t2 }+  -> { t3:Tick a | DIM t1 t2 && DIM t1 t3 && t2 == t3 }+@-}+infixl 3 <~<.+(<~<.) :: Tick a -> Tick a -> Tick a+(<~<.) _ t2 = t2+{-# INLINE (<~<.) #-}++{-@ assume (<~<?)+  :: t1:Tick a -> t2:Tick a+  -> { t3:Tick a | DIM t1 t2 && DIM t1 t3 && t2 == t3 }+@-}+infixl 3 <~<?+(<~<?) :: Tick a -> Tick a -> Tick a+(<~<?) _ t2 = t2+{-# INLINE (<~<?) #-}++--+-- Quantified diminishment.+--+{-@ predicate QDIM T1 N T2 = tval T1 == tval T2 && tcost T1 + N == tcost T2 @-}++{-@ (.<==)+  :: t1:Tick a+  -> n:Nat+  -> { t2:Tick a | QDIM t1 n t2 }+  -> { t3:Tick a | QDIM t1 n t2 && QDIM t1 n t3 && t2 == t3 }+@-}+infixl 3 .<==+(.<==) :: Tick a -> Int -> Tick a -> Tick a+(.<==) _ _ t2 = t2+{-# INLINE (.<==) #-}++{-@ assume (?<==)+  :: t1:Tick a -> n:Nat -> t2:Tick a+  -> { t3:Tick a | QDIM t1 n t2 && QDIM t1 n t3 && t2 == t3 }+@-}+infixl 3 ?<==+(?<==) :: Tick a -> Int -> Tick a -> Tick a+(?<==) _ _ t2 = t2+{-# INLINE (?<==) #-}++-------------------------------------------------------------------------------+-- | Cost separators:+-------------------------------------------------------------------------------++--+-- Quantified improvement.+--+{-@ (==>.) :: (a -> b) -> a -> b @-}+infixl 3 ==>.+(==>.) :: (a -> b) -> a -> b+f ==>. a = f a+{-# INLINE (==>.) #-}++--+-- Quantified improvement (assumption).+--+{-@ (==>?) :: (a -> b) -> a -> b @-}+infixl 3 ==>?+(==>?) :: (a -> b) -> a -> b+f ==>? a = f a+{-# INLINE (==>?) #-}++--+-- Quantified diminishment.+--+{-@ (==<.) :: (a -> b) -> a -> b @-}+infixl 3 ==<.+(==<.) :: (a -> b) -> a -> b+f ==<. a = f a+{-# INLINE (==<.) #-}++--+-- Quantified diminishment (assumption).+--+{-@ (==<?) :: (a -> b) -> a -> b @-}+infixl 3 ==<?+(==<?) :: (a -> b) -> a -> b+f ==<? a = f a+{-# INLINE (==<?) #-}
include/Prelude.hquals view
@@ -29,7 +29,6 @@ qualif True1(v:GHC.Types.Bool)   : (v) qualif False1(v:GHC.Types.Bool)  : (~ v) - constant papp1 : func(1, [Pred @(0); @(0); bool]) qualif Papp(v:a,p:Pred a) : (papp1(p, v))
include/Prelude.spec view
@@ -9,33 +9,28 @@  import Data.Foldable import Data.Maybe+import Data.Tuple import GHC.Exts- import GHC.Err   -GHC.Types.D# :: x:_ -> {v:_ | v = x}+// GHC.Types.D# :: x:_ -> {v:_ | v = x} -assume error :: {v:_ | false} -> a +GHC.Err.error :: {v:_ | false} -> a   assume GHC.Base.. :: forall <p :: b -> c -> Bool, q :: a -> b -> Bool, r :: a -> c -> Bool>.                       {xcmp::a, wcmp::b<q xcmp> |- c<p wcmp> <: c<r xcmp>}                      (ycmp:b -> c<p ycmp>)                   -> (zcmp:a -> b<q zcmp>)                   ->  xcmp:a -> c<r xcmp>-assume GHC.Integer.smallInteger :: x:GHC.Prim.Int#-                                -> { v:GHC.Integer.Type.Integer |-                                     v = (x :: int) }+assume GHC.Integer.smallInteger :: x:GHC.Prim.Int# -> { v:GHC.Integer.Type | v = (x :: int) }  assume GHC.Num.+ :: (GHC.Num.Num a) => x:a -> y:a -> {v:a | v = x + y } assume GHC.Num.- :: (GHC.Num.Num a) => x:a -> y:a -> {v:a | v = x - y } -----embed GHC.Types.Double          as real-embed GHC.Integer.Type.Integer  as int+embed GHC.Types.Double  as real+embed GHC.Types.Float   as real+embed Integer           as int  type GeInt N = {v: GHC.Types.Int | v >= N } type LeInt N = {v: GHC.Types.Int | v <= N }@@ -43,10 +38,51 @@ type Even    = {v: GHC.Types.Int | (v mod 2) = 0 } type Odd     = {v: GHC.Types.Int | (v mod 2) = 1 } type BNat N  = {v: Nat           | v <= N }    -type TT      = {v: Bool          | v}-type FF      = {v: Bool          | not v}+type TT      = {v: GHC.Types.Bool | v}+type FF      = {v: GHC.Types.Bool | not v}+type String  = [GHC.Types.Char]  predicate Max V X Y = if X > Y then V = X else V = Y predicate Min V X Y = if X < Y then V = X else V = Y -type IncrListD a D = [a]<{\x y -> (x+D) <= y}>+type IncrListD a  = [a]<{\x y -> (x+D) <= y}>++//BOT: Do not delete EVER!++qualif Bot(v:@(0))    : (0 = 1)+qualif Bot(v:obj)     : (0 = 1)+qualif Bot(v:a)       : (0 = 1)+qualif Bot(v:bool)    : (0 = 1)+qualif Bot(v:int)     : (0 = 1)++qualif CmpZ(v:a)      : (v <  0)+qualif CmpZ(v:a)      : (v <= 0)+qualif CmpZ(v:a)      : (v >  0)+qualif CmpZ(v:a)      : (v >= 0)+qualif CmpZ(v:a)      : (v  = 0)+qualif CmpZ(v:a)      : (v != 0)++qualif Cmp(v:a, x:a)  : (v <  x)+qualif Cmp(v:a, x:a)  : (v <= x)+qualif Cmp(v:a, x:a)  : (v >  x)+qualif Cmp(v:a, x:a)  : (v >= x)+qualif Cmp(v:a, x:a)  : (v  = x)+qualif Cmp(v:a, x:a)  : (v != x)++qualif One(v:int)     : v = 1+qualif True1(v:GHC.Types.Bool)   : (v)+qualif False1(v:GHC.Types.Bool)  : (~ v)++// REBARE constant papp1 : func(1, [Pred @(0); @(0); bool])+qualif Papp(v:a, p:Pred a) : (papp1 p v)++// REBARE constant papp2 : func(4, [Pred @(0) @(1); @(2); @(3); bool])+qualif Papp2(v:a, x:b, p:Pred a b) : (papp2 p v x)++// REBARE constant papp3 : func(6, [Pred @(0) @(1) @(2); @(3); @(4); @(5); bool])+qualif Papp3(v:a, x:b, y:c, p:Pred a b c) : (papp3 p v x y)++// qualif Papp4(v:a,x:b, y:c, z:d, p:Pred a b c d) : papp4(p, v, x, y, z)+// REBARE constant papp4 : func(8, [Pred @(0) @(1) @(2) @(6); @(3); @(4); @(5); @(7); bool])++// REBARE constant runFun : func(2, [Arrow @(0) @(1); @(0); @(1)])
liquidhaskell.cabal view
@@ -1,375 +1,271 @@-Name:                liquidhaskell-Version:             0.8.2.4-Copyright:           2010-17 Ranjit Jhala & Niki Vazou & Eric L. Seidel, University of California, San Diego.-Synopsis:            Liquid Types for Haskell-Description:         Liquid Types for Haskell.-Homepage:            https://github.com/ucsd-progsys/liquidhaskell-License:             BSD3-License-file:        LICENSE-Author:              Ranjit Jhala, Niki Vazou, Eric Seidel-Maintainer:          Ranjit Jhala <jhala@cs.ucsd.edu>-Category:            Language-Build-Type:          Simple-Cabal-version:       >=1.22+name:               liquidhaskell+version:            0.8.6.0+synopsis:           Liquid Types for Haskell+description:        Liquid Types for Haskell.+license:            BSD3+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+maintainer:         Ranjit Jhala <jhala@cs.ucsd.edu>+category:           Language+homepage:           https://github.com/ucsd-progsys/liquidhaskell+build-type:         Simple+extra-source-files: CHANGES.md+                    README.md+                    devel/Paths_liquidhaskell.hs+                    tests/pos/*.hs+                    tests/neg/*.hs+                    tests/import/lib/*.hs+                    tests/import/client/*.hs+                    tests/errors/*.hs+                    tests/pos/*.hquals+                    tests/ffi-include/foo.c+                    tests/ffi-include/foo.h+data-files:         include/*.hquals+                    include/*.hs+                    include/*.spec+                    include/CoreToLogic.lg+                    include/Control/*.spec+                    include/Control/Parallel/*.spec+                    include/Data/*.hquals+                    include/Data/*.spec+                    include/Data/Text/*.spec+                    include/Data/Text/Fusion/*.spec+                    include/Data/Text/Lazy/*.spec+                    include/Data/ByteString/*.spec+                    include/Foreign/*.spec+                    include/Foreign/C/*.spec+                    include/Foreign/Marshal/*.spec+                    include/GHC/*.hquals+                    include/GHC/*.spec+                    include/GHC/IO/*.spec+                    include/Language/Haskell/Liquid/*.hs+                    include/Language/Haskell/Liquid/*.pred+                    include/System/*.spec+                    include/710/Data/*.spec+                    syntax/liquid.css+cabal-version:      >= 1.22 +source-repository head+  type:     git+  location: https://github.com/ucsd-progsys/liquidhaskell/ -data-files: include/*.hquals-          , include/*.hs-          , include/*.spec-          , include/CoreToLogic.lg-          , include/Control/*.spec-          , include/Control/Parallel/*.spec-          , include/Data/*.hquals-          , include/Data/*.spec-          , include/Data/Text/*.spec-          , include/Data/Text/Fusion/*.spec-          , include/Data/Text/Lazy/*.spec-          , include/Data/ByteString/*.spec-          , include/Foreign/*.spec-          , include/Foreign/C/*.spec-          , include/Foreign/Marshal/*.spec-          , include/GHC/*.hquals-          , include/GHC/*.spec-          , include/GHC/IO/*.spec-          , include/Language/Haskell/Liquid/*.hs-          , include/Language/Haskell/Liquid/*.pred-          , include/System/*.spec-          , include/710/Data/*.spec-          , syntax/liquid.css+flag devel+  default:     False+  manual:      True+  description: turn on stricter error reporting for development -extra-source-files: CHANGES.md-                  , README.md-                  , devel/Paths_liquidhaskell.hs-                  , tests/pos/*.hs-                  , tests/neg/*.hs-                  , tests/import/lib/*.hs-                  , tests/import/client/*.hs-                  , tests/errors/*.hs-                  , tests/pos/*.hquals-                  , tests/ffi-include/foo.c-                  , tests/ffi-include/foo.h+flag include+  default:     False+  description: use in-tree include directory -Source-Repository head-  Type:        git-  Location:    https://github.com/ucsd-progsys/liquidhaskell/+flag deterministic-profiling+  default:     False+  description: Support building against GHC with <https://phabricator.haskell.org/D4388>+               backported -Flag devel-  Description: turn on stricter error reporting for development-  Default:     False-  Manual:      True+library+  exposed-modules:    Gradual.Concretize+                      Gradual.GUI+                      Gradual.GUI.Annotate+                      Gradual.GUI.Misc+                      Gradual.GUI.Types+                      Gradual.Misc+                      Gradual.PrettyPrinting+                      Gradual.Refinements+                      Gradual.Trivial+                      Gradual.Types+                      Gradual.Uniquify+                      Language.Haskell.Liquid.Bag+                      Language.Haskell.Liquid.Bare+                      Language.Haskell.Liquid.Bare.Axiom+                      Language.Haskell.Liquid.Bare.Check+                      Language.Haskell.Liquid.Bare.Class+                      Language.Haskell.Liquid.Bare.DataType+                      Language.Haskell.Liquid.Bare.Expand+                      Language.Haskell.Liquid.Bare.Laws+                      Language.Haskell.Liquid.Bare.Measure+                      Language.Haskell.Liquid.Bare.Misc+                      Language.Haskell.Liquid.Bare.Plugged+                      Language.Haskell.Liquid.Bare.Resolve+                      Language.Haskell.Liquid.Bare.ToBare+                      Language.Haskell.Liquid.Bare.Types+                      Language.Haskell.Liquid.Constraint.Constraint+                      Language.Haskell.Liquid.Constraint.Env+                      Language.Haskell.Liquid.Constraint.Fresh+                      Language.Haskell.Liquid.Constraint.Generate+                      Language.Haskell.Liquid.Constraint.Init+                      Language.Haskell.Liquid.Constraint.Monad+                      Language.Haskell.Liquid.Constraint.Qualifier+                      Language.Haskell.Liquid.Constraint.Split+                      Language.Haskell.Liquid.Constraint.ToFixpoint+                      Language.Haskell.Liquid.Constraint.Types+                      Language.Haskell.Liquid.Equational+                      Language.Haskell.Liquid.Foreign+                      Language.Haskell.Liquid.GHC.API+                      Language.Haskell.Liquid.GHC.Interface+                      Language.Haskell.Liquid.GHC.Misc+                      Language.Haskell.Liquid.GHC.Play+                      Language.Haskell.Liquid.GHC.Resugar+                      Language.Haskell.Liquid.GHC.SpanStack+                      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.Termination.Structural+                      Language.Haskell.Liquid.Transforms.ANF+                      Language.Haskell.Liquid.Transforms.CoreToLogic+                      Language.Haskell.Liquid.Transforms.Rec+                      Language.Haskell.Liquid.Transforms.RefSplit+                      Language.Haskell.Liquid.Transforms.Rewrite+                      Language.Haskell.Liquid.Transforms.Simplify+                      Language.Haskell.Liquid.Types+                      Language.Haskell.Liquid.Types.Bounds+                      Language.Haskell.Liquid.Types.Dictionaries+                      Language.Haskell.Liquid.Types.Equality+                      Language.Haskell.Liquid.Types.Errors+                      Language.Haskell.Liquid.Types.Fresh+                      Language.Haskell.Liquid.Types.Literals+                      Language.Haskell.Liquid.Types.Meet+                      Language.Haskell.Liquid.Types.Names+                      Language.Haskell.Liquid.Types.PredType+                      Language.Haskell.Liquid.Types.PrettyPrint+                      Language.Haskell.Liquid.Types.RefType+                      Language.Haskell.Liquid.Types.Specs+                      Language.Haskell.Liquid.Types.Strata+                      Language.Haskell.Liquid.Types.Types+                      Language.Haskell.Liquid.Types.Variance+                      Language.Haskell.Liquid.Types.Visitors+                      Language.Haskell.Liquid.UX.ACSS+                      Language.Haskell.Liquid.UX.Annotate+                      Language.Haskell.Liquid.UX.CTags+                      Language.Haskell.Liquid.UX.CmdLine+                      Language.Haskell.Liquid.UX.Config+                      Language.Haskell.Liquid.UX.DiffCheck+                      Language.Haskell.Liquid.UX.Errors+                      Language.Haskell.Liquid.UX.QuasiQuoter+                      Language.Haskell.Liquid.UX.Tidy+                      Language.Haskell.Liquid.WiredIn+                      LiquidHaskell+                      Paths_liquidhaskell+  hs-source-dirs:     src, include+  build-depends:      base                 >= 4.11.1.0 && < 5+                    , Diff                 >= 0.3+                    , aeson+                    , binary+                    , bytestring           >= 0.10+                    , cereal+                    , cmdargs              >= 0.10+                    , containers           >= 0.5+                    , data-default         >= 0.5+                    , deepseq              >= 1.3+                    , directory            >= 1.2+                    , filepath             >= 1.3+                    , fingertree           >= 0.1+                    , ghc+                    , ghc-boot+                    , ghc-paths            >= 0.1+                    , ghc-prim+                    , gitrev+                    , hashable             >= 1.2+                    , hscolour             >= 1.22+                    , liquid-fixpoint      >= 0.8.0.0+                    , mtl                  >= 2.1+                    , optparse-simple+                    , githash+                    , parsec               >= 3.1+                    , pretty               >= 1.1+                    , syb                  >= 0.4.4+                    , template-haskell     >= 2.9+                    , temporary            >= 1.2+                    , text                 >= 1.2+                    , time                 >= 1.4+                    , time+                    , transformers         >= 0.3+                    , unordered-containers >= 0.2+                    , vector               >= 0.10+  default-language:   Haskell98+  default-extensions: PatternGuards+  ghc-options:        -W -fwarn-missing-signatures -Flag include-  Description: use in-tree include directory-  Default:     False+  if flag(include)+    hs-source-dirs: devel -Flag deterministic-profiling-  Description: Support building against GHC with https://phabricator.haskell.org/D4388 backported-  Default:     False+  if flag(deterministic-profiling)+    cpp-options: -DDETERMINISTIC_PROFILING -Executable liquid-  default-language: Haskell98-  Build-Depends: base >=4.8.1.0 && <5-               , ghc-               , ghc-boot-               , cmdargs-               , time-               , deepseq-               , pretty-               , process-               , liquid-fixpoint >= 0.7.0.7-               , located-base-               , liquidhaskell-               , hpc >= 0.6+executable liquid+  main-is:            src/Liquid.hs+  build-depends:      base >= 4.9.1.0 && < 5, liquidhaskell+  default-language:   Haskell98+  default-extensions: PatternGuards+  ghc-options:        -W -threaded -fdefer-typed-holes -  Main-is: src/Liquid.hs-  ghc-options: -W -threaded -fdefer-typed-holes   if flag(devel)     ghc-options: -Werror-  Default-Extensions: PatternGuards --- executable gradual-  -- default-language: Haskell2010-  -- main-is:        src/Gradual.hs-  -- ghc-options: -W -threaded-  -- if flag(devel)-    -- ghc-options: -Werror-  -- build-depends:  base >=4.8.1.0 && <5,-                  -- liquidhaskell,-                  -- liquid-fixpoint >= 0.7.0.5,-                  -- hscolour,-                  -- cmdargs---- executable target-  -- default-language: Haskell2010-  -- main-is:        src/Target.hs-  -- build-depends:  base >=4.8.1.0 && <5,-                  -- hint,-                  -- liquidhaskell--Library-   Default-Language: Haskell98-   Build-Depends: base >=4.8.1.0 && <5-                , ghc == 8.2.2-                , ghc-boot == 8.2.2-                , template-haskell >= 2.9-                , time >= 1.4-                , array >= 0.5-                , hpc >= 0.6-                , cmdargs >= 0.10-                , time-                , containers >= 0.5-                , data-default >= 0.5-                , deepseq >= 1.3-                , directory >= 1.2-                , Diff >= 0.3-                , filepath >= 1.3-                , ghc-paths >= 0.1-                , hscolour >= 1.22-                , mtl >= 2.1-                , parsec >= 3.1-                , pretty >= 1.1-                , process >= 1.2-                , syb >= 0.4.4-                , text >= 1.2-                , vector >= 0.10-                , hashable >= 1.2-                , unordered-containers >= 0.2-                , liquid-fixpoint >= 0.7.0.7-                , located-base-                , aeson >= 1.2 && < 1.3-                , bytestring >= 0.10-                , fingertree >= 0.1-                , Cabal >= 1.18-                , bifunctors >= 5.1-                , cereal-                , binary-                , temporary >= 1.2-                , transformers >= 0.3-                , text-format-                , th-lift-                , exceptions >= 0.6-                , QuickCheck >= 2.7-                , ghc-prim-                , hpc >= 0.6-                , gitrev-                , optparse-simple--   hs-source-dirs:  src, include-   Exposed-Modules: LiquidHaskell,-                    Language.Haskell.Liquid.Prelude,-                    Language.Haskell.Liquid.Bag,-                    Language.Haskell.Liquid.ProofCombinators,-                    Language.Haskell.Liquid.Foreign,-                    Language.Haskell.Liquid.List,-                    Language.Haskell.Liquid.Bare,-                    Language.Haskell.Liquid.Constraint.Constraint,-                    Language.Haskell.Liquid.Constraint.Init,-                    Language.Haskell.Liquid.Constraint.Monad,-                    Language.Haskell.Liquid.Constraint.Env,-                    Language.Haskell.Liquid.Constraint.Types,-                    Language.Haskell.Liquid.Constraint.Split,-                    Language.Haskell.Liquid.Constraint.Generate,-                    Language.Haskell.Liquid.Constraint.ToFixpoint,-                    Language.Haskell.Liquid.Measure,-                    Language.Haskell.Liquid.Parse,-                    Language.Haskell.Liquid.GHC.Interface,-                    Language.Haskell.Liquid.GHC.SpanStack,-                    Language.Haskell.Liquid.Types.RefType,-                    Language.Haskell.Liquid.Types.Errors,-                    Language.Haskell.Liquid.Types.PrettyPrint,-                    Language.Haskell.Liquid.Types.Specifications,-                    Language.Haskell.Liquid.Types.PredType,-                    Language.Haskell.Liquid.Types.Meet,-                    Language.Haskell.Liquid.UX.ACSS,-                    Language.Haskell.Liquid.UX.DiffCheck,-                    Language.Haskell.Liquid.UX.QuasiQuoter,-                    Language.Haskell.Liquid.Transforms.Rewrite,-                    Language.Haskell.Liquid.Transforms.ANF,-                    Language.Haskell.Liquid.Transforms.RefSplit,-                    Language.Haskell.Liquid.Transforms.CoreToLogic,-                    Language.Haskell.Liquid.Transforms.Rec,-                    Language.Haskell.Liquid.Transforms.Simplify,-                    Language.Haskell.Liquid.UX.Errors,-                    Language.Haskell.Liquid.UX.Annotate,-                    Language.Haskell.Liquid.UX.CTags,-                    Language.Haskell.Liquid.UX.Config,-                    Language.Haskell.Liquid.UX.CmdLine,-                    Language.Haskell.Liquid.GHC.Misc,-                    Language.Haskell.Liquid.GHC.Play,-                    Language.Haskell.Liquid.GHC.TypeRep,-                    Language.Haskell.Liquid.GHC.Resugar,-                    Language.Haskell.Liquid.Misc,-                    Language.Haskell.Liquid.Types.Variance,-                    Language.Haskell.Liquid.Types.Bounds,-                    Language.Haskell.Liquid.Types.Dictionaries,-                    Language.Haskell.Liquid.Constraint.Qualifier,-                    Language.Haskell.Liquid.UX.Tidy,-                    Language.Haskell.Liquid.Types,-                    Language.Haskell.Liquid.Types.Literals,-                    Language.Haskell.Liquid.Types.Strata,-                    Language.Haskell.Liquid.Types.Fresh,-                    Language.Haskell.Liquid.Constraint.Fresh,-                    Language.Haskell.Liquid.Types.Visitors,-                    Language.Haskell.Liquid.WiredIn,-                    Language.Haskell.Liquid.Types.Names,-                    Language.Haskell.Liquid.Liquid,--                    Language.Haskell.Liquid.Desugar.HscMain,--                    -- NOTE: these need to be exposed so GHC generates .dyn_o files for them..-                    Language.Haskell.Liquid.Desugar.Check,-                    Language.Haskell.Liquid.Desugar.Coverage,-                    Language.Haskell.Liquid.Desugar.Desugar,-                    Language.Haskell.Liquid.Desugar.DsArrows,-                    Language.Haskell.Liquid.Desugar.DsBinds,-                    Language.Haskell.Liquid.Desugar.DsCCall,-                    Language.Haskell.Liquid.Desugar.DsExpr,-                    Language.Haskell.Liquid.Desugar.DsForeign,-                    Language.Haskell.Liquid.Desugar.DsGRHSs,-                    Language.Haskell.Liquid.Desugar.DsListComp,-                    Language.Haskell.Liquid.Desugar.DsMeta,-                    Language.Haskell.Liquid.Desugar.DsUtils,-                    Language.Haskell.Liquid.Desugar.Match,-                    Language.Haskell.Liquid.Desugar.MatchCon,-                    Language.Haskell.Liquid.Desugar.MatchLit,-                    Language.Haskell.Liquid.Desugar.DsMonad,-                    Language.Haskell.Liquid.Desugar.StaticPtrTable,-                    Language.Haskell.Liquid.Desugar.TmOracle,-                    Paths_liquidhaskell,--                    -- FIXME: These shouldn't really be exposed, but the linker complains otherwise...-                    Language.Haskell.Liquid.Bare.Check,-                    Language.Haskell.Liquid.Bare.DataType,-                    Language.Haskell.Liquid.Bare.Env,-                    Language.Haskell.Liquid.Bare.Expand,-                    Language.Haskell.Liquid.Bare.Existential,-                    Language.Haskell.Liquid.Bare.Lookup,-                    Language.Haskell.Liquid.Bare.Axiom,-                    Language.Haskell.Liquid.Bare.Measure,-                    Language.Haskell.Liquid.Bare.Misc,-                    Language.Haskell.Liquid.Bare.OfType,-                    Language.Haskell.Liquid.Bare.Plugged,-                    Language.Haskell.Liquid.Bare.ToBare,-                    Language.Haskell.Liquid.Bare.Resolve,-                    Language.Haskell.Liquid.Bare.RTEnv,-                    Language.Haskell.Liquid.Bare.SymSort,-                    Language.Haskell.Liquid.Bare.Spec,-                    Language.Haskell.Liquid.Interactive.Types,-                    Language.Haskell.Liquid.Interactive.Handler,-                    Language.Haskell.Liquid.Model,--                    Test.Target,-                    Test.Target.Eval,-                    Test.Target.Expr,-                    Test.Target.Monad,-                    Test.Target.Targetable,-                    Test.Target.Targetable.Function,-                    Test.Target.Testable,-                    Test.Target.Types,-                    Test.Target.Util,+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 -                    Gradual.Concretize,-                    Gradual.Uniquify,-                    Gradual.Types,-                    Gradual.Refinements,-                    Gradual.PrettyPrinting,-                    Gradual.Misc,-                    Gradual.Trivial,-                    Gradual.GUI,-                    Gradual.GUI.Annotate,-                    Gradual.GUI.Types,-                    Gradual.GUI.Misc+  if flag(devel)+    ghc-options: -Werror -   ghc-options: -W -fwarn-missing-signatures-   if flag(include)-     hs-source-dirs: devel-   if flag(devel)-     ghc-options: -Werror-   if flag(deterministic-profiling)-     cpp-options: -DDETERMINISTIC_PROFILING-   Default-Extensions: PatternGuards+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+  other-modules:    Paths_liquidhaskell+  hs-source-dirs:   tests+  build-depends:    base                 >= 4.8.1.0 && < 5+                  , containers           >= 0.5+                  , directory            >= 1.2+                  , filepath             >= 1.3+                  , mtl                  >= 2.1+                  , optparse-applicative >= 0.11+                  , process              >= 1.2+                  , stm                  >= 2.4+                  , tagged               >= 0.7.3+                  , tasty                >= 0.10+                  , tasty-ant-xml+                  , tasty-hunit          >= 0.9+                  , tasty-rerun          >= 1.1+                  , text+                  , transformers         >= 0.3   default-language: Haskell98-  type:              exitcode-stdio-1.0-  hs-source-dirs:    tests-  ghc-options:       -W -threaded---  if flag(devel)---    ghc-options: -Werror-  main-is:           test.hs-  build-depends:     base >=4.8.1.0 && <5-               ,     containers >= 0.5-               ,     directory >= 1.2-               ,     filepath >= 1.3-               ,     mtl >= 2.1-               ,     process >= 1.2-               ,     optparse-applicative >= 0.11-               ,     stm >= 2.4-               ,     tagged >= 0.7.3-               ,     tasty >= 0.10-               ,     tasty-ant-xml-               ,     tasty-hunit >= 0.9-               ,     tasty-rerun >= 1.1-               ,     transformers >= 0.3-               ,     syb-               ,     liquid-fixpoint >= 0.7.0.7-               ,     hpc >= 0.6-               ,     text+  ghc-options:      -W -threaded  test-suite liquidhaskell-parser+  type:             exitcode-stdio-1.0+  main-is:          Parser.hs+  other-modules:    Paths_liquidhaskell+  hs-source-dirs:   tests+  build-depends:    base            >= 4.8.1.0 && < 5+                  , liquid-fixpoint >= 0.8.0.0+                  , liquidhaskell+                  , parsec+                  , syb+                  , tasty           >= 0.10+                  , tasty-ant-xml+                  , tasty-hunit     >= 0.9   default-language: Haskell2010-  type: exitcode-stdio-1.0-  hs-source-dirs: tests-  ghc-options: -W-  main-is: Parser.hs-  build-depends:-                     base >=4.8.1.0 && <5-               ,     ghc-boot-               ,     containers >= 0.5-               ,     parsec-               ,     tasty >= 0.10-               ,     tasty-ant-xml-               ,     tasty-hunit >= 0.9-               ,     tasty-rerun >= 1.1-               ,     text-               ,     transformers >= 0.3-               ,     syb-               ,     liquid-fixpoint >= 0.7.0.7-               ,     hpc >= 0.6--  if flag(devel)-    hs-source-dirs:   tests src-    build-depends:-                  aeson-                , binary-                , bytestring-                , cereal-                , cmdargs >= 0.10-                , data-default >= 0.5-                , deepseq-                , directory >= 1.2-                , filepath >= 1.3-                , mtl >= 2.1-                , ghc-                , ghc-boot-                , hashable >= 1.2-                , liquid-fixpoint >= 0.7.0.7-                , pretty-                , syb >= 0.4.4-                , time-                , unordered-containers >= 0.2-                , template-haskell-                , hpc >= 0.6--  else-    build-depends: liquidhaskell-                 , base >= 4 && < 5-                 , ghc-                 , ghc-boot-                 , array >= 0.5-                 , time >= 1.4-                 , directory >= 1.2-                 , hpc >= 0.6-                 , containers >= 0.5-                 , template-haskell >= 2.9-                 , bytestring+  ghc-options:      -W
+ scripts/CountBinders.hs view
@@ -0,0 +1,93 @@+{-# 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 view
@@ -0,0 +1,122 @@+#!/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 view
@@ -0,0 +1,200 @@+#!/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 view
@@ -0,0 +1,26 @@+#!/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 view
@@ -0,0 +1,248 @@+#!/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 view
@@ -0,0 +1,77 @@+#!/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 view
@@ -0,0 +1,51 @@+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 view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ scripts/plot-benchmarks/plot-benchmarks.cabal view
@@ -0,0 +1,36 @@+-- 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 view
@@ -0,0 +1,56 @@+{-# 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 view
@@ -0,0 +1,50 @@+{-# 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 view
@@ -0,0 +1,30 @@+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 view
@@ -0,0 +1,80 @@+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 view
@@ -0,0 +1,161 @@+{-# 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 view
@@ -0,0 +1,11 @@+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 view
@@ -0,0 +1,162 @@+#!/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 view
@@ -0,0 +1,86 @@+{-# 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/Concretize.hs view
@@ -31,7 +31,7 @@ instance GSubable (SimpC a) where   gsubst (benv,i) c = c {_crhs = substGrad x i (_crhs c)}     where-      x = fst $ lookupBindEnv (_cbind c) benv+      x = fst $ lookupBindEnv (cbind c) benv  instance (GSubable v) => GSubable (M.HashMap SubcId v) where   gsubst i m = M.map (gsubst i) m
+ src/Gradual/GUI/Names.hs view
@@ -0,0 +1,4 @@+module Gradual.GUI.Names where++buttonPrefix :: String +buttonPrefix = "button-"
+ src/Gradual/GUI/Render.hs view
src/Gradual/Refinements.hs view
@@ -20,8 +20,8 @@   where     sI   = solverInfo cfg' sinfo     act  = mapM (concretize gcfg) mes-    cfg' = cfg { srcFile        = srcFile cfg `withExt` Pred -               , extensionality = True -- disable mbqi+    cfg' = cfg { srcFile = srcFile cfg `withExt` Pred +               , gradual = True -- disable mbqi            }  concretize :: GConfig -> (KVar, (GWInfo, [Expr])) -> SolveM (KVar, (GWInfo,[Expr]))
+ src/LHi.hs view
@@ -0,0 +1,35 @@+{-# 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
@@ -3,939 +3,969 @@ {-# LANGUAGE TupleSections             #-} {-# LANGUAGE RecordWildCards           #-} {-# LANGUAGE ViewPatterns              #-}---- | 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.---   The actual /representations/ of bare and real (refinement) types are all---   in `RefType` -- they are different instances of `RType`--module Language.Haskell.Liquid.Bare (-    GhcSpec(..)-  , makeGhcSpec--  -- * Lifted Spec-  , loadLiftedSpec-  , saveLiftedSpec-  ) where---import           Prelude                                    hiding (error)-import           CoreSyn                                    hiding (Expr)-import qualified CoreSyn-import qualified Unique-import           HscTypes-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)--import           Control.Monad.Reader-import           Control.Monad.State--- import           Control.Monad.Except                       (throwError)-import           Data.Bifunctor-import qualified Data.Binary                                as B-import           Data.Maybe--import           Text.PrettyPrint.HughesPJ                  hiding (first) -- (text, (<+>))--import qualified Control.Exception                          as Ex-import qualified Data.List                                  as L-import qualified Data.HashMap.Strict                        as M-import qualified Data.HashSet                               as S-import           System.Directory                           (doesFileExist)--import           Language.Fixpoint.Utils.Files              -- (extFileName)-import           Language.Fixpoint.Misc                     (applyNonNull, ensurePath, thd3, mapFst, mapSnd)-import           Language.Fixpoint.Types                    hiding (DataDecl, Error, panic)-import qualified Language.Fixpoint.Types                    as F-import qualified Language.Fixpoint.Smt.Theories             as Thy--import           Language.Haskell.Liquid.Types.Dictionaries-import qualified Language.Haskell.Liquid.Misc               as Misc -- (nubHashOn)-import qualified Language.Haskell.Liquid.GHC.Misc  as GM-import           Language.Haskell.Liquid.Types.PredType     (makeTyConInfo)-import           Language.Haskell.Liquid.Types.RefType-import           Language.Haskell.Liquid.Types-import           Language.Haskell.Liquid.WiredIn--import qualified Language.Haskell.Liquid.Measure            as Ms--import           Language.Haskell.Liquid.Bare.Check-import           Language.Haskell.Liquid.Bare.DataType-import           Language.Haskell.Liquid.Bare.Env-import           Language.Haskell.Liquid.Bare.Existential-import           Language.Haskell.Liquid.Bare.Measure-import           Language.Haskell.Liquid.Bare.Axiom-import           Language.Haskell.Liquid.Bare.Misc         (freeSymbols, makeSymbols, mkVarExpr, simpleSymbolVar)-import           Language.Haskell.Liquid.Bare.Plugged-import           Language.Haskell.Liquid.Bare.RTEnv-import           Language.Haskell.Liquid.Bare.Spec-import           Language.Haskell.Liquid.Bare.Expand-import           Language.Haskell.Liquid.Bare.SymSort-import           Language.Haskell.Liquid.Bare.Lookup        (lookupGhcTyCon)-import           Language.Haskell.Liquid.Bare.ToBare---- import Debug.Trace (trace)----------------------------------------------------------------------------------makeGhcSpec :: Config-            -> FilePath-            -> ModName-            -> [CoreBind]-            -> [TyCon]-            -> Maybe [ClsInst]-            -> [Var]-            -> [Var]-            -> NameSet-            -> HscEnv-            -> Either Error LogicMap-            -> [(ModName, Ms.BareSpec)]-            -> IO GhcSpec----------------------------------------------------------------------------------makeGhcSpec cfg file name cbs tcs instenv vars defVars exports env lmap specs = do-  (fiTcs, fie) <- makeFamInstEnv env-  let act       = makeGhcSpec' cfg file cbs fiTcs tcs instenv vars defVars exports specs-  sp           <- throwLeft =<< execBare act (initEnv fie)-  let renv      = L.foldl' (\e (x, s) -> insertSEnv x (RR s mempty) e) (ghcSpecEnv sp defVars) wiredSortedSyms-  throwLeft . checkGhcSpec specs renv $ postProcess cbs renv sp-  where-    throwLeft   = either Ex.throw return-    lmap'       = case lmap of { Left e -> Ex.throw e; Right x -> x `mappend` listLMap}-    initEnv fie = BE { modName  = name-                     , tcEnv    = mempty-                     , rtEnv    = mempty-                     , varEnv   = mempty-                     , hscEnv   = env-                     , famEnv   = fie-                     , logicEnv = lmap'-                     , dcEnv    = mempty-                     , bounds   = mempty-                     , embeds   = mempty-                     , axSyms   = initAxSymbols name defVars specs-                     , propSyms = initPropSymbols specs-                     , beConfig = cfg-                     , beIndex  = 0-                     }--makeFamInstEnv :: HscEnv -> IO ([TyCon], M.HashMap Symbol DataCon)-makeFamInstEnv env = do-  famInsts <- getFamInstances env-  let fiTcs = [ tc            | FamInst { fi_flavor = DataFamilyInst tc } <- famInsts ]-  let fiDcs = [ (symbol d, d) | tc <- fiTcs, d <- tyConDataCons tc ]-  return      (fiTcs, F.notracepp "FAM-INST-TCS" $ M.fromList fiDcs)--getFamInstances :: HscEnv -> IO [FamInst]-getFamInstances env = do-  (_, Just (pkg_fie, home_fie)) <- runTcInteractive env tcGetFamInstEnvs-  return $ famInstEnvElts home_fie ++ famInstEnvElts pkg_fie----initAxSymbols :: ModName -> [Var] -> [(ModName, Ms.BareSpec)] -> M.HashMap Symbol LocSymbol-initAxSymbols name vs = locMap .  Ms.reflects . fromMaybe mempty . lookup name-  where-    locMap xs         = M.fromList [ (val x, x) | x <- fmap tx <$> S.toList xs ]-    tx                = qualifySymbol' vs---- | see NOTE:AUTO-INDPRED in Bare/DataType.hs-initPropSymbols :: [(ModName, Ms.BareSpec)] -> M.HashMap Symbol LocSymbol-initPropSymbols _ = M.empty--importedSymbols :: ModName -> [(ModName, Ms.BareSpec)] -> S.HashSet LocSymbol-importedSymbols name specs = S.unions [ exportedSymbols sp |  (m, sp) <- specs, m /= name ]--exportedSymbols :: Ms.BareSpec -> S.HashSet LocSymbol-exportedSymbols spec = S.unions-  [ Ms.reflects spec-  , Ms.hmeas    spec-  , Ms.inlines  spec ]---listLMap :: LogicMap-listLMap  = toLogicMap [ (dummyLoc nilName , []     , hNil)-                       , (dummyLoc consName, [x, xs], hCons (EVar <$> [x, xs])) ]-  where-    x     = symbol "x"-    xs    = symbol "xs"-    hNil  = mkEApp (dcSym nilDataCon ) []-    hCons = mkEApp (dcSym consDataCon)-    dcSym = dummyLoc . GM.dropModuleUnique . symbol--postProcess :: [CoreBind] -> SEnv SortedReft -> GhcSpec -> GhcSpec-postProcess cbs specEnv sp@(SP {..})-  = sp { gsTySigs     = mapSnd addTCI <$> sigs-       , gsInSigs     = mapSnd addTCI <$> insigs-       , gsAsmSigs    = mapSnd addTCI <$> assms-       , gsInvariants = mapSnd addTCI <$> gsInvariants-       , gsLits       = txSort        <$> gsLits-       , gsMeas       = txSort        <$> gsMeas-       , gsDicts      = dmapty addTCI'    gsDicts-       , gsTexprs     = ts-       }-  where-    (sigs,   ts')     = replaceLocBinds gsTySigs  gsTexprs-    (assms,  ts'')    = replaceLocBinds gsAsmSigs ts'-    (insigs, ts)      = replaceLocBinds gsInSigs  ts''-    replaceLocBinds   = replaceLocalBinds allowHO gsTcEmbeds gsTyconEnv specEnv cbs-    txSort            = mapSnd (addTCI . txRefSort gsTyconEnv gsTcEmbeds)-    addTCI            = (addTCI' <$>)-    addTCI'           = addTyConInfo gsTcEmbeds gsTyconEnv-    allowHO           = higherOrderFlag gsConfig--ghcSpecEnv :: GhcSpec -> [Var] -> SEnv SortedReft-ghcSpecEnv sp defs   = res-  where-    res              = fromListSEnv binds-    emb              = gsTcEmbeds sp-    binds            =  ([(x,       rSort t) | (x, Loc _ _ t) <- gsMeas sp])-                     ++ [(symbol v, rSort t) | (v, Loc _ _ t) <- gsCtors sp]-                     ++ [(x,        vSort v) | (x, v)         <- gsFreeSyms sp,-                                                                 isConLikeId v ]-                     ++ [(symbol x, vSort x) |  x  <- defs]-    rSort t          = rTypeSortedReft emb t-    vSort            = rSort . varRSort-    varRSort         :: Var -> RSort-    varRSort         = ofType . varType--    -- TODO:AUTO-INDPRED-    -- res               = unionSEnv' (fromListSEnv binds) env1-    -- env1             = fromListSEnv (tracepp "PROPBINDS" propBinds)-    -- propBinds        = [ propCtor d          | d <- gsADTs sp, isPropDecl d  ]--_adtEnv     :: F.DataDecl -> [(F.Symbol, F.SortedReft)]-_adtEnv     = map (mapSnd thySort) . Thy.dataDeclSymbols-  where-    thySort = F.trueSortedReft . F.tsSort--_propCtor :: F.DataDecl -> (Symbol, SortedReft)-_propCtor (F.DDecl c n [DCtor f ts]) = (F.symbol f, F.trueSortedReft t)-  where-    t                               = F.mkFFunc n (inTs ++ [outT])-    inTs                            = F.dfSort <$> ts-    outT                            = F.fTyconSelfSort c n-_propCtor (F.DDecl c _ _)            = panic (Just (GM.fSrcSpan c)) msg-  where-    msg                             = "Invalid propCtor: " ++ show c------------------------------------------------------------------------------------- | [NOTE]: REFLECT-IMPORTS------ 1. MAKE the full LiftedSpec, which will eventually, contain:---      makeHaskell{Inlines, Measures, Axioms, Bounds}--- 2. SAVE the LiftedSpec, which will be reloaded---- | This step creates the aliases and inlines etc. It must be done BEFORE---   we compute the `SpecType` for (all, including the reflected binders),---   as we need the inlines and aliases to properly `expand` the SpecTypes.-----------------------------------------------------------------------------------makeLiftedSpec0 :: Config -> ModName -> TCEmb TyCon -> [CoreBind] -> [TyCon] -> Ms.BareSpec-                -> BareM Ms.BareSpec-makeLiftedSpec0 cfg name embs cbs defTcs mySpec = do-  xils      <- makeHaskellInlines  embs cbs mySpec-  ms        <- makeHaskellMeasures embs cbs mySpec-  let refTcs = reflectedTyCons cfg embs cbs mySpec-  let tcs    = uniqNub (defTcs ++ refTcs)-  return     $ mempty-                { Ms.ealiases  = lmapEAlias . snd <$> xils-                , Ms.measures  = F.notracepp "MS-MEAS" $ ms-                , Ms.reflects  = F.notracepp "MS-REFLS" $ Ms.reflects mySpec-                , Ms.dataDecls = F.notracepp "MS-DATADECL" $ makeHaskellDataDecls cfg name mySpec tcs-                }---- sortUniquable :: (Uniquable a) => [a] -> [a]--- sortUniquable xs = s--- getUnique getKey :: Unique -> Int--- hashNub :: (Eq k, Hashable k) => [k] -> [k]--- hashNub = M.keys . M.fromList . fmap (, ())---uniqNub :: (Unique.Uniquable a) => [a] -> [a]-uniqNub xs = M.elems $ M.fromList [ (index x, x) | x <- xs ]-  where-    index  = Unique.getKey . Unique.getUnique---- | '_reflectedTyCons' returns the list of `[TyCon]` that must be reflected but---   which are defined *outside* the current module e.g. in Base or somewhere---   that we don't have access to the code.--- // _reflectedTyCons :: Config -> Ms.BareSpec -> BareM [TyCon]--- // _reflectedTyCons cfg spec-  -- // | exactDC cfg = mapM (lookupGhcTyCon "reflectedTyCons") $ tycName <$> Ms.dataDecls spec-  -- // | otherwise   = return []--reflectedTyCons :: Config -> TCEmb TyCon -> [CoreBind] -> Ms.BareSpec -> [TyCon]-reflectedTyCons cfg embs cbs spec-  | exactDC cfg = filter (not . isEmbedded embs)-                $ concatMap varTyCons-                $ reflectedVars spec cbs--  | otherwise   = []---- | We cannot reflect embedded tycons (e.g. Bool) as that gives you a sort---   conflict: e.g. what is the type of is-True? does it take a GHC.Types.Bool---   or its embedding, a bool?-isEmbedded :: TCEmb TyCon -> TyCon -> Bool-isEmbedded embs c = M.member c embs----varTyCons :: Var -> [TyCon]-varTyCons = specTypeCons . ofType . varType--specTypeCons           :: SpecType -> [TyCon]-specTypeCons           = foldRType tc []-  where-    tc acc t@(RApp {}) = (rtc_tc $ rt_tycon t) : acc-    tc acc _           = acc--reflectedVars :: Ms.BareSpec -> [CoreBind] -> [Var]-reflectedVars spec cbs = fst <$> xDefs-  where-    xDefs              = mapMaybe (`GM.findVarDef` cbs) reflSyms-    reflSyms           = fmap val . S.toList . Ms.reflects $ spec--makeLiftedSpec1-  :: FilePath -> ModName -> Ms.BareSpec-  -> [(Var, LocSpecType)]-  -> [AxiomEq]-  -> [(Maybe Var, LocSpecType)]-  -> BareM ()-makeLiftedSpec1 file name lSpec0 xts axs invs-  = liftIO $ saveLiftedSpec file name lSpec1-  where-    xbs    = [ (varLocSym x       , specToBare <$> t) | (x, t) <- xts  ]-    -- xinvs  = [ (Just (varLocSym x), specToBare <$> t) | (Just x, t) <- invs ]-    xinvs  = [ ((varLocSym <$>x), specToBare <$> t) | (x, t) <- invs ]-    lSpec1 = lSpec0 { Ms.asmSigs    = xbs-                    , Ms.reflSigs   = xbs-                    , Ms.axeqs      = axs-                    , Ms.invariants = xinvs-                    }--varLocSym :: Var -> LocSymbol-varLocSym v = symbol <$> GM.locNamedThing v--varLocSimpleSym :: Var -> LocSymbol-varLocSimpleSym v = simpleSymbolVar <$> GM.locNamedThing v--saveLiftedSpec :: FilePath -> ModName -> Ms.BareSpec -> IO ()-saveLiftedSpec srcF _ lspec = do-  ensurePath specF-  B.encodeFile specF lspec-  where-    specF = extFileName BinSpec srcF--loadLiftedSpec :: Config -> FilePath -> IO Ms.BareSpec-loadLiftedSpec cfg srcF-  | noLiftedImport cfg = return mempty-  | otherwise          = do-      let specF = extFileName BinSpec srcF-      ex  <- doesFileExist specF-      -- putStrLn $ "Loading Binary Lifted Spec: " ++ specF ++ " " ++ show ex-      lSp <- if ex then B.decodeFile specF else return mempty-      -- putStrLn $ "Loaded Spec: " ++ showpp (Ms.reflSigs lSp)-      return lSp--insert :: (Eq k) => k -> v -> [(k, v)] -> [(k, v)]-insert k v []              = [(k, v)]-insert k v ((k', v') : kvs)-  | k == k'                = (k, v)   : kvs-  | otherwise              = (k', v') : insert k v kvs--_dumpSigs :: [(ModName, Ms.BareSpec)] -> IO ()-_dumpSigs specs0 = putStrLn $ "DUMPSIGS:" ++  showpp [ (m, dump sp) | (m, sp) <- specs0 ]-  where-    dump sp = Ms.asmSigs sp ++ Ms.sigs sp ++ Ms.localSigs sp------------------------------------------------------------------------------------- | symbolVarMap resolves each Symbol occuring in the spec to its Var -------------------------------------------------------------------------------------------symbolVarMap :: (Id -> Bool) -> [Id] -> [LocSymbol] -> BareM [(Symbol, Var)]-symbolVarMap f vs xs' = do-  let xs    = Misc.nubHashOn val [ x' | x <- xs', not (isWiredIn x), x' <- [x, GM.dropModuleNames <$> x] ]-  syms1    <- M.fromList <$> makeSymbols f vs (val <$> xs)-  syms2    <- lookupIds True [ (lx, ()) | lx@(Loc _ _ x) <- xs-                                        , not (M.member x syms1)-                                        , not (isTestSymbol x)    ]-  return $ (M.toList syms1 ++ [ (val lx, v) | (v, lx, _) <- syms2])---- `liftedVarMap` is a special case of `symbolVarMap` that checks that all--- lifted binders are in fact exported by the given module. We cannot use--- GHC's isExportedId because it marks things exported even when they are not;--- see tests/error_messages/ExportReflects.hs--liftedVarMap :: (Id -> Bool) -> [LocSymbol] -> BareM [(Symbol, Var)]-liftedVarMap f xs = do-  syms    <- symbolVarMap f [] xs-  let symm = M.fromList syms-  let es   = [ x | x <- xs, not (checkLifted symm x) ]-  applyNonNull (return syms) (Ex.throw . fmap mkErr) es-  where-    mkErr :: LocSymbol -> Error-    mkErr x = ErrLiftExp (GM.sourcePosSrcSpan $ loc x) (pprint $ val x)--checkLifted :: M.HashMap Symbol Var -> LocSymbol -> Bool-checkLifted symm x = M.member (val x) symm---- TODO: move into Check.hs-checkShadowedSpecs :: [Measure ta ca] -> [Measure tb cb] -> [LocSymbol] -> [Var] -> BareM ()-checkShadowedSpecs myDcs myMeas myExportSyms defVars = do-  checkDisjoint dcSyms   measSyms-  checkDisjoint dcSyms   myExportSyms-  checkDisjoint measSyms myExportSyms-  checkDisjoint measSyms defSyms-  where-    dcSyms   = name <$> myDcs-    measSyms = name <$> myMeas-    defSyms  = varLocSimpleSym <$> defVars--checkDisjoint :: [LocSymbol] -> [LocSymbol] -> BareM ()-checkDisjoint xs ys-  | (x,y) : _ <- dups = uError $ err x y-  | otherwise         = return ()-  where-    dups              = M.elems $ M.intersectionWith (,) (symMap xs) (symMap ys)-    symMap  zs        = M.fromList [ (val z, z) | z <- zs ]-    err x y           = ErrDupSpecs (GM.fSrcSpan x) (pprint $ val x) [GM.fSrcSpan y]-----------------------------------------------------------------------------------makeGhcSpec'-  :: Config -> FilePath -> [CoreBind] -> [TyCon] -> [TyCon] -> Maybe [ClsInst] -> [Var] -> [Var]-  -> NameSet -> [(ModName, Ms.BareSpec)]-  -> BareM GhcSpec----------------------------------------------------------------------------------makeGhcSpec' cfg file cbs fiTcs tcs instenv vars defVars exports specs0 = do-  -- liftIO $ _dumpSigs specs0-  name           <- modName <$> get-  let mySpec      = fromMaybe mempty (lookup name specs0)-  embs           <- addClassEmbeds instenv fiTcs <$> (mconcat <$> mapM makeTyConEmbeds specs0)-  lSpec0         <- makeLiftedSpec0 cfg name embs cbs tcs mySpec-  let fullSpec    = mySpec `mappend` lSpec0-  lmap           <- lmSymDefs . logicEnv    <$> get-  let specs       = insert name fullSpec specs0-  makeRTEnv name lSpec0 specs lmap-  let expSyms     = S.toList (exportedSymbols mySpec)-  syms0 <- liftedVarMap (varInModule name) expSyms-  syms1 <- symbolVarMap (varInModule name) vars (S.toList $ importedSymbols name   specs)--  (tycons, datacons, dcSs, recSs, tyi, adts) <- makeGhcSpecCHOP1 cfg specs embs (syms0 ++ syms1)-  checkShadowedSpecs dcSs (Ms.measures mySpec) expSyms defVars-  makeBounds embs name defVars cbs specs-  modify                                   $ \be -> be { tcEnv = tyi }-  (cls, mts)                              <- second mconcat . unzip . mconcat <$> mapM (makeClasses name cfg vars) specs-  (measures, cms', ms', cs', xs')         <- makeGhcSpecCHOP2 specs dcSs datacons cls embs-  (invs, ntys, ialias, sigs, asms)        <- makeGhcSpecCHOP3 cfg vars defVars specs name mts embs-  quals    <- mconcat <$> mapM makeQualifiers specs-  let fSyms =  freeSymbols xs' (sigs ++ asms ++ cs') ms' ((snd <$> invs) ++ (snd <$> ialias))-            ++ measureSymbols measures-  syms2    <- symbolVarMap (varInModule name) (vars ++ map fst cs') fSyms-  let syms  = syms0 ++ syms1 ++ syms2-  let su    = mkSubst [ (x, mkVarExpr v) | (x, v) <- syms ]-  makeGhcSpec0 cfg defVars exports name adts (emptySpec cfg)-    >>= makeGhcSpec1 syms vars defVars embs tyi exports name sigs (recSs ++ asms) cs'  ms' cms' su-    >>= makeGhcSpec2 invs ntys ialias measures su syms-    >>= makeGhcSpec3 (datacons ++ cls) tycons embs syms-    >>= makeSpecDictionaries embs vars specs-    -- The lifted-spec is saved in the next step-    >>= makeGhcAxioms file name embs cbs su specs lSpec0 invs adts-    >>= makeLogicMap-    -- RJ: AAAAAAARGHHH: this is duplicate of RT.strengthenDataConType-    -- >>= makeExactDataCons name cfg (snd <$> syms)-    -- This step needs the UPDATED logic map, ie should happen AFTER makeLogicMap-    >>= makeGhcSpec4 quals defVars specs name su syms-    >>= addRTEnv--measureSymbols :: MSpec SpecType DataCon -> [LocSymbol]-measureSymbols measures = zs-  where-    -- msg = "MEASURE-SYMBOLS" ++ showpp [(loc v, val v) | v <- zs]-    zs = [ name m | m <- M.elems (Ms.measMap measures) ++ Ms.imeas measures ]--addRTEnv :: GhcSpec -> BareM GhcSpec-addRTEnv spec = do-  rt <- rtEnv <$> get-  return $ spec { gsRTAliases = rt }---- RJ: AAAAAAARGHHH: this is duplicate of RT.strengthenDataConType--- // _makeExactDataCons :: ModName -> Config -> [Var] -> GhcSpec -> BareM GhcSpec--- // _makeExactDataCons _n cfg vs spec-  -- // | exactDC cfg = return $ spec { gsTySigs = gsTySigs spec ++ xts}-  -- // | otherwise   = return   spec-  -- // where-    -- // xts         = makeDataConCtor <$> filter f vs-    -- // f v         = GM.isDataConId v--varInModule :: (Show a, Show a1) => a -> a1 -> Bool-varInModule n v = L.isPrefixOf (show n) $ show v---getReflects :: [(ModName, Ms.BareSpec)] -> [Symbol]-getReflects  = fmap val . S.toList . S.unions . fmap (names . snd)-  where-    names  z = S.unions [ Ms.reflects z, Ms.inlines z, Ms.hmeas z ]--getAxiomEqs :: [(ModName, Ms.BareSpec)] -> [AxiomEq]-getAxiomEqs = concatMap (Ms.axeqs . snd)---- TODO: pull the `makeLiftedSpec1` out; a function should do ONE thing.-makeGhcAxioms-  :: FilePath -> ModName -> TCEmb TyCon -> [CoreBind] -> Subst-  -> [(ModName, Ms.BareSpec)] -> Ms.BareSpec-  -> [(Maybe Var, LocSpecType)] -> [F.DataDecl]-  -> GhcSpec-  -> BareM GhcSpec-makeGhcAxioms file name embs cbs su specs lSpec0 invs adts sp = do-  let mSpc = fromMaybe mempty (lookup name specs)-  let rfls = S.fromList (getReflects specs)-  xtes    <- makeHaskellAxioms embs cbs sp mSpc adts-  let xts  = [ (x, subst su t)       | (x, t, _) <- xtes ]-  let mAxs = [ qualifyAxiomEq x su e | (x, _, e) <- xtes ]  -- axiom-eqs in THIS module-  let iAxs = getAxiomEqs specs                              -- axiom-eqs from IMPORTED modules-  let axs  = mAxs ++ iAxs-  _       <- makeLiftedSpec1 file name lSpec0 xts mAxs invs-  let xts' = xts ++ F.notracepp "GS-ASMSIGS" (gsAsmSigs sp)-  let vts  = [ (v, t)        | (v, t) <- xts', let vx = GM.dropModuleNames $ symbol v, S.member vx rfls ]-  let msR  = [ (symbol v, t) | (v, t) <- vts ]-  let vs   = [ v             | (v, _) <- vts ]-  return   $ sp { gsAsmSigs  = xts'                   -- the IMPORTED refl-sigs are in gsAsmSigs sp-                , gsMeas     = msR ++ gsMeas     sp   -- we must add them to gsMeas to allow the names in specifications-                , gsReflects = vs  ++ gsReflects sp-                , gsAxioms   = axs ++ gsAxioms   sp-                }--qualifyAxiomEq :: Var -> Subst -> AxiomEq -> AxiomEq-qualifyAxiomEq v su eq = subst su eq { eqName = symbol v}--makeLogicMap :: GhcSpec -> BareM GhcSpec-makeLogicMap sp = do-  lmap  <- logicEnv <$> get-  return $ sp { gsLogicMap = lmap }--emptySpec     :: Config -> GhcSpec-emptySpec cfg = SP-  { gsTySigs     = mempty-  , gsAsmSigs    = mempty-  , gsInSigs     = mempty-  , gsCtors      = mempty-  , gsLits       = mempty-  , gsMeas       = mempty-  , gsInvariants = mempty-  , gsIaliases   = mempty-  , gsDconsP     = mempty-  , gsTconsP     = mempty-  , gsFreeSyms   = mempty-  , gsTcEmbeds   = mempty-  , gsQualifiers = mempty-  , gsADTs       = mempty-  , gsTgtVars    = mempty-  , gsDecr       = mempty-  , gsTexprs     = mempty-  , gsNewTypes   = mempty-  , gsLvars      = mempty-  , gsLazy       = mempty-  , gsAutoInst   = mempty-  , gsAutosize   = mempty-  , gsConfig     = cfg-  , gsExports    = mempty-  , gsMeasures   = mempty-  , gsTyconEnv   = mempty-  , gsDicts      = mempty-  , gsAxioms     = mempty-  , gsReflects   = mempty-  , gsLogicMap   = mempty-  , gsProofType  = Nothing-  , gsRTAliases  = mempty-  }---makeGhcSpec0 :: Config-             -> [Var]-             -> NameSet-             -> ModName-             -> [F.DataDecl]-             -> GhcSpec-             -> BareM GhcSpec-makeGhcSpec0 cfg defVars exports name adts sp-  = do targetVars <- makeTargetVars name defVars $ checks cfg-       return      $ sp { gsConfig  = cfg-                        , gsExports = exports-                        , gsTgtVars = targetVars-                        , gsADTs    = adts-                        }--makeGhcSpec1 :: [(Symbol, Var)]-             -> [Var]-             -> [Var]-             -> TCEmb TyCon-             -> M.HashMap TyCon RTyCon-             -> NameSet-             -> ModName-             -> [(Var,    LocSpecType)]-             -> [(Var,    LocSpecType)]-             -> [(Var,    LocSpecType)]-             -> [(Symbol, Located (RRType Reft))]-             -> [(Symbol, Located (RRType Reft))]-             -> Subst-             -> GhcSpec-             -> BareM GhcSpec-makeGhcSpec1 syms vars defVars embs tyi exports name sigs asms cs' ms' cms' su sp-  = do tySigs      <- makePluggedSigs name embs tyi exports $ tx sigs-       asmSigs     <- F.notracepp "MAKE-ASSUME-SPEC-3" <$> (makePluggedAsmSigs embs tyi           $ tx asms)-       ctors       <- F.notracepp "MAKE-CTORS-SPEC"    <$> (makePluggedAsmSigs embs tyi           $ tx cs' )-       return $ sp { gsTySigs   = filter (\(v,_) -> v `elem` vs) tySigs-                   , gsAsmSigs  = filter (\(v,_) -> v `elem` vs) asmSigs-                   , gsCtors    = filter (\(v,_) -> v `elem` vs) ctors-                   , gsMeas     = measSyms-                   , gsLits     = measSyms -- RJ: we will be adding *more* things to `meas` but not `lits`-                   }-    where-      tx       = fmap . mapSnd . subst $ su-      tx'      = fmap (mapSnd $ fmap uRType)-      tx''     = fmap . mapFst . qualifySymbol $ syms-      vs       = S.fromList $ vars ++ defVars ++ (snd <$> syms)-      measSyms = tx'' . tx' . tx $ ms'-                                ++ (varMeasures vars)-                                ++ cms'--qualifyDefs :: [(Symbol, Var)] -> S.HashSet (Var, Symbol) -> S.HashSet (Var, Symbol)-qualifyDefs syms = S.fromList . fmap (mapSnd (qualifySymbol syms)) . S.toList--qualifyMeasure :: [(Symbol, Var)] -> Measure a b -> Measure a b-qualifyMeasure syms m = m { name = qualifyLocSymbol (qualifySymbol syms) (name m) }--qualifyRTyCon :: (Symbol -> Symbol) -> RTyCon -> RTyCon-qualifyRTyCon f rtc = rtc { rtc_info = qualifyTyConInfo f (rtc_info rtc) }--qualifyTyConInfo :: (Symbol -> Symbol) -> TyConInfo -> TyConInfo-qualifyTyConInfo f tci = tci { sizeFunction = qualifySizeFun f <$> sizeFunction tci }--qualifyLocSymbol :: (Symbol -> Symbol) -> LocSymbol -> LocSymbol-qualifyLocSymbol f lx = atLoc lx (f (val lx))--qualifyTyConP :: (Symbol -> Symbol) -> TyConP -> TyConP-qualifyTyConP f tcp = tcp { sizeFun = qualifySizeFun f <$> sizeFun tcp }--qualifySizeFun :: (Symbol -> Symbol) -> SizeFun -> SizeFun-qualifySizeFun f (SymSizeFun lx) = SymSizeFun (qualifyLocSymbol f lx)-qualifySizeFun _  sf              = sf--qualifySymbol :: [(Symbol, Var)] -> Symbol -> Symbol-qualifySymbol syms x = maybe x symbol (lookup x syms)--qualifySymbol' :: [Var] -> Symbol -> Symbol-qualifySymbol' vs x = maybe x symbol (L.find (isSymbolOfVar x) vs)--makeGhcSpec2 :: [(Maybe Var  , LocSpecType)]-             -> [(TyCon      , LocSpecType)]-             -> [(LocSpecType, LocSpecType)]-             -> MSpec SpecType DataCon-             -> Subst-             -> [(Symbol, Var)]-             -> GhcSpec-             -> BareM GhcSpec-makeGhcSpec2 invs ntys ialias measures su syms sp-  = return $ sp { gsInvariants = mapSnd (subst su) <$> invs-                , gsNewTypes   = mapSnd (subst su) <$> ntys-                , gsIaliases   = subst su ialias-                , gsMeasures   = ((qualifyMeasure syms . subst su) <$> (ms1 ++ ms2))-                }-    where-      ms1 = M.elems (Ms.measMap measures)-      ms2 =          Ms.imeas   measures--makeGhcSpec3 :: [(DataCon, DataConP)] -> [(TyCon, TyConP)] -> TCEmb TyCon -> [(Symbol, Var)]-             -> GhcSpec -> BareM GhcSpec-makeGhcSpec3 datacons tycons embs syms sp = do-  tce    <- tcEnv    <$> get-  return  $ sp { gsTyconEnv = tce-               , gsDconsP   = [ Loc (dc_loc z) (dc_locE z) dc | (dc, z) <- datacons]-               , gsTcEmbeds = embs-               , gsTconsP   = [(tc, qualifyTyConP (qualifySymbol syms) tcp) | (tc, tcp) <- tycons]-               , gsFreeSyms = [(symbol v, v) | (_, v) <- syms]-               }--makeGhcSpec4 :: [Qualifier]-             -> [Var]-             -> [(ModName, Ms.Spec ty bndr)]-             -> ModName-             -> Subst-             -> [(Symbol, Var)]-             -> GhcSpec-             -> BareM GhcSpec-makeGhcSpec4 quals defVars specs name su syms sp = do-  decr'     <- mconcat <$> mapM (makeHints defVars . snd) specs-  gsTexprs' <- mconcat <$> mapM (makeTExpr defVars . snd) specs-  lazies    <- mkThing makeLazy-  lvars'    <- mkThing makeLVar-  autois    <- mkThing makeAutoInsts-  addDefs  =<< (qualifyDefs syms <$> mkThing makeDefs)-  asize'    <- S.fromList <$> makeASize-  hmeas     <- mkThing' True makeHMeas-  hinls     <- mkThing makeHInlines-  mapM_ (\(v, _) -> insertAxiom (val v) Nothing) $ S.toList hmeas-  mapM_ (\(v, _) -> insertAxiom (val v) Nothing) $ S.toList hinls-  mapM_ insertHMeasLogicEnv $ S.toList hmeas-  mapM_ insertHMeasLogicEnv $ S.toList hinls-  lmap'       <- logicEnv <$> get-  isgs        <- expand' $ strengthenHaskellInlines  (S.map fst hinls) (gsTySigs sp)-  gsTySigs'   <- expand' $ strengthenHaskellMeasures (S.map fst hmeas) isgs-  gsMeasures' <- expand' $ gsMeasures   sp-  gsAsmSigs'  <- expand' $ gsAsmSigs    sp-  gsInSigs'   <- expand' $ gsInSigs     sp-  gsInvarnts' <- expand' $ gsInvariants sp-  gsCtors'    <- expand' $ gsCtors      sp-  gsIaliases' <- expand' $ gsIaliases   sp-  return   $ sp { gsQualifiers = subst su quals-                , gsDecr       = decr'-                , gsLvars      = lvars'-                , gsAutoInst   = M.fromList $ S.toList autois-                , gsAutosize   = asize'-                , gsLazy       = S.insert dictionaryVar lazies-                , gsLogicMap   = lmap'-                , gsTySigs     = gsTySigs'-                , gsTexprs     = [ (v, subst su es) | (v, es) <- gsTexprs' ]-                , gsMeasures   = gsMeasures'-                , gsAsmSigs    = gsAsmSigs'-                , gsInSigs     = gsInSigs'-                , gsInvariants = gsInvarnts'-                , gsCtors      = gsCtors'-                , gsIaliases   = gsIaliases'-                }-  where-    mkThing         = mkThing' False-    mkThing' b mk   = S.fromList . mconcat <$> sequence [ mk defVars s | (m, s) <- specs , b || m == name ]-    makeASize       = mapM (lookupGhcTyCon "makeASize") [v | (m, s) <- specs, m == name, v <- S.toList (Ms.autosize s)]----insertHMeasLogicEnv :: (Located Var, LocSymbol) -> BareM ()-insertHMeasLogicEnv (x, s)-  = insertLogicEnv "insertHMeasLogicENV" s (fst <$> vxs) $ mkEApp s ((EVar . fst) <$> vxs)-  where-    -- res = ty_res rep-    rep = toRTypeRep  t-    t   = (ofType $ varType $ val x) :: SpecType-    xs  = intSymbol (symbol ("x" :: String)) <$> [1..length $ ty_binds rep]-    vxs = dropWhile (isClassType.snd) $ zip xs (ty_args rep)--makeGhcSpecCHOP1-  :: Config -> [(ModName,Ms.Spec ty bndr)] -> TCEmb TyCon -> [(Symbol, Var)]-  -> BareM ( [(TyCon,TyConP)]-           , [(DataCon, DataConP)]-           , [Measure SpecType DataCon]-           , [(Var, Located SpecType)]-           , M.HashMap TyCon RTyCon-           , [F.DataDecl]-           )-makeGhcSpecCHOP1 cfg specs embs syms = do-  (tcDds, dcs)    <- mconcat <$> mapM makeConTypes specs-  let tcs          = [(x, y) | (_, x, y, _)       <- tcDds]-  let tycons       = tcs ++ wiredTyCons-  let tyi          = qualifyRTyCon (qualifySymbol syms) <$> makeTyConInfo tycons-  datacons        <- makePluggedDataCons embs tyi (concat dcs ++ wiredDataCons)-  let tds          = [(name, tc, dd) | (name, tc, _, Just dd) <- tcDds]-  myName          <- modName <$> get-  let adts         = makeDataDecls cfg embs myName tds datacons-  dm              <- gets dcEnv-  _               <- setDataDecls adts-  let dcSelectors  = concatMap (makeMeasureSelectors cfg dm) datacons-  recSels         <- makeRecordSelectorSigs datacons-  return             (tycons, second val <$> datacons, dcSelectors, recSels, tyi, adts)----makeGhcSpecCHOP3 :: Config -> [Var] -> [Var] -> [(ModName, Ms.BareSpec)]-                 -> ModName -> [(ModName, Var, LocSpecType)]-                 -> TCEmb TyCon-                 -> BareM ( [(Maybe Var, LocSpecType)]-                          , [(TyCon, LocSpecType)]-                          , [(LocSpecType, LocSpecType)]-                          , [(Var, LocSpecType)]-                          , [(Var, LocSpecType)] )-makeGhcSpecCHOP3 cfg vars defVars specs name mts embs = do-  sigs'    <- F.notracepp "MAKE-ASSERT-SPEC-1" <$> (mconcat <$> mapM (makeAssertSpec name cfg vars defVars) specs)-  asms'    <- F.notracepp "MAKE-ASSUME-SPEC-1" . Misc.fstByRank . mconcat <$> mapM (makeAssumeSpec name cfg vars defVars) specs-  invs     <- mconcat <$> mapM makeInvariants specs-  ialias   <- mconcat <$> mapM makeIAliases   specs-  ntys     <- mconcat <$> mapM makeNewTypes   specs-  let dms   = makeDefaultMethods vars mts-  tyi      <- gets tcEnv-  let sigs  = [ (x, txRefSort tyi embs $ fmap txExpToBind t) | (_, x, t) <- sigs' ++ mts ++ dms ]-  let asms  = F.notracepp "MAKE-ASSUME-SPEC-2" [ (x, txRefSort tyi embs $ fmap txExpToBind t) | (_, x, t) <- asms' ]-  let hms   = concatMap (S.toList . Ms.hmeas . snd) (filter ((== name) . fst) specs)-  let minvs = makeMeasureInvariants sigs hms-  checkDuplicateSigs sigs -- separate checks as assumes are supposed to "override" other sigs.-  -- checkDuplicateSigs asms-  return     (invs ++ minvs, ntys, ialias, sigs, asms)---checkDuplicateSigs :: [(Var, LocSpecType)] -> BareM ()-checkDuplicateSigs xts = case Misc.uniqueByKey symXs  of-  Left (k, ls) -> uError (errDupSpecs (pprint k) (GM.sourcePosSrcSpan <$> ls))-  Right _      -> return ()-  where-    symXs = [ (F.symbol x, F.loc t) | (x, t) <- xts ]--makeMeasureInvariants :: [(Var, LocSpecType)] -> [LocSymbol] -> [(Maybe Var, LocSpecType)]-makeMeasureInvariants sigs xs-  = measureTypeToInv <$> [(x, (y, ty)) | x <- xs, (y, ty) <- sigs-                                       , isSymbolOfVar (val x) y ]--isSymbolOfVar :: Symbol -> Var -> Bool-isSymbolOfVar x v = x == symbol' v-  where-    symbol' :: Var -> Symbol-    symbol' = GM.dropModuleNames . symbol . getName--measureTypeToInv :: (LocSymbol, (Var, LocSpecType)) -> (Maybe Var, LocSpecType)-measureTypeToInv (x, (v, t)) = (Just v, t {val = mtype})-  where-    trep = toRTypeRep $ val t-    ts   = ty_args trep-    mtype-      | isBool $ ty_res trep-      = uError $ ErrHMeas (GM.sourcePosSrcSpan $ loc t) (pprint x)-                          (text "Specification of boolean measures is not allowed")-{--      | [tx] <- ts, not (isTauto tx)-      = uError $ ErrHMeas (sourcePosSrcSpan $ loc t) (pprint x)-                          (text "Measures' types cannot have preconditions")--}-      | [tx] <- ts-      = mkInvariant (head $ ty_binds trep) tx $ ty_res trep-      | otherwise-      = uError $ ErrHMeas (GM.sourcePosSrcSpan $ loc t) (pprint x)-                          (text "Measures has more than one arguments")---    mkInvariant :: Symbol -> SpecType -> SpecType -> SpecType-    mkInvariant z t tr = strengthen (top <$> t) (MkUReft reft mempty mempty)-      where-        Reft (v, p) = toReft $ fromMaybe mempty $ stripRTypeBase tr-        su    = mkSubst [(v, mkEApp x [EVar v])]-        reft  = Reft (v, subst su p')-        p'    = pAnd $ filter (\e -> z `notElem` syms e) $ conjuncts p--makeGhcSpecCHOP2 :: [(ModName, Ms.BareSpec)]-                 -> [Measure SpecType DataCon]-                 -> [(DataCon, DataConP)]-                 -> [(DataCon, DataConP)]-                 -> TCEmb TyCon-                 -> BareM ( MSpec SpecType DataCon-                          , [(Symbol, Located (RRType Reft))]-                          , [(Symbol, Located (RRType Reft))]-                          , [(Var,    LocSpecType)]-                          , [Symbol] )-makeGhcSpecCHOP2 specs dcSelectors datacons cls embs = do-  measures'   <- mconcat <$> mapM makeMeasureSpec specs-  tyi         <- gets tcEnv-  let measures = mconcat [ measures' , Ms.mkMSpec' dcSelectors]-  let (cs, ms) = makeMeasureSpec' measures-  let cms      = makeClassMeasureSpec measures-  let cms'     = [ (x, Loc l l' $ cSort t) | (Loc l l' x, t) <- cms ]-  let ms'      = [ (x, Loc l l' t) | (Loc l l' x, t) <- ms, isNothing $ lookup x cms' ]-  let cs'      = [ (v, txRefSort' v tyi embs t) | (v, t) <- meetDataConSpec cs (datacons ++ cls)]-  let xs'      = fst <$> ms'-  return (measures, cms', ms', cs', xs')--txRefSort' :: NamedThing a => a -> TCEnv -> TCEmb TyCon -> SpecType -> LocSpecType-txRefSort' v tyi embs t = txRefSort tyi embs (const t <$> GM.locNamedThing v) -- (atLoc' v t)---- atLoc' :: NamedThing t => t -> a -> Located a--- atLoc' v t = Loc (getSourcePos v) (getSourcePosE v)--data ReplaceEnv = RE-  { _reEnv  :: M.HashMap Symbol Symbol-  , _reFEnv :: SEnv SortedReft-  , _reEmb  :: TCEmb TyCon-  , _reTyi  :: M.HashMap TyCon RTyCon-  }--type ReplaceState = ( M.HashMap Var LocSpecType-                    , M.HashMap Var [Located Expr]-                    )--type ReplaceM = ReaderT ReplaceEnv (State ReplaceState)---- ASKNIKI: WHAT DOES THIS FUNCTION DO?!!!!-replaceLocalBinds :: Bool-                  -> TCEmb TyCon-                  -> M.HashMap TyCon RTyCon-                  -> SEnv SortedReft-                  -> CoreProgram-                  -> [(Var, LocSpecType)]-                  -> [(Var, [Located Expr])]-                  -> ([(Var, LocSpecType)], [(Var, [Located Expr])])-replaceLocalBinds allowHO emb tyi senv cbs sigs texprs-  = (M.toList s, M.toList t)-  where-    (s, t) = execState (runReaderT (mapM_ (\x -> traverseBinds allowHO x (return ())) cbs)-                                   (RE M.empty senv emb tyi))-                       (M.fromList sigs,  M.fromList texprs)--traverseExprs :: Bool -> CoreSyn.Expr Var -> ReplaceM ()-traverseExprs allowHO (Let b e)-  = traverseBinds allowHO b (traverseExprs allowHO e)-traverseExprs allowHO (Lam b e)-  = withExtendedEnv allowHO [b] (traverseExprs allowHO e)-traverseExprs allowHO (App x y)-  = traverseExprs allowHO x >> traverseExprs allowHO y-traverseExprs allowHO (Case e _ _ as)-  = traverseExprs allowHO e >> mapM_ (traverseExprs allowHO . thd3) as-traverseExprs allowHO (Cast e _)-  = traverseExprs allowHO e-traverseExprs allowHO (Tick _ e)-  = traverseExprs allowHO e-traverseExprs _ _-  = return ()--traverseBinds :: Bool -> Bind Var -> ReplaceM b -> ReplaceM b-traverseBinds allowHO b k = withExtendedEnv allowHO (bindersOf b) $ do-  mapM_ (traverseExprs allowHO) (rhssOfBind b)-  k---- RJ: this function is incomprehensible, what does it do?!-withExtendedEnv :: Bool -> [Var] -> ReplaceM b -> ReplaceM b-withExtendedEnv allowHO vs k = do-  RE env' fenv' emb tyi <- ask-  let env  = L.foldl' (\m v -> M.insert (varShortSymbol v) (symbol v) m) env' vs-      fenv = F.notracepp "FENV" $ L.foldl' (\m v -> insertSEnv (symbol v) (rTypeSortedReft emb (ofType $ varType v :: RSort)) m) fenv' vs-  withReaderT (const (RE env fenv emb tyi)) $ do-    mapM_ (replaceLocalBindsOne allowHO) vs-    k--varShortSymbol :: Var -> Symbol-varShortSymbol = symbol . takeWhile (/= '#') . GM.showPpr . getName---- RJ: this function is incomprehensible, what does it do?!-replaceLocalBindsOne :: Bool -> Var -> ReplaceM ()-replaceLocalBindsOne allowHO v-  = do mt <- gets (M.lookup v . fst)-       case mt of-         Nothing -> return ()-         Just (Loc l l' (toRTypeRep -> t@(RTypeRep {..}))) -> do-           (RE env' fenv emb tyi) <- ask-           let f m k = M.lookupDefault k k m-           let (env,args) = L.mapAccumL (\e (v, t) -> (M.insert v v e, substa (f e) t))-                             env' (zip ty_binds ty_args)-           let res  = substa (f env) ty_res-           let t'   = fromRTypeRep $ t { ty_args = args, ty_res = res }-           let msg  = ErrTySpec (GM.sourcePosSrcSpan l) ( {- text "replaceLocalBindsOne" <+> -} pprint v) t'-           case checkTy allowHO msg emb tyi fenv (Loc l l' t') of-             Just err -> Ex.throw err-             Nothing  -> modify (first $ M.insert v (Loc l l' t'))-           mes <- gets (M.lookup v . snd)-           case mes of-             Nothing -> return ()-             Just es -> do-               let es'  = substa (f env) es-               case checkTerminationExpr emb fenv (v, Loc l l' t', es') of-                 Just err -> Ex.throw err-                 Nothing  -> modify (second $ M.insert v es')+{-# LANGUAGE PartialTypeSignatures     #-}+{-# LANGUAGE OverloadedStrings         #-}++-- | This module contains the functions that convert /from/ descriptions of+--   symbols, names and types (over freshly parsed /bare/ Strings),+--   /to/ representations connected to GHC vars, names, and types.+--   The actual /representations/ of bare and real (refinement) types are all+--   in `RefType` -- they are different instances of `RType`++module Language.Haskell.Liquid.Bare (+    GhcSpec(..)+  , makeGhcSpec++  -- * Lifted Spec+  , loadLiftedSpec+  , saveLiftedSpec+  ) where++import           Prelude                                    hiding (error)+import           Control.Monad                              (unless)+import qualified Control.Exception                          as Ex+import qualified Data.Binary                                as B+import qualified Data.Maybe                                 as Mb+import qualified Data.List                                  as L+import qualified Data.HashMap.Strict                        as M+import qualified Data.HashSet                               as S+import           Text.PrettyPrint.HughesPJ                  hiding (first, (<>)) -- (text, (<+>))+import           System.Directory                           (doesFileExist)+import           System.Console.CmdArgs.Verbosity           (whenLoud)+import           Language.Fixpoint.Utils.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.Types+import           Language.Haskell.Liquid.WiredIn+import qualified Language.Haskell.Liquid.Measure            as Ms+import qualified Language.Haskell.Liquid.Bare.Types         as Bare +import qualified Language.Haskell.Liquid.Bare.Resolve       as Bare +import qualified Language.Haskell.Liquid.Bare.DataType      as Bare +import qualified Language.Haskell.Liquid.Bare.Expand        as Bare +import qualified Language.Haskell.Liquid.Bare.Measure       as Bare +import qualified Language.Haskell.Liquid.Bare.Plugged       as Bare +import qualified Language.Haskell.Liquid.Bare.Axiom         as Bare +import qualified Language.Haskell.Liquid.Bare.ToBare        as Bare +import qualified Language.Haskell.Liquid.Bare.Class         as Bare +import qualified Language.Haskell.Liquid.Bare.Check         as Bare +import qualified Language.Haskell.Liquid.Bare.Laws          as Bare +import qualified Language.Haskell.Liquid.Transforms.CoreToLogic as CoreToLogic +import           Control.Arrow                    (second)++--------------------------------------------------------------------------------+-- | De/Serializing Spec files -------------------------------------------------+--------------------------------------------------------------------------------++loadLiftedSpec :: Config -> FilePath -> IO (Maybe Ms.BareSpec)+loadLiftedSpec cfg srcF+  | noLiftedImport cfg = putStrLn "No LIFTED Import" >> return Nothing +  | otherwise          = do+      let specF = extFileName BinSpec srcF+      ex  <- doesFileExist specF+      whenLoud $ putStrLn $ "Loading Binary Lifted Spec: " ++ specF ++ " " ++ "for source-file: " ++ show srcF ++ " " ++ show ex+      lSp <- if ex +               then Just <$> B.decodeFile specF +               else (warnMissingLiftedSpec srcF specF >> return Nothing)+      Ex.evaluate lSp++warnMissingLiftedSpec :: FilePath -> FilePath -> IO () +warnMissingLiftedSpec srcF specF = do +  incDir <- Misc.getIncludeDir +  unless (Misc.isIncludeFile incDir srcF)+    $ Ex.throw (errMissingSpec srcF specF) ++errMissingSpec :: FilePath -> FilePath -> UserError +errMissingSpec srcF specF = ErrNoSpec Ghc.noSrcSpan (text srcF) (text specF)++-- saveLiftedSpec :: FilePath -> ModName -> Ms.BareSpec -> IO ()+saveLiftedSpec :: GhcSrc -> GhcSpec -> IO () +saveLiftedSpec src sp = do+  ensurePath specF+  B.encodeFile specF lspec+  -- print (errorP "DIE" "HERE" :: String) +  where+    srcF  = giTarget src +    lspec = gsLSpec  sp +    specF = extFileName BinSpec srcF++-------------------------------------------------------------------------------------+-- | @makeGhcSpec@ invokes @makeGhcSpec0@ to construct the @GhcSpec@ and then +--   validates it using @checkGhcSpec@. +-------------------------------------------------------------------------------------+makeGhcSpec :: Config -> GhcSrc ->  LogicMap -> [(ModName, Ms.BareSpec)] -> 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 ++ghcSpecEnv :: GhcSpec -> SEnv SortedReft+ghcSpecEnv sp = fromListSEnv binds+  where+    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, RR s mempty)    | (x, s)         <- wiredSortedSyms       ]+                 , [(x, RR s mempty)    | (x, s)         <- gsImps sp       ]+                 ]+    vSort     = Bare.varSortedReft emb+    rSort     = rTypeSortedReft    emb+++-------------------------------------------------------------------------------------+-- | @makeGhcSpec0@ slurps up all the relevant information needed to generate +--   constraints for a target module and packages them into a @GhcSpec@ +--   See [NOTE] LIFTING-STAGES to see why we split into lSpec0, lSpec1, etc.+--   essentially, to get to the `BareRTEnv` as soon as possible, as thats what+--   lets us use aliases inside data-constructor definitions.+-------------------------------------------------------------------------------------+makeGhcSpec0 :: Config -> GhcSrc ->  LogicMap -> [(ModName, Ms.BareSpec)] -> 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 +                   } +  }+  where+    -- 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 +    laws     = makeSpecLaws env sigEnv (gsTySigs sig ++ gsAsmSigs sig) measEnv specs +    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 +    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"+    iSpecs2  = Bare.qualifyExpand env name rtEnv l [] iSpecs0    where l = F.dummyPos "expand-iSpecs2"+    rtEnv    = Bare.makeRTEnv env name mySpec1 iSpecs0 lmap  +    mySpec1  = mySpec0 <> lSpec0    +    lSpec0   = makeLiftedSpec0 cfg src embs lmap mySpec0 +    embs     = makeEmbeds          src env ((name, mySpec0) : M.toList iSpecs0)+    -- extract name and specs+    env      = Bare.makeEnv cfg src lmap mspecs  +    (mySpec0, iSpecs0) = splitSpecs name mspecs +    -- check barespecs +    name     = F.notracepp ("ALL-SPECS" ++ zzz) $ giTargetMod  src +    zzz      = F.showpp (fst <$> mspecs)++splitSpecs :: ModName -> [(ModName, Ms.BareSpec)] -> (Ms.BareSpec, Bare.ModSpecs) +splitSpecs name specs = (mySpec, iSpecm) +  where +    mySpec            = mconcat (snd <$> mySpecs)+    (mySpecs, iSpecs) = L.partition ((name ==) . fst) specs +    iSpecm            = fmap mconcat . Misc.group $ iSpecs+++makeImports :: [(ModName, Ms.BareSpec)] -> [(F.Symbol, F.Sort)]+makeImports specs = concatMap (expSigs . snd) specs'+  where specs' = filter (isSrcImport . fst) specs+++makeEmbeds :: GhcSrc -> Bare.Env -> [(ModName, Ms.BareSpec)] -> F.TCEmb Ghc.TyCon +makeEmbeds src env +  = Bare.addClassEmbeds (gsCls src) (gsFiTcs src) +  . mconcat +  . map (makeTyConEmbeds env)++makeTyConEmbeds :: Bare.Env -> (ModName, Ms.BareSpec) -> F.TCEmb Ghc.TyCon+makeTyConEmbeds env (name, spec) +  = F.tceFromList [ (tc, t) | (c,t) <- F.tceToList (Ms.embeds spec), tc <- symTc c ]+    where+      symTc = Mb.maybeToList . Bare.maybeResolveSym env name "embed-tycon" ++--------------------------------------------------------------------------------+-- | [NOTE]: REFLECT-IMPORTS+--+-- 1. MAKE the full LiftedSpec, which will eventually, contain:+--      makeHaskell{Inlines, Measures, Axioms, Bounds}+-- 2. SAVE the LiftedSpec, which will be reloaded+-- +--   This step creates the aliases and inlines etc. It must be done BEFORE+--   we compute the `SpecType` for (all, including the reflected binders),+--   as we need the inlines and aliases to properly `expand` the SpecTypes.+--------------------------------------------------------------------------------+makeLiftedSpec1 :: Config -> GhcSrc -> Bare.TycEnv -> LogicMap -> Ms.BareSpec +                -> Ms.BareSpec+makeLiftedSpec1 _ src tycEnv lmap mySpec = mempty+  { Ms.measures  = Bare.makeHaskellMeasures src tycEnv lmap mySpec }++--------------------------------------------------------------------------------+-- | [NOTE]: LIFTING-STAGES +-- +-- We split the lifting up into stage:+-- 0. Where we only lift inlines,+-- 1. Where we lift reflects, measures, and normalized tySigs+-- +-- This is because we need the inlines to build the @BareRTEnv@ which then+-- does the alias @expand@ business, that in turn, lets us build the DataConP,+-- i.e. the refined datatypes and their associate selectors, projectors etc,+-- that are needed for subsequent stages of the lifting.+--------------------------------------------------------------------------------+makeLiftedSpec0 :: Config -> GhcSrc -> F.TCEmb Ghc.TyCon -> LogicMap -> Ms.BareSpec +                -> Ms.BareSpec+makeLiftedSpec0 cfg src embs lmap mySpec = mempty+  { Ms.ealiases  = lmapEAlias . snd <$> Bare.makeHaskellInlines src embs lmap mySpec +  , Ms.reflects  = Ms.reflects mySpec+  , Ms.dataDecls = Bare.makeHaskellDataDecls cfg name mySpec tcs  +  }+  where +    tcs          = uniqNub (gsTcs src ++ refTcs)+    refTcs       = reflectedTyCons cfg embs cbs  mySpec+    cbs          = giCbs       src+    name         = giTargetMod src++uniqNub :: (Ghc.Uniquable a) => [a] -> [a]+uniqNub xs = M.elems $ M.fromList [ (index x, x) | x <- xs ]+  where+    index  = Ghc.getKey . Ghc.getUnique++-- | 'reflectedTyCons' returns the list of `[TyCon]` that must be reflected but+--   which are defined *outside* the current module e.g. in Base or somewhere+--   that we don't have access to the code.++reflectedTyCons :: Config -> TCEmb Ghc.TyCon -> [Ghc.CoreBind] -> Ms.BareSpec -> [Ghc.TyCon]+reflectedTyCons cfg embs cbs spec+  | exactDCFlag cfg = filter (not . isEmbedded embs)+                    $ concatMap varTyCons+                    $ reflectedVars spec cbs+  | otherwise       = []++-- | We cannot reflect embedded tycons (e.g. Bool) as that gives you a sort+--   conflict: e.g. what is the type of is-True? does it take a GHC.Types.Bool+--   or its embedding, a bool?+isEmbedded :: TCEmb Ghc.TyCon -> Ghc.TyCon -> Bool+isEmbedded embs c = F.tceMember c embs++varTyCons :: Ghc.Var -> [Ghc.TyCon]+varTyCons = specTypeCons . ofType . Ghc.varType++specTypeCons           :: SpecType -> [Ghc.TyCon]+specTypeCons           = foldRType tc []+  where+    tc acc t@(RApp {}) = (rtc_tc $ rt_tycon t) : acc+    tc acc _           = acc++reflectedVars :: Ms.BareSpec -> [Ghc.CoreBind] -> [Ghc.Var]+reflectedVars spec cbs = (fst <$> xDefs)+  where+    xDefs              = Mb.mapMaybe (`GM.findVarDef` cbs) reflSyms+    reflSyms           = fmap val . S.toList . Ms.reflects $ spec++------------------------------------------------------------------------------------------+makeSpecVars :: Config -> GhcSrc -> Ms.BareSpec -> Bare.Env -> Bare.MeasEnv -> GhcSpecVars +------------------------------------------------------------------------------------------+makeSpecVars cfg src mySpec env measEnv = SpVar +  { gsTgtVars    =   map (resolveStringVar  env name)              (checks     cfg) +  , gsIgnoreVars = S.map (Bare.lookupGhcVar env name "gs-ignores") (Ms.ignores mySpec) +  , gsLvars      = S.map (Bare.lookupGhcVar env name "gs-lvars"  ) (Ms.lvars   mySpec)+  , gsCMethods   = snd3 <$> Bare.meMethods measEnv +  }+  where name     = giTargetMod src ++qualifySymbolic :: (F.Symbolic a) => ModName -> a -> F.Symbol +qualifySymbolic name s = GM.qualifySymbol (F.symbol name) (F.symbol s)++resolveStringVar :: Bare.Env -> ModName -> String -> Ghc.Var+resolveStringVar env name s = Bare.lookupGhcVar env name "resolve-string-var" lx+  where +    lx                      = dummyLoc (qualifySymbolic name s)++------------------------------------------------------------------------------------------+makeSpecQual :: Config -> Bare.Env -> Bare.TycEnv -> Bare.MeasEnv -> BareRTEnv -> Bare.ModSpecs +             -> GhcSpecQual +------------------------------------------------------------------------------------------+makeSpecQual _cfg env tycEnv measEnv _rtEnv specs = SpQual +  { gsQualifiers = filter okQual quals +  , gsRTAliases  = [] -- makeSpecRTAliases env rtEnv -- TODO-REBARE+  } +  where +    quals        = concatMap (makeQualifiers env tycEnv) (M.toList specs) +    -- mSyms        = F.tracepp "MSYMS" $ M.fromList (Bare.meSyms measEnv ++ Bare.meClassSyms measEnv)+    okQual q     = F.notracepp ("okQual: " ++ F.showpp q) +                   $ all (`S.member` mSyms) (F.syms q)+    mSyms        = F.notracepp "MSYMS" . S.fromList +                   $  (fst <$> wiredSortedSyms) +                   ++ (fst <$> Bare.meSyms measEnv) +                   ++ (fst <$> Bare.meClassSyms measEnv)++makeQualifiers :: Bare.Env -> Bare.TycEnv -> (ModName, Ms.Spec ty bndr) -> [F.Qualifier]+makeQualifiers env tycEnv (mod, spec) +  = fmap        (Bare.qualifyTopDummy env        mod) +  . Mb.mapMaybe (resolveQParams       env tycEnv mod)+  $ Ms.qualifiers spec +++-- | @resolveQualParams@ converts the sorts of parameters from, e.g. +--     'Int' ===> 'GHC.Types.Int' or +--     'Ptr' ===> 'GHC.Ptr.Ptr'  +--   It would not be required if _all_ qualifiers are scraped from +--   function specs, but we're keeping it around for backwards compatibility.++resolveQParams :: Bare.Env -> Bare.TycEnv -> ModName -> F.Qualifier -> Maybe F.Qualifier +resolveQParams env tycEnv name q = do +     qps   <- mapM goQP (F.qParams q) +     return $ q { F.qParams = qps } +  where +    goQP qp          = do { s <- go (F.qpSort qp) ; return qp { F.qpSort = s } } +    go               :: F.Sort -> Maybe F.Sort   +    go (FAbs i s)    = FAbs i <$> go s+    go (FFunc s1 s2) = FFunc  <$> go s1 <*> go s2+    go (FApp  s1 s2) = FApp   <$> go s1 <*> go s2+    go (FTC c)       = qualifyFTycon env tycEnv name c +    go s             = Just s ++qualifyFTycon :: Bare.Env -> Bare.TycEnv -> ModName -> F.FTycon -> Maybe F.Sort +qualifyFTycon env tycEnv name c +  | isPrimFTC           = Just (FTC c) +  | otherwise           = tyConSort embs . F.atLoc tcs <$> ty +  where       +    ty                  = Bare.maybeResolveSym env name "qualify-FTycon" tcs                +    isPrimFTC           = (F.val tcs) `elem` F.prims +    tcs                 = F.fTyconSymbol c+    embs                = Bare.tcEmbs tycEnv ++tyConSort :: F.TCEmb Ghc.TyCon -> F.Located Ghc.TyCon -> F.Sort +tyConSort embs lc = Mb.maybe s0 fst (F.tceLookup c embs)+  where +    c             = F.val lc+    s0            = tyConSortRaw lc++tyConSortRaw :: F.Located Ghc.TyCon -> F.Sort +tyConSortRaw = FTC . F.symbolFTycon . fmap F.symbol ++------------------------------------------------------------------------------------------+makeSpecTerm :: Config -> Ms.BareSpec -> Bare.Env -> ModName -> GhcSpecTerm +------------------------------------------------------------------------------------------+makeSpecTerm cfg mySpec env name = SpTerm +  { gsLazy       = S.insert dictionaryVar (lazies `mappend` sizes)+  , gsStTerm     = sizes+  , gsAutosize   = autos +  , gsDecr       = makeDecrs env name mySpec+  , gsNonStTerm  = mempty +  }+  where  +    lazies       = makeLazy     env name mySpec+    autos        = makeAutoSize env name mySpec+    strT         = not (structuralTerm cfg) +    sizes +     | strT      = makeSize env name mySpec +     | otherwise = mempty ++-- formerly, makeHints+makeDecrs :: Bare.Env -> ModName -> Ms.BareSpec -> [(Ghc.Var, [Int])] +makeDecrs env name mySpec = +  [ (v, z) | (lx, z) <- Ms.decr mySpec+           , let v    = Bare.lookupGhcVar env name "decreasing" lx+  ]++makeLazy :: Bare.Env -> ModName -> Ms.BareSpec -> S.HashSet Ghc.Var+makeLazy env name spec = +  S.map (Bare.lookupGhcVar env name "Var") (Ms.lazy spec)++makeAutoSize :: Bare.Env -> ModName -> Ms.BareSpec -> S.HashSet Ghc.TyCon+makeAutoSize env name spec =+  S.map (Bare.lookupGhcTyCon env name "TyCon") (Ms.autosize spec) ++makeSize :: Bare.Env -> ModName -> Ms.BareSpec -> S.HashSet Ghc.Var+makeSize env name spec = +  S.map (Bare.lookupGhcVar env name "Var") (S.fromList lzs)+  where+    lzs = Mb.catMaybes (getSizeFuns <$> Ms.dataDecls spec)+    getSizeFuns decl+      | Just x       <- tycSFun decl+      , SymSizeFun f <- x+      = Just f+      | otherwise+      = Nothing++------------------------------------------------------------------------------------------+makeSpecLaws :: Bare.Env -> Bare.SigEnv -> [(Ghc.Var,LocSpecType)] -> Bare.MeasEnv -> Bare.ModSpecs +             -> GhcSpecLaws +------------------------------------------------------------------------------------------+makeSpecLaws env sigEnv sigs menv specs = SpLaws +  { gsLawDefs = second (map (\(_,x,y) -> (x,y))) <$> Bare.meCLaws menv  +  , gsLawInst = Bare.makeInstanceLaws env sigEnv sigs specs+  }++------------------------------------------------------------------------------------------+makeSpecRefl :: GhcSrc -> Bare.MeasEnv -> Bare.ModSpecs -> Bare.Env -> ModName -> GhcSpecSig -> Bare.TycEnv +             -> GhcSpecRefl +------------------------------------------------------------------------------------------+makeSpecRefl 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)+  , gsHAxioms    = F.notracepp "gsHAxioms" xtes +  }+  where+    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+    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  <$> gsTySigs  sig)   -- measures ++    lmap         = Bare.reLMap env++isReflectVar :: S.HashSet F.Symbol -> Ghc.Var -> Bool +isReflectVar reflSyms v = S.member vx reflSyms+  where+    vx                  = GM.dropModuleNames (symbol v)++getReflects :: Bare.ModSpecs -> [Symbol]+getReflects  = fmap val . S.toList . S.unions . fmap (names . snd) . M.toList+  where+    names  z = S.unions [ Ms.reflects z, Ms.inlines z, Ms.hmeas z ]+    +------------------------------------------------------------------------------------------+-- | @updateReflSpecSig@ uses the information about reflected functions to update the +--   "assumed" signatures. +------------------------------------------------------------------------------------------+addReflSigs :: GhcSpecRefl -> GhcSpecSig -> GhcSpecSig+------------------------------------------------------------------------------------------+addReflSigs refl sig = sig { gsAsmSigs = reflSigs ++ gsAsmSigs sig }+  where +    reflSigs         = [ (x, t) | (x, t, _) <- gsHAxioms refl ]   ++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)++----------------------------------------------------------------------------------------+makeSpecSig :: Config -> ModName -> Bare.ModSpecs -> Bare.Env -> Bare.SigEnv -> Bare.TycEnv -> Bare.MeasEnv -> [Ghc.CoreBind]+            -> GhcSpecSig +----------------------------------------------------------------------------------------+makeSpecSig cfg name specs env sigEnv tycEnv measEnv cbs = SpSig +  { gsTySigs   = F.notracepp "gsTySigs"  tySigs +  , gsAsmSigs  = F.notracepp "gsAsmSigs" asmSigs+  , gsDicts    = dicts +  , gsMethods  = if noclasscheck cfg then [] else Bare.makeMethodTypes dicts (Bare.meClasses  measEnv) cbs +  , gsInSigs   = mempty -- TODO-REBARE :: ![(Var, LocSpecType)]  +  , gsNewTypes = makeNewTypes env sigEnv allSpecs +  , gsTexprs   = [ (v, t, es) | (v, t, Just es) <- mySigs ] +  }+  where +    dicts      = Bare.makeSpecDictionaries env sigEnv specs  +    mySpec     = M.lookupDefault mempty name specs+    asmSigs    = Bare.tcSelVars tycEnv +              ++ makeAsmSigs env sigEnv name specs +              ++ [ (x,t) | (_, x, t) <- concat $ map snd (Bare.meCLaws measEnv)]+    tySigs     = strengthenSigs . concat $+                  [ [(v, (0, t)) | (v, t,_) <- mySigs                         ]   -- NOTE: these weights are to priortize +                  , [(v, (1, t)) | (v, t  ) <- makeMthSigs measEnv            ]   -- user defined sigs OVER auto-generated +                  , [(v, (2, t)) | (v, t  ) <- makeInlSigs env rtEnv allSpecs ]   -- during the strengthening, i.e. to KEEP +                  , [(v, (3, t)) | (v, t  ) <- makeMsrSigs env rtEnv allSpecs ]   -- the binders used in USER-defined sigs +                  ]                                                               -- as they appear in termination metrics+    mySigs     = F.notracepp "MAKE-TYSIGS" $ makeTySigs  env sigEnv name mySpec+    allSpecs   = M.toList specs +    rtEnv      = Bare.sigRTEnv sigEnv +    -- hmeas      = makeHMeas    env allSpecs ++strengthenSigs :: [(Ghc.Var, (Int, LocSpecType))] ->[(Ghc.Var, LocSpecType)]+strengthenSigs sigs = go <$> Misc.groupList sigs +  where+    go (v, ixs)     = (v,) $ L.foldl1' (flip meetLoc) (F.notracepp ("STRENGTHEN-SIGS: " ++ F.showpp v) (prio ixs))+    prio            = fmap snd . Misc.sortOn fst +    meetLoc         :: LocSpecType -> LocSpecType -> LocSpecType+    meetLoc t1 t2   = t1 {val = val t1 `F.meet` val t2}++makeMthSigs :: Bare.MeasEnv -> [(Ghc.Var, LocSpecType)]+makeMthSigs measEnv = [ (v, t) | (_, v, t) <- Bare.meMethods measEnv ]++makeInlSigs :: Bare.Env -> BareRTEnv -> [(ModName, Ms.BareSpec)] -> [(Ghc.Var, LocSpecType)] +makeInlSigs env rtEnv +  = makeLiftedSigs rtEnv CoreToLogic.inlineSpecType +  . makeFromSet "hinlines" Ms.inlines env ++makeMsrSigs :: Bare.Env -> BareRTEnv -> [(ModName, Ms.BareSpec)] -> [(Ghc.Var, LocSpecType)] +makeMsrSigs env rtEnv +  = makeLiftedSigs rtEnv CoreToLogic.measureSpecType +  . makeFromSet "hmeas" Ms.hmeas env ++makeLiftedSigs :: BareRTEnv -> (Ghc.Var -> SpecType) -> [Ghc.Var] -> [(Ghc.Var, LocSpecType)]+makeLiftedSigs rtEnv f xs +  = [(x, lt) | x <- xs+             , let lx = GM.locNamedThing x+             , let lt = expand $ lx {val = f x}+    ]+  where+    expand   = Bare.specExpandType rtEnv ++makeFromSet :: String -> (Ms.BareSpec -> S.HashSet LocSymbol) -> Bare.Env -> [(ModName, Ms.BareSpec)] +            -> [Ghc.Var] +makeFromSet msg f env specs = concat [ mk n xs | (n, s) <- specs, let xs = S.toList (f s)] +  where +    mk name                 = Mb.mapMaybe (Bare.maybeResolveSym env name msg) ++makeTySigs :: Bare.Env -> Bare.SigEnv -> ModName -> Ms.BareSpec +           -> [(Ghc.Var, LocSpecType, Maybe [Located F.Expr])]+makeTySigs env sigEnv name spec +              = [ (x, cook x bt, z) | (x, bt, z) <- rawSigs ]+  where +    rawSigs   = Bare.resolveLocalBinds env expSigs +    expSigs   = makeTExpr  env name bareSigs rtEnv spec +    bareSigs  = bareTySigs env name                spec +    rtEnv     = Bare.sigRTEnv sigEnv +    cook x bt = Bare.cookSpecType env sigEnv name (Bare.HsTV x) bt ++bareTySigs :: Bare.Env -> ModName -> Ms.BareSpec -> [(Ghc.Var, LocBareType)]+bareTySigs env name spec = checkDuplicateSigs +  [ (v, t) | (x, t) <- Ms.sigs spec ++ Ms.localSigs spec  +           , let v   = F.notracepp "LOOKUP-GHC-VAR" $ Bare.lookupGhcVar env name "rawTySigs" x +  ] ++-- checkDuplicateSigs :: [(Ghc.Var, LocSpecType)] -> [(Ghc.Var, LocSpecType)] +checkDuplicateSigs :: (Symbolic x) => [(x, F.Located t)] -> [(x, F.Located t)]+checkDuplicateSigs xts = case Misc.uniqueByKey symXs  of+  Left (k, ls) -> uError (errDupSpecs (pprint k) (GM.sourcePosSrcSpan <$> ls))+  Right _      -> xts +  where+    symXs = [ (F.symbol x, F.loc t) | (x, t) <- xts ]+++makeAsmSigs :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.ModSpecs -> [(Ghc.Var, LocSpecType)]+makeAsmSigs env sigEnv myName specs = +  [ (x, t) | (name, x, bt) <- rawAsmSigs env myName specs+           , let t = Bare.cookSpecType env sigEnv name (Bare.LqTV x) bt+  ] ++rawAsmSigs :: Bare.Env -> ModName -> Bare.ModSpecs -> [(ModName, Ghc.Var, LocBareType)]+rawAsmSigs env myName specs = +  [ (m, v, t) | (v, sigs) <- allAsmSigs env myName specs +              , let (m, t) = myAsmSig v sigs +  ] +    +myAsmSig :: Ghc.Var -> [(Bool, ModName, LocBareType)] -> (ModName, LocBareType)+myAsmSig v sigs = Mb.fromMaybe errImp (Misc.firstMaybes [mbHome, mbImp]) +  where +    mbHome      = takeUnique err                  sigsHome +    mbImp       = takeUnique err (Misc.firstGroup sigsImp) -- see [NOTE:Prioritize-Home-Spec] +    sigsHome    = [(m, t)      | (True,  m, t) <- sigs ]+    sigsImp     = F.notracepp ("SIGS-IMP: " ++ F.showpp v)+                  [(d, (m, t)) | (False, m, t) <- sigs, let d = nameDistance vName m]+    err ts      = ErrDupSpecs (Ghc.getSrcSpan v) (F.pprint v) (GM.sourcePosSrcSpan . F.loc . snd <$> ts) :: UserError+    errImp      = impossible Nothing "myAsmSig: cannot happen as sigs is non-null"+    vName       = GM.takeModuleNames (F.symbol v)++makeTExpr :: Bare.Env -> ModName -> [(Ghc.Var, LocBareType)] -> BareRTEnv -> Ms.BareSpec +          -> [(Ghc.Var, LocBareType, Maybe [Located F.Expr])]+makeTExpr env name tySigs rtEnv spec +                = F.notracepp "MAKE-TEXPRS" +                  [ (v, t, qual t <$> es) | (v, (t, es)) <- M.toList vSigExprs ] +  where +    qual t es   = qualifyTermExpr env name rtEnv t <$> es+    vSigExprs   = Misc.hashMapMapWithKey (\v t -> (t, M.lookup v vExprs)) vSigs +    vExprs      = M.fromList (makeVarTExprs env name spec) +    vSigs       = M.fromList tySigs +                    +qualifyTermExpr :: Bare.Env -> ModName -> BareRTEnv -> LocBareType -> Located F.Expr +                -> Located F.Expr +qualifyTermExpr env name rtEnv t le +        = F.atLoc le (Bare.qualifyExpand env name rtEnv l bs e)+  where +    l   = F.loc le +    e   = F.val le +    bs  = ty_binds . toRTypeRep . val $ t ++makeVarTExprs :: Bare.Env -> ModName -> Ms.BareSpec -> [(Ghc.Var, [Located F.Expr])]+makeVarTExprs env name spec = +  [ (Bare.lookupGhcVar env name "Var" x, es) +      | (x, es) <- Ms.termexprs spec           ]+----------------------------------------------------------------------------------------+-- [NOTE:Prioritize-Home-Spec] Prioritize spec for THING defined in +-- `Foo.Bar.Baz.Quux.x` over any other specification, IF GHC's +-- fully qualified name for THING is `Foo.Bar.Baz.Quux.x`. +--+-- For example, see tests/names/neg/T1078.hs for example, +-- which assumes a spec for `head` defined in both +-- +--   (1) Data/ByteString.spec+--   (2) Data/ByteString/Char8.spec +-- +-- We end up resolving the `head` in (1) to the @Var@ `Data.ByteString.Char8.head` +-- even though there is no exact match, just to account for re-exports of "internal"+-- modules and such (see `Resolve.matchMod`). However, we should pick the closer name+-- if its available.+----------------------------------------------------------------------------------------+nameDistance :: F.Symbol -> ModName -> Int +nameDistance vName tName +  | vName == F.symbol tName = 0 +  | otherwise               = 1+++takeUnique :: Ex.Exception e => ([a] -> e) -> [a] -> Maybe a+takeUnique _ []  = Nothing +takeUnique _ [x] = Just x +takeUnique f xs  = Ex.throw (f xs) ++allAsmSigs :: Bare.Env -> ModName -> Bare.ModSpecs -> [(Ghc.Var, [(Bool, ModName, LocBareType)])]+allAsmSigs env myName specs = Misc.groupList+  [ (v, (must, name, t))  +      | (name, spec) <- M.toList specs+      , (must, x, t) <- getAsmSigs myName name spec+      , v            <- Mb.maybeToList (resolveAsmVar env name must x) +  ] ++resolveAsmVar :: Bare.Env -> ModName -> Bool -> LocSymbol -> Maybe Ghc.Var +resolveAsmVar env name True  lx = Just $ Bare.lookupGhcVar env name "resolveAsmVar-True"  lx+resolveAsmVar env name False lx = Bare.maybeResolveSym     env name "resolveAsmVar-False" lx  ++getAsmSigs :: ModName -> ModName -> Ms.BareSpec -> [(Bool, LocSymbol, LocBareType)]  +getAsmSigs myName name spec +  | myName == name = [ (True,  x,  t) | (x, t) <- Ms.asmSigs spec ] -- MUST    resolve, or error+  | otherwise      = [ (False, x', t) | (x, t) <- Ms.asmSigs spec +                                                  ++ Ms.sigs spec+                                      , let x' = qSym x           ]  -- MAY-NOT resolve+  where +    qSym           = fmap (GM.qualifySymbol ns) +    ns             = F.symbol name++-- TODO-REBARE: grepClassAssumes+_grepClassAssumes :: [RInstance t] -> [(Located F.Symbol, t)]+_grepClassAssumes  = concatMap go+  where+    go    xts              = Mb.mapMaybe goOne (risigs xts)+    goOne (x, RIAssumed t) = Just (fmap (F.symbol . (".$c" ++ ) . F.symbolString) x, t)+    goOne (_, RISig _)     = Nothing++makeSigEnv :: F.TCEmb Ghc.TyCon -> Bare.TyConMap -> Ghc.NameSet -> BareRTEnv -> Bare.SigEnv +makeSigEnv embs tyi exports rtEnv = Bare.SigEnv+  { sigEmbs     = embs +  , sigTyRTyMap = tyi +  , sigExports  = exports +  , sigRTEnv    = rtEnv+  } ++makeNewTypes :: Bare.Env -> Bare.SigEnv -> [(ModName, Ms.BareSpec)] -> [(Ghc.TyCon, LocSpecType)]+makeNewTypes env sigEnv specs = +  [ ct | (name, spec) <- specs+       , d            <- Ms.newtyDecls spec+       , ct           <- makeNewType env sigEnv name d +  ] ++makeNewType :: Bare.Env -> Bare.SigEnv -> ModName -> DataDecl -> [(Ghc.TyCon, LocSpecType)]+makeNewType env sigEnv name d + | Just tc <- tcMb            = [(tc, t)] + | otherwise                  = []+  where +    tcMb                      = Bare.lookupGhcDnTyCon env name "makeNewType" tcName+    tcName                    = tycName d+    t                         = Bare.cookSpecType env sigEnv name Bare.GenTV bt+    bt                        = getTy tcName (tycSrcPos d) (tycDCons d)+    getTy _ l [c]+      | [(_, t)] <- dcFields c = Loc l l t+    getTy n l _                = Ex.throw (err n l) +    err n l                    = ErrOther (GM.sourcePosSrcSpan l) ("Bad new type declaration:" <+> F.pprint n) :: UserError++------------------------------------------------------------------------------------------+makeSpecData :: GhcSrc -> Bare.Env -> Bare.SigEnv -> Bare.MeasEnv -> GhcSpecSig -> Bare.ModSpecs+             -> GhcSpecData+------------------------------------------------------------------------------------------+makeSpecData src env sigEnv measEnv sig specs = SpData +  { gsCtors      = -- F.notracepp "GS-CTORS" +                   [ (x, tt) +                       | (x, t) <- Bare.meDataCons measEnv+                       , let tt  = Bare.plugHoles sigEnv name (Bare.LqTV x) t +                   ]+  , gsMeas       = [ (F.symbol x, uRType <$> t) | (x, t) <- measVars ] +  , gsMeasures   = Bare.qualifyTopDummy env name <$> (ms1 ++ ms2)+  , gsInvariants = Misc.nubHashOn (F.loc . snd) invs +  , gsIaliases   = concatMap (makeIAliases env sigEnv) (M.toList specs)+  , gsUnsorted   = usI ++ (concatMap msUnSorted $ concatMap measures specs)+  }+  where+    measVars     = Bare.meSyms      measEnv -- ms'+                ++ Bare.meClassSyms measEnv -- cms' +                ++ Bare.varMeasures env+    measuresSp   = Bare.meMeasureSpec measEnv  +    ms1          = M.elems (Ms.measMap measuresSp)+    ms2          =          Ms.imeas   measuresSp+    mySpec       = M.lookupDefault mempty name specs+    name         = giTargetMod      src+    (minvs,usI)  = makeMeasureInvariants env name sig mySpec+    invs         = minvs ++ concat (makeInvariants env sigEnv <$> M.toList specs)++makeIAliases :: Bare.Env -> Bare.SigEnv -> (ModName, BareSpec) -> [(LocSpecType, LocSpecType)]+makeIAliases env sigEnv (name, spec)+  = [ z | Right z <- mkIA <$> Ms.ialiases spec ]+  where +    -- mkIA :: (LocBareType, LocBareType) -> Either _ (LocSpecType, LocSpecType)+    mkIA (t1, t2) = (,) <$> mkI t1 <*> mkI t2+    mkI           = Bare.cookSpecTypeE env sigEnv name Bare.GenTV ++makeInvariants :: Bare.Env -> Bare.SigEnv -> (ModName, Ms.BareSpec) -> [(Maybe Ghc.Var, Located SpecType)]+makeInvariants env sigEnv (name, spec) = +  [ (Nothing, t) +    | (_, bt) <- Ms.invariants spec +    , Bare.knownGhcType env name bt+    , let t = Bare.cookSpecType env sigEnv name Bare.GenTV bt+  ]++makeMeasureInvariants :: Bare.Env -> ModName -> GhcSpecSig -> Ms.BareSpec +                      -> ([(Maybe Ghc.Var, LocSpecType)], [UnSortedExpr])+makeMeasureInvariants env name sig mySpec +  = mapSnd Mb.catMaybes $ +    unzip (measureTypeToInv env name <$> [(x, (y, ty)) | x <- xs, (y, ty) <- sigs+                                         , isSymbolOfVar (val x) y ])+  where +    sigs = gsTySigs sig +    xs   = S.toList (Ms.hmeas  mySpec) ++isSymbolOfVar :: Symbol -> Ghc.Var -> Bool+isSymbolOfVar x v = x == symbol' v+  where+    symbol' :: Ghc.Var -> Symbol+    symbol' = GM.dropModuleNames . symbol . Ghc.getName++measureTypeToInv :: Bare.Env -> ModName -> (LocSymbol, (Ghc.Var, LocSpecType)) -> ((Maybe Ghc.Var, LocSpecType), Maybe UnSortedExpr)+measureTypeToInv env name (x, (v, t)) +  = notracepp "measureTypeToInv" $ ((Just v, t {val = Bare.qualifyTop env name (F.loc x) mtype}), usorted)+  where+    trep = toRTypeRep (val t)+    ts   = ty_args  trep+    args = ty_binds trep+    res  = ty_res   trep+    z    = last args+    tz   = last ts+    usorted = if isSimpleADT tz then Nothing else ((mapFst (:[])) <$> mkReft (dummyLoc $ F.symbol v) z tz res)+    mtype+      | null ts +      = uError $ ErrHMeas (GM.sourcePosSrcSpan $ loc t) (pprint x) "Measure has no arguments!"+      | otherwise +      = mkInvariant x z tz res +    isSimpleADT (RApp _ ts _ _) = all isRVar ts +    isSimpleADT _               = False ++mkInvariant :: LocSymbol -> Symbol -> SpecType -> SpecType -> SpecType+mkInvariant x z t tr = strengthen (top <$> t) (MkUReft reft mempty mempty)+      where+        reft  = Mb.maybe mempty Reft mreft+        mreft = mkReft x z t tr +++mkReft :: LocSymbol -> Symbol -> SpecType -> SpecType -> Maybe (Symbol, Expr)+mkReft x z _t tr +  | Just q <- stripRTypeBase tr+  = let Reft (v, p) = toReft q+        su          = mkSubst [(v, mkEApp x [EVar v])]+        p'          = pAnd $ filter (\e -> z `notElem` syms e) $ conjuncts p+    in  Just (v, subst su p')+mkReft _ _ _ _  +  = Nothing +++-- REBARE: formerly, makeGhcSpec3+-------------------------------------------------------------------------------------------+makeSpecName :: Bare.Env -> Bare.TycEnv -> Bare.MeasEnv -> ModName -> GhcSpecNames+-------------------------------------------------------------------------------------------+makeSpecName env tycEnv measEnv name = SpNames +  { gsFreeSyms = Bare.reSyms env +  , gsDconsP   = [ F.atLoc dc (dcpCon dc) | dc <- datacons ++ cls ] +  , gsTconsP   = Bare.qualifyTopDummy env name <$> tycons                +  -- , gsLits = mempty                                              -- TODO-REBARE, redundant with gsMeas+  , gsTcEmbeds = Bare.tcEmbs     tycEnv   +  , gsADTs     = Bare.tcAdts     tycEnv +  , gsTyconEnv = Bare.tcTyConMap tycEnv  +  }+  where +    datacons, cls :: [DataConP]+    datacons   = Bare.tcDataCons tycEnv +    cls        = F.tracepp "meClasses" $ Bare.meClasses measEnv +    tycons     = Bare.tcTyCons   tycEnv +++-- REBARE: formerly, makeGhcCHOP1+-------------------------------------------------------------------------------------------+makeTycEnv :: Config -> ModName -> Bare.Env -> TCEmb Ghc.TyCon -> Ms.BareSpec -> Bare.ModSpecs +           -> Bare.TycEnv +-------------------------------------------------------------------------------------------+makeTycEnv cfg myName env embs mySpec iSpecs = Bare.TycEnv +  { tcTyCons      = tycons                  +  , tcDataCons    = val <$> datacons +  , tcSelMeasures = dcSelectors             +  , tcSelVars     = recSelectors            +  , tcTyConMap    = tyi                     +  , tcAdts        = adts                    +  , tcDataConMap  = dm+  , tcEmbs        = embs+  , tcName        = myName+  }+  where +    (tcDds, dcs)  = Misc.concatUnzip $ Bare.makeConTypes env <$> specs +    specs         = (myName, mySpec) : M.toList iSpecs+    tcs           = Misc.snd3 <$> tcDds +    tyi           = Bare.qualifyTopDummy env myName (makeTyConInfo embs fiTcs tycons)+    -- tycons        = F.tracepp "TYCONS" $ Misc.replaceWith tcpCon tcs wiredTyCons+    -- datacons      =  Bare.makePluggedDataCons embs tyi (Misc.replaceWith (dcpCon . val) (F.tracepp "DATACONS" $ concat dcs) wiredDataCons)+    tycons        = tcs ++ knownWiredTyCons env myName +    datacons      = Bare.makePluggedDataCon embs tyi <$> (concat dcs ++ knownWiredDataCons env myName)+    tds           = [(name, tcpCon tcp, dd) | (name, tcp, Just dd) <- tcDds]+    adts          = Bare.makeDataDecls cfg embs myName tds       datacons+    dm            = Bare.dataConMap adts+    dcSelectors   = concatMap (Bare.makeMeasureSelectors cfg dm) datacons+    recSelectors  = Bare.makeRecordSelectorSigs env myName       datacons+    fiTcs         = gsFiTcs (Bare.reSrc env)+   +knownWiredDataCons :: Bare.Env -> ModName -> [Located DataConP] +knownWiredDataCons env name = filter isKnown wiredDataCons +  where +    isKnown                 = Bare.knownGhcDataCon env name . GM.namedLocSymbol . dcpCon . val++knownWiredTyCons :: Bare.Env -> ModName -> [TyConP] +knownWiredTyCons env name = filter isKnown wiredTyCons +  where +    isKnown               = Bare.knownGhcTyCon env name . GM.namedLocSymbol . tcpCon +++-- REBARE: formerly, makeGhcCHOP2+-------------------------------------------------------------------------------------------+makeMeasEnv :: Bare.Env -> Bare.TycEnv -> Bare.SigEnv -> Bare.ModSpecs -> Bare.MeasEnv +-------------------------------------------------------------------------------------------+makeMeasEnv env tycEnv sigEnv specs = Bare.MeasEnv +  { meMeasureSpec = measures +  , meClassSyms   = cms' +  , meSyms        = ms' +  , meDataCons    = cs' +  , meClasses     = cls+  , meMethods     = mts ++ dms +  , meCLaws       = laws+  }+  where +    measures      = mconcat (Ms.mkMSpec' dcSelectors : (Bare.makeMeasureSpec env sigEnv name <$> M.toList specs))+    (cs, ms)      = Bare.makeMeasureSpec'     measures+    cms           = Bare.makeClassMeasureSpec measures+    cms'          = [ (x, Loc l l' $ cSort t)  | (Loc l l' x, t) <- cms ]+    ms'           = [ (F.val lx, F.atLoc lx t) | (lx, t) <- ms+                                               , Mb.isNothing (lookup (val lx) cms') ]+    cs'           = [ (v, txRefs v t) | (v, t) <- Bare.meetDataConSpec embs cs (datacons ++ cls)]+    txRefs v t    = Bare.txRefSort tyi embs (const t <$> GM.locNamedThing v) +    -- unpacking the environment+    tyi           = Bare.tcTyConMap    tycEnv +    dcSelectors   = Bare.tcSelMeasures tycEnv +    datacons      = Bare.tcDataCons    tycEnv +    embs          = Bare.tcEmbs        tycEnv +    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++-----------------------------------------------------------------------------------------+-- | @makeLiftedSpec@ is used to generate the BareSpec object that should be serialized +--   so that downstream files that import this target can access the lifted definitions, +--   e.g. for measures, reflected functions etc.+-----------------------------------------------------------------------------------------+makeLiftedSpec :: GhcSrc -> Bare.Env +               -> GhcSpecRefl -> GhcSpecData -> GhcSpecSig -> GhcSpecQual -> BareRTEnv +               -> Ms.BareSpec -> Ms.BareSpec +-----------------------------------------------------------------------------------------+makeLiftedSpec src _env refl sData sig qual myRTE lSpec0 = lSpec0 +  { Ms.asmSigs    = F.notracepp   "LIFTED-ASM-SIGS" $ xbs -- ++ mkSigs (gsAsmSigs sig)+  , Ms.reflSigs   = F.notracepp "REFL-SIGS"         xbs+  , Ms.sigs       = F.notracepp   "LIFTED-SIGS"     $        mkSigs (gsTySigs sig)  +  , Ms.invariants = [ ((varLocSym <$> x), Bare.specToBare <$> t) +                       | (x, t) <- gsInvariants sData +                       , isLocInFile srcF t+                    ]+  , Ms.axeqs      = gsMyAxioms refl +  , Ms.aliases    = F.notracepp "MY-ALIASES" $ M.elems . typeAliases $ myRTE+  , Ms.ealiases   = M.elems . exprAliases $ myRTE +  , Ms.qualifiers = filter (isLocInFile srcF) (gsQualifiers qual)+  }+  where+    mkSigs xts    = [ toBare (x, t) | (x, t) <- xts,  S.member x sigVars && (isExportedVar 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]+    reflVars      = S.fromList (fst <$> reflTySigs)+    -- myAliases fld = M.elems . fld $ myRTE +    srcF          = giTarget src ++isLocInFile :: (F.Loc a) => FilePath -> a ->  Bool +isLocInFile f lx = f == (locFile lx) ++locFile :: (F.Loc a) => a -> FilePath +locFile = Misc.fst3 . F.sourcePosElts . F.sp_start . F.srcSpan++varLocSym :: Ghc.Var -> LocSymbol+varLocSym v = F.symbol <$> GM.locNamedThing v++-- makeSpecRTAliases :: Bare.Env -> BareRTEnv -> [Located SpecRTAlias]+-- makeSpecRTAliases _env _rtEnv = [] -- TODO-REBARE +++--------------------------------------------------------------------------------+-- | @myRTEnv@ slices out the part of RTEnv that was generated by aliases defined +--   in the _target_ file, "cooks" the aliases (by conversion to SpecType), and +--   then saves them back as BareType.+--------------------------------------------------------------------------------+myRTEnv :: GhcSrc -> Bare.Env -> Bare.SigEnv -> BareRTEnv -> BareRTEnv +myRTEnv src env sigEnv rtEnv = mkRTE tAs' eAs +  where +    tAs'                     = normalizeBareAlias env sigEnv name <$> tAs+    tAs                      = myAliases typeAliases +    eAs                      = myAliases exprAliases +    myAliases fld            = filter (isLocInFile srcF) . M.elems . fld $ rtEnv +    srcF                     = giTarget    src+    name                     = giTargetMod src+  +mkRTE :: [Located (RTAlias x a)] -> [Located (RTAlias F.Symbol F.Expr)] -> RTEnv x a +mkRTE tAs eAs   = RTE +  { typeAliases = M.fromList [ (aName a, a) | a <- tAs ] +  , exprAliases = M.fromList [ (aName a, a) | a <- eAs ] +  } +  where aName   = rtName . F.val  ++normalizeBareAlias :: Bare.Env -> Bare.SigEnv -> ModName -> Located BareRTAlias +                   -> Located BareRTAlias +normalizeBareAlias env sigEnv name lx = fixRTA <$> lx +  where +    fixRTA  :: BareRTAlias -> BareRTAlias +    fixRTA  = mapRTAVars fixArg . fmap fixBody ++    fixArg  :: Symbol -> Symbol +    fixArg  = F.symbol . GM.symbolTyVar +      +    fixBody :: BareType -> BareType +    fixBody = Bare.specToBare +            . F.val +            . Bare.cookSpecType env sigEnv name Bare.RawTV +            . F.atLoc lx+
src/Language/Haskell/Liquid/Bare/Axiom.hs view
@@ -6,189 +6,168 @@ -- | 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 ) where  import Prelude hiding (error)-import CoreSyn-import TyCon-import Id-import Name-import Var-import Language.Haskell.Liquid.GHC.TypeRep- import Prelude hiding (mapM)+import qualified Control.Exception         as Ex -import           Control.Monad.Except hiding (forM, mapM)-import           Control.Monad.State hiding (forM, mapM)-import           Text.PrettyPrint.HughesPJ (text)-import qualified Data.HashSet        as S-import           Data.Maybe (fromMaybe)+-- import           Control.Monad.Except      hiding (forM, mapM)+-- import           Control.Monad.State       hiding (forM, mapM)+import qualified Text.PrettyPrint.HughesPJ as PJ -- (text)+import qualified Data.HashSet              as S+import qualified Data.Maybe                as Mb +import Control.Monad.Trans.State.Lazy (runState, get, put)+ import           Language.Fixpoint.Misc import qualified Language.Haskell.Liquid.Measure as Ms import qualified Language.Fixpoint.Types as F+import qualified Language.Haskell.Liquid.GHC.API as Ghc  import           Language.Haskell.Liquid.Types.RefType import           Language.Haskell.Liquid.Transforms.CoreToLogic import           Language.Haskell.Liquid.GHC.Misc import           Language.Haskell.Liquid.Types-import           Language.Haskell.Liquid.Bare.Env ----------------------------------------------------------------------------------makeHaskellAxioms-  :: F.TCEmb TyCon -> [CoreBind] -> GhcSpec -> Ms.BareSpec -> [F.DataDecl]-  -> BareM [ (Var, LocSpecType, AxiomEq)]----------------------------------------------------------------------------------makeHaskellAxioms tce cbs spec sp adts = do-  xtvds <- getReflectDefs spec sp cbs-  forM_ xtvds $ \(x,_,v,_) -> updateLMapXV x v-  lmap  <- logicEnv <$> get-  let dm = dataConMap adts-  mapM (makeAxiom tce lmap dm) xtvds+import           Language.Haskell.Liquid.Bare.Resolve as Bare+import           Language.Haskell.Liquid.Bare.Types   as Bare +-----------------------------------------------------------------------------------------------+makeHaskellAxioms :: GhcSrc -> Bare.Env -> Bare.TycEnv -> ModName -> LogicMap -> GhcSpecSig -> Ms.BareSpec +                  -> [(Ghc.Var, LocSpecType, F.Equation)]+-----------------------------------------------------------------------------------------------+makeHaskellAxioms src env tycEnv name lmap spSig +  = fmap (makeAxiom env tycEnv name lmap) +  . getReflectDefs src spSig -updateLMapXV :: LocSymbol -> Var -> BareM ()-updateLMapXV x v = do-  updateLMap x x v-  updateLMap (x {val = (F.symbol . showPpr . getName) v}) x v -getReflectDefs-  :: GhcSpec -> Ms.BareSpec -> [CoreBind]-  -> BareM [(LocSymbol, Maybe SpecType, Var, CoreExpr)]-getReflectDefs spec sp cbs  = mapM (findVarDefType cbs sigs) xs+getReflectDefs :: GhcSrc -> GhcSpecSig -> Ms.BareSpec +               -> [(LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr)]+getReflectDefs src sig spec = findVarDefType cbs sigs <$> xs   where-    sigs                    = gsTySigs spec-    xs                      = S.toList (Ms.reflects sp)+    sigs                    = gsTySigs sig +    xs                      = S.toList (Ms.reflects spec)+    cbs                     = giCbs src -findVarDefType-  :: [CoreBind] -> [(Var, LocSpecType)] -> LocSymbol-  -> BareM (LocSymbol, Maybe SpecType, Var, CoreExpr)+findVarDefType :: [Ghc.CoreBind] -> [(Ghc.Var, LocSpecType)] -> LocSymbol+               -> (LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr) findVarDefType cbs sigs x = case findVarDef (val x) cbs of-  Just (v, e) -> if isExportedId v-                   then return (x, val <$> lookup v sigs, v, e)-                   else throwError $ mkError x ("Lifted functions must be exported; please export " ++ show v)-  Nothing     -> throwError $ mkError x "Cannot lift haskell function"+  Just (v, e) -> if Ghc.isExportedId v+                   then (x, val <$> lookup v sigs, v, e)+                   else Ex.throw $ mkError x ("Lifted functions must be exported; please export " ++ show v)+  Nothing     -> Ex.throw $ mkError x "Cannot lift haskell function"  ---------------------------------------------------------------------------------makeAxiom :: F.TCEmb TyCon-          -> LogicMap-          -> DataConMap-          -> (LocSymbol, Maybe SpecType, Var, CoreExpr)-          -> BareM (Var, LocSpecType, AxiomEq)+makeAxiom :: Bare.Env -> Bare.TycEnv -> ModName -> LogicMap +          -> (LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr)+          -> (Ghc.Var, LocSpecType, F.Equation) ---------------------------------------------------------------------------------makeAxiom tce lmap dm (x, mbT, v, def) = do-  insertAxiom v Nothing-  updateLMap x x v-  updateLMap (x{val = (F.symbol . showPpr . getName) v}) x v-  let (t, e) = makeAssumeType tce lmap dm x mbT v def-  return (v, t, e)+makeAxiom env tycEnv name lmap (x, mbT, v, def) +            = (v, t, e)+  where +    t       = Bare.qualifyTop env name (F.loc t0) t0 +    (t0, e) = makeAssumeType embs lmap dm x mbT v def+    embs    = Bare.tcEmbs       tycEnv +    dm      = Bare.tcDataConMap tycEnv   mkError :: LocSymbol -> String -> Error-mkError x str = ErrHMeas (sourcePosSrcSpan $ loc x) (pprint $ val x) (text str)+mkError x str = ErrHMeas (sourcePosSrcSpan $ loc x) (pprint $ val x) (PJ.text str)  makeAssumeType-  :: F.TCEmb TyCon -> LogicMap -> DataConMap -> LocSymbol -> Maybe SpecType-  -> Var -> CoreExpr-  -> (LocSpecType, AxiomEq)+  :: F.TCEmb Ghc.TyCon -> LogicMap -> DataConMap -> LocSymbol -> Maybe SpecType+  -> Ghc.Var -> Ghc.CoreExpr+  -> (LocSpecType, F.Equation) makeAssumeType tce lmap dm x mbT v def-  = (x {val = at `strengthenRes` F.subst su ref},  F.mkEquation (val x) xts le out)+  = (x {val = aty at `strengthenRes` F.subst su ref},  F.mkEquation (val x) xts (F.subst su le) out)   where-    t     = fromMaybe (ofType $ varType v) mbT-    out   = rTypeSort tce (ty_res tRep)-    at    = axiomType x mbT t-    tRep  = toRTypeRep at-    xArgs = F.EVar <$> [x | (x, t) <- zip (ty_binds tRep) (ty_args tRep), not (isClassType t)]+    t     = Mb.fromMaybe (ofType $ Ghc.varType v) mbT+    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               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) (text s)+    mkErr s    = ErrHMeas (sourcePosSrcSpan $ loc x) (pprint $ val x) (PJ.text s)     bbs        = filter isBoolBind xs     (xs, def') = grabBody (normalize def)     su         = F.mkSubst  $ zip (F.symbol     <$> xs) xArgs                            ++ zip (simplesymbol <$> xs) xArgs-    xts        = zipWith (\x t -> (F.symbol x, rTypeSort tce t)) xs ts-    ts         = filter (not . isClassType) (ty_args tRep)+    xts        = [(F.symbol x, rTypeSortExp tce t) | (x, t) <- aargs at] --- makeSMTAxiom :: LocSymbol -> [(Symbol, F.Sort)] -> F.Expr -> F.Sort -> AxiomEq--- makeSMTAxiom = F.mkEquation . val+rTypeSortExp :: F.TCEmb Ghc.TyCon -> SpecType -> F.Sort+rTypeSortExp tce = typeSort tce . Ghc.expandTypeSynonyms . toType -grabBody :: CoreExpr -> ([Id], CoreExpr)-grabBody (Lam x e)  = (x:xs, e') where (xs, e') = grabBody e-grabBody (Tick _ e) = grabBody e-grabBody e          = ([], e)+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) -isBoolBind :: Var -> Bool-isBoolBind v = isBool (ty_res $ toRTypeRep ((ofType $ varType v) :: RRType ()))+isBoolBind :: Ghc.Var -> Bool+isBoolBind v = isBool (ty_res $ toRTypeRep ((ofType $ Ghc.varType v) :: RRType ()))  strengthenRes :: SpecType -> F.Reft -> SpecType-strengthenRes t r = fromRTypeRep $ trep {ty_res = ty_res trep `strengthen` F.ofReft r }-  where-    trep = toRTypeRep t--updateLMap :: LocSymbol -> LocSymbol -> Var -> BareM ()-updateLMap x y vv-  | val x /= val y && isFun (varType vv)-  = insertLogicEnv ("UPDATELMAP: vv =" ++ show vv) x ys (F.eApps (F.EVar $ val y) (F.EVar <$> ys))-  | otherwise-  = return ()-  where-    nargs = dropWhile isClassType $ ty_args trep-    trep  = toRTypeRep ((ofType $ varType vv) :: RRType ())-    ys    = zipWith (\i _ -> F.symbol ("x" ++ show i)) [1..] nargs--    isFun (FunTy _ _)    = True-    isFun (ForAllTy _ t) = isFun t-    isFun  _             = False+strengthenRes t r = go t +  where +    go (RAllT a t)     = RAllT a $ go t +    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   class Subable a where-  subst :: (Var, CoreExpr) -> a -> a+  subst :: (Ghc.Var, Ghc.CoreExpr) -> a -> a -instance Subable Var where-  subst (x, ex) z | x == z, Var y <- ex = y-                  | otherwise           = z+instance Subable Ghc.Var where+  subst (x, ex) z +    | x == z, Ghc.Var y <- ex = y+    | otherwise           = z -instance Subable CoreExpr where-  subst (x, ex) (Var y)+instance Subable Ghc.CoreExpr where+  subst (x, ex) (Ghc.Var y)     | x == y    = ex-    | otherwise = Var y-  subst su (App f e)-    = App (subst su f) (subst su e)-  subst su (Lam x e)-    = Lam x (subst su e)-  subst su (Case e x t alts)-    = Case (subst su e) x t (subst su <$> alts)-  subst su (Let (Rec xes) e)-    = Let (Rec (mapSnd (subst su) <$> xes)) (subst su e)-  subst su (Let (NonRec x ex) e)-    = Let (NonRec x (subst su ex)) (subst su e)-  subst su (Cast e t)-    = Cast (subst su e) t-  subst su (Tick t e)-    = Tick t (subst su e)-  subst _ (Lit l)-    = Lit l-  subst _ (Coercion c)-    = Coercion c-  subst _ (Type t)-    = Type t+    | otherwise = Ghc.Var y+  subst su (Ghc.App f e)+    = Ghc.App (subst su f) (subst su e)+  subst su (Ghc.Lam x e)+    = Ghc.Lam x (subst su e)+  subst su (Ghc.Case e x t alts)+    = Ghc.Case (subst su e) x t (subst su <$> alts)+  subst su (Ghc.Let (Ghc.Rec xes) e)+    = Ghc.Let (Ghc.Rec (mapSnd (subst su) <$> xes)) (subst su e)+  subst su (Ghc.Let (Ghc.NonRec x ex) e)+    = Ghc.Let (Ghc.NonRec x (subst su ex)) (subst su e)+  subst su (Ghc.Cast e t)+    = Ghc.Cast (subst su e) t+  subst su (Ghc.Tick t e)+    = Ghc.Tick t (subst su e)+  subst _ e +    = e  -instance Subable CoreAlt where+instance Subable Ghc.CoreAlt where   subst su (c, xs, e) = (c, xs, subst su e) +data AxiomType = AT { aty :: SpecType, aargs :: [(F.Symbol, SpecType)], ares :: SpecType }+ -- | Specification for Haskell function-axiomType-  :: (TyConable c) => LocSymbol -> Maybe SpecType -> RType c tv RReft-  -> RType c tv RReft-axiomType s _mbT t = fromRTypeRep (tr {ty_res = res, ty_binds = xs})+axiomType :: LocSymbol -> SpecType -> AxiomType+axiomType s t = AT to (reverse xts) res     where-    res           = strengthen (ty_res tr) (singletonApp s ys)-    ys            = fst $ unzip $ dropWhile (isClassType . snd) xts-    xts           = safeZip "axiomBinds" xs (ty_args tr)-    xs            = zipWith unDummy bs [1..]-    tr            = toRTypeRep t-    bs            = ty_binds tr+    (to, (_,xts, Just res)) = runState (go t) (1,[], Nothing)+    go (RAllT a t) = RAllT a <$> go t+    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 +      (i,bs,res) <- get +      let x' = unDummy x i +      put (i+1, (x', tx):bs,res)+      t' <- go t +      return $ RFun x' tx t' r +    go t = do +      (i,bs,res) <- get +      let ys = reverse $ map fst bs+      let t' = strengthen t (singletonApp s ys)+      put (i, bs, Just t')+      return t'   unDummy :: F.Symbol -> Int -> F.Symbol unDummy x i
src/Language/Haskell/Liquid/Bare/Check.hs view
@@ -4,123 +4,223 @@ {-# LANGUAGE TupleSections       #-} {-# LANGUAGE RecordWildCards     #-} {-# LANGUAGE OverloadedStrings   #-}-module Language.Haskell.Liquid.Bare.Check (-    checkGhcSpec-  , checkTerminationExpr-  , checkTy++module Language.Haskell.Liquid.Bare.Check +  ( checkGhcSpec+  , checkBareSpec   ) where -import           BasicTypes-import           DataCon-import           Id-import           Name                                      (getSrcSpan)-import           Prelude                                   hiding (error)-import           TyCon-import           Var+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 qualified Data.List                                 as L import qualified Data.HashMap.Strict                       as M--import           Language.Fixpoint.Misc                    (applyNonNull, group, safeHead, mapSnd)+import qualified Data.HashSet                              as S+import           Data.Hashable+import qualified Language.Fixpoint.Misc                    as Misc   import           Language.Fixpoint.SortCheck               (checkSorted, checkSortedReftFull, checkSortFull)-import           Language.Fixpoint.Types                   hiding (panic, Error, R)--import           Language.Haskell.Liquid.GHC.Misc          (showPpr, fSrcSpan, sourcePosSrcSpan)+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)  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) --- import           Language.Haskell.Liquid.Bare.DataType     (dataConSpec)-import           Language.Haskell.Liquid.Bare.Env-import           Language.Haskell.Liquid.Bare.SymSort      (txRefSort)+----------------------------------------------------------------------------------------------+-- | 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)  -import           Debug.Trace (trace)+dataDeclFields :: DataDecl -> [F.LocSymbol]+dataDeclFields = filter (not . GM.isTmpSymbol . F.val) +               . Misc.hashNubWith val +               . concatMap dataCtorFields +               . tycDCons +dataCtorFields :: DataCtor -> [F.LocSymbol]+dataCtorFields c +  | isGadt c  = [] +  | otherwise = F.atLoc c <$> [ f | (f,_) <- dcFields c ] +isGadt :: DataCtor -> Bool +isGadt = isJust . dcResult ++checkUnique :: String -> [F.LocSymbol] -> [Error]+checkUnique _ = checkUnique' F.val GM.fSrcSpan ++checkUnique' :: (PPrint a, Eq a, Hashable a) +             => (t -> a) -> (t -> Ghc.SrcSpan) -> [t] -> [Error]+checkUnique' nameF locF ts = [ErrDupSpecs l (pprint n) ls | (n, ls@(l:_)) <- dups] +-- mkErr <$> dups+  where+    -- mkErr (n, ls@(l:_))    = ErrDupSpecs l (pprint n) ls+    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 ++checkDisjoint :: S.HashSet F.LocSymbol -> S.HashSet F.LocSymbol -> [Error]+checkDisjoint s1 s2 = checkUnique "disjoint" (S.toList s1 ++ S.toList s2) + ---------------------------------------------------------------------------------------------- -- | Checking GhcSpec ------------------------------------------------------------------------ ----------------------------------------------------------------------------------------------  checkGhcSpec :: [(ModName, Ms.BareSpec)]-             -> SEnv SortedReft+             -> GhcSrc+             -> F.SEnv F.SortedReft+             -> [CoreBind]              -> GhcSpec              -> Either [Error] GhcSpec -checkGhcSpec specs env sp =  applyNonNull (Right sp) Left errors+checkGhcSpec specs src env cbs sp = Misc.applyNonNull (Right sp) Left errors   where-    errors           =  -- mapMaybe (checkBind allowHO "constructor"  emb tcEnv env) (dcons      sp) ++-                        mapMaybe (checkBind allowHO "measure"      emb tcEnv env) (gsMeas       sp)-                     ++ condNull noPrune-                       (mapMaybe (checkBind allowHO "constructor"  emb tcEnv env) (gsCtors      sp))-                     ++ mapMaybe (checkBind allowHO "assumed type" emb tcEnv env) (gsAsmSigs    sp)-                     ++ mapMaybe (checkBind allowHO "class method" emb tcEnv env) (clsSigs      sp)-                     ++ mapMaybe (checkInv allowHO emb tcEnv env)                 (gsInvariants sp)-                     ++ checkIAl allowHO emb tcEnv env (gsIaliases   sp)+    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 sp)+                     ++ checkClassMeasures                                        (gsMeasures (gsData sp))+                     ++ checkClassMethods (gsCls src) (gsCMethods (gsVars sp)) (gsTySigs     (gsSig sp))                      ++ mapMaybe checkMismatch                     sigs-                     ++ checkDuplicate                             (gsTySigs sp)-                     ++ checkQualifiers env                        (gsQualifiers sp)-                     ++ checkDuplicate                             (gsAsmSigs sp)-                     ++ checkDupIntersect                          (gsTySigs sp) (gsAsmSigs sp)+                     ++ 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                      -- ++ _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 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)+     _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]-    emb              = gsTcEmbeds sp-    tcEnv            = gsTyconEnv sp-    ms               = gsMeasures sp+    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 sp ++ gsAsmSigs sp+    sigs             = gsTySigs (gsSig sp) ++ gsAsmSigs (gsSig sp) ++ gsCtors (gsData sp)     allowHO          = higherOrderFlag sp     noPrune          = not (pruneFlag sp)+    txCtors ts       = [(v, fmap (fmap (fmap (F.filterUnMatched temps))) t) | (v, t) <- ts]+    temps            = F.makeTemplates $ gsUnsorted $ gsData sp     -- env'             = L.foldl' (\e (x, s) -> insertSEnv x (RR s mempty) e) env wiredSortedSyms  -checkQualifiers :: SEnv SortedReft -> [Qualifier] -> [Error]-checkQualifiers = mapMaybe . checkQualifier -checkQualifier       :: SEnv SortedReft -> Qualifier -> Maybe Error-checkQualifier env q =  mkE <$> checkSortFull γ boolSort  (qBody q)-  where γ   = foldl (\e (x, s) -> insertSEnv x (RR s mempty) e) env (qParams q ++ wiredSortedSyms)-        mkE = ErrBadQual (sourcePosSrcSpan $ qPos q) (pprint $ qName q)  -checkSizeFun :: TCEmb TyCon -> SEnv SortedReft -> [(TyCon, TyConP)] -> [Error]+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 +    msg        = "Cannot resolve type hole `_`. Use explicit type instead."+++--------------------------------------------------------------------------------+checkTySigs :: Bool -> [CoreBind] -> F.TCEmb TyCon -> Bare.TyConMap -> F.SEnv F.SortedReft +            -> GhcSpecSig+            -> [Error]+--------------------------------------------------------------------------------+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+    locTm          = M.fromList locTs+    (locTs, topTs) = Bare.partitionLocalBinds vtes +    vtes           = [ (x, (t, es)) | (x, t) <- gsTySigs sig, let es = M.lookup x vExprs]+    vExprs         = M.fromList  [ (x, es) | (x, _, es) <- gsTexprs sig ] ++    checkVisitor  :: CoreVisitor (F.SEnv F.SortedReft) [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 +                       }  +    vSort            = Bare.varSortedReft emb+    errs env v       = case M.lookup v locTm of +                         Nothing -> [] +                         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 ++_checkQualifiers :: F.SEnv F.SortedReft -> [F.Qualifier] -> [Error]+_checkQualifiers = mapMaybe . checkQualifier++checkQualifier       :: F.SEnv F.SortedReft -> F.Qualifier -> Maybe Error+checkQualifier env q =  mkE <$> checkSortFull (F.srcSpan q) γ F.boolSort  (F.qBody q)+  where +    γ                = L.foldl' (\e (x, s) -> F.insertSEnv x (F.RR s mempty) e) env (F.qualBinds q ++ wiredSortedSyms)+    mkE              = ErrBadQual (GM.fSrcSpan q) (pprint $ F.qName q)++checkSizeFun :: F.TCEmb TyCon -> F.SEnv F.SortedReft -> [TyConP] -> [Error] checkSizeFun emb env tys = mkError <$> mapMaybe go tys   where-    mkError ((f, tc, tcp), msg)  = ErrTyCon (sourcePosSrcSpan $ ty_loc tcp)-                                   (text "Size function" <+> pprint (f x) <+> text "should have type int." $+$   msg)-                                   (pprint tc)-    go (tc, tcp)      = case sizeFun tcp of-                          Nothing  -> Nothing-                          Just f   -> checkWFSize (szFun f) tc tcp+    mkError ((f, tcp), msg)  = ErrTyCon (GM.sourcePosSrcSpan $ tcpLoc tcp)+                                 (text "Size function" <+> pprint (f x) <+> text "should have type int." $+$   msg)+                                 (pprint (tcpCon tcp))+    go tcp = case tcpSizeFun tcp of+               Nothing  -> Nothing+               Just f   -> checkWFSize (szFun f) tcp -    checkWFSize f tc tcp = ((f, tc, tcp),) <$> checkSortFull (insertSEnv x (mkTySort tc) env) intSort (f x)-    x                    = "x" :: Symbol-    mkTySort tc          = rTypeSortedReft emb (ofType $ TyConApp tc (TyVarTy <$> tyConTyVars tc) :: RRType ())+    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 ()) -_checkRefinedClasses :: [RClass (Located BareType)] -> [RInstance (Located BareType)] -> [Error]+_checkRefinedClasses :: [RClass LocBareType] -> [RInstance LocBareType] -> [Error] _checkRefinedClasses definitions instances   = mkError <$> duplicates   where@@ -132,20 +232,19 @@           conflicts -> Just (cls, conflicts)     findConflicts cls       = filter ((== cls) . riclass) instances-     mkError (cls, conflicts)-      = ErrRClass (sourcePosSrcSpan $ loc $ btc_tc cls)+      = ErrRClass (GM.sourcePosSrcSpan $ loc $ btc_tc cls)                   (pprint cls) (ofConflict <$> conflicts)     ofConflict-      = sourcePosSrcSpan . loc . btc_tc . riclass &&& pprint . ritype+      = GM.sourcePosSrcSpan . loc . btc_tc . riclass &&& pprint . ritype  _checkDuplicateFieldNames :: [(DataCon, DataConP)]  -> [Error] _checkDuplicateFieldNames = mapMaybe go   where-    go (d, dts)          = checkNoDups (dc_loc dts) d (fst <$> tyArgs dts)+    go (d, dts)          = checkNoDups (dcpLoc dts) d (fst <$> dcpTyArgs dts)     checkNoDups l d xs   = mkErr l d <$> _firstDuplicate xs -    mkErr l d x = ErrBadData (sourcePosSrcSpan l)+    mkErr l d x = ErrBadData (GM.sourcePosSrcSpan l)                              (pprint d)                              (text "Multiple declarations of record selector" <+> pprintSymbol x) @@ -156,55 +255,57 @@                 | otherwise = go (x:xs)     go _                    = Nothing -checkInv :: Bool -> TCEmb TyCon -> TCEnv -> SEnv SortedReft -> (Maybe Var, Located SpecType) -> Maybe Error+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   where-    err              = ErrInvt (sourcePosSrcSpan $ loc t) (val t)+    err              = ErrInvt (GM.sourcePosSrcSpan $ loc t) (val t) -checkIAl :: Bool -> TCEmb TyCon -> TCEnv -> SEnv SortedReft -> [(Located SpecType, Located SpecType)] -> [Error]+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  checkIAlOne :: Bool-            -> TCEmb TyCon-            -> TCEnv-            -> SEnv SortedReft-            -> (Located SpecType, Located SpecType)+            -> 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])   where     tcheck t = checkTy allowHO (err t) emb tcEnv env t-    err    t = ErrIAl (sourcePosSrcSpan $ loc t) (val 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-    errmis   = ErrIAlMis (sourcePosSrcSpan $ loc t1) (val t1) (val t2) emsg+    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 -> [RTAlias s a] -> [Error]+checkRTAliases :: String -> t -> [Located (RTAlias s a)] -> [Error] checkRTAliases msg _ as = err1s   where-    err1s                  = checkDuplicateRTAlias msg as+    err1s               = checkDuplicateRTAlias msg as -checkBind :: (PPrint v) => Bool -> String -> TCEmb TyCon -> TCEnv -> SEnv SortedReft -> (v, Located SpecType) -> Maybe Error+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   where-    msg                      = ErrTySpec (fSrcSpan t) (text s <+> pprint v) (val t)+    msg                      = ErrTySpec (GM.fSrcSpan t) (Just s) (pprint v) (val t) -checkTerminationExpr :: (Eq v, PPrint v) => TCEmb TyCon -> SEnv SortedReft -> (v, LocSpecType, [Located Expr]) -> Maybe Error++checkTerminationExpr :: (Eq v, PPrint v) => F.TCEmb TyCon -> F.SEnv F.SortedReft -> (v, LocSpecType, [F.Located F.Expr]) -> Maybe Error checkTerminationExpr emb env (v, Loc l _ t, les)-            = (mkErr <$> go es) <|> (mkErr' <$> go' es)+            = (mkErr "ill-sorted" <$> go les) <|> (mkErr "non-numeric" <$> go' les)   where-    es      = val <$> les-    mkErr   = uncurry (ErrTermSpec (sourcePosSrcSpan l) (pprint v) (text "ill-sorted" ))-    mkErr'  = uncurry (ErrTermSpec (sourcePosSrcSpan l) (pprint v) (text "non-numeric"))-    go      = foldl (\err e -> err <|> (e,) <$> checkSorted env' e)           Nothing-    go'     = foldl (\err e -> err <|> (e,) <$> checkSorted env' (cmpZero e)) Nothing-    -- env'    = foldl (\e (x, s) -> insertSEnv x s e) env'' wiredSortedSyms-    env'   = sr_sort <$> foldl (\e (x,s) -> insertSEnv x s e) env xts+    -- es      = val <$> les+    mkErr k = uncurry (\ e d -> ErrTermSpec (GM.sourcePosSrcSpan l) (pprint v) k e t d)+    -- 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      = L.foldl' (\err e -> err <|> (val e,) <$> checkSorted (F.srcSpan e) env' (val e))     Nothing+    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 @@ -212,77 +313,92 @@     mkClass (x, t)                         = [(x, rSort t)]      rSort   = rTypeSortedReft emb-    cmpZero = PAtom Le $ expr (0 :: Int) -- zero+    cmpZero e = F.PAtom F.Le (F.expr (0 :: Int)) (val e) -checkTy :: Bool -> (Doc -> Error) -> TCEmb TyCon -> TCEnv -> SEnv SortedReft -> Located SpecType -> Maybe Error-checkTy allowHO mkE emb tcEnv env t = mkE <$> checkRType allowHO emb env (val $ txRefSort tcEnv emb t)+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)   where     _msg =  "CHECKTY: " ++ showpp (val t) -checkDupIntersect     :: [(Var, Located SpecType)] -> [(Var, Located SpecType)] -> [Error]+checkDupIntersect     :: [(Var, LocSpecType)] -> [(Var, LocSpecType)] -> [Error] checkDupIntersect xts asmSigs = concatMap mkWrn {- trace msg -} dups   where-    mkWrn (x, t)     = pprWrn x (sourcePosSrcSpan $ loc t)+    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 ++ " : " ++ showPpr l) []+    pprWrn v l       = trace ("WARNING: Assume Overwrites Specifications for "++ show v ++ " : " ++ GM.showPpr l) []     -- msg              = "CHECKDUPINTERSECT:" ++ msg1 ++ msg2     -- msg1             = "\nCheckd-SIGS:\n" ++ showpp (M.fromList xts)     -- msg2             = "\nAssume-SIGS:\n" ++ showpp (M.fromList asmSigs) -checkDuplicate        :: [(Var, Located SpecType)] -> [Error]-checkDuplicate xts = mkErr <$> dups-  where-    mkErr (x, ts) = ErrDupSpecs (getSrcSpan x) (pprint x) (sourcePosSrcSpan . loc <$> ts)-    dups          = [z | z@(_, _:_:_) <- M.toList $ group xts ] -checkDuplicateRTAlias :: String -> [RTAlias s a] -> [Error]+checkDuplicate :: [(Var, LocSpecType)] -> [Error]+checkDuplicate = 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' +    ms   = F.notracepp "MS"  $ concatMap (classMethods . is_cls) clsis+    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   where-    mkErr xs@(x:_)          = ErrDupAlias (sourcePosSrcSpan $ rtPos x)+    mkErr xs@(x:_)          = ErrDupAlias (GM.fSrcSpan x)                                           (text s)-                                          (pprint $ rtName x)-                                          (sourcePosSrcSpan . rtPos <$> xs)+                                          (pprint . rtName . val $ x)+                                          (GM.fSrcSpan <$> xs)     mkErr []                = panic Nothing "mkError: called on empty list"-    dups                    = [z | z@(_:_:_) <- L.groupBy ((==) `on` rtName) tas]+    dups                    = [z | z@(_:_:_) <- L.groupBy ((==) `on` (rtName . val)) tas]  -checkMismatch        :: (Var, Located SpecType) -> Maybe Error+checkMismatch        :: (Var, LocSpecType) -> Maybe Error checkMismatch (x, t) = if ok then Nothing else Just err   where-    ok               = tyCompat x (val t)-    err              = errTypeMismatch x t+    ok               = tyCompat x (val t')+    err              = errTypeMismatch x t'+    t'               = dropImplicits <$> t  tyCompat :: Var -> RType RTyCon RTyVar r -> Bool-tyCompat x t         = lhs == rhs+tyCompat x t         = F.notracepp msg (lqT == hsT)   where-    lhs :: RSort     = toRSort t-    rhs :: RSort     = ofType $ varType x+    lqT :: RSort     = toRSort t+    hsT :: RSort     = ofType (varType x)+    msg              = "TY-COMPAT: " ++ GM.showPpr x ++ ": hs = " ++ F.showpp hsT ++ " :lq = " ++ F.showpp lqT  errTypeMismatch     :: Var -> Located SpecType -> Error-errTypeMismatch x t = ErrMismatch lqSp (pprint x) (text "Checked")  d1 d2 hsSp+errTypeMismatch x t = ErrMismatch lqSp (pprint x) (text "Checked")  d1 d2 Nothing hsSp   where     d1              = pprint $ varType x     d2              = pprint $ toType $ val t-    lqSp            = sourcePosSrcSpan $ loc t+    lqSp            = GM.fSrcSpan t     hsSp            = getSrcSpan x  ------------------------------------------------------------------------------------------------ -- | @checkRType@ determines if a type is malformed in a given environment --------------------- -------------------------------------------------------------------------------------------------checkRType :: Bool -> TCEmb TyCon -> SEnv SortedReft -> SpecType -> Maybe Doc+checkRType :: Bool -> F.TCEmb TyCon -> F.SEnv F.SortedReft -> LocSpecType -> Maybe Doc -------------------------------------------------------------------------------------------------checkRType allowHO emb env t+checkRType allowHO emb env lt   =   checkAppTys t   <|> checkAbstractRefs t   <|> efoldReft farg cb (tyToBind emb) (rTypeSortedReft emb) f insertPEnv env Nothing t   where+    t                  = val lt     cb c ts            = classBinds emb (rRCls c ts)     farg _ t           = allowHO || isBase t  -- NOTE: this check should be the same as the one in addCGEnv-    f env me r err     = err <|> checkReft env emb me r-    insertPEnv p γ     = insertsSEnv γ (mapSnd (rTypeSortedReft emb) <$> pbinds p)+    f env me r err     = err <|> checkReft (F.srcSpan lt) env emb me r+    insertPEnv p γ     = insertsSEnv γ (Misc.mapSnd (rTypeSortedReft emb) <$> pbinds p)     pbinds p           = (pname p, pvarRType p :: RSort) : [(x, tx) | (tx, x, _) <- pargs p] -tyToBind :: TCEmb TyCon -> RTVar RTyVar RSort  -> [(Symbol, SortedReft)]+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)]@@ -296,7 +412,8 @@     go (RAllS _ t)      = go t     go (RApp rtc ts _ _)       = checkTcArity rtc (length ts) <|>-        foldl (\merr t -> merr <|> go t) Nothing ts+        L.foldl' (\merr t -> merr <|> go t) Nothing ts+    go (RImpF _ t1 t2 _)= go t1 <|> go t2     go (RFun _ t1 t2 _) = go t1 <|> go t2     go (RVar _ _)       = Nothing     go (RAllE _ t1 t2)  = go t1 <|> go t2@@ -338,7 +455,7 @@ -}  checkAbstractRefs-  :: (PPrint t, Reftable t, SubsTy RTyVar RSort t, Reftable (RTProp RTyCon RTyVar (UReft t))) =>+  :: (PPrint t, F.Reftable t, SubsTy RTyVar RSort t, F.Reftable (RTProp RTyCon RTyVar (UReft t))) =>      RType RTyCon RTyVar (UReft t) -> Maybe Doc checkAbstractRefs t = go t   where@@ -348,6 +465,7 @@     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     go t@(RVar _ r)       = check (toRSort t :: RSort) r     go (RAllE _ t1 t2)    = go t1 <|> go t2@@ -357,7 +475,7 @@     go (RExprArg _)       = Nothing     go (RHole _)          = Nothing -    go' c rs = foldl (\acc (x, y) -> acc <|> checkOne' x y) Nothing (zip rs (rTyConPVs c))+    go' c rs = L.foldl' (\acc (x, y) -> acc <|> checkOne' x y) Nothing (zip rs (rTyConPVs c))      checkOne' (RProp xs (RHole _)) p       | or [s1 /= s2 | ((_, s1), (s2, _, _)) <- zip xs (pargs p)]@@ -377,9 +495,9 @@       = go t  -    efold f = foldl (\acc x -> acc <|> f x) Nothing+    efold f = L.foldl' (\acc x -> acc <|> f x) Nothing -    check s (MkUReft _ (Pr ps) _) = 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"@@ -388,24 +506,22 @@                        <+> text "is applied to"                        <+> pprint s                        <+> text "\n\t In" <+> pprint p-                 | or [x == y | (_, x, EVar y) <- pargs p]-                 = Just $ text "Missing arguments on " <+> pprint p                  | otherwise                  = Nothing      mkPEnv (RAllT _ t) = mkPEnv t     mkPEnv (RAllP p t) = p:mkPEnv t     mkPEnv _           = []-    pvType' p          = safeHead (showpp p ++ " not in env of " ++ showpp t) [pvType q | q <- penv, pname p == pname q]+    pvType' p          = Misc.safeHead (showpp p ++ " not in env of " ++ showpp t) [pvType q | q <- penv, pname p == pname q]  -checkReft                    :: (PPrint r, Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, Reftable (RTProp RTyCon RTyVar (UReft r)))-                             => SEnv SortedReft -> TCEmb TyCon -> Maybe (RRType (UReft r)) -> UReft r -> Maybe Doc-checkReft _   _   Nothing _  = Nothing -- TODO:RPropP/Ref case, not sure how to check these yet.-checkReft env emb (Just t) _ = (\z -> dr $+$ z) <$> checkSortedReftFull env r+checkReft                    :: (PPrint r, F.Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, F.Reftable (RTProp RTyCon RTyVar (UReft r)))+                             => F.SrcSpan -> F.SEnv F.SortedReft -> F.TCEmb TyCon -> Maybe (RRType (UReft r)) -> UReft r -> Maybe Doc+checkReft _ _   _   Nothing _   = Nothing -- TODO:RPropP/Ref case, not sure how to check these yet.+checkReft sp env emb (Just t) _ = (\z -> dr $+$ z) <$> checkSortedReftFull sp env r   where-    r                        = rTypeSortedReft emb t-    dr                       = text "Sort Error in Refinement:" <+> pprint r+    r                           = rTypeSortedReft emb t+    dr                          = text "Sort Error in Refinement:" <+> pprint r  -- DONT DELETE the below till we've added pred-checking as well -- checkReft env emb (Just t) _ = checkSortedReft env xs (rTypeSortedReft emb t)@@ -421,33 +537,32 @@ --------------------------------------------------------------------------------------------------- -- | @checkMeasures@ determines if a measure definition is wellformed ----------------------------- ----------------------------------------------------------------------------------------------------checkMeasures :: TCEmb TyCon -> SEnv SortedReft -> [Measure SpecType DataCon] -> [Error]+checkMeasures :: F.TCEmb TyCon -> F.SEnv F.SortedReft -> [Measure SpecType DataCon] -> [Error] --------------------------------------------------------------------------------------------------- checkMeasures emb env = concatMap (checkMeasure emb env) -checkMeasure :: TCEmb TyCon -> SEnv SortedReft -> Measure SpecType DataCon -> [Error]-checkMeasure emb γ (M name@(Loc src _ n) sort body)-  = [txerror e | Just e <- checkMBody γ emb name sort <$> body]+checkMeasure :: F.TCEmb TyCon -> F.SEnv F.SortedReft -> Measure SpecType DataCon -> [Error]+checkMeasure emb γ (M name@(Loc src _ n) sort body _ _)+  = [ txerror e | Just e <- checkMBody γ emb name sort <$> body ]   where-    txerror = ErrMeas (sourcePosSrcSpan src) (pprint n)+    txerror = ErrMeas (GM.sourcePosSrcSpan src) (pprint n) -checkMBody :: (PPrint r,Reftable r,SubsTy RTyVar RSort r, Reftable (RTProp RTyCon RTyVar r))-           => SEnv SortedReft-           -> TCEmb TyCon+checkMBody :: (PPrint r, F.Reftable r,SubsTy RTyVar RSort r, F.Reftable (RTProp RTyCon RTyVar r))+           => F.SEnv F.SortedReft+           -> F.TCEmb TyCon            -> t            -> SpecType            -> Def (RRType r) DataCon            -> Maybe Doc-checkMBody γ emb _ sort (Def _ as c _ bs body) = checkMBody' emb sort' γ' body+checkMBody γ emb _ sort (Def m c _ bs body) = checkMBody' emb sort γ' sp body   where-    γ'    = L.foldl' (\γ (x, t) -> insertSEnv x t γ) γ (ats ++ xts)-    ats   = mapSnd (rTypeSortedReft emb) <$> as+    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     trep  = toRTypeRep ct     su    = checkMBodyUnify (ty_res trep) (last txs)     txs   = snd4 $ bkArrowDeep sort     ct    = ofType $ dataConUserType c :: SpecType-    sort' = dropNArgs (length as) sort  checkMBodyUnify   :: RType t t2 t1 -> RType c tv r -> [(t2,RType c tv (),RType c tv r)]@@ -457,18 +572,18 @@     go t@(RApp {}) t'@(RApp {}) = concat $ zipWith go (rt_args t) (rt_args t')     go _ _                      = [] -checkMBody' :: (PPrint r,Reftable r,SubsTy RTyVar RSort r, Reftable (RTProp RTyCon RTyVar r))-            => TCEmb TyCon+checkMBody' :: (PPrint r, F.Reftable r,SubsTy RTyVar RSort r, F.Reftable (RTProp RTyCon RTyVar r))+            => F.TCEmb TyCon             -> RType RTyCon RTyVar r-            -> SEnv SortedReft+            -> F.SEnv F.SortedReft+            -> F.SrcSpan              -> Body             -> Maybe Doc-checkMBody' emb sort γ body = case body of-    E e   -> checkSortFull γ (rTypeSort emb sort') e-    P p   -> checkSortFull γ boolSort  p-    R s p -> checkSortFull (insertSEnv s sty γ) boolSort p+checkMBody' emb sort γ sp body = case body of+    E e   -> checkSortFull sp γ (rTypeSort emb sort') e+    P p   -> checkSortFull sp γ F.boolSort  p+    R s p -> checkSortFull sp (F.insertSEnv s sty γ) F.boolSort p   where-    -- psort = FApp propFTyCon []     sty   = rTypeSortedReft emb sort'     sort' = dropNArgs 1 sort @@ -484,14 +599,17 @@ checkClassMeasures :: [Measure SpecType DataCon] -> [Error] checkClassMeasures ms = mapMaybe checkOne byTyCon   where-  byName = L.groupBy ((==) `on` (val.name)) ms+  byName = L.groupBy ((==) `on` (val . msName)) ms -  byTyCon = concatMap (L.groupBy ((==) `on` (dataConTyCon . ctor . head . eqns)))+  byTyCon = concatMap (L.groupBy ((==) `on` (dataConTyCon . ctor . head . msEqns)))                       byName    checkOne []     = impossible Nothing "checkClassMeasures.checkOne on empty measure group"   checkOne [_]    = Nothing-  checkOne (m:ms) = Just (ErrDupIMeas (sourcePosSrcSpan (loc (name m)))-                                      (pprint (val (name m)))-                                      (pprint ((dataConTyCon . ctor . head . eqns) m))-                                      (map (sourcePosSrcSpan.loc.name) (m:ms)))+  checkOne (m:ms) = Just (ErrDupIMeas (GM.fSrcSpan (msName m))+                                      (pprint (val (msName m)))+                                      (pprint ((dataConTyCon . ctor . head . msEqns) m))+                                      (GM.fSrcSpan <$> (m:ms)))+++
+ src/Language/Haskell/Liquid/Bare/Class.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ParallelListComp  #-}+{-# LANGUAGE TupleSections     #-}+{-# LANGUAGE BangPatterns      #-}++module Language.Haskell.Liquid.Bare.Class +  ( makeClasses+  , makeCLaws+  , makeSpecDictionaries+  , makeDefaultMethods+  , makeMethodTypes+  ) +  where++import           Data.Bifunctor +import qualified Data.Maybe                                 as Mb+import qualified Data.List                                  as L+import qualified Data.HashMap.Strict                        as M++import qualified Language.Fixpoint.Misc                     as Misc+import qualified Language.Fixpoint.Types                    as F++import           Language.Haskell.Liquid.Types.Dictionaries+import qualified Language.Haskell.Liquid.GHC.Misc           as GM+import qualified Language.Haskell.Liquid.GHC.API            as Ghc+import           Language.Haskell.Liquid.Misc+import           Language.Haskell.Liquid.Types.RefType+import           Language.Haskell.Liquid.Types              hiding (freeTyVars)++import qualified Language.Haskell.Liquid.Measure            as Ms+import           Language.Haskell.Liquid.Bare.Types         as Bare +import           Language.Haskell.Liquid.Bare.Resolve       as Bare+import           Language.Haskell.Liquid.Bare.Expand        as Bare++++-------------------------------------------------------------------------------+makeMethodTypes :: DEnv Ghc.Var LocSpecType -> [DataConP] -> [Ghc.CoreBind] -> [(Ghc.Var, MethodType LocSpecType)]+-------------------------------------------------------------------------------+makeMethodTypes (DEnv m) cls cbs +  = [(x, MT (addCC x . fromRISig <$> methodType d x m) (addCC x <$> classType (splitDictionary e) x)) | (d,e) <- ds, x <- grepMethods e]+    where +      grepMethods = filter GM.isMethod . freeVars mempty+      ds = filter (GM.isDictionary . fst) (concatMap unRec cbs)+      unRec (Ghc.Rec xes) = xes+      unRec (Ghc.NonRec x e) = [(x,e)]++      classType Nothing _ = Nothing+      classType (Just (d, ts, _)) x = +        case filter ((==d) . Ghc.dataConWorkId . dcpCon) cls of +          (di:_) -> fmap ((dcpLoc di `F.atLoc`) . subst (zip (dcpFreeTyVars di) ts)) $ L.lookup (mkSymbol x) (dcpTyArgs di)+          _      -> Nothing ++      methodType d x m = ihastype (M.lookup d m) x++      ihastype Nothing _    = Nothing+      ihastype (Just xts) x = M.lookup (mkSymbol x) xts++      mkSymbol x = F.dropSym 2 $ GM.simplesymbol x++      subst [] t = t +      subst ((a,ta):su) t = 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)} +  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 ++splitDictionary :: Ghc.CoreExpr -> Maybe (Ghc.Var, [Ghc.Type], [Ghc.Var])+splitDictionary = go [] [] +  where +    go ts xs (Ghc.App e (Ghc.Tick _ a)) = go ts xs (Ghc.App e a)+    go ts xs (Ghc.App e (Ghc.Type t))   = go (t:ts) xs e +    go ts xs (Ghc.App e (Ghc.Var x))    = go ts (x:xs) e +    go ts xs (Ghc.Tick _ t) = go ts xs t +    go ts xs (Ghc.Var x) = Just (x, reverse ts, reverse xs)+    go _ _ _ = Nothing+++-------------------------------------------------------------------------------+makeCLaws :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.ModSpecs +            -> [(Ghc.Class, [(ModName, Ghc.Var, LocSpecType)])]+-------------------------------------------------------------------------------+makeCLaws env sigEnv myName specs = +  [ (Mb.fromMaybe (msg tc) (Ghc.tyConClass_maybe tc), snd cls) | (name, spec) <- M.toList specs+          , cls          <- Ms.claws spec+          , tc           <- Mb.maybeToList (classTc cls) +          , cls          <- Mb.maybeToList (mkClass env sigEnv myName name cls tc)+    ]+  where+    msg tc  = error ("Not a type class: " ++ F.showpp tc)+    classTc = Bare.maybeResolveSym env myName "makeClass" . btc_tc . rcName ++++-------------------------------------------------------------------------------+makeClasses :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.ModSpecs +            -> ([DataConP], [(ModName, Ghc.Var, LocSpecType)])+-------------------------------------------------------------------------------+makeClasses env sigEnv myName specs = +  second mconcat . unzip +  $ [ cls | (name, spec) <- M.toList specs+          , cls          <- Ms.classes spec+          , tc           <- Mb.maybeToList (classTc cls) +          , cls          <- Mb.maybeToList (mkClass env sigEnv myName name cls tc)+    ]+  where+    classTc = Bare.maybeResolveSym env myName "makeClass" . btc_tc . rcName ++mkClass :: Bare.Env -> Bare.SigEnv -> ModName -> ModName -> RClass LocBareType -> Ghc.TyCon +        -> Maybe (DataConP, [(ModName, Ghc.Var, LocSpecType)])+mkClass env sigEnv _myName name (RClass cc ss as ms) +  = Bare.failMaybe env name +  . mkClassE env sigEnv _myName name (RClass cc ss as ms) ++mkClassE :: Bare.Env -> Bare.SigEnv -> ModName -> ModName -> RClass LocBareType -> Ghc.TyCon +         -> Either UserError (DataConP, [(ModName, Ghc.Var, LocSpecType)])+mkClassE env sigEnv _myName name (RClass cc ss as ms) tc = do +    ss'    <- mapM (mkConstr   env sigEnv name) ss +    meths  <- mapM (makeMethod env sigEnv name) ms'+    let vts = [ (m, v, t) | (m, kv, t) <- meths, v <- Mb.maybeToList (plugSrc kv) ]+    let sts = [(val s, unClass $ val t) | (s, _) <- ms | (_, _, t) <- meths]+    let dcp = DataConP l dc αs [] [] (val <$> ss') (reverse sts) t False (F.symbol name) l'+    return  $ F.notracepp msg (dcp, vts)+  where+    c      = btc_tc cc+    l      = loc  c+    l'     = locE c+    msg    = "MKCLASS: " ++ F.showpp (cc, as, αs) +    (dc:_) = Ghc.tyConDataCons tc+    αs     = bareRTyVar <$> as+    as'    = [rVar $ GM.symbolTyVar $ F.symbol a | a <- as ]+    ms'    = [ (s, rFun "" (RApp cc (flip RVar mempty <$> as) [] mempty) <$> t) | (s, t) <- ms]+    t      = rCls tc as'++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++   --FIXME: cleanup this code+unClass :: SpecType -> SpecType +unClass = snd . bkClass . fourth4 . bkUniv++makeMethod :: Bare.Env -> Bare.SigEnv -> ModName -> (LocSymbol, LocBareType) +         -> Either UserError (ModName, PlugTV Ghc.Var, LocSpecType)+makeMethod env sigEnv name (lx, bt) = (name, mbV,) <$> Bare.cookSpecTypeE env sigEnv name mbV bt+  where +    mbV = case Bare.maybeResolveSym env name "makeMethod" lx of +            Just v  -> Bare.LqTV v +            Nothing -> Bare.GenTV ++-------------------------------------------------------------------------------+makeSpecDictionaries :: Bare.Env -> Bare.SigEnv -> ModSpecs -> DEnv Ghc.Var LocSpecType +-------------------------------------------------------------------------------+makeSpecDictionaries env sigEnv specs+  = dfromList +  . concat +  . fmap (makeSpecDictionary env sigEnv) +  $ M.toList specs++makeSpecDictionary :: Bare.Env -> Bare.SigEnv -> (ModName, Ms.BareSpec)+                   -> [(Ghc.Var, M.HashMap F.Symbol (RISig LocSpecType))]+makeSpecDictionary env sigEnv (name, spec)+  = Mb.catMaybes +  . resolveDictionaries env name +  . fmap (makeSpecDictionaryOne env sigEnv name) +  . Ms.rinstance +  $ spec++makeSpecDictionaryOne :: Bare.Env -> Bare.SigEnv -> ModName +                      -> RInstance LocBareType +                      -> (F.Symbol, M.HashMap F.Symbol (RISig LocSpecType))+makeSpecDictionaryOne env sigEnv name (RI x t xts)+         = makeDictionary $ RI x (mkTy <$> t) [(x, mkLSpecIType t) | (x, t) <- xts ] +  where+    mkTy :: LocBareType -> LocSpecType+    mkTy = Bare.cookSpecType env sigEnv name Bare.GenTV++    mkLSpecIType :: RISig LocBareType -> RISig LocSpecType+    mkLSpecIType t = fmap mkTy t++resolveDictionaries :: Bare.Env -> ModName -> [(F.Symbol, M.HashMap F.Symbol (RISig LocSpecType))] +                    -> [Maybe (Ghc.Var, M.HashMap F.Symbol (RISig LocSpecType))]+resolveDictionaries env name = fmap lookupVar +                             . concat +                             . fmap addInstIndex +                             . Misc.groupList +  where+    lookupVar (x, inst)      = (, inst) <$> Bare.maybeResolveSym env name "resolveDict" (F.dummyLoc x)++-- formerly, addIndex+-- GHC internal postfixed same name dictionaries with ints+addInstIndex            :: (F.Symbol, [a]) -> [(F.Symbol, a)]+addInstIndex (x, is) = go 0 (reverse is)+  where +    go _ []          = []+    go _ [i]         = [(x, i)]+    go j (i:is)      = (F.symbol (F.symbolString x ++ show j),i) : go (j+1) is++----------------------------------------------------------------------------------+makeDefaultMethods :: Bare.Env -> [(ModName, Ghc.Var, LocSpecType)] +                   -> [(ModName, Ghc.Var, LocSpecType)]+----------------------------------------------------------------------------------+makeDefaultMethods env mts = [ (mname, dm, t) +                                 | (mname, m, t) <- mts+                                 , dm            <- lookupDefaultVar env mname m ]  ++lookupDefaultVar :: Bare.Env -> ModName -> Ghc.Var -> [Ghc.Var] +lookupDefaultVar env name v = Mb.maybeToList +                            . Bare.maybeResolveSym env name "default-method" +                            $ dmSym+  where +    dmSym                   = F.atLoc v (GM.qualifySymbol mSym dnSym)+    dnSym                   = F.mappendSym "$dm" nSym+    (mSym, nSym)            = GM.splitModuleName (F.symbol v) 
src/Language/Haskell/Liquid/Bare/DataType.hs view
@@ -3,50 +3,42 @@ {-# LANGUAGE TupleSections     #-}  module Language.Haskell.Liquid.Bare.DataType-  ( -- * Constructors-    makeDataDecls+  ( dataConMap++  -- * Names for accessing Data Constuctors +  , makeDataConChecker+  , makeDataConSelector +  , addClassEmbeds++  -- * Constructors+  , makeDataDecls   , makeConTypes-  , makeTyConEmbeds   , makeRecordSelectorSigs   , meetDataConSpec-  , addClassEmbeds--  , DataConMap-  , dataConMap+  -- , makeTyConEmbeds -  -- * Tests-  -- , isPropDecl-  -- , qualifyDataDecl   ) where -import           TysWiredIn (listTyCon)-import           TysPrim-import           DataCon-import           Name                                   (getSrcSpan) import           Prelude                                hiding (error)-import           SrcLoc                                 (SrcSpan)-import qualified Type-import           Text.Parsec-import           TyCon                                  hiding (tyConName)-import           Var-import           InstEnv-import           Class-import           Data.Maybe-import           Language.Haskell.Liquid.GHC.TypeRep -import           Control.Monad                          (forM_, when) -- , (>=>))-import           Control.Monad.State                    (gets)+-- import           Text.Parsec+-- import           Var+-- import           Data.Maybe+-- import           Language.Haskell.Liquid.GHC.TypeRep+ import qualified Control.Exception                      as Ex import qualified Data.List                              as L import qualified Data.HashMap.Strict                    as M import qualified Data.HashSet                           as S+import qualified Data.Maybe                             as Mb  -import qualified Language.Fixpoint.Types.Visitor        as V+-- import qualified Language.Fixpoint.Types.Visitor        as V import qualified Language.Fixpoint.Types                as F-import qualified Language.Haskell.Liquid.GHC.Misc       as GM -- (sourcePosSrcSpan, sourcePos2SrcSpan, symbolTyVar)---import           Language.Haskell.Liquid.Types.PredType (dataConWorkRep, dataConPSpecType)+import qualified Language.Haskell.Liquid.GHC.Misc       as GM +import qualified Language.Haskell.Liquid.GHC.API        as Ghc +import           Language.Haskell.Liquid.Types.PredType (dataConPSpecType) import qualified Language.Haskell.Liquid.Types.RefType  as RT-import           Language.Haskell.Liquid.Types+import           Language.Haskell.Liquid.Types.Types import           Language.Haskell.Liquid.Types.Meet import qualified Language.Fixpoint.Misc                 as Misc import qualified Language.Haskell.Liquid.Misc           as Misc@@ -54,19 +46,69 @@ import           Language.Haskell.Liquid.WiredIn  import qualified Language.Haskell.Liquid.Measure        as Ms+import qualified Language.Haskell.Liquid.Bare.Types     as Bare  +import qualified Language.Haskell.Liquid.Bare.Resolve   as Bare  -import qualified Language.Haskell.Liquid.Bare.Misc      as GM-import           Language.Haskell.Liquid.Bare.Env-import           Language.Haskell.Liquid.Bare.Lookup-import           Language.Haskell.Liquid.Bare.OfType+-- import qualified Language.Haskell.Liquid.Bare.Misc      as GM+-- import           Language.Haskell.Liquid.Bare.Env+-- import           Language.Haskell.Liquid.Bare.Lookup+-- import           Language.Haskell.Liquid.Bare.OfType+ import           Text.Printf                     (printf) import           Text.PrettyPrint.HughesPJ       ((<+>)) -- import           Debug.Trace (trace)  --------------------------------------------------------------------------------+-- | 'DataConMap' stores the names of those ctor-fields that have been declared+--   as SMT ADTs so we don't make up new names for them.+--------------------------------------------------------------------------------+dataConMap :: [F.DataDecl] -> Bare.DataConMap+dataConMap ds = M.fromList $ do+  d     <- ds+  c     <- F.ddCtors d+  let fs = F.symbol <$> F.dcFields c+  zip ((F.symbol c,) <$> [1..]) fs+++--------------------------------------------------------------------------------+-- | 'makeDataConChecker d' creates the measure for `is$d` which tests whether+--   a given value was created by 'd'. e.g. is$Nil or is$Cons.+--------------------------------------------------------------------------------+makeDataConChecker :: Ghc.DataCon -> F.Symbol+--------------------------------------------------------------------------------+makeDataConChecker = F.testSymbol . F.symbol ++--------------------------------------------------------------------------------+-- | 'makeDataConSelector d' creates the selector `select$d$i`+--   which projects the i-th field of a constructed value.+--   e.g. `select$Cons$1` and `select$Cons$2` are respectively+--   equivalent to `head` and `tail`.+--------------------------------------------------------------------------------+makeDataConSelector :: Maybe Bare.DataConMap -> Ghc.DataCon -> Int -> F.Symbol+makeDataConSelector dmMb d i = M.lookupDefault def (F.symbol d, i) dm+  where +    dm                       = Mb.fromMaybe M.empty dmMb +    def                      = makeDataConSelector' d i+ ++makeDataConSelector' :: Ghc.DataCon -> Int -> F.Symbol+makeDataConSelector' d i+  = symbolMeasure "$select" (dcSymbol d) (Just i)++dcSymbol :: Ghc.DataCon -> F.Symbol+dcSymbol = {- simpleSymbolVar -} F.symbol . Ghc.dataConWorkId++symbolMeasure :: String -> F.Symbol -> Maybe Int -> F.Symbol+symbolMeasure f d iMb = foldr1 F.suffixSymbol (dcPrefix : F.symbol f : d : rest)+  where+    rest          = maybe [] (Misc.singleton . F.symbol . show) iMb+++-------------------------------------------------------------------------------- -- | makeClassEmbeds: sort-embeddings for numeric, and family-instance tycons ---------------------------------------------------------------------------------addClassEmbeds :: Maybe [ClsInst] -> [TyCon] -> F.TCEmb TyCon -> F.TCEmb TyCon+addClassEmbeds :: Maybe [Ghc.ClsInst] -> [Ghc.TyCon] -> F.TCEmb Ghc.TyCon +               -> F.TCEmb Ghc.TyCon addClassEmbeds instenv fiTcs = makeFamInstEmbeds fiTcs . makeNumEmbeds instenv  --------------------------------------------------------------------------------@@ -75,35 +117,34 @@ --     Query.R$58$EntityFieldBlobdog --   with the actual family instance  types that have numeric instances as int [Check!] ---------------------------------------------------------------------------------makeFamInstEmbeds :: [TyCon] -> F.TCEmb TyCon -> F.TCEmb TyCon+makeFamInstEmbeds :: [Ghc.TyCon] -> F.TCEmb Ghc.TyCon -> F.TCEmb Ghc.TyCon makeFamInstEmbeds cs0 embs = L.foldl' embed embs famInstSorts   where     famInstSorts          = F.notracepp "famInstTcs"                             [ (c, RT.typeSort embs ty)                                 | c   <- cs-                                , ty  <- maybeToList (famInstTyConType c) ]-    embed embs (c, t)     = M.insert c t embs+                                , ty  <- Mb.maybeToList (RT.famInstTyConType c) ]+    embed embs (c, t)     = F.tceInsert c t F.NoArgs embs     cs                    = F.notracepp "famInstTcs-all" cs0 -famInstTyConType :: TyCon -> Maybe Type-famInstTyConType c = case tyConFamInst_maybe c of-  Just (c', ts) -> Just (famInstType (tyConArity c) c' ts)-  Nothing       -> Nothing--famInstType :: Int -> TyCon -> [Type] -> Type-famInstType n c ts = Type.mkTyConApp c (take (length ts - n) ts)+{- +famInstTyConType :: Ghc.TyCon -> Maybe Ghc.Type+famInstTyConType c = case Ghc.tyConFamInst_maybe c of+    Just (c', ts) -> F.tracepp ("famInstTyConType: " ++ F.showpp (c, Ghc.tyConArity c, ts)) +                     $ Just (famInstType (Ghc.tyConArity c) c' ts)+    Nothing       -> Nothing --- famInstSort :: F.TCEmb TyCon -> TyCon -> Maybe F.Sort--- famInstSort embs c = tcAppSort embs <$> tyConFamInst_maybe c+famInstType :: Int -> Ghc.TyCon -> [Ghc.Type] -> Ghc.Type+famInstType n c ts = Ghc.mkTyConApp c (take (length ts - n) ts)+-} --- tcAppSort :: F.TCEmb TyCon -> (TyCon, [Type]) -> F.Sort--- tcAppSort embs (c, ts) = RT.typeSort embs (Type.mkTyConApp c ts)+{- | [NOTE:FamInstEmbeds] GHC represents family instances in two ways:  -{- | [NOTE:FamInstEmbeds] For various reasons, GHC represents family instances-     in two ways: (1) As an applied type, (2) As a special tycon.+     (1) As an applied type, +     (2) As a special tycon.+           For example, consider `tests/pos/ExactGADT4.hs`: -         class PersistEntity record where           data EntityField record :: * -> * @@ -130,24 +171,26 @@         R$58$EntityFieldBlobdog :-> EntityField Blob       So that all occurrences of the (2) are treated as (1) by the sort checker.+  -}  -------------------------------------------------------------------------------- -- | makeNumEmbeds: embed types that have numeric instances as int [Check!] ---------------------------------------------------------------------------------makeNumEmbeds :: Maybe [ClsInst] -> F.TCEmb TyCon -> F.TCEmb TyCon+makeNumEmbeds :: Maybe [Ghc.ClsInst] -> F.TCEmb Ghc.TyCon -> F.TCEmb Ghc.TyCon makeNumEmbeds Nothing x   = x makeNumEmbeds (Just is) x = L.foldl' makeNumericInfoOne x is -makeNumericInfoOne :: F.TCEmb TyCon -> ClsInst -> F.TCEmb TyCon+makeNumericInfoOne :: F.TCEmb Ghc.TyCon -> Ghc.ClsInst -> F.TCEmb Ghc.TyCon makeNumericInfoOne m is-  | isFracCls $ classTyCon $ is_cls is, Just tc <- instanceTyCon is-  = M.insertWith (flip mappendSortFTC) tc (ftc tc True True) m-  | isNumCls  $ classTyCon $ is_cls is, Just tc <- instanceTyCon is-  = M.insertWith (flip mappendSortFTC) tc (ftc tc True False) m+  | isFracCls cls, Just tc <- instanceTyCon is+  = F.tceInsertWith (flip mappendSortFTC) tc (ftc tc True True) F.NoArgs m+  | isNumCls  cls, Just tc <- instanceTyCon is+  = F.tceInsertWith (flip mappendSortFTC) tc (ftc tc True False) F.NoArgs m   | otherwise   = m   where+    cls         = Ghc.classTyCon (Ghc.is_cls is)     ftc c f1 f2 = F.FTC (F.symbolNumInfoFTyCon (dummyLoc $ RT.tyConName c) f1 f2)  mappendSortFTC :: F.Sort -> F.Sort -> F.Sort@@ -156,11 +199,11 @@ mappendSortFTC (F.FTC _) s         = s mappendSortFTC s1        s2        = panic Nothing ("mappendSortFTC: s1 = " ++ showpp s1 ++ " s2 = " ++ showpp s2) -instanceTyCon :: ClsInst -> Maybe TyCon-instanceTyCon = go . is_tys+instanceTyCon :: Ghc.ClsInst -> Maybe Ghc.TyCon+instanceTyCon = go . Ghc.is_tys   where-    go [TyConApp c _] = Just c-    go _              = Nothing+    go [Ghc.TyConApp c _] = Just c+    go _                  = Nothing  -------------------------------------------------------------------------------- -- | Create Fixpoint DataDecl from LH DataDecls --------------------------------@@ -173,18 +216,18 @@  type DataPropDecl = (DataDecl, Maybe SpecType) -makeDataDecls :: Config -> F.TCEmb TyCon -> ModName-              -> [(ModName, TyCon, DataPropDecl)]-              -> [(DataCon, Located DataConP)]+makeDataDecls :: Config -> F.TCEmb Ghc.TyCon -> ModName+              -> [(ModName, Ghc.TyCon, DataPropDecl)]+              -> [Located DataConP]               -> [F.DataDecl] makeDataDecls cfg tce name tds ds   | makeDecls = [ makeFDataDecls tce tc dd ctors-                | (tc, (dd, ctors)) <- groupDataCons tds' ds-                , tc /= listTyCon+                | (tc, (dd, ctors)) <- groupDataCons tds' (F.notracepp "makeDataDecls" ds)+                , tc /= Ghc.listTyCon                 ]   | otherwise = []   where-    makeDecls = exactDC cfg && not (noADT cfg)+    makeDecls = exactDCFlag cfg && not (noADT cfg)     tds'      = resolveTyCons name tds  -- [NOTE:Orphan-TyCons]@@ -215,52 +258,44 @@       and hence, unsafely pass its invariants! (Feature not bug?)  -}-resolveTyCons :: ModName -> [(ModName, TyCon, DataPropDecl)]-              -> [(TyCon, (ModName, DataPropDecl))]+resolveTyCons :: ModName -> [(ModName, Ghc.TyCon, DataPropDecl)]+              -> [(Ghc.TyCon, (ModName, DataPropDecl))] resolveTyCons m mtds = [(tc, (m, d)) | (tc, mds) <- M.toList tcDecls-                                     , (m, d)    <- maybeToList $ resolveDecls m tc mds ]+                                     , (m, d)    <- Mb.maybeToList $ resolveDecls m tc mds ]   where     tcDecls          = Misc.group [ (tc, (m, d)) | (m, tc, d) <- mtds ]  -- | See [NOTE:Orphan-TyCons], the below function tells us which of (possibly many) --   DataDecls to use.-resolveDecls :: ModName -> TyCon -> Misc.ListNE (ModName, DataPropDecl)+resolveDecls :: ModName -> Ghc.TyCon -> Misc.ListNE (ModName, DataPropDecl)              -> Maybe (ModName, DataPropDecl)-resolveDecls mName tc mds  = Misc.firstMaybes $ (`L.find` mds) <$> [ isHomeDef , isMyDef]+resolveDecls mName tc mds  = F.notracepp msg $ Misc.firstMaybes $ (`L.find` mds) <$> [ isHomeDef , isMyDef]   where+    msg                    = "resolveDecls" ++ F.showpp (mName, tc)     isMyDef                = (mName ==)             . fst     isHomeDef              = (tcHome ==) . F.symbol . fst     tcHome                 = GM.takeModuleNames (F.symbol tc) --groupDataCons :: [(TyCon, (ModName, DataPropDecl))]-              -> [(DataCon, Located DataConP)]-              -> [(TyCon, (DataPropDecl, [(DataCon, DataConP)]))]+groupDataCons :: [(Ghc.TyCon, (ModName, DataPropDecl))]+              -> [Located DataConP]+              -> [(Ghc.TyCon, (DataPropDecl, [(Ghc.DataCon, DataConP)]))] groupDataCons tds ds = [ (tc, (d, dds')) | (tc, ((m, d), dds)) <- tcDataCons                                          , let dds' = filter (isResolvedDataConP m . snd) dds                        ]   where     tcDataCons       = M.toList $ M.intersectionWith (,) declM ctorM     declM            = M.fromList tds-    ctorM            = Misc.group [(dataConTyCon d, (d, val dp)) | (d, dp) <- ds]+    ctorM            = Misc.group [(Ghc.dataConTyCon d, (d, dcp)) | Loc _ _ dcp <- ds, let d = dcpCon dcp]  isResolvedDataConP :: ModName -> DataConP -> Bool isResolvedDataConP m dp = F.symbol m == dcpModule dp --- _groupDataCons :: [(TyCon, DataPropDecl)]-              -- -> [(DataCon, Located DataConP)]-              -- -> [(TyCon, (DataPropDecl, [(DataCon, DataConP)]))]--- _groupDataCons tds ds = M.toList $ M.intersectionWith (,) declM ctorM-  -- where-    -- declM             = M.fromList tds-    -- ctorM             = Misc.group [(dataConTyCon d, (d, val dp)) | (d, dp) <- ds]--makeFDataDecls :: F.TCEmb TyCon -> TyCon -> DataPropDecl -> [(DataCon, DataConP)]+makeFDataDecls :: F.TCEmb Ghc.TyCon -> Ghc.TyCon -> DataPropDecl -> [(Ghc.DataCon, DataConP)]                -> F.DataDecl makeFDataDecls tce tc dd ctors = makeDataDecl tce tc (fst dd) ctors                                -- ++ maybeToList (makePropDecl tce tc dd) -- TODO: AUTO-INDPRED -makeDataDecl :: F.TCEmb TyCon -> TyCon -> DataDecl -> [(DataCon, DataConP)]+makeDataDecl :: F.TCEmb Ghc.TyCon -> Ghc.TyCon -> DataDecl -> [(Ghc.DataCon, DataConP)]              -> F.DataDecl makeDataDecl tce tc dd ctors   = F.DDecl@@ -271,7 +306,7 @@   where     ftc = F.symbolFTycon (tyConLocSymbol tc dd) -tyConLocSymbol :: TyCon -> DataDecl -> LocSymbol+tyConLocSymbol :: Ghc.TyCon -> DataDecl -> LocSymbol tyConLocSymbol tc dd = F.atLoc (tycName dd) (F.symbol tc)  -- [NOTE:ADT] We need to POST-PROCESS the 'Sort' so that:@@ -280,132 +315,120 @@ -- 2. The "self" type is replaced with just itself --    (i.e. without any type applications.) -makeDataCtor :: F.TCEmb TyCon -> F.FTycon -> (DataCon, DataConP) -> F.DataCtor+makeDataCtor :: F.TCEmb Ghc.TyCon -> F.FTycon -> (Ghc.DataCon, DataConP) -> F.DataCtor makeDataCtor tce c (d, dp) = F.DCtor   { F.dcName    = GM.namedLocSymbol d   , F.dcFields  = makeDataFields tce c as xts   }   where-    as          = freeTyVars dp-    xts         = [ (fld x, t) | (x, t) <- reverse (tyArgs dp) ]-    fld         = Loc (dc_loc dp) (dc_locE dp) . fieldName d dp+    as          = dcpFreeTyVars dp+    xts         = [ (fld x, t) | (x, t) <- reverse (dcpTyArgs dp) ]+    fld         = F.atLoc dp . fieldName d dp -fieldName :: DataCon -> DataConP -> F.Symbol -> F.Symbol+fieldName :: Ghc.DataCon -> DataConP -> F.Symbol -> F.Symbol fieldName d dp x   | dcpIsGadt dp = F.suffixSymbol (F.symbol d) x   | otherwise    = x -makeDataFields :: F.TCEmb TyCon -> F.FTycon -> [RTyVar] -> [(F.LocSymbol, SpecType)]+makeDataFields :: F.TCEmb Ghc.TyCon -> F.FTycon -> [RTyVar] -> [(F.LocSymbol, SpecType)]                -> [F.DataField]-makeDataFields tce c as xts = [ F.DField x (fSort t) | (x, t) <- xts]+makeDataFields tce _c as xts = [ F.DField x (fSort t) | (x, t) <- xts]   where-    su                      = zip ({- rtyVarUniqueSymbol -} F.symbol <$> as) [0..]-    fSort                   = muSort c (length as) . F.substVars su . RT.rTypeSort tce+    su    = zip (F.symbol <$> as) [0..]+    fSort = F.substVars su . F.mapFVar (+ (length as)) . RT.rTypeSort tce +{-  muSort :: F.FTycon -> Int -> F.Sort -> F.Sort muSort c n  = V.mapSort tx   where     ct      = F.fTyconSort c     me      = F.fTyconSelfSort c n     tx t    = if t == me then ct else t-+-}  ---------------------------------------------------------------------------------{- | NOTE:AUTO-INDPRED (tests/todo/IndPred1.hs)--- DO NOT DELETE--- RJ: too hard, too brittle, I _thought_ we could just--- generate the F.DataDecl, but really, you need the GHC--- names for the Prop-Ctor if you want to be able to `import`--- a predicate across modules. Seems a LOT easier to just have--- the program explicitly create the the proposition type--- e.g. as shownn in (tests/pos/IndPred0.hs)+meetDataConSpec :: F.TCEmb Ghc.TyCon -> [(Ghc.Var, SpecType)] -> [DataConP] +                -> [(Ghc.Var, SpecType)] ----------------------------------------------------------------------------------type SpecTypeRep  = RTypeRep RTyCon RTyVar RReft---- | 'makePropDecl' creates the 'F.DataDecl' for the *proposition* described---   by the corresponding 'TyCon' / 'DataDecl', e.g. tests/pos/IndPred0.hs-makePropDecl :: F.TCEmb TyCon -> TyCon -> DataPropDecl -> Maybe F.DataDecl-makePropDecl tce tc (dd, pd) = makePropTyDecl tce tc dd <$> pd--makePropTyDecl :: F.TCEmb TyCon -> TyCon -> DataDecl -> SpecType -> F.DataDecl-makePropTyDecl tce tc dd t-  = F.DDecl-    { F.ddTyCon = ftc-    , F.ddVars  = length (ty_vars tRep)-    , F.ddCtors = [ makePropTyCtor tce ftc tRep ]-    }-  where-    ftc         = propFTycon tc dd-    tRep        = toRTypeRep t--propFTycon :: TyCon -> DataDecl -> F.FTycon-propFTycon tc = F.symbolFTycon . fmap (`F.suffixSymbol` F.propConName) . tyConLocSymbol tc--makePropTyCtor :: F.TCEmb TyCon -> F.FTycon -> SpecTypeRep -> F.DataCtor-makePropTyCtor tce ftc t-  = F.DCtor-    { F.dcName   = F.fTyconSymbol ftc-    , F.dcFields = makePropTyFields tce ftc t-    }--makePropTyFields :: F.TCEmb TyCon -> F.FTycon -> SpecTypeRep -> [F.DataField]-makePropTyFields tce ftc t = makeDataFields tce ftc as xts+meetDataConSpec emb xts dcs  = -- F.notracepp "meetDataConSpec" $+                               M.toList $ snd <$> L.foldl' upd dcm0 xts   where-    as                     = [ a | RTVar a _ <- ty_vars t ]-    xts                    = zipWith (\i t -> (fld i, t)) [0..] (ty_args t)-    tcSym                  = F.fTyconSymbol ftc-    fld                    = F.atLoc tcSym-                           . GM.symbolMeasure "propField" (val tcSym)-                           . Just--isPropDecl :: F.DataDecl -> Bool-isPropDecl d =  (F.isSuffixOfSym F.propConName . F.symbol . F.ddTyCon $ d)-              && (length (F.ddCtors d) == 1)--qualifyDataDecl :: ModName -> DataDecl -> DataDecl-qualifyDataDecl name d = d { tycName = qualifyName name (tycName d)}+    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')+    _msg x t t'              = "MEET-VAR-TYPES: " ++ showpp (x, t, t') -qualifyName :: ModName -> LocSymbol -> LocSymbol-qualifyName n x = F.atLoc x $ GM.qualifySymbol nSym (val x)+dataConSpec' :: [DataConP] -> [(Ghc.Var, (Ghc.SrcSpan, SpecType))]+dataConSpec' = concatMap tx    where-    nSym        = GM.takeModuleNames (F.symbol n)---}-+    tx dcp   =  [ (x, res) | (x, t0) <- dataConPSpecType dcp+                          , let t    = RT.expandProductType x t0  +                          , let res  = (GM.fSrcSpan dcp, t)+                ] -------------------------------------------------------------------------------- -- | Bare Predicate: DataCon Definitions --------------------------------------- ---------------------------------------------------------------------------------makeConTypes-  :: (ModName, Ms.Spec ty bndr)-  -> BareM ( [(ModName, TyCon, TyConP, Maybe DataPropDecl)]-           , [[(DataCon, Located DataConP)]]   )-makeConTypes (name, spec) = inModule name $-  makeConTypes' name (Ms.dataDecls spec) (Ms.dvariance spec)--makeConTypes' :: ModName -> [DataDecl] -> [(LocSymbol, [Variance])]-              -> BareM ( [(ModName, TyCon, TyConP, Maybe DataPropDecl)]-                       , [[(DataCon, Located DataConP)]])-makeConTypes' name dcs vdcs = do-  dcs' <- F.notracepp "CANONIZED-DECLS" <$> canonizeDecls dcs-  unzip <$> mapM (uncurry (ofBDataDecl name)) (groupVariances dcs' vdcs)+makeConTypes :: Bare.Env -> (ModName, Ms.BareSpec) +             -> ([(ModName, TyConP, Maybe DataPropDecl)], [[Located DataConP]])+makeConTypes env (name, spec) +         = unzip  [ ofBDataDecl env name x y | (x, y) <- gvs ] +  where +    gvs  = groupVariances dcs' vdcs+    dcs' = canonizeDecls env name dcs+    dcs  = Ms.dataDecls spec +    vdcs = Ms.dvariance spec   -- | 'canonizeDecls ds' returns a subset of 'ds' with duplicates, e.g. arising --   due to automatic lifting (via 'makeHaskellDataDecls'). We require that the --   lifted versions appear LATER in the input list, and always use those --   instead of the unlifted versions. -canonizeDecls :: [DataDecl] -> BareM [DataDecl]-canonizeDecls ds = do-  ks <- mapM key ds-  case Misc.uniqueByKey' selectDD (zip ks ds) of-    Left  ds     -> err    ds-    Right ds     -> return ds+canonizeDecls :: Bare.Env -> ModName -> [DataDecl] -> [DataDecl]+canonizeDecls env name ds =+  case Misc.uniqueByKey' selectDD kds of+    Left  decls  -> err    decls+    Right decls  -> decls   where-    key          = fmap F.symbol . lookupGhcDnTyCon "canonizeDecls" . tycName+    kds          = [ (k, d) | d <- ds, k <- Mb.maybeToList (dataDeclKey env name d) ]      err ds@(d:_) = uError (errDupSpecs (pprint $ tycName d)(GM.fSrcSpan <$> ds))     err _        = impossible Nothing "canonizeDecls" +dataDeclKey :: Bare.Env -> ModName -> DataDecl -> Maybe F.Symbol +-- dataDeclKey env name = fmap F.symbol . Bare.lookupGhcDnTyCon env name "canonizeDecls" . tycName+dataDeclKey env name d = do +  tc    <- Bare.lookupGhcDnTyCon env name "canonizeDecls" (tycName d)+  _     <- checkDataCtors env name tc (tycDCons d)   +  return (F.symbol tc)++checkDataCtors :: Bare.Env -> ModName -> Ghc.TyCon -> [DataCtor] -> Maybe [DataCtor] +checkDataCtors env name c = mapM (checkDataCtor2 env name c dcs . checkDataCtor1) +  where +    dcs                   = S.fromList . fmap F.symbol $ Ghc.tyConDataCons c++checkDataCtor2 :: Bare.Env -> ModName -> Ghc.TyCon -> S.HashSet F.Symbol -> DataCtor +               -> Maybe DataCtor +checkDataCtor2 env name c dcs d = do+  let dn = dcName d+  ctor  <- Bare.failMaybe env name (Bare.resolveLocSym env name "checkDataCtor2" dn :: Either UserError Ghc.DataCon) +  let x  = F.symbol ctor +  if S.member x dcs +    then Just d+    else Ex.throw (errInvalidDataCon c dn)++checkDataCtor1 :: DataCtor -> DataCtor +checkDataCtor1 d +  | x : _ <- dups = uError (err lc x :: UserError)+  | otherwise     = d +    where+      lc          = dcName   d +      xts         = dcFields d+      dups        = [ x | (x, ts) <- Misc.groupList xts, 2 <= length ts ]+      err lc x    = ErrDupField (GM.sourcePosSrcSpan $ loc lc) (pprint $ val lc) (pprint x)+++ selectDD :: (a, [DataDecl]) -> Either [DataDecl] DataDecl selectDD (_,[d]) = Right d selectDD (_, ds) = case [ d | d <- ds, tycKind d == DataReflected ] of@@ -425,98 +448,115 @@     merge ds     []         = ((,Nothing) . Just) <$> ds     sym                     = val . fst -dataConSpec' :: [(DataCon, DataConP)] -> [(Var, (SrcSpan, SpecType))]-dataConSpec' dcs = concatMap tx dcs-  where-    sspan z      = GM.sourcePos2SrcSpan (dc_loc z) (dc_locE z)-    tx (dc, dcp) = [ (x, (sspan dcp, t)) | (x, t0) <- dataConPSpecType dc dcp-                                         , let t  = F.notracepp ("expandProductType" ++ showpp (x, t0)) $ RT.expandProductType x t0  ] -    -- tx (dc, dcp) = [ (x, (sspan dcp, t)) | (x, t) <- RT.mkDataConIdsTy dc (dataConPSpecType dc dcp) ] -- HEREHEREHEREHERE-1089---meetDataConSpec :: [(Var, SpecType)] -> [(DataCon, DataConP)] -> [(Var, SpecType)]-meetDataConSpec xts dcs  = M.toList $ snd <$> L.foldl' upd dcm0 (F.notracepp "meetDataConSpec" xts)-  where-    dcm0                 = M.fromList $ dataConSpec' dcs-    upd dcm (x, t)       = M.insert x (getSrcSpan x, tx') dcm-                             where-                               tx' = maybe t (meetX x t) (M.lookup x dcm)-    meetX x t (sp', t')  = meetVarTypes (pprint x) (getSrcSpan x, t) (sp', t')--checkDataCtors :: TyCon -> [DataCtor] -> BareM ()-checkDataCtors c ds = do-  mapM_ checkDataCtor ds-  let dcs = S.fromList . fmap F.symbol $ tyConDataCons c-  forM_ ds $ \d -> do-    let dn = dcName d-    x     <- F.symbol <$> lookupGhcDataCon dn-    when (not (S.member x dcs)) (uError (errInvalidDataCon c dn))--errInvalidDataCon :: TyCon -> LocSymbol -> UserError-errInvalidDataCon c d = ErrBadData sp (pprint (val d)) msg-  where-    sp                = GM.sourcePosSrcSpan (loc d)-    msg               = ppVar c <+> "is not the type constructor"--checkDataCtor :: DataCtor -> BareM ()-checkDataCtor (DataCtor lc _ xts _)-  | x : _ <- dups = Ex.throw (err lc x :: UserError)-  | otherwise     = return ()-    where-      dups        = [ x | (x, ts) <- Misc.groupList xts, 2 <= length ts ]-      err lc x    = ErrDupField (GM.sourcePosSrcSpan $ loc lc) (pprint $ val lc) (pprint x)- -- | 'checkDataDecl' checks that the supplied DataDecl is indeed a refinement --   of the GHC TyCon. We just check that the right tyvars are supplied --   as errors in the names and types of the constructors will be caught --   elsewhere. [e.g. tests/errors/BadDataDecl.hs] -checkDataDecl :: TyCon -> DataDecl -> Bool+checkDataDecl :: Ghc.TyCon -> DataDecl -> Bool checkDataDecl c d = F.notracepp _msg (cN == dN || null (tycDCons d))   where     _msg          = printf "checkDataDecl: c = %s, cN = %d, dN = %d" (show c) cN dN     cN            = length (GM.tyConTyVarsDef c)     dN            = length (tycTyVars         d) +getDnTyCon :: Bare.Env -> ModName -> DataName -> Ghc.TyCon+getDnTyCon env name dn = Mb.fromMaybe ugh (Bare.lookupGhcDnTyCon env name "ofBDataDecl-1" dn)+  where +    ugh                = impossible Nothing "getDnTyCon"+ -- FIXME: ES: why the maybes?-ofBDataDecl :: ModName-            -> Maybe DataDecl-            -> (Maybe (LocSymbol, [Variance]))-            -> BareM ((ModName, TyCon, TyConP, Maybe DataPropDecl), [(DataCon, Located DataConP)])-ofBDataDecl name (Just dd@(D tc as ps ls cts _ sfun pt _)) maybe_invariance_info-  = do πs            <- mapM ofBPVar ps-       tc'           <- lookupGhcDnTyCon "ofBDataDecl" tc-       when (not $ checkDataDecl tc' dd) (Ex.throw err)-       checkDataCtors tc' cts-       cts'          <- mapM (ofBDataCtor name lc lc' tc' αs ps ls πs) cts-       pd            <- mapM (mkSpecType' lc []) pt-       let tys        = [t | (_, dcp) <- cts', (_, t) <- tyArgs dcp]-       let initmap    = zip (RT.uPVar <$> πs) [0..]-       let varInfo    = L.nub $  concatMap (getPsSig initmap True) tys-       let defPs      = varSignToVariance varInfo <$> [0 .. (length πs - 1)]-       let (tvi, pvi) = f defPs-       let tcp        = TyConP lc αs πs ls tvi pvi sfun-       return ((name, tc', tcp, Just (dd { tycDCons = cts }, pd)), (Misc.mapSnd (Loc lc lc') <$> cts'))-    where-       err          = ErrBadData (GM.fSrcSpan tc) (pprint tc) "Mismatch in number of type variables" :: UserError-       αs           = RTV . GM.symbolTyVar <$> as-       n            = length αs-       Loc lc lc' _ = dataNameSymbol tc-       f defPs      = case maybe_invariance_info of-                       { Nothing -> ([], defPs);-                         Just (_,is) -> (take n is, if null (drop n is) then defPs else (drop n is))}+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+  | not (checkDataDecl tc' dd)+  = uError err+  | otherwise+  = ((name, tcp, Just (dd { tycDCons = cts }, pd)), Loc lc lc' <$> cts')+  where+    π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+    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+    err          = ErrBadData (GM.fSrcSpan tc) (pprint tc) "Mismatch in number of type variables" :: UserError+    αs           = RTV . GM.symbolTyVar <$> as+    n            = length αs+    Loc lc lc' _ = dataNameSymbol tc+    f defPs      = case maybe_invariance_info of+                     Nothing     -> ([], defPs)+                     Just (_,is) -> (take n is, if null (drop n is) then defPs else (drop n is)) -ofBDataDecl name Nothing (Just (tc, is))-  = do tc'        <- lookupGhcTyCon "ofBDataDecl" tc-       return ((name, tc', TyConP srcpos [] [] [] tcov tcontr Nothing, Nothing), [])+ofBDataDecl env name Nothing (Just (tc, is))+  = ((name, TyConP srcpos tc' [] [] [] tcov tcontr Nothing, Nothing), [])   where+    tc'            = Bare.lookupGhcTyCon env name "ofBDataDecl-2" tc     (tcov, tcontr) = (is, [])-    srcpos = F.dummyPos "LH.DataType.Variance"+    srcpos         = F.dummyPos "LH.DataType.Variance" -ofBDataDecl _ Nothing Nothing+ofBDataDecl _ _ Nothing Nothing   = panic Nothing "Bare.DataType.ofBDataDecl called on invalid inputs" +-- TODO:EFFECTS:ofBDataCon+ofBDataCtor :: Bare.Env +            -> ModName+            -> F.SourcePos+            -> F.SourcePos+            -> Ghc.TyCon+            -> [RTyVar]+            -> [PVar BSort]+            -> [F.Symbol]+            -> [PVar RSort]+            -> DataCtor+            -> DataConP+ofBDataCtor env name l l' tc αs ps ls π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                +  , dcpIsGadt     = isGadt                +  , dcpModule     = F.symbol name          +  , dcpLocE       = l'+  } +  where+    c'            = Bare.lookupGhcDataCon env name "ofBDataCtor" c+    ts'           = Bare.ofBareType env name l (Just ps) <$> ts+    res'          = Bare.ofBareType env name l (Just ps) <$> res+    t0'           = dataConResultTy c' αs t0 res'+    _cfg          = getConfig env +    (yts, ot)     = -- F.tracepp ("dataConTys: " ++ F.showpp (c, αs)) $ +                      qualifyDataCtor (not isGadt) name dLoc (zip xs ts', t0')+    zts           = zipWith (normalizeField c') [1..] (reverse yts)+    usedTvs       = S.fromList (ty_var_value <$> concatMap RT.freeTyVars (t0':ts'))+    cs            = [ p | p <- RT.ofType <$> Ghc.dataConTheta c', keepPredType usedTvs p ]+    (xs, ts)      = unzip xts+    t0            = case RT.famInstTyConType tc of+                      Nothing -> F.notracepp "dataConResult-3: " $ RT.gApp tc αs πs+                      Just ty -> RT.ofType ty+    isGadt        = Mb.isJust res+    dLoc          = F.Loc l l' ()+++++errInvalidDataCon :: Ghc.TyCon -> LocSymbol -> UserError+errInvalidDataCon c d = ErrBadGADT sp v msg+  where+    v                 = pprint (val d)+    sp                = GM.sourcePosSrcSpan (loc d)+    msg               = ppTicks c <+> "is not the type constructed by" <+> ppTicks v+ varSignToVariance :: Eq a => [(a, Bool)] -> a -> Variance varSignToVariance varsigns i = case filter (\p -> fst p == i) varsigns of                                 []       -> Invariant@@ -546,44 +586,8 @@  addps :: [(UsedPVar, a)] -> b -> UReft t -> [(a, b)] addps m pos (MkUReft _ ps _) = (flip (,)) pos . f  <$> pvars ps-  where f = fromMaybe (panic Nothing "Bare.addPs: notfound") . (`L.lookup` m) . RT.uPVar---- TODO:EFFECTS:ofBDataCon-ofBDataCtor :: ModName-            -> SourcePos-            -> SourcePos-            -> TyCon-            -> [RTyVar]-            -> [PVar BSort]-            -> [F.Symbol]-            -> [PVar RSort]-            -> DataCtor-            -> BareM (DataCon, DataConP)-ofBDataCtor name l l' tc αs ps ls πs (DataCtor c _ xts res) = do-  c'           <- lookupGhcDataCon c-  ts'          <- mapM (mkSpecType' l ps) ts-  res'         <- mapM (mkSpecType' l ps) res-  let t0'       = F.notracepp ("dataConResultTy c' = " ++ show c' ++ " res' = " ++ show res') $ dataConResultTy c' αs t0 res'-  cfg          <- gets beConfig-  let (yts, ot) = F.notracepp ("OFBDataCTOR: " ++ show c' ++ " " ++ show (isVanillaDataCon c', res') ++ " " ++ show isGadt)-                $ qualifyDataCtor (exactDC cfg && not isGadt) name dLoc (zip xs ts', t0')-  let zts       = zipWith (normalizeField c') [1..] (reverse yts)--  let usedTvs   = S.fromList (ty_var_value <$> concatMap RT.freeTyVars (t0':ts'))-  -- let cs        = RT.ofType <$> dataConStupidTheta c'-  let cs        = [ p | p <- RT.ofType <$> dataConTheta c', keepPredType usedTvs p ]-  return          (c', DataConP l αs πs ls cs zts ot isGadt (F.symbol name) l')-  where-    (xs, ts)    = unzip xts-    t0          = case famInstTyConType tc of-                    Nothing -> RT.gApp tc αs πs-                    Just ty -> RT.ofType ty-    -- nFlds    = length xts-    -- rs       = [RT.rVar α | RTV α <- αs]-    -- t0       = F.tracepp "t0 = " $ RT.rApp tc rs (rPropP [] . pdVarReft <$> πs) mempty -- 1089 HEREHERE use the SPECIALIZED type?-    isGadt      = isJust res-    dLoc        = F.Loc l l' ()-+  where +    f = Mb.fromMaybe (panic Nothing "Bare.addPs: notfound") . (`L.lookup` m) . RT.uPVar  keepPredType :: S.HashSet RTyVar -> SpecType -> Bool keepPredType tvs p@@ -594,45 +598,33 @@ -- | This computes the result of a `DataCon` application. --   For 'isVanillaDataCon' we can just use the `TyCon` --   applied to the relevant tyvars.-dataConResultTy :: DataCon+dataConResultTy :: Ghc.DataCon                 -> [RTyVar]         -- ^ DataConP ty-vars                 -> SpecType         -- ^ vanilla result type                 -> Maybe SpecType   -- ^ user-provided result type                 -> SpecType dataConResultTy _ _ _ (Just t) = t-dataConResultTy c αs t _-  | isVanillaDataCon c         = t-  | False                      = F.notracepp "RESULT-TYPE:" $ RT.subsTyVars_meet (gadtSubst αs c) t-dataConResultTy c _ _ _        = RT.ofType t-  where-    (_,_,_,_,_,t)              = {- GM.tracePpr ("FULL-SIG:" ++ show c ++ " -- repr : " ++ GM.showPpr (_tr0, _tr1, _tr2)) $ -} dataConFullSig c-    _tr0                        = dataConRepType c-    _tr1                        = varType $ dataConWorkId c-    _tr2                        = varType $ dataConWrapId c---- RTVar RTyVar RSort--gadtSubst :: [RTyVar] -> DataCon -> [(RTyVar, RSort, SpecType)]-gadtSubst as c  = mkSubst (Misc.join aBs bTs)+dataConResultTy c _ t _+  | Ghc.isVanillaDataCon c     = F.notracepp ("dataConResultTy-1 : " ++ F.showpp c) $ t+  | otherwise                  = F.notracepp ("dataConResultTy-2 : " ++ F.showpp c) $ RT.ofType ct   where-    bTs         = [ (b, t) |  Just (b, t) <- eqSubst <$> ty_args workR ]-    aBs         = zip as bs-    bs          = ty_var_value <$> ty_vars workR-    workR       = dataConWorkRep c-    mkSubst bTs = [ (b, toRSort t, t) | (b, t) <- bTs ]+    (_,_,_,_,_,ct)             = Ghc.dataConFullSig c+    -- _tr0                    = Ghc.dataConRepType c+    -- _tr1                    = Ghc.varType (Ghc.dataConWorkId c)+    -- _tr2                    = Ghc.varType (Ghc.dataConWrapId c)  eqSubst :: SpecType -> Maybe (RTyVar, SpecType) eqSubst (RApp c [_, _, (RVar a _), t] _ _)-  | rtc_tc c == eqPrimTyCon = Just (a, t)-eqSubst _                   = Nothing+  | rtc_tc c == Ghc.eqPrimTyCon = Just (a, t)+eqSubst _                       = Nothing -normalizeField :: DataCon -> Int -> (F.Symbol, a) -> (F.Symbol, a)+normalizeField :: Ghc.DataCon -> Int -> (F.Symbol, a) -> (F.Symbol, a) normalizeField c i (x, t)   | isTmp x   = (xi, t)   | otherwise = (x , t)   where     isTmp     = F.isPrefixOfSym F.tempPrefix-    xi        = GM.makeDataConSelector Nothing c i+    xi        = makeDataConSelector Nothing c i  -- | `qualifyDataCtor` qualfies the field names for each `DataCtor` to --   ensure things work properly when exported.@@ -645,55 +637,56 @@  where    t'        = F.subst su <$> t    xts'      = [ (qx, F.subst su t)       | (qx, t, _) <- fields ]-   su        = F.notracepp "F-ING subst" $ F.mkSubst [ (x, F.eVar qx) | (qx, _, Just x) <- fields ]+   su        = F.mkSubst [ (x, F.eVar qx) | (qx, _, Just x) <- fields ]    fields    = [ (qx, t, mbX) | (x, t) <- xts, let (mbX, qx) = qualifyField name (F.atLoc l x) ]  qualifyField :: ModName -> LocSymbol -> (Maybe F.Symbol, F.Symbol) qualifyField name lx- | needsQual = (Just x, F.notracepp msg $ qualifyModName name x)+ | needsQual = (Just x, F.notracepp msg $ qualifyModName name x)   | otherwise = (Nothing, x)  where    msg       = "QUALIFY-NAME: " ++ show x ++ " in module " ++ show (F.symbol name)    x         = val lx    needsQual = not (isWiredIn lx) -makeTyConEmbeds :: (ModName,Ms.Spec ty bndr) -> BareM (F.TCEmb TyCon)-makeTyConEmbeds (mod, spec)-  = inModule mod $ makeTyConEmbeds' $ Ms.embeds spec--makeTyConEmbeds' :: F.TCEmb LocSymbol -> BareM (F.TCEmb TyCon)-makeTyConEmbeds' z = M.fromList <$> mapM tx (M.toList z)-  where-    tx (c, y) = (, y) <$> lookupGhcTyCon "makeTyConEmbeds'" c+checkRecordSelectorSigs :: [(Ghc.Var, LocSpecType)] -> [(Ghc.Var, LocSpecType)]+checkRecordSelectorSigs vts = [ (v, take1 v ts) | (v, ts) <- Misc.groupList vts ] +  where +    take1 v ts              = case Misc.nubHashOn (showpp . val) ts of +                                [t]    -> t +                                (t:ts) -> Ex.throw (ErrDupSpecs (GM.fSrcSpan t) (pprint v) (GM.fSrcSpan <$> ts) :: Error)+                                _      -> impossible Nothing "checkRecordSelectorSigs" -makeRecordSelectorSigs :: [(DataCon, Located DataConP)] -> BareM [(Var, LocSpecType)]-makeRecordSelectorSigs dcs = F.notracepp "makeRecordSelectorSigs" <$> (concat <$> mapM makeOne dcs)+makeRecordSelectorSigs :: Bare.Env -> ModName -> [Located DataConP] -> [(Ghc.Var, LocSpecType)]+makeRecordSelectorSigs env name = checkRecordSelectorSigs . concatMap makeOne   where-  makeOne (dc, Loc l l' dcp)-    | null (dataConFieldLabels dc)  -- no field labels OR-      || any (isFunTy . snd) args   -- OR function-valued fields-      || dcpIsGadt dcp              -- OR GADT style datcon-    = return []-    | otherwise = do-        fs <- mapM lookupGhcVar (dataConFieldLabels dc)-        return $ zip fs ts+  makeOne (Loc l l' dcp)+    | null fls                    --    no field labels+    || any (isFunTy . snd) args && not (higherOrderFlag env)   -- OR function-valued fields+    || dcpIsGadt dcp              -- OR GADT style datcon+    = []+    | otherwise +    = [ (v, t) | (Just v, t) <- zip fs ts ]      where-    ts :: [ LocSpecType ]-    ts = [ Loc l l' (mkArrow (makeRTVar <$> freeTyVars dcp) [] (freeLabels dcp)-                               [(z, res, mempty)]-                               (dropPreds (F.subst su t `RT.strengthen` mt)))-           | (x, t) <- reverse args -- NOTE: the reverse here is correct-           , let vv = rTypeValueVar t-             -- the measure singleton refinement, eg `v = getBar foo`-           , let mt = RT.uReft (vv, F.PAtom F.Eq (F.EVar vv) (F.EApp (F.EVar x) (F.EVar z)))-           ]--    su   = F.mkSubst [ (x, F.EApp (F.EVar x) (F.EVar z)) | x <- fst <$> args ]-    args = tyArgs dcp-    z    = F.notracepp ("makeRecordSelectorSigs:" ++ show args) "lq$recSel"-    res  = dropPreds (tyRes dcp)--    -- FIXME: this is clearly imprecise, but the preds in the DataConP seem-    -- to be malformed. If we leave them in, tests/pos/kmp.hs fails with-    -- a malformed predicate application. Niki, help!!-    dropPreds = fmap (\(MkUReft r _ps ss) -> MkUReft r mempty ss)+      dc  = dcpCon dcp+      fls = Ghc.dataConFieldLabels dc+      fs  = Bare.lookupGhcNamedVar env name . Ghc.flSelector <$> fls +      ts :: [ LocSpecType ]+      ts = [ Loc l l' (mkArrow (makeRTVar <$> dcpFreeTyVars dcp) [] (dcpFreeLabels dcp)+                                 [] [(z, res, mempty)]+                                 (dropPreds (F.subst su t `RT.strengthen` mt)))+             | (x, t) <- reverse args -- NOTE: the reverse here is correct+             , let vv = rTypeValueVar t+               -- the measure singleton refinement, eg `v = getBar foo`+             , let mt = RT.uReft (vv, F.PAtom F.Eq (F.EVar vv) (F.EApp (F.EVar x) (F.EVar z)))+             ]+  +      su   = F.mkSubst [ (x, F.EApp (F.EVar x) (F.EVar z)) | x <- fst <$> args ]+      args = dcpTyArgs dcp+      z    = F.notracepp ("makeRecordSelectorSigs:" ++ show args) "lq$recSel"+      res  = dropPreds (dcpTyRes dcp)+  +      -- FIXME: this is clearly imprecise, but the preds in the DataConP seem+      -- to be malformed. If we leave them in, tests/pos/kmp.hs fails with+      -- a malformed predicate application. Niki, help!!+      dropPreds = fmap (\(MkUReft r _ps ss) -> MkUReft r mempty ss)
− src/Language/Haskell/Liquid/Bare/Env.hs 
@@ -1,175 +0,0 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE TypeSynonymInstances  #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Language.Haskell.Liquid.Bare.Env (-    BareM-  , Warn-  , TCEnv-  , BareEnv(..)-  , InlnEnv--  , inModule-  , withVArgs--  , setRTAlias-  , setREAlias-  -- , setEmbeds-  , setDataDecls--  , execBare--  , insertLogicEnv-  , insertAxiom-  , addDefs---  -- * Exact DataConstructor Functions-  , DataConMap-  , dataConMap-  ) where--import           HscTypes-import           Prelude                              hiding (error)-import           Text.Parsec.Pos-import           TyCon-import           DataCon-import           Var--import           Control.Monad.Except-import           Control.Monad.State-import           Control.Monad.Writer--import qualified Control.Exception                    as Ex-import qualified Data.HashMap.Strict                  as M-import qualified Data.HashSet                         as S---import           Language.Fixpoint.Types              (Expr(..), TCEmb)-import qualified Language.Fixpoint.Types as F--import           Language.Haskell.Liquid.UX.Errors    ()-import           Language.Haskell.Liquid.Types-import           Language.Haskell.Liquid.Types.Fresh-import           Language.Haskell.Liquid.Types.Bounds------------------------------------------------------------------------------------- | 'DataConMap' stores the names of those ctor-fields that have been declared---   as SMT ADTs so we don't make up new names for them.----------------------------------------------------------------------------------type DataConMap = M.HashMap (F.Symbol, Int) F.Symbol--dataConMap :: [F.DataDecl] -> DataConMap-dataConMap ds = M.fromList $ do-  d     <- ds-  c     <- F.ddCtors d-  let fs = F.symbol <$> F.dcFields c-  zip ((F.symbol c,) <$> [1..]) fs------------------------------------------------------------------------------------- | Error-Reader-IO For Bare Transformation ------------------------------------------------------------------------------------------------------------------------ FIXME: don't use WriterT [], very slow-type BareM   = WriterT [Warn] (ExceptT Error (StateT BareEnv IO))-type Warn    = String-type TCEnv   = M.HashMap TyCon RTyCon-type InlnEnv = M.HashMap F.Symbol LMap--data BareEnv = BE-  { modName  :: !ModName-  , tcEnv    :: !TCEnv-  , rtEnv    :: !RTEnv-  , varEnv   :: !(M.HashMap F.Symbol Var)-  , hscEnv   :: !(HscEnv)-  , famEnv   :: !(M.HashMap F.Symbol DataCon)     -- ^ see NOTE:Family-Instance-Environment-  , logicEnv :: !LogicMap-  , dcEnv    :: !DataConMap-  , bounds   :: !(RBEnv)-  , embeds   :: !(TCEmb TyCon)-  , axSyms   :: !(M.HashMap F.Symbol LocSymbol)-  , propSyms :: !(M.HashMap F.Symbol LocSymbol)-  , beConfig :: !Config-  , beIndex  :: !Integer-  }--{- | [NOTE:Family-Instance-Environment]-     For some reason, the usual lookup machinery (lookupGhcThing) refuses-     to properly lookup _imported_ names of family-instance data-constructors.-     e.g. see tests/pos/ExactGADT8.hs and tests/pos/ExactGADT9.hs; inside the latter,-     the lookupGhcThing fails to resolve the name of `BlobXVal` (but it works just fine-     when BlobXVal is a plain DataCon as in tests/pos/ExactGADT8a.hs-     To get around this hassle, we also save a map from _family instance_ DataCon-names-     to the corresponding family instance Tycon in the `famEnv` field of BareEnv.-     This map is *created* inside the function FIXME, and *used* inside the function FIXME.- -}--instance Freshable BareM Integer where-  fresh = do s <- get-             let n = beIndex s-             put $ s { beIndex = n + 1 }-             return n--instance HasConfig BareEnv where-  getConfig = beConfig--setDataDecls :: [F.DataDecl] -> BareM ()-setDataDecls adts = modify $ \be -> be { dcEnv = dataConMap adts }--_setEmbeds :: TCEmb TyCon -> BareM ()-_setEmbeds emb = modify $ \be -> be {embeds = emb}--insertLogicEnv :: String -> LocSymbol -> [F.Symbol] -> Expr -> BareM ()-insertLogicEnv _msg x ys e = modify $ \be -> be {logicEnv = (logicEnv be) {lmSymDefs = M.insert (val x) (LMap x ys e) $ lmSymDefs $ logicEnv be}}--insertAxiom :: Var -> Maybe F.Symbol -> BareM ()-insertAxiom x s-  = modify $ \be -> be {logicEnv = (logicEnv be) {lmVarSyms = M.insert x s $ lmVarSyms $ logicEnv be}}--addDefs :: S.HashSet (Var, F.Symbol) -> BareM ()-addDefs ds = forM_ (S.toList ds) $ \(v, x) -> insertAxiom v (Just x)--setModule :: ModName -> BareEnv -> BareEnv-setModule m b = b { modName = m }--inModule :: ModName -> BareM b -> BareM b-inModule m act = do-  old <- gets modName-  modify $ setModule m-  res <- act-  modify $ setModule old-  return res--withVArgs :: (Foldable t, PPrint a)-          => SourcePos-          -> SourcePos-          -> t a-          -> BareM b-          -> BareM b-withVArgs l l' vs act = do-  old <- gets rtEnv-  mapM_ (mkExprAlias l l' . F.symbol . showpp) vs-  res <- act-  modify $ \be -> be { rtEnv = old }-  return res--mkExprAlias :: SourcePos -> SourcePos -> F.Symbol -> BareM ()-mkExprAlias l l' v = setRTAlias v (RTA v [] [] (RExprArg (Loc l l' $ EVar $ F.symbol v)) l l')--setRTAlias :: F.Symbol -> RTAlias RTyVar SpecType -> BareM ()-setRTAlias s a = modify $ \b -> b { rtEnv = mapRT (M.insert s a) $ rtEnv b }--setREAlias :: F.Symbol -> RTAlias F.Symbol Expr -> BareM ()-setREAlias s a = modify $ \b -> b { rtEnv = mapRE (M.insert s a) $ rtEnv b }---------------------------------------------------------------------execBare :: BareM a -> BareEnv -> IO (Either Error a)--------------------------------------------------------------------execBare act benv =-   do z <- evalStateT (runExceptT (runWriterT act)) benv `Ex.catch` (return . Left)-      case z of-        Left s        -> return $ Left s-        Right (x, ws) -> do forM_ ws $ putStrLn . ("WARNING: " ++)-                            return $ Right x
− src/Language/Haskell/Liquid/Bare/Existential.hs 
@@ -1,110 +0,0 @@-module Language.Haskell.Liquid.Bare.Existential (-    txExpToBind-  ) where--import Control.Monad.State-import Data.Char--import qualified Data.HashMap.Strict as M--import Prelude hiding (error)-import Language.Fixpoint.Misc (fst3)-import Language.Fixpoint.Types.Names (headSym)-import Language.Fixpoint.Types (Expr(..), Symbol, symbol, exprReft)--import Language.Haskell.Liquid.Types.RefType (strengthen, uTop)-import Language.Haskell.Liquid.Types------------------------------------------------------------------------------------ | Replace Predicate Arguments With Existentials --------------------------------------------------------------------------------------------------------------data ExSt = ExSt { fresh :: Int-                 , emap  :: M.HashMap Symbol (RSort, Expr)-                 , pmap  :: M.HashMap Symbol RPVar-                 }---- | Niki: please write more documentation for this, maybe an example?--- I can't really tell whats going on... (RJ)--txExpToBind   :: SpecType -> SpecType-txExpToBind t = evalState (expToBindT t) (ExSt 0 M.empty πs)-  where πs = M.fromList [(pname p, p) | p <- ty_preds $ toRTypeRep t ]--expToBindT :: SpecType -> State ExSt SpecType-expToBindT (RVar v r)-  = expToBindRef r >>= addExists . RVar v-expToBindT (RFun x t1 t2 r)-  = do t1' <- expToBindT t1-       t2' <- expToBindT t2-       expToBindRef r >>= addExists . RFun x t1' t2'-expToBindT (RAllT a t)-  = liftM (RAllT a) (expToBindT 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-       expToBindRef r >>= addExists . RApp c ts' rs'-expToBindT (RAppTy t1 t2 r)-  = do t1' <- expToBindT t1-       t2' <- expToBindT t2-       expToBindRef r >>= addExists . RAppTy t1' t2'-expToBindT (RRTy xts r o t)-  = do xts' <- zip xs <$> mapM expToBindT ts-       r'   <- expToBindRef r-       t'   <- expToBindT t-       return $ RRTy xts' r' o t'-  where-     (xs, ts) = unzip xts-expToBindT t-  = return t--expToBindReft              :: SpecProp -> State ExSt SpecProp-expToBindReft (RProp s (RHole r)) = rPropP s <$> expToBindRef r-expToBindReft (RProp s t)  = RProp s  <$> expToBindT t---getBinds :: State ExSt (M.HashMap Symbol (RSort, Expr))-getBinds-  = do bds <- emap <$> get-       modify $ \st -> st{emap = M.empty}-       return bds--addExists :: SpecType -> State ExSt SpecType-addExists t = liftM (M.foldlWithKey' addExist t) getBinds--addExist :: SpecType -> Symbol -> (RSort, Expr) -> SpecType-addExist t x (tx, e) = REx x t' t-  where t' = (ofRSort tx) `strengthen` uTop r-        r  = 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--expToBind :: UsedPVar -> State ExSt UsedPVar-expToBind p-  = do Just π <- liftM (M.lookup (pname p)) (pmap <$> get)-       let pargs0 = zip (pargs p) (fst3 <$> pargs π)-       pargs' <- mapM expToBindParg pargs0-       return $ p{pargs = pargs'}--expToBindParg :: (((), Symbol, Expr), RSort) -> State ExSt ((), Symbol, Expr)-expToBindParg ((t, s, e), s') = liftM ((,,) t s) (expToBindExpr e s')--expToBindExpr :: Expr ->  RSort -> State ExSt Expr-expToBindExpr e@(EVar s) _ | isLower $ headSym $ symbol s-  = return e-expToBindExpr e t-  = do s <- freshSymbol-       modify $ \st -> st{emap = M.insert s (t, e) (emap st)}-       return $ EVar s--freshSymbol :: State ExSt Symbol-freshSymbol-  = do n <- fresh <$> get-       modify $ \s -> s{fresh = n+1}-       return $ symbol $ "ex#" ++ show n
src/Language/Haskell/Liquid/Bare/Expand.hs view
@@ -1,46 +1,645 @@-{-# LANGUAGE TupleSections        #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances    #-}+-- | This module has the code for applying refinement (and) type aliases +--   and the pipeline for "cooking" a @BareType@ into a @SpecType@. +--   TODO: _only_ export `makeRTEnv`, `cookSpecType` and maybe `qualifyExpand`... -module Language.Haskell.Liquid.Bare.Expand (-  -- * Alias Expansion-    ExpandAliases (..)-  , expand'+{-# LANGUAGE TupleSections         #-}+{-# LANGUAGE TypeSynonymInstances  #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE OverloadedStrings     #-}+++module Language.Haskell.Liquid.Bare.Expand +  ( -- * Create alias expansion environment+    makeRTEnv ++    -- * Expand and Qualify +  , qualifyExpand ++    -- * Converting BareType to SpecType+  , cookSpecType+  , cookSpecTypeE+  , specExpandType++    -- * Re-exported for data-constructors+  , plugHoles   ) where -import           Prelude                          hiding (error)-import           Control.Monad.State              hiding (forM)-import           Control.Monad.Except             (throwError)-import qualified Data.HashMap.Strict              as M-import qualified Language.Fixpoint.Types          as F-import           Language.Fixpoint.Types          (Expr(..), Reft(..), mkSubst, subst, eApps, splitEApp, Symbol, Subable)-import qualified Language.Haskell.Liquid.Misc     as Misc-import           Language.Haskell.Liquid.GHC.Misc-import           Language.Haskell.Liquid.Types-import           Language.Haskell.Liquid.Bare.Env-import           Text.PrettyPrint.HughesPJ+import Prelude hiding (error)+import Data.Graph hiding (Graph)+import Data.Maybe -expand' :: (ExpandAliases a) => a -> BareM a-expand' = expand (F.dummyPos "Bare.expand'")+import           Control.Monad.State+import qualified Control.Exception         as Ex+import qualified Data.HashMap.Strict       as M+import qualified Data.Char                 as Char+import qualified Data.List                 as L+import qualified Text.Printf               as Printf +import qualified Text.PrettyPrint.HughesPJ as PJ -class ExpandAliases a where-  expand :: F.SourcePos -> a -> BareM a+import qualified Language.Fixpoint.Types               as F +-- import qualified Language.Fixpoint.Types.Visitor       as F +import qualified Language.Fixpoint.Misc                as Misc +import           Language.Fixpoint.Types (Expr(..)) -- , Symbol, symbol) +import qualified Language.Haskell.Liquid.GHC.Misc      as GM +import qualified Language.Haskell.Liquid.GHC.API       as Ghc +import qualified Language.Haskell.Liquid.Types.RefType as RT +import           Language.Haskell.Liquid.Types         hiding (fresh)+import qualified Language.Haskell.Liquid.Misc          as Misc +import qualified Language.Haskell.Liquid.Measure       as Ms+import qualified Language.Haskell.Liquid.Bare.Resolve  as Bare+import qualified Language.Haskell.Liquid.Bare.Types    as Bare+import qualified Language.Haskell.Liquid.Bare.Plugged  as Bare -instance ExpandAliases Expr where-  expand = expandExpr+--------------------------------------------------------------------------------+-- | `makeRTEnv` initializes the env needed to `expand` refinements and types,+--   that is, the below needs to be called *before* we use `Expand.expand`+--------------------------------------------------------------------------------+makeRTEnv :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.ModSpecs -> LogicMap +          -> BareRTEnv +--------------------------------------------------------------------------------+makeRTEnv env m mySpec iSpecs lmap +          = renameRTArgs $ makeRTAliases tAs $ makeREAliases eAs+  where+    tAs   = [ t                   | (_, s)  <- specs, t <- Ms.aliases  s ]+    eAs   = [ specREAlias env m e | (m, s)  <- specs, e <- Ms.ealiases s ]+         ++ [ specREAlias env m e | (_, xl) <- M.toList (lmSymDefs lmap)+                                  , let e    = lmapEAlias xl             ]+    specs = (m, mySpec) : M.toList iSpecs -instance ExpandAliases Reft where-  expand = txPredReft' expandExpr+-- | We apply @renameRTArgs@ *after* expanding each alias-definition, to +--   ensure that the substitutions work properly (i.e. don't miss expressions +--   hidden inside @RExprArg@ or as strange type parameters. +renameRTArgs :: BareRTEnv -> BareRTEnv +renameRTArgs rte = RTE +  { typeAliases = M.map (fmap (renameVV . renameRTVArgs)) (typeAliases rte) +  , exprAliases = M.map (fmap (           renameRTVArgs)) (exprAliases rte) +  }  -instance ExpandAliases SpecType where-  expand z = mapReftM (expand z)+makeREAliases :: [Located (RTAlias F.Symbol F.Expr)] -> BareRTEnv +makeREAliases = graphExpand buildExprEdges f mempty +  where+    f rtEnv xt = setREAlias rtEnv (expandLoc rtEnv xt) -instance ExpandAliases Body where-  expand z (E e)   = E   <$> expand z e-  expand z (P e)   = P   <$> expand z e-  expand z (R x e) = R x <$> expand z e+renameVV :: RTAlias F.Symbol BareType -> RTAlias F.Symbol BareType +renameVV rt = rt { rtBody = RT.shiftVV (rtBody rt) (F.vv (Just 0)) } -instance ExpandAliases ty => ExpandAliases (Def ty ctor) where+-- | @renameRTVArgs@ ensures that @RTAlias@ value parameters have distinct names +--   to avoid variable capture e.g. as in tests-names-pos-Capture01.hs+renameRTVArgs :: (F.PPrint a, F.Subable a) => RTAlias x a -> RTAlias x a +renameRTVArgs rt = rt { rtVArgs = newArgs+                      , rtBody  = F.notracepp msg $ F.subst su (rtBody rt) +                      } +  where +    msg          = "renameRTVArgs: " ++ F.showpp su+    su           = F.mkSubst (zip oldArgs (F.eVar <$> newArgs)) +    newArgs      = zipWith rtArg (rtVArgs rt) [0..]+    oldArgs      = rtVArgs rt+    rtArg x i    = F.suffixSymbol x (F.intSymbol "rta" i) ++makeRTAliases :: [Located (RTAlias F.Symbol BareType)] -> BareRTEnv -> BareRTEnv  +makeRTAliases lxts rte = graphExpand buildTypeEdges f rte lxts +  where+    f rtEnv xt         = setRTAlias rtEnv (expandLoc rtEnv xt)++specREAlias :: Bare.Env -> ModName -> Located (RTAlias F.Symbol F.Expr) -> Located (RTAlias F.Symbol F.Expr) +specREAlias env m la = F.atLoc la $ a { rtBody = Bare.qualify env m (loc la) (rtVArgs a) (rtBody a) } +  where +    a     = val la ++--------------------------------------------------------------------------------------------------------------++graphExpand :: (PPrint t)+            => (AliasTable x t -> t -> [F.Symbol])         -- ^ dependencies+            -> (thing -> Located (RTAlias x t) -> thing) -- ^ update+            -> thing                                     -- ^ initial+            -> [Located (RTAlias x t)]                   -- ^ vertices+            -> thing                                     -- ^ final +graphExpand buildEdges expBody env lxts +           = L.foldl' expBody env (genExpandOrder table' graph)+  where +    -- xts    = val <$> lxts+    table  = buildAliasTable lxts+    graph  = buildAliasGraph (buildEdges table) lxts+    table' = checkCyclicAliases table graph++setRTAlias :: RTEnv x t -> Located (RTAlias x t) -> RTEnv x t +setRTAlias env a = env { typeAliases =  M.insert n a (typeAliases env) } +  where +    n            = rtName (val a)  ++setREAlias :: RTEnv x t -> Located (RTAlias F.Symbol F.Expr) -> RTEnv x t +setREAlias env a = env { exprAliases = M.insert n a (exprAliases env) } +  where +    n            = rtName (val a)++++--------------------------------------------------------------------------------+type AliasTable x t = M.HashMap F.Symbol (Located (RTAlias x t))++buildAliasTable :: [Located (RTAlias x t)] -> AliasTable x t+buildAliasTable = M.fromList . map (\rta -> (rtName (val rta), rta))++fromAliasSymbol :: AliasTable x t -> F.Symbol -> Located (RTAlias x t)+fromAliasSymbol table sym+  = fromMaybe err (M.lookup sym table)+  where+    err = panic Nothing ("fromAliasSymbol: Dangling alias symbol: " ++ show sym)++type Graph t = [Node t]+type Node  t = (t, t, [t])++buildAliasGraph :: (PPrint t) => (t -> [F.Symbol]) -> [Located (RTAlias x t)] +                -> Graph F.Symbol+buildAliasGraph buildEdges = map (buildAliasNode buildEdges)++buildAliasNode :: (PPrint t) => (t -> [F.Symbol]) -> Located (RTAlias x t) +               -> Node F.Symbol+buildAliasNode f la = (rtName a, rtName a, f (rtBody a))+  where +    a               = val la ++checkCyclicAliases :: AliasTable x t -> Graph F.Symbol -> AliasTable x t +checkCyclicAliases table graph+  = case mapMaybe go (stronglyConnComp graph) of+      []   -> table +      sccs -> Ex.throw (cycleAliasErr table <$> sccs)+    where+      go (CyclicSCC vs) = Just vs+      go (AcyclicSCC _) = Nothing++cycleAliasErr :: AliasTable x t -> [F.Symbol] -> Error+cycleAliasErr _ []          = panic Nothing "checkCyclicAliases: No type aliases in reported cycle"+cycleAliasErr t scc@(rta:_) = ErrAliasCycle { pos    = fst (locate rta)+                                            , acycle = map locate scc }+  where+    locate sym = ( GM.fSrcSpan $ fromAliasSymbol t sym+                 , pprint sym )+++genExpandOrder :: AliasTable x t -> Graph F.Symbol -> [Located (RTAlias x t)]+genExpandOrder table graph+  = map (fromAliasSymbol table) symOrder+  where+    (digraph, lookupVertex, _)+      = graphFromEdges graph+    symOrder+      = map (Misc.fst3 . lookupVertex) $ reverse $ topSort digraph++--------------------------------------------------------------------------------++ordNub :: Ord a => [a] -> [a]+ordNub = map head . L.group . L.sort++buildTypeEdges :: (F.Symbolic c) => AliasTable x t -> RType c tv r -> [F.Symbol]+buildTypeEdges table = ordNub . go+  where+    -- go :: t -> [Symbol]+    go (RApp c ts rs _) = go_alias (F.symbol c) ++ concatMap go ts ++ concatMap go (mapMaybe go_ref rs)+    go (RImpF _ t1 t2 _) = go t1 ++ go t2+    go (RFun _ t1 t2 _) = go t1 ++ go t2+    go (RAppTy t1 t2 _) = go t1 ++ go t2+    go (RAllE _ t1 t2)  = go t1 ++ go t2+    go (REx _ t1 t2)    = go t1 ++ go t2+    go (RAllT _ t)      = go t+    go (RAllP _ t)      = go t+    go (RAllS _ t)      = go t+    go (RVar _ _)       = []+    go (RExprArg _)     = []+    go (RHole _)        = []+    go (RRTy env _ _ t) = concatMap (go . snd) env ++ go t+    go_alias c          = [c | M.member c table]+    go_ref (RProp _ (RHole _)) = Nothing+    go_ref (RProp  _ t) = Just t++buildExprEdges :: M.HashMap F.Symbol a -> F.Expr -> [F.Symbol]+buildExprEdges table  = ordNub . go+  where+    go :: F.Expr -> [F.Symbol]+    go (EApp e1 e2)   = go e1 ++ go e2+    go (ENeg e)       = go e+    go (EBin _ e1 e2) = go e1 ++ go e2+    go (EIte _ e1 e2) = go e1 ++ go e2+    go (ECst e _)     = go e+    go (ESym _)       = []+    go (ECon _)       = []+    go (EVar v)       = go_alias v+    go (PAnd ps)       = concatMap go ps+    go (POr ps)        = concatMap go ps+    go (PNot p)        = go p+    go (PImp p q)      = go p ++ go q+    go (PIff p q)      = go p ++ go q+    go (PAll _ p)      = go p+    go (ELam _ e)      = go e+    go (ECoerc _ _ e)  = go e+    go (PAtom _ e1 e2) = go e1 ++ go e2+    go (ETApp e _)     = go e+    go (ETAbs e _)     = go e+    go (PKVar _ _)     = []+    go (PExist _ e)    = go e+    go (PGrad _ _ _ e) = go e+    go_alias f         = [f | M.member f table ]+++----------------------------------------------------------------------------------+-- | Using the `BareRTEnv` to do alias-expansion +----------------------------------------------------------------------------------+class Expand a where +  expand :: BareRTEnv -> F.SourcePos -> a -> a ++----------------------------------------------------------------------------------+-- | @qualifyExpand@ first qualifies names so that we can successfully resolve +--   them during expansion. +----------------------------------------------------------------------------------+qualifyExpand :: (Expand a, Bare.Qualify a) +              => Bare.Env -> ModName -> BareRTEnv -> F.SourcePos -> [F.Symbol] -> a -> a +----------------------------------------------------------------------------------+qualifyExpand env name rtEnv l bs+  = expand rtEnv l  +  . Bare.qualify env name l bs++----------------------------------------------------------------------------------+expandLoc :: (Expand a) => BareRTEnv -> Located a -> Located a +expandLoc rtEnv lx = expand rtEnv (F.loc lx) <$> lx ++instance Expand Expr where +  expand = expandExpr ++instance Expand F.Reft where+  expand rtEnv l (F.Reft (v, ra)) = F.Reft (v, expand rtEnv l ra) ++instance Expand RReft where+  expand rtEnv l = fmap (expand rtEnv l)++expandReft :: (Expand r) => BareRTEnv -> F.SourcePos -> RType c tv r -> RType c tv r +expandReft rtEnv l = fmap (expand rtEnv l)+-- expandReft rtEnv l = emapReft (expand rtEnv l)+++-- | @expand@ on a SpecType simply expands the refinements, +--   i.e. *does not* apply the type aliases, but just the +--   1. predicate aliases, +--   2. inlines,+--   3. stuff from @LogicMap@++instance Expand SpecType where+  expand = expandReft ++-- | @expand@ on a BareType actually applies the type- and expression- aliases.+instance Expand BareType where +  expand rtEnv l +    = expandReft     rtEnv l -- apply expression aliases +    . expandBareType rtEnv l -- apply type       aliases ++instance Expand (RTAlias F.Symbol Expr) where +  expand rtEnv l x = x { rtBody = expand rtEnv l (rtBody x) } ++instance Expand BareRTAlias where +  expand rtEnv l x = x { rtBody = expand rtEnv l (rtBody x) } ++instance Expand Body where +  expand rtEnv l (P   p) = P   (expand rtEnv l p) +  expand rtEnv l (E   e) = E   (expand rtEnv l e)+  expand rtEnv l (R x p) = R x (expand rtEnv l p)++instance Expand DataCtor where +  expand rtEnv l c = c+    { dcTheta  = expand rtEnv l (dcTheta c) +    , dcFields = [(x, expand rtEnv l t) | (x, t) <- dcFields c ] +    , dcResult = expand rtEnv l (dcResult c)+    }+ +instance Expand DataDecl where +  expand rtEnv l d = d +    { tycDCons  = expand rtEnv l (tycDCons  d)+    , tycPropTy = expand rtEnv l (tycPropTy d) +    } ++instance Expand BareMeasure where +  expand rtEnv l m = m +    { msSort = expand rtEnv l (msSort m) +    , msEqns = expand rtEnv l (msEqns m)+    } ++instance Expand BareDef where +  expand rtEnv l d = d +    { dsort = expand rtEnv l (dsort d) +    , binds = [ (x, expand rtEnv l t) | (x, t) <- binds d] +    , body  = expand rtEnv l (body  d) +    } ++instance Expand BareSpec where +  expand = expandBareSpec++instance Expand a => Expand (F.Located a) where +  expand rtEnv _ = expandLoc rtEnv ++instance Expand a => Expand (F.LocSymbol, a) where +  expand rtEnv l (x, y) = (x, expand rtEnv l y)++instance Expand a => Expand (Maybe a) where +  expand rtEnv l = fmap (expand rtEnv l) ++instance Expand a => Expand [a] where +  expand rtEnv l = fmap (expand rtEnv l) ++instance Expand a => Expand (M.HashMap k a) where +  expand rtEnv l = fmap (expand rtEnv l) ++expandBareSpec :: BareRTEnv -> F.SourcePos -> BareSpec -> BareSpec+expandBareSpec rtEnv l sp = sp +  { measures   = expand rtEnv l (measures   sp) +  , asmSigs    = expand rtEnv l (asmSigs    sp)+  , sigs       = expand rtEnv l (sigs       sp)+  , localSigs  = expand rtEnv l (localSigs  sp)+  , reflSigs   = expand rtEnv l (reflSigs   sp)+  , ialiases   = [ (f x, f y) | (x, y) <- ialiases sp ]+  , dataDecls  = expand rtEnv l (dataDecls  sp)+  , newtyDecls = expand rtEnv l (newtyDecls sp)+  } +  where f      = expand rtEnv l +  +expandBareType :: BareRTEnv -> F.SourcePos -> BareType -> BareType +expandBareType rtEnv _ = go +  where+    go (RApp c ts rs r)  = case lookupRTEnv c rtEnv of +                             Just rta -> expandRTAliasApp (GM.fSourcePos c) rta (go <$> ts) r +                             Nothing  -> RApp c (go <$> ts) (goRef <$> rs) r +    go (RAppTy t1 t2 r)  = RAppTy (go t1) (go t2) r+    go (RImpF x 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 (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)+    go t@(RHole {})      = t +    go t@(RVar {})       = t +    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)++expandRTAliasApp :: F.SourcePos -> Located BareRTAlias -> [BareType] -> RReft -> BareType +expandRTAliasApp l (Loc la _ rta) args r = case isOK of +  Just e     -> Ex.throw e+  Nothing    -> F.subst esu . (`RT.strengthen` r) . RT.subsTyVars_meet tsu $ rtBody rta+  where+    tsu       = zipWith (\α t -> (α, toRSort t, t)) αs ts+    esu       = F.mkSubst $ zip (F.symbol <$> εs) es+    es        = exprArg l msg <$> es0+    (ts, es0) = splitAt nαs args+    (αs, εs)  = (BTV <$> rtTArgs rta, rtVArgs rta)+    targs     = takeWhile (not . isRExprArg) args+    eargs     = dropWhile (not . isRExprArg) args++    -- ERROR Checking Code+    msg       = "EXPAND-RTALIAS-APP: " ++ F.showpp (rtName rta)+    nαs       = length αs+    nεs       = length εs +    nargs     = length args +    ntargs    = length targs+    neargs    = length eargs+    err       = errRTAliasApp l la rta +    isOK :: Maybe Error+    isOK+      | nargs /= ntargs + neargs+      = err $ PJ.hsep ["Expects", pprint nαs, "type arguments and then", pprint nεs, "expression arguments, but is given", pprint nargs]+      | nargs /= nαs + nεs+      = err $ PJ.hsep ["Expects", pprint nαs, "type arguments and "    , pprint nεs, "expression arguments, but is given", pprint nargs]+      | nαs /= ntargs, not (null eargs)+      = err $ PJ.hsep ["Expects", pprint nαs, "type arguments before expression arguments"]+      | otherwise+      = Nothing++isRExprArg :: RType c tv r -> Bool+isRExprArg (RExprArg _) = True +isRExprArg _            = False ++errRTAliasApp :: F.SourcePos -> F.SourcePos -> BareRTAlias -> PJ.Doc -> Maybe Error +errRTAliasApp l la rta = Just . ErrAliasApp  sp name sp' +  where +    name            = pprint              (rtName rta)+    sp              = GM.sourcePosSrcSpan l+    sp'             = GM.sourcePosSrcSpan la ++++--------------------------------------------------------------------------------+-- | exprArg converts a tyVar to an exprVar because parser cannot tell+--   this function allows us to treating (parsed) "types" as "value"+--   arguments, e.g. type Matrix a Row Col = List (List a Row) Col+--   Note that during parsing, we don't necessarily know whether a+--   string is a type or a value expression. E.g. in tests/pos/T1189.hs,+--   the string `Prop (Ev (plus n n))` where `Prop` is the alias:+--     {-@ type Prop E = {v:_ | prop v = E} @-}+--   the parser will chomp in `Ev (plus n n)` as a `BareType` and so+--   `exprArg` converts that `BareType` into an `Expr`.+--------------------------------------------------------------------------------+exprArg :: F.SourcePos -> String -> BareType -> Expr+exprArg l msg = F.notracepp ("exprArg: " ++ msg) . go +  where +    go :: BareType -> Expr+    go (RExprArg e)     = val e+    go (RVar x _)       = EVar (F.symbol x)+    go (RApp x [] [] _) = EVar (F.symbol x)+    go (RApp f ts [] _) = F.mkEApp (F.symbol <$> btc_tc f) (go <$> ts)+    go (RAppTy t1 t2 _) = F.EApp (go t1) (go t2)+    go z                = panic sp $ Printf.printf "Unexpected expression parameter: %s in %s" (show z) msg+    sp                  = Just (GM.sourcePosSrcSpan l)+++----------------------------------------------------------------------------------------+-- | @cookSpecType@ is the central place where a @BareType@ gets processed, +--   in multiple steps, into a @SpecType@. See [NOTE:Cooking-SpecType] for +--   details of each of the individual steps.+----------------------------------------------------------------------------------------+cookSpecType :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.PlugTV Ghc.Var -> LocBareType +             -> LocSpecType +cookSpecType env sigEnv name x bt+         = either Ex.throw id (cookSpecTypeE env sigEnv name x bt)+  where +    _msg = "cookSpecType: " ++ GM.showPpr (z, Ghc.varType <$> z)+    z    = Bare.plugSrc x +++-----------------------------------------------------------------------------------------+cookSpecTypeE :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.PlugTV Ghc.Var -> LocBareType +              -> Either UserError LocSpecType +-----------------------------------------------------------------------------------------+cookSpecTypeE env sigEnv name x bt+  = id +  . fmap (plugHoles sigEnv name x)+  . fmap (fmap (addTyConInfo   embs tyi))+  . fmap (Bare.txRefSort tyi embs)     +  . fmap (fmap txExpToBind)      -- What does this function DO+  . fmap (specExpandType rtEnv)                         +  . fmap (fmap (generalizeWith x))+  . fmap (maybePlug       sigEnv name x)+  . fmap (Bare.qualifyTop    env name l) +  . bareSpecType       env name +  . bareExpandType     rtEnv+  $ bt +  where +    _msg i = "cook-" ++ show i ++ " : " ++ F.showpp x+    rtEnv  = Bare.sigRTEnv    sigEnv+    embs   = Bare.sigEmbs     sigEnv +    tyi    = Bare.sigTyRTyMap sigEnv+    l      = F.loc bt++-- | We don't want to generalize type variables that maybe bound in the +--   outer scope, e.g. see tests/basic/pos/LocalPlug00.hs ++generalizeWith :: Bare.PlugTV Ghc.Var -> SpecType -> SpecType +generalizeWith (Bare.HsTV v) t = generalizeVar v t +generalizeWith  Bare.RawTV   t = t +generalizeWith _             t = RT.generalize t ++generalizeVar :: Ghc.Var -> SpecType -> SpecType +generalizeVar v t = mkUnivs as [] [] t +  where +    as            = filter isGen (freeTyVars t)+    (vas,_)       = Ghc.splitForAllTys (GM.expandVarType v) +    isGen (RTVar (RTV a) _) = a `elem` vas ++-- splitForAllTys :: Type -> ([TyVar], Type)+-- +-- generalize :: (Eq tv) => RType c tv r -> RType c tv r+-- generalize t = mkUnivs (freeTyVars t) [] [] t +++bareExpandType :: BareRTEnv -> LocBareType -> LocBareType +bareExpandType = expandLoc ++specExpandType :: BareRTEnv -> LocSpecType -> LocSpecType+specExpandType = expandLoc ++bareSpecType :: Bare.Env -> ModName -> LocBareType -> Either UserError LocSpecType +bareSpecType env name bt = case Bare.ofBareTypeE env name (F.loc bt) Nothing (val bt) of +  Left e  -> Left e +  Right t -> Right (F.atLoc bt t)++maybePlug :: Bare.SigEnv -> ModName -> Bare.PlugTV Ghc.Var -> LocSpecType -> LocSpecType +maybePlug sigEnv name kx = case Bare.plugSrc kx of +                             Nothing -> id  +                             Just _  -> plugHoles sigEnv name kx ++plugHoles :: Bare.SigEnv -> ModName -> Bare.PlugTV Ghc.Var -> LocSpecType -> LocSpecType +plugHoles sigEnv name = Bare.makePluggedSig name embs tyi exports+  where +    embs              = Bare.sigEmbs     sigEnv +    tyi               = Bare.sigTyRTyMap sigEnv +    exports           = Bare.sigExports  sigEnv ++{- [NOTE:Cooking-SpecType] +    A @SpecType@ is _raw_ when it is obtained directly from a @BareType@, i.e. +    just by replacing all the @BTyCon@ with @RTyCon@. Before it can be used +    for constraint generation, we need to _cook_ it via the following transforms:++    A @SigEnv@ should contain _all_ the information needed to do the below steps.++    - expand               : resolving all type/refinement etc. aliases +    - ofType               : convert BareType -> SpecType+    - plugged              : filling in any remaining "holes"+    - txRefSort            : filling in the abstract-refinement predicates etc. (YUCK) +    - resolve              : renaming / qualifying symbols?+    - expand (again)       : as the "resolve" step can rename variables to trigger more aliases (e.g. member -> Data.Set.Internal.Member -> Set_mem)+    - generalize           : (universally) quantify free type variables +    - strengthen-measures  : ?+    - strengthen-inline(?) : ? ++-}++-----------------------------------------------------------------------------------------------+-- | From BareOLD.Expand +-----------------------------------------------------------------------------------------------+++{- TODO-REBARE +instance Expand ty => Expand (Def ty ctor) where   expand z (Def f xts c t bxts b) =     Def f <$> expand z xts           <*> pure c@@ -48,101 +647,190 @@           <*> expand z bxts           <*> expand z b -instance ExpandAliases ty => ExpandAliases (Measure ty ctor) where-  expand z (M n t ds) =-    M n <$> expand z t <*> expand z ds+instance Expand ty => Expand (Measure ty ctor) where+  expand z (M n t ds k) =+    M n <$> expand z t <*> expand z ds <*> pure k -instance ExpandAliases DataConP where+instance Expand DataConP where   expand z d = do     tyRes'    <- expand z (tyRes     d)     tyConsts' <- expand z (tyConstrs d)     tyArgs'   <- expand z (tyArgs    d)     return d { tyRes =  tyRes', tyConstrs = tyConsts', tyArgs = tyArgs' }--instance ExpandAliases RReft where-  expand z = mapM (expand z)+-} -instance (ExpandAliases a) => ExpandAliases (Located a) where-  expand _ x = mapM (expand (F.loc x)) x+--------------------------------------------------------------------------------+-- | @expandExpr@ applies the aliases and inlines in @BareRTEnv@ to its argument +--   @Expr@. It must first @resolve@ the symbols in the refinement to see if +--   they correspond to alias definitions. However, we ensure that we do not +--   resolve bound variables (e.g. those bound in output refinements by input +--   parameters), and we use the @bs@ parameter to pass in the bound symbols.+--------------------------------------------------------------------------------+expandExpr :: BareRTEnv -> F.SourcePos -> Expr -> Expr+expandExpr rtEnv l      = go+  where+    go e@(EApp _ _)     = expandEApp rtEnv l (F.splitEApp e)+    go (EVar x)         = expandSym  rtEnv l x+    go (ENeg e)         = ENeg       (go e)+    go (ECst e s)       = ECst       (go e) s +    go (PAnd ps)        = PAnd       (go <$> ps)+    go (POr ps)         = POr        (go <$> ps)+    go (PNot p)         = PNot       (go p)+    go (PAll xs p)      = PAll xs    (go p)+    go (PExist xs p)    = PExist xs  (go p)+    go (ELam xt e)      = ELam xt    (go e)+    go (ECoerc a t e)   = ECoerc a t (go e)+    go (ETApp e s)      = ETApp      (go e) s +    go (ETAbs e s)      = ETAbs      (go e) s +    go (EBin op e1 e2)  = EBin op    (go e1) (go e2)+    go (PImp    e1 e2)  = PImp       (go e1) (go e2)+    go (PIff    e1 e2)  = PIff       (go e1) (go e2)+    go (PAtom b e1 e2)  = PAtom b    (go e1) (go e2)+    go (EIte  p e1 e2)  = EIte (go p)(go e1) (go e2)+    go (PGrad k su i e) = PGrad k su i (go e)+    go e@(PKVar _ _)    = e+    go e@(ESym _)       = e+    go e@(ECon _)       = e -instance (ExpandAliases a) => ExpandAliases (Maybe a) where-  expand z = mapM (expand z)+expandSym :: BareRTEnv -> F.SourcePos -> F.Symbol -> Expr+expandSym rtEnv l s' = expandEApp rtEnv l (EVar s', []) -instance (ExpandAliases a) => ExpandAliases [a] where-  expand z = mapM (expand z)+-- REBARE :: expandSym' :: Symbol -> BareM Symbol+-- REBARE :: expandSym' s = do+  -- REBARE :: axs <- gets axSyms+  -- REBARE :: let s' = dropModuleNamesAndUnique s+  -- REBARE :: return $ if M.member s' axs then s' else s -instance (ExpandAliases b) => ExpandAliases (a, b) where-  expand z = mapM (expand z)+expandEApp :: BareRTEnv -> F.SourcePos -> (Expr, [Expr]) -> Expr+expandEApp rtEnv l (EVar f, es) = case mBody of+    Just re -> expandApp l   re       es' +    Nothing -> F.eApps       (EVar f) es' +  where+    eAs     = exprAliases rtEnv+    mBody   = Misc.firstMaybes [M.lookup f eAs, M.lookup (GM.dropModuleUnique f) eAs]+    es'     = expandExpr rtEnv l <$> es+    _f0     = GM.dropModuleNamesAndUnique f ------------------------------------------------------------------------------------ Expand Reft Preds & Exprs -------------------------------------------------------------------------------------------------------------------------------------txPredReft' :: (a -> Expr -> BareM Expr) -> a -> Reft -> BareM Reft-txPredReft' f z (Reft (v, ra)) = Reft . (v,) <$> f z ra+expandEApp _ _ (f, es) = F.eApps f es  ----------------------------------------------------------------------------------- Expand Exprs ----------------------------------------------------------------+-- | Expand Alias Application -------------------------------------------------- ---------------------------------------------------------------------------------expandExpr :: F.SourcePos -> Expr -> BareM Expr-expandExpr sp = go+expandApp :: F.Subable ty => F.SourcePos -> Located (RTAlias F.Symbol ty) -> [Expr] -> ty+expandApp l lre es+  | Just su <- args = F.subst su (rtBody re)+  | otherwise       = Ex.throw err   where-    go e@(EApp _ _)    = {- tracepp ("EXPANDEAPP e = " ++ showpp e ) <$> -} expandEApp sp (splitEApp e)-    go (EVar x)        = expandSym sp x-    go (ENeg e)        = ENeg        <$> go e-    go (ECst e s)      = (`ECst` s)  <$> go e-    go (PAnd ps)       = PAnd        <$> mapM go ps-    go (POr ps)        = POr         <$> mapM go ps-    go (PNot p)        = PNot        <$> go p-    go (PAll xs p)     = PAll xs     <$> go p-    go (PExist s e)    = PExist s    <$> go e-    go (ELam xt e)     = ELam xt     <$> go e-    go (ECoerc a t e)  = ECoerc a t  <$> go e-    go (ETApp e s)     = (`ETApp` s) <$> go e-    go (ETAbs e s)     = (`ETAbs` s) <$> go e-    go (EBin op e1 e2) = EBin op     <$> go e1  <*> go e2-    go (PImp p q)      = PImp        <$> go p   <*> go q-    go (PIff p q)      = PIff        <$> go p   <*> go q-    go (PAtom b e e')  = PAtom b     <$> go e   <*> go e'-    go (EIte p e1 e2)  = EIte        <$> go p   <*> go e1 <*> go e2-    -- go e@(EVar _)      = return e-    go e@(PKVar _ _)   = return e-    go (PGrad k su i e)  = PGrad k su i <$> go e-    go e@(ESym _)      = return e-    go e@(ECon _)      = return e+    re              = F.val lre+    args            = F.mkSubst <$> Misc.zipMaybe (rtVArgs re) es+    err             :: UserError +    err             = ErrAliasApp sp alias sp' msg+    sp              = GM.sourcePosSrcSpan l+    alias           = pprint           (rtName re)+    sp'             = GM.fSrcSpan lre -- sourcePosSrcSpan (rtPos re)+    msg             =  "expects" PJ.<+> pprint (length $ rtVArgs re)+                   PJ.<+> "arguments but it is given"+                   PJ.<+> pprint (length es) -expandSym :: F.SourcePos -> Symbol -> BareM Expr-expandSym sp s = do-  s' <- expandSym' s-  expandEApp sp (EVar s', []) -expandSym' :: Symbol -> BareM Symbol-expandSym' s = do-  axs <- gets axSyms-  let s' = dropModuleNamesAndUnique s-  return $ if M.member s' axs then s' else s+-------------------------------------------------------------------------------+-- | Replace Predicate Arguments With Existentials ----------------------------+-------------------------------------------------------------------------------+txExpToBind   :: SpecType -> SpecType+-------------------------------------------------------------------------------+txExpToBind t = evalState (expToBindT t) (ExSt 0 M.empty πs)+  where +    πs        = M.fromList [(pname p, p) | p <- ty_preds $ toRTypeRep t ] -expandEApp :: F.SourcePos -> (Expr, [Expr]) -> BareM Expr-expandEApp sp (EVar f, es) = do-  eAs   <- gets (exprAliases . rtEnv)-  let mBody = Misc.firstMaybes [M.lookup f eAs, M.lookup (dropModuleUnique f) eAs]-  case mBody of-    Just re -> expandApp sp re =<< mapM (expandExpr sp) es-    Nothing -> eApps (EVar f)  <$> mapM (expandExpr sp) es-expandEApp _ (f, es) =-  return $ eApps f es+data ExSt = ExSt { fresh :: Int+                 , emap  :: M.HashMap F.Symbol (RSort, F.Expr)+                 , pmap  :: M.HashMap F.Symbol RPVar+                 } ------------------------------------------------------------------------------------ | Expand Alias Application ------------------------------------------------------------------------------------------------------------------------------------expandApp :: Subable ty => F.SourcePos -> RTAlias Symbol ty -> [Expr] -> BareM ty-expandApp l re es-  | Just su <- args = return     $ subst su (rtBody re)-  | otherwise       = throwError $ ErrAliasApp sp alias sp' msg+-- | TODO: Niki please write more documentation for this, maybe an example?+--   I can't really tell whats going on... (RJ)++expToBindT :: SpecType -> State ExSt SpecType+expToBindT (RVar v r)+  = expToBindRef r >>= addExists . RVar v+expToBindT (RFun x t1 t2 r)+  = do t1' <- expToBindT t1+       t2' <- expToBindT t2+       expToBindRef r >>= addExists . RFun x t1' t2'+expToBindT (RAllT a t)+  = liftM (RAllT a) (expToBindT 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+       expToBindRef r >>= addExists . RApp c ts' rs'+expToBindT (RAppTy t1 t2 r)+  = do t1' <- expToBindT t1+       t2' <- expToBindT t2+       expToBindRef r >>= addExists . RAppTy t1' t2'+expToBindT (RRTy xts r o t)+  = do xts' <- zip xs <$> mapM expToBindT ts+       r'   <- expToBindRef r+       t'   <- expToBindT t+       return $ RRTy xts' r' o t'   where-    args            = mkSubst <$> Misc.zipMaybe (rtVArgs re) es-    sp              = sourcePosSrcSpan l-    alias           = pprint           (rtName re)-    sp'             = sourcePosSrcSpan (rtPos re)-    msg             =  text "expects" <+> pprint (length $ rtVArgs re)-                   <+> text "arguments but it is given"-                   <+> pprint (length es)+     (xs, ts) = unzip xts+expToBindT t+  = return t++expToBindReft              :: SpecProp -> State ExSt SpecProp+expToBindReft (RProp s (RHole r)) = rPropP s <$> expToBindRef r+expToBindReft (RProp s t)  = RProp s  <$> expToBindT t+++getBinds :: State ExSt (M.HashMap F.Symbol (RSort, F.Expr))+getBinds+  = do bds <- emap <$> get+       modify $ \st -> st{emap = M.empty}+       return bds++addExists :: SpecType -> State ExSt SpecType+addExists t = liftM (M.foldlWithKey' addExist t) getBinds++addExist :: SpecType -> F.Symbol -> (RSort, F.Expr) -> SpecType+addExist t x (tx, e) = REx x t' t+  where +    t'               = (ofRSort tx) `strengthen` uTop r+    r                = F.exprReft e++expToBindRef :: UReft r -> State ExSt (UReft r)+expToBindRef (MkUReft r (Pr p) l)+  = mapM expToBind p >>= return . (\p -> MkUReft r p l). Pr++expToBind :: UsedPVar -> State ExSt UsedPVar+expToBind p = do +  res <- liftM (M.lookup (pname p)) (pmap <$> get)+  case res of +    Nothing -> +      panic Nothing ("expToBind: " ++ show p) +    Just π  -> do+      let pargs0 = zip (pargs p) (Misc.fst3 <$> pargs π)+      pargs' <- mapM expToBindParg pargs0+      return $ p { pargs = pargs' }++expToBindParg :: (((), F.Symbol, F.Expr), RSort) -> State ExSt ((), F.Symbol, F.Expr)+expToBindParg ((t, s, e), s') = liftM ((,,) t s) (expToBindExpr e s')++expToBindExpr :: F.Expr ->  RSort -> State ExSt F.Expr+expToBindExpr e@(EVar s) _ +  | Char.isLower $ F.headSym $ F.symbol s+  = return e+expToBindExpr e t+  = do s <- freshSymbol+       modify $ \st -> st{emap = M.insert s (t, e) (emap st)}+       return $ EVar s++freshSymbol :: State ExSt F.Symbol+freshSymbol+  = do n <- fresh <$> get+       modify $ \s -> s {fresh = n+1}+       return $ F.symbol $ "ex#" ++ show n+
+ src/Language/Haskell/Liquid/Bare/Laws.hs view
@@ -0,0 +1,54 @@+module Language.Haskell.Liquid.Bare.Laws ( makeInstanceLaws ) where++import qualified Data.Maybe                                 as Mb+import qualified Data.List                                  as L+import qualified Data.HashMap.Strict                        as M+import           Control.Monad (join)++import qualified Language.Haskell.Liquid.Measure            as Ms+import qualified Language.Fixpoint.Types                    as F+import qualified Language.Haskell.Liquid.GHC.Misc           as GM+import           Language.Haskell.Liquid.Bare.Types         as Bare +import           Language.Haskell.Liquid.Bare.Resolve       as Bare+import           Language.Haskell.Liquid.Bare.Expand        as Bare+import           Language.Haskell.Liquid.Types+import           Language.Haskell.Liquid.GHC.API            ++++makeInstanceLaws :: Bare.Env -> Bare.SigEnv -> [(Var,LocSpecType)] +                -> Bare.ModSpecs -> [LawInstance]+makeInstanceLaws env sigEnv sigs specs +  = [makeInstanceLaw env sigEnv sigs name rilaw +              | (name, spec) <- M.toList specs+              , rilaw <- Ms.ilaws spec ]+++makeInstanceLaw :: Bare.Env -> Bare.SigEnv -> [(Var,LocSpecType)] -> ModName  +                -> RILaws LocBareType -> LawInstance+makeInstanceLaw env sigEnv sigs name rilaw = LawInstance+  { lilName   = Mb.fromMaybe errmsg tc+  , liSupers  = mkTy <$> rilSupers rilaw +  , lilTyArgs = mkTy <$> rilTyArgs rilaw+  , lilEqus   = [(mkVar l, mkTypedVar r) | (l,r)<- rilEqus rilaw ]  +  , lilPos    = GM.sourcePosSrcSpan $ loc $ rilPos rilaw+  } +  where+    tc    :: Maybe Class +    tc     = classTc (rilName rilaw)+    errmsg = error ("Not a type class: " ++ F.showpp tc)++    classTc = join . fmap tyConClass_maybe . Bare.maybeResolveSym env name "makeClass" . btc_tc  ++    mkTy :: LocBareType -> LocSpecType+    mkTy = Bare.cookSpecType env sigEnv name Bare.GenTV +    mkVar :: LocSymbol -> VarOrLocSymbol +    mkVar x = case Bare.maybeResolveSym env name "makeInstanceLaw" x of +                Just v -> Left v +                _      -> Right x ++    mkTypedVar :: LocSymbol -> (VarOrLocSymbol, Maybe LocSpecType)+    mkTypedVar l = case mkVar l of +                     Left x -> (Left x, Just $ Mb.fromMaybe (dummyLoc $ ofType $ varType x) (L.lookup x sigs))+                     Right x -> (Right x, Nothing)+
− src/Language/Haskell/Liquid/Bare/Lookup.hs 
@@ -1,323 +0,0 @@-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE NoMonomorphismRestriction  #-}-{-# LANGUAGE OverloadedStrings          #-}--module Language.Haskell.Liquid.Bare.Lookup (-    GhcLookup(..)-  , lookupGhcVar-  , lookupGhcTyCon-  , lookupGhcDnTyCon-  , lookupGhcDataCon-  ) where--import           BasicTypes-import           ConLike-import           DataCon-import           GHC                              (HscEnv)-import           HscMain-import           Name-import           PrelInfo                         (wiredInIds, ghcPrimIds)-import           PrelNames                        (fromIntegerName, smallIntegerName, integerTyConName, basicKnownKeyNames, genericTyConNames) -- , getUnique)-import           Prelude                          hiding (error)-import           RdrName                          (mkQual, rdrNameOcc)-import           SrcLoc                           (SrcSpan, GenLocated(L))-import qualified SrcLoc-import           TcEnv-import           TyCon-import           TysWiredIn-import           Module-import           Finder-import           TcRnMonad-import           IfaceEnv-import           Var hiding (varName)-import           TysPrim-import           RdrName--- import PrelNames (ioTyConKey)-import           Control.Monad.Except             (catchError, throwError)-import           Control.Monad.State-import qualified Control.Exception as Ex--import           Data.Maybe-import           Text.PrettyPrint.HughesPJ        (text)-import qualified Data.HashMap.Strict              as M-import qualified Data.Text                        as T-import qualified Data.List                        as L-import           Data.Function                    (on)-import           Language.Fixpoint.Types.Names    (symbolText, isPrefixOfSym, lengthSym, symbolString)-import qualified Language.Fixpoint.Types          as F-import           Language.Fixpoint.Misc           as F-import qualified Language.Haskell.Liquid.GHC.Misc as GM-import qualified Language.Haskell.Liquid.Misc     as Misc-import           Language.Haskell.Liquid.Types-import           Language.Haskell.Liquid.Bare.Env---- import Debug.Trace (trace)------------------------------------------------------------------------------------- | Querying GHC for Id, Type, Class, Con etc. -------------------------------------------------------------------------------------------------------------------class F.Symbolic a => GhcLookup a where-  lookupName :: HscEnv -> ModName -> Maybe NameSpace -> a -> IO [Name]-  srcSpan    :: a -> SrcSpan--instance GhcLookup (Located F.Symbol) where-  lookupName e m ns = symbolLookup e m ns . val-  srcSpan           = GM.sourcePosSrcSpan . loc--instance GhcLookup Name where-  lookupName _ _ _ = return . (:[])-  srcSpan          = nameSrcSpan--instance GhcLookup FieldLabel where-  lookupName e m ns = lookupName e m ns . flSelector-  srcSpan           = srcSpan . flSelector--instance F.Symbolic FieldLabel where-  symbol = F.symbol . flSelector--instance GhcLookup DataName where-  lookupName e m ns = lookupName e m ns . dataNameSymbol-  srcSpan           = GM.fSrcSpanSrcSpan . F.srcSpan--lookupGhcThing :: (GhcLookup a, PPrint b) => String -> (TyThing -> Maybe (Int, b)) -> Maybe NameSpace -> a -> BareM b-lookupGhcThing name f ns x = lookupGhcThing' err f ns x >>= maybe (throwError err) return-  where-    err                 = ErrGhc (srcSpan x) (text msg)-    msg                 = unwords [ "Not in scope:", name, symbolicIdent x]--symbolicIdent :: (F.Symbolic a) => a -> String-symbolicIdent x = "'" ++ symbolicString x ++ "'"---lookupGhcThing' :: (GhcLookup a, PPrint b) => TError e -> (TyThing -> Maybe (Int, b)) -> Maybe NameSpace -> a -> BareM (Maybe b)-lookupGhcThing' _err f ns x = do-  be     <- get-  let env = hscEnv be-  ns     <- liftIO $ lookupName env (modName be) ns x-  ts     <- liftIO $ catMaybes <$> mapM (hscTcRcLookupName env) ns-  ts'    <- map (AConLike . RealDataCon)  . lookupEnv x <$> gets famEnv-  -- _      <- liftIO $ putStrLn ("lookupGhcThing: POST " ++ symbolicString x ++ show [(n, getSrcSpan n) | n <- ns] ++ GM.showPpr ts ++ GM.showPpr ts')-  let kts = catMaybes (f <$> (ts ++ ts'))-  -- hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)-  case Misc.nubHashOn showpp (minBy kts) of-    []  -> return Nothing-    [z] -> return (Just z)-    zs  -> uError $ ErrDupNames (srcSpan x) (pprint (F.symbol x)) (pprint <$> zs)--lookupEnv :: (GhcLookup a) => a -> M.HashMap F.Symbol b -> [b]-lookupEnv x env = maybeToList (M.lookup (F.symbol x) env)--minBy :: [(Int, a)] -> [a]-minBy kvs = case kvs' of-              (_, vs):_ -> vs-              []        -> []-  where-    kvs'  = L.sortBy (compare `on` fst) (F.groupList kvs)---_filterByName :: (F.Symbolic a, PPrint b) => a -> [b] -> [b]-_filterByName x = filter (L.isSuffixOf xKey . showpp)-  where-    xKey       = symbolicName x--symbolicName :: (F.Symbolic a) => a -> String-symbolicName = symbolString . GM.dropModuleNamesAndUnique . F.symbol-- -- ghcSymbolString = symbolString . dropModuleUnique--symbolicString :: F.Symbolic a => a -> String-symbolicString = symbolString . F.symbol---- liftIOErr :: TError e -> IO a -> BareM a--- liftIOErr e act = liftIO (act `catchError` \_ -> throwError e)--symbolLookup :: HscEnv -> ModName -> Maybe NameSpace -> F.Symbol -> IO [Name]-symbolLookup env mod ns k-  | k `M.member` wiredIn-  = return $ maybeToList $ M.lookup k wiredIn-  | otherwise-  = symbolLookupEnv env mod ns k--wiredIn      :: M.HashMap F.Symbol Name-wiredIn      = M.fromList $ special ++ wiredIns ++ wiredIns' ++ wiredTyCons ++ wiredDcCons-  where-    wiredIns  = [ (F.symbol n, n) | thing <- (wiredInIds ++ ghcPrimIds) {- NV CHECK -}, let n = getName thing ]-    wiredIns' = [ (F.symbol n, n) | n <- (genericTyConNames ++ basicKnownKeyNames)]-    wiredTyCons = [(F.symbol n, n) | n <- getName <$> (primTyCons ++ wiredInTyCons) ]-    wiredDcCons = [(F.symbol n, n) | n <- getName <$>-                      [ falseDataCon, trueDataCon-                      , ltDataCon, eqDataCon, gtDataCon-                      , nilDataCon, consDataCon-                      , charDataCon, intDataCon, wordDataCon, floatDataCon, doubleDataCon]]-    special   = [ ("GHC.Integer.smallInteger", smallIntegerName)-                , ("GHC.Integer.Type.Integer", integerTyConName)-                , ("GHC.Num.fromInteger"     , fromIntegerName ) ]--symbolLookupEnv :: HscEnv -> ModName -> Maybe NameSpace -> F.Symbol -> IO [Name]-symbolLookupEnv env mod ns k = do-  ns <- symbolLookupEnvOrig env mod ns k-  case ns of-    [] -> symbolLookupEnvFull env mod k-    _  -> return ns--safeParseIdentifier :: HscEnv -> String -> IO (SrcLoc.Located RdrName)-safeParseIdentifier env s = hscParseIdentifier env s `Ex.catch` handle-  where-    handle = uError . head . sourceErrors ("GHC error in safeParseIdentifier: " ++ s)--symbolLookupEnvOrig :: HscEnv -> ModName -> Maybe NameSpace -> F.Symbol -> IO [Name]-symbolLookupEnvOrig env mod namespace s-  | isSrcImport mod-  = do let modName = getModName mod-       L _ rn <- safeParseIdentifier env (ghcSymbolString s)-       let rn' = mkQual tcName (moduleNameFS modName,occNameFS $ rdrNameOcc rn)-       res    <- GM.lookupRdrName env modName (makeRdrName rn namespace)-       -- 'safeParseIdentifier' defaults constructors to 'DataCon's, but we also-       -- need to get the 'TyCon's for declarations like @data Foo = Foo Int@.-       res'   <- GM.lookupRdrName env modName rn'-       return $ catMaybes [res, res']-  | otherwise-  = do rn             <- safeParseIdentifier env (ghcSymbolString s)-       (_, lookupres) <- GM.tcRnLookupRdrName env rn-       case lookupres of-         Just ns -> return ns-         _       -> return []------ TODO: move to misc-makeRdrName :: RdrName -> Maybe NameSpace -> RdrName-makeRdrName (Unqual n) ns = Unqual $ makeOcc n ns-makeRdrName (Qual m n) ns = Qual m $ makeOcc n ns-makeRdrName (Orig m n) ns = Orig m $ makeOcc n ns-makeRdrName (Exact n)  _  = Exact n--makeOcc :: OccName -> Maybe NameSpace -> OccName-makeOcc n Nothing   = n-makeOcc n (Just ns) = mkOccNameFS ns (occNameFS n)--symbolLookupEnvFull :: HscEnv -> ModName -> F.Symbol -> IO [Name]-symbolLookupEnvFull hsc _m s = do-  let (modName, occName) =  ghcSplitModuleName s-  mbMod  <- lookupTheModule hsc modName-  case mbMod of-    Just mod -> liftIO $ F.singleton <$> lookupTheName hsc mod occName-    Nothing  -> return []--lookupTheModule :: HscEnv -> ModuleName -> IO (Maybe Module)-lookupTheModule hsc modName = do-  r <- findImportedModule hsc modName Nothing-  return $ case r of-    Found _ mod -> Just mod-    NotFound {fr_mods_hidden=(unitId:_)} -> Just (mkModule unitId modName)-    _ -> Nothing -- error "i don't know what to do here"--lookupTheName :: HscEnv -> Module -> OccName -> IO Name-lookupTheName hsc mod name = initTcForLookup hsc (lookupOrig mod name)---ghcSplitModuleName :: F.Symbol -> (ModuleName, OccName)-ghcSplitModuleName x = (mkModuleName $ ghcSymbolString m, mkTcOcc $ ghcSymbolString s)-  where-    (m, s)           = GM.splitModuleName x--ghcSymbolString :: F.Symbol -> String-ghcSymbolString = T.unpack . fst . T.breakOn "##" . symbolText--- ghcSymbolString = symbolString . dropModuleUnique------------------------------------------------------------------------------------- | It's possible that we have already resolved the 'Name' we are looking for,--- but have had to turn it back into a 'String', e.g. to be used in an 'Expr',--- as in @{v:Ordering | v = EQ}@. In this case, the fully-qualified 'Name'--- (@GHC.Types.EQ@) will likely not be in scope, so we store our own mapping of--- fully-qualified 'Name's to 'Var's and prefer pulling 'Var's from it.----------------------------------------------------------------------------------lookupGhcVar :: GhcLookup a => a -> BareM Var-lookupGhcVar x = do-  env <- gets varEnv-  case M.lookup (F.symbol x) env of-    Nothing -> lookupGhcThing "variable" fv (Just varName) x `catchError` \_ ->-               lookupGhcThing "variable or data constructor" fv (Just dataName) x-    Just v  -> return v-  where-    fv (AnId x)                   = Just (0, x)-    fv (AConLike (RealDataCon x)) = Just (1, dataConWorkId x)-    fv _                          = Nothing--lookupGhcDnTyCon :: String -> DataName -> BareM TyCon-lookupGhcDnTyCon src (DnName s)-                   = lookupGhcThing err ftc (Just tcName) s-  where-    err            = "type constructor " ++ src-    ftc (ATyCon x) = Just (0, x)-    ftc (AConLike (RealDataCon x))-                   = Just (1, dataConTyCon x)-      where-        res        = dataConTyCon x-        _ok        = res == listTyCon-    ftc _z         = GM.notracePpr ("lookupGhcDnTyCon 1 s = " ++ show s ++ "result = " ++ GM.showPpr _z)-                     $ Nothing--lookupGhcDnTyCon src (DnCon  s)-                   = lookupGhcThing err ftc (Just tcName) s-  where-    err            = "type konstructor " ++ src-    ftc (AConLike (RealDataCon x))-                   = GM.notracePpr ("lookupGhcDnTyCon 1 s = " ++ show s ++ "result = " ++ GM.showPpr x)-                     $ Just (1, dataConTyCon x)-    ftc (AConLike _z)-                   = GM.notracePpr ("lookupGhcDnTyCon 2 s = " ++ show s ++ "result = " ++ GM.showPpr _z)-                     $ Nothing-    ftc (AnId _z)-                   = GM.notracePpr ("lookupGhcDnTyCon 3 s = " ++ show s ++ "result = " ++ GM.showPpr _z)-                     $ Nothing-    ftc (ATyCon _z) = GM.notracePpr ("lookupGhcDnTyCon 4 s = " ++ show s ++ "result = " ++ GM.showPpr _z)-                     $ Nothing-    ftc _z          = GM.notracePpr ("lookupGhcDnTyCon 5 s = " ++ show s ++ "result = " ++ GM.showPpr _z)-                     $ Nothing--lookupGhcTyCon   ::  GhcLookup a => String -> a -> BareM TyCon-lookupGhcTyCon src s = do-  lookupGhcThing err ftc (Just tcName) s-    -- `catchError` \_ ->-    --  lookupGhcThing err fdc (Just tcName) s-  where-    -- s = trace ("lookupGhcTyCon: " ++ symbolicString _s) _s-    ftc (ATyCon x)-      = Just (0, {- GM.tracePpr ("lookupGHCTC2 s =" ++ symbolicIdent s) -} x)-    -- ftc (AConLike (RealDataCon x))-    --   = Just (1, dataConTyCon x)-    ftc (AConLike (RealDataCon x)) | GM.showPpr x == "GHC.Types.IO"-      = Just (0, dataConTyCon x)-    ftc (AConLike (RealDataCon x))-      = Just (1, promoteDataCon x)-    ftc _-      = Nothing--    err = "type constructor or class\n " ++ src--lookupGhcDataCon :: Located F.Symbol -> BareM DataCon-lookupGhcDataCon dc-  | Just n <- isTupleDC (val dc)-  = return $ tupleDataCon Boxed n-  | val dc == "[]"-  = return nilDataCon-  | val dc == ":"-  = return consDataCon-  | otherwise-  = lookupGhcDataCon' dc--isTupleDC :: F.Symbol -> Maybe Int-isTupleDC zs-  | "(," `isPrefixOfSym` zs-  = Just $ lengthSym zs - 1-  | otherwise-  = Nothing--lookupGhcDataCon' :: (GhcLookup a) => a -> BareM DataCon-lookupGhcDataCon' = lookupGhcThing "data constructor" fdc (Just dataName)-  where-    fdc (AConLike (RealDataCon x)) = Just (0, x)-    fdc _                          = Nothing
src/Language/Haskell/Liquid/Bare/Measure.hs view
@@ -6,108 +6,187 @@ --   . code- (CoreBind), and data- (Tycon) definitions into the spec level.  module Language.Haskell.Liquid.Bare.Measure-  ( makeHaskellDataDecls-  , makeHaskellMeasures+  ( makeHaskellMeasures   , makeHaskellInlines-  , makeHaskellBounds+  , makeHaskellDataDecls+  , makeMeasureSelectors   , makeMeasureSpec   , makeMeasureSpec'-  , makeClassMeasureSpec-  , makeMeasureSelectors-  , strengthenHaskellMeasures-  , strengthenHaskellInlines   , varMeasures+  , makeClassMeasureSpec+  -- , makeHaskellBounds   ) where -import CoreSyn-import DataCon-import TyCon-import Id-import Type hiding (isFunTy)--- import qualified Type-import Var- import Data.Default--- import Data.Either (either)+import qualified Control.Exception as Ex import Prelude hiding (mapM, error)-import Control.Monad hiding (forM, mapM)-import Control.Monad.Except hiding (forM, mapM)-import Control.Monad.State hiding (forM, mapM) import Data.Bifunctor-import Data.Maybe-import Data.Char (toUpper)--import TysWiredIn (boolTyCon) -- , wiredInTyCons)--import Data.Traversable (forM, mapM)+import qualified Data.Maybe as Mb import Text.PrettyPrint.HughesPJ (text)-import Text.Parsec.Pos (SourcePos)-import Text.Printf     (printf)-import qualified Data.List as L+-- import Text.Printf     (printf)  import qualified Data.HashMap.Strict as M import qualified Data.HashSet        as S -import Language.Fixpoint.Types (Symbol, dummySymbol, symbolString, symbol, Expr(..), meet)-import Language.Fixpoint.SortCheck (isFirstOrder)-+import           Language.Fixpoint.SortCheck (isFirstOrder) import qualified Language.Fixpoint.Types as F- import           Language.Haskell.Liquid.Transforms.CoreToLogic import qualified Language.Fixpoint.Misc                as Misc import qualified Language.Haskell.Liquid.Misc          as Misc import           Language.Haskell.Liquid.Misc             ((.||.))+import qualified Language.Haskell.Liquid.GHC.API       as Ghc  import qualified Language.Haskell.Liquid.GHC.Misc      as GM import qualified Language.Haskell.Liquid.Types.RefType as RT import           Language.Haskell.Liquid.Types-import           Language.Haskell.Liquid.Types.Bounds+-- import           Language.Haskell.Liquid.Types.Bounds import qualified Language.Haskell.Liquid.Measure       as Ms-import           Language.Haskell.Liquid.Bare.Env-import           Language.Haskell.Liquid.Bare.Misc       (simpleSymbolVar, hasBoolResult, makeDataConChecker, makeDataConSelector)-import           Language.Haskell.Liquid.Bare.Expand-import           Language.Haskell.Liquid.Bare.Lookup-import           Language.Haskell.Liquid.Bare.OfType-import           Language.Haskell.Liquid.Bare.Resolve-import           Language.Haskell.Liquid.Bare.ToBare +import qualified Language.Haskell.Liquid.Bare.Types    as Bare +import qualified Language.Haskell.Liquid.Bare.Resolve  as Bare +import qualified Language.Haskell.Liquid.Bare.Expand   as Bare +import qualified Language.Haskell.Liquid.Bare.DataType as Bare +import qualified Language.Haskell.Liquid.Bare.ToBare   as Bare + ---------------------------------------------------------------------------------makeHaskellDataDecls :: Config -> ModName -> Ms.BareSpec -> [TyCon] -> [DataDecl]+makeHaskellMeasures :: GhcSrc -> Bare.TycEnv -> LogicMap -> Ms.BareSpec+                    -> [Measure (Located BareType) LocSymbol] --------------------------------------------------------------------------------+makeHaskellMeasures src tycEnv lmap spec +          = Bare.measureToBare <$> ms+  where +    ms    = makeMeasureDefinition tycEnv lmap cbs <$> mSyms +    cbs   = nonRecCoreBinds   (giCbs src) +    mSyms = S.toList (Ms.hmeas spec)+  +makeMeasureDefinition :: Bare.TycEnv -> LogicMap -> [Ghc.CoreBind] -> LocSymbol +                      -> Measure LocSpecType Ghc.DataCon+makeMeasureDefinition tycEnv lmap cbs x = +  case GM.findVarDef (val x) cbs of+    Nothing       -> Ex.throw $ errHMeas x "Cannot extract measure from haskell function"+    Just (v, def) -> Ms.mkM vx vinfo mdef MsLifted (makeUnSorted (Ghc.varType v) mdef) +                     where +                       vx           = F.atLoc x (F.symbol v)+                       mdef         = coreToDef' tycEnv lmap vx v def+                       vinfo        = GM.varLocInfo logicType v++makeUnSorted :: Ghc.Type -> [Def LocSpecType Ghc.DataCon] -> UnSortedExprs+makeUnSorted t defs+  | isMeasureType ta +  = mempty+  | otherwise+  = map defToUnSortedExpr defs+  where+    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 t                  = t -- this should never happen!++    isMeasureType (Ghc.TyConApp _ ts) = all Ghc.isTyVarTy ts+    isMeasureType _                   = False  ++    defToUnSortedExpr def = (xx:(fst <$> binds def), +                             Ms.bodyPred (F.mkEApp (measure def) [F.expr xx]) (body def)) ++    xx = F.vv $ Just 10000++coreToDef' :: Bare.TycEnv -> LogicMap -> LocSymbol -> Ghc.Var -> Ghc.CoreExpr +           -> [Def LocSpecType Ghc.DataCon] +coreToDef' tycEnv lmap vx v def = +  case runToLogic embs lmap dm (errHMeas vx) (coreToDef vx v def) of+    Right l -> l+    Left e  -> Ex.throw e+  where +    embs    = Bare.tcEmbs       tycEnv +    dm      = Bare.tcDataConMap tycEnv  ++errHMeas :: LocSymbol -> String -> Error+errHMeas x str = ErrHMeas (GM.sourcePosSrcSpan $ loc x) (pprint $ val x) (text str)++--------------------------------------------------------------------------------+makeHaskellInlines :: GhcSrc -> F.TCEmb Ghc.TyCon -> LogicMap -> Ms.BareSpec +                   -> [(LocSymbol, LMap)]+--------------------------------------------------------------------------------+makeHaskellInlines src embs lmap spec +         = makeMeasureInline embs lmap cbs <$> inls +  where+    cbs  = nonRecCoreBinds (giCbs src) +    inls = S.toList        (Ms.inlines spec)++makeMeasureInline :: F.TCEmb Ghc.TyCon -> LogicMap -> [Ghc.CoreBind] -> LocSymbol+                  -> (LocSymbol, LMap)+makeMeasureInline embs lmap cbs x = +  case GM.findVarDef (val x) cbs of +    Nothing       -> Ex.throw $ errHMeas x "Cannot inline haskell function"+    Just (v, def) -> (vx, coreToFun' embs Nothing lmap vx v def ok)+                     where +                       vx         = F.atLoc x (F.symbol v)+                       ok (xs, e) = LMap vx (F.symbol <$> xs) (either id id e)++-- | @coreToFun'@ takes a @Maybe DataConMap@: we need a proper map when lifting +--   measures and reflects (which have case-of, and hence, need the projection symbols),+--   but NOT when lifting inlines (which do not have case-of). +--   For details, see [NOTE:Lifting-Stages] ++coreToFun' :: F.TCEmb Ghc.TyCon -> Maybe Bare.DataConMap -> LogicMap -> LocSymbol -> Ghc.Var -> Ghc.CoreExpr+           -> (([Ghc.Var], Either F.Expr F.Expr) -> a) -> a+coreToFun' embs dmMb lmap x v def ok = either Ex.throw ok act +  where +    act  = runToLogic embs lmap dm err xFun +    xFun = coreToFun x v def  +    err  = errHMeas x  +    dm   = Mb.fromMaybe mempty dmMb +++nonRecCoreBinds :: [Ghc.CoreBind] -> [Ghc.CoreBind]+nonRecCoreBinds            = concatMap go +  where +    go cb@(Ghc.NonRec _ _) = [cb]+    go    (Ghc.Rec xes)    = [Ghc.NonRec x e | (x, e) <- xes]++-------------------------------------------------------------------------------+makeHaskellDataDecls :: Config -> ModName -> Ms.BareSpec -> [Ghc.TyCon] +                     -> [DataDecl]+-------------------------------------------------------------------------------- makeHaskellDataDecls cfg name spec tcs-  | exactDC cfg = mapMaybe tyConDataDecl-                . F.notracepp "makeHaskellDataDecls-1"-                . zipMap   (hasDataDecl name spec . fst)-                . liftableTyCons-                . filter isReflectableTyCon-                $ tcs-  | otherwise   = []+  | exactDCFlag cfg = Mb.mapMaybe tyConDataDecl+                    -- . F.tracepp "makeHaskellDataDecls-3"+                    . zipMap   (hasDataDecl name spec . fst)+                    -- . F.tracepp "makeHaskellDataDecls-2"+                    . liftableTyCons+                    -- . F.tracepp "makeHaskellDataDecls-1"+                    . filter isReflectableTyCon+                    $ tcs+  | otherwise       = []  -isReflectableTyCon :: TyCon -> Bool-isReflectableTyCon  = isFamInstTyCon .||. isVanillaAlgTyCon+isReflectableTyCon :: Ghc.TyCon -> Bool+isReflectableTyCon  = Ghc.isFamInstTyCon .||. Ghc.isVanillaAlgTyCon -liftableTyCons :: [TyCon] -> [(TyCon, DataName)]-liftableTyCons = F.notracepp "LiftableTCs 3"-               . zipMapMaybe (tyConDataName True)-               . F.notracepp "LiftableTCs 2"-               . filter   (not . isBoxedTupleTyCon)-               . F.notracepp "LiftableTCs 1"-               -- . (`sortDiff` wiredInTyCons)-               -- . F.tracepp "LiftableTCs 0"+liftableTyCons :: [Ghc.TyCon] -> [(Ghc.TyCon, DataName)]+liftableTyCons +  = F.notracepp "LiftableTCs 3"+  . zipMapMaybe (tyConDataName True)+  . F.notracepp "LiftableTCs 2"+  . filter   (not . Ghc.isBoxedTupleTyCon)+  . F.notracepp "LiftableTCs 1"+  -- . (`sortDiff` wiredInTyCons)+  -- . F.tracepp "LiftableTCs 0"  zipMap :: (a -> b) -> [a] -> [(a, b)] zipMap f xs = zip xs (map f xs)  zipMapMaybe :: (a -> Maybe b) -> [a] -> [(a, b)]-zipMapMaybe f = mapMaybe (\x -> (x, ) <$> f x)+zipMapMaybe f = Mb.mapMaybe (\x -> (x, ) <$> f x) -hasDataDecl :: ModName -> Ms.BareSpec -> TyCon -> HasDataDecl+hasDataDecl :: ModName -> Ms.BareSpec -> Ghc.TyCon -> HasDataDecl hasDataDecl mod spec                  = \tc -> F.notracepp (msg tc) $ M.lookupDefault def (tcName tc) decls   where     msg tc       = "hasDataDecl " ++ show (tcName tc)     def          = NoDecl Nothing-    tcName       = fmap (qualifiedDataName mod) . tyConDataName True -- False+    tcName       = fmap (qualifiedDataName mod) . tyConDataName True     dcName       =       qualifiedDataName mod  . tycName     decls        = M.fromList [ (Just dn, hasDecl d)                                 | d     <- Ms.dataDecls spec@@ -118,43 +197,43 @@ qualifiedDataName mod (DnCon  lx) = DnCon  (qualifyModName mod <$> lx)  {-tyConDataDecl :: {tc:TyCon | isAlgTyCon tc} -> Maybe DataDecl @-}-tyConDataDecl :: ((TyCon, DataName), HasDataDecl) -> Maybe DataDecl+tyConDataDecl :: ((Ghc.TyCon, DataName), HasDataDecl) -> Maybe DataDecl tyConDataDecl (_, HasDecl)   = Nothing tyConDataDecl ((tc, dn), NoDecl szF)-  = Just $ D+  = Just $ DataDecl       { tycName   = dn-      , tycTyVars = symbol <$> GM.tyConTyVarsDef tc+      , tycTyVars = F.symbol <$> GM.tyConTyVarsDef tc       , tycPVars  = []       , tycTyLabs = []-      , tycDCons  = F.notracepp ("tyConDataDecl-DECLS: tc = " ++ show tc) $ decls tc+      , tycDCons  = decls tc       , tycSrcPos = GM.getSourcePos tc       , tycSFun   = szF       , tycPropTy = Nothing       , tycKind   = DataReflected       }-      where decls = map dataConDecl . tyConDataCons+      where decls = map dataConDecl . Ghc.tyConDataCons -tyConDataName :: Bool -> TyCon -> Maybe DataName+tyConDataName :: Bool -> Ghc.TyCon -> Maybe DataName tyConDataName full tc-  | vanillaTc  = Just (DnName ((post . symbol) <$> GM.locNamedThing tc))-  | d:_ <- dcs = Just (DnCon  ((post . symbol) <$> GM.locNamedThing d ))+  | vanillaTc  = Just (DnName ((post . F.symbol) <$> GM.locNamedThing tc))+  | d:_ <- dcs = Just (DnCon  ((post . F.symbol) <$> GM.locNamedThing d ))   | otherwise  = Nothing   where     post       = if full then id else GM.dropModuleNamesAndUnique-    vanillaTc  = isVanillaAlgTyCon tc-    dcs        = Misc.sortOn symbol (tyConDataCons tc)+    vanillaTc  = Ghc.isVanillaAlgTyCon tc+    dcs        = Misc.sortOn F.symbol (Ghc.tyConDataCons tc) -dataConDecl :: DataCon -> DataCtor-dataConDecl d     = F.notracepp msg $ DataCtor dx [] xts Nothing--- dataConDecl d     = F.tracepp msg $ DataCtor dx (RT.bareOfType <$> ps) xts outT+dataConDecl :: Ghc.DataCon -> DataCtor+dataConDecl d     = {- F.notracepp msg $ -} DataCtor dx (F.symbol <$> as) [] xts outT   where-    isGadt        = not (isVanillaDataCon d)-    msg           = printf "dataConDecl (gadt = %s)" (show isGadt)-    xts           = [(makeDataConSelector Nothing d i, RT.bareOfType t) | (i, t) <- its ]-    dx            = symbol <$> GM.locNamedThing d+    isGadt        = not (Ghc.isVanillaDataCon d)+    -- msg           = printf "dataConDecl (gadt = %s)" (show isGadt)+    xts           = [(Bare.makeDataConSelector Nothing d i, RT.bareOfType t) | (i, t) <- its ]+    dx            = F.symbol <$> GM.locNamedThing d     its           = zip [1..] ts-    (_,_ps,ts,t)   = dataConSig d+    (as,_ps,ts,t)  = Ghc.dataConSig d+    outT          = Just (RT.bareOfType t :: BareType)      _outT :: Maybe BareType     _outT       | isGadt    = Just (RT.bareOfType t)@@ -162,88 +241,22 @@   ----------------------------------------------------------------------------------makeHaskellMeasures :: F.TCEmb TyCon -> [CoreBind] -> Ms.BareSpec-                    -> BareM [Measure (Located BareType) LocSymbol]----------------------------------------------------------------------------------makeHaskellMeasures tce cbs spec = do-    lmap <- gets logicEnv-    dm   <- gets dcEnv-    ms   <- mapM (makeMeasureDefinition tce lmap dm cbs') (S.toList $ Ms.hmeas spec)-    return (measureToBare <$> ms)-  where-    cbs'                  = concatMap unrec cbs-    unrec cb@(NonRec _ _) = [cb]-    unrec (Rec xes)       = [NonRec x e | (x, e) <- xes] ----------------------------------------------------------------------------------makeHaskellInlines :: F.TCEmb TyCon -> [CoreBind] -> Ms.BareSpec-                   -> BareM [(LocSymbol, LMap)]----------------------------------------------------------------------------------makeHaskellInlines tce cbs spec = do-  lmap <- gets logicEnv-  mapM (makeMeasureInline tce lmap cbs') (S.toList $ Ms.inlines spec)-  where-    cbs'                  = concatMap unrec cbs-    unrec cb@(NonRec _ _) = [cb]-    unrec (Rec xes)       = [NonRec x e | (x, e) <- xes]  ---------------------------------------------------------------------------------makeMeasureInline :: F.TCEmb TyCon -> LogicMap -> [CoreBind] ->  LocSymbol-                  -> BareM (LocSymbol, LMap)----------------------------------------------------------------------------------makeMeasureInline tce lmap cbs x = maybe err chomp $ GM.findVarDef (val x) cbs-  where-    chomp (v, def)               = (vx, ) <$> coreToFun' tce lmap vx v def (ok vx)-                                      where vx = F.atLoc x (symbol v)-    err                          = throwError $ errHMeas x "Cannot inline haskell function"-    ok vx (xs, e)                = return (LMap vx (symbol <$> xs) (either id id e))--makeMeasureDefinition-  :: F.TCEmb TyCon -> LogicMap -> DataConMap -> [CoreBind] -> LocSymbol-  -> BareM (Measure LocSpecType DataCon)-makeMeasureDefinition tce lmap dm cbs x = maybe err chomp $ GM.findVarDef (val x) cbs-  where-    chomp (v, def)     = Ms.mkM vx (GM.varLocInfo logicType v) <$> coreToDef' vx v def-                         where vx = F.atLoc x (symbol v)-    coreToDef' x v def = case runToLogic tce lmap dm mkErr (coreToDef x v def) of-                           Right l -> return     l-                           Left e  -> throwError e--    mkErr :: String -> Error-    mkErr str = ErrHMeas (GM.sourcePosSrcSpan $ loc x) (pprint $ val x) (text str)-    err       = throwError $ mkErr "Cannot extract measure from haskell function"--errHMeas :: LocSymbol -> String -> Error-errHMeas x str = ErrHMeas (GM.sourcePosSrcSpan $ loc x) (pprint $ val x) (text str)--strengthenHaskellInlines  :: S.HashSet (Located Var) -> [(Var, LocSpecType)] -> [(Var, LocSpecType)]-strengthenHaskellInlines  = strengthenHaskell strengthenResult--strengthenHaskellMeasures :: S.HashSet (Located Var) -> [(Var, LocSpecType)] -> [(Var, LocSpecType)]-strengthenHaskellMeasures = strengthenHaskell strengthenResult'--strengthenHaskell :: (Var -> SpecType) -> S.HashSet (Located Var) -> [(Var, LocSpecType)] -> [(Var, LocSpecType)]-strengthenHaskell strengthen hmeas sigs-  = go <$> Misc.groupList (reverse sigs ++ hsigs)-  where-    hsigs      = [(val x, x {val = strengthen $ val x}) | x <- S.toList hmeas]-    go (v, xs) = (v,) $ L.foldl1' (flip meetLoc) xs--meetLoc :: Located SpecType -> Located SpecType -> LocSpecType-meetLoc t1 t2 = t1 {val = val t1 `meet` val t2}---------------------------------------------------------------------------------- -- | 'makeMeasureSelectors' converts the 'DataCon's and creates the measures for --   the selectors and checkers that then enable reflection. -------------------------------------------------------------------------------- -makeMeasureSelectors :: Config -> DataConMap -> (DataCon, Located DataConP) -> [Measure SpecType DataCon]-makeMeasureSelectors cfg dm (dc, Loc l l' (DataConP _ _vs _ps _ _ xts _resTy isGadt _ _))-  = (Misc.condNull (exactDC cfg) $ checker : catMaybes (go' <$> fields)) --  internal measures, needed for reflection- ++ (Misc.condNull (autofields)  $           catMaybes (go  <$> fields)) --  user-visible measures.+makeMeasureSelectors :: Config -> Bare.DataConMap -> Located DataConP -> [Measure SpecType Ghc.DataCon]+makeMeasureSelectors cfg dm (Loc l l' c)+  = (Misc.condNull (exactDCFlag cfg) $ checker : Mb.catMaybes (go' <$> fields)) --  internal measures, needed for reflection+ ++ (Misc.condNull (autofields)      $           Mb.catMaybes (go  <$> fields)) --  user-visible measures.   where-    autofields = not (isGadt || noMeasureFields cfg)+    dc         = dcpCon    c +    isGadt     = dcpIsGadt c +    xts        = dcpTyArgs c+    autofields = not (isGadt)     go ((x, t), i)       -- do not make selectors for functional fields       | isFunTy t && not (higherOrderFlag cfg)@@ -256,45 +269,45 @@       | isFunTy t && not (higherOrderFlag cfg)       = Nothing       | otherwise-      = Just $ makeMeasureSelector (Loc l l' (makeDataConSelector (Just dm) dc i)) (projT i) dc n i+      = Just $ makeMeasureSelector (Loc l l' (Bare.makeDataConSelector (Just dm) dc i)) (projT i) dc n i      fields   = zip (reverse xts) [1..]     n        = length xts-    checker  = makeMeasureChecker (Loc l l' (makeDataConChecker dc)) checkT dc n+    checker  = makeMeasureChecker (Loc l l' (Bare.makeDataConChecker dc)) checkT dc n     projT i  = dataConSel dc n (Proj i)     checkT   = dataConSel dc n Check -dataConSel :: DataCon -> Int -> DataConSel -> SpecType-dataConSel dc n Check    = mkArrow as [] [] [xt] bareBool+dataConSel :: Ghc.DataCon -> Int -> DataConSel -> SpecType+dataConSel dc n Check    = mkArrow as [] [] [] [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 as [] [] [] [xt] (mempty <$> ti)   where-    ti                   = fromMaybe err $ Misc.getNth (i-1) ts+    ti                   = Mb.fromMaybe err $ Misc.getNth (i-1) ts     (as, ts, xt)         = {- F.tracepp ("bkDatacon dc = " ++ F.showpp (dc, n)) $ -} bkDataCon dc n     err                  = panic Nothing $ "DataCon " ++ show dc ++ "does not have " ++ show i ++ " fields"  -- bkDataCon :: DataCon -> Int -> ([RTVar RTyVar RSort], [SpecType], (Symbol, SpecType, RReft))-bkDataCon :: (F.Reftable r) => DataCon -> Int -> ([RTVar RTyVar RSort], [RRType r], (Symbol, RRType r, r))-bkDataCon dc nFlds  = (as, ts, (dummySymbol, t, mempty))+bkDataCon :: (F.Reftable (RTProp RTyCon RTyVar r), PPrint r, F.Reftable r) => Ghc.DataCon -> Int -> ([RTVar RTyVar RSort], [RRType r], (F.Symbol, RRType r, r))+bkDataCon dc nFlds  = (as, ts, (F.dummySymbol, t, mempty))   where     ts                = RT.ofType <$> Misc.takeLast nFlds _ts-    t                 = {- traceShow ("bkDataConResult" ++ GM.showPpr (_t, t0)) $ -}-                        RT.ofType  $ mkTyConApp tc tArgs'+    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-    tArgs'            = take (nArgs - nVars) tArgs ++ (mkTyVarTy <$> αs)+    tArgs'            = take (nArgs - nVars) tArgs ++ (Ghc.mkTyVarTy <$> αs)     nVars             = length αs     nArgs             = length tArgs-    (tc, tArgs)       = fromMaybe err (splitTyConApp_maybe _t)+    (tc, tArgs)       = Mb.fromMaybe err (Ghc.splitTyConApp_maybe _t)     err               = GM.namedPanic dc ("Cannot split result type of DataCon " ++ show dc)-    hammer dc         = (dataConFullSig dc, Var.varType . dataConWorkId $ dc)+    hammer dc         = (Ghc.dataConFullSig dc, Ghc.varType . Ghc.dataConWorkId $ dc)  data DataConSel = Check | Proj Int  bareBool :: SpecType-bareBool = RApp (RTyCon boolTyCon [] def) [] [] mempty+bareBool = RApp (RTyCon Ghc.boolTyCon [] def) [] [] mempty   {- | NOTE:Use DataconWorkId@@ -305,110 +318,159 @@  -} -makeMeasureSelector :: (Show a1)-                    => LocSymbol -> SpecType -> DataCon -> Int -> a1 -> Measure SpecType DataCon-makeMeasureSelector x s dc n i = M {name = x, sort = s, eqns = [eqn]}+makeMeasureSelector :: (Show a1) => LocSymbol -> SpecType -> Ghc.DataCon -> Int -> a1 -> Measure SpecType Ghc.DataCon+makeMeasureSelector x s dc n i = M { msName = x, msSort = s, msEqns = [eqn], msKind = MsSelector, msUnSorted = mempty}   where-    eqn                        = Def x [] dc Nothing args (E (EVar $ mkx i))+    eqn                        = Def x dc Nothing args (E (F.EVar $ mkx i))     args                       = ((, Nothing) . mkx) <$> [1 .. n]-    mkx j                      = symbol ("xx" ++ show j)+    mkx j                      = F.symbol ("xx" ++ show j) -makeMeasureChecker :: LocSymbol -> SpecType -> DataCon -> Int -> Measure SpecType DataCon-makeMeasureChecker x s0 dc n = M {name = x, sort = s, eqns = eqn : (eqns <$> filter (/= dc) dcs)}+makeMeasureChecker :: LocSymbol -> SpecType -> Ghc.DataCon -> Int -> Measure SpecType Ghc.DataCon+makeMeasureChecker x s0 dc n = M { msName = x, msSort = s, msEqns = eqn : (eqns <$> filter (/= dc) dcs), msKind = MsChecker, msUnSorted = mempty }   where     s       = F.notracepp ("makeMeasureChecker: " ++ show x) s0-    eqn     = Def x [] dc Nothing (((, Nothing) . mkx) <$> [1 .. n])       (P F.PTrue)-    eqns d  = Def x [] d  Nothing (((, Nothing) . mkx) <$> [1 .. nArgs d]) (P F.PFalse)-    nArgs d = length (dataConOrigArgTys d)-    mkx j   = symbol ("xx" ++ show j)-    dcs     = tyConDataCons (dataConTyCon dc)+    eqn     = Def x dc Nothing (((, Nothing) . mkx) <$> [1 .. n])       (P F.PTrue)+    eqns d  = Def x d  Nothing (((, Nothing) . mkx) <$> [1 .. nArgs d]) (P F.PFalse)+    nArgs d = length (Ghc.dataConOrigArgTys d)+    mkx j   = F.symbol ("xx" ++ show j)+    dcs     = Ghc.tyConDataCons (Ghc.dataConTyCon dc) -makeMeasureSpec :: (ModName, Ms.BareSpec) -> BareM (Ms.MSpec SpecType DataCon)-makeMeasureSpec (mod, spec) = inModule mod mkSpec-  where-    mkSpec = mkMeasureDCon =<< mkMeasureSort =<< first val <$> m-    m      = Ms.mkMSpec <$> mapM expandMeasure (Ms.measures spec)-                        <*> return (Ms.cmeasures spec)-                        <*> mapM expandMeasure (Ms.imeasures spec) -makeMeasureSpec' :: MSpec SpecType DataCon-                 -> ([(Var, SpecType)], [(LocSymbol, RRType F.Reft)])-makeMeasureSpec' = Misc.mapFst (Misc.mapSnd RT.uRType <$>) . Ms.dataConTypes . first (mapReft ur_reft)+----------------------------------------------------------------------------------------------+makeMeasureSpec' :: MSpec SpecType Ghc.DataCon -> ([(Ghc.Var, SpecType)], [(LocSymbol, RRType F.Reft)])+----------------------------------------------------------------------------------------------+makeMeasureSpec' mspec0 = (ctorTys, measTys) +  where +    ctorTys             = Misc.mapSnd RT.uRType <$> ctorTys0+    (ctorTys0, measTys) = Ms.dataConTypes mspec +    mspec               = first (mapReft ur_reft) mspec0 -makeClassMeasureSpec :: MSpec (RType c tv (UReft r2)) t-                     -> [(LocSymbol, CMeasure (RType c tv r2))]-makeClassMeasureSpec (Ms.MSpec {..}) = tx <$> M.elems cmeasMap-  where-    tx (M n s _) = (n, CM n (mapReft ur_reft s))+----------------------------------------------------------------------------------------------+makeMeasureSpec :: Bare.Env -> Bare.SigEnv -> ModName -> (ModName, Ms.BareSpec) -> Ms.MSpec SpecType Ghc.DataCon+----------------------------------------------------------------------------------------------+makeMeasureSpec env sigEnv myName (name, spec) +  = mkMeasureDCon env               name +  . mkMeasureSort env               name +  . first val +  . bareMSpec     env sigEnv myName name +  $ spec  +bareMSpec :: Bare.Env -> Bare.SigEnv -> ModName -> ModName -> Ms.BareSpec -> Ms.MSpec LocBareType LocSymbol +bareMSpec env sigEnv myName name spec = Ms.mkMSpec ms cms ims +  where+    cms        = F.notracepp "CMS" $ filter inScope1 $             Ms.cmeasures spec+    ms         = F.notracepp "UMS" $ filter inScope2 $ expMeas <$> Ms.measures  spec+    ims        = F.notracepp "IMS" $ filter inScope2 $ expMeas <$> Ms.imeasures spec+    expMeas    = expandMeasure env name  rtEnv+    rtEnv      = Bare.sigRTEnv          sigEnv+    force      = name == myName +    inScope1 z = F.notracepp ("inScope1: " ++ F.showpp (msName z)) $ (force ||  okSort z)+    inScope2 z = F.notracepp ("inScope2: " ++ F.showpp (msName z)) $ (force || (okSort z && okCtors z))+    okSort     = Bare.knownGhcType env name . msSort +    okCtors    = all (Bare.knownGhcDataCon env name . ctor) . msEqns  -mkMeasureDCon :: Ms.MSpec t LocSymbol -> BareM (Ms.MSpec t DataCon)-mkMeasureDCon m-  = mkMeasureDCon_ m <$> forM (measureCtors m)-                           (\n -> (val n,) <$> lookupGhcDataCon n)+mkMeasureDCon :: Bare.Env -> ModName -> Ms.MSpec t LocSymbol -> Ms.MSpec t Ghc.DataCon+mkMeasureDCon env name m = mkMeasureDCon_ m [ (val n, symDC n) | n <- measureCtors m ]+  where +    symDC                = Bare.lookupGhcDataCon env name "measure-datacon" -mkMeasureDCon_ :: Ms.MSpec t LocSymbol -> [(Symbol, DataCon)] -> Ms.MSpec t DataCon+mkMeasureDCon_ :: Ms.MSpec t LocSymbol -> [(F.Symbol, Ghc.DataCon)] -> Ms.MSpec t Ghc.DataCon mkMeasureDCon_ m ndcs = m' {Ms.ctorMap = cm'}   where     m'                = fmap (tx.val) m-    cm'               = Misc.hashMapMapKeys (symbol . tx) $ Ms.ctorMap m'+    cm'               = Misc.hashMapMapKeys (F.symbol . tx) $ Ms.ctorMap m'     tx                = Misc.mlookup (M.fromList ndcs)  measureCtors ::  Ms.MSpec t LocSymbol -> [LocSymbol] measureCtors = Misc.sortNub . fmap ctor . concat . M.elems . Ms.ctorMap -mkMeasureSort ::  Ms.MSpec BareType LocSymbol -> BareM (Ms.MSpec SpecType LocSymbol)-mkMeasureSort (Ms.MSpec c mm cm im)-  = Ms.MSpec <$> forM c (mapM txDef) <*> forM mm tx <*> forM cm tx <*> forM im tx+mkMeasureSort :: Bare.Env -> ModName -> Ms.MSpec BareType LocSymbol +              -> Ms.MSpec SpecType LocSymbol+mkMeasureSort env name (Ms.MSpec c mm cm im) = +  Ms.MSpec (map txDef <$> c) (tx <$> mm) (tx <$> cm) (tx <$> im)      where-      tx :: Measure BareType ctor -> BareM (Measure SpecType ctor)-      tx (M n s eqs) = M n <$> ofMeaSort s <*> mapM txDef eqs+      ofMeaSort :: F.SourcePos -> BareType -> SpecType+      ofMeaSort l = Bare.ofBareType env name l Nothing  -      txDef :: Def BareType ctor -> BareM (Def SpecType ctor)-      txDef def = liftM3 (\xs t bds-> def{ dparams = xs, dsort = t, binds = bds})-                  (mapM (Misc.mapSndM ofMeaSort) (dparams def))-                  (mapM ofMeaSort $ dsort def)-                  (mapM (Misc.mapSndM $ mapM ofMeaSort) (binds def))+      tx :: Measure BareType ctor -> (Measure SpecType ctor)+      tx (M n s eqs k u) = M n (ofMeaSort l s) (txDef <$> eqs) k u where l = GM.fSourcePos n +      txDef :: Def BareType ctor -> (Def SpecType ctor)+      txDef d = first (ofMeaSort l) d                              where l = GM.fSourcePos (measure d)  -varMeasures :: (Monoid r) => [Var] -> [(Symbol, Located (RRType r))]-varMeasures vars = [ (symbol v, varSpecType v)  | v <- vars-                                                , GM.isDataConId v-                                                , isSimpleType $ varType v ] -isSimpleType :: Type -> Bool-isSimpleType = isFirstOrder . RT.typeSort M.empty+  +--------------------------------------------------------------------------------+-- | Expand Measures -----------------------------------------------------------+--------------------------------------------------------------------------------+-- type BareMeasure = Measure LocBareType LocSymbol -varSpecType :: (Monoid r) => Var -> Located (RRType r)-varSpecType = fmap (RT.ofType . varType) . GM.locNamedThing+expandMeasure :: Bare.Env -> ModName -> BareRTEnv -> BareMeasure -> BareMeasure+expandMeasure env name rtEnv m = m +  { msSort = RT.generalize                   <$> msSort m+  , msEqns = expandMeasureDef env name rtEnv <$> msEqns m +  } -makeHaskellBounds :: F.TCEmb TyCon -> CoreProgram -> S.HashSet (Var, LocSymbol) -> BareM RBEnv-makeHaskellBounds tce cbs xs = do+expandMeasureDef :: Bare.Env -> ModName -> BareRTEnv -> Def t LocSymbol -> Def t LocSymbol+expandMeasureDef env name rtEnv d = d +  { body  = F.notracepp msg $ Bare.qualifyExpand env name rtEnv l bs (body d) }+  where +    l     = loc (measure d) +    bs    = fst <$> binds d +    msg   = "QUALIFY-EXPAND-BODY" ++ F.showpp (bs, body d) ++------------------------------------------------------------------------------+varMeasures :: (Monoid r) => Bare.Env -> [(F.Symbol, Located (RRType r))]+------------------------------------------------------------------------------+varMeasures env = +  [ (F.symbol v, varSpecType v) +      | v <- knownVars env +      , GM.isDataConId v+      , isSimpleType (Ghc.varType v) ]++knownVars :: Bare.Env -> [Ghc.Var]+knownVars env = [ v | (_, xThings)   <- M.toList (Bare._reTyThings env) +                    , (_,Ghc.AnId v) <- xThings +                ]++varSpecType :: (Monoid r) => Ghc.Var -> Located (RRType r)+varSpecType = fmap (RT.ofType . Ghc.varType) . GM.locNamedThing++isSimpleType :: Ghc.Type -> Bool+isSimpleType = isFirstOrder . RT.typeSort mempty++makeClassMeasureSpec :: MSpec (RType c tv (UReft r2)) t+                     -> [(LocSymbol, CMeasure (RType c tv r2))]+makeClassMeasureSpec (Ms.MSpec {..}) = tx <$> M.elems cmeasMap+  where+    tx (M n s _ _ _) = (n, CM n (mapReft ur_reft s))+++{- +expandMeasureBody :: Bare.Env -> ModName -> BareRTEnv -> SourcePos -> Body -> Body+expandMeasureBody env name rtEnv l (P   p) = P   (Bare.expandQualify env name rtEnv l p) +expandMeasureBody env name rtEnv l (R x p) = R x (Bare.expandQualify env name rtEnv l p) +expandMeasureBody env name rtEnv l (E   e) = E   (Bare.expandQualify env name rtEnv l e) +++makeHaskellBounds :: F.TCEmb TyCon -> CoreProgram -> S.HashSet (Var, LocSymbol) -> BareM RBEnv  -- TODO-REBARE+makeHaskellBounds embs cbs xs = do   lmap <- gets logicEnv-  M.fromList <$> mapM (makeHaskellBound tce lmap cbs) (S.toList xs)+  M.fromList <$> mapM (makeHaskellBound embs lmap cbs) (S.toList xs)  makeHaskellBound :: F.TCEmb TyCon                  -> LogicMap                  -> [Bind Var]                  -> (Var, Located Symbol)                  -> BareM (LocSymbol, RBound)-makeHaskellBound tce lmap  cbs (v, x) =+makeHaskellBound embs lmap  cbs (v, x) =   case filter ((v  `elem`) . GM.binders) cbs of-    (NonRec v def:_)   -> toBound v x <$> coreToFun' tce lmap x v def return-    (Rec [(v, def)]:_) -> toBound v x <$> coreToFun' tce lmap x v def return+    (NonRec v def:_)   -> toBound v x <$> coreToFun' embs lmap x v def return+    (Rec [(v, def)]:_) -> toBound v x <$> coreToFun' embs lmap x v def return     _                  -> throwError $ errHMeas x "Cannot make bound of haskell function" -coreToFun' :: F.TCEmb TyCon-           -> LogicMap-           -> LocSymbol-           -> Var-           -> CoreExpr-           -> (([Var], Either F.Expr F.Expr) -> BareM a)-           -> BareM a-coreToFun' tce lmap x v def ok = do-  dm <- gets dcEnv-  either throwError ok $ runToLogic tce lmap dm (errHMeas x) (coreToFun x v def) + toBound :: Var -> LocSymbol -> ([Var], Either F.Expr F.Expr) -> (LocSymbol, RBound) toBound v x (vs, Left p) = (x', Bound x' fvs ps xs p)   where@@ -427,23 +489,5 @@     toUpperHead []     = []     toUpperHead (x:xs) = toUpper x:xs ------------------------------------------------------------------------------------ | Expand Measures ---------------------------------------------------------------------------------------------------------------------------------------------type BareMeasure = Measure (Located BareType) LocSymbol--expandMeasure :: BareMeasure -> BareM BareMeasure-expandMeasure m = do-  eqns <- sequence $ expandMeasureDef <$> eqns m-  return $ m { sort = RT.generalize <$> sort m-             , eqns = eqns }--expandMeasureDef :: Def t LocSymbol -> BareM (Def t LocSymbol)-expandMeasureDef d-  = do body <- expandMeasureBody (loc $ measure d) $ body d-       return $ d { body = body }+-} -expandMeasureBody :: SourcePos -> Body -> BareM Body-expandMeasureBody l (P p)   = P   <$> (resolve l =<< expand l p)-expandMeasureBody l (R x p) = R x <$> (resolve l =<< expand l p)-expandMeasureBody l (E e)   = E   <$> resolve l e
src/Language/Haskell/Liquid/Bare/Misc.hs view
@@ -1,22 +1,16 @@ {-# LANGUAGE FlexibleContexts         #-} -module Language.Haskell.Liquid.Bare.Misc (-    makeSymbols-  , freeSymbols+module Language.Haskell.Liquid.Bare.Misc +  ( freeSymbols   , joinVar   , mkVarExpr-  , MapTyVarST(..)-  , initMapSt+  , vmap   , runMapTyVars-  , mapTyVars   , matchKindArgs   , symbolRTyVar   , simpleSymbolVar   , hasBoolResult-  , symbolMeasure   , isKind-  , makeDataConChecker-  , makeDataConSelector   ) where  import           Name@@ -25,71 +19,32 @@  import           Id import           Type-import           Kind                                  (isStarKind)+import           Kind                                  (classifiesTypeWithValues)  import           Language.Haskell.Liquid.GHC.TypeRep import           Var -import           DataCon+-- import           DataCon import           Control.Monad.Except                  (MonadError, throwError) import           Control.Monad.State-import           Data.Maybe                            (isNothing)+import qualified Data.Maybe                            as Mb --(fromMaybe, isNothing) +import qualified Text.PrettyPrint.HughesPJ             as PJ  import qualified Data.List                             as L import qualified Data.HashMap.Strict                   as M-import           Language.Fixpoint.Misc                (singleton, sortNub)+import           Language.Fixpoint.Misc                as Misc -- (singleton, sortNub) import qualified Language.Fixpoint.Types as F import           Language.Haskell.Liquid.GHC.Misc import           Language.Haskell.Liquid.Types.RefType-import           Language.Haskell.Liquid.Types-import           Language.Haskell.Liquid.Bare.Env-import           Language.Haskell.Liquid.WiredIn       (dcPrefix)+import           Language.Haskell.Liquid.Types.Types ------------------------------------------------------------------------------------ | 'makeDataConChecker d' creates the measure for `is$d` which tests whether---   a given value was created by 'd'. e.g. is$Nil or is$Cons.----------------------------------------------------------------------------------makeDataConChecker :: DataCon -> F.Symbol----------------------------------------------------------------------------------makeDataConChecker d-  -- // NO-SPL-CASE | nilDataCon  == d-  -- // NO-SPL-CASE = F.symbol "isNull"-  -- // NO-SPL-CASE | consDataCon == d-  -- // NO-SPL-CASE = F.symbol "notIsNull"-  -- // NO-SPL-CASE | otherwise-  = F.testSymbol (F.symbol d)+-- import           Language.Haskell.Liquid.Bare.Env ------------------------------------------------------------------------------------ | 'makeDataConSelector d' creates the selector `select$d$i`---   which projects the i-th field of a constructed value.---   e.g. `select$Cons$1` and `select$Cons$2` are respectively---   equivalent to `head` and `tail`.----------------------------------------------------------------------------------makeDataConSelector :: Maybe DataConMap -> DataCon -> Int -> F.Symbol-makeDataConSelector mbDm d i = case mbDm of-  Nothing -> def-  Just dm -> M.lookupDefault def (F.symbol d, i) dm-  where-    def   =  makeDataConSelector' d i+-- import           Language.Haskell.Liquid.WiredIn       (dcPrefix) -makeDataConSelector' :: DataCon -> Int -> F.Symbol-makeDataConSelector' d i-  -- // NO-SPL-CASE | d == consDataCon, i == 1-  -- // NO-SPL-CASE = F.symbol "head"-  -- // NO-SPL-CASE | d == consDataCon,  i == 2-  -- // NO-SPL-CASE = F.symbol "tail"-  -- // NO-SPL-CASE | otherwise-  = symbolMeasure "$select" (dcSymbol d) (Just i) -dcSymbol :: DataCon -> F.Symbol-dcSymbol = {- simpleSymbolVar -} F.symbol . dataConWorkId--symbolMeasure :: String -> F.Symbol -> Maybe Int -> F.Symbol-symbolMeasure f d iMb = foldr1 F.suffixSymbol (dcPrefix : F.symbol f : d : rest)-  where-    rest          = maybe [] (singleton . F.symbol . show) iMb- -- TODO: This is where unsorted stuff is for now. Find proper places for what follows. +{-  -- WTF does this function do? makeSymbols :: (Id -> Bool) -> [Id] -> [F.Symbol] -> BareM [(F.Symbol, Var)] makeSymbols f vs xs@@ -102,13 +57,15 @@       hasBasicArgs (FunTy tx t)   = isBaseTy tx && hasBasicArgs t       hasBasicArgs _              = True +-} + freeSymbols :: (F.Reftable r, F.Reftable r1, F.Reftable r2, TyConable c, TyConable c1, TyConable c2)             => [F.Symbol]             -> [(a1, Located (RType c2 tv2 r2))]             -> [(a, Located (RType c1 tv1 r1))]             -> [(Located (RType c tv r))]             -> [LocSymbol]-freeSymbols xs' xts yts ivs =  [ lx | lx <- sortNub $ zs ++ zs' ++ zs'' , not (M.member (val lx) knownM) ]+freeSymbols xs' xts yts ivs =  [ lx | lx <- Misc.sortNub $ zs ++ zs' ++ zs'' , not (M.member (val lx) knownM) ]   where     knownM                  = M.fromList [ (x, ()) | x <- xs' ]     zs                      = concatMap freeSyms (snd <$> xts)@@ -120,28 +77,24 @@ freeSyms :: (F.Reftable r, TyConable c) => Located (RType c tv r) -> [LocSymbol] freeSyms ty    = [ F.atLoc ty x | x <- tySyms ]   where-    tySyms     = sortNub $ concat $ efoldReft (\_ _ -> True) (\_ _ -> []) (\_ -> []) (const ()) f (const id) F.emptySEnv [] (val ty)+    tySyms     = Misc.sortNub $ concat $ efoldReft (\_ _ -> True) (\_ _ -> []) (\_ -> []) (const ()) f (const id) F.emptySEnv [] (val ty)     f γ _ r xs = let F.Reft (v, _) = F.toReft r in                  [ x | x <- F.syms r, x /= v, not (x `F.memberSEnv` γ)] : xs  ------------------------------------------------------------------------------- -- Renaming Type Variables in Haskell Signatures ------------------------------ -------------------------------------------------------------------------------+runMapTyVars :: Type -> SpecType -> (PJ.Doc -> PJ.Doc -> Error) -> Either Error MapTyVarST+runMapTyVars τ t err = execStateT (mapTyVars τ t) (MTVST [] err)   data MapTyVarST = MTVST   { vmap   :: [(Var, RTyVar)]-  , errmsg :: Error+  , errmsg :: PJ.Doc -> PJ.Doc -> Error   } -initMapSt :: Error -> MapTyVarST-initMapSt = MTVST []---- TODO: Maybe don't expose this; instead, roll this in with mapTyVar and export a---       single "clean" function as the API.-runMapTyVars :: StateT MapTyVarST (Either Error) () -> MapTyVarST -> Either Error MapTyVarST-runMapTyVars = execStateT- mapTyVars :: Type -> SpecType -> StateT MapTyVarST (Either Error) ()+mapTyVars t (RImpF _ _ t' _)+   = mapTyVars t t' mapTyVars (FunTy τ τ') (RFun _ t t' _)    = mapTyVars τ t >> mapTyVars τ' t' mapTyVars τ (RAllT _ t)@@ -173,11 +126,12 @@   = return () mapTyVars (ForAllTy _ τ) t   = mapTyVars τ t-mapTyVars _ _-  = throwError =<< errmsg <$> get+mapTyVars hsT lqT+  = do err <- errmsg <$> get+       throwError (err (F.pprint hsT) (F.pprint lqT))   isKind :: Kind -> Bool-isKind k = isStarKind k --  typeKind k+isKind = classifiesTypeWithValues -- TODO:GHC-863 isStarKind k --  typeKind k   mapTyRVar :: MonadError Error m@@ -185,7 +139,7 @@ mapTyRVar α a s@(MTVST αas err)   = case lookup α αas of       Just a' | a == a'   -> return s-              | otherwise -> throwError err+              | otherwise -> throwError (err (F.pprint a) (F.pprint a'))       Nothing             -> return $ MTVST ((α,a):αas) err  matchKindArgs' :: [Type] -> [SpecType] -> [SpecType]@@ -213,7 +167,7 @@ varFunSymbol = dummyLoc . F.symbol . idDataCon  isFunVar :: Id -> Bool-isFunVar v   = isDataConId v && not (null αs) && isNothing tf+isFunVar v   = isDataConId v && not (null αs) && Mb.isNothing tf   where     (αs, t)  = splitForAllTys $ varType v     tf       = splitFunTy_maybe t
− src/Language/Haskell/Liquid/Bare/OfType.hs 
@@ -1,311 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TupleSections    #-}-{-# LANGUAGE BangPatterns     #-}--module Language.Haskell.Liquid.Bare.OfType (-    ofBareType-  , ofMeaSort-  , ofBPVar-  , mkLSpecType-  , mkSpecType'-  ) where--import Prelude hiding (error)-import BasicTypes-import Name-import TyCon hiding (synTyConRhs_maybe)-import Type (expandTypeSynonyms)-import TysWiredIn--import Control.Monad.Reader hiding (forM)-import Control.Monad.State hiding (forM)-import Data.Maybe (fromMaybe)--import Data.Traversable (forM)-import Text.Parsec.Pos-import Text.Printf--import Text.PrettyPrint.HughesPJ--import qualified Control.Exception as Ex-import qualified Data.HashMap.Strict as M---- import Language.Fixpoint.Misc (traceShow)-import Language.Fixpoint.Types (Expr (..))-import qualified Language.Fixpoint.Types as F--import Language.Haskell.Liquid.GHC.Misc-import Language.Haskell.Liquid.Misc (secondM)-import Language.Haskell.Liquid.Types.RefType-import Language.Haskell.Liquid.Types-import Language.Haskell.Liquid.Types.Bounds--import Language.Haskell.Liquid.Bare.Env-import Language.Haskell.Liquid.Bare.Expand-import Language.Haskell.Liquid.Bare.Lookup-import Language.Haskell.Liquid.Bare.Resolve--- import Language.Haskell.Liquid.Bare.RefToLogic---- import Data.Data (toConstr)-----------------------------------------------------------------------------------ofBareType :: SourcePos -> BareType -> BareM SpecType-ofBareType l bt-  = {- F.tracepp msg <$> -} ofBRType expandRTAliasApp (resolve l <=< expand l) bt-  -- where msg = "OF-BARETYPE: " ++ F.showpp bt---ofMeaSort :: BareType -> BareM SpecType-ofMeaSort-  = ofBRType failRTAliasApp return--ofBSort :: BSort -> BareM RSort-ofBSort-  = ofBRType failRTAliasApp return-------------------------------------------------------------------------------------ofBPVar :: BPVar -> BareM RPVar-ofBPVar-  = mapMPvar ofBSort--mapMPvar :: (Monad m) => (a -> m b) -> PVar a -> m (PVar b)-mapMPvar f (PV x t v txys)-  = do t'    <- forM t f-       txys' <- mapM (\(t, x, y) -> liftM (, x, y) (f t)) txys-       return $ PV x t' v txys'-----------------------------------------------------------------------------------mkLSpecType :: Located BareType -> BareM (Located SpecType)-mkLSpecType !t = F.atLoc t <$> mkSpecType (loc t) (val t)--mkSpecType :: SourcePos -> BareType -> BareM SpecType-mkSpecType l t = mkSpecType' l (ty_preds $ toRTypeRep t) t--mkSpecType' :: SourcePos -> [PVar BSort] -> BareType -> BareM SpecType-mkSpecType' l πs t = ofBRType expandRTAliasApp resolveReft t-  where-    resolveReft    = (resolve l <=< expand l) . txParam l subvUReft (uPVar <$> πs) t---txParam :: SourcePos-        -> ((UsedPVar -> UsedPVar) -> t) -> [UsedPVar] -> RType c tv r -> t-txParam l f πs t = f (txPvar l (predMap πs t))--txPvar :: SourcePos -> M.HashMap F.Symbol UsedPVar -> UsedPVar -> UsedPVar-txPvar l m π = π { pargs = args' }-  where-    args' | not (null (pargs π)) = zipWith (\(_,x ,_) (t,_,y) -> (t, x, y)) (pargs π') (pargs π)-          | otherwise            = pargs π'-    π'    = fromMaybe err $ M.lookup (pname π) m-    err   = uError $ ErrUnbPred (sourcePosSrcSpan l) (pprint π)-        -- err   = "Bare.replaceParams Unbound Predicate Variable: " ++ show π---predMap :: [UsedPVar] -> RType c tv r -> M.HashMap F.Symbol UsedPVar-predMap πs t = M.fromList [(pname π, π) | π <- πs ++ rtypePredBinds t]--rtypePredBinds :: RType c tv r -> [UsedPVar]-rtypePredBinds = map uPVar . ty_preds . toRTypeRep-----------------------------------------------------------------------------------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 (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---    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"---matchTyCon :: LocSymbol -> Int -> BareM TyCon-matchTyCon lc@(Loc _ _ c) arity-  | isList c && arity == 1-  = return listTyCon-  | isTuple c-  = return $ tupleTyCon Boxed arity-  | otherwise-  = lookupGhcTyCon "matchTyCon" lc------------------------------------------------------------------------------------failRTAliasApp :: SourcePos -> RTAlias RTyVar SpecType -> [BRType r] -> r -> BareM (RRType r)-failRTAliasApp l rta _ _-  = Ex.throw err-  where-    err :: Error-    err = ErrIllegalAliasApp (sourcePosSrcSpan l) (pprint $ rtName rta) (sourcePosSrcSpan $ rtPos rta)--_expandRTAliasApp_ :: SourcePos -> RTAlias RTyVar SpecType -> [BSort] -> () -> BareM RSort-_expandRTAliasApp_ l rta args _ = do-  res <- expandRTAliasApp l rta ([ const mempty <$> t | t <- args] ) mempty-  return (void res)--expandRTAliasApp :: SourcePos -> RTAlias RTyVar SpecType -> [BareType] -> RReft -> BareM SpecType-expandRTAliasApp l rta args r-  | Just errmsg <- isOK-    = Ex.throw errmsg-  | otherwise-    = do ts <- mapM (ofBareType l) $ take (length αs) args-         es <- mapM (resolve l . exprArg (F.symbolString $ rtName rta)) $ drop (length αs) args-         let tsu = zipWith (\α t -> (α, toRSort t, t)) αs ts-         let esu = F.mkSubst $ zip (F.symbol <$> εs) es-         return  $ F.subst esu . (`strengthen` r) . subsTyVars_meet tsu $ rtBody rta--  where-    (αs, εs)  = F.notracepp _msg (rtTArgs rta, rtVArgs rta)-    _msg      = "EXPAND-RTALIAS-APP: " ++ F.showpp (rtName rta)-    err       :: Doc -> Error-    err       = ErrAliasApp (sourcePosSrcSpan l)-                            (pprint $ rtName rta)-                            (sourcePosSrcSpan $ rtPos rta)-    isOK :: Maybe Error-    isOK-      | length args /= length targs + length eargs-      = Just $ err (text "Expects" <+> (pprint $ length αs) <+> text "type arguments and then" <+> (pprint $ length εs) <+> text "expression arguments, but is given" <+> (pprint $ length args))-      | length args /= length αs + length εs-      = Just $ err (text "Expects" <+> (pprint $ length αs) <+> text "type arguments and " <+> (pprint $ length εs) <+> text "expression arguments, but is given" <+> (pprint $ length args))-      | length αs /= length targs, not (null eargs)-      = Just $ err (text "Expects" <+> (pprint $ length αs) <+> text "type arguments before expression arguments")---  Many expression arguments are parsed like type arguments-{--      | length αs /= length targs-      = Just $ err (text "Expects" <+> (pprint $ length αs) <+> text "type arguments but is given" <+> (pprint $ length targs))-      | length εs /= length eargs-      = Just $ err (text "Expects" <+> (pprint $ length εs) <+> text "expression arguments but is given" <+> (pprint $ length eargs))--}-      | otherwise-      = Nothing--    notIsRExprArg (RExprArg _) = False-    notIsRExprArg _            = True--    targs = takeWhile notIsRExprArg args-    eargs = dropWhile notIsRExprArg args------------------------------------------------------------------------------------- | exprArg converts a tyVar to an exprVar because parser cannot tell---   this function allows us to treating (parsed) "types" as "value"---   arguments, e.g. type Matrix a Row Col = List (List a Row) Col---   Note that during parsing, we don't necessarily know whether a---   string is a type or a value expression. E.g. in tests/pos/T1189.hs,---   the string `Prop (Ev (plus n n))` where `Prop` is the alias:---     {-@ type Prop E = {v:_ | prop v = E} @-}---   the parser will chomp in `Ev (plus n n)` as a `BareType` and so---   `exprArg` converts that `BareType` into an `Expr`.----------------------------------------------------------------------------------exprArg :: (PrintfArg t1)  => t1 -> BareType -> Expr-exprArg _   (RExprArg e)-  = val e-exprArg _   (RVar x _)-  = EVar (F.symbol x)-exprArg _   (RApp x [] [] _)-  = EVar (F.symbol x)-exprArg msg (RApp f ts [] _)-  = F.mkEApp (F.symbol <$> btc_tc f) (exprArg msg <$> ts)-exprArg msg (RAppTy t1 t2 _)-  = F.EApp (exprArg msg t1) (exprArg msg t2)--- ORIG exprArg msg (RAppTy (RVar f _) t _)--- ORIG = F.mkEApp (dummyLoc $ F.symbol f) [exprArg msg t]-exprArg msg z-  = panic Nothing $ printf "Unexpected expression parameter: %s in %s" (show z) msg-  -- = panic Nothing $ printf "Unexpected expression parameter: %s in %s" (show z ++ "[" ++ show (toConstr z) ++ "]") msg-    -- FIXME: Handle this error much better!------------------------------------------------------------------------------------bareTCApp :: (Monad m, PPrint r, F.Reftable r, SubsTy RTyVar RSort r, F.Reftable (RTProp RTyCon RTyVar r))-          => r-          -> Located TyCon-          -> [RTProp RTyCon RTyVar r]-          -> [RType RTyCon RTyVar r]-          -> m (RType RTyCon RTyVar r)-bareTCApp r (Loc l _ c) rs ts | Just rhs <- synTyConRhs_maybe c-  = do when (kindTCArity c < length ts) (Ex.throw err)-       return $ tyApp (subsTyVars_meet su $ ofType rhs) (drop nts ts) rs r-    where-       tvs = [ v | (v, b) <- zip (tyConTyVarsDef c) (tyConBinders c), isAnonBinder b]-       su  = zipWith (\a t -> (rTyVar a, toRSort t, t)) tvs ts-       nts = length tvs--       err :: Error-       err = ErrAliasApp (sourcePosSrcSpan l) (pprint c) (getSrcSpan c)-                         (text "Expects " <+> (pprint $ realTcArity c) <+> text "arguments, but is given" <+> (pprint $ length ts))---- TODO expandTypeSynonyms here to-bareTCApp r (Loc _ _ c) rs ts | isFamilyTyCon c && isTrivial t-  = return (expandRTypeSynonyms $ t `strengthen` r)-  where t = rApp c ts rs mempty--bareTCApp r (Loc _ _ c) rs ts-  = return $ rApp c ts rs r--tyApp :: F.Reftable r-      => RType c tv r-      -> [RType c tv r] -> [RTProp c tv r] -> r -> RType c tv r-tyApp (RApp c ts rs r) ts' rs' r' = RApp c (ts ++ ts') (rs ++ rs') (r `F.meet` r')-tyApp t                []  []  r  = t `strengthen` r-tyApp _                 _  _   _  = panic Nothing $ "Bare.Type.tyApp on invalid inputs"--expandRTypeSynonyms :: (PPrint r, F.Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, F.Reftable (RTProp RTyCon RTyVar r))-                    => RRType r -> RRType r-expandRTypeSynonyms = ofType . expandTypeSynonyms . toType
src/Language/Haskell/Liquid/Bare/Plugged.hs view
@@ -1,47 +1,43 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TupleSections         #-}+{-# LANGUAGE PartialTypeSignatures #-} -module Language.Haskell.Liquid.Bare.Plugged (-    makePluggedSigs-  , makePluggedAsmSigs-  , makePluggedDataCons+module Language.Haskell.Liquid.Bare.Plugged +  ( makePluggedSig+  , makePluggedDataCon   ) where  import Prelude hiding (error)-import DataCon-import Module-import Name-import NameSet-import TyCon-import Type (expandTypeSynonyms, Type)-import Var--- import           Language.Haskell.Liquid.GHC.Misc (showPpr)--import Control.Monad-import Control.Monad.Except-import qualified Control.Exception                      as Ex import Data.Generics.Aliases (mkT) import Data.Generics.Schemes (everywhere)  import           Text.PrettyPrint.HughesPJ--import qualified Data.HashMap.Strict as M--import Language.Fixpoint.Types.Names (dummySymbol)-import qualified Language.Fixpoint.Types         as F-import qualified Language.Fixpoint.Types.Visitor as F--- import Language.Fixpoint.Types (traceFix, showFix)--- import Language.Fixpoint.Misc (traceShow)--import qualified Language.Haskell.Liquid.GHC.Misc       as GM -- (sourcePosSrcSpan, sourcePos2SrcSpan, symbolTyVar)----- import Language.Haskell.Liquid.GHC.Misc      (sourcePos2SrcSpan)-import Language.Haskell.Liquid.Types.RefType (updateRTVar, addTyConInfo, ofType, rVar, rTyVar, subts, toType, uReft)-import Language.Haskell.Liquid.Types--import Language.Haskell.Liquid.Misc (zipWithDefM)+import qualified Control.Exception                 as Ex+import qualified Data.HashMap.Strict               as M+import qualified Data.Maybe                        as Mb +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.Types+import qualified Language.Haskell.Liquid.Misc       as Misc +import qualified Language.Haskell.Liquid.Bare.Types as Bare+import qualified Language.Haskell.Liquid.Bare.Misc  as Bare -import Language.Haskell.Liquid.Bare.Env-import Language.Haskell.Liquid.Bare.Misc+---------------------------------------------------------------------------------------+-- [NOTE: Plug-Holes-TyVars] We have _two_ versions of `plugHoles:+-- * `HsTyVars` ensures that the returned signature uses the GHC type variables;+--   We need this as these tyvars can appear in the SOURCE (as type annotations, or+--   as the types of lambdas) and renaming them will cause problems; +-- * `LqTyVars` ensures that the returned signatuer uses the LIQUID type variables; +--   We need this e.g. for class specifications where we cannot change the tyvars +--   used inside method signatures as that messes up the type for the data-constructor +--   for the dictionary (as we need to use the same tyvars as are "bound" in the class +--   definition).+-- In short, use `HsTyVars` when we also have to analyze the binder's SOURCE; and +-- otherwise, use `LqTyVars`.+---------------------------------------------------------------------------------------  -------------------------------------------------------------------------------- -- | NOTE: Be *very* careful with the use functions from RType -> GHC.Type,@@ -49,138 +45,227 @@ --   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+               -> Bare.PlugTV Ghc.Var -> LocSpecType+               -> LocSpecType -makePluggedSigs :: ModName-                -> F.TCEmb TyCon-                -> M.HashMap TyCon RTyCon-                -> NameSet-                -> [(Var, LocSpecType)]-                -> BareM [(Var, LocSpecType)]-makePluggedSigs name embs tcEnv exports sigs-  = forM sigs $ \(x,t) -> do-      let τ = expandTypeSynonyms $ varType x-      let r = maybeTrue x name exports-      (x,) <$> plugHoles embs tcEnv x r τ t+makePluggedSig name embs tyi exports kx t +  | Just x <- kxv = mkPlug x +  | otherwise     = t+  where +    kxv           = Bare.plugSrc kx+    mkPlug x      = plugHoles kx embs tyi  r τ t+      where+        τ         = Ghc.expandTypeSynonyms (Ghc.varType x)+        r         = maybeTrue x name exports+    -- x = case kx of { Bare.HsTV x -> x ; Bare.LqTV x -> x } -makePluggedAsmSigs :: F.TCEmb TyCon-                   -> M.HashMap TyCon RTyCon-                   -> [(Var, LocSpecType)]-                   -> BareM [(Var, LocSpecType)]-makePluggedAsmSigs embs tcEnv sigs-  = forM sigs $ \(x,t) -> do-      let τ = expandTypeSynonyms $ varType x-      let r = const killHoles-      (x,) <$> plugHoles embs tcEnv x r τ t -makePluggedDataCons :: F.TCEmb TyCon-                    -> M.HashMap TyCon RTyCon-                    -> [(DataCon, Located DataConP)]-                    -> BareM [(DataCon, Located DataConP)]-makePluggedDataCons embs tcEnv dcs-  = forM dcs $ \(dc, Loc l l' dcp) -> do-       let (das, _, dts, dt0) = dataConSig dc-       let (dt, rest) = (dt0, tyRes dcp)-       when (mismatch dts dcp) (Ex.throw $ err dc dcp)-       tyArgs <- zipWithM (\t1 (x, t2) ->-                   (x,) . val <$> plugHoles embs tcEnv (dataConName dc) (const killHoles) t1 (Loc l l' t2))-                 dts (reverse $ tyArgs dcp)-       tyRes <- val <$> plugHoles embs tcEnv (dataConName dc) (const killHoles) dt (Loc l l' (rest {- tyRes dcp -}))-       return (dc, Loc l l' dcp { freeTyVars = map rTyVar das-                                , freePred   = map (subts (zip (freeTyVars dcp) (map (rVar :: TyVar -> RSort) das))) (freePred dcp)-                                , tyArgs     = reverse tyArgs-                                , tyRes      = tyRes})+-- makePluggedDataCon = makePluggedDataCon_old +-- plugHoles          = plugHoles_old +-- makePluggedDataCon = makePluggedDataCon_new  -    where-      mismatch dts dcp = length dts /= length (tyArgs dcp)-      err dc dcp       = ErrBadData (GM.fSrcSpan dcp) (pprint dc) "GHC and Liquid specifications have different numbers of fields" :: UserError+-- plugHoles _         = plugHoles_old -plugHoles :: (NamedThing a, PPrint a, Show a)-          => F.TCEmb TyCon-          -> M.HashMap TyCon RTyCon-          -> a+plugHoles :: (Ghc.NamedThing a, PPrint a, Show a) +          => Bare.PlugTV a+          -> F.TCEmb Ghc.TyCon+          -> Bare.TyConMap           -> (SpecType -> RReft -> RReft)-          -> Type-          -> Located SpecType-          -> BareM (Located SpecType)-plugHoles tce tyi x f t (Loc l l' st)-                                    -- NOTE: this use of toType is safe as rt' is derived from t.-  = do tyvsmap <- case runMapTyVars (mapTyVars (toType rt') st'') initvmap of-                    Left e -> throwError e-                    Right s -> return (vmap s)-       let su    = F.notracepp ("MAKE-ASSUME-SPEC-4: " ++ show x) [(y, rTyVar x) | (x, y) <- tyvsmap]-           coSub = F.notracepp ("MAKE-ASSUME-SPEC-5: " ++ show x) $ M.fromList [(F.symbol y, F.FObj (F.symbol x)) | (y, x) <- su]-           st3   = subts su st''-           st4   = mapExprReft (F.applyCoSub coSub) st3-           ps'   = fmap (subts su') <$> ps-           su'   = [(y, RVar (rTyVar x) ()) | (x, y) <- tyvsmap] :: [(RTyVar, RSort)]-       Loc l l' . mkArrow (updateRTVar <$> αs) ps' (ls1 ++ ls2) [] . makeCls cs' <$> (go rt' st4)-  where-    (αs, _, ls1, rt)  = bkUniv (ofType (expandTypeSynonyms t) :: SpecType)-    (cs, rt')         = bkClass rt+          -> Ghc.Type+          -> LocSpecType+          -> LocSpecType+plugHoles (Bare.HsTV x) a b = plugHoles_old a b x +plugHoles (Bare.LqTV x) a b = plugHoles_new a b x +plugHoles _             _ _ = \_ _ t -> t -    (_, ps, ls2, st') = bkUniv st-    (_, st'')         = bkClass st'-    cs'               = [(dummySymbol, RApp c t [] mempty) | (c,t) <- cs] -    initvmap          = initMapSt $ ErrMismatch lqSp (pprint x) (text "Plugged Init types" {- <+> pprint t <+> "\nVS\n" <+> pprint st -})-                                                                (pprint $ expandTypeSynonyms t)-                                                                (pprint $ toRSort st)-                                                                hsSp-    hsSp              = getSrcSpan x-    lqSp              = GM.sourcePos2SrcSpan l l'+makePluggedDataCon :: F.TCEmb Ghc.TyCon -> Bare.TyConMap -> Located DataConP -> Located DataConP+makePluggedDataCon embs tyi ldcp +  | mismatchFlds      = Ex.throw (err "fields")+  | mismatchTyVars    = Ex.throw (err "type variables")+  | otherwise         = F.atLoc ldcp $ F.notracepp "makePluggedDataCon" $ dcp +                          { 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 +    dc                = dcpCon        dcp+    dcp               = val           ldcp  -    go :: SpecType -> SpecType -> BareM SpecType-    go t                (RHole r)          = return $ (addHoles t') { rt_reft = f t r }+    mismatchFlds      = length dts /= length dcArgs +    mismatchTyVars    = length das /= length dcVars +    err things        = ErrBadData (GM.fSrcSpan dcp) (pprint dc) ("GHC and Liquid specifications have different numbers of" <+> things) :: UserError++++-- | @plugMany@ is used to "simultaneously" plug several different types, +--   e.g. as arise in the fields of a data constructor. To do so we create +--   a single "function type" that is then passed into @plugHoles@. +--   We also pass in the type parameters as dummy arguments, because, e.g. +--   we want @plugMany@ on the two types+--  +--      forall a. a -> a -> Bool +--      forall b. _ -> _ -> _ +-- +--   to return something like +-- +--      forall b. b -> b -> Bool+-- +--   and not, forall b. a -> a -> Bool.++plugMany :: F.TCEmb Ghc.TyCon -> Bare.TyConMap +         -> Located DataConP            +         -> ([Ghc.Var], [Ghc.Type],             Ghc.Type)   -- ^ hs type +         -> ([RTyVar] , [(F.Symbol, SpecType)], SpecType)   -- ^ lq type +         -> ([(F.Symbol, SpecType)], SpecType)              -- ^ plugged lq type+plugMany embs tyi ldcp (hsAs, hsArgs, hsRes) (lqAs, lqArgs, lqRes) +                     = F.notracepp msg (drop nTyVars (zip xs ts), t) +  where +    (_,(xs,ts,_), t) = bkArrow (val pT) +    -- pRep             = toRTypeRep (val pT)+    pT               = plugHoles (Bare.LqTV dcName) embs tyi (const killHoles) hsT (F.atLoc ldcp lqT)+    hsT              = foldr Ghc.mkFunTy    hsRes hsArgs' +    lqT              = foldr (uncurry rFun) lqRes lqArgs' +    hsArgs'          = [ Ghc.mkTyVarTy a               | a <- hsAs] ++ hsArgs +    lqArgs'          = [(F.dummySymbol, RVar a mempty) | a <- lqAs] ++ lqArgs +    nTyVars          = length hsAs -- == length lqAs+    dcName           = Ghc.dataConName . dcpCon . val $ ldcp+    msg              = "plugMany: " ++ F.showpp (dcName, hsT, lqT)++plugHoles_old, plugHoles_new +  :: (Ghc.NamedThing a, PPrint a, Show a)+  => F.TCEmb Ghc.TyCon+  -> Bare.TyConMap +  -> a+  -> (SpecType -> RReft -> RReft)+  -> Ghc.Type+  -> LocSpecType+  -> LocSpecType+  +-- NOTE: this use of toType is safe as rt' is derived from t.+plugHoles_old tce tyi x f t0 zz@(Loc l l' st0) +    = Loc l l' +    . mkArrow (updateRTVar <$> αs) ps' (ls1 ++ ls2) [] [] +    . 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+                          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 ++    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)+                          (Just (hsT, lqT))+                          (Ghc.getSrcSpan x) +++plugHoles_new tce tyi x f t0 zz@(Loc l l' st0) +    = Loc l l' +    . mkArrow (updateRTVar <$> as') ps (ls1 ++ ls2) [] [] +    . 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+                          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++    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)+                          (Just (hsT, lqT))+                          (Ghc.getSrcSpan x) ++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 +  where+    go t (RHole r) = (addHoles t') { rt_reft = f t r }       where-        t'       = everywhere (mkT $ addRefs tce tyi) t-        addHoles = everywhere (mkT $ addHole)+        t'         = everywhere (mkT $ addRefs tce tyi) t+        addHoles   = everywhere (mkT $ addHole)         -- NOTE: make sure we only add holes to RVar and RApp (NOT RFun)         addHole :: SpecType -> SpecType         addHole t@(RVar v _)       = RVar v (f t (uReft ("v", hole)))         addHole t@(RApp c ts ps _) = RApp c ts ps (f t (uReft ("v", hole)))         addHole t                  = t -    go (RVar _ _)       v@(RVar _ _)       = return v-    go (RFun _ i o _)   (RFun x i' o' r)   = RFun x     <$> go i i' <*> go o o' <*> return r-    go (RAllT _ t)      (RAllT a t')       = RAllT a    <$> go t t'-    go (RAllT a t)      t'                 = RAllT a    <$> go t t'-    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'-    go (RAppTy t1 t2 _) (RAppTy t1' t2' r) = RAppTy     <$> go t1 t1' <*> go t2 t2' <*> return r+    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 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')+    go (RAppTy t1 t2 _) (RAppTy t1' t2' r) = RAppTy     (go t1 t1') (go t2 t2') r     -- zipWithDefM: if ts and ts' have different length then the liquid and haskell types are different.     -- keep different types for now, as a pretty error message will be created at Bare.Check-    go (RApp _ ts _ _)  (RApp c ts' p r)   --  length ts == length ts'-                                           = RApp c <$> (zipWithDefM go ts $ matchKindArgs ts ts') <*> return p <*> return r+    go (RApp _ ts _ _)  (RApp c ts' p r)   +      | length ts == length ts'            = RApp c     (Misc.zipWithDef go ts $ Bare.matchKindArgs ts ts') p r+    go hsT lqT                             = Ex.throw (err (F.pprint hsT) (F.pprint lqT))++    -- otherwise                          = Ex.throw err      -- If we reach the default case, there's probably an error, but we defer     -- throwing it as checkGhcSpec does a much better job of reporting the     -- problem to the user.-    go st               _                 = return st--    makeCls cs t              = foldr (uncurry rFun) t cs+    -- go st               _                 = st -addRefs :: F.TCEmb TyCon-     -> M.HashMap TyCon RTyCon-     -> SpecType-     -> SpecType+addRefs :: F.TCEmb Ghc.TyCon -> TyConMap -> SpecType -> SpecType addRefs tce tyi (RApp c ts _ r) = RApp c' ts ps r   where     RApp c' _ ps _ = addTyConInfo tce tyi (RApp c ts [] r) addRefs _ _ t  = t --maybeTrue :: NamedThing a => a -> ModName -> NameSet -> SpecType -> RReft -> RReft+maybeTrue :: Ghc.NamedThing a => a -> ModName -> Ghc.NameSet -> SpecType -> RReft -> RReft maybeTrue x target exports t r-  | not (isFunTy t) && (isInternalName name || inTarget && notExported)+  | not (isFunTy t) && (Ghc.isInternalName name || inTarget && notExported)   = r   | otherwise   = killHoles r   where-    inTarget    = moduleName (nameModule name) == getModName target-    name        = getName x-    notExported = not $ getName x `elemNameSet` exports+    inTarget    = Ghc.moduleName (Ghc.nameModule name) == getModName target+    name        = Ghc.getName x+    notExported = not (Ghc.getName x `Ghc.elemNameSet` exports)  -- killHoles r@(U (Reft (v, rs)) _ _) = r { ur_reft = Reft (v, filter (not . isHole) rs) } 
− src/Language/Haskell/Liquid/Bare/RTEnv.hs 
@@ -1,188 +0,0 @@-{-# LANGUAGE TupleSections #-}--module Language.Haskell.Liquid.Bare.RTEnv ( makeRTEnv ) where--import Prelude hiding (error)--import Data.Graph hiding (Graph)-import Data.Maybe--import qualified Control.Exception   as Ex-import qualified Data.HashMap.Strict as M-import qualified Data.List           as L--import           Language.Fixpoint.Misc (fst3)-import           Language.Fixpoint.Types (Expr(..), Symbol, symbol) -- , tracepp)-import           Language.Haskell.Liquid.GHC.Misc (sourcePosSrcSpan)-import           Language.Haskell.Liquid.Types.RefType (symbolRTyVar)-import           Language.Haskell.Liquid.Types.Fresh-import           Language.Haskell.Liquid.Types-import qualified Language.Haskell.Liquid.Measure as Ms-import           Language.Haskell.Liquid.Bare.Env-import           Language.Haskell.Liquid.Bare.Expand-import           Language.Haskell.Liquid.Bare.OfType-import           Language.Haskell.Liquid.Bare.Resolve------------------------------------------------------------------------------------- | `makeRTEnv` initializes the env needed to `expand` refinements and types,---   that is, the below needs to be called *before* we use `Expand.expand`----------------------------------------------------------------------------------makeRTEnv :: ModName-          -> Ms.BareSpec-          -> [(ModName, Ms.BareSpec)]-          -> M.HashMap Symbol LMap-          -> BareM ()----------------------------------------------------------------------------------makeRTEnv m lfSpec specs lm = do-  makeREAliases (eAs ++ eAs' ++ eAs'')-  makeRTAliases tAs-  where-    tAs   = [ (m, t) | (m, s)  <- specs,           t <- Ms.aliases   s ]-    eAs   = [ (m, e) | (m, s)  <- specs,           e <- Ms.ealiases  s ]-    eAs'  = [ (m, e) | e       <- Ms.ealiases lfSpec                   ]-    eAs'' = [ (m, e) | (_, xl) <- M.toList lm, let e  = lmapEAlias  xl ]--makeRTAliases :: [(ModName, RTAlias Symbol BareType)] -> BareM ()-makeRTAliases = graphExpand buildTypeEdges expBody-  where-    expBody (m, xt) = inModule m $ do-      let l  = rtPos  xt-      let l' = rtPosE xt-      body  <- withVArgs l l' (rtVArgs xt) $ ofBareType l $ rtBody xt-      body' <- refreshTy body-      setRTAlias (rtName xt) $ mapRTAVars symbolRTyVar $ xt { rtBody = body' }--makeREAliases :: [(ModName, RTAlias Symbol Expr)] -> BareM ()-makeREAliases-  = graphExpand buildExprEdges expBody-  where-    expBody (mod, xt)-      = inModule mod $-          do let l  = rtPos  xt-             let l' = rtPosE xt-             body  <- withVArgs l l' (rtVArgs xt) $ resolve l =<< expand l (rtBody xt)-             setREAlias (rtName xt) $ xt { rtBody = body }---graphExpand :: (PPrint t)-            => (AliasTable t -> t -> [Symbol])-            -> ((ModName, RTAlias Symbol t) -> BareM b)-            -> [(ModName, RTAlias Symbol t)]-            -> BareM ()-graphExpand buildEdges expBody xts-  = do let table = buildAliasTable xts-           graph = buildAliasGraph (buildEdges table) (map snd xts)-       checkCyclicAliases table graph-       mapM_ expBody $ genExpandOrder table graph------------------------------------------------------------------------------------type AliasTable t = M.HashMap Symbol (ModName, RTAlias Symbol t)--buildAliasTable :: [(ModName, RTAlias Symbol t)] -> AliasTable t-buildAliasTable-  = M.fromList . map (\(m, rta) -> (rtName rta, (m, rta)))--fromAliasSymbol :: AliasTable t -> Symbol -> (ModName, RTAlias Symbol t)-fromAliasSymbol table sym-  = fromMaybe err $ M.lookup sym table-  where-    err = panic Nothing $ "fromAliasSymbol: Dangling alias symbol: " ++ show sym---type Graph t = [Node t]-type Node  t = (t, t, [t])--buildAliasGraph :: (PPrint t) => (t -> [Symbol]) -> [RTAlias Symbol t] -> Graph Symbol-buildAliasGraph buildEdges-  = map (buildAliasNode buildEdges)--buildAliasNode :: (PPrint t) => (t -> [Symbol]) -> RTAlias Symbol t -> Node Symbol-buildAliasNode buildEdges alias-  = (rtName alias, rtName alias, buildEdges $ rtBody alias)--checkCyclicAliases :: AliasTable t -> Graph Symbol -> BareM ()-checkCyclicAliases table graph-  = case mapMaybe go $ stronglyConnComp graph of-      []   -> return ()-      sccs -> Ex.throw (cycleAliasErr table <$> sccs)-    where-      go (CyclicSCC vs) = Just vs-      go (AcyclicSCC _) = Nothing--cycleAliasErr :: AliasTable t -> [Symbol] -> Error-cycleAliasErr _ []          = panic Nothing "checkCyclicAliases: No type aliases in reported cycle"-cycleAliasErr t scc@(rta:_) = ErrAliasCycle { pos    = fst (locate rta)-                                            , acycle = map locate scc }-  where-    locate sym = ( sourcePosSrcSpan $ rtPos $ snd $ fromAliasSymbol t sym-                 , pprint sym )---genExpandOrder :: AliasTable t -> Graph Symbol -> [(ModName, RTAlias Symbol t)]-genExpandOrder table graph-  = map (fromAliasSymbol table) symOrder-  where-    (digraph, lookupVertex, _)-      = graphFromEdges graph-    symOrder-      = map (fst3 . lookupVertex) $ reverse $ topSort digraph------------------------------------------------------------------------------------ordNub :: Ord a => [a] -> [a]-ordNub = map head . L.group . L.sort--buildTypeEdges :: AliasTable BareType -> BareType -> [Symbol]-buildTypeEdges table = ordNub . go-  where-    go :: BareType -> [Symbol]-    go (RApp c ts rs _) = go_alias (symbol c) ++ concatMap go ts ++ concatMap go (mapMaybe go_ref rs)-    go (RFun _ t1 t2 _) = go t1 ++ go t2-    go (RAppTy t1 t2 _) = go t1 ++ go t2-    go (RAllE _ t1 t2)  = go t1 ++ go t2-    go (REx _ t1 t2)    = go t1 ++ go t2-    go (RAllT _ t)      = go t-    go (RAllP _ t)      = go t-    go (RAllS _ t)      = go t-    go (RVar _ _)       = []-    go (RExprArg _)     = []-    go (RHole _)        = []-    go (RRTy env _ _ t) = concatMap (go . snd) env ++ go t-    go_alias c          = [c | M.member c table]-    -- case M.lookup c table of-    --                         Just _  -> [c]-    --                         Nothing -> [ ]--    go_ref (RProp _ (RHole _)) = Nothing-    go_ref (RProp  _ t) = Just t---buildExprEdges :: M.HashMap Symbol a -> Expr -> [Symbol]-buildExprEdges table  = ordNub . go-  where-    go :: Expr -> [Symbol]-    go (EApp e1 e2)   = go e1 ++ go e2-    go (ENeg e)       = go e-    go (EBin _ e1 e2) = go e1 ++ go e2-    go (EIte _ e1 e2) = go e1 ++ go e2-    go (ECst e _)     = go e-    go (ESym _)       = []-    go (ECon _)       = []-    go (EVar v)       = go_alias v-    go (PAnd ps)       = concatMap go ps-    go (POr ps)        = concatMap go ps-    go (PNot p)        = go p-    go (PImp p q)      = go p ++ go q-    go (PIff p q)      = go p ++ go q-    go (PAll _ p)      = go p-    go (ELam _ e)      = go e-    go (ECoerc _ _ e)  = go e-    go (PAtom _ e1 e2) = go e1 ++ go e2-    go (ETApp e _)     = go e-    go (ETAbs e _)     = go e-    go (PKVar _ _)     = []-    go (PExist _ e)    = go e-    go (PGrad _ _ _ e) = go e--    go_alias f         = [f | M.member f table ]
src/Language/Haskell/Liquid/Bare/Resolve.hs view
@@ -1,147 +1,987 @@-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE TupleSections        #-}-{-# LANGUAGE TypeSynonymInstances #-}--module Language.Haskell.Liquid.Bare.Resolve (-     Resolvable(..)-  ) where---import           Prelude                             hiding (error)-import           Var--import           Control.Monad.State-import           Data.Char                           (isUpper)-import           Text.Parsec.Pos---- import qualified Data.List                           as L--- import qualified Data.HashSet                        as S-import qualified Data.HashMap.Strict                 as M---- import           Language.Fixpoint.Misc              (traceShow)-import           Language.Fixpoint.Types.Names       (prims, unconsSym)-import Language.Fixpoint.Types (Expr(..),-                                Qualifier(..),-                                Reft(..),-                                Sort(..),-                                Symbol,-                                atLoc,-                                fTyconSymbol,-                                symbol,-                                symbolFTycon)--import           Language.Haskell.Liquid.Misc        (secondM, third3M)-import           Language.Haskell.Liquid.Types-import           Language.Haskell.Liquid.Bare.Env-import           Language.Haskell.Liquid.Bare.Lookup--class Resolvable a where-  resolve :: SourcePos -> a -> BareM a--instance Resolvable a => Resolvable [a] where-  resolve = mapM . resolve--instance Resolvable Qualifier where-  resolve _ (Q n ps b l) = Q n <$> mapM (secondM (resolve l)) ps <*> resolve l b <*> return l---instance Resolvable Expr where-  resolve l (EVar s)        = EVar   <$> resolve l s-  resolve l (EApp s es)     = EApp   <$> resolve l s  <*> resolve l es-  resolve l (ENeg e)        = ENeg   <$> resolve l e-  resolve l (EBin o e1 e2)  = EBin o <$> resolve l e1 <*> resolve l e2-  resolve l (EIte p e1 e2)  = EIte   <$> resolve l p  <*> resolve l e1 <*> resolve l e2-  resolve l (ECst x s)      = ECst   <$> resolve l x  <*> resolve l s-  resolve l (PAnd ps)       = PAnd    <$> resolve l ps-  resolve l (POr  ps)       = POr     <$> resolve l ps-  resolve l (PNot p)        = PNot    <$> resolve l p-  resolve l (PImp p q)      = PImp    <$> resolve l p  <*> resolve l q-  resolve l (PIff p q)      = PIff    <$> resolve l p  <*> resolve l q-  resolve l (PAtom r e1 e2) = PAtom r <$> resolve l e1 <*> resolve l e2-  resolve l (ELam (x,t) e)  = ELam    <$> ((,) <$> resolve l x <*> resolve l t) <*> resolve l e-  resolve l (ECoerc a t e)  = ECoerc  <$> resolve l a <*> resolve l t   <*> resolve l e-  resolve l (PAll vs p)     = PAll    <$> mapM (secondM (resolve l)) vs <*> resolve l p-  resolve l (ETApp e s)     = ETApp   <$> resolve l e <*> resolve l s-  resolve l (ETAbs e s)     = ETAbs   <$> resolve l e <*> resolve l s-  resolve _ (PKVar k s)     = return $ PKVar k s-  resolve l (PExist ss e)   = PExist ss <$> resolve l e-  resolve _ (ESym s)        = return $ ESym s-  resolve _ (ECon c)        = return $ ECon c-  resolve l (PGrad k su i e)  = PGrad k su i <$> resolve l e--instance Resolvable LocSymbol where-  resolve = resolveSym--resolveSym :: SourcePos -> LocSymbol -> BareM LocSymbol-resolveSym _ ls@(Loc _ _ s) = do-  isKnown <- isSpecialSym s-  if isKnown || not (isCon s)-    then return ls-    else resolveCtor ls--resolveCtor :: LocSymbol -> BareM LocSymbol-resolveCtor ls = do-  env1 <- gets propSyms-  case M.lookup (val ls) env1 of-    Just ls' -> return ls'-    Nothing  -> resolveCtorVar ls--resolveCtorVar :: LocSymbol -> BareM LocSymbol-resolveCtorVar ls = do-  v <- lookupGhcVar ls-  let qs = symbol v-  addSym (qs, v)-  return $ atLoc ls qs-  -- Loc l l' qs--isSpecialSym :: Symbol -> BareM Bool-isSpecialSym s = do-  env0 <- gets (typeAliases . rtEnv)-  return $ or [s `elem` prims, M.member s env0]---addSym :: MonadState BareEnv m => (Symbol, Var) -> m ()-addSym (x, v) = modify $ \be -> be { varEnv = M.insert x v (varEnv be) } --  `L.union` [x] } -- TODO: OMG THIS IS THE SLOWEST THING IN THE WORLD!--isCon :: Symbol -> Bool-isCon s-  | Just (c,_) <- unconsSym s = isUpper c-  | otherwise                 = False--instance Resolvable Symbol where-  resolve l x = fmap val $ resolve l $ Loc l l x--instance Resolvable Sort where-  resolve _ FInt          = return FInt-  resolve _ FReal         = return FReal-  resolve _ FNum          = return FNum-  resolve _ FFrac         = return FFrac-  resolve _ s@(FObj _)    = return s --FObj . S <$> lookupName env m s-  resolve _ s@(FVar _)    = return s-  resolve l (FAbs i  s)   = FAbs i <$> (resolve l s)-  resolve l (FFunc s1 s2) = FFunc <$> (resolve l s1) <*> (resolve l s2)-  resolve _ (FTC c)-    | tcs' `elem` prims   = FTC <$> return c-    | otherwise           = do ty     <- lookupGhcTyCon "resolve1" tcs-                               emb    <- embeds <$> get-                               let ftc = FTC $ symbolFTycon $ Loc l l' $ symbol ty-                               return  $ M.lookupDefault ftc ty emb-    where-      tcs@(Loc l l' tcs') = fTyconSymbol c-  resolve l (FApp t1 t2) = FApp <$> resolve l t1 <*> resolve l t2--instance Resolvable (UReft Reft) where-  resolve l (MkUReft r p s) = MkUReft <$> resolve l r <*> resolve l p <*> return s--instance Resolvable Reft where-  resolve l (Reft (s, ra)) = Reft . (s,) <$> resolve l ra--instance Resolvable Predicate where-  resolve l (Pr pvs) = Pr <$> resolve l pvs--instance (Resolvable t) => Resolvable (PVar t) where-  resolve l (PV n t v as) = PV n t v <$> mapM (third3M (resolve l)) as--instance Resolvable () where-  resolve _ = return+-- | This module has the code that uses the GHC definitions to:+--   1. MAKE a name-resolution environment,+--   2. USE the environment to translate plain symbols into Var, TyCon, etc. ++{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TypeSynonymInstances  #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE TupleSections         #-}++module Language.Haskell.Liquid.Bare.Resolve +  ( -- * Creating the Environment+    makeEnv ++    -- * Resolving symbols +  , ResolveSym (..)+  , Qualify (..)+  , qualifyTop, qualifyTopDummy+  +  -- * Looking up names+  , maybeResolveSym +  , lookupGhcDataCon +  , lookupGhcDnTyCon +  , lookupGhcTyCon +  , lookupGhcVar +  , lookupGhcNamedVar ++  -- * Checking if names exist+  , knownGhcVar +  , knownGhcTyCon +  , knownGhcDataCon +  , knownGhcType ++  -- * Misc +  , srcVars ++  -- * Conversions from Bare+  , ofBareTypeE+  , ofBareType+  , ofBPVar++  -- * Post-processing types+  , txRefSort+  , errResolve++  -- * Fixing local variables+  , resolveLocalBinds +  , partitionLocalBinds +  ) where ++import qualified Control.Exception                 as Ex +import qualified Data.List                         as L +import qualified Data.HashSet                      as S +import qualified Data.Maybe                        as Mb+import qualified Data.HashMap.Strict               as M+import qualified Text.PrettyPrint.HughesPJ         as PJ ++import qualified Language.Fixpoint.Utils.Files         as F +import qualified Language.Fixpoint.Types               as F +import qualified Language.Fixpoint.Types.Visitor       as F +import qualified Language.Fixpoint.Misc                as Misc +import qualified Language.Haskell.Liquid.GHC.API       as Ghc +import qualified Language.Haskell.Liquid.GHC.Misc      as GM +import qualified Language.Haskell.Liquid.Misc          as Misc +import qualified Language.Haskell.Liquid.Types.RefType as RT+import qualified Language.Haskell.Liquid.Types.Errors  as Errors +import           Language.Haskell.Liquid.Types.Types   +import           Language.Haskell.Liquid.Types.Specs +import           Language.Haskell.Liquid.Types.Visitors +import           Language.Haskell.Liquid.Bare.Types +import           Language.Haskell.Liquid.Bare.Misc   +import           Language.Haskell.Liquid.WiredIn ++myTracepp :: (F.PPrint a) => String -> a -> a+myTracepp = F.notracepp ++-------------------------------------------------------------------------------+-- | Creating an environment +-------------------------------------------------------------------------------+makeEnv :: Config -> GhcSrc -> LogicMap -> [(ModName, BareSpec)] -> Env +makeEnv cfg src lmap specs = RE +  { reLMap      = lmap+  , reSyms      = syms +  , _reSubst    = makeVarSubst   src +  , _reTyThings = makeTyThingMap src +  , reQualImps  = gsQualImps     src+  , reAllImps   = gsAllImps      src+  , reLocalVars = makeLocalVars  src +  , reSrc       = src+  , reGlobSyms  = S.fromList     globalSyms +  , reCfg       = cfg+  } +  where +    globalSyms  = concatMap getGlobalSyms specs+    syms        = [ (F.symbol v, v) | v <- vars ] +    vars        = srcVars src++getGlobalSyms :: (ModName, BareSpec) -> [F.Symbol]+getGlobalSyms (_, spec) +  = filter (not . GM.isQualifiedSym) +       $ (mbName <$> measures  spec) +      ++ (mbName <$> cmeasures spec)+      ++ (mbName <$> imeasures spec)+  where +    mbName = F.val . msName++makeLocalVars :: GhcSrc -> LocalVars +makeLocalVars = localVarMap . localBinds . giCbs++-- TODO: rewrite using CoreVisitor+localBinds :: [Ghc.CoreBind] -> [Ghc.Var]+localBinds                    = concatMap (bgo S.empty) +  where+    add  x g                  = maybe g (`S.insert` g) (localKey x) +    adds b g                  = foldr add g (Ghc.bindersOf b) +    take x g                  = maybe [] (\k -> if S.member k g then [] else [x]) (localKey x)+    pgo g (x, e)              = take x g ++ go (add x g) e+    bgo g (Ghc.NonRec x e)    = pgo g (x, e) +    bgo g (Ghc.Rec xes)       = concatMap (pgo g) xes +    go  g (Ghc.App e a)       = concatMap (go  g) [e, a]+    go  g (Ghc.Lam _ e)       = go g e+    go  g (Ghc.Let b e)       = bgo g b ++ go (adds b g) e +    go  g (Ghc.Tick _ e)      = go g e+    go  g (Ghc.Cast e _)      = go g e+    go  g (Ghc.Case e _ _ cs) = go g e ++ concatMap (go g . Misc.thd3) cs+    go  _ (Ghc.Var _)         = []+    go  _ _                   = []++localVarMap :: [Ghc.Var] -> LocalVars+localVarMap vs = +  Misc.group [ (x, (i, v)) | v    <- vs+                           , x    <- Mb.maybeToList (localKey v) +                           , let i = F.srcLine v +             ]++localKey   :: Ghc.Var -> Maybe F.Symbol+localKey v +  | isLocal m = Just x +  | otherwise = Nothing+  where +    (m, x)    = splitModuleNameExact . GM.dropModuleUnique . F.symbol $ v ++makeVarSubst :: GhcSrc -> F.Subst +makeVarSubst src = F.mkSubst unqualSyms +  where +    unqualSyms   = [ (x, mkVarExpr v) +                       | (x, mxs) <- M.toList       (makeSymMap src) +                       , v        <- Mb.maybeToList (okUnqualified me mxs) +                       , not (isWiredInName x)+                   ] +    me           = F.symbol (giTargetMod src) ++-- | @okUnqualified mod mxs@ takes @mxs@ which is a list of modulenames-var +--   pairs all of which have the same unqualified symbol representation. +--   The function returns @Just v@ if +--   1. that list is a singleton i.e. there is a UNIQUE unqualified version, OR+--   2. there is a version whose module equals @me@.++okUnqualified :: F.Symbol -> [(F.Symbol, a)] -> Maybe a +okUnqualified _ [(_, x)] = Just x +okUnqualified me mxs     = go mxs +  where +    go []                = Nothing +    go ((m,x) : rest)    +      | me == m          = Just x +      | otherwise        = go rest +++makeSymMap :: GhcSrc -> M.HashMap F.Symbol [(F.Symbol, Ghc.Var)]+makeSymMap src = Misc.group [ (sym, (m, x)) +                                | x           <- srcVars src+                                , let (m, sym) = qualifiedSymbol x ]++makeTyThingMap :: GhcSrc -> TyThingMap +makeTyThingMap src =+  Misc.group [ (x, (m, t))  | t         <- srcThings src+                            , tSym      <- Mb.maybeToList (tyThingSymbol t)+                            , let (m, x) = qualifiedSymbol tSym +                            , not (isLocal m)+             ] ++tyThingSymbol :: Ghc.TyThing -> Maybe F.Symbol +tyThingSymbol (Ghc.AnId     x) = Just (F.symbol x)+tyThingSymbol (Ghc.ATyCon   c) = Just (F.symbol c)+tyThingSymbol (Ghc.AConLike d) = conLikeSymbol d +tyThingSymbol _tt              = Nothing -- panic Nothing ("TODO: tyThingSymbol" ++ showPpr tt)+++conLikeSymbol :: Ghc.ConLike -> Maybe F.Symbol +conLikeSymbol (Ghc.RealDataCon d) = Just (F.symbol d) +conLikeSymbol _z                   = Nothing -- panic Nothing ("TODO: conLikeSymbol -- " ++ showPpr z)+++++isLocal :: F.Symbol -> Bool+isLocal = isEmptySymbol ++qualifiedSymbol :: (F.Symbolic a) => a -> (F.Symbol, F.Symbol)+qualifiedSymbol = splitModuleNameExact . F.symbol ++isEmptySymbol :: F.Symbol -> Bool +isEmptySymbol x = F.lengthSym x == 0 ++srcThings :: GhcSrc -> [Ghc.TyThing] +srcThings src = myTracepp "SRCTHINGS" +              $ Misc.hashNubWith F.showpp (gsTyThings src ++ mySrcThings src) ++mySrcThings :: GhcSrc -> [Ghc.TyThing] +mySrcThings src = [ Ghc.AnId   x | x <- vars ] +               ++ [ Ghc.ATyCon c | c <- tcs  ] +               ++ [ aDataCon   d | d <- dcs  ] +  where +    vars        = Misc.sortNub $ dataConVars dcs ++ srcVars  src+    dcs         = Misc.sortNub $ concatMap Ghc.tyConDataCons tcs +    tcs         = Misc.sortNub $ srcTyCons src  +    aDataCon    = Ghc.AConLike . Ghc.RealDataCon ++srcTyCons :: GhcSrc -> [Ghc.TyCon]+srcTyCons src = concat +  [ gsTcs     src +  , gsFiTcs   src +  , gsPrimTcs src+  , srcVarTcs src +  ]++srcVarTcs :: GhcSrc -> [Ghc.TyCon]+srcVarTcs = varTyCons . srcVars ++varTyCons :: [Ghc.Var] -> [Ghc.TyCon]+varTyCons = concatMap (typeTyCons . Ghc.dropForAlls . Ghc.varType) ++typeTyCons :: Ghc.Type -> [Ghc.TyCon]+typeTyCons t = tops t ++ inners t +  where +    tops     = Mb.maybeToList . Ghc.tyConAppTyCon_maybe+    inners   = concatMap typeTyCons . snd . Ghc.splitAppTys ++-- | We prioritize the @Ghc.Var@ in @srcVars@ because @giDefVars@ and @gsTyThings@ +--   have _different_ values for the same binder, with different types where the +--   type params are alpha-renamed. However, for absref, we need _the same_ +--   type parameters as used by GHC as those are used inside the lambdas and+--   other bindings in the code. See also [NOTE: Plug-Holes-TyVars] and +--      tests-absref-pos-Papp00.hs ++srcVars :: GhcSrc -> [Ghc.Var]+srcVars src = filter Ghc.isId .  fmap Misc.thd3 . Misc.fstByRank $ concat +  [ key "SRC-VAR-DEF" 0 <$> giDefVars src +  , key "SRC-VAR-DER" 1 <$> S.toList (giDerVars src)+  , key "SRC-VAR-IMP" 2 <$> giImpVars src +  , key "SRC-VAR-USE" 3 <$> giUseVars src +  , key "SRC-VAR-THN" 4 <$> [ x | Ghc.AnId x <- gsTyThings src ]+  ]+  where +    key :: String -> Int -> Ghc.Var -> (Int, F.Symbol, Ghc.Var)+    key _ i x  = (i, F.symbol x, {- dump s -} x) +    _dump msg x = fst . myTracepp msg $ (x, RT.ofType (Ghc.expandTypeSynonyms (Ghc.varType x)) :: SpecType)++dataConVars :: [Ghc.DataCon] -> [Ghc.Var]+dataConVars dcs = concat +  [ Ghc.dataConWorkId <$> dcs +  , Ghc.dataConWrapId <$> dcs +  ] ++-------------------------------------------------------------------------------+-- | Qualify various names +-------------------------------------------------------------------------------+qualifyTop :: (Qualify a) => Env -> ModName -> F.SourcePos -> a -> a +qualifyTop env name l = qualify env name l []++qualifyTopDummy :: (Qualify a) => Env -> ModName -> a -> a +qualifyTopDummy env name = qualifyTop env name dummySourcePos++dummySourcePos :: F.SourcePos +dummySourcePos = F.loc (F.dummyLoc ())++class Qualify a where +  qualify :: Env -> ModName -> F.SourcePos -> [F.Symbol] -> a -> a ++instance Qualify TyConMap where +  qualify env name l bs tyi = tyi +    { tcmTyRTy = tx <$> tcmTyRTy tyi +    , tcmFIRTy = tx <$> tcmFIRTy tyi +    } +    where +      tx :: (Qualify a) => a -> a +      tx = qualify env name l bs ++instance Qualify TyConP where +  qualify env name _ bs tcp = tcp { tcpSizeFun = qualify env name (tcpLoc tcp) bs <$> tcpSizeFun tcp }++instance Qualify SizeFun where +  qualify env name _ bs (SymSizeFun lx) = SymSizeFun (qualify env name (F.loc lx) bs lx)+  qualify _   _    _ _  sf              = sf++instance Qualify F.Equation where +  qualify _env _name _l _bs x = x -- TODO-REBARE +-- REBARE: qualifyAxiomEq :: Bare.Env -> Var -> Subst -> AxiomEq -> AxiomEq+-- REBARE: qualifyAxiomEq v su eq = subst su eq { eqName = symbol v}++instance Qualify F.Symbol where +  qualify env name l bs x = qualifySymbol env name l bs x ++qualifySymbol :: Env -> ModName -> F.SourcePos -> [F.Symbol] -> F.Symbol -> F.Symbol                                                   +qualifySymbol env name l bs x+  | isSpl     = x +  | otherwise = case resolveLocSym env name "Symbol" (F.Loc l l x) of +                  Left  _ -> x +                  Right v -> v +  where +    isSpl     = isSplSymbol env bs x++isSplSymbol :: Env -> [F.Symbol] -> F.Symbol -> Bool +isSplSymbol env bs x +  =  isWiredInName x +  || elem x bs +  || S.member x (reGlobSyms env) ++instance (Qualify a) => Qualify (Located a) where +  qualify env name l bs = fmap (qualify env name l bs) ++instance (Qualify a) => Qualify [a] where+  qualify env name l bs = fmap (qualify env name l bs)++instance (Qualify a) => Qualify (Maybe a) where +  qualify env name l bs = fmap (qualify env name l bs) ++instance Qualify Body where +  qualify env name l bs (P   p) = P   (qualify env name l bs p) +  qualify env name l bs (E   e) = E   (qualify env name l bs e)+  qualify env name l bs (R x p) = R x (qualify env name l bs p)++instance Qualify TyConInfo where +  qualify env name l bs tci = tci { sizeFunction = qualify env name l bs <$> sizeFunction tci }++instance Qualify RTyCon where +  qualify env name l bs rtc = rtc { rtc_info = qualify env name l bs (rtc_info rtc) }++instance Qualify (Measure SpecType Ghc.DataCon) where +  qualify env name _ bs m = m -- FIXME substEnv env name bs $ +    { msName = qualify env name l bs     lname +    , msEqns = qualify env name l bs <$> msEqns m +    }+    where +      l      = F.loc  lname+      lname  = msName m+++instance Qualify (Def ty ctor) where +  qualify env name l bs d = d +    { body  = qualify env name l (bs ++ bs') (body d) } +    where +      bs'   = fst <$> binds d++instance Qualify BareMeasure where +  qualify env name l bs m = m +    { msEqns = qualify env name l bs (msEqns m)+    } ++instance Qualify DataCtor where +  qualify env name l bs c = c+    { dcTheta  = qualify env name l bs (dcTheta  c) +    , dcFields = qualify env name l bs (dcFields c) +    , dcResult = qualify env name l bs (dcResult c)+    }+ +instance Qualify DataDecl where +  qualify env name l bs d = d +    { tycDCons  = qualify env name l bs (tycDCons  d)+    , tycPropTy = qualify env name l bs (tycPropTy d) +    } ++instance Qualify ModSpecs where +  qualify env name l bs = Misc.hashMapMapWithKey (\_ -> qualify env name l bs) ++instance Qualify b => Qualify (a, b) where +  qualify env name l bs (x, y) = (x, qualify env name l bs y)++instance Qualify BareSpec where +  qualify = qualifyBareSpec ++qualifyBareSpec :: Env -> ModName -> F.SourcePos -> [F.Symbol] -> BareSpec -> BareSpec +qualifyBareSpec env name l bs sp = sp +  { measures   = qualify env name l bs (measures   sp) +  , asmSigs    = qualify env name l bs (asmSigs    sp)+  , sigs       = qualify env name l bs (sigs       sp)+  , localSigs  = qualify env name l bs (localSigs  sp)+  , reflSigs   = qualify env name l bs (reflSigs   sp)+  , dataDecls  = qualify env name l bs (dataDecls  sp)+  , newtyDecls = qualify env name l bs (newtyDecls sp)+  , ialiases   = [ (f x, f y) | (x, y) <- ialiases sp ]+  } +  where f      = qualify env name l bs ++instance Qualify F.Expr where +  qualify = substEnv ++instance Qualify RReft where +  qualify = substEnv++instance Qualify F.Qualifier where +  qualify env name _ bs q = q { F.qBody = qualify env name (F.qPos q) bs' (F.qBody q) } +    where +      bs'                 = bs ++ (F.qpSym <$> F.qParams q)++substEnv :: (F.Subable a) => Env -> ModName -> F.SourcePos -> [F.Symbol] -> a -> a +substEnv env name l bs = F.substa (qualifySymbol env name l bs) ++instance Qualify SpecType where +  qualify = substFreeEnv           ++instance Qualify BareType where +  qualify = substFreeEnv ++-- 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) ++-------------------------------------------------------------------------------+lookupGhcNamedVar :: (Ghc.NamedThing a, F.Symbolic a) => Env -> ModName -> a -> Maybe Ghc.Var+-------------------------------------------------------------------------------+lookupGhcNamedVar env name z = maybeResolveSym  env name "Var" lx+  where +    lx                       = GM.namedLocSymbol z++lookupGhcVar :: Env -> ModName -> String -> LocSymbol -> Ghc.Var +lookupGhcVar env name kind lx = +  case resolveLocSym env name kind lx of +    Right v -> Mb.fromMaybe v       (lookupLocalVar env lx [v]) +    Left  e -> Mb.fromMaybe (err e) (lookupLocalVar env lx []) +  where+    -- err e   = Misc.errorP "error-lookupGhcVar" (F.showpp (e, F.loc lx, lx))+    err     = Ex.throw++-- | @lookupLocalVar@ takes as input the list of "global" (top-level) vars +--   that also match the name @lx@; we then pick the "closest" definition. +--   See tests/names/LocalSpec.hs for a motivating example. ++lookupLocalVar :: Env -> LocSymbol -> [Ghc.Var] -> Maybe Ghc.Var+lookupLocalVar env lx gvs = Misc.findNearest lxn kvs+  where +    _msg                  = "LOOKUP-LOCAL: " ++ F.showpp (F.val lx, lxn, kvs)+    kvs                   = gs ++ M.lookupDefault [] x (reLocalVars env) +    gs                    = [(F.srcLine v, v) | v <- gvs]+    lxn                   = F.srcLine lx  +    (_, x)                = unQualifySymbol (F.val lx)+++lookupGhcDataCon :: Env -> ModName -> String -> LocSymbol -> Ghc.DataCon +lookupGhcDataCon = strictResolveSym ++lookupGhcTyCon :: Env -> ModName -> String -> LocSymbol -> Ghc.TyCon +lookupGhcTyCon env name k lx = myTracepp ("LOOKUP-TYCON: " ++ F.showpp (val lx)) +                               $ strictResolveSym env name k lx++lookupGhcDnTyCon :: Env -> ModName -> String -> DataName -> Maybe Ghc.TyCon+lookupGhcDnTyCon env name msg = failMaybe env name . lookupGhcDnTyConE env name msg++lookupGhcDnTyConE :: Env -> ModName -> String -> DataName -> Either UserError Ghc.TyCon+lookupGhcDnTyConE env name msg (DnCon  s) +  = lookupGhcDnCon env name msg s+lookupGhcDnTyConE env name msg (DnName s) +  = case resolveLocSym env name msg s of +      Right r -> Right r +      Left  e -> case lookupGhcDnCon  env name msg s of +                   Right r -> Right r +                   Left  _ -> Left  e++lookupGhcDnCon :: Env -> ModName -> String -> LocSymbol -> Either UserError Ghc.TyCon +lookupGhcDnCon env name msg = fmap Ghc.dataConTyCon . resolveLocSym env name msg++-------------------------------------------------------------------------------+-- | Checking existence of names +-------------------------------------------------------------------------------+knownGhcType :: Env ->  ModName -> LocBareType -> Bool+knownGhcType env name (F.Loc l _ t) = +  case ofBareTypeE env name l Nothing t of +    Left e  -> myTracepp ("knownType: " ++ F.showpp (t, e)) $ False +    Right _ -> True ++++_rTypeTyCons :: (Ord c) => RType c tv r -> [c]+_rTypeTyCons           = Misc.sortNub . foldRType f []   +  where +    f acc t@(RApp {}) = rt_tycon t : acc +    f acc _           = acc++-- Aargh. Silly that each of these is the SAME code, only difference is the type.++knownGhcVar :: Env -> ModName -> LocSymbol -> Bool +knownGhcVar env name lx = Mb.isJust v +  where +    v :: Maybe Ghc.Var -- This annotation is crucial+    v = myTracepp ("knownGhcVar " ++ F.showpp lx) +      $ maybeResolveSym env name "known-var" lx ++knownGhcTyCon :: Env -> ModName -> LocSymbol -> Bool +knownGhcTyCon env name lx = myTracepp  msg $ Mb.isJust v +  where +    msg = ("knownGhcTyCon: "  ++ F.showpp lx)+    v :: Maybe Ghc.TyCon -- This annotation is crucial+    v = maybeResolveSym env name "known-tycon" lx ++knownGhcDataCon :: Env -> ModName -> LocSymbol -> Bool +knownGhcDataCon env name lx = Mb.isJust v +  where +    v :: Maybe Ghc.DataCon -- This annotation is crucial+    v = myTracepp ("knownGhcDataCon" ++ F.showpp lx) +      $ maybeResolveSym env name "known-datacon" lx ++-------------------------------------------------------------------------------+-- | Using the environment +-------------------------------------------------------------------------------+class ResolveSym a where +  resolveLocSym :: Env -> ModName -> String -> LocSymbol -> Either UserError a +  +instance ResolveSym Ghc.Var where +  resolveLocSym = resolveWith "variable" $ \case +                    Ghc.AnId x -> Just x +                    _          -> Nothing++instance ResolveSym Ghc.TyCon where +  resolveLocSym = resolveWith "type constructor" $ \case +                    Ghc.ATyCon x             -> Just x+                    _                        -> Nothing++instance ResolveSym Ghc.DataCon where +  resolveLocSym = resolveWith "data constructor" $ \case +                    Ghc.AConLike (Ghc.RealDataCon x) -> Just x +                    _                                -> Nothing++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)++resolveWith :: (PPrint a) => PJ.Doc -> (Ghc.TyThing -> Maybe a) -> Env -> ModName -> String -> LocSymbol +            -> Either UserError a +resolveWith kind f env name str lx =+  -- case Mb.mapMaybe f things of +  case rankedThings f things of+    []  -> Left  (errResolve kind str lx) +    [x] -> Right x +    xs  -> Left $ ErrDupNames sp (pprint (F.val lx)) (pprint <$> xs)+  where+    -- oThings = Mb.mapMaybe (\(x, y) -> (x,) <$> f y) things+    _xSym   = (F.val lx)+    sp      = GM.fSrcSpanSrcSpan (F.srcSpan lx)+    things  = myTracepp msg $ lookupTyThing env name lx +    msg     = "resolveWith: " ++ str ++ " " ++ F.showpp (val lx)+++rankedThings :: (Misc.EqHash k) => (a -> Maybe b) -> [(k, a)] -> [b]+rankedThings f ias = case Misc.sortOn fst (Misc.groupList ibs) of +                       (_,ts):_ -> ts+                       []       -> []+  where +    ibs            = Mb.mapMaybe (\(k, x) -> (k,) <$> f x) ias++-------------------------------------------------------------------------------+-- | @lookupTyThing@ is the central place where we lookup the @Env@ to find +--   any @Ghc.TyThing@ that match that name. The code is a bit hairy as we+--   have various heuristics to approximiate how GHC resolves names. e.g. +--   see tests-names-pos-*.hs, esp. vector04.hs where we need the name `Vector` +--   to resolve to `Data.Vector.Vector` and not `Data.Vector.Generic.Base.Vector`... +-------------------------------------------------------------------------------+lookupTyThing :: Env -> ModName -> LocSymbol -> [((Int, F.Symbol), Ghc.TyThing)]+-------------------------------------------------------------------------------+lookupTyThing env name lsym = [ (k, t) | (k, ts) <- ordMatches, t <- ts] +                              +  where +    ordMatches             = Misc.sortOn fst (Misc.groupList matches)+    matches                = myTracepp ("matches-" ++ msg)+                             [ ((k, m), t) | (m, t) <- lookupThings env x+                                           , k      <- myTracepp msg $ mm nameSym m mods ]+    msg                    = "lookupTyThing: " ++ F.showpp (lsym, x, mods)+    (x, mods)              = symbolModules env (F.val lsym)+    nameSym                = F.symbol name+    allowExt               = allowExtResolution env lsym +    mm name m mods         = myTracepp ("matchMod: " ++ F.showpp (lsym, name, m, mods, allowExt)) $ +                               matchMod env name m allowExt mods ++-- | [NOTE:External-Resolution] @allowExtResolution@ determines whether a @LocSymbol@ +--   can be resolved by a @TyThing@ that is _outside_ the module corresponding to @LocSymbol@. +--   We need to allow this, e.g. to resolve names like @Data.Set.Set@ with @Data.Set.Internal.Set@, +--   but should do so ONLY when the LocSymbol comes from a "hand-written" .spec file or +--   something from the LH prelude. Other names, e.g. from "machine-generated" .bspec files +--   should already be FULLY-qualified to to their actual definition (e.g. Data.Set.Internal.Set) +--   and so we should DISALLOW external-resolution in such cases.++allowExtResolution :: Env -> LocSymbol -> Bool +allowExtResolution env lx = case fileMb of +  Nothing   -> True +  Just f    -> myTracepp ("allowExt: " ++ show (f, tgtFile)) +                 $ f == tgtFile || Misc.isIncludeFile incDir f || F.isExtFile F.Spec f +  where +    tgtFile = giTarget (reSrc env)+    incDir  = giIncDir (reSrc env)+    fileMb  = Errors.srcSpanFileMb (GM.fSrcSpan lx) ++lookupThings :: Env -> F.Symbol -> [(F.Symbol, Ghc.TyThing)] +lookupThings env x = myTracepp ("lookupThings: " ++ F.showpp x) +                   $ Misc.fromFirstMaybes [] (get <$> [x, GM.stripParensSym x])+  where +    get z          = M.lookup z (_reTyThings env)++matchMod :: Env -> F.Symbol -> F.Symbol -> Bool -> Maybe [F.Symbol] -> [Int]+matchMod env tgtName defName allowExt = go +  where +    go Nothing               -- Score UNQUALIFIED names +     | defName == tgtName = [0]                       -- prioritize names defined in *this* module +     | otherwise          = [matchImp env defName 1]  -- prioritize directly imported modules over +                                                      -- names coming from elsewhere, with a ++    go (Just ms)             -- Score QUALIFIED names+     |  isEmptySymbol defName +     && ms == [tgtName]   = [0]                       -- local variable, see tests-names-pos-local00.hs+     | ms == [defName]    = [1]+     | allowExt && isExt  = [matchImp env defName 2]  -- to allow matching re-exported names e.g. Data.Set.union for Data.Set.Internal.union+     | otherwise          = []  +     where +       isExt              = allowExt && any (`F.isPrefixOfSym` defName) ms++symbolModules :: Env -> F.Symbol -> (F.Symbol, Maybe [F.Symbol])+symbolModules env s = (x, glerb <$> modMb) +  where +    (modMb, x)      = unQualifySymbol s +    glerb m         = M.lookupDefault [m] m qImps +    qImps           = qiNames (reQualImps env)  ++-- | @matchImp@ lets us prioritize @TyThing@ defined in directly imported modules over +--   those defined elsewhere. Specifically, in decreasing order of priority we have +--   TyThings that we:+--   * DIRECTLY     imported WITHOUT qualification +--   * TRANSITIVELY imported (e.g. were re-exported by SOME imported module)+--   * QUALIFIED    imported (so qualify the symbol to get this result!) + +matchImp :: Env -> F.Symbol -> Int -> Int +matchImp env defName i   +  | isUnqualImport = i      +  | isQualImport   = i + 2  +  | otherwise      = i + 1  +  where+    isUnqualImport = S.member defName (reAllImps env) && not isQualImport +    isQualImport   = S.member defName (qiModules (reQualImps env))+++-- | `unQualifySymbol name sym` splits `sym` into a pair `(mod, rest)` where +--   `mod` is the name of the module, derived from `sym` if qualified.+unQualifySymbol :: F.Symbol -> (Maybe F.Symbol, F.Symbol)+unQualifySymbol sym +  | GM.isQualifiedSym sym = Misc.mapFst Just (splitModuleNameExact sym) +  | otherwise             = (Nothing, sym) ++splitModuleNameExact :: F.Symbol -> (F.Symbol, F.Symbol)+splitModuleNameExact x' = myTracepp ("splitModuleNameExact for " ++ F.showpp x) +                          (GM.takeModuleNames x, GM.dropModuleNames x)+  where+    x = GM.stripParensSym x' ++errResolve :: PJ.Doc -> String -> LocSymbol -> UserError +errResolve k msg lx = ErrResolve (GM.fSrcSpan lx) k (F.pprint (F.val lx)) (PJ.text msg) ++-- symbolicString :: F.Symbolic a => a -> String+-- symbolicString = F.symbolString . F.symbol++-- | @strictResolve@ wraps the plain @resolve@ to throw an error +--   if the name being searched for is unknown.+strictResolveSym :: (ResolveSym a) => Env -> ModName -> String -> LocSymbol -> a +strictResolveSym env name kind x = case resolveLocSym env name kind x of +  Left  err -> Misc.errorP "error-strictResolveSym" (F.showpp err) -- uError err +  Right val -> val ++-- | @maybeResolve@ wraps the plain @resolve@ to return @Nothing@ +--   if the name being searched for is unknown.+maybeResolveSym :: (ResolveSym a) => Env -> ModName -> String -> LocSymbol -> Maybe a +maybeResolveSym env name kind x = case resolveLocSym env name kind x of +  Left  _   -> Nothing +  Right val -> Just val +  +-------------------------------------------------------------------------------+-- | @ofBareType@ and @ofBareTypeE@ should be the _only_ @SpecType@ constructors+-------------------------------------------------------------------------------+ofBareType :: Env -> ModName -> F.SourcePos -> Maybe [PVar BSort] -> BareType -> SpecType +ofBareType env name l ps t = either fail id (ofBareTypeE env name l ps t)+  where +    fail                   = Ex.throw +    -- fail                   = Misc.errorP "error-ofBareType" . F.showpp ++ofBareTypeE :: Env -> ModName -> F.SourcePos -> Maybe [PVar BSort] -> BareType -> Either UserError SpecType +ofBareTypeE env name l ps t = ofBRType env name (resolveReft env name l ps t) l t ++resolveReft :: Env -> ModName -> F.SourcePos -> Maybe [PVar BSort] -> BareType -> [F.Symbol] -> RReft -> RReft +resolveReft env name l ps t bs+        = qualify env name l bs +        . txParam l RT.subvUReft (RT.uPVar <$> πs) t+        . fixReftTyVars t       -- same as fixCoercions +  where +    πs  = Mb.fromMaybe tπs ps  +    tπs = ty_preds (toRTypeRep t) +     +fixReftTyVars :: BareType -> RReft -> RReft +fixReftTyVars bt  = coSubRReft coSub +  where+    coSub         = M.fromList [ (F.symbol a, F.FObj (specTvSymbol a)) | a <- tvs ]+    tvs           = RT.allTyVars bt+    specTvSymbol  = F.symbol . RT.bareRTyVar++coSubRReft :: F.CoSub -> RReft -> RReft +coSubRReft su r = r { ur_reft = coSubReft su (ur_reft r) } ++coSubReft :: F.CoSub -> F.Reft -> F.Reft +coSubReft su (F.Reft (x, e)) = F.Reft (x, F.applyCoSub su e)+++ofBSort :: Env -> ModName -> F.SourcePos -> BSort -> RSort +ofBSort env name l t = either (Misc.errorP "error-ofBSort" . F.showpp) id (ofBSortE env name l t)++ofBSortE :: Env -> ModName -> F.SourcePos -> BSort -> Either UserError RSort +ofBSortE env name l t = ofBRType env name (const id) l t +  +ofBPVar :: Env -> ModName -> F.SourcePos -> BPVar -> RPVar+ofBPVar env name l = fmap (ofBSort env name l) ++--------------------------------------------------------------------------------+txParam :: F.SourcePos -> ((UsedPVar -> UsedPVar) -> t) -> [UsedPVar] -> RType c tv r -> t+txParam l f πs t = f (txPvar l (predMap πs t))++txPvar :: F.SourcePos -> M.HashMap F.Symbol UsedPVar -> UsedPVar -> UsedPVar+txPvar l m π = π { pargs = args' }+  where+    args' | not (null (pargs π)) = zipWith (\(_,x ,_) (t,_,y) -> (t, x, y)) (pargs π') (pargs π)+          | otherwise            = pargs π'+    π'    = Mb.fromMaybe err $ M.lookup (pname π) m+    err   = uError $ ErrUnbPred sp (pprint π)+    sp    = GM.sourcePosSrcSpan l ++predMap :: [UsedPVar] -> RType c tv r -> M.HashMap F.Symbol UsedPVar+predMap πs t = M.fromList [(pname π, π) | π <- πs ++ rtypePredBinds t]++rtypePredBinds :: RType c tv r -> [UsedPVar]+rtypePredBinds = map RT.uPVar . ty_preds . toRTypeRep++++--------------------------------------------------------------------------------+type Expandable r = ( PPrint r+                    , F.Reftable r+                    , SubsTy RTyVar (RType RTyCon RTyVar ()) r+                    , F.Reftable (RTProp RTyCon RTyVar r))++ofBRType :: (Expandable r) => Env -> ModName -> ([F.Symbol] -> r -> r) -> F.SourcePos -> BRType r +         -> Either UserError (RRType r)+ofBRType env name f l t  = go [] t +  where+    goReft bs r             = return (f bs r) +    goRImpF bs x t1 t2 r    = RImpF x <$> (rebind x <$> go bs t1) <*> go (x:bs) t2 <*> goReft bs r+    goRFun  bs x t1 t2 r    = RFun  x <$> (rebind x <$> go bs t1) <*> go (x:bs) t2 <*> goReft bs r+    rebind x t              = F.subst1 t (x, F.EVar $ rTypeValueVar t)+    go bs (RAppTy t1 t2 r)  = RAppTy <$> go bs t1 <*> go bs t2 <*> goReft bs r+    go bs (RApp tc ts rs r) = goRApp bs tc ts rs r +    go bs (RImpF x 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 +      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+      where xts'            = mapM (Misc.mapSndM (go bs)) xts+    go bs (RHole r)         = RHole    <$> goReft bs r+    go bs (RExprArg le)     = return    $ RExprArg (qualify env name l bs le) +    goRef bs (RProp ss (RHole r)) = rPropP <$> (mapM goSyms ss) <*> goReft bs r+    goRef bs (RProp ss t)         = RProp  <$> (mapM goSyms ss) <*> go bs t+    goSyms (x, t)                 = (x,) <$> ofBSortE env name l t +    goRApp bs tc ts rs r          = bareTCApp <$> goReft bs r <*> lc' <*> mapM (goRef bs) rs <*> mapM (go bs) ts+      where+        lc'                    = F.atLoc lc <$> matchTyCon env name lc (length ts)+        lc                     = btc_tc tc+    -- goRApp _ _ _ _             = impossible Nothing "goRApp failed through to final case"++{- +    -- TODO-REBARE: goRImpF bounds _ (RApp c ps' _ _) t _+    -- TODO-REBARE:  | Just bnd <- M.lookup (btc_tc c) bounds+    -- TODO-REBARE:   = do let (ts', ps) = splitAt (length $ tyvars bnd) ps'+    -- TODO-REBARE:        ts <- mapM go ts'+    -- TODO-REBARE:        makeBound bnd ts [x | RVar (BTV x) _ <- ps] <$> go t+    -- TODO-REBARE: goRFun bounds _ (RApp c ps' _ _) t _+    -- TODO-REBARE: | Just bnd <- M.lookup (btc_tc c) bounds+    -- TODO-REBARE: = do let (ts', ps) = splitAt (length $ tyvars bnd) ps'+    -- TODO-REBARE: ts <- mapM go ts'+    -- TODO-REBARE: makeBound bnd ts [x | RVar (BTV x) _ <- ps] <$> go t++  -- TODO-REBARE: ofBareRApp env name t@(F.Loc _ _ !(RApp tc ts _ r))+  -- TODO-REBARE: | Loc l _ c <- btc_tc tc+  -- TODO-REBARE: , Just rta <- M.lookup c aliases+  -- TODO-REBARE: = appRTAlias l rta ts =<< resolveReft r++-}++matchTyCon :: Env -> ModName -> LocSymbol -> Int -> Either UserError Ghc.TyCon+matchTyCon env name lc@(Loc _ _ c) arity+  | isList c && arity == 1  = Right Ghc.listTyCon+  | isTuple c               = Right tuplTc +  | otherwise               = resolveLocSym env name msg lc +  where +    msg                     = "matchTyCon: " ++ F.showpp c+    tuplTc                  = Ghc.tupleTyCon Ghc.Boxed arity +++bareTCApp :: (Expandable r) +          => r+          -> Located Ghc.TyCon+          -> [RTProp RTyCon RTyVar r]+          -> [RType RTyCon RTyVar r]+          -> (RType RTyCon RTyVar r)+bareTCApp r (Loc l _ c) rs ts | Just rhs <- Ghc.synTyConRhs_maybe c+  = if (GM.kindTCArity c < length ts) +      then Ex.throw err -- error (F.showpp err)+      else tyApp (RT.subsTyVars_meet su $ RT.ofType rhs) (drop nts ts) rs r+    where+       tvs = [ v | (v, b) <- zip (GM.tyConTyVarsDef c) (Ghc.tyConBinders c), GM.isAnonBinder b]+       su  = zipWith (\a t -> (RT.rTyVar a, toRSort t, t)) tvs ts+       nts = length tvs++       err :: UserError+       err = ErrAliasApp (GM.sourcePosSrcSpan l) (pprint c) (Ghc.getSrcSpan c)+                         (PJ.hcat [ PJ.text "Expects"+                                  , pprint (GM.realTcArity c) +                                  , PJ.text "arguments, but is given" +                                  , pprint (length ts) ] )+-- TODO expandTypeSynonyms here to+bareTCApp r (Loc _ _ c) rs ts | Ghc.isFamilyTyCon c && isTrivial t+  = expandRTypeSynonyms (t `RT.strengthen` r)+  where t = RT.rApp c ts rs mempty++bareTCApp r (Loc _ _ c) rs ts+  = RT.rApp c ts rs r+++tyApp :: F.Reftable r => RType c tv r -> [RType c tv r] -> [RTProp c tv r] -> r +      -> RType c tv r+tyApp (RApp c ts rs r) ts' rs' r' = RApp c (ts ++ ts') (rs ++ rs') (r `F.meet` r')+tyApp t                []  []  r  = t `RT.strengthen` r+tyApp _                 _  _   _  = panic Nothing $ "Bare.Type.tyApp on invalid inputs"++expandRTypeSynonyms :: (Expandable r) => RRType r -> RRType r+expandRTypeSynonyms = RT.ofType . Ghc.expandTypeSynonyms . RT.toType++{- +expandRTypeSynonyms :: (Expandable r) => RRType r -> RRType r+expandRTypeSynonyms t+  | rTypeHasHole t = t +  | otherwise      = expandRTypeSynonyms' t++rTypeHasHole :: RType c tv r -> Bool+rTypeHasHole = foldRType f False+  where +    f _ (RHole _) = True+    f b _         = b+-}++------------------------------------------------------------------------------------------+-- | Is this the SAME as addTyConInfo? No. `txRefSort`+-- (1) adds the _real_ sorts to RProp,+-- (2) gathers _extra_ RProp at turns them into refinements,+--     e.g. tests/pos/multi-pred-app-00.hs+------------------------------------------------------------------------------------------++txRefSort :: TyConMap -> F.TCEmb Ghc.TyCon -> LocSpecType -> LocSpecType+txRefSort tyi tce t = F.atLoc t $ mapBot (addSymSort (GM.fSrcSpan t) tce tyi) (val t)++addSymSort :: Ghc.SrcSpan -> F.TCEmb Ghc.TyCon -> TyConMap -> SpecType -> SpecType +addSymSort sp tce tyi (RApp rc@(RTyCon {}) ts rs r)+  = RApp rc ts (zipWith3 (addSymSortRef sp rc) pvs rargs [1..]) r'+  where+    (_, pvs)           = RT.appRTyCon tce tyi rc ts+    -- pvs             = rTyConPVs rc'+    (rargs, rrest)     = splitAt (length pvs) rs+    r'                 = L.foldl' go r rrest+    go r (RProp _ (RHole r')) = r' `F.meet` r+    go r (RProp  _ t' )       = let r' = Mb.fromMaybe mempty (stripRTypeBase t') in r `F.meet` r'++addSymSort _ _ _ t+  = t++addSymSortRef :: (PPrint s) => Ghc.SrcSpan -> s -> RPVar -> SpecProp -> Int -> SpecProp +addSymSortRef sp rc p r i+  | isPropPV p+  = addSymSortRef' sp rc i p r+  | otherwise+  = panic Nothing "addSymSortRef: malformed ref application"+              +addSymSortRef' :: (PPrint s) => Ghc.SrcSpan -> s -> Int -> RPVar -> SpecProp -> SpecProp +addSymSortRef' _ _ _ p (RProp s (RVar v r)) | isDummy v+  = RProp xs t+    where+      t  = ofRSort (pvType p) `RT.strengthen` r+      xs = spliceArgs "addSymSortRef 1" s p++addSymSortRef' sp rc i p (RProp _ (RHole r@(MkUReft _ (Pr [up]) _)))+  | length xs == length ts+  = RProp xts (RHole r)+  | otherwise+  = -- Misc.errorP "ZONK" $ F.showpp (rc, pname up, i, length xs, length ts)+    uError $ ErrPartPred sp (pprint rc) (pprint $ pname up) i (length xs) (length ts)+    where+      xts = Misc.safeZipWithError "addSymSortRef'" xs ts+      xs  = Misc.snd3 <$> pargs up+      ts  = Misc.fst3 <$> pargs p++addSymSortRef' _ _ _ _ (RProp s (RHole r))+  = RProp s (RHole r)++addSymSortRef' _ _ _ p (RProp s t)+  = RProp xs t+    where+      xs = spliceArgs "addSymSortRef 2" s p++spliceArgs :: String  -> [(F.Symbol, b)] -> PVar t -> [(F.Symbol, t)]+spliceArgs msg s p = go (fst <$> s) (pargs p)+  where+    go []     []           = []+    go []     ((s,x,_):as) = (x, s):go [] as+    go (x:xs) ((s,_,_):as) = (x,s):go xs as+    go xs     []           = panic Nothing $ "spliceArgs: " ++ msg ++ "on XS=" ++ show xs++---------------------------------------------------------------------------------+-- RJ: formerly, `replaceLocalBinds` AFAICT+-- | @resolveLocalBinds@ resolves that the "free" variables that appear in the +--   type-sigs for non-toplevel binders (that correspond to other locally bound)+--   source variables that are visible at that at non-top-level scope. +--   e.g. tests-names-pos-local02.hs  +---------------------------------------------------------------------------------+resolveLocalBinds :: Env -> [(Ghc.Var, LocBareType, Maybe [Located F.Expr])] +                  -> [(Ghc.Var, LocBareType, Maybe [Located F.Expr])]+---------------------------------------------------------------------------------+resolveLocalBinds env xtes = [ (x,t,es) | (x, (t, es)) <- topTs ++ replace locTs ]+  where +    (locTs, topTs)         = partitionLocalBinds [ (x, (t, es)) | (x, t, es) <- xtes] +    replace                = M.toList . replaceSigs . M.fromList +    replaceSigs sigm       = coreVisitor replaceVisitor M.empty sigm cbs +    cbs                    = giCbs (reSrc env)++replaceVisitor :: CoreVisitor SymMap SigMap +replaceVisitor = CoreVisitor +  { envF  = addBind+  , bindF = updSigMap+  , exprF = \_ m _ -> m +  }++addBind :: SymMap -> Ghc.Var -> SymMap +addBind env v = case localKey v of +  Just vx -> M.insert vx (F.symbol v) env +  Nothing -> env+    +updSigMap :: SymMap -> SigMap -> Ghc.Var -> SigMap +updSigMap env m v = case M.lookup v m of +  Nothing  -> m +  Just tes -> M.insert v (myTracepp ("UPD-LOCAL-SIG " ++ GM.showPpr v) $ renameLocalSig env tes) m++renameLocalSig :: SymMap -> (LocBareType, Maybe [Located F.Expr]) +               -> (LocBareType, Maybe [Located F.Expr])  +renameLocalSig env (t, es) = (F.substf tSub t, F.substf esSub es) +  where +    tSub                   = F.EVar . qualifySymMap env +    esSub                  = tSub `F.substfExcept` xs+    xs                     = ty_binds (toRTypeRep (F.val t)) ++qualifySymMap :: SymMap -> F.Symbol -> F.Symbol +qualifySymMap env x = M.lookupDefault x x env ++type SigMap = M.HashMap Ghc.Var  (LocBareType, Maybe [Located F.Expr])+type SymMap = M.HashMap F.Symbol F.Symbol++---------------------------------------------------------------------------------+partitionLocalBinds :: [(Ghc.Var, a)] -> ([(Ghc.Var, a)], [(Ghc.Var, a)])+---------------------------------------------------------------------------------+partitionLocalBinds = L.partition (Mb.isJust . localKey . fst)
− src/Language/Haskell/Liquid/Bare/Spec.hs 
@@ -1,381 +0,0 @@-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ParallelListComp  #-}-{-# LANGUAGE TupleSections     #-}-{-# LANGUAGE BangPatterns      #-}--module Language.Haskell.Liquid.Bare.Spec (-    makeClasses-  , makeQualifiers-  , makeHints-  , makeLVar-  , makeLazy-  , makeAutoInsts-  , makeDefs-  , makeHMeas, makeHInlines-  , makeTExpr-  , makeTargetVars-  , makeAssertSpec-  , makeAssumeSpec-  , makeDefaultMethods-  , makeIAliases-  , makeInvariants-  , makeNewTypes-  , makeSpecDictionaries-  , makeBounds-  , makeHBounds-  , lookupIds-  ) where--import           CoreSyn                                    (CoreBind)-import           DataCon-import           MonadUtils                                 (mapMaybeM)-import           Prelude                                    hiding (error)-import           TyCon-import           Var--import qualified OccName as NS-import           Control.Monad.Except-import           Control.Monad.State-import           Data.Maybe---import qualified Data.List                                  as L-import qualified Data.HashSet                               as S-import qualified Data.HashMap.Strict                        as M--import qualified Language.Fixpoint.Misc                     as Misc-import qualified Language.Fixpoint.Types                    as F-import qualified Language.Fixpoint.Types.Visitor            as F--import           Language.Haskell.Liquid.Types.Dictionaries-import           Language.Haskell.Liquid.GHC.Misc-import           Language.Haskell.Liquid.Misc-import           Language.Haskell.Liquid.Types.RefType-import           Language.Haskell.Liquid.Types              hiding (freeTyVars)-import           Language.Haskell.Liquid.Types.Bounds--import qualified Language.Haskell.Liquid.Measure            as Ms--import           Language.Haskell.Liquid.Bare.Env-import           Language.Haskell.Liquid.Bare.Existential-import           Language.Haskell.Liquid.Bare.Lookup-import           Language.Haskell.Liquid.Bare.Misc          (joinVar)-import           Language.Haskell.Liquid.Bare.OfType-import           Language.Haskell.Liquid.Bare.Resolve-import           Language.Haskell.Liquid.Bare.SymSort-import           Language.Haskell.Liquid.Bare.Measure--makeClasses :: ModName-            -> Config-            -> [Var]-            -> (ModName, Ms.Spec (Located BareType) bndr)-            -> BareM [((DataCon, DataConP), [(ModName, Var, LocSpecType)])]-makeClasses cmod cfg vs (mod, spec) = inModule mod $ mapM mkClass $ Ms.classes spec-  where-    --FIXME: cleanup this code-    unClass = snd . bkClass . fourth4 . bkUniv-    mkClass (RClass cc ss as ms)-            = do let c      = btc_tc cc-                 let l      = loc  c-                 let l'     = locE c-                 tc        <- lookupGhcTyCon "makeClasses" c-                 ss'       <- mapM mkLSpecType ss-                 let (dc:_) = tyConDataCons tc-                 let αs  = map bareRTyVar as-                 let as' = [rVar $ symbolTyVar $ F.symbol a | a <- as ]-                 let ms' = [ (s, rFun "" (RApp cc (flip RVar mempty <$> as) [] mempty) <$> t) | (s, t) <- ms]-                 vts <- makeSpec (noCheckUnknown cfg || cmod /= mod) vs ms'-                 let sts = [(val s, unClass $ val t) | (s, _)    <- ms-                                                     | (_, _, t) <- vts]-                 let t   = rCls tc as'-                 let dcp = DataConP l αs [] [] (val <$> ss') (reverse sts) t False (F.symbol mod) l'-                 return ((dc,dcp),vts)--makeQualifiers :: (ModName, Ms.Spec ty bndr)-               -> BareM [F.Qualifier]-makeQualifiers (mod,spec) = inModule mod mkQuals-  where-    mkQuals = mapM (\q -> resolve (F.qPos q) q) $ Ms.qualifiers spec--makeHints :: [Var] -> Ms.Spec ty bndr -> BareM [(Var, [Int])]-makeHints   vs spec = varSymbols id vs $ Ms.decr spec--makeLVar :: [Var]-         -> Ms.Spec ty bndr-         -> BareM [Var]-makeLVar    vs spec = fmap fst <$> varSymbols id vs [(v, ()) | v <- Ms.lvars spec]--makeLazy :: [Var]-         -> Ms.Spec ty bndr-         -> BareM [Var]-makeLazy    vs spec = fmap fst <$> varSymbols id vs [(v, ()) | v <- S.toList $ Ms.lazy spec]--makeAutoInsts :: [Var]-              -> Ms.Spec ty bndr-              -> BareM [(Var, Maybe Int)]-makeAutoInsts vs spec = varSymbols id vs (M.toList $ Ms.autois spec)--makeDefs :: [Var] -> Ms.Spec ty bndr -> BareM [(Var, F.Symbol)]-makeDefs vs spec = varSymbols id vs (M.toList $ Ms.defs spec)--makeHBounds :: [Var] -> Ms.Spec ty bndr -> BareM [(Var, LocSymbol)]-makeHBounds vs spec = varSymbols id vs [(v, v ) | v <- S.toList $ Ms.hbounds spec]--makeTExpr :: [Var] -> Ms.Spec ty bndr -> BareM [(Var, [Located F.Expr])]-makeTExpr   vs spec = varSymbols id vs $ Ms.termexprs spec--makeHInlines :: [Var] -> Ms.Spec ty bndr -> BareM [(Located Var, LocSymbol)]-makeHInlines = makeHIMeas Ms.inlines--makeHMeas :: [Var] -> Ms.Spec ty bndr -> BareM [(Located Var, LocSymbol)]-makeHMeas = makeHIMeas Ms.hmeas--makeHIMeas :: (Ms.Spec ty bndr -> S.HashSet LocSymbol)-           -> [Var]-           -> Ms.Spec ty bndr-           -> BareM [(Located Var, LocSymbol)]-makeHIMeas f vs spec-  = fmap tx <$> varSymbols id vs [(v, (loc v, locE v, v)) | v <- S.toList (f spec)]-  where-    tx (x, (l, l', s))  = (Loc l l' x, s)--varSymbols :: ([Var] -> [Var]) -> [Var] -> [(LocSymbol, a)] -> BareM [(Var, a)]-varSymbols f vs = concatMapM go-  where-    lvs         = M.map L.sort $ Misc.group [(sym v, locVar v) | v <- vs]-    sym         = dropModuleNames . F.symbol . showPpr-    locVar v    = (getSourcePos v, v)-    go (s, ns)  = case M.lookup (val s) lvs of-                    Just lvs -> return  ((, ns) <$> varsAfter f s lvs)-                    Nothing  -> ((:[]) . (,ns)) <$> lookupGhcVar s--varsAfter :: ([b] -> [b]) -> Located a -> [(F.SourcePos, b)] -> [b]-varsAfter f s lvs-  | eqList (fst <$> lvs)    = f (snd <$> lvs)-  | otherwise               = map snd $ takeEqLoc $ dropLeLoc lvs-  where-    takeEqLoc xs@((l, _):_) = L.takeWhile ((l==) . fst) xs-    takeEqLoc []            = []-    dropLeLoc               = L.dropWhile ((loc s >) . fst)-    eqList []               = True-    eqList (x:xs)           = all (==x) xs-------------------------------------------------------------------------------------- | API: Bare Refinement Types -----------------------------------------------------------------------------------------------------------------------------------makeTargetVars :: ModName -> [Var] -> [String] -> BareM [Var]-makeTargetVars name vs ss-  = do env   <- gets hscEnv-       ns    <- liftIO $ concatMapM (lookupName env name (Just NS.varName) . dummyLoc . prefix) ss-       return $ filter ((`elem` ns) . varName) vs-    where-       prefix s = qualifySymbol (F.symbol name) (F.symbol s)--makeAssertSpec :: ModName -> Config -> [Var] -> [Var] -> (ModName, Ms.BareSpec)-               -> BareM [(ModName, Var, LocSpecType)]-makeAssertSpec cmod cfg vs lvs (mod, spec)-  | cmod == mod-  = makeLocalSpec cfg cmod vs lvs (grepClassAsserts (Ms.rinstance spec)) (Ms.sigs spec ++ Ms.localSigs spec)-  | otherwise-  = inModule mod $ makeSpec True vs $ Ms.sigs spec--makeAssumeSpec-  :: ModName -> Config -> [Var] -> [Var] -> (ModName, Ms.BareSpec)-  -> BareM [(ModName, Var, LocSpecType)]-makeAssumeSpec cmod cfg vs lvs (mod, spec)-  | cmod == mod-  = makeLocalSpec cfg cmod vs lvs (grepClassAssumes (Ms.rinstance spec)) $ Ms.asmSigs spec-  | otherwise-  = inModule mod $ makeSpec True vs $  Ms.asmSigs spec--grepClassAsserts :: [RInstance t] -> [(Located F.Symbol, t)]-grepClassAsserts           = concatMap go-   where-    go    xts              = mapMaybe goOne (risigs xts)-    goOne (x, RISig t)     = Just ((F.symbol . (".$c" ++ ) . F.symbolString) <$> x, t)-    goOne (_, RIAssumed _) = Nothing--grepClassAssumes :: [RInstance t] -> [(Located F.Symbol, t)]-grepClassAssumes  = concatMap go-   where-    go    xts              = catMaybes $ map goOne $ risigs xts-    goOne (x, RIAssumed t) = Just (fmap (F.symbol . (".$c" ++ ) . F.symbolString) x, t)-    goOne (_, RISig _)     = Nothing--makeDefaultMethods :: [Var] -> [(ModName,Var,Located SpecType)]-                   -> [(ModName, Var ,Located SpecType)]-makeDefaultMethods defVs sigs-  = [ (m,dmv,t)-    | dmv <- defVs-    , let dm = F.symbol $ showPpr dmv-    , "$dm" `F.isPrefixOfSym` dropModuleNames dm-    , let mod = takeModuleNames dm-    , let method = qualifySymbol mod $ F.dropSym 3 (dropModuleNames dm)-    , let mb = L.find ((method `F.isPrefixOfSym`) . F.symbol . Misc.snd3) sigs-    , isJust mb-    , let Just (m,_,t) = mb-    ]--makeLocalSpec :: Config -> ModName -> [Var] -> [Var]-              -> [(LocSymbol, Located BareType)]-              -> [(LocSymbol, Located BareType)]-              -> BareM [(ModName, Var, Located SpecType)]-makeLocalSpec cfg mod vs lvs cbs xbs-  = do vbs1  <- fmap expand3 <$> varSymbols fchoose lvs (dupSnd <$> xbs1)-       vts1  <- map (addFst3 mod) <$> mapM mkVarSpec vbs1-       vts2  <- makeSpec (noCheckUnknown cfg) vs xbs2-       return $ (vts1 ++ vts2)-  where-    xbs1                = xbs1' ++ cbs-    (xbs1', xbs2)       = L.partition (modElem mod . fst) xbs-    dupSnd (x, y)       = (dropMod x, (x, y))-    expand3 (x, (y, w)) = (x, y, w)-    dropMod             = fmap (dropModuleNames . F.symbol)-    fchoose ls          = maybe ls (:[]) $ L.find (`elem` vs) ls-    modElem n x         = takeModuleNames (val x) == F.symbol n--makeSpec :: Bool -> [Var] -> [(LocSymbol, Located BareType)]-         -> BareM [(ModName, Var, LocSpecType)]-makeSpec _ignoreUnknown vs xbs = do-  (BE { modName = mod}) <- get-  vbs <- map (joinVar vs) <$> lookupIds False xbs-  map (addFst3 mod) <$> mapM mkVarSpec vbs--lookupIds :: Bool -> [(LocSymbol, a)] -> BareM [(Var, LocSymbol, a)]-lookupIds !ignoreUnknown-  = mapMaybeM lookup-  where-    lookup (s, t)-      = (Just . (,s,t) <$> lookupGhcVar s) `catchError` handleError-    handleError ( ErrGhc {})-      | ignoreUnknown-      = return Nothing-    handleError err-      = throwError err--mkVarSpec :: (Var, LocSymbol, Located BareType) -> BareM (Var, Located SpecType)-mkVarSpec (v, _, b) = (v,) . fmap (txCoerce . generalize) <$> mkLSpecType b-  where-    coSub           = F.tracepp _msg $ M.fromList [ (F.symbol a, F.FObj (specTvSymbol a)) | a <- tvs ]-    _msg            = "mkVarSpec v = " ++ F.showpp (v, b)-    tvs             = bareTypeVars (val b) -- fmap ty_var_value . fst4 . bkUniv . val $ b-    specTvSymbol    = F.symbol . bareRTyVar-    txCoerce        = mapExprReft (F.applyCoSub coSub)--bareTypeVars :: BareType -> [BTyVar]-bareTypeVars t = Misc.sortNub . fmap ty_var_value $ vs ++ vs'-  where-    vs         = fst4 . bkUniv $ t-    vs'        = freeTyVars    $ t--makeIAliases :: (ModName, Ms.Spec (Located BareType) bndr)-             -> BareM [(Located SpecType, Located SpecType)]-makeIAliases (mod, spec)-  = inModule mod $ makeIAliases' $ Ms.ialiases spec--makeIAliases' :: [(Located BareType, Located BareType)] -> BareM [(Located SpecType, Located SpecType)]-makeIAliases'     = mapM mkIA-  where-    mkIA (t1, t2) = (,) <$> mkI t1 <*> mkI t2-    mkI t         = fmap generalize <$> mkLSpecType t--makeNewTypes :: (ModName, Ms.Spec (Located BareType) bndr)-               -> BareM [(TyCon, Located SpecType)]-makeNewTypes (mod,spec)-  = inModule mod $ makeNewTypes' $ Ms.newtyDecls spec--makeNewTypes' :: [DataDecl] -> BareM [(TyCon, Located SpecType)]-makeNewTypes' = mapM mkNT-  where-    mkNT :: DataDecl -> BareM (TyCon, Located SpecType)-    mkNT d       = (,) <$> lookupGhcTyCon "makeNewTypes'" (tycName d)-                       <*> (fmap generalize <$> (getTy (tycSrcPos d) (tycDCons d) >>= mkLSpecType))--    getTy l [c]-      | [(_, t)] <- dcFields c = return $ withLoc l t-    getTy l _                  = throwError $ ErrOther (sourcePosSrcSpan l) "bad new type declaration"-    -- getTy l [(_,[(_,t)])] = return $ withLoc l t--    withLoc s = Loc s s---makeInvariants :: (ModName, Ms.Spec (Located BareType) bndr)-               -> BareM [(Maybe Var, Located SpecType)]-makeInvariants (mod,spec)-  = inModule mod $ makeInvariants' $ Ms.invariants spec--makeInvariants' :: [(a, Located BareType)] -> BareM [(Maybe Var, Located SpecType)]-makeInvariants' = mapM mkI-  where-    mkI (_,t)       = (Nothing,) . fmap generalize <$> mkLSpecType t--makeSpecDictionaries :: F.TCEmb TyCon -> [Var] -> [(a, Ms.BareSpec)] -> GhcSpec-                     -> BareM GhcSpec-makeSpecDictionaries embs vars specs sp-  = do ds <- (dfromList . concat)  <$>  mapM (makeSpecDictionary embs vars) specs-       return $ sp { gsDicts = ds }----makeSpecDictionary :: F.TCEmb TyCon -> [Var] -> (a, Ms.BareSpec)-                   -> BareM [(Var, M.HashMap F.Symbol (RISig SpecType))]-makeSpecDictionary embs vars (_, spec)-  = (catMaybes . resolveDictionaries vars) <$> mapM (makeSpecDictionaryOne embs) (Ms.rinstance spec)---makeSpecDictionaryOne :: F.TCEmb TyCon -> RInstance (Located BareType)-                      -> BareM (F.Symbol, M.HashMap F.Symbol (RISig SpecType))-makeSpecDictionaryOne embs (RI x t xts)-  = do t'  <- mapM mkLSpecType t-       tyi <- gets tcEnv-       ts' <- map (tidy tyi) <$> (mapM mkLSpecIType ts)-       return $ makeDictionary $ RI x (val <$> t') $ zip xs ts'-  where-    mkTy' :: Located BareType -> BareM (Located SpecType)-    mkTy' t  = fmap generalize <$> mkLSpecType t--    (xs, ts) = unzip xts--    tidy :: TCEnv -> RISig (Located SpecType) -> RISig SpecType-    tidy tyi = fmap (val . txRefSort tyi embs . fmap txExpToBind)--    mkLSpecIType :: RISig (Located BareType) -> BareM (RISig (Located SpecType))-    mkLSpecIType (RISig     t) = RISig     <$> mkTy' t-    mkLSpecIType (RIAssumed t) = RIAssumed <$> mkTy' t---resolveDictionaries :: [Var] -> [(F.Symbol, M.HashMap F.Symbol (RISig SpecType))] -> [Maybe (Var, M.HashMap F.Symbol (RISig SpecType))]-resolveDictionaries vars ds  = lookupVar <$> concat (go <$> Misc.groupList ds)- where-    go (x,is)           = addIndex 0 x $ reverse is--    -- GHC internal postfixed same name dictionaries with ints-    addIndex _ _ []     = []-    addIndex _ x [i]    = [(x,i)]-    addIndex j x (i:is) = (F.symbol (F.symbolString x ++ show j),i):addIndex (j+1) x is--    lookupVar (s, i)    = (, i) <$> lookupName s-    lookupName x-             = case filter ((==x) . fst) ((\x -> (dropModuleNames $ F.symbol $ show x, x)) <$> vars) of-                [(_, x)] -> Just x-                _        -> Nothing--makeBounds ::  F.TCEmb TyCon -> ModName -> [Var] -> [CoreBind] -> [(ModName, Ms.BareSpec)] -> BareM ()-makeBounds tce name defVars cbs specs-  = do bnames  <- mkThing makeHBounds-       hbounds <- makeHaskellBounds tce cbs bnames-       bnds    <- M.fromList <$> mapM go (concatMap (M.toList . Ms.bounds . snd ) specs)-       modify   $ \env -> env { bounds = hbounds `mappend` bnds }-  where-    go (x,bound) = (x,) <$> mkBound bound-    mkThing mk   = S.fromList . mconcat <$> sequence [ mk defVars s | (m, s) <- specs, m == name]--mkBound :: (Resolvable a) => Bound (Located BareType) a -> BareM (Bound RSort a)-mkBound (Bound s vs pts xts r)-  = do ptys' <- mapM (\(x, t) -> ((x,) . toRSort . val) <$> mkLSpecType t) pts-       xtys' <- mapM (\(x, t) -> ((x,) . toRSort . val) <$> mkLSpecType t) xts-       vs'   <- map (toRSort . val) <$> mapM mkLSpecType vs-       Bound s vs' ptys' xtys' <$> resolve (loc s) r
− src/Language/Haskell/Liquid/Bare/SymSort.hs 
@@ -1,100 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--module Language.Haskell.Liquid.Bare.SymSort (-    txRefSort-  ) where--import qualified Data.HashMap.Strict                   as M-import           Prelude                               hiding (error)-import qualified GHC-import qualified Data.List                             as L-import           Data.Maybe                            (fromMaybe)-import           TyCon                                 (TyCon)-import           Language.Fixpoint.Misc                (fst3, snd3)-import           Language.Fixpoint.Types.Sorts-import           Language.Fixpoint.Types               (atLoc, meet, Reftable, Symbolic, Symbol)-import           Language.Haskell.Liquid.Types.RefType (appRTyCon, strengthen)-import           Language.Haskell.Liquid.Types-import           Language.Haskell.Liquid.GHC.Misc      (fSrcSpan)-import           Language.Haskell.Liquid.Misc          (safeZipWithError)-import           Language.Haskell.Liquid.Bare.Env----- EFFECTS: TODO is this the SAME as addTyConInfo? No. `txRefSort`--- (1) adds the _real_ sorts to RProp,--- (2) gathers _extra_ RProp at turnst them into refinements,---     e.g. tests/pos/multi-pred-app-00.hs--txRefSort :: TCEnv -> TCEmb TyCon -> Located SpecType -> Located SpecType-txRefSort tyi tce t = atLoc t $ mapBot (addSymSort (fSrcSpan t) tce tyi) (val t)--addSymSort :: (PPrint t, Reftable t)-           => GHC.SrcSpan-           -> TCEmb TyCon-           -> M.HashMap TyCon RTyCon-           -> RType RTyCon RTyVar (UReft t)-           -> RType RTyCon RTyVar (UReft t)-addSymSort sp tce tyi (RApp rc@(RTyCon {}) ts rs r)-  = RApp rc ts (zipWith3 (addSymSortRef sp rc) pvs rargs [1..]) r'-  where-    rc'                = appRTyCon tce tyi rc ts-    pvs                = rTyConPVs rc'-    (rargs, rrest)     = splitAt (length pvs) rs-    r'                 = L.foldl' go r rrest-    go r (RProp _ (RHole r')) = r' `meet` r-    go r (RProp  _ t' )       = let r' = fromMaybe mempty (stripRTypeBase t') in r `meet` r'--addSymSort _ _ _ t-  = t--addSymSortRef :: (PPrint t, PPrint a, Symbolic tv, Reftable t)-              => GHC.SrcSpan-              -> a-              -> PVar (RType c tv ())-              -> Ref (RType c tv ()) (RType c tv (UReft t))-              -> Int-              -> Ref (RType c tv ()) (RType c tv (UReft t))-addSymSortRef sp rc p r i-  | isPropPV p-  = addSymSortRef' sp rc i p r-  | otherwise-  = panic Nothing "addSymSortRef: malformed ref application"--addSymSortRef' :: (PPrint t, PPrint a, Symbolic tv, Reftable t)-               => GHC.SrcSpan-               -> a-               -> Int-               -> PVar (RType c tv ())-               -> Ref (RType c tv ()) (RType c tv (UReft t))-               -> Ref (RType c tv ()) (RType c tv (UReft t))-addSymSortRef' _ _ _ p (RProp s (RVar v r)) | isDummy v-  = RProp xs t-    where-      t  = ofRSort (pvType p) `strengthen` r-      xs = spliceArgs "addSymSortRef 1" s p--addSymSortRef' sp rc i p (RProp _ (RHole r@(MkUReft _ (Pr [up]) _)))-  | length xs == length ts-  = RProp xts (RHole r)-  | otherwise-  = uError $ ErrPartPred sp (pprint rc) (pprint $ pname up) i (length xs) (length ts)-    where-      xts = safeZipWithError "addSymSortRef'" xs ts-      xs  = snd3 <$> pargs up-      ts  = fst3 <$> pargs p--addSymSortRef' _ _ _ _ (RProp s (RHole r))-  = RProp s (RHole r)--addSymSortRef' _ _ _ p (RProp s t)-  = RProp xs t-    where-      xs = spliceArgs "addSymSortRef 2" s p--spliceArgs :: String  -> [(Symbol, b)] -> PVar t -> [(Symbol, t)]-spliceArgs msg s p = go (fst <$> s) (pargs p)-  where-    go []     []           = []-    go []     ((s,x,_):as) = (x, s):go [] as-    go (x:xs) ((s,_,_):as) = (x,s):go xs as-    go xs     []           = panic Nothing $ "spliceArgs: " ++ msg ++ "on XS=" ++ show xs
src/Language/Haskell/Liquid/Bare/ToBare.hs view
@@ -17,8 +17,8 @@ import qualified Language.Fixpoint.Types as F import           Language.Haskell.Liquid.GHC.Misc import           Language.Haskell.Liquid.Types-import           Language.Haskell.Liquid.Measure-import           Language.Haskell.Liquid.Types.RefType+-- import           Language.Haskell.Liquid.Measure+-- import           Language.Haskell.Liquid.Types.RefType  -------------------------------------------------------------------------------- specToBare :: SpecType -> BareType@@ -57,6 +57,7 @@     go (RAllT α t)         = RAllT (goRTV α) (go t)     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')     go (REx x t t')        = REx   x         (go t) (go t')
+ src/Language/Haskell/Liquid/Bare/Types.hs view
@@ -0,0 +1,155 @@+-- | This module has the code that uses the GHC definitions to:+--   1. MAKE a name-resolution environment,+--   2. USE the environment to translate plain symbols into Var, TyCon, etc. ++module Language.Haskell.Liquid.Bare.Types +  ( -- * Name resolution environment +    Env (..)+  , TyThingMap +  , ModSpecs+  , LocalVars ++    -- * Tycon and Datacon processing environment+  , TycEnv (..) +  , DataConMap+  , RT.TyConMap++    -- * Signature processing environment +  , SigEnv (..)++    -- * Measure related environment +  , MeasEnv (..)++    -- * Misc +  , PlugTV (..)+  , plugSrc+  , varRSort +  , varSortedReft+  , failMaybe+  ) where ++import qualified Control.Exception                     as Ex +import qualified Text.PrettyPrint.HughesPJ             as PJ +import qualified Data.HashSet                          as S+import qualified Data.HashMap.Strict                   as M+import qualified Language.Fixpoint.Types               as F +import qualified Language.Haskell.Liquid.Measure       as Ms+import qualified Language.Haskell.Liquid.Types.RefType as RT +import           Language.Haskell.Liquid.Types.Types   +import           Language.Haskell.Liquid.Types.Specs +import           Language.Haskell.Liquid.GHC.API       as Ghc hiding (Located) +++type ModSpecs = M.HashMap ModName Ms.BareSpec++-------------------------------------------------------------------------------+-- | See [NOTE: Plug-Holes-TyVars] for a rationale for @PlugTV@ +-------------------------------------------------------------------------------++data PlugTV v +  = HsTV v  -- ^ Use tyvars from GHC specification (in the `v`) +  | LqTV v  -- ^ Use tyvars from Liquid specification+  | GenTV   -- ^ Generalize ty-vars +  | RawTV   -- ^ Do NOT generalize ty-vars (e.g. for type-aliases)+  deriving (Show)+++instance (Show v, F.PPrint v) => F.PPrint (PlugTV v) where +  pprintTidy _ = PJ.text . show +   +plugSrc ::  PlugTV v -> Maybe v +plugSrc (HsTV v) = Just v +plugSrc (LqTV v) = Just v +plugSrc _        = Nothing++-------------------------------------------------------------------------------+-- | Name resolution environment +-------------------------------------------------------------------------------+data Env = RE +  { reLMap      :: !LogicMap+  , reSyms      :: ![(F.Symbol, Ghc.Var)]    -- ^ see "syms" in old makeGhcSpec'+  , _reSubst    :: !F.Subst                  -- ^ see "su"   in old makeGhcSpec'+  , _reTyThings :: !TyThingMap +  , reCfg       :: !Config+  , reQualImps  :: !QImports                 -- ^ qualified imports+  , reAllImps   :: !(S.HashSet F.Symbol)     -- ^ all imported modules+  , reLocalVars :: !LocalVars                -- ^ lines at which local variables are defined.+  , reGlobSyms  :: !(S.HashSet F.Symbol)     -- ^ global symbols, typically unlifted measures like 'len', 'fromJust'+  , reSrc       :: !GhcSrc                   -- ^ all source info+  }++instance HasConfig Env where +  getConfig = reCfg ++-- | @LocalVars@ is a map from names to lists of pairs of @Ghc.Var@ and +--   the lines at which they were defined. +type LocalVars = M.HashMap F.Symbol [(Int, Ghc.Var)]++-------------------------------------------------------------------------------+-- | A @TyThingMap@ is used to resolve symbols into GHC @TyThing@ and, +--   from there into Var, TyCon, DataCon, etc.+-------------------------------------------------------------------------------+type TyThingMap = M.HashMap F.Symbol [(F.Symbol, Ghc.TyThing)]++-------------------------------------------------------------------------------+-- | A @SigEnv@ contains the needed to process type signatures +-------------------------------------------------------------------------------+data SigEnv = SigEnv +  { sigEmbs       :: !(F.TCEmb Ghc.TyCon) +  , sigTyRTyMap   :: !RT.TyConMap +  , sigExports    :: !Ghc.NameSet+  , sigRTEnv      :: !BareRTEnv+  }++-------------------------------------------------------------------------------+-- | A @TycEnv@ contains the information needed to process Type- and Data- Constructors +-------------------------------------------------------------------------------+data TycEnv = TycEnv +  { tcTyCons      :: ![TyConP]+  , tcDataCons    :: ![DataConP]+  , tcSelMeasures :: ![Measure SpecType Ghc.DataCon]+  , tcSelVars     :: ![(Ghc.Var, LocSpecType)]+  , tcTyConMap    :: !RT.TyConMap +  , tcAdts        :: ![F.DataDecl]+  , tcDataConMap  :: !DataConMap +  , tcEmbs        :: !(F.TCEmb Ghc.TyCon)+  , tcName        :: !ModName+  }++type DataConMap = M.HashMap (F.Symbol, Int) F.Symbol++-------------------------------------------------------------------------------+-- | Intermediate representation for Measure information +-------------------------------------------------------------------------------+-- REBARE: used to be output of makeGhcSpecCHOP2+data MeasEnv = MeasEnv +  { meMeasureSpec :: !(MSpec SpecType Ghc.DataCon)          +  , meClassSyms   :: ![(F.Symbol, Located (RRType F.Reft))] +  , meSyms        :: ![(F.Symbol, Located (RRType F.Reft))]+  , meDataCons    :: ![(Ghc.Var,  LocSpecType)]           +  , meClasses     :: ![DataConP]                           +  , meMethods     :: ![(ModName, Ghc.Var, LocSpecType)]  +  , meCLaws       :: !([(Ghc.Class, [(ModName, Ghc.Var, LocSpecType)])])  +  }++-------------------------------------------------------------------------------+-- | Converting @Var@ to @Sort@+-------------------------------------------------------------------------------+varSortedReft :: F.TCEmb Ghc.TyCon -> Ghc.Var -> F.SortedReft +varSortedReft emb = RT.rTypeSortedReft emb . varRSort ++varRSort  :: Ghc.Var -> RSort+varRSort  = RT.ofType . Ghc.varType++-------------------------------------------------------------------------------+-- | Handling failed resolution +-------------------------------------------------------------------------------+failMaybe :: Env -> ModName -> Either UserError r -> Maybe r+failMaybe env name res = case res of +  Right r -> Just r +  Left  e -> if isTargetModName env name +              then Ex.throw e+              else Nothing ++isTargetModName :: Env -> ModName -> Bool +isTargetModName env name = name == giTargetMod (reSrc env) 
src/Language/Haskell/Liquid/Constraint/Env.hs view
@@ -25,6 +25,7 @@   , extendEnvWithVV   , addBinders   , addSEnv+  , addEEnv   , (-=)   , globalize @@ -78,7 +79,7 @@ import qualified Language.Haskell.Liquid.GHC.SpanStack as Sp import           Language.Haskell.Liquid.Types            hiding (binds, Loc, loc, freeTyVars, Def) import           Language.Haskell.Liquid.Constraint.Types-import           Language.Haskell.Liquid.Constraint.Fresh+import           Language.Haskell.Liquid.Constraint.Fresh () import           Language.Haskell.Liquid.Transforms.RefSplit import qualified Language.Haskell.Liquid.UX.CTags       as Tg @@ -179,21 +180,18 @@  addCGEnv tx γ (_, x, t') = do   idx   <- fresh-  allowHOBinders <- allowHO <$> get+  -- allowHOBinders <- allowHO <$> get   let t  = tx $ normalize idx t'   let l  = getLocation γ   let γ' = γ { renv = insertREnv x t (renv γ) }-  pflag <- pruneRefs <$> get-  is    <- if allowHOBinders || isBase t-            then (:) <$> addBind l x (rTypeSortedReft' pflag γ' t) <*> addClassBind γ' l t-            else return []+  tem   <- getTemplates +  is    <- (:) <$> addBind l x (rTypeSortedReft' γ' tem t) <*> addClassBind γ' l t   return $ γ' { fenv = insertsFEnv (fenv γ) is }  rTypeSortedReft' :: (PPrint r, F.Reftable r, SubsTy RTyVar RSort r, F.Reftable (RTProp RTyCon RTyVar r))-                 => Bool -> CGEnv -> RRType r -> F.SortedReft-rTypeSortedReft' pflag γ-  | pflag     = pruneUnsortedReft (feEnv $ fenv γ) . f-  | otherwise = f+                 => CGEnv -> F.Templates -> RRType r -> F.SortedReft+rTypeSortedReft' γ t +  = pruneUnsortedReft (feEnv $ fenv γ) t . f   where     f         = rTypeSortedReft (emb γ) @@ -241,6 +239,19 @@ addSEnv :: CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv -------------------------------------------------------------------------------- addSEnv γ = addCGEnv (addRTyConInv (invs γ)) γ++addEEnv :: CGEnv -> (F.Symbol, SpecType) -> CG CGEnv+addEEnv γ (x,t')= do+  idx   <- fresh+  -- allowHOBinders <- allowHO <$> get+  let t  = addRTyConInv (invs γ) $ normalize idx t'+  let l  = getLocation γ+  let γ' = γ { renv = insertREnv x t (renv γ) }+  tem   <- getTemplates+  is    <- (:) <$> addBind l x (rTypeSortedReft' γ' tem t) <*> addClassBind γ' l t+  modify (\s -> s { ebinds = ebinds s ++ (snd <$> is)})+  return $ γ' { fenv = insertsFEnv (fenv γ) is }+  (+++=) :: (CGEnv, String) -> (F.Symbol, CoreExpr, SpecType) -> CG CGEnv (γ, _) +++= (x, e, t) = (γ {lcb = M.insert x e (lcb γ) }) += ("+++=", x, t)
src/Language/Haskell/Liquid/Constraint/Fresh.hs view
@@ -10,8 +10,9 @@ {-# LANGUAGE ConstraintKinds       #-}  module Language.Haskell.Liquid.Constraint.Fresh-  ( module Language.Haskell.Liquid.Types.Fresh-  , refreshArgsTop+  ( -- module Language.Haskell.Liquid.Types.Fresh+    -- , +    refreshArgsTop   , freshTy_type   , freshTy_expr   , trueTy@@ -38,9 +39,10 @@ import qualified Language.Fixpoint.Types as F import           Language.Fixpoint.Types.Visitor (kvars) import           Language.Haskell.Liquid.Types-import           Language.Haskell.Liquid.Types.RefType-import           Language.Haskell.Liquid.Types.Fresh+-- import           Language.Haskell.Liquid.Types.RefType+-- import           Language.Haskell.Liquid.Types.Fresh import           Language.Haskell.Liquid.Constraint.Types+import qualified Language.Haskell.Liquid.GHC.Misc as GM   -------------------------------------------------------------------------------- -- | This is all hardwiring stuff to CG ----------------------------------------@@ -69,7 +71,8 @@ --   Constraint generation should ONLY use @freshTy_type@ and @freshTy_expr@  freshTy_type        :: KVKind -> CoreExpr -> Type -> CG SpecType-freshTy_type k _ τ  = freshTy_reftype k $ ofType τ+freshTy_type k e τ  =  F.notracepp ("freshTy_type: " ++ F.showpp k ++ GM.showPpr e) +                   <$> freshTy_reftype k (ofType τ)  freshTy_expr        :: KVKind -> CoreExpr -> Type -> CG SpecType freshTy_expr k e _  = freshTy_reftype k $ exprRefType e
src/Language/Haskell/Liquid/Constraint/Generate.hs view
@@ -43,17 +43,20 @@ import           FastString (fastStringToByteString) import           Unify import           UniqSet (mkUniqSet)-import           Text.PrettyPrint.HughesPJ                     hiding (first)+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 import qualified Data.List                                     as L import qualified Data.Foldable                                 as F import qualified Data.Traversable                              as T+import qualified Data.Functor.Identity import           Language.Fixpoint.Misc import           Language.Fixpoint.Types.Visitor import qualified Language.Fixpoint.Types                       as F+import qualified Language.Fixpoint.Types.Visitor               as F -- import           Language.Fixpoint.Solver.Instantiate import           Language.Haskell.Liquid.Constraint.Fresh import           Language.Haskell.Liquid.Constraint.Init@@ -61,22 +64,23 @@ import           Language.Haskell.Liquid.Constraint.Monad import           Language.Haskell.Liquid.Constraint.Split import           Language.Haskell.Liquid.Types.Dictionaries+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, freeTyVars, Def)+import           Language.Haskell.Liquid.Types                 hiding (binds, Loc, loc, Def) import           Language.Haskell.Liquid.Types.Names       (anyTypeSymbol)-import           Language.Haskell.Liquid.Types.Strata-import           Language.Haskell.Liquid.Types.RefType-import           Language.Haskell.Liquid.Types.PredType        hiding (freeTyVars)+-- 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-import           Language.Haskell.Liquid.Types.Literals -- 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 Debug.Trace (trace)+import           Language.Haskell.Liquid.Transforms.CoreToLogic (weakenResult)+import           Language.Haskell.Liquid.Bare.DataType (makeDataConChecker)  -------------------------------------------------------------------------------- -- | Constraint Generation: Toplevel -------------------------------------------@@ -90,15 +94,18 @@  consAct :: Config -> GhcInfo -> CG () consAct cfg info = do-  γ     <- initEnv      info-  sflag <- scheck   <$> get-  when (gradual cfg) (mapM_ (addW . WfC γ . val . snd) (gsTySigs (spec info) ++ gsAsmSigs (spec info)))-  foldM_ (consCBTop cfg info) γ (cbs info)-  hcs   <- hsCs  <$> get-  hws   <- hsWfs <$> get-  scss  <- sCs   <$> get-  annot <- annotMap <$> get-  scs   <- if sflag then concat <$> mapM splitS (hcs ++ scss)+  γ       <- initEnv      info+  sflag   <- scheck   <$> get+  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@@ -112,7 +119,21 @@                      , fixWfs   = fws                      , annotMap = annot' } ++ --------------------------------------------------------------------------------+-- | Ensure that the instance type is a subtype of the class type --------------+--------------------------------------------------------------------------------++consClass :: CGEnv -> (Var, MethodType LocSpecType) -> CG ()+consClass γ (x,mt) +  | Just ti <- tyInstance mt +  , Just tc <- tyClass    mt +  = addC (SubC (γ `setLocation` Sp.Span (GM.fSrcSpan (F.loc ti))) (val ti) (val tc)) ("cconsClass for " ++ GM.showPpr x)+consClass _ _ +  = return () ++-------------------------------------------------------------------------------- -- | TERMINATION TYPE ---------------------------------------------------------- -------------------------------------------------------------------------------- makeDecrIndex :: (Var, Template SpecType, [Var]) -> CG [Int]@@ -132,7 +153,7 @@ makeDecrIndexTy x t args   = do spDecr <- specDecr <$> get        autosz <- autoSize <$> get-       hint   <- checkHint' autosz (L.lookup x $ spDecr)+       hint   <- checkHint' autosz (L.lookup x spDecr)        case dindex autosz of          Nothing -> return $ Left msg          Just i  -> return $ Right $ fromMaybe [i] hint@@ -170,7 +191,7 @@     where        loc   = getSrcSpan x        ts    = ty_args $ toRTypeRep $ unOCons $ unTemplate t-       msg1  = ErrTermin loc [xd] ("No decreasing" <+> F.pprint index <> "-th argument on" <+> xd <+> "with" <+> (F.pprint vs))+       msg1  = ErrTermin loc [xd] ("No decreasing" <+> F.pprint index <-> "-th argument on" <+> xd <+> "with" <+> (F.pprint vs))        msg2  = ErrTermin loc [xd] "No decreasing parameter"        xd    = F.pprint x @@ -197,16 +218,11 @@ 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 (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-mergecondition _ t-  = t+mergecondition (RAllT _ t1) (RAllT v t2)               = RAllT v (mergecondition t1 t2)+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+mergecondition _ t                                     = t  safeLogIndex :: Error -> [a] -> Int -> CG (Maybe a) safeLogIndex err ls n@@ -245,8 +261,7 @@ -------------------------------------------------------------------------------- consCBLet γ cb = do   oldtcheck <- tcheck <$> get-  lazyVars  <- specLazy <$> get-  let isStr  = doTermCheck lazyVars cb+  isStr     <- doTermCheck (getConfig γ) cb   -- TODO: yuck.   modify $ \s -> s { tcheck = oldtcheck && isStr }   γ' <- consCB (oldtcheck && isStr) isStr γ cb@@ -268,8 +283,8 @@  consCBTop _ _ γ cb   = do oldtcheck <- tcheck <$> get-       lazyVars  <- specLazy <$> get-       let isStr  = doTermCheck lazyVars cb+       -- lazyVars  <- specLazy <$> get+       isStr     <- doTermCheck (getConfig γ) cb        modify $ \s -> s { tcheck = oldtcheck && isStr}        -- remove invariants that came from the cb definition        let (γ', i) = removeInvariant γ cb                 --- DIFF@@ -281,16 +296,24 @@       topBind (Rec [(v,_)]) = Just v       topBind _             = Nothing - trustVar :: Config -> GhcInfo -> Var -> Bool-trustVar cfg info x = trustInternals cfg && derivedVar info x+trustVar cfg info x = not (checkDerived cfg) && derivedVar (giSrc info) x -derivedVar :: GhcInfo -> Var -> Bool-derivedVar info x = x `elem` derVars info || GM.isInternal x+derivedVar :: GhcSrc -> Var -> Bool+derivedVar src x = S.member x (giDerVars src) -doTermCheck :: S.HashSet Var -> Bind Var -> Bool-doTermCheck lazyVs = not . any (\x -> S.member x lazyVs || GM.isInternal x) . bindersOf+doTermCheck :: Config -> Bind Var -> CG Bool+doTermCheck cfg bind = do +  lazyVs    <- specLazy   <$> get +  termVs    <- specTmVars <$> get+  let skip   = any (\x -> S.member x lazyVs || GM.isInternal x) xs+  let chk    = not (structuralTerm cfg) || any (\x -> S.member x termVs) xs+  return     $ chk && not skip+  where +    xs       = bindersOf bind +-- nonStructTerm && not skip+ -- RJ: AAAAAAARGHHH!!!!!! THIS CODE IS HORRIBLE!!!!!!!!! consCBSizedTys :: CGEnv -> [(Var, CoreExpr)] -> CG CGEnv consCBSizedTys γ xes@@ -309,7 +332,7 @@        let rts   = (recType autoenv <$>) <$> xeets        let xts   = zip xs ts        γ'       <- foldM extender γ xts-       let γs    = zipWith makeRecInvariants [γ' `setTRec` zip xs rts' | rts' <- rts] (filter (not . GM.isPredVar {- isClassPred . varType -}) <$> vs)+       let γs    = zipWith makeRecInvariants [γ' `setTRec` zip xs rts' | rts' <- rts] (filter (not . GM.isPredVar) <$> vs)        let xets' = zip3 xs es ts        mapM_ (uncurry $ consBind True) (zip γs xets')        return γ'@@ -329,9 +352,7 @@          | all (==(f x)) (f <$> xs) = return (x:xs)          | otherwise                = addWarning err >> return [] -consCBWithExprs :: CGEnv-                -> [(Var, CoreExpr)]-                -> CG CGEnv+consCBWithExprs :: CGEnv -> [(Var, CoreExpr)] -> CG CGEnv consCBWithExprs γ xes   = do xets'     <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))        texprs    <- termExprs <$> get@@ -383,11 +404,12 @@     err x        = "Constant: makeTermEnvs: no terminating expression for " ++ GM.showPpr x  addObligation :: Oblig -> SpecType -> RReft -> SpecType-addObligation o t r  = mkArrow αs πs ls xts $ RRTy [] r o t2+addObligation o t r  = mkArrow αs πs ls yts xts $ RRTy [] r o t2   where     (αs, πs, ls, t1) = bkUniv t-    (xs, ts, rs, t2) = bkArrow t1+    ((xs',ts',rs'),(xs, ts, rs), t2) = bkArrow t1     xts              = zip3 xs ts rs+    yts              = zip3 xs' ts' rs'  -------------------------------------------------------------------------------- consCB :: Bool -> Bool -> CGEnv -> CoreBind -> CG CGEnv@@ -401,7 +423,7 @@          then consCBSizedTys γ xes          else check xxes <$> consCBWithExprs γ xes     where-      xs = fst $ unzip xes+      xs = fst (unzip xes)       check ys r | length ys == length xs = r                  | otherwise              = panic (Just loc) $ msg       msg        = "Termination expressions must be provided for all mutually recursive binders"@@ -410,13 +432,13 @@  -- 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 cmakeDivType = if sflag then makeDivType else id-       let xets = mapThd3 (fmap cmakeDivType) <$> xets'-       modify $ \i -> i { recCount = recCount i + length xes }-       let xts = [(x, to) | (x, _, to) <- xets]-       γ'     <- foldM extender (γ `setRecs` (fst <$> xts)) xts+  = 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'+       modify     $ \i -> i { recCount = recCount i + length xes }+       let xts    = [(x, to) | (x, _, to) <- xets]+       γ'        <- foldM extender (γ `setRecs` (fst <$> xts)) xts        mapM_ (consBind True γ') xets        return γ' @@ -443,7 +465,7 @@   , Just d      <- dlookup (denv γ) w   = do t        <- trueTy τ        addW      $ WfC γ t-       let xts   = dmap (mapRISig (f t)) d+       let xts   = dmap (fmap (f t)) d        let  γ'   = γ { denv = dinsert (denv γ) x xts }        t        <- trueTy (varType x)        extender γ' (x, Assumed t)@@ -454,7 +476,7 @@ consCB _ _ γ (NonRec x e)   = do to  <- varTemplate γ (x, Nothing)        to' <- consBind False γ (x, e, to) >>= (addPostTemplate γ)-       extender γ (x, to')+       extender (addRankNBind γ x e) (x, to')  grepDictionary :: CoreExpr -> Maybe (Var, Type) grepDictionary (App (Var w) (Type t)) = Just (w, t)@@ -462,20 +484,23 @@ grepDictionary _                      = Nothing  ---------------------------------------------------------------------------------consBind :: Bool-         -> CGEnv-         -> (Var, CoreExpr, Template SpecType)-         -> CG (Template SpecType)+consBind :: Bool -> CGEnv -> (Var, CoreExpr, Template SpecType) -> CG (Template SpecType) ---------------------------------------------------------------------------------consBind _ _ (x, _, t)-  | RecSelId {} <- idDetails x -- don't check record selectors-  = return t+consBind _ _ (x, _, Assumed t)+  | RecSelId {} <- idDetails x -- don't check record selectors with assumed specs+  = return $ F.notracepp ("TYPE FOR SELECTOR " ++ show x) $ Assumed t  consBind isRec γ (x, e, Asserted spect)   = do let γ'         = γ `setBind` x            (_,πs,_,_) = bkUniv spect        γπ    <- foldM addPToEnv γ' πs-       cconsE γπ e spect++       -- take implcits out of the function's SpecType and into the env+       let tyr = toRTypeRep spect+       let spect' = fromRTypeRep (tyr { ty_ebinds = [], ty_eargs = [], ty_erefts = [] })+       γπ <- foldM (+=) γπ $ (\(y,t)->("implicitError",y,t)) <$> zip (ty_ebinds tyr) (ty_eargs tyr)++       cconsE γπ e (weakenResult x spect')        when (F.symbol x `elemHEnv` holes γ) $          -- have to add the wf constraint here for HOLEs so we have the proper env          addW $ WfC γπ $ fmap killSubst spect@@ -492,7 +517,7 @@          -- have to add the wf constraint here for HOLEs so we have the proper env          addW $ WfC γπ $ fmap killSubst spect        addIdA x (defAnn isRec spect)-       return $ Internal spect -- Nothing+       return $ Internal spect   where     explanation = "Cannot give singleton type to the function definition." @@ -541,19 +566,26 @@ extender γ _   = return γ -data Template a = Asserted a-                | Assumed a-                | Internal a-                | Unknown-                deriving (Functor, F.Foldable, T.Traversable)+data Template a+  = Asserted a+  | Assumed a+  | Internal a+  | Unknown+  deriving (Functor, F.Foldable, T.Traversable)  deriving instance (Show a) => (Show (Template a)) +instance PPrint a => PPrint (Template a) where+  pprintTidy k (Asserted t) = "Asserted" <+> pprintTidy k t+  pprintTidy k (Assumed  t) = "Assumed"  <+> pprintTidy k t+  pprintTidy k (Internal t) = "Internal" <+> pprintTidy k t+  pprintTidy _ Unknown      = "Unknown"+ unTemplate :: Template t -> t unTemplate (Asserted t) = t unTemplate (Assumed t)  = t unTemplate (Internal t) = t-unTemplate _ = panic Nothing "Constraint.Generate.unTemplate called on `Unknown`"+unTemplate _            = panic Nothing "Constraint.Generate.unTemplate called on `Unknown`"  addPostTemplate :: CGEnv                 -> Template SpecType@@ -595,15 +627,15 @@ topSpecType :: Var -> SpecType -> CG SpecType topSpecType x t = do   info  <- ghcI <$> get-  return $ if derivedVar info x then topRTypeBase t else t+  return $ if derivedVar (giSrc info) x then topRTypeBase t else t  ----------------------------------------------------------------------------------- | Constraint Generation: Checking -------------------------------------------+-- | Bidirectional Constraint Generation: CHECKING ----------------------------- -------------------------------------------------------------------------------- cconsE :: CGEnv -> CoreExpr -> SpecType -> CG () -------------------------------------------------------------------------------- cconsE g e t = do-  -- Note: tracing goes here+  -- NOTE: tracing goes here   -- traceM $ printf "cconsE:\n  expr = %s\n  exprType = %s\n  lqType = %s\n" (showPpr e) (showPpr (exprType e)) (showpp t)   cconsE' g e t @@ -671,6 +703,9 @@   = do t' <- castTy γ (exprType e) e' c        addC (SubC γ 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 γ@@ -710,6 +745,32 @@   = ([], t)  -------------------------------------------------------------------+-- | @instantiateGhosts@ peels away implicit argument binders,+-- instantiates them with fresh variables, and adds those variables+-- to the context as @ebind@s TODO: the second half+-------------------------------------------------------------------+instantiateGhosts :: CGEnv+                 -> SpecType+                 -> CG (Bool, CGEnv, SpecType)+instantiateGhosts γ t | not (null yts)+  = do ys' <- mapM (const fresh) ys+       γ'  <- foldM addEEnv γ (zip ys' ts)++       let su = F.mkSubst $ zip ys (F.EVar <$> ys')+       return (True, γ', F.subst su te')+  where (yts, te') = bkImplicit t+        (ys, ts)   = unzip yts++instantiateGhosts γ t = return (False, γ, t)++bkImplicit :: RType c tv r+           -> ( [(F.Symbol, RType c tv r)]+              , RType c tv r)+bkImplicit (RImpF x tx t _) = ((x,tx):acc, t')+  where (acc,t') = bkImplicit t+bkImplicit t = ([],t)++------------------------------------------------------------------- -- | @instantiatePreds@ peels away the universally quantified @PVars@ --   of a @RType@, generates fresh @Ref@ for them and substitutes them --   in the body.@@ -755,26 +816,31 @@   = panic Nothing "Constraint.Generate.cconsLazyLet called on invalid inputs"  ----------------------------------------------------------------------------------- | Type Synthesis ------------------------------------------------------------+-- | Bidirectional Constraint Generation: SYNTHESIS ---------------------------- -------------------------------------------------------------------------------- consE :: CGEnv -> CoreExpr -> CG SpecType -------------------------------------------------------------------------------- consE γ e   | patternFlag γ   , Just p <- Rs.lift e-  = consPattern γ p+  = consPattern γ (F.notracepp "CONSE-PATTERN: " p) (exprType e)  -- NV (below) is a hack to type polymorphic axiomatized functions -- no need to check this code with flag, the axioms environment with--- be empty if there is no axiomatization+-- 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          <- if isGeneric (ty_var_value α) te then freshTy_type TypeInstE e τ else trueTy τ+       t          <- {- PLE-OPT -} if isGeneric γ (ty_var_value α) te && not (isPLETerm γ) +                                     then freshTy_type TypeInstE e τ +                                     else trueTy τ        addW        $ WfC γ t        t'         <- refreshVV t-       tt <- instantiatePreds γ e' $ subsTyVar_meet' (ty_var_value α, t') te-       return $ strengthenMeet tt (singletonReft (M.lookup x $ aenv γ) x)+       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 @@ -788,10 +854,11 @@  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 τ+       t          <- if isGeneric γ (ty_var_value α) te then freshTy_type TypeInstE e τ else trueTy τ        addW        $ WfC γ t        t'         <- refreshVV t-       tt         <- instantiatePreds γ e' (subsTyVar_meet' (ty_var_value α, t') te)+       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'        case rTVarToBind α of          Just (x, _) -> return $ maybe (checkUnbound γ e' x tt a) (F.subst1 tt . (x,)) (argType τ)@@ -811,17 +878,24 @@         pushConsBind      $ 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 γ e+  = 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'''        updateLocA (exprLoc e) te''-       let RFun x tx t _ = checkFun ("Non-fun App with caller ", e') γ te''-       pushConsBind      $ cconsE γ' a tx-       makeSingleton γ e' <$>  (addPost γ' $ maybe (checkUnbound γ' e' x t a) (F.subst1 t . (x,)) (argExpr γ a))+       (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))+       if hasGhost+          then do+           tk   <- freshTy_type ImplictE e' $ exprType e'+           addW $ WfC γ tk+           addC (SubC γ'' tout tk) ""+           return tk+          else return tout  consE γ (Lam α e) | isTyVar α   = do γ' <- updateEnvironment γ α@@ -843,7 +917,7 @@  consE γ e@(Case _ _ _ [_])   | Just p@(Rs.PatProject {}) <- Rs.lift e-  = consPattern γ p+  = consPattern γ p (exprType e)  consE γ e@(Case _ _ _ cs)   = cconsFreshE (caseKVKind cs) γ e@@ -896,9 +970,24 @@     go _                = Nothing  --------------------------------------------------------------------------------+-- | With GADTs and reflection, refinements can contain type variables, +--   as 'coercions' (see ucsd-progsys/#1424). At application sites, we +--   must also substitute those from the refinements (not just the types).+--      https://github.com/ucsd-progsys/liquidhaskell/issues/1424+-- +--   see: tests/ple/{pos,neg}/T1424.hs+--+--------------------------------------------------------------------------------++subsTyReft :: CGEnv -> RTyVar -> Type -> SpecType -> SpecType +subsTyReft γ a t = mapExprReft (\_ -> F.applyCoSub coSub) +  where +    coSub        = M.fromList [(F.symbol a, typeSort (emb γ) t)]++-------------------------------------------------------------------------------- -- | Type Synthesis for Special @Pattern@s ------------------------------------- ---------------------------------------------------------------------------------consPattern :: CGEnv -> Rs.Pattern -> CG SpecType+consPattern :: CGEnv -> Rs.Pattern -> Type -> CG SpecType  {- [NOTE] special type rule for monadic-bind application @@ -907,7 +996,7 @@           G |- (e1 >>= \x -> e2) ~> m t  -} -consPattern γ (Rs.PatBind e1 x e2 _ _ _ _ _) = do+consPattern γ (Rs.PatBind e1 x e2 _ _ _ _ _) _ = do   tx <- checkMonad (msg, e1) γ <$> consE γ e1   γ' <- γ += ("consPattern", F.symbol x, tx)   addIdA x (AnnDef tx)@@ -918,14 +1007,15 @@  {- [NOTE] special type rule for monadic-return -           G |- e ~> t+           G |- e ~> et     -------------------------      G |- return e ~ m t+      G |- return e ~ m et  -}-consPattern γ (Rs.PatReturn e m _ _ _) = do-  t     <- consE γ e+consPattern γ (Rs.PatReturn e m _ _ _) t = do+  et    <- F.notracepp "Cons-Pattern-Ret" <$> consE γ e   mt    <- trueTy  m-  return $ RAppTy mt t mempty+  tt    <- trueTy  t+  return (mkRAppTy mt et tt) -- /// {-    $ RAppTy mt et mempty -}  {- [NOTE] special type rule for field projection, is           t  = G(x)       ti = Proj(t, i)@@ -933,7 +1023,7 @@       G |- case x of C [y1...yn] -> yi : ti  -} -consPattern γ (Rs.PatProject xe _ τ c ys i) = do+consPattern γ (Rs.PatProject xe _ τ c ys i) _ = do   let yi = ys !! i   t    <- (addW . WfC γ) <<= freshTy_type ProjectE (Var yi) τ   γ'   <- caseEnv γ xe [] (DataAlt c) ys (Just [i])@@ -941,12 +1031,16 @@   addC (SubC γ' ti t) "consPattern:project"   return t -consPattern γ (Rs.PatSelfBind _ e) =+consPattern γ (Rs.PatSelfBind _ e) _ =   consE γ e -consPattern γ p@(Rs.PatSelfRecBind {}) =+consPattern γ p@(Rs.PatSelfRecBind {}) _ =   cconsFreshE LetE γ (Rs.lower p) +mkRAppTy :: SpecType -> SpecType -> SpecType -> SpecType +mkRAppTy mt et (RAppTy _ _ _)    = RAppTy mt et mempty +mkRAppTy _  et (RApp c [_] [] _) = RApp c [et] [] mempty +mkRAppTy _  _  _                 = panic Nothing $ "Unexpected return-pattern"   checkMonad :: (Outputable a) => (String, a) -> CGEnv -> SpecType -> SpecType checkMonad x g = go . unRRTy@@ -1086,32 +1180,43 @@   = do cγ <- caseEnv γ x acs ac ys mempty        cconsE cγ ce t +{- ++case x :: List b of +  Emp -> e ++  Emp :: tdc          forall a. {v: List a | cons v === 0} +  x   :: xt           List b +  ys  == binders      [] ++-} ------------------------------------------------------------------------------------- caseEnv   :: CGEnv -> Var -> [AltCon] -> AltCon -> [Var] -> Maybe [Int] -> CG CGEnv --------------------------------------------------------------------------------------caseEnv γ x _   (DataAlt c) ys pIs-  = do let (x' : ys')    = F.symbol <$> (x:ys)-       xt0              <- checkTyCon ("checkTycon cconsCase", x) γ <$> γ ??= x-       let xt            = shiftVV xt0 x'-       tdc              <- γ ??= ({- F.symbol -} dataConWorkId c) >>= refreshVV-       let (rtd,yts', _) = unfoldR tdc xt ys-       yts              <- projectTypes pIs yts'-       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 . GM.isPredVar) ys+caseEnv γ x _   (DataAlt c) ys pIs = do ++  let (x' : ys')   = F.symbol <$> (x:ys)+  xt0             <- checkTyCon ("checkTycon cconsCase", x) γ <$> γ ??= x+  let xt           = shiftVV xt0 x'+  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 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) -caseEnv γ x acs a _ _-  = do let x'  = F.symbol x-       xt'    <- (`strengthen` uTop (altReft γ acs a)) <$> (γ ??= x)-       cγ     <- addBinders γ x' [(x', xt')]-       return cγ+caseEnv γ x acs a _ _ = do +  let x'  = F.symbol x+  xt'    <- (`strengthen` uTop (altReft γ acs a)) <$> (γ ??= x)+  cγ     <- addBinders γ x' [(x', xt')]+  return cγ  -------------------------------------------------------------------------------- -- | `projectTypes` masks (i.e. true's out) all types EXCEPT those@@ -1128,41 +1233,46 @@  altReft :: CGEnv -> [AltCon] -> AltCon -> F.Reft altReft _ _ (LitAlt l)   = literalFReft l-altReft γ acs DEFAULT    = mconcat [notLiteralReft l | LitAlt l <- acs]-  where notLiteralReft   = maybe mempty F.notExprReft . snd . literalConst (emb γ)-altReft _ _ _            = panic Nothing "Constraint : altReft"+altReft γ acs DEFAULT    = mconcat ([notLiteralReft l | LitAlt l <- acs] ++ [notDataConReft d | DataAlt d <- acs])+  where+    notLiteralReft   = maybe mempty F.notExprReft . snd . literalConst (emb γ)+    notDataConReft d | exactDC (getConfig γ)+                     = F.Reft (F.vv_, F.PNot (F.EApp (F.EVar $ makeDataConChecker d) (F.EVar F.vv_)))+                     | otherwise = mempty+altReft _ _ _        = panic Nothing "Constraint : altReft" -unfoldR :: SpecType-        -> SpecType-        -> [Var]-        -> (SpecType, [SpecType], SpecType)+unfoldR :: SpecType -> SpecType -> [Var] -> (SpecType, [SpecType], SpecType) unfoldR td (RApp _ ts rs _) ys = (t3, tvys ++ yts, ignoreOblig rt)   where-        tbody              = instantiatePvs (instantiateTys (F.notracepp "UNFOLDR-1" td) ts) $ reverse rs-        (ys0, yts', _, rt) = safeBkArrow $ instantiateTys tbody tvs'-        yts''              = F.notracepp "UNFOLDR-0" $ zipWith F.subst sus (yts'++[rt])+        tbody              = instantiatePvs (instantiateTys td ts) (reverse rs)+        -- TODO: if we ever want to support applying implicits explicitly, will need to rejigger+        ((_,_,_),(ys0,yts',_), rt) = safeBkArrow (F.notracepp msg $ instantiateTys tbody tvs')+        msg                = "INST-TY: " ++ F.showpp (td, ts, tbody, ys, tvs') +        yts''              = zipWith F.subst sus (yts'++[rt])         (t3,yts)           = (last yts'', init yts'')         sus                = F.mkSubst <$> (L.inits [(x, F.EVar y) | (x, y) <- zip ys0 ys'])         (αs, ys')          = mapSnd (F.symbol <$>) $ L.partition isTyVar ys+        tvs' :: [SpecType]         tvs'               = rVar <$> αs         tvys               = ofType . varType <$> αs  unfoldR _  _                _  = panic Nothing "Constraint.hs : unfoldR" -instantiateTys :: (Foldable t)-               => SpecType -> t (SpecType) -> SpecType+instantiateTys :: SpecType -> [SpecType] -> SpecType instantiateTys = L.foldl' go-  where go (RAllT α tbody) t = subsTyVar_meet' (ty_var_value α, t) tbody-        go _ _               = panic Nothing "Constraint.instanctiateTy"+  where +    go (RAllT α tbody) t = subsTyVar_meet' (ty_var_value α, t) tbody+    go _ _               = panic Nothing "Constraint.instantiateTy" -instantiatePvs :: Foldable t => SpecType -> t SpecProp -> SpecType-instantiatePvs = L.foldl' go-  where go (RAllP p tbody) r = replacePreds "instantiatePv" tbody [(p, r)]-        go _ _               = panic Nothing "Constraint.instanctiatePv"+instantiatePvs :: SpecType -> [SpecProp] -> SpecType+instantiatePvs           = L.foldl' go+  where +    go (RAllP p tbody) r = replacePreds "instantiatePv" tbody [(p, r)]+    go t               _ = errorP "" ("Constraint.instantiatePvs: t = " ++ showpp t)  checkTyCon :: (Outputable a) => (String, a) -> CGEnv -> SpecType -> SpecType checkTyCon _ _ t@(RApp _ _ _ _) = t-checkTyCon x g t              = checkErr x g t+checkTyCon x g t                = checkErr x g t  checkFun :: (Outputable a) => (String, a) -> CGEnv -> SpecType -> SpecType checkFun _ _ t@(RFun _ _ _ _) = t@@ -1197,7 +1307,22 @@ freshPredRef _ _ (PV _ PVHProp _ _)   = todo Nothing "EFFECTS:freshPredRef" + --------------------------------------------------------------------------------+-- | 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@@ -1246,6 +1371,22 @@ 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 --------------------------------------------------------------------------------@@ -1284,7 +1425,7 @@ makeSingleton :: CGEnv -> CoreExpr -> SpecType -> SpecType makeSingleton γ e t   | higherOrderFlag γ, App f x <- simplify e-  = case (funExpr γ f, argExpr γ x) of+  = case (funExpr γ f, argForAllExpr x) of       (Just f', Just x')                  | not (GM.isPredExpr x) -- (isClassPred $ exprType x)                  -> strengthenMeet t (uTop $ F.exprReft (F.EApp f' x'))@@ -1293,7 +1434,15 @@       _ -> t   | otherwise   = t+  where +    argForAllExpr (Var x)+      | rankNTypes (getConfig γ)+      , Just e <- M.lookup x (forallcb γ)+      = Just e +    argForAllExpr e+      = argExpr γ e + funExpr :: CGEnv -> CoreExpr -> Maybe F.Expr  -- reflectefd functions@@ -1301,7 +1450,7 @@   = F.EVar <$> (M.lookup v $ aenv γ)  -- local function arguments-funExpr γ (Var v) | S.member v (fargs γ)+funExpr γ (Var v) | S.member v (fargs γ) || GM.isDataConId v   = Just $ F.EVar (F.symbol v)  funExpr γ (App e1 e2)@@ -1360,13 +1509,29 @@ 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  -isGeneric :: RTyVar -> SpecType -> Bool-isGeneric α t =  all (\(c, α') -> (α'/=α) || isOrd c || isEq c ) (classConstrs t)-  where classConstrs t = [(c, ty_var_value α')-                                  | (c, ts) <- tyClasses t-                                  , t'      <- ts-                                  , α'      <- freeTyVars t']-        isOrd          = (ordClassName ==) . className-        isEq           = (eqClassName ==) . className+-- | @isGenericVar@ determines whether the @RTyVar@ has no class constraints+isGenericVar :: RTyVar -> SpecType -> Bool+isGenericVar α t =  all (\(c, α') -> (α'/=α) || isOrd c || isEq c ) (classConstrs t)+  where +    classConstrs t = [(c, ty_var_value α')+                        | (c, ts) <- tyClasses t+                        , t'      <- ts+                        , α'      <- freeTyVars t']+    isOrd          = (ordClassName ==) . className+    isEq           = (eqClassName ==) . className++-- instance MonadFail CG where +--  fail msg = panic Nothing msg++instance MonadFail Data.Functor.Identity.Identity where +  fail msg = panic Nothing msg
src/Language/Haskell/Liquid/Constraint/Init.hs view
@@ -39,16 +39,16 @@ 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.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.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.Types.Literals import           Language.Haskell.Liquid.Constraint.Types  -- import Debug.Trace (trace)@@ -57,9 +57,9 @@ initEnv :: GhcInfo -> CG CGEnv -------------------------------------------------------------------------------- initEnv info-  = do let tce   = gsTcEmbeds sp-       let fVars = impVars info-       let dcs   = filter isConLikeId (snd <$> gsFreeSyms sp)+  = do let tce   = gsTcEmbeds (gsName sp)+       let fVars = giImpVars (giSrc info)+       let dcs   = filter isConLikeId (snd <$> gsFreeSyms (gsName sp))        let dcs'  = filter isConLikeId fVars        defaults <- forM fVars $ \x -> liftM (x,) (trueTy $ varType x)        dcsty    <- forM dcs   makeDataConTypes@@ -68,33 +68,35 @@        f0''     <- refreshArgs' =<< grtyTop info                      -- default TOP reftype      (for exported vars without spec)        let f0'   = if notruetypes $ getConfig sp then [] else f0''        f1       <- refreshArgs'   defaults                            -- default TOP reftype      (for all vars)-       f1'      <- refreshArgs' $ makedcs dcsty                       -- data constructors+       f1'      <- refreshArgs' $ makeExactDc dcsty                   -- data constructors        f2       <- refreshArgs' $ assm info                           -- assumed refinements      (for imported vars)-       f3       <- refreshArgs' $ vals gsAsmSigs sp                   -- assumed refinedments     (with `assume`)-       f40      <- makeExactDc <$> (refreshArgs' $ vals gsCtors sp)   -- constructor refinements  (for measures)-       f5       <- refreshArgs' $ vals gsInSigs sp                    -- internal refinements     (from Haskell measures)-       (invs1, f41) <- mapSndM refreshArgs' $ makeAutoDecrDataCons dcsty  (gsAutosize sp) dcs-       (invs2, f42) <- mapSndM refreshArgs' $ makeAutoDecrDataCons dcsty' (gsAutosize sp) dcs'-       let f4    = mergeDataConTypes (mergeDataConTypes f40 (f41 ++ f42)) (filter (isDataConId . fst) f2)+       f3'      <- refreshArgs' =<< recSelectorsTy info                      -- assumed refinements      (for record selectors)+       f3       <- 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 bs    = (tx <$> ) <$> [f0 ++ f0', f1 ++ f1', f2, f3, f4, f5]+       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 γ0    = measEnv sp (head bs) (cbs info) tcb lt1s lt2s (bs!!3) (bs!!5) hs info-       γ  <- globalize <$> foldM (+=) γ0 (  [("initEnv", x, y) | (x, y) <- concat $ tail 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])        return γ {invs = is (invs1 ++ invs2)}   where-    sp           = spec info-    ialias       = mkRTyConIAl $ gsIaliases sp+    sp           = giSpec info+    ialias       = mkRTyConIAl (gsIaliases (gsData sp))     vals f       = map (mapSnd val) . f     mapSndM f    = \(x,y) -> ((x,) <$> f y)-    makedcs      = map strengthenDataConType-    makeExactDc dcs = if exactDC (getConfig info) then makedcs dcs else dcs-    is autoinv   = mkRTyConInv    (gsInvariants sp ++ ((Nothing,) <$> autoinv))+    makeExactDc dcs = if exactDCFlag info then map strengthenDataConType dcs else dcs+    is autoinv   = mkRTyConInv    (gsInvariants (gsData sp) ++ ((Nothing,) <$> autoinv))  makeDataConTypes :: Var -> CG (Var, SpecType) makeDataConTypes x = (x,) <$> (trueTy $ varType x)@@ -131,8 +133,8 @@       recarguments = filter (\(t,_) -> (toRSort t == toRSort tres)) (zip (ty_args trep) (ty_binds trep))       computelen   = foldr (F.EBin F.Plus) (F.ECon $ F.I n) (lenOf .  snd <$> recarguments) -mergeDataConTypes ::  [(Var, SpecType)] -> [(Var, SpecType)] -> [(Var, SpecType)]-mergeDataConTypes xts yts = merge (L.sortBy f xts) (L.sortBy f yts)+mergeDataConTypes ::  F.TCEmb TyCon -> [(Var, SpecType)] -> [(Var, SpecType)] -> [(Var, SpecType)]+mergeDataConTypes tce xts yts = merge (L.sortBy f xts) (L.sortBy f yts)   where     f (x,_) (y,_) = compare x y     merge [] ys = ys@@ -141,7 +143,7 @@       | x == y    = (x, mXY x tx y ty) : merge xs ys       | x <  y    = xt : merge xs (yt : ys)       | otherwise = yt : merge (xt : xs) ys-    mXY x tx y ty = meetVarTypes (F.pprint x) (getSrcSpan x, tx) (getSrcSpan y, ty)+    mXY x tx y ty = meetVarTypes tce (F.pprint x) (getSrcSpan x, tx) (getSrcSpan y, ty)  refreshArgs' :: [(a, SpecType)] -> CG [(a, SpecType)] refreshArgs' = mapM (mapSndM refreshArgs)@@ -161,8 +163,8 @@ predsUnify :: GhcSpec -> (Var, RRType RReft) -> (Var, RRType RReft) predsUnify sp = second (addTyConInfo tce tyi) -- needed to eliminate some @RPropH@   where-    tce            = gsTcEmbeds sp-    tyi            = gsTyconEnv sp+    tce            = gsTcEmbeds (gsName sp)+    tyi            = gsTyconEnv (gsName sp)   --------------------------------------------------------------------------------@@ -180,17 +182,17 @@ -------------------------------------------------------------------------------- measEnv sp xts cbs _tcb lt1s lt2s asms itys hs info = CGE   { cgLoc    = Sp.empty-  , renv     = fromListREnv (second val <$> gsMeas sp) []-  , syenv    = F.fromListSEnv $ gsFreeSyms sp+  , renv     = fromListREnv (second val <$> gsMeas (gsData sp)) []+  , syenv    = F.fromListSEnv (gsFreeSyms (gsName sp))   , litEnv   = F.fromListSEnv lts   , constEnv = F.fromListSEnv lt2s-  , fenv     = initFEnv $ filterHO (tcb' ++ lts ++ (second (rTypeSort tce . val) <$> gsMeas sp))-  , denv     = gsDicts sp+  , 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   sp+  , ial      = mkRTyConIAl (gsIaliases (gsData sp))   , grtys    = fromListREnv xts  []   , assms    = fromListREnv asms []   , intys    = fromListREnv itys []@@ -199,15 +201,16 @@   , tgKey    = Nothing   , trec     = Nothing   , lcb      = M.empty+  , forallcb = M.empty   , holes    = fromListHEnv hs   , lcs      = mempty-  , aenv     = axEnv sp+  , aenv     = axEnv (gsRefl sp)   , cerr     = Nothing   , cgInfo   = info   , cgVar    = Nothing   }   where-      tce         = gsTcEmbeds sp+      tce         = gsTcEmbeds (gsName sp)       filterHO xs = if higherOrderFlag sp then xs else filter (F.isFirstOrder . snd) xs       lts         = lt1s ++ lt2s       tcb'        = []@@ -216,23 +219,35 @@   assm :: GhcInfo -> [(Var, SpecType)]-assm = assmGrty impVars+assm = assmGrty (giImpVars . giSrc)  grty :: GhcInfo -> [(Var, SpecType)]-grty = assmGrty defVars+grty = assmGrty (giDefVars . giSrc)   assmGrty :: (GhcInfo -> [Var]) -> GhcInfo -> [(Var, SpecType)] assmGrty f info = [ (x, val t) | (x, t) <- sigs, x `S.member` xs ]   where-    xs          = S.fromList $ f info-    sigs        = gsTySigs     $ spec info+    xs          = S.fromList . f             $ info+    sigs        = gsTySigs  . gsSig . giSpec $ info ++recSelectorsTy :: GhcInfo -> 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]+    sp           = gsSig . giSpec $ info+    ++ grtyTop :: GhcInfo -> CG [(Var, SpecType)] grtyTop info     = forM topVs $ \v -> (v,) <$> trueTy (varType v)   where-    topVs        = filter isTop $ defVars info-    isTop v      = isExportedVar info v && not (v `S.member` sigVs)-    sigVs        = S.fromList [v | (v,_) <- gsTySigs (spec info) ++ gsAsmSigs (spec info) ++ gsInSigs (spec info)]+    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]+    sp           = gsSig . giSpec $ info   infoLits :: (GhcSpec -> [(F.Symbol, LocSpecType)]) -> (F.Sort -> Bool) -> GhcInfo -> F.SEnv F.Sort@@ -240,8 +255,8 @@   where     cbLits    = filter (selF . snd) $ coreBindLits tce info     measLits  = filter (selF . snd) $ mkSort <$> litF spc-    spc       = spec info-    tce       = gsTcEmbeds spc+    spc       = giSpec info+    tce       = gsTcEmbeds (gsName spc)     mkSort    = mapSnd (F.sr_sort . rTypeSortedReft tce . val)  initCGI :: Config -> GhcInfo -> CGInfo@@ -256,19 +271,22 @@   , freshIndex = 0   , dataConTys = []   , binds      = F.emptyBindEnv+  , ebinds     = []   , annotMap   = AI M.empty-  , newTyEnv   = M.fromList (mapSnd val <$> gsNewTypes spc)+  , holesMap   = M.empty+  , newTyEnv   = M.fromList (mapSnd val <$> gsNewTypes (gsSig spc))   , tyConInfo  = tyi   , tyConEmbed = tce   , kuts       = mempty   , kvPacks    = mempty-  , cgLits     = infoLits gsMeas   (const True) info-  , cgConsts   = infoLits gsLits notFn info-  , cgADTs     = gsADTs spc-  , termExprs  = M.fromList $ gsTexprs spc-  , specDecr   = gsDecr spc-  , specLVars  = gsLvars spc-  , specLazy   = dictionaryVar `S.insert` gsLazy spc+  , cgLits     = infoLits (gsMeas . gsData) (const True) info+  , cgConsts   = infoLits (gsMeas . gsData) notFn        info+  , cgADTs     = gsADTs nspc+  , termExprs  = M.fromList [(v, es) | (v, _, es) <- gsTexprs (gsSig spc) ]+  , specDecr   = gsDecr  tspc+  , specLVars  = gsLvars (gsVars spc)+  , specLazy   = dictionaryVar `S.insert` (gsLazy tspc)+  , specTmVars = gsNonStTerm tspc   , tcheck     = terminationCheck cfg   , scheck     = strata cfg   , pruneRefs  = pruneUnsorted cfg@@ -276,14 +294,17 @@   , kvProf     = emptyKVProf   , recCount   = 0   , bindSpans  = M.empty-  , autoSize   = gsAutosize spc+  , autoSize   = gsAutosize tspc   , allowHO    = higherOrderFlag cfg   , ghcI       = info+  , unsorted   = F.notracepp "UNSORTED" $ F.makeTemplates $ gsUnsorted $ gsData spc   }   where-    tce        = gsTcEmbeds spc-    spc        = spec info-    tyi        = gsTyconEnv spc+    tce        = gsTcEmbeds nspc +    tspc       = gsTerm spc+    spc        = giSpec info+    tyi        = gsTyconEnv nspc+    nspc       = gsName spc     notFn      = isNothing . F.functionSort  coreBindLits :: F.TCEmb TyCon -> GhcInfo -> [(F.Symbol, F.Sort)]@@ -291,9 +312,11 @@   = sortNub      $ [ (F.symbol x, F.strSort) | (_, Just (F.ESym x)) <- lconsts ]    -- strings                 ++ [ (dconToSym dc, dconToSort dc) | dc <- dcons ]                  -- data constructors   where-    lconsts      = literalConst tce <$> literals (cbs info)+    src         = giSrc info+    lconsts      = literalConst tce <$> literals (giCbs src)     dcons        = filter isDCon freeVs-    freeVs       = impVars info ++ (snd <$> gsFreeSyms (spec info))+    freeVs       = giImpVars src ++ freeSyms+    freeSyms     = fmap snd . gsFreeSyms . gsName . giSpec $ info     dconToSort   = typeSort tce . expandTypeSynonyms . varType     dconToSym    = F.symbol . idDataCon     isDCon x     = isDataConId x && not (hasBaseTypeVar x)
src/Language/Haskell/Liquid/Constraint/Monad.hs view
@@ -12,9 +12,10 @@ import           Var import           Name (getSrcSpan) import           SrcLoc-import           Outputable hiding (showPpr, panic)+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@@ -22,11 +23,14 @@ 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.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?@@ -51,7 +55,7 @@   | otherwise   = do modify $ \s -> s { hsCs  = c : (hsCs s) }        bflag <- headDefault True . isBind <$> get-       sflag <- scheck                 <$> get+       sflag <- scheck                    <$> get        if bflag && sflag          then modify $ \s -> s {sCs = (SubC γ t2 t1) : (sCs s) }          else return ()@@ -112,6 +116,18 @@ addLocA !xo !l !t   = modify $ \s -> s { annotMap = addA l xo t $ annotMap s } ++-- | Used for annotating holes ++addHole :: Var -> SpecType -> CGEnv -> CG () +addHole x t γ = do +  modify $ \s -> s {holesMap = M.insertWith (<>) x hinfo $ holesMap s}+  addWarning $ ErrHole loc ("hole found") (reGlobal env <> reLocal env) x' t +    where +      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
src/Language/Haskell/Liquid/Constraint/Qualifier.hs view
@@ -5,7 +5,7 @@   module Language.Haskell.Liquid.Constraint.Qualifier-  ( qualifiers+  ( giQuals    , useSpcQuals   )   where@@ -26,14 +26,15 @@ 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    ---------------------------------------------------------------------------------qualifiers :: GhcInfo -> SEnv Sort -> [Qualifier]+giQuals :: GhcInfo -> SEnv Sort -> [Qualifier] ---------------------------------------------------------------------------------qualifiers info lEnv-  =  condNull (useSpcQuals info) (gsQualifiers $ spec info)+giQuals info lEnv+  =  notracepp ("GI-QUALS: " ++ showpp lEnv)+  $  condNull (useSpcQuals info) (gsQualifiers . gsQual . giSpec $ info)   ++ condNull (useSigQuals info) (sigQualifiers  info lEnv)   ++ condNull (useAlsQuals info) (alsQualifiers  info lEnv) @@ -72,26 +73,22 @@ alsQualifiers :: GhcInfo -> SEnv Sort -> [Qualifier] -------------------------------------------------------------------------------- alsQualifiers info lEnv-  = [ q | a <- specAliases info-        , q <- refTypeQuals lEnv (rtPos a) tce (rtBody a)+  = [ q | a <- gsRTAliases . gsQual . giSpec $ info+        , q <- refTypeQuals lEnv (loc a) tce (rtBody (val a))         , length (qParams q) <= k + 1         , validQual lEnv q     ]     where       k   = maxQualParams info-      tce = gsTcEmbeds (spec info)--    -- Symbol (RTAlias RTyVar SpecType)--specAliases :: GhcInfo -> [RTAlias RTyVar SpecType]-specAliases = M.elems . typeAliases . gsRTAliases . spec+      tce = gsTcEmbeds . gsName . giSpec $ info  validQual :: SEnv Sort -> Qualifier -> Bool-validQual lEnv q = isJust $ checkSortExpr env (qBody q)+validQual lEnv q = isJust $ checkSortExpr (srcSpan q) env (qBody q)   where     env          = unionSEnv lEnv qEnv-    qEnv         = M.fromList (qParams q)+    qEnv         = M.fromList (qualBinds q) + -------------------------------------------------------------------------------- sigQualifiers :: GhcInfo -> SEnv Sort -> [Qualifier] --------------------------------------------------------------------------------@@ -105,36 +102,38 @@     ]     where       k   = maxQualParams info-      tce = gsTcEmbeds (spec info)+      tce = gsTcEmbeds . gsName . giSpec $ info       qbs = qualifyingBinders info  qualifyingBinders :: GhcInfo -> S.HashSet Var qualifyingBinders info = S.difference sTake sDrop   where-    sTake              = S.fromList $ defVars info ++ useVars info ++ scrapeVars info+    sTake              = S.fromList $ giDefVars src ++ giUseVars src ++ scrapeVars cfg src      sDrop              = S.fromList $ specAxiomVars info-+    cfg                = getConfig info +    src                = giSrc     info +     -- NOTE: this mines extra, useful qualifiers but causes -- a significant increase in running time, so we hide it -- behind `--scrape-imports` and `--scrape-used-imports`-scrapeVars :: GhcInfo -> [Var]-scrapeVars info-  | info `hasOpt` scrapeUsedImports = useVars info-  | info `hasOpt` scrapeImports     = impVars info-  | otherwise                       = []+scrapeVars :: Config -> GhcSrc -> [Var]+scrapeVars cfg src +  | cfg `hasOpt` scrapeUsedImports = giUseVars src +  | cfg `hasOpt` scrapeImports     = giImpVars src +  | otherwise                      = []  specBinders :: GhcInfo -> [(Var, LocSpecType)] specBinders info = mconcat-  [ gsTySigs  sp-  , gsAsmSigs sp-  , gsCtors   sp-  , if info `hasOpt` scrapeInternals then gsInSigs sp else []+  [ gsTySigs  (gsSig  sp)+  , gsAsmSigs (gsSig  sp)+  , gsCtors   (gsData sp)+  , if info `hasOpt` scrapeInternals then gsInSigs (gsSig sp) else []   ]   where-    sp  = spec info+    sp  = giSpec info  specAxiomVars :: GhcInfo -> [Var]-specAxiomVars =  gsReflects . spec+specAxiomVars =  gsReflects . gsRefl . giSpec  -- GRAVEYARD: scraping quals from imports kills the system with too much crap -- specificationQualifiers info = {- filter okQual -} qs@@ -191,7 +190,8 @@                    , pa                        <- conjuncts ra                    , not $ isHole    pa                    , not $ isGradual pa-                   , isNothing $ checkSorted (insertSEnv v so γ') pa+                   , notracepp ("refTopQuals: " ++ showpp pa) +                     $ isNothing $ checkSorted (srcSpan l) (insertSEnv v so γ') pa     ]     ++     [ mkP s e | let (MkUReft _ (Pr ps) _) = fromMaybe (msg t) $ stripRTypeBase t@@ -228,10 +228,10 @@        -> Sort        -> Expr        -> Qualifier-mkQual lEnv l _ γ v so p   = Q "Auto" ((v, so) : xts) p l+mkQual lEnv l _ γ v so p   = mkQ "Auto" ((v, so) : xts) p l   where     xs   = delete v $ nub $ syms p-    xts = catMaybes $ zipWith (envSort l lEnv γ) xs [0..]+    xts  = catMaybes $ zipWith (envSort l lEnv γ) xs [0..]  envSort :: SourcePos -> SEnv Sort -> SEnv Sort -> Symbol -> Integer -> Maybe (Symbol, Sort) envSort l lEnv tEnv x i
src/Language/Haskell/Liquid/Constraint/Split.hs view
@@ -43,17 +43,16 @@  import           Language.Haskell.Liquid.Misc -- (concatMapM) import qualified Language.Haskell.Liquid.UX.CTags       as Tg-import           Language.Haskell.Liquid.UX.Errors () -- 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.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.Fresh import           Language.Haskell.Liquid.Constraint.Monad import           Language.Haskell.Liquid.Constraint.Constraint @@ -67,6 +66,14 @@         ws'' <- splitW (WfC γ' t2)         return $ ws ++ ws' ++ ws'' +splitW (WfC γ t@(RImpF x t1 t2 _))+  =  do ws'  <- splitW (WfC γ t1)+        γ'   <- γ += ("splitW", x, t1)+        ws   <- bsplitW γ t+        ws'' <- splitW (WfC γ' t2)+        return $ ws ++ ws' ++ ws''++ splitW (WfC γ t@(RAppTy t1 t2 _))   =  do ws   <- bsplitW γ t         ws'  <- splitW (WfC γ t1)@@ -125,19 +132,19 @@  bsplitW :: CGEnv -> SpecType -> CG [FixWfC] bsplitW γ t =-  do pflag <- pruneRefs <$> get+  do temp  <- getTemplates      isHO  <- allowHO   <$> get-     return $ bsplitW' γ t pflag isHO+     return $ bsplitW' γ t temp isHO  bsplitW' :: (PPrint r, F.Reftable r, SubsTy RTyVar RSort r, F.Reftable (RTProp RTyCon RTyVar r))-         => CGEnv -> RRType r -> Bool -> Bool -> [F.WfC Cinfo]-bsplitW' γ t pflag isHO+         => CGEnv -> RRType r -> F.Templates -> Bool -> [F.WfC Cinfo]+bsplitW' γ t temp isHO   | isHO || F.isNonTrivial r'   = F.wfC (feBinds $ fenv γ) r' ci   | otherwise   = []   where-    r'                = rTypeSortedReft' pflag γ t+    r'                = rTypeSortedReft' γ temp t     ci                = Ci (getLocation γ) Nothing (cgVar γ)  --------------------------------------------------------------------------------@@ -176,6 +183,15 @@         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)@@ -342,6 +358,16 @@         cs''     <- splitC  (SubC γ' t1x2' t2')         return    $ cs ++ cs' ++ cs'' +splitC (SubC γ (RImpF x1 t1 t1' r1) (RImpF x2 t2 t2' r2))+  =  do cs'      <- splitC  (SubC γ t2 t1)+        γ'       <- γ+= ("splitC", x2, t2)+        cs       <- bsplitC γ (RImpF x1 t1 t1' (r1 `F.subst1` (x1, F.EVar x2)))+                              (RImpF x2 t2 t2'  r2)+        let t1x2' = t1' `F.subst1` (x1, F.EVar x2)+        cs''     <- splitC  (SubC γ' t1x2' t2')+        return    $ cs ++ cs' ++ cs''++ splitC (SubC γ t1@(RAppTy r1 r1' _) t2@(RAppTy r2 r2' _))   =  do cs    <- bsplitC γ t1 t2         cs'   <- splitC  (SubC γ r1 r2)@@ -394,8 +420,8 @@   = panic (Just $ getLocation γ) $ "(Another Broken Test!!!) splitc unexpected:\n" ++ traceTy t1 ++ "\n  <:\n" ++ traceTy t2  splitC (SubR γ o r)-  = do fg     <- pruneRefs <$> get-       let r1' = if fg then pruneUnsortedReft γ'' r1 else r1+  = do ts     <- getTemplates+       let r1' = pruneUnsortedReft γ'' ts r1        return $ F.subC γ' r1' r2 Nothing tag ci   where     γ'' = feEnv $ fenv γ@@ -416,6 +442,7 @@ traceTy (RAllP _ t)     = parens ("RAllP " ++ traceTy t) traceTy (RAllS _ t)     = parens ("RAllS " ++ traceTy t) traceTy (RAllT _ t)     = parens ("RAllT " ++ traceTy t)+traceTy (RImpF _ t t' _) = parens ("RImpF " ++ parens (traceTy t) ++ parens (traceTy t')) traceTy (RFun _ t t' _) = parens ("RFun " ++ parens (traceTy t) ++ parens (traceTy t')) traceTy (RAllE _ tx t)  = parens ("RAllE " ++ parens (traceTy tx) ++ parens (traceTy t)) traceTy (REx _ tx t)    = parens ("REx " ++ parens (traceTy tx) ++ parens (traceTy t))@@ -457,10 +484,10 @@         -> CG [F.SubC Cinfo] bsplitC γ t1 t2 = do   checkStratum γ t1 t2-  pflag  <- pruneRefs <$> get+  temp   <- getTemplates   isHO   <- allowHO   <$> get   t1'    <- addLhsInv γ <$> refreshVV t1-  return  $ bsplitC' γ t1' t2 pflag isHO+  return  $ bsplitC' γ t1' t2 temp isHO  addLhsInv :: CGEnv -> SpecType -> SpecType addLhsInv γ t = addRTyConInv (invs γ) t `strengthen` r@@ -481,8 +508,8 @@     [s1, s2]  = getStrata <$> [t1, t2]     wrn       =  ErrOther (getLocation γ) (text $ "Stratum Error : " ++ show s1 ++ " > " ++ show s2) -bsplitC' :: CGEnv -> SpecType -> SpecType -> Bool -> Bool -> [F.SubC Cinfo]-bsplitC' γ t1 t2 pflag isHO+bsplitC' :: CGEnv -> SpecType -> SpecType -> F.Templates -> Bool -> [F.SubC Cinfo]+bsplitC' γ t1 t2 tem isHO  | isHO  = F.subC γ' r1'  r2' Nothing tag ci  | F.isFunctionSortedReft r1' && F.isNonTrivial r2'@@ -493,8 +520,8 @@  = []   where     γ'  = feBinds $ fenv γ-    r1' = rTypeSortedReft' pflag γ t1-    r2' = rTypeSortedReft' pflag γ t2+    r1' = rTypeSortedReft' γ tem t1+    r2' = rTypeSortedReft' γ tem t2     ci  = Ci src err (cgVar γ)     tag = getTag γ     -- err = Just $ ErrSubType src "subtype" g t1 t2@@ -561,7 +588,7 @@                      -> Maybe ([F.Symbol], [SpecType], [RReft], SpecType) forallExprReftLookup γ x = snap <$> F.lookupSEnv x (syenv γ)   where-    snap     = mapFourth4 ignoreOblig . bkArrow . fourth4 . bkUniv . lookup+    snap     = mapFourth4 ignoreOblig . (\(_,(a,b,c),t)->(a,b,c,t)) . bkArrow . fourth4 . bkUniv . lookup     lookup z = fromMaybe (panicUnbound γ z) (γ ?= F.symbol z)  
src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs view
@@ -5,25 +5,22 @@   ) where  import           Prelude hiding (error)-import           Data.Monoid-+import qualified Language.Haskell.Liquid.GHC.API as Ghc import qualified Language.Fixpoint.Types.Config as FC import           System.Console.CmdArgs.Default (def) import qualified Language.Fixpoint.Types        as F import           Language.Haskell.Liquid.Constraint.Types import qualified Language.Haskell.Liquid.Types.RefType as RT import           Language.Haskell.Liquid.Types hiding     ( binds )-import           Language.Fixpoint.Solver                 ( parseFInfo ) import           Language.Haskell.Liquid.Constraint.Qualifier-import Data.Maybe (fromJust)+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.GHC.Misc  (simplesymbol)+import qualified Language.Haskell.Liquid.GHC.Misc  as GM -- (simplesymbol) import qualified Data.List                         as L import qualified Data.HashMap.Strict               as M-import           Data.Maybe                        (fromMaybe) -- import           Language.Fixpoint.Misc import qualified Language.Haskell.Liquid.Misc      as Misc import           Var@@ -31,7 +28,7 @@  fixConfig :: FilePath -> Config -> FC.Config fixConfig tgt cfg = def-  { FC.solver           = fromJust (smtsolver cfg)+  { FC.solver           = Mb.fromJust (smtsolver cfg)   , FC.linear           = linear            cfg   , FC.eliminate        = eliminate         cfg   , FC.nonLinCuts       = not (higherOrderFlag cfg) -- eliminate cfg /= FC.All@@ -44,10 +41,7 @@   , FC.elimBound        = elimBound         cfg   , FC.allowHO          = higherOrderFlag   cfg   , FC.allowHOqs        = higherorderqs     cfg-  , FC.extensionality   = extensionality    cfg || gradual cfg-  , FC.alphaEquivalence = alphaEquivalence  cfg-  , FC.betaEquivalence  = betaEquivalence   cfg-  , FC.normalForm       = normalForm        cfg+  , FC.smtTimeout       = smtTimeout        cfg    , FC.stringTheory     = stringTheory      cfg   , FC.gradual          = gradual           cfg   , FC.ginteractive     = ginteractive       cfg@@ -57,28 +51,21 @@   cgInfoFInfo :: GhcInfo -> CGInfo -> IO (F.FInfo Cinfo)-cgInfoFInfo info cgi = do-  let tgtFI  = targetFInfo info cgi-  impFI     <- ignoreQualifiers info <$> parseFInfo (hqFiles info)-  return       (tgtFI <> impFI)--ignoreQualifiers :: GhcInfo -> F.FInfo a -> F.FInfo a-ignoreQualifiers info fi-  | useSpcQuals info = fi-  | otherwise        = fi { F.quals = [] }+cgInfoFInfo info cgi = return (targetFInfo info cgi)  targetFInfo :: GhcInfo -> 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+    fi               = F.fi cs ws bs ls consts ks qs bi aHO aHOqs es mempty adts ebs     cs               = fixCs    cgi     ws               = fixWfs   cgi     bs               = binds    cgi+    ebs              = ebinds   cgi     ls               = fEnv     cgi     consts           = cgConsts cgi     ks               = kuts     cgi     adts             = cgADTs   cgi-    qs               = qualifiers info (fEnv cgi)+    qs               = giQuals info (fEnv cgi)     bi               = (\x -> Ci x Nothing Nothing) <$> bindSpans cgi     aHO              = allowHO cgi     aHOqs            = higherOrderFlag info@@ -88,18 +75,35 @@  makeAxiomEnvironment :: GhcInfo -> [(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 (makeEquations sp ++ [specTypeEq emb x t | (x, t) <- xts])             (concatMap makeSimplify xts)            (doExpand sp cfg <$> fcs)   where-    emb      = gsTcEmbeds sp+    emb      = gsTcEmbeds (gsName sp)     cfg      = getConfig  info-    sp       = spec       info+    sp       = giSpec     info +_isClassOrDict :: Id -> Bool+_isClassOrDict x = F.tracepp ("isClassOrDict: " ++ F.showpp x) +                    $ (hasClassArg x || GM.isDictionary x || Mb.isJust (Ghc.isClassOpId_maybe x))++hasClassArg :: Id -> Bool+hasClassArg x = F.tracepp msg $ (GM.isDataConId x && any Ghc.isClassPred (t:ts))+  where +    msg       = "hasClassArg: " ++ showpp (x, t:ts)+    (ts, t)   = Ghc.splitFunTys . snd . Ghc.splitForAllTys . Ghc.varType $ x++ doExpand :: GhcSpec -> Config -> F.SubC Cinfo -> Bool doExpand sp cfg sub = Config.allowGlobalPLE cfg-                   || (Config.allowLocalPLE cfg && maybe False (`M.member` gsAutoInst sp) (subVar sub))+                   || (Config.allowLocalPLE cfg && maybe False (isPLEVar sp) (subVar sub)) +-- [TODO:missing-sorts] data-constructors often have unelaboratable 'define' so either+-- 1. Make `elaborate` robust so it doesn't crash and returns maybe or+-- 2. Make the `ctor` well-sorted or +-- 3. Don't create `define` for the ctor. +-- Unfortunately 3 breaks a bunch of tests...+ specTypeEq :: F.TCEmb TyCon -> Var -> SpecType -> F.Equation specTypeEq emb f t = F.mkEquation (F.symbol f) xts body tOut   where@@ -137,12 +141,14 @@  makeEquations :: GhcSpec -> [F.Equation] makeEquations sp = [ F.mkEquation f xts (equationBody (F.EVar f) xArgs e mbT) t-                      | F.Equ f xts e t _ <- gsAxioms sp+                      | F.Equ f xts e t _ <- axioms                        , let mbT            = M.lookup f sigs                       , let xArgs          = F.EVar . fst <$> xts                    ]   where-    sigs         = M.fromList [ (simplesymbol v, t) | (v, t) <- gsTySigs sp ]+    axioms       = gsMyAxioms refl ++ gsImpAxioms refl +    refl         = gsRefl sp+    sigs         = M.fromList [ (GM.simplesymbol v, t) | (v, t) <- gsTySigs (gsSig sp) ]  equationBody :: F.Expr -> [F.Expr] -> F.Expr -> Maybe LocSpecType -> F.Expr equationBody f xArgs e mbT@@ -161,7 +167,7 @@   where     res       = specTypeToResultRef e t     args      = zipWith mkExpr (mkReft <$> ts) es-    mkReft t  =  F.toReft $ fromMaybe mempty (stripRTypeBase t)+    mkReft t  =  F.toReft $ Mb.fromMaybe mempty (stripRTypeBase t)     mkExpr (F.Reft (v, ev)) e = F.subst1 ev (v, e)  @@ -185,7 +191,7 @@  specTypeToResultRef :: F.Expr -> SpecType -> F.Expr specTypeToResultRef e t-  = mkExpr $ F.toReft $ fromMaybe mempty (stripRTypeBase $ ty_res trep)+  = mkExpr $ F.toReft $ Mb.fromMaybe mempty (stripRTypeBase $ ty_res trep)   where     mkExpr (F.Reft (v, ev)) = F.subst1 ev (v, e)     trep                   = toRTypeRep t
src/Language/Haskell/Liquid/Constraint/Types.hs view
@@ -1,8 +1,11 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE TupleSections     #-}-{-# LANGUAGE EmptyDataDecls    #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE TupleSections        #-}+{-# LANGUAGE EmptyDataDecls       #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances    #-} + module Language.Haskell.Liquid.Constraint.Types   ( -- * Constraint Generation Monad     CG@@ -50,6 +53,8 @@   , removeInvariant, restoreInvariant, makeRecInvariants    , addArgument, addArguments++  , getTemplates   ) where  import Prelude hiding (error)@@ -60,18 +65,20 @@ import           Unify (tcUnifyTy) import qualified TyCon   as TC import qualified DataCon as DC-import           Text.PrettyPrint.HughesPJ hiding (first)+import           Text.PrettyPrint.HughesPJ hiding ((<>))  import qualified Data.HashMap.Strict as M import qualified Data.HashSet        as S import qualified Data.List           as L import           Control.DeepSeq import           Data.Maybe               (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.Types.Strata import           Language.Haskell.Liquid.Misc           (fourth4)-import           Language.Haskell.Liquid.Types.RefType  (shiftVV, toType)+-- import           Language.Haskell.Liquid.Types.RefType  (shiftVV, toType) import           Language.Haskell.Liquid.WiredIn        (wiredSortedSyms) import qualified Language.Fixpoint.Types            as F import Language.Fixpoint.Misc@@ -101,6 +108,7 @@   , tgKey  :: !(Maybe Tg.TagKey)                     -- ^ Current top-level binder   , trec   :: !(Maybe (M.HashMap F.Symbol SpecType)) -- ^ Type of recursive function with decreasing constraints   , lcb    :: !(M.HashMap F.Symbol CoreExpr)         -- ^ Let binding that have not been checked (c.f. LAZYVARs)+  , forallcb :: !(M.HashMap Var F.Expr)              -- ^ Polymorhic let bindings    , holes  :: !HEnv                                  -- ^ Types with holes, will need refreshing   , lcs    :: !LConstraint                           -- ^ Logical Constraints   , aenv   :: !(M.HashMap Var F.Symbol)              -- ^ axiom environment maps reflected Haskell functions to the logical functions@@ -117,8 +125,11 @@  instance Monoid LConstraint where   mempty  = LC []-  mappend (LC cs1) (LC cs2) = LC (cs1 ++ cs2)+  mappend = (<>) +instance Semigroup LConstraint where+  LC cs1 <> LC cs2 = LC (cs1 ++ cs2)+ instance PPrint CGEnv where   pprintTidy k = pprintTidy k . renv @@ -171,9 +182,8 @@ -------------------------------------------------------------------------------- -- | Generation: Types --------------------------------------------------------- ----------------------------------------------------------------------------------data CGInfo = CGInfo {-    fEnv       :: !(F.SEnv F.Sort)             -- ^ top-level fixpoint env+data CGInfo = CGInfo +  { 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@@ -182,13 +192,16 @@   , 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-  , tyConInfo  :: !(M.HashMap TC.TyCon RTyCon) -- ^ information about type-constructors-  , specDecr   :: ![(Var, [Int])]              -- ^ ? FIX THIS+  , holesMap   :: !(M.HashMap Var [HoleInfo 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.   , termExprs  :: !(M.HashMap Var [F.Located F.Expr])   -- ^ Terminating Metrics for Recursive functions   , specLVars  :: !(S.HashSet Var)             -- ^ Set of variables to ignore for termination checking   , specLazy   :: !(S.HashSet Var)             -- ^ "Lazy binders", skip termination checking+  , specTmVars :: !(S.HashSet Var)             -- ^ Binders that FAILED struct termination check that MUST be checked    , autoSize   :: !(S.HashSet TC.TyCon)        -- ^ ? FIX THIS   , tyConEmbed :: !(F.TCEmb TC.TyCon)          -- ^ primitive Sorts into which TyCons should be embedded   , kuts       :: !F.Kuts                      -- ^ Fixpoint Kut variables (denoting "back-edges"/recursive KVars)@@ -206,8 +219,17 @@   , allowHO    :: !Bool   , ghcI       :: !GhcInfo   , dataConTys :: ![(Var, SpecType)]           -- ^ Refined Types of Data Constructors+  , unsorted   :: !F.Templates                 -- ^ Potentially unsorted expressions   } ++getTemplates :: CG F.Templates+getTemplates = do +  fg     <- pruneRefs <$> get+  ts     <- unsorted  <$> get+  return $ if fg then F.anything else ts +       + instance PPrint CGInfo where   pprintTidy = pprCGInfo @@ -410,7 +432,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/Desugar/Check.hs 
@@ -1,1856 +0,0 @@-{--Author: George Karachalias <george.karachalias@cs.kuleuven.be>--Pattern Matching Coverage Checking.--}--{-# LANGUAGE CPP, GADTs, DataKinds, KindSignatures #-}-{-# LANGUAGE TupleSections #-}--module Language.Haskell.Liquid.Desugar.Check (-        -- Checking and printing-        checkSingle, checkMatches, isAnyPmCheckEnabled,--        -- See Note [Type and Term Equality Propagation]-        genCaseTmCs1, genCaseTmCs2-    ) where--import Language.Haskell.Liquid.Desugar.TmOracle--import DynFlags-import HsSyn-import TcHsSyn-import Id-import ConLike-import Name-import FamInstEnv-import TysWiredIn-import TyCon-import SrcLoc-import Util-import Outputable-import FastString-import DataCon-import HscTypes (CompleteMatch(..))--import Language.Haskell.Liquid.Desugar.DsMonad-import TcSimplify    (tcCheckSatisfiability)-import TcType        (toTcType, isStringTy, isIntTy, isWordTy)-import Bag-import ErrUtils-import Var           (EvVar)-import Type-import UniqSupply-import Language.Haskell.Liquid.Desugar.DsGRHSs       (isTrueLHsExpr)--import Data.List     (find)-import Data.Maybe    (isJust, fromMaybe)-import Control.Monad (forM, when, forM_)-import Coercion-import TcEvidence-import IOEnv--import ListT (ListT(..), fold, select)--{--This module checks pattern matches for:-\begin{enumerate}-  \item Equations that are redundant-  \item Equations with inaccessible right-hand-side-  \item Exhaustiveness-\end{enumerate}--The algorithm is based on the paper:--  "GADTs Meet Their Match:-     Pattern-matching Warnings That Account for GADTs, Guards, and Laziness"--    http://people.cs.kuleuven.be/~george.karachalias/papers/p424-karachalias.pdf--%************************************************************************-%*                                                                      *-                     Pattern Match Check Types-%*                                                                      *-%************************************************************************--}---- We use the non-determinism monad to apply the algorithm to several--- possible sets of constructors. Users can specify complete sets of--- constructors by using COMPLETE pragmas.--- The algorithm only picks out constructor--- sets deep in the bowels which makes a simpler `mapM` more difficult to--- implement. The non-determinism is only used in one place, see the ConVar--- case in `pmCheckHd`.--type PmM a = ListT DsM a--liftD :: DsM a -> PmM a-liftD m = ListT $ \sk fk -> m >>= \a -> sk a fk---- Pick the first match complete covered match or otherwise the "best" match.--- The best match is the one with the least uncovered clauses, ties broken--- by the number of inaccessible clauses followed by number of redudant--- clauses-getResult :: PmM PmResult -> DsM PmResult-getResult ls = do-  res <- fold ls goM (pure Nothing)-  case res of-    Nothing -> panic "getResult is empty"-    Just a -> return a-  where-    goM :: PmResult -> DsM (Maybe PmResult) -> DsM (Maybe PmResult)-    goM mpm dpm = do-      pmr <- dpm-      return $ go pmr mpm-    -- Careful not to force unecessary results-    go :: Maybe PmResult -> PmResult -> Maybe PmResult-    go Nothing rs = Just rs-    go old@(Just (PmResult prov rs (UncoveredPatterns us) is)) new-      | null us && null rs && null is = old-      | otherwise =-        let PmResult prov' rs' (UncoveredPatterns us') is' = new-            lr  = length rs-            lr' = length rs'-            li  = length is-            li' = length is'-        in case compare (length us) (length us')-                `mappend` (compare li li')-                `mappend` (compare lr lr')-                `mappend` (compare prov prov') of-              GT  -> Just new-              EQ  -> Just new-              LT  -> old-    go (Just (PmResult _ _ (TypeOfUncovered _) _)) _new-      = panic "getResult: No inhabitation candidates"--data PatTy = PAT | VA -- Used only as a kind, to index PmPat---- The *arity* of a PatVec [p1,..,pn] is--- the number of p1..pn that are not Guards--data PmPat :: PatTy -> * where-  PmCon  :: { pm_con_con     :: ConLike-            , pm_con_arg_tys :: [Type]-            , pm_con_tvs     :: [TyVar]-            , pm_con_dicts   :: [EvVar]-            , pm_con_args    :: [PmPat t] } -> PmPat t-            -- For PmCon arguments' meaning see @ConPatOut@ in hsSyn/HsPat.hs-  PmVar  :: { pm_var_id   :: Id    } -> PmPat t-  PmLit  :: { pm_lit_lit  :: PmLit } -> PmPat t -- See Note [Literals in PmPat]-  PmNLit :: { pm_lit_id   :: Id-            , pm_lit_not  :: [PmLit] } -> PmPat 'VA-  PmGrd  :: { pm_grd_pv   :: PatVec-            , pm_grd_expr :: PmExpr  } -> PmPat 'PAT---- data T a where---     MkT :: forall p q. (Eq p, Ord q) => p -> q -> T [p]--- or  MkT :: forall p q r. (Eq p, Ord q, [p] ~ r) => p -> q -> T r--type Pattern = PmPat 'PAT -- ^ Patterns-type ValAbs  = PmPat 'VA  -- ^ Value Abstractions--type PatVec = [Pattern]             -- ^ Pattern Vectors-data ValVec = ValVec [ValAbs] Delta -- ^ Value Vector Abstractions---- | Term and type constraints to accompany each value vector abstraction.--- For efficiency, we store the term oracle state instead of the term--- constraints. TODO: Do the same for the type constraints?-data Delta = MkDelta { delta_ty_cs :: Bag EvVar-                     , delta_tm_cs :: TmState }--type ValSetAbs = [ValVec]  -- ^ Value Set Abstractions-type Uncovered = ValSetAbs---- Instead of keeping the whole sets in memory, we keep a boolean for both the--- covered and the divergent set (we store the uncovered set though, since we--- want to print it). For both the covered and the divergent we have:------   True <=> The set is non-empty------ hence:---  C = True             ==> Useful clause (no warning)---  C = False, D = True  ==> Clause with inaccessible RHS---  C = False, D = False ==> Redundant clause--data Covered = Covered | NotCovered-  deriving Show--instance Outputable Covered where-  ppr (Covered) = text "Covered"-  ppr (NotCovered) = text "NotCovered"---- Like the or monoid for booleans--- Covered = True, Uncovered = False-instance Monoid Covered where-  mempty = NotCovered-  Covered `mappend` _ = Covered-  _ `mappend` Covered = Covered-  NotCovered `mappend` NotCovered = NotCovered--data Diverged = Diverged | NotDiverged-  deriving Show--instance Outputable Diverged where-  ppr Diverged = text "Diverged"-  ppr NotDiverged = text "NotDiverged"--instance Monoid Diverged where-  mempty = NotDiverged-  Diverged `mappend` _ = Diverged-  _ `mappend` Diverged = Diverged-  NotDiverged `mappend` NotDiverged = NotDiverged---- | When we learned that a given match group is complete-data Provenance =-                  FromBuiltin -- ^  From the original definition of the type-                              --    constructor.-                | FromComplete -- ^ From a user-provided @COMPLETE@ pragma-  deriving (Show, Eq, Ord)--instance Outputable Provenance where-  ppr  = text . show--instance Monoid Provenance where-  mempty = FromBuiltin-  FromComplete `mappend` _ = FromComplete-  _ `mappend` FromComplete = FromComplete-  _ `mappend` _ = FromBuiltin--data PartialResult = PartialResult {-                        presultProvenence :: Provenance-                         -- keep track of provenance because we don't want-                         -- to warn about redundant matches if the result-                         -- is contaiminated with a COMPLETE pragma-                      , presultCovered :: Covered-                      , presultUncovered :: Uncovered-                      , presultDivergent :: Diverged }--instance Outputable PartialResult where-  ppr (PartialResult prov c vsa d)-           = text "PartialResult" <+> ppr prov <+> ppr c-                                  <+> ppr d <+> ppr vsa--instance Monoid PartialResult where-  mempty = PartialResult mempty mempty [] mempty-  (PartialResult prov1 cs1 vsa1 ds1)-    `mappend` (PartialResult prov2 cs2 vsa2 ds2)-      = PartialResult (prov1 `mappend` prov2)-                      (cs1 `mappend` cs2)-                      (vsa1 `mappend` vsa2)-                      (ds1 `mappend` ds2)---- newtype ChoiceOf a = ChoiceOf [a]---- | Pattern check result------ * Redundant clauses--- * Not-covered clauses (or their type, if no pattern is available)--- * Clauses with inaccessible RHS------ More details about the classification of clauses into useful, redundant--- and with inaccessible right hand side can be found here:------     https://ghc.haskell.org/trac/ghc/wiki/PatternMatchCheck----data PmResult =-  PmResult {-      pmresultProvenance :: Provenance-    , pmresultRedundant :: [Located [LPat Id]]-    , pmresultUncovered :: UncoveredCandidates-    , pmresultInaccessible :: [Located [LPat Id]] }---- | Either a list of patterns that are not covered, or their type, in case we--- have no patterns at hand. Not having patterns at hand can arise when--- handling EmptyCase expressions, in two cases:------ * The type of the scrutinee is a trivially inhabited type (like Int or Char)--- * The type of the scrutinee cannot be reduced to WHNF.------ In both these cases we have no inhabitation candidates for the type at hand,--- but we don't want to issue just a wildcard as missing. Instead, we print a--- type annotated wildcard, so that the user knows what kind of patterns is--- expected (e.g. (_ :: Int), or (_ :: F Int), where F Int does not reduce).-data UncoveredCandidates = UncoveredPatterns Uncovered-                         | TypeOfUncovered Type---- | The empty pattern check result-emptyPmResult :: PmResult-emptyPmResult = PmResult FromBuiltin [] (UncoveredPatterns []) []---- | Non-exhaustive empty case with unknown/trivial inhabitants-uncoveredWithTy :: Type -> PmResult-uncoveredWithTy ty = PmResult FromBuiltin [] (TypeOfUncovered ty) []--{--%************************************************************************-%*                                                                      *-       Entry points to the checker: checkSingle and checkMatches-%*                                                                      *-%************************************************************************--}---- | Check a single pattern binding (let)-checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat Id -> DsM ()-checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do-  tracePmD "checkSingle" (vcat [ppr ctxt, ppr var, ppr p])-  mb_pm_res <- tryM (getResult (checkSingle' locn var p))-  case mb_pm_res of-    Left  _   -> warnPmIters dflags ctxt-    Right res -> dsPmWarn dflags ctxt res---- | Check a single pattern binding (let)-checkSingle' :: SrcSpan -> Id -> Pat Id -> PmM PmResult-checkSingle' locn var p = do-  liftD resetPmIterDs -- set the iter-no to zero-  fam_insts <- liftD dsGetFamInstEnvs-  clause    <- liftD $ translatePat fam_insts p-  missing   <- mkInitialUncovered [var]-  tracePm "checkSingle: missing" (vcat (map pprValVecDebug missing))-                                 -- no guards-  PartialResult prov cs us ds <- runMany (pmcheckI clause []) missing-  let us' = UncoveredPatterns us-  return $ case (cs,ds) of-    (Covered,  _    )         -> PmResult prov [] us' [] -- useful-    (NotCovered, NotDiverged) -> PmResult prov m  us' [] -- redundant-    (NotCovered, Diverged )   -> PmResult prov [] us' m  -- inaccessible rhs-  where m = [L locn [L locn p]]---- | Check a matchgroup (case, functions, etc.)-checkMatches :: DynFlags -> DsMatchContext-             -> [Id] -> [LMatch Id (LHsExpr Id)] -> DsM ()-checkMatches dflags ctxt vars matches = do-  tracePmD "checkMatches" (hang (vcat [ppr ctxt-                               , ppr vars-                               , text "Matches:"])-                               2-                               (vcat (map ppr matches)))-  mb_pm_res <- tryM $ getResult $ case matches of-    -- Check EmptyCase separately-    -- See Note [Checking EmptyCase Expressions]-    [] | [var] <- vars -> checkEmptyCase' var-    _normal_match      -> checkMatches' vars matches-  case mb_pm_res of-    Left  _   -> warnPmIters dflags ctxt-    Right res -> dsPmWarn dflags ctxt res---- | Check a matchgroup (case, functions, etc.). To be called on a non-empty--- list of matches. For empty case expressions, use checkEmptyCase' instead.-checkMatches' :: [Id] -> [LMatch Id (LHsExpr Id)] -> PmM PmResult-checkMatches' vars matches-  | null matches = panic "checkMatches': EmptyCase"-  | otherwise = do-      liftD resetPmIterDs -- set the iter-no to zero-      missing    <- mkInitialUncovered vars-      tracePm "checkMatches: missing" (vcat (map pprValVecDebug missing))-      (prov, rs,us,ds) <- go matches missing-      return $ PmResult {-                   pmresultProvenance   = prov-                 , pmresultRedundant    = map hsLMatchToLPats rs-                 , pmresultUncovered    = UncoveredPatterns us-                 , pmresultInaccessible = map hsLMatchToLPats ds }-  where-    go :: [LMatch Id (LHsExpr Id)] -> Uncovered-       -> PmM (Provenance-              , [LMatch Id (LHsExpr Id)]-              , Uncovered-              , [LMatch Id (LHsExpr Id)])-    go []     missing = return (mempty, [], missing, [])-    go (m:ms) missing = do-      tracePm "checMatches': go" (ppr m $$ ppr missing)-      fam_insts          <- liftD dsGetFamInstEnvs-      (clause, guards)   <- liftD $ translateMatch fam_insts m-      r@(PartialResult prov cs missing' ds)-        <- runMany (pmcheckI clause guards) missing-      tracePm "checMatches': go: res" (ppr r)-      (ms_prov, rs, final_u, is)  <- go ms missing'-      let final_prov = prov `mappend` ms_prov-      return $ case (cs, ds) of-        -- useful-        (Covered,  _    )        -> (final_prov,  rs, final_u,   is)-        -- redundant-        (NotCovered, NotDiverged) -> (final_prov, m:rs, final_u,is)-        -- inaccessible-        (NotCovered, Diverged )   -> (final_prov,  rs, final_u, m:is)--    hsLMatchToLPats :: LMatch id body -> Located [LPat id]-    hsLMatchToLPats (L l (Match _ pats _ _)) = L l pats---- | Check an empty case expression. Since there are no clauses to process, we---   only compute the uncovered set. See Note [Checking EmptyCase Expressions]---   for details.-checkEmptyCase' :: Id -> PmM PmResult-checkEmptyCase' var = do-  tm_css <- map toComplex . bagToList <$> liftD getTmCsDs-  case tmOracle initialTmState tm_css of-    Just tm_state -> do-      ty_css        <- liftD getDictsDs-      fam_insts     <- liftD dsGetFamInstEnvs-      mb_candidates <- inhabitationCandidates fam_insts (idType var)-      case mb_candidates of-        -- Inhabitation checking failed / the type is trivially inhabited-        Left ty -> return (uncoveredWithTy ty)--        -- A list of inhabitant candidates is available: Check for each-        -- one for the satisfiability of the constraints it gives rise to.-        Right candidates -> do-          missing_m <- flip concatMapM candidates $ \(va,tm_ct,ty_cs) -> do-            let all_ty_cs = unionBags ty_cs ty_css-            sat_ty <- tyOracle all_ty_cs-            return $ case (sat_ty, tmOracle tm_state (tm_ct:tm_css)) of-              (True, Just tm_state') -> [(va, all_ty_cs, tm_state')]-              _non_sat               -> []-          let mkValVec (va,all_ty_cs,tm_state')-                = ValVec [va] (MkDelta all_ty_cs tm_state')-              uncovered = UncoveredPatterns (map mkValVec missing_m)-          return $ if null missing_m-            then emptyPmResult-            else PmResult FromBuiltin [] uncovered []-    Nothing -> return emptyPmResult---- | Generate all inhabitation candidates for a given type. The result is--- either (Left ty), if the type cannot be reduced to a closed algebraic type--- (or if it's one trivially inhabited, like Int), or (Right candidates), if it--- can. In this case, the candidates are the singnature of the tycon, each one--- accompanied by the term- and type- constraints it gives rise to.--- See also Note [Checking EmptyCase Expressions]-inhabitationCandidates :: FamInstEnvs -> Type-                       -> PmM (Either Type [(ValAbs, ComplexEq, Bag EvVar)])-inhabitationCandidates fam_insts ty-  = case pmTopNormaliseType_maybe fam_insts ty of-      Just (src_ty, dcs, core_ty) -> alts_to_check src_ty core_ty dcs-      Nothing                     -> alts_to_check ty     ty      []-  where-    -- All these types are trivially inhabited-    trivially_inhabited = [ charTyCon, doubleTyCon, floatTyCon-                          , intTyCon, wordTyCon, word8TyCon ]--    -- Note: At the moment we leave all the typing and constraint fields of-    -- PmCon empty, since we know that they are not gonna be used. Is the-    -- right-thing-to-do to actually create them, even if they are never used?-    build_tm :: ValAbs -> [DataCon] -> ValAbs-    build_tm = foldr (\dc e -> PmCon (RealDataCon dc) [] [] [] [e])--    -- Inhabitation candidates, using the result of pmTopNormaliseType_maybe-    alts_to_check :: Type -> Type -> [DataCon]-                  -> PmM (Either Type [(ValAbs, ComplexEq, Bag EvVar)])-    alts_to_check src_ty core_ty dcs = case splitTyConApp_maybe core_ty of-      Just (tc, _)-        | tc `elem` trivially_inhabited -> case dcs of-            []    -> return (Left src_ty)-            (_:_) -> do var <- liftD $ mkPmId (toTcType core_ty)-                        let va = build_tm (PmVar var) dcs-                        return $ Right [(va, mkIdEq var, emptyBag)]-        | isClosedAlgType core_ty -> liftD $ do-            var  <- mkPmId (toTcType core_ty) -- it would be wrong to unify x-            alts <- mapM (mkOneConFull var . RealDataCon) (tyConDataCons tc)-            return $ Right [(build_tm va dcs, eq, cs) | (va, eq, cs) <- alts]-      -- For other types conservatively assume that they are inhabited.-      _other -> return (Left src_ty)--{- Note [Checking EmptyCase Expressions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Empty case expressions are strict on the scrutinee. That is, `case x of {}`-will force argument `x`. Hence, `checkMatches` is not sufficient for checking-empty cases, because it assumes that the match is not strict (which is true-for all other cases, apart from EmptyCase). This gave rise to #10746. Instead,-we do the following:--1. We normalise the outermost type family redex, data family redex or newtype,-   using pmTopNormaliseType_maybe (in types/FamInstEnv.hs). This computes 3-   things:-   (a) A normalised type src_ty, which is equal to the type of the scrutinee in-       source Haskell (does not normalise newtypes or data families)-   (b) The actual normalised type core_ty, which coincides with the result-       topNormaliseType_maybe. This type is not necessarily equal to the input-       type in source Haskell. And this is precicely the reason we compute (a)-       and (c): the reasoning happens with the underlying types, but both the-       patterns and types we print should respect newtypes and also show the-       family type constructors and not the representation constructors.--   (c) A list of all newtype data constructors dcs, each one corresponding to a-       newtype rewrite performed in (b).--   For an example see also Note [Type normalisation for EmptyCase]-   in types/FamInstEnv.hs.--2. Function checkEmptyCase' performs the check:-   - If core_ty is not an algebraic type, then we cannot check for-     inhabitation, so we emit (_ :: src_ty) as missing, conservatively assuming-     that the type is inhabited.-   - If core_ty is an algebraic type, then we unfold the scrutinee to all-     possible constructor patterns, using inhabitationCandidates, and then-     check each one for constraint satisfiability, same as we for normal-     pattern match checking.--%************************************************************************-%*                                                                      *-              Transform source syntax to *our* syntax-%*                                                                      *-%************************************************************************--}---- -------------------------------------------------------------------------- * Utilities--nullaryConPattern :: ConLike -> Pattern--- Nullary data constructor and nullary type constructor-nullaryConPattern con =-  PmCon { pm_con_con = con, pm_con_arg_tys = []-        , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = [] }-{-# INLINE nullaryConPattern #-}--truePattern :: Pattern-truePattern = nullaryConPattern (RealDataCon trueDataCon)-{-# INLINE truePattern #-}---- | A fake guard pattern (True <- _) used to represent cases we cannot handle-fake_pat :: Pattern-fake_pat = PmGrd { pm_grd_pv   = [truePattern]-                 , pm_grd_expr = PmExprOther EWildPat }-{-# INLINE fake_pat #-}---- | Check whether a guard pattern is generated by the checker (unhandled)-isFakeGuard :: [Pattern] -> PmExpr -> Bool-isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther EWildPat)-  | c == trueDataCon = True-  | otherwise        = False-isFakeGuard _pats _e = False---- | Generate a `canFail` pattern vector of a specific type-mkCanFailPmPat :: Type -> DsM PatVec-mkCanFailPmPat ty = do-  var <- mkPmVar ty-  return [var, fake_pat]--vanillaConPattern :: ConLike -> [Type] -> PatVec -> Pattern--- ADT constructor pattern => no existentials, no local constraints-vanillaConPattern con arg_tys args =-  PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys-        , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = args }-{-# INLINE vanillaConPattern #-}---- | Create an empty list pattern of a given type-nilPattern :: Type -> Pattern-nilPattern ty =-  PmCon { pm_con_con = RealDataCon nilDataCon, pm_con_arg_tys = [ty]-        , pm_con_tvs = [], pm_con_dicts = []-        , pm_con_args = [] }-{-# INLINE nilPattern #-}--mkListPatVec :: Type -> PatVec -> PatVec -> PatVec-mkListPatVec ty xs ys = [PmCon { pm_con_con = RealDataCon consDataCon-                               , pm_con_arg_tys = [ty]-                               , pm_con_tvs = [], pm_con_dicts = []-                               , pm_con_args = xs++ys }]-{-# INLINE mkListPatVec #-}---- | Create a (non-overloaded) literal pattern-mkLitPattern :: HsLit -> Pattern-mkLitPattern lit = PmLit { pm_lit_lit = PmSLit lit }-{-# INLINE mkLitPattern #-}---- -------------------------------------------------------------------------- * Transform (Pat Id) into of (PmPat Id)--translatePat :: FamInstEnvs -> Pat Id -> DsM PatVec-translatePat fam_insts pat = case pat of-  WildPat ty  -> mkPmVars [ty]-  VarPat  id  -> return [PmVar (unLoc id)]-  ParPat p    -> translatePat fam_insts (unLoc p)-  LazyPat _   -> mkPmVars [hsPatType pat] -- like a variable--  -- ignore strictness annotations for now-  BangPat p   -> translatePat fam_insts (unLoc p)--  AsPat lid p -> do-     -- Note [Translating As Patterns]-    ps <- translatePat fam_insts (unLoc p)-    let [e] = map vaToPmExpr (coercePatVec ps)-        g   = PmGrd [PmVar (unLoc lid)] e-    return (ps ++ [g])--  SigPatOut p _ty -> translatePat fam_insts (unLoc p)--  -- See Note [Translate CoPats]-  CoPat wrapper p ty-    | isIdHsWrapper wrapper                   -> translatePat fam_insts p-    | WpCast co <-  wrapper, isReflexiveCo co -> translatePat fam_insts p-    | otherwise -> do-        ps      <- translatePat fam_insts p-        (xp,xe) <- mkPmId2Forms ty-        let g = mkGuard ps (HsWrap wrapper (unLoc xe))-        return [xp,g]--  -- (n + k)  ===>   x (True <- x >= k) (n <- x-k)-  NPlusKPat (L _ _n) _k1 _k2 _ge _minus ty -> mkCanFailPmPat ty--  -- (fun -> pat)   ===>   x (pat <- fun x)-  ViewPat lexpr lpat arg_ty -> do-    ps <- translatePat fam_insts (unLoc lpat)-    -- See Note [Guards and Approximation]-    case all cantFailPattern ps of-      True  -> do-        (xp,xe) <- mkPmId2Forms arg_ty-        let g = mkGuard ps (HsApp lexpr xe)-        return [xp,g]-      False -> mkCanFailPmPat arg_ty--  -- list-  ListPat ps ty Nothing -> do-    foldr (mkListPatVec ty) [nilPattern ty]-      <$> translatePatVec fam_insts (map unLoc ps)--  -- overloaded list-  ListPat lpats elem_ty (Just (pat_ty, _to_list))-    | Just e_ty <- splitListTyConApp_maybe pat_ty-    , (_, norm_elem_ty) <- normaliseType fam_insts Nominal elem_ty-         -- elem_ty is frequently something like-         -- `Item [Int]`, but we prefer `Int`-    , norm_elem_ty `eqType` e_ty ->-        -- We have to ensure that the element types are exactly the same.-        -- Otherwise, one may give an instance IsList [Int] (more specific than-        -- the default IsList [a]) with a different implementation for `toList'-        translatePat fam_insts (ListPat lpats e_ty Nothing)-      -- See Note [Guards and Approximation]-    | otherwise -> mkCanFailPmPat pat_ty--  ConPatOut { pat_con     = L _ con-            , pat_arg_tys = arg_tys-            , pat_tvs     = ex_tvs-            , pat_dicts   = dicts-            , pat_args    = ps } -> do-    groups <- allCompleteMatches con arg_tys-    case groups of-      [] -> mkCanFailPmPat (conLikeResTy con arg_tys)-      _  -> do-        args <- translateConPatVec fam_insts arg_tys ex_tvs con ps-        return [PmCon { pm_con_con     = con-                      , pm_con_arg_tys = arg_tys-                      , pm_con_tvs     = ex_tvs-                      , pm_con_dicts   = dicts-                      , pm_con_args    = args }]--  NPat (L _ ol) mb_neg _eq ty -> translateNPat fam_insts ol mb_neg ty--  LitPat lit-      -- If it is a string then convert it to a list of characters-    | HsString src s <- lit ->-        foldr (mkListPatVec charTy) [nilPattern charTy] <$>-          translatePatVec fam_insts (map (LitPat . HsChar src) (unpackFS s))-    | otherwise -> return [mkLitPattern lit]--  PArrPat ps ty -> do-    tidy_ps <- translatePatVec fam_insts (map unLoc ps)-    let fake_con = RealDataCon (parrFakeCon (length ps))-    return [vanillaConPattern fake_con [ty] (concat tidy_ps)]--  TuplePat ps boxity tys -> do-    tidy_ps <- translatePatVec fam_insts (map unLoc ps)-    let tuple_con = RealDataCon (tupleDataCon boxity (length ps))-    return [vanillaConPattern tuple_con tys (concat tidy_ps)]--  SumPat p alt arity ty -> do-    tidy_p <- translatePat fam_insts (unLoc p)-    let sum_con = RealDataCon (sumDataCon alt arity)-    return [vanillaConPattern sum_con ty tidy_p]--  -- ---------------------------------------------------------------------------  -- Not supposed to happen-  ConPatIn  {} -> panic "Check.translatePat: ConPatIn"-  SplicePat {} -> panic "Check.translatePat: SplicePat"-  SigPatIn  {} -> panic "Check.translatePat: SigPatIn"---- | Translate an overloaded literal (see `tidyNPat' in deSugar/MatchLit.hs)-translateNPat :: FamInstEnvs-              -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> Type -> DsM PatVec-translateNPat fam_insts (OverLit val False _ ty) mb_neg outer_ty-  | not type_change, isStringTy ty, HsIsString src s <- val, Nothing <- mb_neg-  = translatePat fam_insts (LitPat (HsString src s))-  | not type_change, isIntTy    ty, HsIntegral src i <- val-  = translatePat fam_insts (mk_num_lit HsInt src i)-  | not type_change, isWordTy   ty, HsIntegral src i <- val-  = translatePat fam_insts (mk_num_lit HsWordPrim src i)-  where-    type_change = not (outer_ty `eqType` ty)-    mk_num_lit c src i = LitPat $ case mb_neg of-      Nothing -> c src i-      Just _  -> c src (-i)-translateNPat _ ol mb_neg _-  = return [PmLit { pm_lit_lit = PmOLit (isJust mb_neg) ol }]---- | Translate a list of patterns (Note: each pattern is translated--- to a pattern vector but we do not concatenate the results).-translatePatVec :: FamInstEnvs -> [Pat Id] -> DsM [PatVec]-translatePatVec fam_insts pats = mapM (translatePat fam_insts) pats---- | Translate a constructor pattern-translateConPatVec :: FamInstEnvs -> [Type] -> [TyVar]-                   -> ConLike -> HsConPatDetails Id -> DsM PatVec-translateConPatVec fam_insts _univ_tys _ex_tvs _ (PrefixCon ps)-  = concat <$> translatePatVec fam_insts (map unLoc ps)-translateConPatVec fam_insts _univ_tys _ex_tvs _ (InfixCon p1 p2)-  = concat <$> translatePatVec fam_insts (map unLoc [p1,p2])-translateConPatVec fam_insts  univ_tys  ex_tvs c (RecCon (HsRecFields fs _))-    -- Nothing matched. Make up some fresh term variables-  | null fs        = mkPmVars arg_tys-    -- The data constructor was not defined using record syntax. For the-    -- pattern to be in record syntax it should be empty (e.g. Just {}).-    -- So just like the previous case.-  | null orig_lbls = mkPmVars arg_tys-    -- Some of the fields appear, in the original order (there may be holes).-    -- Generate a simple constructor pattern and make up fresh variables for-    -- the rest of the fields-  | matched_lbls `subsetOf` orig_lbls-  =   let translateOne (lbl, ty) = case lookup lbl matched_pats of-            Just p  -> translatePat fam_insts p-            Nothing -> mkPmVars [ty]-      in  concatMapM translateOne (zip orig_lbls arg_tys)-    -- The fields that appear are not in the correct order. Make up fresh-    -- variables for all fields and add guards after matching, to force the-    -- evaluation in the correct order.-  | otherwise = do-      arg_var_pats    <- mkPmVars arg_tys-      translated_pats <- forM matched_pats $ \(x,pat) -> do-        pvec <- translatePat fam_insts pat-        return (x, pvec)--      let zipped = zip orig_lbls [ x | PmVar x <- arg_var_pats ]-          guards = map (\(name,pvec) -> case lookup name zipped of-                            Just x  -> PmGrd pvec (PmExprVar (idName x))-                            Nothing -> panic "translateConPatVec: lookup")-                       translated_pats--      return (arg_var_pats ++ guards)-  where-    -- The actual argument types (instantiated)-    arg_tys = conLikeInstOrigArgTys c (univ_tys ++ mkTyVarTys ex_tvs)--    -- Some label information-    orig_lbls    = map flSelector $ conLikeFieldLabels c-    matched_pats = [ (getName (unLoc (hsRecFieldId x)), unLoc (hsRecFieldArg x))-                   | L _ x <- fs]-    matched_lbls = [ name | (name, _pat) <- matched_pats ]--    subsetOf :: Eq a => [a] -> [a] -> Bool-    subsetOf []     _  = True-    subsetOf (_:_)  [] = False-    subsetOf (x:xs) (y:ys)-      | x == y    = subsetOf    xs  ys-      | otherwise = subsetOf (x:xs) ys---- Translate a single match-translateMatch :: FamInstEnvs -> LMatch Id (LHsExpr Id) -> DsM (PatVec,[PatVec])-translateMatch fam_insts (L _ (Match _ lpats _ grhss)) = do-  pats'   <- concat <$> translatePatVec fam_insts pats-  guards' <- mapM (translateGuards fam_insts) guards-  return (pats', guards')-  where-    extractGuards :: LGRHS Id (LHsExpr Id) -> [GuardStmt Id]-    extractGuards (L _ (GRHS gs _)) = map unLoc gs--    pats   = map unLoc lpats-    guards = map extractGuards (grhssGRHSs grhss)---- -------------------------------------------------------------------------- * Transform source guards (GuardStmt Id) to PmPats (Pattern)---- | Translate a list of guard statements to a pattern vector-translateGuards :: FamInstEnvs -> [GuardStmt Id] -> DsM PatVec-translateGuards fam_insts guards = do-  all_guards <- concat <$> mapM (translateGuard fam_insts) guards-  return (replace_unhandled all_guards)-  -- It should have been (return all_guards) but it is too expressive.-  -- Since the term oracle does not handle all constraints we generate,-  -- we (hackily) replace all constraints the oracle cannot handle with a-  -- single one (we need to know if there is a possibility of falure).-  -- See Note [Guards and Approximation] for all guard-related approximations-  -- we implement.-  where-    replace_unhandled :: PatVec -> PatVec-    replace_unhandled gv-      | any_unhandled gv = fake_pat : [ p | p <- gv, shouldKeep p ]-      | otherwise        = gv--    any_unhandled :: PatVec -> Bool-    any_unhandled gv = any (not . shouldKeep) gv--    shouldKeep :: Pattern -> Bool-    shouldKeep p-      | PmVar {} <- p      = True-      | PmCon {} <- p      = singleConstructor (pm_con_con p)-                             && all shouldKeep (pm_con_args p)-    shouldKeep (PmGrd pv e)-      | all shouldKeep pv  = True-      | isNotPmExprOther e = True  -- expensive but we want it-    shouldKeep _other_pat  = False -- let the rest..---- | Check whether a pattern can fail to match-cantFailPattern :: Pattern -> Bool-cantFailPattern p-  | PmVar {} <- p = True-  | PmCon {} <- p = singleConstructor (pm_con_con p)-                    && all cantFailPattern (pm_con_args p)-cantFailPattern (PmGrd pv _e)-                  = all cantFailPattern pv-cantFailPattern _ = False---- | Translate a guard statement to Pattern-translateGuard :: FamInstEnvs -> GuardStmt Id -> DsM PatVec-translateGuard fam_insts guard = case guard of-  BodyStmt   e _ _ _ -> translateBoolGuard e-  LetStmt      binds -> translateLet (unLoc binds)-  BindStmt p e _ _ _ -> translateBind fam_insts p e-  LastStmt        {} -> panic "translateGuard LastStmt"-  ParStmt         {} -> panic "translateGuard ParStmt"-  TransStmt       {} -> panic "translateGuard TransStmt"-  RecStmt         {} -> panic "translateGuard RecStmt"-  ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt"---- | Translate let-bindings-translateLet :: HsLocalBinds Id -> DsM PatVec-translateLet _binds = return []---- | Translate a pattern guard-translateBind :: FamInstEnvs -> LPat Id -> LHsExpr Id -> DsM PatVec-translateBind fam_insts (L _ p) e = do-  ps <- translatePat fam_insts p-  return [mkGuard ps (unLoc e)]---- | Translate a boolean guard-translateBoolGuard :: LHsExpr Id -> DsM PatVec-translateBoolGuard e-  | isJust (isTrueLHsExpr e) = return []-    -- The formal thing to do would be to generate (True <- True)-    -- but it is trivial to solve so instead we give back an empty-    -- PatVec for efficiency-  | otherwise = return [mkGuard [truePattern] (unLoc e)]--{- Note [Guards and Approximation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Even if the algorithm is really expressive, the term oracle we use is not.-Hence, several features are not translated *properly* but we approximate.-The list includes:--1. View Patterns------------------A view pattern @(f -> p)@ should be translated to @x (p <- f x)@. The term-oracle does not handle function applications so we know that the generated-constraints will not be handled at the end. Hence, we distinguish between two-cases:-  a) Pattern @p@ cannot fail. Then this is just a binding and we do the *right-     thing*.-  b) Pattern @p@ can fail. This means that when checking the guard, we will-     generate several cases, with no useful information. E.g.:--       h (f -> [a,b]) = ...-       h x ([a,b] <- f x) = ...--       uncovered set = { [x |> { False ~ (f x ~ [])            }]-                       , [x |> { False ~ (f x ~ (t1:[]))       }]-                       , [x |> { False ~ (f x ~ (t1:t2:t3:t4)) }] }--     So we have two problems:-       1) Since we do not print the constraints in the general case (they may-          be too many), the warning will look like this:--            Pattern match(es) are non-exhaustive-            In an equation for `h':-                Patterns not matched:-                    _-                    _-                    _-          Which is not short and not more useful than a single underscore.-       2) The size of the uncovered set increases a lot, without gaining more-          expressivity in our warnings.--     Hence, in this case, we replace the guard @([a,b] <- f x)@ with a *dummy*-     @fake_pat@: @True <- _@. That is, we record that there is a possibility-     of failure but we minimize it to a True/False. This generates a single-     warning and much smaller uncovered sets.--2. Overloaded Lists---------------------An overloaded list @[...]@ should be translated to @x ([...] <- toList x)@. The-problem is exactly like above, as its solution. For future reference, the code-below is the *right thing to do*:--   ListPat lpats elem_ty (Just (pat_ty, to_list))-     otherwise -> do-       (xp, xe) <- mkPmId2Forms pat_ty-       ps       <- translatePatVec (map unLoc lpats)-       let pats = foldr (mkListPatVec elem_ty) [nilPattern elem_ty] ps-           g    = mkGuard pats (HsApp (noLoc to_list) xe)-       return [xp,g]--3. Overloaded Literals------------------------The case with literals is a bit different. a literal @l@ should be translated-to @x (True <- x == from l)@. Since we want to have better warnings for-overloaded literals as it is a very common feature, we treat them differently.-They are mainly covered in Note [Undecidable Equality on Overloaded Literals]-in PmExpr.--4. N+K Patterns & Pattern Synonyms-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-An n+k pattern (n+k) should be translated to @x (True <- x >= k) (n <- x-k)@.-Since the only pattern of the three that causes failure is guard @(n <- x-k)@,-and has two possible outcomes. Hence, there is no benefit in using a dummy and-we implement the proper thing. Pattern synonyms are simply not implemented yet.-Hence, to be conservative, we generate a dummy pattern, assuming that the-pattern can fail.--5. Actual Guards------------------During translation, boolean guards and pattern guards are translated properly.-Let bindings though are omitted by function @translateLet@. Since they are lazy-bindings, we do not actually want to generate a (strict) equality (like we do-in the pattern bind case). Hence, we safely drop them.--Additionally, top-level guard translation (performed by @translateGuards@)-replaces guards that cannot be reasoned about (like the ones we described in-1-4) with a single @fake_pat@ to record the possibility of failure to match.--Note [Translate CoPats]-~~~~~~~~~~~~~~~~~~~~~~~-The pattern match checker did not know how to handle coerced patterns `CoPat`-efficiently, which gave rise to #11276. The original approach translated-`CoPat`s:--    pat |> co    ===>    x (pat <- (e |> co))--Instead, we now check whether the coercion is a hole or if it is just refl, in-which case we can drop it. Unfortunately, data families generate useful-coercions so guards are still generated in these cases and checking data-families is not really efficient.--%************************************************************************-%*                                                                      *-                 Utilities for Pattern Match Checking-%*                                                                      *-%************************************************************************--}---- ------------------------------------------------------------------------------- * Basic utilities---- | Get the type out of a PmPat. For guard patterns (ps <- e) we use the type--- of the first (or the single -WHEREVER IT IS- valid to use?) pattern-pmPatType :: PmPat p -> Type-pmPatType (PmCon { pm_con_con = con, pm_con_arg_tys = tys })-  = conLikeResTy con tys-pmPatType (PmVar  { pm_var_id  = x }) = idType x-pmPatType (PmLit  { pm_lit_lit = l }) = pmLitType l-pmPatType (PmNLit { pm_lit_id  = x }) = idType x-pmPatType (PmGrd  { pm_grd_pv  = pv })-  = (pmPatType p)-  where Just p = find ((==1) . patternArity) pv---- | Generate a value abstraction for a given constructor (generate--- fresh variables of the appropriate type for arguments)-mkOneConFull :: Id -> ConLike -> DsM (ValAbs, ComplexEq, Bag EvVar)---  *  x :: T tys, where T is an algebraic data type---     NB: in the case of a data family, T is the *representation* TyCon---     e.g.   data instance T (a,b) = T1 a b---       leads to---            data TPair a b = T1 a b  -- The "representation" type---       It is TPair, not T, that is given to mkOneConFull------  * 'con' K is a constructor of data type T------ After instantiating the universal tyvars of K we get---          K tys :: forall bs. Q => s1 .. sn -> T tys------ Results: ValAbs:          K (y1::s1) .. (yn::sn)---          ComplexEq:       x ~ K y1..yn---          [EvVar]:         Q-mkOneConFull x con = do-  let -- res_ty == TyConApp (ConLikeTyCon cabs_con) cabs_arg_tys-      res_ty  = idType x-      (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta , arg_tys, _)-        = conLikeFullSig con-      tc_args = case splitTyConApp_maybe res_ty of-                  Just (_, tys) -> tys-                  Nothing -> pprPanic "mkOneConFull: Not TyConApp:" (ppr res_ty)-      subst1  = zipTvSubst univ_tvs tc_args--  (subst, ex_tvs') <- cloneTyVarBndrs subst1 ex_tvs <$> getUniqueSupplyM--  -- Fresh term variables (VAs) as arguments to the constructor-  arguments <-  mapM mkPmVar (substTys subst arg_tys)-  -- All constraints bound by the constructor (alpha-renamed)-  let theta_cs = substTheta subst (eqSpecPreds eq_spec ++ thetas)-  evvars <- mapM (nameType "pm") theta_cs-  let con_abs  = PmCon { pm_con_con     = con-                       , pm_con_arg_tys = tc_args-                       , pm_con_tvs     = ex_tvs'-                       , pm_con_dicts   = evvars-                       , pm_con_args    = arguments }-  return (con_abs, (PmExprVar (idName x), vaToPmExpr con_abs), listToBag evvars)---- ------------------------------------------------------------------------------- * More smart constructors and fresh variable generation---- | Create a guard pattern-mkGuard :: PatVec -> HsExpr Id -> Pattern-mkGuard pv e-  | all cantFailPattern pv = PmGrd pv expr-  | PmExprOther {} <- expr = fake_pat-  | otherwise              = PmGrd pv expr-  where-    expr = hsExprToPmExpr e---- | Create a term equality of the form: `(False ~ (x ~ lit))`-mkNegEq :: Id -> PmLit -> ComplexEq-mkNegEq x l = (falsePmExpr, PmExprVar (idName x) `PmExprEq` PmExprLit l)-{-# INLINE mkNegEq #-}---- | Create a term equality of the form: `(x ~ lit)`-mkPosEq :: Id -> PmLit -> ComplexEq-mkPosEq x l = (PmExprVar (idName x), PmExprLit l)-{-# INLINE mkPosEq #-}---- | Create a term equality of the form: `(x ~ x)`--- (always discharged by the term oracle)-mkIdEq :: Id -> ComplexEq-mkIdEq x = (PmExprVar name, PmExprVar name)-  where name = idName x-{-# INLINE mkIdEq #-}---- | Generate a variable pattern of a given type-mkPmVar :: Type -> DsM (PmPat p)-mkPmVar ty = PmVar <$> mkPmId ty-{-# INLINE mkPmVar #-}---- | Generate many variable patterns, given a list of types-mkPmVars :: [Type] -> DsM PatVec-mkPmVars tys = mapM mkPmVar tys-{-# INLINE mkPmVars #-}---- | Generate a fresh `Id` of a given type-mkPmId :: Type -> DsM Id-mkPmId ty = getUniqueM >>= \unique ->-  let occname = mkVarOccFS (fsLit (show unique))-      name    = mkInternalName unique occname noSrcSpan-  in  return (mkLocalId name ty)---- | Generate a fresh term variable of a given and return it in two forms:--- * A variable pattern--- * A variable expression-mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr Id)-mkPmId2Forms ty = do-  x <- mkPmId ty-  return (PmVar x, noLoc (HsVar (noLoc x)))---- ------------------------------------------------------------------------------- * Converting between Value Abstractions, Patterns and PmExpr---- | Convert a value abstraction an expression-vaToPmExpr :: ValAbs -> PmExpr-vaToPmExpr (PmCon  { pm_con_con = c, pm_con_args = ps })-  = PmExprCon c (map vaToPmExpr ps)-vaToPmExpr (PmVar  { pm_var_id  = x }) = PmExprVar (idName x)-vaToPmExpr (PmLit  { pm_lit_lit = l }) = PmExprLit l-vaToPmExpr (PmNLit { pm_lit_id  = x }) = PmExprVar (idName x)---- | Convert a pattern vector to a list of value abstractions by dropping the--- guards (See Note [Translating As Patterns])-coercePatVec :: PatVec -> [ValAbs]-coercePatVec pv = concatMap coercePmPat pv---- | Convert a pattern to a list of value abstractions (will be either an empty--- list if the pattern is a guard pattern, or a singleton list in all other--- cases) by dropping the guards (See Note [Translating As Patterns])-coercePmPat :: Pattern -> [ValAbs]-coercePmPat (PmVar { pm_var_id  = x }) = [PmVar { pm_var_id  = x }]-coercePmPat (PmLit { pm_lit_lit = l }) = [PmLit { pm_lit_lit = l }]-coercePmPat (PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys-                   , pm_con_tvs = tvs, pm_con_dicts = dicts-                   , pm_con_args = args })-  = [PmCon { pm_con_con  = con, pm_con_arg_tys = arg_tys-           , pm_con_tvs  = tvs, pm_con_dicts = dicts-           , pm_con_args = coercePatVec args }]-coercePmPat (PmGrd {}) = [] -- drop the guards---- | Check whether a data constructor is the only way to construct--- a data type.-singleConstructor :: ConLike -> Bool-singleConstructor (RealDataCon dc) =-  case tyConDataCons (dataConTyCon dc) of-    [_] -> True-    _   -> False-singleConstructor _ = False---- | For a given conlike, finds all the sets of patterns which could--- be relevant to that conlike by consulting the result type.------ These come from two places.---  1. From data constructors defined with the result type constructor.---  2. From `COMPLETE` pragmas which have the same type as the result---     type constructor.-allCompleteMatches :: ConLike -> [Type] -> DsM [(Provenance, [ConLike])]-allCompleteMatches cl tys = do-  let fam = case cl of-           RealDataCon dc ->-            [(FromBuiltin, map RealDataCon (tyConDataCons (dataConTyCon dc)))]-           PatSynCon _    -> []--  pragmas <- case splitTyConApp_maybe (conLikeResTy cl tys) of-              Just (tc, _) -> dsGetCompleteMatches tc-              Nothing -> return []-  let fams cm = fmap (FromComplete,) $-                mapM dsLookupConLike (completeMatchConLikes cm)-  from_pragma <- mapM fams pragmas--  let final_groups = fam ++ from_pragma-  tracePmD "allCompleteMatches" (ppr final_groups)-  return final_groups---- -------------------------------------------------------------------------- * Types and constraints--newEvVar :: Name -> Type -> EvVar-newEvVar name ty = mkLocalId name (toTcType ty)--nameType :: String -> Type -> DsM EvVar-nameType name ty = do-  unique <- getUniqueM-  let occname = mkVarOccFS (fsLit (name++"_"++show unique))-      idname  = mkInternalName unique occname noSrcSpan-  return (newEvVar idname ty)--{--%************************************************************************-%*                                                                      *-                              The type oracle-%*                                                                      *-%************************************************************************--}---- | Check whether a set of type constraints is satisfiable.-tyOracle :: Bag EvVar -> PmM Bool-tyOracle evs-  = liftD $-    do { ((_warns, errs), res) <- initTcDsForSolver $ tcCheckSatisfiability evs-       ; case res of-            Just sat -> return sat-            Nothing  -> pprPanic "tyOracle" (vcat $ pprErrMsgBagWithLoc errs) }--{--%************************************************************************-%*                                                                      *-                             Sanity Checks-%*                                                                      *-%************************************************************************--}---- | The arity of a pattern/pattern vector is the--- number of top-level patterns that are not guards-type PmArity = Int---- | Compute the arity of a pattern vector--- patVecArity :: PatVec -> PmArity--- patVecArity = sum . map patternArity---- | Compute the arity of a pattern-patternArity :: Pattern -> PmArity-patternArity (PmGrd {}) = 0-patternArity _other_pat = 1--{--%************************************************************************-%*                                                                      *-            Heart of the algorithm: Function pmcheck-%*                                                                      *-%************************************************************************--Main functions are:--* mkInitialUncovered :: [Id] -> PmM Uncovered--  Generates the initial uncovered set. Term and type constraints in scope-  are checked, if they are inconsistent, the set is empty, otherwise, the-  set contains only a vector of variables with the constraints in scope.--* pmcheck :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult--  Checks redundancy, coverage and inaccessibility, using auxilary functions-  `pmcheckGuards` and `pmcheckHd`. Mainly handles the guard case which is-  common in all three checks (see paper) and calls `pmcheckGuards` when the-  whole clause is checked, or `pmcheckHd` when the pattern vector does not-  start with a guard.--* pmcheckGuards :: [PatVec] -> ValVec -> PmM PartialResult--  Processes the guards.--* pmcheckHd :: Pattern -> PatVec -> [PatVec]-          -> ValAbs -> ValVec -> PmM PartialResult--  Worker: This function implements functions `covered`, `uncovered` and-  `divergent` from the paper at once. Slightly different from the paper because-  it does not even produce the covered and uncovered sets. Since we only care-  about whether a clause covers SOMETHING or if it may forces ANY argument, we-  only store a boolean in both cases, for efficiency.--}---- | Lift a pattern matching action from a single value vector abstration to a--- value set abstraction, but calling it on every vector and the combining the--- results.-runMany :: (ValVec -> PmM PartialResult) -> (Uncovered -> PmM PartialResult)-runMany _ [] = return mempty-runMany pm (m:ms) = mappend <$> pm m <*> runMany pm ms---- | Generate the initial uncovered set. It initializes the--- delta with all term and type constraints in scope.-mkInitialUncovered :: [Id] -> PmM Uncovered-mkInitialUncovered vars = do-  ty_cs  <- liftD getDictsDs-  tm_cs  <- map toComplex . bagToList <$> liftD getTmCsDs-  sat_ty <- tyOracle ty_cs-  let initTyCs = if sat_ty then ty_cs else emptyBag-      initTmState = fromMaybe initialTmState (tmOracle initialTmState tm_cs)-      patterns  = map PmVar vars-    -- If any of the term/type constraints are non-    -- satisfiable then return with the initialTmState. See #12957-  return [ValVec patterns (MkDelta initTyCs initTmState)]---- | Increase the counter for elapsed algorithm iterations, check that the--- limit is not exceeded and call `pmcheck`-pmcheckI :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult-pmcheckI ps guards vva = do-  n <- liftD incrCheckPmIterDs-  tracePm "pmCheck" (ppr n <> colon <+> pprPatVec ps-                        $$ hang (text "guards:") 2 (vcat (map pprPatVec guards))-                        $$ pprValVecDebug vva)-  res <- pmcheck ps guards vva-  tracePm "pmCheckResult:" (ppr res)-  return res-{-# INLINE pmcheckI #-}---- | Increase the counter for elapsed algorithm iterations, check that the--- limit is not exceeded and call `pmcheckGuards`-pmcheckGuardsI :: [PatVec] -> ValVec -> PmM PartialResult-pmcheckGuardsI gvs vva = liftD incrCheckPmIterDs >> pmcheckGuards gvs vva-{-# INLINE pmcheckGuardsI #-}---- | Increase the counter for elapsed algorithm iterations, check that the--- limit is not exceeded and call `pmcheckHd`-pmcheckHdI :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec-           -> PmM PartialResult-pmcheckHdI p ps guards va vva = do-  n <- liftD incrCheckPmIterDs-  tracePm "pmCheckHdI" (ppr n <> colon <+> pprPmPatDebug p-                        $$ pprPatVec ps-                        $$ hang (text "guards:") 2 (vcat (map pprPatVec guards))-                        $$ pprPmPatDebug va-                        $$ pprValVecDebug vva)--  res <- pmcheckHd p ps guards va vva-  tracePm "pmCheckHdI: res" (ppr res)-  return res-{-# INLINE pmcheckHdI #-}---- | Matching function: Check simultaneously a clause (takes separately the--- patterns and the list of guards) for exhaustiveness, redundancy and--- inaccessibility.-pmcheck :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult-pmcheck [] guards vva@(ValVec [] _)-  | null guards = return $ mempty { presultCovered = Covered }-  | otherwise   = pmcheckGuardsI guards vva---- Guard-pmcheck (p@(PmGrd pv e) : ps) guards vva@(ValVec vas delta)-    -- short-circuit if the guard pattern is useless.-    -- we just have two possible outcomes: fail here or match and recurse-    -- none of the two contains any useful information about the failure-    -- though. So just have these two cases but do not do all the boilerplate-  | isFakeGuard pv e = forces . mkCons vva <$> pmcheckI ps guards vva-  | otherwise = do-      y <- liftD $ mkPmId (pmPatType p)-      let tm_state = extendSubst y e (delta_tm_cs delta)-          delta'   = delta { delta_tm_cs = tm_state }-      utail <$> pmcheckI (pv ++ ps) guards (ValVec (PmVar y : vas) delta')--pmcheck [] _ (ValVec (_:_) _) = panic "pmcheck: nil-cons"-pmcheck (_:_) _ (ValVec [] _) = panic "pmcheck: cons-nil"--pmcheck (p:ps) guards (ValVec (va:vva) delta)-  = pmcheckHdI p ps guards va (ValVec vva delta)---- | Check the list of guards-pmcheckGuards :: [PatVec] -> ValVec -> PmM PartialResult-pmcheckGuards []       vva = return (usimple [vva])-pmcheckGuards (gv:gvs) vva = do-  (PartialResult prov1 cs vsa ds) <- pmcheckI gv [] vva-  (PartialResult prov2 css vsas dss) <- runMany (pmcheckGuardsI gvs) vsa-  return $ PartialResult (prov1 `mappend` prov2)-                         (cs `mappend` css)-                         vsas-                         (ds `mappend` dss)---- | Worker function: Implements all cases described in the paper for all three--- functions (`covered`, `uncovered` and `divergent`) apart from the `Guard`--- cases which are handled by `pmcheck`-pmcheckHd :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec-          -> PmM PartialResult---- Var-pmcheckHd (PmVar x) ps guards va (ValVec vva delta)-  | Just tm_state <- solveOneEq (delta_tm_cs delta)-                                (PmExprVar (idName x), vaToPmExpr va)-  = ucon va <$> pmcheckI ps guards (ValVec vva (delta {delta_tm_cs = tm_state}))-  | otherwise = return mempty---- ConCon-pmcheckHd ( p@(PmCon {pm_con_con = c1, pm_con_args = args1})) ps guards-          (va@(PmCon {pm_con_con = c2, pm_con_args = args2})) (ValVec vva delta)-  | c1 /= c2  =-    return (usimple [ValVec (va:vva) delta])-  | otherwise = kcon c1 (pm_con_arg_tys p) (pm_con_tvs p) (pm_con_dicts p)-                <$> pmcheckI (args1 ++ ps) guards (ValVec (args2 ++ vva) delta)---- LitLit-pmcheckHd (PmLit l1) ps guards (va@(PmLit l2)) vva =-  case eqPmLit l1 l2 of-    True  -> ucon va <$> pmcheckI ps guards vva-    False -> return $ ucon va (usimple [vva])---- ConVar-pmcheckHd (p@(PmCon { pm_con_con = con, pm_con_arg_tys = tys }))-          ps guards-          (PmVar x) (ValVec vva delta) = do-  (prov, complete_match) <- select =<< liftD (allCompleteMatches con tys)--  cons_cs <- mapM (liftD . mkOneConFull x) complete_match--  inst_vsa <- flip concatMapM cons_cs $ \(va, tm_ct, ty_cs) -> do-    let ty_state = ty_cs `unionBags` delta_ty_cs delta -- not actually a state-    sat_ty <- if isEmptyBag ty_cs then return True-                                  else tyOracle ty_state-    return $ case (sat_ty, solveOneEq (delta_tm_cs delta) tm_ct) of-      (True, Just tm_state) -> [ValVec (va:vva) (MkDelta ty_state tm_state)]-      _ty_or_tm_failed      -> []--  set_provenance prov .-    force_if (canDiverge (idName x) (delta_tm_cs delta)) <$>-      runMany (pmcheckI (p:ps) guards) inst_vsa---- LitVar-pmcheckHd (p@(PmLit l)) ps guards (PmVar x) (ValVec vva delta)-  = force_if (canDiverge (idName x) (delta_tm_cs delta)) <$>-      mkUnion non_matched <$>-        case solveOneEq (delta_tm_cs delta) (mkPosEq x l) of-          Just tm_state -> pmcheckHdI p ps guards (PmLit l) $-                             ValVec vva (delta {delta_tm_cs = tm_state})-          Nothing       -> return mempty-  where-    us | Just tm_state <- solveOneEq (delta_tm_cs delta) (mkNegEq x l)-       = [ValVec (PmNLit x [l] : vva) (delta { delta_tm_cs = tm_state })]-       | otherwise = []--    non_matched = usimple us---- LitNLit-pmcheckHd (p@(PmLit l)) ps guards-          (PmNLit { pm_lit_id = x, pm_lit_not = lits }) (ValVec vva delta)-  | all (not . eqPmLit l) lits-  , Just tm_state <- solveOneEq (delta_tm_cs delta) (mkPosEq x l)-    -- Both guards check the same so it would be sufficient to have only-    -- the second one. Nevertheless, it is much cheaper to check whether-    -- the literal is in the list so we check it first, to avoid calling-    -- the term oracle (`solveOneEq`) if possible-  = mkUnion non_matched <$>-      pmcheckHdI p ps guards (PmLit l)-                (ValVec vva (delta { delta_tm_cs = tm_state }))-  | otherwise = return non_matched-  where-    us | Just tm_state <- solveOneEq (delta_tm_cs delta) (mkNegEq x l)-       = [ValVec (PmNLit x (l:lits) : vva) (delta { delta_tm_cs = tm_state })]-       | otherwise = []--    non_matched = usimple us---- ------------------------------------------------------------------------------- The following three can happen only in cases like #322 where constructors--- and overloaded literals appear in the same match. The general strategy is--- to replace the literal (positive/negative) by a variable and recurse. The--- fact that the variable is equal to the literal is recorded in `delta` so--- no information is lost---- LitCon-pmcheckHd (PmLit l) ps guards (va@(PmCon {})) (ValVec vva delta)-  = do y <- liftD $ mkPmId (pmPatType va)-       let tm_state = extendSubst y (PmExprLit l) (delta_tm_cs delta)-           delta'   = delta { delta_tm_cs = tm_state }-       pmcheckHdI (PmVar y) ps guards va (ValVec vva delta')---- ConLit-pmcheckHd (p@(PmCon {})) ps guards (PmLit l) (ValVec vva delta)-  = do y <- liftD $ mkPmId (pmPatType p)-       let tm_state = extendSubst y (PmExprLit l) (delta_tm_cs delta)-           delta'   = delta { delta_tm_cs = tm_state }-       pmcheckHdI p ps guards (PmVar y) (ValVec vva delta')---- ConNLit-pmcheckHd (p@(PmCon {})) ps guards (PmNLit { pm_lit_id = x }) vva-  = pmcheckHdI p ps guards (PmVar x) vva---- Impossible: handled by pmcheck-pmcheckHd (PmGrd {}) _ _ _ _ = panic "pmcheckHd: Guard"---- ------------------------------------------------------------------------------- * Utilities for main checking--updateVsa :: (ValSetAbs -> ValSetAbs) -> (PartialResult -> PartialResult)-updateVsa f p@(PartialResult { presultUncovered = old })-  = p { presultUncovered = f old }----- | Initialise with default values for covering and divergent information.-usimple :: ValSetAbs -> PartialResult-usimple vsa = mempty { presultUncovered = vsa }---- | Take the tail of all value vector abstractions in the uncovered set-utail :: PartialResult -> PartialResult-utail = updateVsa upd-  where upd vsa = [ ValVec vva delta | ValVec (_:vva) delta <- vsa ]---- | Prepend a value abstraction to all value vector abstractions in the--- uncovered set-ucon :: ValAbs -> PartialResult -> PartialResult-ucon va = updateVsa upd-  where-    upd vsa = [ ValVec (va:vva) delta | ValVec vva delta <- vsa ]---- | Given a data constructor of arity `a` and an uncovered set containing--- value vector abstractions of length `(a+n)`, pass the first `n` value--- abstractions to the constructor (Hence, the resulting value vector--- abstractions will have length `n+1`)-kcon :: ConLike -> [Type] -> [TyVar] -> [EvVar]-     -> PartialResult -> PartialResult-kcon con arg_tys ex_tvs dicts-  = let n = conLikeArity con-        upd vsa =-          [ ValVec (va:vva) delta-          | ValVec vva' delta <- vsa-          , let (args, vva) = splitAt n vva'-          , let va = PmCon { pm_con_con     = con-                            , pm_con_arg_tys = arg_tys-                            , pm_con_tvs     = ex_tvs-                            , pm_con_dicts   = dicts-                            , pm_con_args    = args } ]-    in updateVsa upd---- | Get the union of two covered, uncovered and divergent value set--- abstractions. Since the covered and divergent sets are represented by a--- boolean, union means computing the logical or (at least one of the two is--- non-empty).--mkUnion :: PartialResult -> PartialResult -> PartialResult-mkUnion = mappend---- | Add a value vector abstraction to a value set abstraction (uncovered).-mkCons :: ValVec -> PartialResult -> PartialResult-mkCons vva = updateVsa (vva:)---- | Set the divergent set to not empty-forces :: PartialResult -> PartialResult-forces pres = pres { presultDivergent = Diverged }---- | Set the divergent set to non-empty if the flag is `True`-force_if :: Bool -> PartialResult -> PartialResult-force_if True  pres = forces pres-force_if False pres = pres--set_provenance :: Provenance -> PartialResult -> PartialResult-set_provenance prov pr = pr { presultProvenence = prov }---- ------------------------------------------------------------------------------- * Propagation of term constraints inwards when checking nested matches--{- Note [Type and Term Equality Propagation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When checking a match it would be great to have all type and term information-available so we can get more precise results. For this reason we have functions-`addDictsDs' and `addTmCsDs' in PmMonad that store in the environment type and-term constraints (respectively) as we go deeper.--The type constraints we propagate inwards are collected by `collectEvVarsPats'-in HsPat.hs. This handles bug #4139 ( see example-  https://ghc.haskell.org/trac/ghc/attachment/ticket/4139/GADTbug.hs )-where this is needed.--For term equalities we do less, we just generate equalities for HsCase. For-example we accurately give 2 redundancy warnings for the marked cases:--f :: [a] -> Bool-f x = case x of--  []    -> case x of        -- brings (x ~ []) in scope-             []    -> True-             (_:_) -> False -- can't happen--  (_:_) -> case x of        -- brings (x ~ (_:_)) in scope-             (_:_) -> True-             []    -> False -- can't happen--Functions `genCaseTmCs1' and `genCaseTmCs2' are responsible for generating-these constraints.--}---- | Generate equalities when checking a case expression:---     case x of { p1 -> e1; ... pn -> en }--- When we go deeper to check e.g. e1 we record two equalities:--- (x ~ y), where y is the initial uncovered when checking (p1; .. ; pn)--- and (x ~ p1).-genCaseTmCs2 :: Maybe (LHsExpr Id) -- Scrutinee-             -> [Pat Id]           -- LHS       (should have length 1)-             -> [Id]               -- MatchVars (should have length 1)-             -> DsM (Bag SimpleEq)-genCaseTmCs2 Nothing _ _ = return emptyBag-genCaseTmCs2 (Just scr) [p] [var] = do-  fam_insts <- dsGetFamInstEnvs-  [e] <- map vaToPmExpr . coercePatVec <$> translatePat fam_insts p-  let scr_e = lhsExprToPmExpr scr-  return $ listToBag [(var, e), (var, scr_e)]-genCaseTmCs2 _ _ _ = panic "genCaseTmCs2: HsCase"---- | Generate a simple equality when checking a case expression:---     case x of { matches }--- When checking matches we record that (x ~ y) where y is the initial--- uncovered. All matches will have to satisfy this equality.-genCaseTmCs1 :: Maybe (LHsExpr Id) -> [Id] -> Bag SimpleEq-genCaseTmCs1 Nothing     _    = emptyBag-genCaseTmCs1 (Just scr) [var] = unitBag (var, lhsExprToPmExpr scr)-genCaseTmCs1 _ _              = panic "genCaseTmCs1: HsCase"--{- Note [Literals in PmPat]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Instead of translating a literal to a variable accompanied with a guard, we-treat them like constructor patterns. The following example from-"./libraries/base/GHC/IO/Encoding.hs" shows why:--mkTextEncoding' :: CodingFailureMode -> String -> IO TextEncoding-mkTextEncoding' cfm enc = case [toUpper c | c <- enc, c /= '-'] of-    "UTF8"    -> return $ UTF8.mkUTF8 cfm-    "UTF16"   -> return $ UTF16.mkUTF16 cfm-    "UTF16LE" -> return $ UTF16.mkUTF16le cfm-    ...--Each clause gets translated to a list of variables with an equal number of-guards. For every guard we generate two cases (equals True/equals False) which-means that we generate 2^n cases to feed the oracle with, where n is the sum of-the length of all strings that appear in the patterns. For this particular-example this means over 2^40 cases. Instead, by representing them like with-constructor we get the following:-  1. We exploit the common prefix with our representation of VSAs-  2. We prune immediately non-reachable cases-     (e.g. False == (x == "U"), True == (x == "U"))--Note [Translating As Patterns]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Instead of translating x@p as:  x (p <- x)-we instead translate it as:     p (x <- coercePattern p)-for performance reasons. For example:--  f x@True  = 1-  f y@False = 2--Gives the following with the first translation:--  x |> {x == False, x == y, y == True}--If we use the second translation we get an empty set, independently of the-oracle. Since the pattern `p' may contain guard patterns though, it cannot be-used as an expression. That's why we call `coercePatVec' to drop the guard and-`vaToPmExpr' to transform the value abstraction to an expression in the-guard pattern (value abstractions are a subset of expressions). We keep the-guards in the first pattern `p' though.---%************************************************************************-%*                                                                      *-      Pretty printing of exhaustiveness/redundancy check warnings-%*                                                                      *-%************************************************************************--}---- | Check whether any part of pattern match checking is enabled (does not--- matter whether it is the redundancy check or the exhaustiveness check).-isAnyPmCheckEnabled :: DynFlags -> DsMatchContext -> Bool-isAnyPmCheckEnabled dflags (DsMatchContext kind _loc)-  = wopt Opt_WarnOverlappingPatterns dflags || exhaustive dflags kind--instance Outputable ValVec where-  ppr (ValVec vva delta)-    = let (residual_eqs, subst) = wrapUpTmState (delta_tm_cs delta)-          vector                = substInValAbs subst vva-      in  ppr_uncovered (vector, residual_eqs)---- | Apply a term substitution to a value vector abstraction. All VAs are--- transformed to PmExpr (used only before pretty printing).-substInValAbs :: PmVarEnv -> [ValAbs] -> [PmExpr]-substInValAbs subst = map (exprDeepLookup subst . vaToPmExpr)---- | Wrap up the term oracle's state once solving is complete. Drop any--- information about unhandled constraints (involving HsExprs) and flatten--- (height 1) the substitution.-wrapUpTmState :: TmState -> ([ComplexEq], PmVarEnv)-wrapUpTmState (residual, (_, subst)) = (residual, flattenPmVarEnv subst)---- | Issue all the warnings (coverage, exhaustiveness, inaccessibility)-dsPmWarn :: DynFlags -> DsMatchContext -> PmResult -> DsM ()-dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result-  = when (flag_i || flag_u) $ do-      let exists_r = flag_i && notNull redundant && onlyBuiltin-          exists_i = flag_i && notNull inaccessible && onlyBuiltin && not is_rec_upd-          exists_u = flag_u && (case uncovered of-                                  TypeOfUncovered   _ -> True-                                  UncoveredPatterns u -> notNull u)--      when exists_r $ forM_ redundant $ \(L l q) -> do-        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)-                               (pprEqn q "is redundant"))-      when exists_i $ forM_ inaccessible $ \(L l q) -> do-        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)-                               (pprEqn q "has inaccessible right hand side"))-      when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $-        case uncovered of-          TypeOfUncovered ty           -> warnEmptyCase ty-          UncoveredPatterns candidates -> pprEqns candidates-  where-    PmResult-      { pmresultProvenance = prov-      , pmresultRedundant = redundant-      , pmresultUncovered = uncovered-      , pmresultInaccessible = inaccessible } = pm_result--    flag_i = wopt Opt_WarnOverlappingPatterns dflags-    flag_u = exhaustive dflags kind-    flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind)--    is_rec_upd = case kind of { RecUpd -> True; _ -> False }-       -- See Note [Inaccessible warnings for record updates]--    onlyBuiltin = prov == FromBuiltin--    maxPatterns = maxUncoveredPatterns dflags--    -- Print a single clause (for redundant/with-inaccessible-rhs)-    pprEqn q txt = pp_context True ctx (text txt) $ \f -> ppr_eqn f kind q--    -- Print several clauses (for uncovered clauses)-    pprEqns qs = pp_context False ctx (text "are non-exhaustive") $ \_ ->-      case qs of -- See #11245-           [ValVec [] _]-                    -> text "Guards do not cover entire pattern space"-           _missing -> let us = map ppr qs-                       in  hang (text "Patterns not matched:") 4-                                (vcat (take maxPatterns us)-                                 $$ dots maxPatterns us)--    -- Print a type-annotated wildcard (for non-exhaustive `EmptyCase`s for-    -- which we only know the type and have no inhabitants at hand)-    warnEmptyCase ty = pp_context False ctx (text "are non-exhaustive") $ \_ ->-      hang (text "Patterns not matched:") 4 (underscore <+> dcolon <+> ppr ty)--{- Note [Inaccessible warnings for record updates]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (Trac #12957)-  data T a where-    T1 :: { x :: Int } -> T Bool-    T2 :: { x :: Int } -> T a-    T3 :: T a--  f :: T Char -> T a-  f r = r { x = 3 }--The desugarer will (conservatively generate a case for T1 even though-it's impossible:-  f r = case r of-          T1 x -> T1 3   -- Inaccessible branch-          T2 x -> T2 3-          _    -> error "Missing"--We don't want to warn about the inaccessible branch because the programmer-didn't put it there!  So we filter out the warning here.--}---- | Issue a warning when the predefined number of iterations is exceeded--- for the pattern match checker-warnPmIters :: DynFlags -> DsMatchContext -> DsM ()-warnPmIters dflags (DsMatchContext kind loc)-  = when (flag_i || flag_u) $ do-      iters <- maxPmCheckIterations <$> getDynFlags-      putSrcSpanDs loc (warnDs NoReason (msg iters))-  where-    ctxt   = pprMatchContext kind-    msg is = fsep [ text "Pattern match checker exceeded"-                  , parens (ppr is), text "iterations in", ctxt <> dot-                  , text "(Use -fmax-pmcheck-iterations=n"-                  , text "to set the maximun number of iterations to n)" ]--    flag_i = wopt Opt_WarnOverlappingPatterns dflags-    flag_u = exhaustive dflags kind--dots :: Int -> [a] -> SDoc-dots maxPatterns qs-    | qs `lengthExceeds` maxPatterns = text "..."-    | otherwise                      = empty---- | Check whether the exhaustiveness checker should run (exhaustiveness only)-exhaustive :: DynFlags -> HsMatchContext id -> Bool-exhaustive  dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag---- | Denotes whether an exhaustiveness check is supported, and if so,--- via which 'WarningFlag' it's controlled.--- Returns 'Nothing' if check is not supported.-exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag-exhaustiveWarningFlag (FunRhs {})   = Just Opt_WarnIncompletePatterns-exhaustiveWarningFlag CaseAlt       = Just Opt_WarnIncompletePatterns-exhaustiveWarningFlag IfAlt         = Nothing-exhaustiveWarningFlag LambdaExpr    = Just Opt_WarnIncompleteUniPatterns-exhaustiveWarningFlag PatBindRhs    = Just Opt_WarnIncompleteUniPatterns-exhaustiveWarningFlag ProcExpr      = Just Opt_WarnIncompleteUniPatterns-exhaustiveWarningFlag RecUpd        = Just Opt_WarnIncompletePatternsRecUpd-exhaustiveWarningFlag ThPatSplice   = Nothing-exhaustiveWarningFlag PatSyn        = Nothing-exhaustiveWarningFlag ThPatQuote    = Nothing-exhaustiveWarningFlag (StmtCtxt {}) = Nothing -- Don't warn about incomplete patterns-                                       -- in list comprehensions, pattern guards-                                       -- etc. They are often *supposed* to be-                                       -- incomplete---- True <==> singular-pp_context :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc-pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun-  = vcat [text txt <+> msg,-          sep [ text "In" <+> ppr_match <> char ':'-              , nest 4 (rest_of_msg_fun pref)]]-  where-    txt | singular  = "Pattern match"-        | otherwise = "Pattern match(es)"--    (ppr_match, pref)-        = case kind of-             FunRhs (L _ fun) _ _ -> (pprMatchContext kind,-                                      \ pp -> ppr fun <+> pp)-             _                    -> (pprMatchContext kind, \ pp -> pp)--ppr_pats :: HsMatchContext Name -> [Pat Id] -> SDoc-ppr_pats kind pats-  = sep [sep (map ppr pats), matchSeparator kind, text "..."]--ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> [LPat Id] -> SDoc-ppr_eqn prefixF kind eqn = prefixF (ppr_pats kind (map unLoc eqn))--ppr_constraint :: (SDoc,[PmLit]) -> SDoc-ppr_constraint (var, lits) = var <+> text "is not one of"-                                 <+> braces (pprWithCommas ppr lits)--ppr_uncovered :: ([PmExpr], [ComplexEq]) -> SDoc-ppr_uncovered (expr_vec, complex)-  | null cs   = fsep vec -- there are no literal constraints-  | otherwise = hang (fsep vec) 4 $-                  text "where" <+> vcat (map ppr_constraint cs)-  where-    sdoc_vec = mapM pprPmExprWithParens expr_vec-    (vec,cs) = runPmPprM sdoc_vec (filterComplex complex)--{- Note [Representation of Term Equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the paper, term constraints always take the form (x ~ e). Of course, a more-general constraint of the form (e1 ~ e1) can always be transformed to an-equivalent set of the former constraints, by introducing a fresh, intermediate-variable: { y ~ e1, y ~ e1 }. Yet, implementing this representation gave rise-to #11160 (incredibly bad performance for literal pattern matching). Two are-the main sources of this problem (the actual problem is how these two interact-with each other):--1. Pattern matching on literals generates twice as many constraints as needed.-   Consider the following (tests/ghci/should_run/ghcirun004):--    foo :: Int -> Int-    foo 1    = 0-    ...-    foo 5000 = 4999--   The covered and uncovered set *should* look like:-     U0 = { x |> {} }--     C1  = { 1  |> { x ~ 1 } }-     U1  = { x  |> { False ~ (x ~ 1) } }-     ...-     C10 = { 10 |> { False ~ (x ~ 1), .., False ~ (x ~ 9), x ~ 10 } }-     U10 = { x  |> { False ~ (x ~ 1), .., False ~ (x ~ 9), False ~ (x ~ 10) } }-     ...--     If we replace { False ~ (x ~ 1) } with { y ~ False, y ~ (x ~ 1) }-     we get twice as many constraints. Also note that half of them are just the-     substitution [x |-> False].--2. The term oracle (`tmOracle` in deSugar/TmOracle) uses equalities of the form-   (x ~ e) as substitutions [x |-> e]. More specifically, function-   `extendSubstAndSolve` applies such substitutions in the residual constraints-   and partitions them in the affected and non-affected ones, which are the new-   worklist. Essentially, this gives quadradic behaviour on the number of the-   residual constraints. (This would not be the case if the term oracle used-   mutable variables but, since we use it to handle disjunctions on value set-   abstractions (`Union` case), we chose a pure, incremental interface).--Now the problem becomes apparent (e.g. for clause 300):-  * Set U300 contains 300 substituting constraints [y_i |-> False] and 300-    constraints that we know that will not reduce (stay in the worklist).-  * To check for consistency, we apply the substituting constraints ONE BY ONE-    (since `tmOracle` is called incrementally, it does not have all of them-    available at once). Hence, we go through the (non-progressing) constraints-    over and over, achieving over-quadradic behaviour.--If instead we allow constraints of the form (e ~ e),-  * All uncovered sets Ui contain no substituting constraints and i-    non-progressing constraints of the form (False ~ (x ~ lit)) so the oracle-    behaves linearly.-  * All covered sets Ci contain exactly (i-1) non-progressing constraints and-    a single substituting constraint. So the term oracle goes through the-    constraints only once.--The performance improvement becomes even more important when more arguments are-involved.--}---- Debugging Infrastructre--tracePm :: String -> SDoc -> PmM ()-tracePm herald doc = liftD $ tracePmD herald doc---tracePmD :: String -> SDoc -> DsM ()-tracePmD herald doc = do-  dflags <- getDynFlags-  printer <- mkPrintUnqualifiedDs-  liftIO $ dumpIfSet_dyn_printer printer dflags-            Opt_D_dump_ec_trace (text herald $$ (nest 2 doc))---pprPmPatDebug :: PmPat a -> SDoc-pprPmPatDebug (PmCon cc _arg_tys _con_tvs _con_dicts con_args)-  = hsep [text "PmCon", ppr cc, hsep (map pprPmPatDebug con_args)]-pprPmPatDebug (PmVar vid) = text "PmVar" <+> ppr vid-pprPmPatDebug (PmLit li)  = text "PmLit" <+> ppr li-pprPmPatDebug (PmNLit i nl) = text "PmNLit" <+> ppr i <+> ppr nl-pprPmPatDebug (PmGrd pv ge) = text "PmGrd" <+> hsep (map pprPmPatDebug pv)-                                           <+> ppr ge--pprPatVec :: PatVec -> SDoc-pprPatVec ps = hang (text "Pattern:") 2-                (brackets $ sep-                  $ punctuate (comma <> char '\n') (map pprPmPatDebug ps))--pprValAbs :: [ValAbs] -> SDoc-pprValAbs ps = hang (text "ValAbs:") 2-                (brackets $ sep-                  $ punctuate (comma) (map pprPmPatDebug ps))--pprValVecDebug :: ValVec -> SDoc-pprValVecDebug (ValVec vas _d) = text "ValVec" <+>-                                  parens (pprValAbs vas)
− src/Language/Haskell/Liquid/Desugar/Coverage.hs 
@@ -1,1388 +0,0 @@-{--(c) Galois, 2006-(c) University of Glasgow, 2007--}--{-# LANGUAGE CPP, NondecreasingIndentation, RecordWildCards #-}--module Language.Haskell.Liquid.Desugar.Coverage (addTicksToBinds, hpcInitCode) where--#ifdef GHCI-import qualified GHCi-import GHCi.RemoteTypes-import Data.Array-import ByteCodeTypes-#if MIN_VERSION_base(4,9,0)-import GHC.Stack.CCS-#else-import GHC.Stack as GHC.Stack.CCS-#endif-#endif-import Type-import HsSyn-import Module-import Outputable-import DynFlags-import ConLike-import Control.Monad-import SrcLoc-import ErrUtils-import NameSet hiding (FreeVars)-import Name-import Bag-import CostCentre-#ifdef DETERMINISTIC_PROFILING-import CostCentreState-#endif-import CoreSyn-import Id-import VarSet-import Data.List-import FastString-import HscTypes-import TyCon-#ifndef DETERMINISTIC_PROFILING-import UniqSupply-#endif-import BasicTypes-import MonadUtils-import Maybes-import CLabel-import Util--import Data.Time-import System.Directory--import Trace.Hpc.Mix-import Trace.Hpc.Util--import Data.Map (Map)-import qualified Data.Map as Map--{--************************************************************************-*                                                                      *-*              The main function: addTicksToBinds-*                                                                      *-************************************************************************--}--addTicksToBinds-        :: HscEnv-        -> Module-        -> ModLocation          -- ... off the current module-        -> NameSet              -- Exported Ids.  When we call addTicksToBinds,-                                -- isExportedId doesn't work yet (the desugarer-                                -- hasn't set it), so we have to work from this set.-        -> [TyCon]              -- Type constructor in this module-        -> LHsBinds Id-        -> IO (LHsBinds Id, HpcInfo, Maybe ModBreaks)--addTicksToBinds hsc_env mod mod_loc exports tyCons binds-  | let dflags = hsc_dflags hsc_env-        passes = coveragePasses dflags, not (null passes),-    Just orig_file <- ml_hs_file mod_loc,-    not ("boot" `isSuffixOf` orig_file) = do--#ifndef DETERMINISTIC_PROFILING-     us <- mkSplitUniqSupply 'C' -- for cost centres-#endif-     let  orig_file2 = guessSourceFile binds orig_file--          tickPass tickish (binds,st) =-            let env = TTE-                      { fileName     = mkFastString orig_file2-                      , declPath     = []-                      , tte_dflags   = dflags-                      , exports      = exports-                      , inlines      = emptyVarSet-                      , inScope      = emptyVarSet-                      , blackList    = Map.fromList-                                          [ (getSrcSpan (tyConName tyCon),())-                                          | tyCon <- tyCons ]-                      , density      = mkDensity tickish dflags-                      , this_mod     = mod-                      , tickishType  = tickish-}-                (binds',_,st') = unTM (addTickLHsBinds binds) env st-            in (binds', st')--          initState = TT { tickBoxCount = 0-                         , mixEntries   = []-#ifdef DETERMINISTIC_PROFILING-                         , ccIndices    = newCostCentreState-#else-                         , uniqSupply   = us-#endif-                         }--          (binds1,st) = foldr tickPass (binds, initState) passes--     let tickCount = tickBoxCount st-         entries = reverse $ mixEntries st-     hashNo <- writeMixEntries dflags mod tickCount entries orig_file2-     modBreaks <- mkModBreaks hsc_env mod tickCount entries--     when (dopt Opt_D_dump_ticked dflags) $-         putLogMsg dflags NoReason SevDump noSrcSpan-             (defaultDumpStyle dflags) (pprLHsBinds binds1)--     return (binds1, HpcInfo tickCount hashNo, Just modBreaks)--  | otherwise = return (binds, emptyHpcInfo False, Nothing)--guessSourceFile :: LHsBinds Id -> FilePath -> FilePath-guessSourceFile binds orig_file =-     -- Try look for a file generated from a .hsc file to a-     -- .hs file, by peeking ahead.-     let top_pos = catMaybes $ foldrBag (\ (L pos _) rest ->-                                 srcSpanFileName_maybe pos : rest) [] binds-     in-     case top_pos of-        (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name-                      -> unpackFS file_name-        _ -> orig_file---mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks-#ifndef GHCI-mkModBreaks _hsc_env _mod _count _entries = return emptyModBreaks-#else-mkModBreaks hsc_env mod count entries-  | HscInterpreted <- hscTarget (hsc_dflags hsc_env) = do-    breakArray <- GHCi.newBreakArray hsc_env (length entries)-    ccs <- mkCCSArray hsc_env mod count entries-    let-           locsTicks  = listArray (0,count-1) [ span  | (span,_,_,_)  <- entries ]-           varsTicks  = listArray (0,count-1) [ vars  | (_,_,vars,_)  <- entries ]-           declsTicks = listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ]-    return emptyModBreaks-                       { modBreaks_flags = breakArray-                       , modBreaks_locs  = locsTicks-                       , modBreaks_vars  = varsTicks-                       , modBreaks_decls = declsTicks-                       , modBreaks_ccs   = ccs-                       }-  | otherwise = return emptyModBreaks--mkCCSArray-  :: HscEnv -> Module -> Int -> [MixEntry_]-  -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))-mkCCSArray hsc_env modul count entries = do-  if interpreterProfiled dflags-    then do-      let module_str = moduleNameString (moduleName modul)-      costcentres <- GHCi.mkCostCentres hsc_env module_str (map mk_one entries)-      return (listArray (0,count-1) costcentres)-    else do-      return (listArray (0,-1) [])- where-    dflags = hsc_dflags hsc_env-    mk_one (srcspan, decl_path, _, _) = (name, src)-      where name = concat (intersperse "." decl_path)-            src = showSDoc dflags (ppr srcspan)-#endif--writeMixEntries-  :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int-writeMixEntries dflags mod count entries filename-  | not (gopt Opt_Hpc dflags) = return 0-  | otherwise   = do-        let-            hpc_dir = hpcDir dflags-            mod_name = moduleNameString (moduleName mod)--            hpc_mod_dir-              | moduleUnitId mod == mainUnitId  = hpc_dir-              | otherwise = hpc_dir ++ "/" ++ unitIdString (moduleUnitId mod)--            tabStop = 8 -- <tab> counts as a normal char in GHC's-                        -- location ranges.--        createDirectoryIfMissing True hpc_mod_dir-        modTime <- getModificationUTCTime filename-        let entries' = [ (hpcPos, box)-                       | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]-        when (length entries' /= count) $ do-          panic "the number of .mix entries are inconsistent"-        let hashNo = mixHash filename modTime tabStop entries'-        mixCreate hpc_mod_dir mod_name-                       $ Mix filename modTime (toHash hashNo) tabStop entries'-        return hashNo----- -------------------------------------------------------------------------------- TickDensity: where to insert ticks--data TickDensity-  = TickForCoverage       -- for Hpc-  | TickForBreakPoints    -- for GHCi-  | TickAllFunctions      -- for -prof-auto-all-  | TickTopFunctions      -- for -prof-auto-top-  | TickExportedFunctions -- for -prof-auto-exported-  | TickCallSites         -- for stack tracing-  deriving Eq--mkDensity :: TickishType -> DynFlags -> TickDensity-mkDensity tickish dflags = case tickish of-  HpcTicks             -> TickForCoverage-  SourceNotes          -> TickForCoverage-  Breakpoints          -> TickForBreakPoints-  ProfNotes ->-    case profAuto dflags of-      ProfAutoAll      -> TickAllFunctions-      ProfAutoTop      -> TickTopFunctions-      ProfAutoExports  -> TickExportedFunctions-      ProfAutoCalls    -> TickCallSites-      _other           -> panic "mkDensity"---- | Decide whether to add a tick to a binding or not.-shouldTickBind  :: TickDensity-                -> Bool         -- top level?-                -> Bool         -- exported?-                -> Bool         -- simple pat bind?-                -> Bool         -- INLINE pragma?-                -> Bool--shouldTickBind density top_lev exported _simple_pat inline- = case density of-      TickForBreakPoints    -> False-        -- we never add breakpoints to simple pattern bindings-        -- (there's always a tick on the rhs anyway).-      TickAllFunctions      -> not inline-      TickTopFunctions      -> top_lev && not inline-      TickExportedFunctions -> exported && not inline-      TickForCoverage       -> True-      TickCallSites         -> False--shouldTickPatBind :: TickDensity -> Bool -> Bool-shouldTickPatBind density top_lev-  = case density of-      TickForBreakPoints    -> False-      TickAllFunctions      -> True-      TickTopFunctions      -> top_lev-      TickExportedFunctions -> False-      TickForCoverage       -> False-      TickCallSites         -> False---- -------------------------------------------------------------------------------- Adding ticks to bindings--addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)-addTickLHsBinds = mapBagM addTickLHsBind--addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)-addTickLHsBind (L pos bind@(AbsBinds { abs_binds   = binds,-                                       abs_exports = abs_exports })) = do-  withEnv add_exports $ do-  withEnv add_inlines $ do-  binds' <- addTickLHsBinds binds-  return $ L pos $ bind { abs_binds = binds' }- where-   -- in AbsBinds, the Id on each binding is not the actual top-level-   -- Id that we are defining, they are related by the abs_exports-   -- field of AbsBinds.  So if we're doing TickExportedFunctions we need-   -- to add the local Ids to the set of exported Names so that we know to-   -- tick the right bindings.-   add_exports env =-     env{ exports = exports env `extendNameSetList`-                      [ idName mid-                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports-                      , idName pid `elemNameSet` (exports env) ] }--   add_inlines env =-     env{ inlines = inlines env `extendVarSetList`-                      [ mid-                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports-                      , isAnyInlinePragma (idInlinePragma pid) ] }--addTickLHsBind (L pos bind@(AbsBindsSig { abs_sig_bind   = val_bind-                                        , abs_sig_export = poly_id }))-  | L _ FunBind { fun_id = L _ mono_id } <- val_bind-  = do withEnv (add_export  mono_id) $ do-       withEnv (add_inlines mono_id) $ do-       val_bind' <- addTickLHsBind val_bind-       return $ L pos $ bind { abs_sig_bind = val_bind' }--  | otherwise-  = pprPanic "addTickLHsBind" (ppr bind)- where-  -- see AbsBinds comments-  add_export mono_id env-    | idName poly_id `elemNameSet` exports env-    = env { exports = exports env `extendNameSet` idName mono_id }-    | otherwise-    = env--  add_inlines mono_id env-    | isAnyInlinePragma (idInlinePragma poly_id)-    = env { inlines = inlines env `extendVarSet` mono_id }-    | otherwise-    = env--addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do-  let name = getOccString id-  decl_path <- getPathEntry-  density <- getDensity--  inline_ids <- liftM inlines getEnv-  let inline   = isAnyInlinePragma (idInlinePragma id)-                 || id `elemVarSet` inline_ids--  -- See Note [inline sccs]-  tickish <- tickishType `liftM` getEnv-  if inline && tickish == ProfNotes then return (L pos funBind) else do--  (fvs, mg@(MG { mg_alts = matches' })) <--        getFreeVars $-        addPathEntry name $-        addTickMatchGroup False (fun_matches funBind)--  blackListed <- isBlackListed pos-  exported_names <- liftM exports getEnv--  -- We don't want to generate code for blacklisted positions-  -- We don't want redundant ticks on simple pattern bindings-  -- We don't want to tick non-exported bindings in TickExportedFunctions-  let simple = isSimplePatBind funBind-      toplev = null decl_path-      exported = idName id `elemNameSet` exported_names--  tick <- if not blackListed &&-               shouldTickBind density toplev exported simple inline-             then-                bindTick density name pos fvs-             else-                return Nothing--  let mbCons = maybe Prelude.id (:)-  return $ L pos $ funBind { fun_matches = mg { mg_alts = matches' }-                           , fun_tick = tick `mbCons` fun_tick funBind }--   where-   -- a binding is a simple pattern binding if it is a funbind with-   -- zero patterns-   isSimplePatBind :: HsBind a -> Bool-   isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0---- TODO: Revisit this-addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do-  let name = "(...)"-  (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs-  let pat' = pat { pat_rhs = rhs'}--  -- Should create ticks here?-  density <- getDensity-  decl_path <- getPathEntry-  let top_lev = null decl_path-  if not (shouldTickPatBind density top_lev) then return (L pos pat') else do--    -- Allocate the ticks-    rhs_tick <- bindTick density name pos fvs-    let patvars = map getOccString (collectPatBinders lhs)-    patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars--    -- Add to pattern-    let mbCons = maybe id (:)-        rhs_ticks = rhs_tick `mbCons` fst (pat_ticks pat')-        patvar_tickss = zipWith mbCons patvar_ticks-                        (snd (pat_ticks pat') ++ repeat [])-    return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }---- Only internal stuff, not from source, uses VarBind, so we ignore it.-addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind-addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind---bindTick-  :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))-bindTick density name pos fvs = do-  decl_path <- getPathEntry-  let-      toplev        = null decl_path-      count_entries = toplev || density == TickAllFunctions-      top_only      = density /= TickAllFunctions-      box_label     = if toplev then TopLevelBox [name]-                                else LocalBox (decl_path ++ [name])-  ---  allocATickBox box_label count_entries top_only pos fvs----- Note [inline sccs]------ It should be reasonable to add ticks to INLINE functions; however--- currently this tickles a bug later on because the SCCfinal pass--- does not look inside unfoldings to find CostCentres.  It would be--- difficult to fix that, because SCCfinal currently works on STG and--- not Core (and since it also generates CostCentres for CAFs,--- changing this would be difficult too).------ Another reason not to add ticks to INLINE functions is that this--- sometimes handy for avoiding adding a tick to a particular function--- (see #6131)------ So for now we do not add any ticks to INLINE functions at all.---- -------------------------------------------------------------------------------- Decorate an LHsExpr with ticks---- selectively add ticks to interesting expressions-addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)-addTickLHsExpr e@(L pos e0) = do-  d <- getDensity-  case d of-    TickForBreakPoints | isGoodBreakExpr e0 -> tick_it-    TickForCoverage    -> tick_it-    TickCallSites      | isCallSite e0      -> tick_it-    _other             -> dont_tick_it- where-   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0-   dont_tick_it = addTickLHsExprNever e---- Add a tick to an expression which is the RHS of an equation or a binding.--- We always consider these to be breakpoints, unless the expression is a 'let'--- (because the body will definitely have a tick somewhere).  ToDo: perhaps--- we should treat 'case' and 'if' the same way?-addTickLHsExprRHS :: LHsExpr Id -> TM (LHsExpr Id)-addTickLHsExprRHS e@(L pos e0) = do-  d <- getDensity-  case d of-     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it-                        | otherwise     -> tick_it-     TickForCoverage -> tick_it-     TickCallSites   | isCallSite e0 -> tick_it-     _other          -> dont_tick_it- where-   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0-   dont_tick_it = addTickLHsExprNever e---- The inner expression of an evaluation context:---    let binds in [], ( [] )--- we never tick these if we're doing HPC, but otherwise--- we treat it like an ordinary expression.-addTickLHsExprEvalInner :: LHsExpr Id -> TM (LHsExpr Id)-addTickLHsExprEvalInner e = do-   d <- getDensity-   case d of-     TickForCoverage -> addTickLHsExprNever e-     _otherwise      -> addTickLHsExpr e---- | A let body is treated differently from addTickLHsExprEvalInner--- above with TickForBreakPoints, because for breakpoints we always--- want to tick the body, even if it is not a redex.  See test--- break012.  This gives the user the opportunity to inspect the--- values of the let-bound variables.-addTickLHsExprLetBody :: LHsExpr Id -> TM (LHsExpr Id)-addTickLHsExprLetBody e@(L pos e0) = do-  d <- getDensity-  case d of-     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it-                        | otherwise     -> tick_it-     _other -> addTickLHsExprEvalInner e- where-   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0-   dont_tick_it = addTickLHsExprNever e---- version of addTick that does not actually add a tick,--- because the scope of this tick is completely subsumed by--- another.-addTickLHsExprNever :: LHsExpr Id -> TM (LHsExpr Id)-addTickLHsExprNever (L pos e0) = do-    e1 <- addTickHsExpr e0-    return $ L pos e1---- general heuristic: expressions which do not denote values are good--- break points-isGoodBreakExpr :: HsExpr Id -> Bool-isGoodBreakExpr (HsApp {})        = True-isGoodBreakExpr (HsAppTypeOut {}) = True-isGoodBreakExpr (OpApp {})        = True-isGoodBreakExpr _other            = False--isCallSite :: HsExpr Id -> Bool-isCallSite HsApp{}        = True-isCallSite HsAppTypeOut{} = True-isCallSite OpApp{}        = True-isCallSite _ = False--addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)-addTickLHsExprOptAlt oneOfMany (L pos e0)-  = ifDensity TickForCoverage-        (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)-        (addTickLHsExpr (L pos e0))--addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)-addBinTickLHsExpr boxLabel (L pos e0)-  = ifDensity TickForCoverage-        (allocBinTickBox boxLabel pos $ addTickHsExpr e0)-        (addTickLHsExpr (L pos e0))----- -------------------------------------------------------------------------------- Decorate the body of an HsExpr with ticks.--- (Whether to put a tick around the whole expression was already decided,--- in the addTickLHsExpr family of functions.)--addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)-addTickHsExpr e@(HsVar (L _ id)) = do freeVar id; return e-addTickHsExpr (HsUnboundVar {})  = panic "addTickHsExpr.HsUnboundVar"-addTickHsExpr e@(HsConLikeOut con)-  | Just id <- conLikeWrapId_maybe con = do freeVar id; return e-addTickHsExpr e@(HsIPVar _)      = return e-addTickHsExpr e@(HsOverLit _)    = return e-addTickHsExpr e@(HsOverLabel{})  = return e-addTickHsExpr e@(HsLit _)        = return e-addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup)-addTickHsExpr (HsLamCase mgs)    = liftM HsLamCase (addTickMatchGroup True mgs)-addTickHsExpr (HsApp e1 e2)      = liftM2 HsApp (addTickLHsExprNever e1)-                                                (addTickLHsExpr      e2)-addTickHsExpr (HsAppTypeOut e ty) = liftM2 HsAppTypeOut (addTickLHsExprNever e)-                                                        (return ty)--addTickHsExpr (OpApp e1 e2 fix e3) =-        liftM4 OpApp-                (addTickLHsExpr e1)-                (addTickLHsExprNever e2)-                (return fix)-                (addTickLHsExpr e3)-addTickHsExpr (NegApp e neg) =-        liftM2 NegApp-                (addTickLHsExpr e)-                (addTickSyntaxExpr hpcSrcSpan neg)-addTickHsExpr (HsPar e) =-        liftM HsPar (addTickLHsExprEvalInner e)-addTickHsExpr (SectionL e1 e2) =-        liftM2 SectionL-                (addTickLHsExpr e1)-                (addTickLHsExprNever e2)-addTickHsExpr (SectionR e1 e2) =-        liftM2 SectionR-                (addTickLHsExprNever e1)-                (addTickLHsExpr e2)-addTickHsExpr (ExplicitTuple es boxity) =-        liftM2 ExplicitTuple-                (mapM addTickTupArg es)-                (return boxity)-addTickHsExpr (ExplicitSum tag arity e ty) = do-        e' <- addTickLHsExpr e-        return (ExplicitSum tag arity e' ty)-addTickHsExpr (HsCase e mgs) =-        liftM2 HsCase-                (addTickLHsExpr e) -- not an EvalInner; e might not necessarily-                                   -- be evaluated.-                (addTickMatchGroup False mgs)-addTickHsExpr (HsIf cnd e1 e2 e3) =-        liftM3 (HsIf cnd)-                (addBinTickLHsExpr (BinBox CondBinBox) e1)-                (addTickLHsExprOptAlt True e2)-                (addTickLHsExprOptAlt True e3)-addTickHsExpr (HsMultiIf ty alts)-  = do { let isOneOfMany = case alts of [_] -> False; _ -> True-       ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts-       ; return $ HsMultiIf ty alts' }-addTickHsExpr (HsLet (L l binds) e) =-        bindLocals (collectLocalBinders binds) $-          liftM2 (HsLet . L l)-                  (addTickHsLocalBinds binds) -- to think about: !patterns.-                  (addTickLHsExprLetBody e)-addTickHsExpr (HsDo cxt (L l stmts) srcloc)-  = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())-       ; return (HsDo cxt (L l stmts') srcloc) }-  where-        forQual = case cxt of-                    ListComp -> Just $ BinBox QualBinBox-                    _        -> Nothing-addTickHsExpr (ExplicitList ty wit es) =-        liftM3 ExplicitList-                (return ty)-                (addTickWit wit)-                (mapM (addTickLHsExpr) es)-             where addTickWit Nothing = return Nothing-                   addTickWit (Just fln)-                     = do fln' <- addTickSyntaxExpr hpcSrcSpan fln-                          return (Just fln')-addTickHsExpr (ExplicitPArr ty es) =-        liftM2 ExplicitPArr-                (return ty)-                (mapM (addTickLHsExpr) es)--addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e--addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds })-  = do { rec_binds' <- addTickHsRecordBinds rec_binds-       ; return (expr { rcon_flds = rec_binds' }) }--addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })-  = do { e' <- addTickLHsExpr e-       ; flds' <- mapM addTickHsRecField flds-       ; return (expr { rupd_expr = e', rupd_flds = flds' }) }--addTickHsExpr (ExprWithTySig e ty) =-        liftM2 ExprWithTySig-                (addTickLHsExprNever e) -- No need to tick the inner expression-                                    -- for expressions with signatures-                (return ty)-addTickHsExpr (ArithSeq  ty wit arith_seq) =-        liftM3 ArithSeq-                (return ty)-                (addTickWit wit)-                (addTickArithSeqInfo arith_seq)-             where addTickWit Nothing = return Nothing-                   addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl-                                             return (Just fl')---- We might encounter existing ticks (multiple Coverage passes)-addTickHsExpr (HsTick t e) =-        liftM (HsTick t) (addTickLHsExprNever e)-addTickHsExpr (HsBinTick t0 t1 e) =-        liftM (HsBinTick t0 t1) (addTickLHsExprNever e)--addTickHsExpr (HsTickPragma _ _ _ (L pos e0)) = do-    e2 <- allocTickBox (ExpBox False) False False pos $-                addTickHsExpr e0-    return $ unLoc e2-addTickHsExpr (PArrSeq   ty arith_seq) =-        liftM2 PArrSeq-                (return ty)-                (addTickArithSeqInfo arith_seq)-addTickHsExpr (HsSCC src nm e) =-        liftM3 HsSCC-                (return src)-                (return nm)-                (addTickLHsExpr e)-addTickHsExpr (HsCoreAnn src nm e) =-        liftM3 HsCoreAnn-                (return src)-                (return nm)-                (addTickLHsExpr e)-addTickHsExpr e@(HsBracket     {})   = return e-addTickHsExpr e@(HsTcBracketOut  {}) = return e-addTickHsExpr e@(HsRnBracketOut  {}) = return e-addTickHsExpr e@(HsSpliceE  {})      = return e-addTickHsExpr (HsProc pat cmdtop) =-        liftM2 HsProc-                (addTickLPat pat)-                (liftL (addTickHsCmdTop) cmdtop)-addTickHsExpr (HsWrap w e) =-        liftM2 HsWrap-                (return w)-                (addTickHsExpr e)       -- Explicitly no tick on inside--addTickHsExpr (ExprWithTySigOut e ty) =-        liftM2 ExprWithTySigOut-               (addTickLHsExprNever e) -- No need to tick the inner expression-               (return ty)             -- for expressions with signatures---- Others should never happen in expression content.-addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)--addTickTupArg :: LHsTupArg Id -> TM (LHsTupArg Id)-addTickTupArg (L l (Present e))  = do { e' <- addTickLHsExpr e-                                      ; return (L l (Present e')) }-addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))--addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id))-addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do-  let isOneOfMany = matchesOneOfMany matches-  matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches-  return $ mg { mg_alts = L l matches' }--addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id))-addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) =-  bindLocals (collectPatsBinders pats) $ do-    gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs-    return $ Match mf pats opSig gRHSs'--addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id))-addTickGRHSs isOneOfMany isLambda (GRHSs guarded (L l local_binds)) = do-  bindLocals binders $ do-    local_binds' <- addTickHsLocalBinds local_binds-    guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded-    return $ GRHSs guarded' (L l local_binds')-  where-    binders = collectLocalBinders local_binds--addTickGRHS :: Bool -> Bool -> GRHS Id (LHsExpr Id) -> TM (GRHS Id (LHsExpr Id))-addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do-  (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts-                        (addTickGRHSBody isOneOfMany isLambda expr)-  return $ GRHS stmts' expr'--addTickGRHSBody :: Bool -> Bool -> LHsExpr Id -> TM (LHsExpr Id)-addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do-  d <- getDensity-  case d of-    TickForCoverage  -> addTickLHsExprOptAlt isOneOfMany expr-    TickAllFunctions | isLambda ->-       addPathEntry "\\" $-         allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $-           addTickHsExpr e0-    _otherwise ->-       addTickLHsExprRHS expr--addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM [ExprLStmt Id]-addTickLStmts isGuard stmts = do-  (stmts, _) <- addTickLStmts' isGuard stmts (return ())-  return stmts--addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM a-               -> TM ([ExprLStmt Id], a)-addTickLStmts' isGuard lstmts res-  = bindLocals (collectLStmtsBinders lstmts) $-    do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts-       ; a <- res-       ; return (lstmts', a) }--addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id (LHsExpr Id) -> TM (Stmt Id (LHsExpr Id))-addTickStmt _isGuard (LastStmt e noret ret) = do-        liftM3 LastStmt-                (addTickLHsExpr e)-                (pure noret)-                (addTickSyntaxExpr hpcSrcSpan ret)-addTickStmt _isGuard (BindStmt pat e bind fail ty) = do-        liftM5 BindStmt-                (addTickLPat pat)-                (addTickLHsExprRHS e)-                (addTickSyntaxExpr hpcSrcSpan bind)-                (addTickSyntaxExpr hpcSrcSpan fail)-                (return ty)-addTickStmt isGuard (BodyStmt e bind' guard' ty) = do-        liftM4 BodyStmt-                (addTick isGuard e)-                (addTickSyntaxExpr hpcSrcSpan bind')-                (addTickSyntaxExpr hpcSrcSpan guard')-                (return ty)-addTickStmt _isGuard (LetStmt (L l binds)) = do-        liftM (LetStmt . L l)-                (addTickHsLocalBinds binds)-addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr ty) = do-    liftM4 ParStmt-        (mapM (addTickStmtAndBinders isGuard) pairs)-        (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr))-        (addTickSyntaxExpr hpcSrcSpan bindExpr)-        (return ty)-addTickStmt isGuard (ApplicativeStmt args mb_join body_ty) = do-    args' <- mapM (addTickApplicativeArg isGuard) args-    return (ApplicativeStmt args' mb_join body_ty)--addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts-                                    , trS_by = by, trS_using = using-                                    , trS_ret = returnExpr, trS_bind = bindExpr-                                    , trS_fmap = liftMExpr }) = do-    t_s <- addTickLStmts isGuard stmts-    t_y <- fmapMaybeM  addTickLHsExprRHS by-    t_u <- addTickLHsExprRHS using-    t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr-    t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr-    L _ t_m <- addTickLHsExpr (L hpcSrcSpan liftMExpr)-    return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u-                  , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }--addTickStmt isGuard stmt@(RecStmt {})-  = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)-       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)-       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)-       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)-       ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'-                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }--addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)-addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e-                  | otherwise          = addTickLHsExprRHS e--addTickApplicativeArg-  :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr Id, ApplicativeArg Id Id)-  -> TM (SyntaxExpr Id, ApplicativeArg Id Id)-addTickApplicativeArg isGuard (op, arg) =-  liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)- where-  addTickArg (ApplicativeArgOne pat expr) =-    ApplicativeArgOne <$> addTickLPat pat <*> addTickLHsExpr expr-  addTickArg (ApplicativeArgMany stmts ret pat) =-    ApplicativeArgMany-      <$> addTickLStmts isGuard stmts-      <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret))-      <*> addTickLPat pat--addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock Id Id-                      -> TM (ParStmtBlock Id Id)-addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =-    liftM3 ParStmtBlock-        (addTickLStmts isGuard stmts)-        (return ids)-        (addTickSyntaxExpr hpcSrcSpan returnExpr)--addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)-addTickHsLocalBinds (HsValBinds binds) =-        liftM HsValBinds-                (addTickHsValBinds binds)-addTickHsLocalBinds (HsIPBinds binds)  =-        liftM HsIPBinds-                (addTickHsIPBinds binds)-addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds--addTickHsValBinds :: HsValBindsLR Id a -> TM (HsValBindsLR Id b)-addTickHsValBinds (ValBindsOut binds sigs) =-        liftM2 ValBindsOut-                (mapM (\ (rec,binds') ->-                                liftM2 (,)-                                        (return rec)-                                        (addTickLHsBinds binds'))-                        binds)-                (return sigs)-addTickHsValBinds _ = panic "addTickHsValBinds"--addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id)-addTickHsIPBinds (IPBinds ipbinds dictbinds) =-        liftM2 IPBinds-                (mapM (liftL (addTickIPBind)) ipbinds)-                (return dictbinds)--addTickIPBind :: IPBind Id -> TM (IPBind Id)-addTickIPBind (IPBind nm e) =-        liftM2 IPBind-                (return nm)-                (addTickLHsExpr e)---- There is no location here, so we might need to use a context location??-addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)-addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do-        L _ x' <- addTickLHsExpr (L pos x)-        return $ syn { syn_expr = x' }--- we do not walk into patterns.-addTickLPat :: LPat Id -> TM (LPat Id)-addTickLPat pat = return pat--addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id)-addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =-        liftM4 HsCmdTop-                (addTickLHsCmd cmd)-                (return tys)-                (return ty)-                (return syntaxtable)--addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)-addTickLHsCmd (L pos c0) = do-        c1 <- addTickHsCmd c0-        return $ L pos c1--addTickHsCmd :: HsCmd Id -> TM (HsCmd Id)-addTickHsCmd (HsCmdLam matchgroup) =-        liftM HsCmdLam (addTickCmdMatchGroup matchgroup)-addTickHsCmd (HsCmdApp c e) =-        liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e)-{--addTickHsCmd (OpApp e1 c2 fix c3) =-        liftM4 OpApp-                (addTickLHsExpr e1)-                (addTickLHsCmd c2)-                (return fix)-                (addTickLHsCmd c3)--}-addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e)-addTickHsCmd (HsCmdCase e mgs) =-        liftM2 HsCmdCase-                (addTickLHsExpr e)-                (addTickCmdMatchGroup mgs)-addTickHsCmd (HsCmdIf cnd e1 c2 c3) =-        liftM3 (HsCmdIf cnd)-                (addBinTickLHsExpr (BinBox CondBinBox) e1)-                (addTickLHsCmd c2)-                (addTickLHsCmd c3)-addTickHsCmd (HsCmdLet (L l binds) c) =-        bindLocals (collectLocalBinders binds) $-          liftM2 (HsCmdLet . L l)-                   (addTickHsLocalBinds binds) -- to think about: !patterns.-                   (addTickLHsCmd c)-addTickHsCmd (HsCmdDo (L l stmts) srcloc)-  = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())-       ; return (HsCmdDo (L l stmts') srcloc) }--addTickHsCmd (HsCmdArrApp   e1 e2 ty1 arr_ty lr) =-        liftM5 HsCmdArrApp-               (addTickLHsExpr e1)-               (addTickLHsExpr e2)-               (return ty1)-               (return arr_ty)-               (return lr)-addTickHsCmd (HsCmdArrForm e f fix cmdtop) =-        liftM4 HsCmdArrForm-               (addTickLHsExpr e)-               (return f)-               (return fix)-               (mapM (liftL (addTickHsCmdTop)) cmdtop)--addTickHsCmd (HsCmdWrap w cmd)-  = liftM2 HsCmdWrap (return w) (addTickHsCmd cmd)---- Others should never happen in a command context.---addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)--addTickCmdMatchGroup :: MatchGroup Id (LHsCmd Id) -> TM (MatchGroup Id (LHsCmd Id))-addTickCmdMatchGroup mg@(MG { mg_alts = L l matches }) = do-  matches' <- mapM (liftL addTickCmdMatch) matches-  return $ mg { mg_alts = L l matches' }--addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id))-addTickCmdMatch (Match mf pats opSig gRHSs) =-  bindLocals (collectPatsBinders pats) $ do-    gRHSs' <- addTickCmdGRHSs gRHSs-    return $ Match mf pats opSig gRHSs'--addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id))-addTickCmdGRHSs (GRHSs guarded (L l local_binds)) = do-  bindLocals binders $ do-    local_binds' <- addTickHsLocalBinds local_binds-    guarded' <- mapM (liftL addTickCmdGRHS) guarded-    return $ GRHSs guarded' (L l local_binds')-  where-    binders = collectLocalBinders local_binds--addTickCmdGRHS :: GRHS Id (LHsCmd Id) -> TM (GRHS Id (LHsCmd Id))--- The *guards* are *not* Cmds, although the body is--- C.f. addTickGRHS for the BinBox stuff-addTickCmdGRHS (GRHS stmts cmd)-  = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)-                                   stmts (addTickLHsCmd cmd)-       ; return $ GRHS stmts' expr' }--addTickLCmdStmts :: [LStmt Id (LHsCmd Id)] -> TM [LStmt Id (LHsCmd Id)]-addTickLCmdStmts stmts = do-  (stmts, _) <- addTickLCmdStmts' stmts (return ())-  return stmts--addTickLCmdStmts' :: [LStmt Id (LHsCmd Id)] -> TM a -> TM ([LStmt Id (LHsCmd Id)], a)-addTickLCmdStmts' lstmts res-  = bindLocals binders $ do-        lstmts' <- mapM (liftL addTickCmdStmt) lstmts-        a <- res-        return (lstmts', a)-  where-        binders = collectLStmtsBinders lstmts--addTickCmdStmt :: Stmt Id (LHsCmd Id) -> TM (Stmt Id (LHsCmd Id))-addTickCmdStmt (BindStmt pat c bind fail ty) = do-        liftM5 BindStmt-                (addTickLPat pat)-                (addTickLHsCmd c)-                (return bind)-                (return fail)-                (return ty)-addTickCmdStmt (LastStmt c noret ret) = do-        liftM3 LastStmt-                (addTickLHsCmd c)-                (pure noret)-                (addTickSyntaxExpr hpcSrcSpan ret)-addTickCmdStmt (BodyStmt c bind' guard' ty) = do-        liftM4 BodyStmt-                (addTickLHsCmd c)-                (addTickSyntaxExpr hpcSrcSpan bind')-                (addTickSyntaxExpr hpcSrcSpan guard')-                (return ty)-addTickCmdStmt (LetStmt (L l binds)) = do-        liftM (LetStmt . L l)-                (addTickHsLocalBinds binds)-addTickCmdStmt stmt@(RecStmt {})-  = do { stmts' <- addTickLCmdStmts (recS_stmts stmt)-       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)-       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)-       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)-       ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'-                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }-addTickCmdStmt ApplicativeStmt{} =-  panic "ToDo: addTickCmdStmt ApplicativeLastStmt"---- Others should never happen in a command context.-addTickCmdStmt stmt  = pprPanic "addTickHsCmd" (ppr stmt)--addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)-addTickHsRecordBinds (HsRecFields fields dd)-  = do  { fields' <- mapM addTickHsRecField fields-        ; return (HsRecFields fields' dd) }--addTickHsRecField :: LHsRecField' id (LHsExpr Id) -> TM (LHsRecField' id (LHsExpr Id))-addTickHsRecField (L l (HsRecField id expr pun))-        = do { expr' <- addTickLHsExpr expr-             ; return (L l (HsRecField id expr' pun)) }---addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)-addTickArithSeqInfo (From e1) =-        liftM From-                (addTickLHsExpr e1)-addTickArithSeqInfo (FromThen e1 e2) =-        liftM2 FromThen-                (addTickLHsExpr e1)-                (addTickLHsExpr e2)-addTickArithSeqInfo (FromTo e1 e2) =-        liftM2 FromTo-                (addTickLHsExpr e1)-                (addTickLHsExpr e2)-addTickArithSeqInfo (FromThenTo e1 e2 e3) =-        liftM3 FromThenTo-                (addTickLHsExpr e1)-                (addTickLHsExpr e2)-                (addTickLHsExpr e3)--liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a)-liftL f (L loc a) = do-  a' <- f a-  return $ L loc a'--data TickTransState = TT { tickBoxCount:: Int-                         , mixEntries  :: [MixEntry_]-#ifdef DETERMINISTIC_PROFILING-                         , ccIndices   :: CostCentreState-#else-                         , uniqSupply  :: UniqSupply-#endif-                         }--data TickTransEnv = TTE { fileName     :: FastString-                        , density      :: TickDensity-                        , tte_dflags   :: DynFlags-                        , exports      :: NameSet-                        , inlines      :: VarSet-                        , declPath     :: [String]-                        , inScope      :: VarSet-                        , blackList    :: Map SrcSpan ()-                        , this_mod     :: Module-                        , tickishType  :: TickishType-                        }----      deriving Show--data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes-                 deriving (Eq)--coveragePasses :: DynFlags -> [TickishType]-coveragePasses dflags =-    ifa (hscTarget dflags == HscInterpreted) Breakpoints $-    ifa (gopt Opt_Hpc dflags)                HpcTicks $-    ifa (gopt Opt_SccProfilingOn dflags &&-         profAuto dflags /= NoProfAuto)      ProfNotes $-    ifa (debugLevel dflags > 0)              SourceNotes []-  where ifa f x xs | f         = x:xs-                   | otherwise = xs---- | Tickishs that only make sense when their source code location--- refers to the current file. This might not always be true due to--- LINE pragmas in the code - which would confuse at least HPC.-tickSameFileOnly :: TickishType -> Bool-tickSameFileOnly HpcTicks = True-tickSameFileOnly _other   = False--type FreeVars = OccEnv Id-noFVs :: FreeVars-noFVs = emptyOccEnv---- Note [freevars]---   For breakpoints we want to collect the free variables of an---   expression for pinning on the HsTick.  We don't want to collect---   *all* free variables though: in particular there's no point pinning---   on free variables that are will otherwise be in scope at the GHCi---   prompt, which means all top-level bindings.  Unfortunately detecting---   top-level bindings isn't easy (collectHsBindsBinders on the top-level---   bindings doesn't do it), so we keep track of a set of "in-scope"---   variables in addition to the free variables, and the former is used---   to filter additions to the latter.  This gives us complete control---   over what free variables we track.--data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }-        -- a combination of a state monad (TickTransState) and a writer-        -- monad (FreeVars).--instance Functor TM where-    fmap = liftM--instance Applicative TM where-    pure a = TM $ \ _env st -> (a,noFVs,st)-    (<*>) = ap--instance Monad TM where-  (TM m) >>= k = TM $ \ env st ->-                                case m env st of-                                  (r1,fv1,st1) ->-                                     case unTM (k r1) env st1 of-                                       (r2,fv2,st2) ->-                                          (r2, fv1 `plusOccEnv` fv2, st2)--instance HasDynFlags TM where-  getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st)--#ifdef DETERMINISTIC_PROFILING--- | Get the next HPC cost centre index for a given centre name-getCCIndexM :: FastString -> TM CostCentreIndex-getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $-                                                 ccIndices st-                              in (idx, noFVs, st { ccIndices = is' })-#else-instance MonadUnique TM where-  getUniqueSupplyM = TM $ \_ st -> (uniqSupply st, noFVs, st)-  getUniqueM = TM $ \_ st -> let (u, us') = takeUniqFromSupply (uniqSupply st)-                             in (u, noFVs, st { uniqSupply = us' })-#endif--getState :: TM TickTransState-getState = TM $ \ _ st -> (st, noFVs, st)--setState :: (TickTransState -> TickTransState) -> TM ()-setState f = TM $ \ _ st -> ((), noFVs, f st)--getEnv :: TM TickTransEnv-getEnv = TM $ \ env st -> (env, noFVs, st)--withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a-withEnv f (TM m) = TM $ \ env st ->-                                 case m (f env) st of-                                   (a, fvs, st') -> (a, fvs, st')--getDensity :: TM TickDensity-getDensity = TM $ \env st -> (density env, noFVs, st)--ifDensity :: TickDensity -> TM a -> TM a -> TM a-ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el--getFreeVars :: TM a -> TM (FreeVars, a)-getFreeVars (TM m)-  = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')--freeVar :: Id -> TM ()-freeVar id = TM $ \ env st ->-                if id `elemVarSet` inScope env-                   then ((), unitOccEnv (nameOccName (idName id)) id, st)-                   else ((), noFVs, st)--addPathEntry :: String -> TM a -> TM a-addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })--getPathEntry :: TM [String]-getPathEntry = declPath `liftM` getEnv--getFileName :: TM FastString-getFileName = fileName `liftM` getEnv--isGoodSrcSpan' :: SrcSpan -> Bool-isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos-isGoodSrcSpan' (UnhelpfulSpan _) = False--isGoodTickSrcSpan :: SrcSpan -> TM Bool-isGoodTickSrcSpan pos = do-  file_name <- getFileName-  tickish <- tickishType `liftM` getEnv-  let need_same_file = tickSameFileOnly tickish-      same_file      = Just file_name == srcSpanFileName_maybe pos-  return (isGoodSrcSpan' pos && (not need_same_file || same_file))--ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a-ifGoodTickSrcSpan pos then_code else_code = do-  good <- isGoodTickSrcSpan pos-  if good then then_code else else_code--bindLocals :: [Id] -> TM a -> TM a-bindLocals new_ids (TM m)-  = TM $ \ env st ->-                 case m env{ inScope = inScope env `extendVarSetList` new_ids } st of-                   (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')-  where occs = [ nameOccName (idName id) | id <- new_ids ]--isBlackListed :: SrcSpan -> TM Bool-isBlackListed pos = TM $ \ env st ->-              case Map.lookup pos (blackList env) of-                Nothing -> (False,noFVs,st)-                Just () -> (True,noFVs,st)---- the tick application inherits the source position of its--- expression argument to support nested box allocations-allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr Id)-             -> TM (LHsExpr Id)-allocTickBox boxLabel countEntries topOnly pos m =-  ifGoodTickSrcSpan pos (do-    (fvs, e) <- getFreeVars m-    env <- getEnv-    tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)-    return (L pos (HsTick tickish (L pos e)))-  ) (do-    e <- m-    return (L pos e)-  )---- the tick application inherits the source position of its--- expression argument to support nested box allocations-allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars-              -> TM (Maybe (Tickish Id))-allocATickBox boxLabel countEntries topOnly  pos fvs =-  ifGoodTickSrcSpan pos (do-    let-      mydecl_path = case boxLabel of-                      TopLevelBox x -> x-                      LocalBox xs  -> xs-                      _ -> panic "allocATickBox"-    tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path-    return (Just tickish)-  ) (return Nothing)---mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]-          -> TM (Tickish Id)-mkTickish boxLabel countEntries topOnly pos fvs decl_path = do--  let ids = filter (not . isUnliftedType . idType) $ occEnvElts fvs-          -- unlifted types cause two problems here:-          --   * we can't bind them  at the GHCi prompt-          --     (bindLocalsAtBreakpoint already fliters them out),-          --   * the simplifier might try to substitute a literal for-          --     the Id, and we can't handle that.--      me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel)--      cc_name | topOnly   = head decl_path-              | otherwise = concat (intersperse "." decl_path)--  dflags <- getDynFlags-  env <- getEnv-  case tickishType env of-    HpcTicks -> do-      c <- liftM tickBoxCount getState-      setState $ \st -> st { tickBoxCount = c + 1-                           , mixEntries = me : mixEntries st }-      return $ HpcTick (this_mod env) c--    ProfNotes -> do-#ifdef DETERMINISTIC_PROFILING-      let nm = mkFastString cc_name-      flavour <- HpcCC <$> getCCIndexM nm-      let cc = mkUserCC nm (this_mod env) pos flavour-#else-      ccUnique <- getUniqueM-      let cc = mkUserCC (mkFastString cc_name) (this_mod env) pos ccUnique-#endif-          count = countEntries && gopt Opt_ProfCountEntries dflags-      return $ ProfNote cc count True{-scopes-}--    Breakpoints -> do-      c <- liftM tickBoxCount getState-      setState $ \st -> st { tickBoxCount = c + 1-                           , mixEntries = me:mixEntries st }-      return $ Breakpoint c ids--    SourceNotes | RealSrcSpan pos' <- pos ->-      return $ SourceNote pos' cc_name--    _otherwise -> panic "mkTickish: bad source span!"---allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr Id)-                -> TM (LHsExpr Id)-allocBinTickBox boxLabel pos m = do-  env <- getEnv-  case tickishType env of-    HpcTicks -> do e <- liftM (L pos) m-                   ifGoodTickSrcSpan pos-                     (mkBinTickBoxHpc boxLabel pos e)-                     (return e)-    _other   -> allocTickBox (ExpBox False) False False pos m--mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr Id-                -> TM (LHsExpr Id)-mkBinTickBoxHpc boxLabel pos e =- TM $ \ env st ->-  let meT = (pos,declPath env, [],boxLabel True)-      meF = (pos,declPath env, [],boxLabel False)-      meE = (pos,declPath env, [],ExpBox False)-      c = tickBoxCount st-      mes = mixEntries st-  in-             ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) e-           -- notice that F and T are reversed,-           -- because we are building the list in-           -- reverse...-             , noFVs-             , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}-             )--mkHpcPos :: SrcSpan -> HpcPos-mkHpcPos pos@(RealSrcSpan s)-   | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,-                                    srcSpanStartCol s,-                                    srcSpanEndLine s,-                                    srcSpanEndCol s - 1)-                              -- the end column of a SrcSpan is one-                              -- greater than the last column of the-                              -- span (see SrcLoc), whereas HPC-                              -- expects to the column range to be-                              -- inclusive, hence we subtract one above.-mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"--hpcSrcSpan :: SrcSpan-hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")--matchesOneOfMany :: [LMatch Id body] -> Bool-matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1-  where-        matchCount (L _ (Match _ _pats _ty (GRHSs grhss _binds))) = length grhss--type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)---- For the hash value, we hash everything: the file name,---  the timestamp of the original source file, the tab stop,---  and the mix entries. We cheat, and hash the show'd string.--- This hash only has to be hashed at Mix creation time,--- and is for sanity checking only.--mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int-mixHash file tm tabstop entries = fromIntegral $ hashString-        (show $ Mix file tm 0 tabstop entries)--{--************************************************************************-*                                                                      *-*              initialisation-*                                                                      *-************************************************************************--Each module compiled with -fhpc declares an initialisation function of-the form `hpc_init_<module>()`, which is emitted into the _stub.c file-and annotated with __attribute__((constructor)) so that it gets-executed at startup time.--The function's purpose is to call hs_hpc_module to register this-module with the RTS, and it looks something like this:--static void hpc_init_Main(void) __attribute__((constructor));-static void hpc_init_Main(void)-{extern StgWord64 _hpc_tickboxes_Main_hpc[];- hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);}--}--hpcInitCode :: Module -> HpcInfo -> SDoc-hpcInitCode _ (NoHpcInfo {}) = Outputable.empty-hpcInitCode this_mod (HpcInfo tickCount hashNo)- = vcat-    [ text "static void hpc_init_" <> ppr this_mod-         <> text "(void) __attribute__((constructor));"-    , text "static void hpc_init_" <> ppr this_mod <> text "(void)"-    , braces (vcat [-        text "extern StgWord64 " <> tickboxes <>-               text "[]" <> semi,-        text "hs_hpc_module" <>-          parens (hcat (punctuate comma [-              doubleQuotes full_name_str,-              int tickCount, -- really StgWord32-              int hashNo,    -- really StgWord32-              tickboxes-            ])) <> semi-       ])-    ]-  where-    tickboxes = ppr (mkHpcTicksLabel $ this_mod)--    module_name  = hcat (map (text.charToC) $-                         bytesFS (moduleNameFS (Module.moduleName this_mod)))-    package_name = hcat (map (text.charToC) $-                         bytesFS (unitIdFS  (moduleUnitId this_mod)))-    full_name_str-       | moduleUnitId this_mod == mainUnitId-       = module_name-       | otherwise-       = package_name <> char '/' <> module_name
− src/Language/Haskell/Liquid/Desugar/Desugar.hs 
@@ -1,564 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---The Desugarer: turning HsSyn into Core.--}--{-# LANGUAGE CPP #-}--module Language.Haskell.Liquid.Desugar.Desugar (-    -- * Desugaring operations-    deSugar, deSugarExpr-    ) where--import DsUsage-import DynFlags-import HscTypes-import HsSyn-import TcRnTypes-import TcRnMonad  ( finalSafeMode, fixSafeInstances )-import TcRnDriver ( runTcInteractive )-import Id-import Name-import Type-import InstEnv-import Class-import Avail-import CoreSyn-import CoreFVs     ( exprsSomeFreeVarsList )-import CoreOpt     ( simpleOptPgm, simpleOptExpr )-import PprCore-import Language.Haskell.Liquid.Desugar.DsMonad-import Language.Haskell.Liquid.Desugar.DsExpr-import Language.Haskell.Liquid.Desugar.DsBinds-import Language.Haskell.Liquid.Desugar.DsForeign-import PrelNames   ( coercibleTyConKey )-import TysPrim     ( eqReprPrimTyCon )-import Unique      ( hasKey )-import Coercion    ( mkCoVarCo )-import TysWiredIn  ( coercibleDataCon )-import DataCon     ( dataConWrapId )-import MkCore      ( mkCoreLet )-import Module-import NameSet-import NameEnv-import Rules-import BasicTypes       ( Activation(.. ), competesWith, pprRuleName )-import CoreMonad        ( CoreToDo(..) )-import CoreLint         ( endPassIO )-import VarSet-import FastString-import ErrUtils-import Outputable-import SrcLoc-import Language.Haskell.Liquid.Desugar.Coverage-import Util-import MonadUtils-import OrdList--import Data.List-import Data.IORef-import Control.Monad( when )--{--************************************************************************-*                                                                      *-*              The main function: deSugar-*                                                                      *-************************************************************************--}---- | Main entry point to the desugarer.-deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)--- Can modify PCS by faulting in more declarations--deSugar hsc_env-        mod_loc-        tcg_env@(TcGblEnv { tcg_semantic_mod = mod,-                            tcg_src          = hsc_src,-                            tcg_type_env     = type_env,-                            tcg_imports      = imports,-                            tcg_exports      = exports,-                            tcg_keep         = keep_var,-                            tcg_th_splice_used = tc_splice_used,-                            tcg_rdr_env      = rdr_env,-                            tcg_fix_env      = fix_env,-                            tcg_inst_env     = inst_env,-                            tcg_fam_inst_env = fam_inst_env,-                            tcg_merged       = merged,-                            tcg_warns        = warns,-                            tcg_anns         = anns,-                            tcg_binds        = binds,-                            tcg_imp_specs    = imp_specs,-                            tcg_dependent_files = dependent_files,-                            tcg_ev_binds     = ev_binds,-                            tcg_th_foreign_files = th_foreign_files_var,-                            tcg_fords        = fords,-                            tcg_rules        = rules,-                            tcg_vects        = vects,-                            tcg_patsyns      = patsyns,-                            tcg_tcs          = tcs,-                            tcg_insts        = insts,-                            tcg_fam_insts    = fam_insts,-                            tcg_hpc          = other_hpc_info,-                            tcg_complete_matches = complete_matches-                            })--  = do { let dflags = hsc_dflags hsc_env-             print_unqual = mkPrintUnqualified dflags rdr_env-        ; withTiming (pure dflags)-                     (text "Desugar"<+>brackets (ppr mod))-                     (const ()) $-     do { -- Desugar the program-        ; let export_set = availsToNameSet exports-              target     = hscTarget dflags-              hpcInfo    = emptyHpcInfo other_hpc_info--        ; (binds_cvr, ds_hpc_info, modBreaks)-                         <- if not (isHsBootOrSig hsc_src)-                              then addTicksToBinds hsc_env mod mod_loc-                                       export_set (typeEnvTyCons type_env) binds-                              else return (binds, hpcInfo, Nothing)-        ; (msgs, mb_res) <- initDs hsc_env tcg_env $-                       do { ds_ev_binds <- dsEvBinds ev_binds-                          ; core_prs <- dsTopLHsBinds binds_cvr-                          ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs-                          ; (ds_fords, foreign_prs) <- dsForeigns fords-                          ; ds_rules <- mapMaybeM dsRule rules-                          ; ds_vects <- mapM dsVect vects-                          ; let hpc_init-                                  | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info-                                  | otherwise = empty-                          ; return ( ds_ev_binds-                                   , foreign_prs `appOL` core_prs `appOL` spec_prs-                                   , spec_rules ++ ds_rules, ds_vects-                                   , ds_fords `appendStubC` hpc_init) }--        ; case mb_res of {-           Nothing -> return (msgs, Nothing) ;-           Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) ->--     do {       -- Add export flags to bindings-          keep_alive <- readIORef keep_var-        ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules-              final_prs = addExportFlagsAndRules target export_set keep_alive-                                                 rules_for_locals (fromOL all_prs)--              final_pgm = combineEvBinds ds_ev_binds final_prs-        -- Notice that we put the whole lot in a big Rec, even the foreign binds-        -- When compiling PrelFloat, which defines data Float = F# Float#-        -- we want F# to be in scope in the foreign marshalling code!-        -- You might think it doesn't matter, but the simplifier brings all top-level-        -- things into the in-scope set before simplifying; so we get no unfolding for F#!--#ifdef DEBUG-          -- Debug only as pre-simple-optimisation program may be really big-        ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps-#endif-        ; (ds_binds, ds_rules_for_imps, ds_vects)-            <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0-                         -- The simpleOptPgm gets rid of type-                         -- bindings plus any stupid dead code--        ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps--        ; let used_names = mkUsedNames tcg_env-        ; deps <- mkDependencies tcg_env--        ; used_th <- readIORef tc_splice_used-        ; dep_files <- readIORef dependent_files-        ; safe_mode <- finalSafeMode dflags tcg_env-        ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names dep_files merged-        -- id_mod /= mod when we are processing an hsig, but hsigs-        -- never desugared and compiled (there's no code!)-        -- Consequently, this should hold for any ModGuts that make-        -- past desugaring. See Note [Identity versus semantic module].-        --; MASSERT( id_mod == mod )--        ; foreign_files <- readIORef th_foreign_files_var--        ; let mod_guts = ModGuts {-                mg_module       = mod,-                mg_hsc_src      = hsc_src,-                mg_loc          = mkFileSrcSpan mod_loc,-                mg_exports      = exports,-                mg_usages       = usages,-                mg_deps         = deps,-                mg_used_th      = used_th,-                mg_rdr_env      = rdr_env,-                mg_fix_env      = fix_env,-                mg_warns        = warns,-                mg_anns         = anns,-                mg_tcs          = tcs,-                mg_insts        = fixSafeInstances safe_mode insts,-                mg_fam_insts    = fam_insts,-                mg_inst_env     = inst_env,-                mg_fam_inst_env = fam_inst_env,-                mg_patsyns      = patsyns,-                mg_rules        = ds_rules_for_imps,-                mg_binds        = ds_binds,-                mg_foreign      = ds_fords,-                mg_foreign_files = foreign_files,-                mg_hpc_info     = ds_hpc_info,-                mg_modBreaks    = modBreaks,-                mg_vect_decls   = ds_vects,-                mg_vect_info    = noVectInfo,-                mg_safe_haskell = safe_mode,-                mg_trust_pkg    = imp_trust_own_pkg imports,-                mg_complete_sigs = complete_matches-              }-        ; return (msgs, Just mod_guts)-        }}}}--mkFileSrcSpan :: ModLocation -> SrcSpan-mkFileSrcSpan mod_loc-  = case ml_hs_file mod_loc of-      Just file_path -> mkGeneralSrcSpan (mkFastString file_path)-      Nothing        -> interactiveSrcSpan   -- Presumably--dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])-dsImpSpecs imp_specs- = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs-      ; let (spec_binds, spec_rules) = unzip spec_prs-      ; return (concatOL spec_binds, spec_rules) }--combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]--- Top-level bindings can include coercion bindings, but not via superclasses--- See Note [Top-level evidence]-combineEvBinds [] val_prs-  = [Rec val_prs]-combineEvBinds (NonRec b r : bs) val_prs-  | isId b    = combineEvBinds bs ((b,r):val_prs)-  | otherwise = NonRec b r : combineEvBinds bs val_prs-combineEvBinds (Rec prs : bs) val_prs-  = combineEvBinds bs (prs ++ val_prs)--{--Note [Top-level evidence]-~~~~~~~~~~~~~~~~~~~~~~~~~-Top-level evidence bindings may be mutually recursive with the top-level value-bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec-because the occurrence analyser doesn't teke account of type/coercion variables-when computing dependencies.--So we pull out the type/coercion variables (which are in dependency order),-and Rec the rest.--}--deSugarExpr :: HscEnv -> LHsExpr Id -> IO (Messages, Maybe CoreExpr)--deSugarExpr hsc_env tc_expr = do {-         let dflags = hsc_dflags hsc_env--       ; showPass dflags "Desugar"--         -- Do desugaring-       ; (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $-                                 dsLExpr tc_expr--       ; case mb_core_expr of-            Nothing   -> return ()-            Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared"-                         (pprCoreExpr expr)--       ; return (msgs, mb_core_expr) }--{--************************************************************************-*                                                                      *-*              Add rules and export flags to binders-*                                                                      *-************************************************************************--}--addExportFlagsAndRules-    :: HscTarget -> NameSet -> NameSet -> [CoreRule]-    -> [(Id, t)] -> [(Id, t)]-addExportFlagsAndRules target exports keep_alive rules prs-  = mapFst add_one prs-  where-    add_one bndr = add_rules name (add_export name bndr)-       where-         name = idName bndr--    ---------- Rules ---------        -- See Note [Attach rules to local ids]-        -- NB: the binder might have some existing rules,-        -- arising from specialisation pragmas-    add_rules name bndr-        | Just rules <- lookupNameEnv rule_base name-        = bndr `addIdSpecialisations` rules-        | otherwise-        = bndr-    rule_base = extendRuleBaseList emptyRuleBase rules--    ---------- Export flag ---------    -- See Note [Adding export flags]-    add_export name bndr-        | dont_discard name = setIdExported bndr-        | otherwise         = bndr--    dont_discard :: Name -> Bool-    dont_discard name = is_exported name-                     || name `elemNameSet` keep_alive--        -- In interactive mode, we don't want to discard any top-level-        -- entities at all (eg. do not inline them away during-        -- simplification), and retain them all in the TypeEnv so they are-        -- available from the command line.-        ---        -- isExternalName separates the user-defined top-level names from those-        -- introduced by the type checker.-    is_exported :: Name -> Bool-    is_exported | targetRetainsAllBindings target = isExternalName-                | otherwise                       = (`elemNameSet` exports)--{--Note [Adding export flags]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Set the no-discard flag if either-        a) the Id is exported-        b) it's mentioned in the RHS of an orphan rule-        c) it's in the keep-alive set--It means that the binding won't be discarded EVEN if the binding-ends up being trivial (v = w) -- the simplifier would usually just-substitute w for v throughout, but we don't apply the substitution to-the rules (maybe we should?), so this substitution would make the rule-bogus.--You might wonder why exported Ids aren't already marked as such;-it's just because the type checker is rather busy already and-I didn't want to pass in yet another mapping.--Note [Attach rules to local ids]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Find the rules for locally-defined Ids; then we can attach them-to the binders in the top-level bindings--Reason-  - It makes the rules easier to look up-  - It means that transformation rules and specialisations for-    locally defined Ids are handled uniformly-  - It keeps alive things that are referred to only from a rule-    (the occurrence analyser knows about rules attached to Ids)-  - It makes sure that, when we apply a rule, the free vars-    of the RHS are more likely to be in scope-  - The imported rules are carried in the in-scope set-    which is extended on each iteration by the new wave of-    local binders; any rules which aren't on the binding will-    thereby get dropped---************************************************************************-*                                                                      *-*              Desugaring transformation rules-*                                                                      *-************************************************************************--}--dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)-dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs))-  = putSrcSpanDs loc $-    do  { let bndrs' = [var | L _ (RuleBndr (L _ var)) <- vars]--        ; lhs' <- unsetGOptM Opt_EnableRewriteRules $-                  unsetWOptM Opt_WarnIdentities $-                  dsLExpr lhs   -- Note [Desugaring RULE left hand sides]--        ; rhs' <- dsLExpr rhs-        ; this_mod <- getModule--        ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'--        -- Substitute the dict bindings eagerly,-        -- and take the body apart into a (f args) form-        ; case decomposeRuleLhs bndrs'' lhs'' of {-                Left msg -> do { warnDs NoReason msg; return Nothing } ;-                Right (final_bndrs, fn_id, args) -> do--        { let is_local = isLocalId fn_id-                -- NB: isLocalId is False of implicit Ids.  This is good because-                -- we don't want to attach rules to the bindings of implicit Ids,-                -- because they don't show up in the bindings until just before code gen-              fn_name   = idName fn_id-              final_rhs = simpleOptExpr rhs''    -- De-crap it-              rule_name = snd (unLoc name)-              final_bndrs_set = mkVarSet final_bndrs-              arg_ids = filterOut (`elemVarSet` final_bndrs_set) $-                        exprsSomeFreeVarsList isId args--        ; dflags <- getDynFlags-        ; rule <- dsMkUserRule this_mod is_local-                         rule_name rule_act fn_name final_bndrs args-                         final_rhs-        ; when (wopt Opt_WarnInlineRuleShadowing dflags) $-          warnRuleShadowing rule_name rule_act fn_id arg_ids--        ; return (Just rule)-        } } }---warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()--- See Note [Rules and inlining/other rules]-warnRuleShadowing rule_name rule_act fn_id arg_ids-  = do { check False fn_id    -- We often have multiple rules for the same Id in a-                              -- module. Maybe we should check that they don't overlap-                              -- but currently we don't-       ; mapM_ (check True) arg_ids }-  where-    check check_rules_too lhs_id-      | isLocalId lhs_id || canUnfold (idUnfolding lhs_id)-                       -- If imported with no unfolding, no worries-      , idInlineActivation lhs_id `competesWith` rule_act-      = warnDs (Reason Opt_WarnInlineRuleShadowing)-               (vcat [ hang (text "Rule" <+> pprRuleName rule_name-                               <+> text "may never fire")-                            2 (text "because" <+> quotes (ppr lhs_id)-                               <+> text "might inline first")-                     , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for"-                       <+> quotes (ppr lhs_id)-                     , ifPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ])--      | check_rules_too-      , bad_rule : _ <- get_bad_rules lhs_id-      = warnDs (Reason Opt_WarnInlineRuleShadowing)-               (vcat [ hang (text "Rule" <+> pprRuleName rule_name-                               <+> text "may never fire")-                            2 (text "because rule" <+> pprRuleName (ruleName bad_rule)-                               <+> text "for"<+> quotes (ppr lhs_id)-                               <+> text "might fire first")-                      , text "Probable fix: add phase [n] or [~n] to the competing rule"-                      , ifPprDebug (ppr bad_rule) ])--      | otherwise-      = return ()--    get_bad_rules lhs_id-      = [ rule | rule <- idCoreRules lhs_id-               , ruleActivation rule `competesWith` rule_act ]---- See Note [Desugaring coerce as cast]-unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr)-unfold_coerce bndrs lhs rhs = do-    (bndrs', wrap) <- go bndrs-    return (bndrs', wrap lhs, wrap rhs)-  where-    go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)-    go []     = return ([], id)-    go (v:vs)-        | Just (tc, [k, t1, t2]) <- splitTyConApp_maybe (idType v)-        , tc `hasKey` coercibleTyConKey = do-            u <- newUnique--            let ty' = mkTyConApp eqReprPrimTyCon [k, k, t1, t2]-                v'  = mkLocalCoVar-                        (mkDerivedInternalName mkRepEqOcc u (getName v)) ty'-                box = Var (dataConWrapId coercibleDataCon) `mkTyApps`-                      [k, t1, t2] `App`-                      Coercion (mkCoVarCo v')--            (bndrs, wrap) <- go vs-            return (v':bndrs, mkCoreLet (NonRec v box) . wrap)-        | otherwise = do-            (bndrs,wrap) <- go vs-            return (v:bndrs, wrap)--{- Note [Desugaring RULE left hand sides]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For the LHS of a RULE we do *not* want to desugar-    [x]   to    build (\cn. x `c` n)-We want to leave explicit lists simply as chains-of cons's. We can achieve that slightly indirectly by-switching off EnableRewriteRules.  See DsExpr.dsExplicitList.--That keeps the desugaring of list comprehensions simple too.--Nor do we want to warn of conversion identities on the LHS;-the rule is precisly to optimise them:-  {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}--Note [Desugaring coerce as cast]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We want the user to express a rule saying roughly “mapping a coercion over a-list can be replaced by a coercion”. But the cast operator of Core (▷) cannot-be written in Haskell. So we use `coerce` for that (#2110). The user writes-    map coerce = coerce-as a RULE, and this optimizes any kind of mapped' casts away, including `map-MkNewtype`.--For that we replace any forall'ed `c :: Coercible a b` value in a RULE by-corresponding `co :: a ~#R b` and wrap the LHS and the RHS in-`let c = MkCoercible co in ...`. This is later simplified to the desired form-by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).-See also Note [Getting the map/coerce RULE to work] in CoreSubst.--Note [Rules and inlining/other rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If you have-  f x = ...-  g x = ...-  {-# RULES "rule-for-f" forall x. f (g x) = ... #-}-then there's a good chance that in a potential rule redex-    ...f (g e)...-then 'f' or 'g' will inline befor the rule can fire.  Solution: add an-INLINE [n] or NOINLINE [n] pragma to 'f' and 'g'.--Note that this applies to all the free variables on the LHS, both the-main function and things in its arguments.--We also check if there are Ids on the LHS that have competing RULES.-In the above example, suppose we had-  {-# RULES "rule-for-g" forally. g [y] = ... #-}-Then "rule-for-f" and "rule-for-g" would compete.  Better to add phase-control, so "rule-for-f" has a chance to fire before "rule-for-g" becomes-active; or perhpas after "rule-for-g" has become inactive. This is checked-by 'competesWith'--Class methods have a built-in RULE to select the method from the dictionary,-so you can't change the phase on this.  That makes id very dubious to-match on class methods in RULE lhs's.   See Trac #10595.   I'm not happy-about this. For example in Control.Arrow we have--{-# RULES "compose/arr"   forall f g .-                          (arr f) . (arr g) = arr (f . g) #-}--and similar, which will elicit exactly these warnings, and risk never-firing.  But it's not clear what to do instead.  We could make the-class methocd rules inactive in phase 2, but that would delay when-subsequent transformations could fire.---************************************************************************-*                                                                      *-*              Desugaring vectorisation declarations-*                                                                      *-************************************************************************--}--dsVect :: LVectDecl Id -> DsM CoreVect-dsVect (L loc (HsVect _ (L _ v) rhs))-  = putSrcSpanDs loc $-    do { rhs' <- dsLExpr rhs-       ; return $ Vect v rhs'-       }-dsVect (L _loc (HsNoVect _ (L _ v)))-  = return $ NoVect v-dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))-  = return $ VectType isScalar tycon' rhs_tycon-  where-    tycon' | Just ty <- coreView $ mkTyConTy tycon-           , (tycon', []) <- splitTyConApp ty      = tycon'-           | otherwise                             = tycon-dsVect vd@(L _ (HsVectTypeIn _ _ _ _))-  = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)-dsVect (L _loc (HsVectClassOut cls))-  = return $ VectClass (classTyCon cls)-dsVect vc@(L _ (HsVectClassIn _ _))-  = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc)-dsVect (L _loc (HsVectInstOut inst))-  = return $ VectInst (instanceDFunId inst)-dsVect vi@(L _ (HsVectInstIn _))-  = pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi)
− src/Language/Haskell/Liquid/Desugar/DsArrows.hs 
@@ -1,1228 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---Desugaring arrow commands--}--{-# LANGUAGE CPP #-}--module Language.Haskell.Liquid.Desugar.DsArrows ( dsProcExpr ) where--import Language.Haskell.Liquid.Desugar.Match-import Language.Haskell.Liquid.Desugar.DsUtils-import Language.Haskell.Liquid.Desugar.DsMonad--import HsSyn    hiding (collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectLStmtBinders, collectStmtBinders )-import TcHsSyn-import qualified HsUtils---- NB: The desugarer, which straddles the source and Core worlds, sometimes---     needs to see source types (newtypes etc), and sometimes not---     So WATCH OUT; check each use of split*Ty functions.--- Sigh.  This is a pain.--import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )--import TcType-import Type ( splitPiTy )-import TcEvidence-import CoreSyn-import CoreFVs-import CoreUtils-import MkCore-import Language.Haskell.Liquid.Desugar.DsBinds (dsHsWrapper)--import Name-import Var-import Id-import ConLike-import TysWiredIn-import BasicTypes-import PrelNames-import Outputable-import Bag-import VarSet-import SrcLoc-import ListSetOps( assocMaybe )-import Data.List-import Util-import UniqDFM-import UniqSet--data DsCmdEnv = DsCmdEnv {-        arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr-    }--mkCmdEnv :: CmdSyntaxTable Id -> DsM ([CoreBind], DsCmdEnv)--- See Note [CmdSyntaxTable] in HsExpr-mkCmdEnv tc_meths-  = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths--       -- NB: Some of these lookups might fail, but that's OK if the-       -- symbol is never used. That's why we use Maybe first and then-       -- panic. An eager panic caused trouble in typecheck/should_compile/tc192-       ; let the_arr_id     = assocMaybe prs arrAName-             the_compose_id = assocMaybe prs composeAName-             the_first_id   = assocMaybe prs firstAName-             the_app_id     = assocMaybe prs appAName-             the_choice_id  = assocMaybe prs choiceAName-             the_loop_id    = assocMaybe prs loopAName--           -- used as an argument in, e.g., do_premap-       ; check_lev_poly 3 the_arr_id--           -- used as an argument in, e.g., dsCmdStmt/BodyStmt-       ; check_lev_poly 5 the_compose_id--           -- used as an argument in, e.g., dsCmdStmt/BodyStmt-       ; check_lev_poly 4 the_first_id--           -- the result of the_app_id is used as an argument in, e.g.,-           -- dsCmd/HsCmdArrApp/HsHigherOrderApp-       ; check_lev_poly 2 the_app_id--           -- used as an argument in, e.g., HsCmdIf-       ; check_lev_poly 5 the_choice_id--           -- used as an argument in, e.g., RecStmt-       ; check_lev_poly 4 the_loop_id--       ; return (meth_binds, DsCmdEnv {-               arr_id     = Var (unmaybe the_arr_id arrAName),-               compose_id = Var (unmaybe the_compose_id composeAName),-               first_id   = Var (unmaybe the_first_id firstAName),-               app_id     = Var (unmaybe the_app_id appAName),-               choice_id  = Var (unmaybe the_choice_id choiceAName),-               loop_id    = Var (unmaybe the_loop_id loopAName)-             }) }-  where-    mk_bind (std_name, expr)-      = do { rhs <- dsExpr expr-           ; id <- newSysLocalDs (exprType rhs)  -- no check needed; these are functions-           ; return (NonRec id rhs, (std_name, id)) }--    unmaybe Nothing name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr name)-    unmaybe (Just id) _  = id--      -- returns the result type of a pi-type (that is, a forall or a function)-      -- Note that this result type may be ill-scoped.-    res_type :: Type -> Type-    res_type ty = res_ty-      where-        (_, res_ty) = splitPiTy ty--    check_lev_poly :: Int -- arity-                   -> Maybe Id -> DsM ()-    check_lev_poly _     Nothing = return ()-    check_lev_poly arity (Just id)-      = dsNoLevPoly (nTimes arity res_type (idType id))-          (text "In the result of the function" <+> quotes (ppr id))----- arr :: forall b c. (b -> c) -> a b c-do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr-do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f]---- (>>>) :: forall b c d. a b c -> a c d -> a b d-do_compose :: DsCmdEnv -> Type -> Type -> Type ->-                CoreExpr -> CoreExpr -> CoreExpr-do_compose ids b_ty c_ty d_ty f g-  = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g]---- first :: forall b c d. a b c -> a (b,d) (c,d)-do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr-do_first ids b_ty c_ty d_ty f-  = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f]---- app :: forall b c. a (a b c, b) c-do_app :: DsCmdEnv -> Type -> Type -> CoreExpr-do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty]---- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d--- note the swapping of d and c-do_choice :: DsCmdEnv -> Type -> Type -> Type ->-                CoreExpr -> CoreExpr -> CoreExpr-do_choice ids b_ty c_ty d_ty f g-  = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g]---- loop :: forall b d c. a (b,d) (c,d) -> a b c--- note the swapping of d and c-do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr-do_loop ids b_ty c_ty d_ty f-  = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f]---- premap :: forall b c d. (b -> c) -> a c d -> a b d--- premap f g = arr f >>> g-do_premap :: DsCmdEnv -> Type -> Type -> Type ->-                CoreExpr -> CoreExpr -> CoreExpr-do_premap ids b_ty c_ty d_ty f g-   = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g--mkFailExpr :: HsMatchContext Id -> Type -> DsM CoreExpr-mkFailExpr ctxt ty-  = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)---- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a-mkFstExpr :: Type -> Type -> DsM CoreExpr-mkFstExpr a_ty b_ty = do-    a_var <- newSysLocalDs a_ty-    b_var <- newSysLocalDs b_ty-    pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)-    return (Lam pair_var-               (coreCasePair pair_var a_var b_var (Var a_var)))---- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b-mkSndExpr :: Type -> Type -> DsM CoreExpr-mkSndExpr a_ty b_ty = do-    a_var <- newSysLocalDs a_ty-    b_var <- newSysLocalDs b_ty-    pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)-    return (Lam pair_var-               (coreCasePair pair_var a_var b_var (Var b_var)))--{--Build case analysis of a tuple.  This cannot be done in the DsM monad,-because the list of variables is typically not yet defined.--}---- coreCaseTuple [u1..] v [x1..xn] body---      = case v of v { (x1, .., xn) -> body }--- But the matching may be nested if the tuple is very big--coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr-coreCaseTuple uniqs scrut_var vars body-  = mkTupleCase uniqs vars body scrut_var (Var scrut_var)--coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr-coreCasePair scrut_var var1 var2 body-  = Case (Var scrut_var) scrut_var (exprType body)-         [(DataAlt (tupleDataCon Boxed 2), [var1, var2], body)]--mkCorePairTy :: Type -> Type -> Type-mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2]--mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr-mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]--mkCoreUnitExpr :: CoreExpr-mkCoreUnitExpr = mkCoreTup []--{--The input is divided into a local environment, which is a flat tuple-(unless it's too big), and a stack, which is a right-nested pair.-In general, the input has the form--        ((x1,...,xn), (s1,...(sk,())...))--where xi are the environment values, and si the ones on the stack,-with s1 being the "top", the first one to be matched with a lambda.--}--envStackType :: [Id] -> Type -> Type-envStackType ids stack_ty = mkCorePairTy (mkBigCoreVarTupTy ids) stack_ty---- splitTypeAt n (t1,... (tn,t)...) = ([t1, ..., tn], t)-splitTypeAt :: Int -> Type -> ([Type], Type)-splitTypeAt n ty-  | n == 0 = ([], ty)-  | otherwise = case tcTyConAppArgs ty of-      [t, ty'] -> let (ts, ty_r) = splitTypeAt (n-1) ty' in (t:ts, ty_r)-      _ -> pprPanic "splitTypeAt" (ppr ty)---------------------------------------------------              buildEnvStack------      ((x1,...,xn),stk)--buildEnvStack :: [Id] -> Id -> CoreExpr-buildEnvStack env_ids stack_id-  = mkCorePairExpr (mkBigCoreVarTup env_ids) (Var stack_id)---------------------------------------------------              matchEnvStack------      \ ((x1,...,xn),stk) -> body---      =>---      \ pair ->---      case pair of (tup,stk) ->---      case tup of (x1,...,xn) ->---      body--matchEnvStack   :: [Id]         -- x1..xn-                -> Id           -- stk-                -> CoreExpr     -- e-                -> DsM CoreExpr-matchEnvStack env_ids stack_id body = do-    uniqs <- newUniqueSupply-    tup_var <- newSysLocalDs (mkBigCoreVarTupTy env_ids)-    let match_env = coreCaseTuple uniqs tup_var env_ids body-    pair_id <- newSysLocalDs (mkCorePairTy (idType tup_var) (idType stack_id))-    return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env))---------------------------------------------------              matchEnv------      \ (x1,...,xn) -> body---      =>---      \ tup ->---      case tup of (x1,...,xn) ->---      body--matchEnv :: [Id]        -- x1..xn-         -> CoreExpr    -- e-         -> DsM CoreExpr-matchEnv env_ids body = do-    uniqs <- newUniqueSupply-    tup_id <- newSysLocalDs (mkBigCoreVarTupTy env_ids)-    return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body))---------------------------------------------------              matchVarStack------      case (x1, ...(xn, s)...) -> e---      =>---      case z0 of (x1,z1) ->---      case zn-1 of (xn,s) ->---      e-matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr)-matchVarStack [] stack_id body = return (stack_id, body)-matchVarStack (param_id:param_ids) stack_id body = do-    (tail_id, tail_code) <- matchVarStack param_ids stack_id body-    pair_id <- newSysLocalDs (mkCorePairTy (idType param_id) (idType tail_id))-    return (pair_id, coreCasePair pair_id param_id tail_id tail_code)--mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr Id-mkHsEnvStackExpr env_ids stack_id-  = mkLHsTupleExpr [mkLHsVarTuple env_ids, nlHsVar stack_id]---- Translation of arrow abstraction---- D; xs |-a c : () --> t'      ---> c'--- ----------------------------- D |- proc p -> c :: a t t'   ---> premap (\ p -> ((xs),())) c'------              where (xs) is the tuple of variables bound by p--dsProcExpr-        :: LPat Id-        -> LHsCmdTop Id-        -> DsM CoreExpr-dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do-    (meth_binds, meth_ids) <- mkCmdEnv ids-    let locals = mkVarSet (collectPatBinders pat)-    (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals unitTy cmd_ty cmd-    let env_ty = mkBigCoreVarTupTy env_ids-    let env_stk_ty = mkCorePairTy env_ty unitTy-    let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr-    fail_expr <- mkFailExpr ProcExpr env_stk_ty-    var <- selectSimpleMatchVarL pat-    match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr-    let pat_ty = hsLPatType pat-    let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty-                    (Lam var match_code)-                    core_cmd-    return (mkLets meth_binds proc_code)--{--Translation of a command judgement of the form--        D; xs |-a c : stk --> t--to an expression e such that--        D |- e :: a (xs, stk) t--}--dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd Id -> [Id]-       -> DsM (CoreExpr, DIdSet)-dsLCmd ids local_vars stk_ty res_ty cmd env_ids-  = dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids--dsCmd   :: DsCmdEnv             -- arrow combinators-        -> IdSet                -- set of local vars available to this command-        -> Type                 -- type of the stack (right-nested tuple)-        -> Type                 -- return type of the command-        -> HsCmd Id             -- command to desugar-        -> [Id]                 -- list of vars in the input to this command-                                -- This is typically fed back,-                                -- so don't pull on it too early-        -> DsM (CoreExpr,       -- desugared expression-                DIdSet)         -- subset of local vars that occur free---- D |- fun :: a t1 t2--- D, xs |- arg :: t1--- -------------------------------- D; xs |-a fun -< arg : stk --> t2------              ---> premap (\ ((xs), _stk) -> arg) fun--dsCmd ids local_vars stack_ty res_ty-        (HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _)-        env_ids = do-    let-        (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty-        (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty-    core_arrow <- dsLExprNoLP arrow-    core_arg   <- dsLExpr arg-    stack_id   <- newSysLocalDs stack_ty-    core_make_arg <- matchEnvStack env_ids stack_id core_arg-    return (do_premap ids-              (envStackType env_ids stack_ty)-              arg_ty-              res_ty-              core_make_arg-              core_arrow,-            exprFreeIdsDSet core_arg `udfmIntersectUFM` (getUniqSet local_vars))---- D, xs |- fun :: a t1 t2--- D, xs |- arg :: t1--- --------------------------------- D; xs |-a fun -<< arg : stk --> t2------              ---> premap (\ ((xs), _stk) -> (fun, arg)) app--dsCmd ids local_vars stack_ty res_ty-        (HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _)-        env_ids = do-    let-        (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty-        (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty--    core_arrow <- dsLExpr arrow-    core_arg   <- dsLExpr arg-    stack_id   <- newSysLocalDs stack_ty-    core_make_pair <- matchEnvStack env_ids stack_id-          (mkCorePairExpr core_arrow core_arg)--    return (do_premap ids-              (envStackType env_ids stack_ty)-              (mkCorePairTy arrow_ty arg_ty)-              res_ty-              core_make_pair-              (do_app ids arg_ty res_ty),-            (exprsFreeIdsDSet [core_arrow, core_arg])-              `udfmIntersectUFM` getUniqSet local_vars)---- D; ys |-a cmd : (t,stk) --> t'--- D, xs |-  exp :: t--- --------------------------- D; xs |-a cmd exp : stk --> t'------              ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd--dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do-    core_arg <- dsLExpr arg-    let-        arg_ty = exprType core_arg-        stack_ty' = mkCorePairTy arg_ty stack_ty-    (core_cmd, free_vars, env_ids')-             <- dsfixCmd ids local_vars stack_ty' res_ty cmd-    stack_id <- newSysLocalDs stack_ty-    arg_id <- newSysLocalDsNoLP arg_ty-    -- push the argument expression onto the stack-    let-        stack' = mkCorePairExpr (Var arg_id) (Var stack_id)-        core_body = bindNonRec arg_id core_arg-                        (mkCorePairExpr (mkBigCoreVarTup env_ids') stack')--    -- match the environment and stack against the input-    core_map <- matchEnvStack env_ids stack_id core_body-    return (do_premap ids-                      (envStackType env_ids stack_ty)-                      (envStackType env_ids' stack_ty')-                      res_ty-                      core_map-                      core_cmd,-            free_vars `unionDVarSet`-              (exprFreeIdsDSet core_arg `udfmIntersectUFM` getUniqSet local_vars))---- D; ys |-a cmd : stk t'--- -------------------------------------------------- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t'------              ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd--dsCmd ids local_vars stack_ty res_ty-        (HsCmdLam (MG { mg_alts = L _ [L _ (Match _ pats _-                                           (GRHSs [L _ (GRHS [] body)] _ ))] }))-        env_ids = do-    let pat_vars = mkVarSet (collectPatsBinders pats)-    let-        local_vars' = pat_vars `unionVarSet` local_vars-        (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty-    (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty' res_ty body-    param_ids <- mapM newSysLocalDsNoLP pat_tys-    stack_id' <- newSysLocalDs stack_ty'--    -- the expression is built from the inside out, so the actions-    -- are presented in reverse order--    let-        -- build a new environment, plus what's left of the stack-        core_expr = buildEnvStack env_ids' stack_id'-        in_ty = envStackType env_ids stack_ty-        in_ty' = envStackType env_ids' stack_ty'--    fail_expr <- mkFailExpr LambdaExpr in_ty'-    -- match the patterns against the parameters-    match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr fail_expr-    -- match the parameters against the top of the old stack-    (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code-    -- match the old environment and stack against the input-    select_code <- matchEnvStack env_ids stack_id param_code-    return (do_premap ids in_ty in_ty' res_ty select_code core_body,-            free_vars `udfmMinusUFM` getUniqSet pat_vars)--dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids-  = dsLCmd ids local_vars stack_ty res_ty cmd env_ids---- D, xs |- e :: Bool--- D; xs1 |-a c1 : stk --> t--- D; xs2 |-a c2 : stk --> t--- ------------------------------------------- D; xs |-a if e then c1 else c2 : stk --> t------              ---> premap (\ ((xs),stk) ->---                       if e then Left ((xs1),stk) else Right ((xs2),stk))---                     (c1 ||| c2)--dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)-        env_ids = do-    core_cond <- dsLExpr cond-    (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack_ty res_ty then_cmd-    (core_else, fvs_else, else_ids) <- dsfixCmd ids local_vars stack_ty res_ty else_cmd-    stack_id   <- newSysLocalDs stack_ty-    either_con <- dsLookupTyCon eitherTyConName-    left_con   <- dsLookupDataCon leftDataConName-    right_con  <- dsLookupDataCon rightDataConName--    let mk_left_expr ty1 ty2 e = mkCoreConApps left_con   [Type ty1, Type ty2, e]-        mk_right_expr ty1 ty2 e = mkCoreConApps right_con [Type ty1, Type ty2, e]--        in_ty = envStackType env_ids stack_ty-        then_ty = envStackType then_ids stack_ty-        else_ty = envStackType else_ids stack_ty-        sum_ty = mkTyConApp either_con [then_ty, else_ty]-        fvs_cond = exprFreeIdsDSet core_cond `udfmIntersectUFM` getUniqSet local_vars--        core_left  = mk_left_expr  then_ty else_ty (buildEnvStack then_ids stack_id)-        core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_id)--    core_if <- case mb_fun of-       Just fun -> do { fun_apps <- dsSyntaxExpr fun [core_cond, core_left, core_right]-                      ; matchEnvStack env_ids stack_id fun_apps }-       Nothing  -> matchEnvStack env_ids stack_id $-                   mkIfThenElse core_cond core_left core_right--    return (do_premap ids in_ty sum_ty res_ty-                core_if-                (do_choice ids then_ty else_ty res_ty core_then core_else),-        fvs_cond `unionDVarSet` fvs_then `unionDVarSet` fvs_else)--{--Case commands are treated in much the same way as if commands-(see above) except that there are more alternatives.  For example--        case e of { p1 -> c1; p2 -> c2; p3 -> c3 }--is translated to--        premap (\ ((xs)*ts) -> case e of-                p1 -> (Left (Left (xs1)*ts))-                p2 -> Left ((Right (xs2)*ts))-                p3 -> Right ((xs3)*ts))-        ((c1 ||| c2) ||| c3)--The idea is to extract the commands from the case, build a balanced tree-of choices, and replace the commands with expressions that build tagged-tuples, obtaining a case expression that can be desugared normally.-To build all this, we use triples describing segments of the list of-case bodies, containing the following fields:- * a list of expressions of the form (Left|Right)* ((xs)*ts), to be put-   into the case replacing the commands- * a sum type that is the common type of these expressions, and also the-   input type of the arrow- * a CoreExpr for an arrow built by combining the translated command-   bodies with |||.--}--dsCmd ids local_vars stack_ty res_ty-      (HsCmdCase exp (MG { mg_alts = L l matches, mg_arg_tys = arg_tys-                         , mg_origin = origin }))-      env_ids = do-    stack_id <- newSysLocalDs stack_ty--    -- Extract and desugar the leaf commands in the case, building tuple-    -- expressions that will (after tagging) replace these leaves--    let-        leaves = concatMap leavesMatch matches-        make_branch (leaf, bound_vars) = do-            (core_leaf, _fvs, leaf_ids) <--                  dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty res_ty leaf-            return ([mkHsEnvStackExpr leaf_ids stack_id],-                    envStackType leaf_ids stack_ty,-                    core_leaf)--    branches <- mapM make_branch leaves-    either_con <- dsLookupTyCon eitherTyConName-    left_con <- dsLookupDataCon leftDataConName-    right_con <- dsLookupDataCon rightDataConName-    let-        left_id  = HsConLikeOut (RealDataCon left_con)-        right_id = HsConLikeOut (RealDataCon right_con)-        left_expr  ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) left_id ) e-        right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) right_id) e--        -- Prefix each tuple with a distinct series of Left's and Right's,-        -- in a balanced way, keeping track of the types.--        merge_branches (builds1, in_ty1, core_exp1)-                       (builds2, in_ty2, core_exp2)-          = (map (left_expr in_ty1 in_ty2) builds1 ++-                map (right_expr in_ty1 in_ty2) builds2,-             mkTyConApp either_con [in_ty1, in_ty2],-             do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)-        (leaves', sum_ty, core_choices) = foldb merge_branches branches--        -- Replace the commands in the case with these tagged tuples,-        -- yielding a HsExpr Id we can feed to dsExpr.--        (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches-        in_ty = envStackType env_ids stack_ty--    core_body <- dsExpr (HsCase exp (MG { mg_alts = L l matches'-                                        , mg_arg_tys = arg_tys-                                        , mg_res_ty = sum_ty, mg_origin = origin }))-        -- Note that we replace the HsCase result type by sum_ty,-        -- which is the type of matches'--    core_matches <- matchEnvStack env_ids stack_id core_body-    return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,-            exprFreeIdsDSet core_body `udfmIntersectUFM` getUniqSet local_vars)---- D; ys |-a cmd : stk --> t--- ------------------------------------- D; xs |-a let binds in cmd : stk --> t------              ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c--dsCmd ids local_vars stack_ty res_ty (HsCmdLet lbinds@(L _ binds) body) env_ids = do-    let-        defined_vars = mkVarSet (collectLocalBinders binds)-        local_vars' = defined_vars `unionVarSet` local_vars--    (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty res_ty body-    stack_id <- newSysLocalDs stack_ty-    -- build a new environment, plus the stack, using the let bindings-    core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id)-    -- match the old environment and stack against the input-    core_map <- matchEnvStack env_ids stack_id core_binds-    return (do_premap ids-                        (envStackType env_ids stack_ty)-                        (envStackType env_ids' stack_ty)-                        res_ty-                        core_map-                        core_body,-        exprFreeIdsDSet core_binds `udfmIntersectUFM` getUniqSet local_vars)---- D; xs |-a ss : t--- ------------------------------------- D; xs |-a do { ss } : () --> t------              ---> premap (\ (env,stk) -> env) c--dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo (L loc stmts) stmts_ty) env_ids = do-    putSrcSpanDs loc $-      dsNoLevPoly stmts_ty-        (text "In the do-command:" <+> ppr do_block)-    (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids-    let env_ty = mkBigCoreVarTupTy env_ids-    core_fst <- mkFstExpr env_ty stack_ty-    return (do_premap ids-                (mkCorePairTy env_ty stack_ty)-                env_ty-                res_ty-                core_fst-                core_stmts,-        env_ids')---- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t--- D; xs |-a ci :: stki --> ti--- -------------------------------------- D; xs |-a (|e c1 ... cn|) :: stk --> t       ---> e [t_xs] c1 ... cn--dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ _ args) env_ids = do-    let env_ty = mkBigCoreVarTupTy env_ids-    core_op <- dsLExpr op-    (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args-    return (mkApps (App core_op (Type env_ty)) core_args,-            unionDVarSets fv_sets)--dsCmd ids local_vars stack_ty res_ty (HsCmdWrap wrap cmd) env_ids = do-    (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids-    core_wrap <- dsHsWrapper wrap-    return (core_wrap core_cmd, env_ids')--dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)---- D; ys |-a c : stk --> t      (ys <= xs)--- ------------------------ D; xs |-a c : stk --> t      ---> premap (\ ((xs),stk) -> ((ys),stk)) c--dsTrimCmdArg-        :: IdSet                -- set of local vars available to this command-        -> [Id]                 -- list of vars in the input to this command-        -> LHsCmdTop Id         -- command argument to desugar-        -> DsM (CoreExpr,       -- desugared expression-                DIdSet)         -- subset of local vars that occur free-dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do-    (meth_binds, meth_ids) <- mkCmdEnv ids-    (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd-    stack_id <- newSysLocalDs stack_ty-    trim_code <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id)-    let-        in_ty = envStackType env_ids stack_ty-        in_ty' = envStackType env_ids' stack_ty-        arg_code = if env_ids' == env_ids then core_cmd else-                do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd-    return (mkLets meth_binds arg_code, free_vars)---- Given D; xs |-a c : stk --> t, builds c with xs fed back.--- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk))--dsfixCmd-        :: DsCmdEnv             -- arrow combinators-        -> IdSet                -- set of local vars available to this command-        -> Type                 -- type of the stack (right-nested tuple)-        -> Type                 -- return type of the command-        -> LHsCmd Id            -- command to desugar-        -> DsM (CoreExpr,       -- desugared expression-                DIdSet,         -- subset of local vars that occur free-                [Id])           -- the same local vars as a list, fed back-dsfixCmd ids local_vars stk_ty cmd_ty cmd-  = do { putSrcSpanDs (getLoc cmd) $ dsNoLevPoly cmd_ty-           (text "When desugaring the command:" <+> ppr cmd)-       ; trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) }---- Feed back the list of local variables actually used a command,--- for use as the input tuple of the generated arrow.--trimInput-        :: ([Id] -> DsM (CoreExpr, DIdSet))-        -> DsM (CoreExpr,       -- desugared expression-                DIdSet,         -- subset of local vars that occur free-                [Id])           -- same local vars as a list, fed back to-                                -- the inner function to form the tuple of-                                -- inputs to the arrow.-trimInput build_arrow-  = fixDs (\ ~(_,_,env_ids) -> do-        (core_cmd, free_vars) <- build_arrow env_ids-        return (core_cmd, free_vars, dVarSetElems free_vars))--{--Translation of command judgements of the form--        D |-a do { ss } : t--}--dsCmdDo :: DsCmdEnv             -- arrow combinators-        -> IdSet                -- set of local vars available to this statement-        -> Type                 -- return type of the statement-        -> [CmdLStmt Id]        -- statements to desugar-        -> [Id]                 -- list of vars in the input to this statement-                                -- This is typically fed back,-                                -- so don't pull on it too early-        -> DsM (CoreExpr,       -- desugared expression-                DIdSet)         -- subset of local vars that occur free--dsCmdDo _ _ _ [] _ = panic "dsCmdDo"---- D; xs |-a c : () --> t--- ----------------------------- D; xs |-a do { c } : t------              ---> premap (\ (xs) -> ((xs), ())) c--dsCmdDo ids local_vars res_ty [L loc (LastStmt body _ _)] env_ids = do-    putSrcSpanDs loc $ dsNoLevPoly res_ty-                         (text "In the command:" <+> ppr body)-    (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids-    let env_ty = mkBigCoreVarTupTy env_ids-    env_var <- newSysLocalDs env_ty-    let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr)-    return (do_premap ids-                        env_ty-                        (mkCorePairTy env_ty unitTy)-                        res_ty-                        core_map-                        core_body,-        env_ids')--dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do-    let bound_vars  = mkVarSet (collectLStmtBinders stmt)-    let local_vars' = bound_vars `unionVarSet` local_vars-    (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts)-    (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids-    return (do_compose ids-                (mkBigCoreVarTupTy env_ids)-                (mkBigCoreVarTupTy env_ids')-                res_ty-                core_stmt-                core_stmts,-              fv_stmt)--{--A statement maps one local environment to another, and is represented-as an arrow from one tuple type to another.  A statement sequence is-translated to a composition of such arrows.--}--dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt Id -> [Id]-           -> DsM (CoreExpr, DIdSet)-dsCmdLStmt ids local_vars out_ids cmd env_ids-  = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids--dsCmdStmt-        :: DsCmdEnv             -- arrow combinators-        -> IdSet                -- set of local vars available to this statement-        -> [Id]                 -- list of vars in the output of this statement-        -> CmdStmt Id           -- statement to desugar-        -> [Id]                 -- list of vars in the input to this statement-                                -- This is typically fed back,-                                -- so don't pull on it too early-        -> DsM (CoreExpr,       -- desugared expression-                DIdSet)         -- subset of local vars that occur free---- D; xs1 |-a c : () --> t--- D; xs' |-a do { ss } : t'--- --------------------------------- D; xs  |-a do { c; ss } : t'------              ---> premap (\ ((xs)) -> (((xs1),()),(xs')))---                      (first c >>> arr snd) >>> ss--dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do-    (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd-    core_mux <- matchEnv env_ids-        (mkCorePairExpr-            (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)-            (mkBigCoreVarTup out_ids))-    let-        in_ty = mkBigCoreVarTupTy env_ids-        in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy-        out_ty = mkBigCoreVarTupTy out_ids-        before_c_ty = mkCorePairTy in_ty1 out_ty-        after_c_ty = mkCorePairTy c_ty out_ty-    dsNoLevPoly c_ty empty -- I (Richard E, Dec '16) have no idea what to say here-    snd_fn <- mkSndExpr c_ty out_ty-    return (do_premap ids in_ty before_c_ty out_ty core_mux $-                do_compose ids before_c_ty after_c_ty out_ty-                        (do_first ids in_ty1 c_ty out_ty core_cmd) $-                do_arr ids after_c_ty out_ty snd_fn,-              extendDVarSetList fv_cmd out_ids)---- D; xs1 |-a c : () --> t--- D; xs' |-a do { ss } : t'            xs2 = xs' - defs(p)--- -------------------------------------- D; xs  |-a do { p <- c; ss } : t'------              ---> premap (\ (xs) -> (((xs1),()),(xs2)))---                      (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss------ It would be simpler and more consistent to do this using second,--- but that's likely to be defined in terms of first.--dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _ _) env_ids = do-    let pat_ty = hsLPatType pat-    (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd-    let pat_vars = mkVarSet (collectPatBinders pat)-    let-        env_ids2 = filterOut (`elemVarSet` pat_vars) out_ids-        env_ty2 = mkBigCoreVarTupTy env_ids2--    -- multiplexing function-    --          \ (xs) -> (((xs1),()),(xs2))--    core_mux <- matchEnv env_ids-        (mkCorePairExpr-            (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)-            (mkBigCoreVarTup env_ids2))--    -- projection function-    --          \ (p, (xs2)) -> (zs)--    env_id <- newSysLocalDs env_ty2-    uniqs <- newUniqueSupply-    let-        after_c_ty = mkCorePairTy pat_ty env_ty2-        out_ty = mkBigCoreVarTupTy out_ids-        body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)--    fail_expr <- mkFailExpr (StmtCtxt DoExpr) out_ty-    pat_id    <- selectSimpleMatchVarL pat-    match_code <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr-    pair_id   <- newSysLocalDs after_c_ty-    let-        proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)--    -- put it all together-    let-        in_ty = mkBigCoreVarTupTy env_ids-        in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy-        in_ty2 = mkBigCoreVarTupTy env_ids2-        before_c_ty = mkCorePairTy in_ty1 in_ty2-    return (do_premap ids in_ty before_c_ty out_ty core_mux $-                do_compose ids before_c_ty after_c_ty out_ty-                        (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $-                do_arr ids after_c_ty out_ty proj_expr,-              fv_cmd `unionDVarSet` (mkDVarSet out_ids `udfmMinusUFM` getUniqSet pat_vars))---- D; xs' |-a do { ss } : t--- ----------------------------------------- D; xs  |-a do { let binds; ss } : t------              ---> arr (\ (xs) -> let binds in (xs')) >>> ss--dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do-    -- build a new environment using the let bindings-    core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids)-    -- match the old environment against the input-    core_map <- matchEnv env_ids core_binds-    return (do_arr ids-                        (mkBigCoreVarTupTy env_ids)-                        (mkBigCoreVarTupTy out_ids)-                        core_map,-            exprFreeIdsDSet core_binds `udfmIntersectUFM` getUniqSet local_vars)---- D; ys  |-a do { ss; returnA -< ((xs1), (ys2)) } : ...--- D; xs' |-a do { ss' } : t--- --------------------------------------- D; xs  |-a do { rec ss; ss' } : t------                      xs1 = xs' /\ defs(ss)---                      xs2 = xs' - defs(ss)---                      ys1 = ys - defs(ss)---                      ys2 = ys /\ defs(ss)------              ---> arr (\(xs) -> ((ys1),(xs2))) >>>---                      first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>---                      arr (\((xs1),(xs2)) -> (xs')) >>> ss'--dsCmdStmt ids local_vars out_ids-        (RecStmt { recS_stmts = stmts-                 , recS_later_ids = later_ids, recS_rec_ids = rec_ids-                 , recS_later_rets = later_rets, recS_rec_rets = rec_rets })-        env_ids = do-    let-        later_ids_set = mkVarSet later_ids-        env2_ids = filterOut (`elemVarSet` later_ids_set) out_ids-        env2_id_set = mkDVarSet env2_ids-        env2_ty = mkBigCoreVarTupTy env2_ids--    -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)--    uniqs <- newUniqueSupply-    env2_id <- newSysLocalDs env2_ty-    let-        later_ty = mkBigCoreVarTupTy later_ids-        post_pair_ty = mkCorePairTy later_ty env2_ty-        post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids)--    post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body--    --- loop (...)--    (core_loop, env1_id_set, env1_ids)-               <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets--    -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))--    let-        env1_ty = mkBigCoreVarTupTy env1_ids-        pre_pair_ty = mkCorePairTy env1_ty env2_ty-        pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids)-                                        (mkBigCoreVarTup env2_ids)--    pre_loop_fn <- matchEnv env_ids pre_loop_body--    -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn--    let-        env_ty = mkBigCoreVarTupTy env_ids-        out_ty = mkBigCoreVarTupTy out_ids-        core_body = do_premap ids env_ty pre_pair_ty out_ty-                pre_loop_fn-                (do_compose ids pre_pair_ty post_pair_ty out_ty-                        (do_first ids env1_ty later_ty env2_ty-                                core_loop)-                        (do_arr ids post_pair_ty out_ty-                                post_loop_fn))--    return (core_body, env1_id_set `unionDVarSet` env2_id_set)--dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)----      loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids))---            (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>>--dsRecCmd-        :: DsCmdEnv             -- arrow combinators-        -> IdSet                -- set of local vars available to this statement-        -> [CmdLStmt Id]        -- list of statements inside the RecCmd-        -> [Id]                 -- list of vars defined here and used later-        -> [HsExpr Id]          -- expressions corresponding to later_ids-        -> [Id]                 -- list of vars fed back through the loop-        -> [HsExpr Id]          -- expressions corresponding to rec_ids-        -> DsM (CoreExpr,       -- desugared statement-                DIdSet,         -- subset of local vars that occur free-                [Id])           -- same local vars as a list--dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do-    let-        later_id_set = mkVarSet later_ids-        rec_id_set = mkVarSet rec_ids-        local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars--    -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets))--    core_later_rets <- mapM dsExpr later_rets-    core_rec_rets <- mapM dsExpr rec_rets-    let-        -- possibly polymorphic version of vars of later_ids and rec_ids-        out_ids = exprsFreeIdsList (core_later_rets ++ core_rec_rets)-        out_ty = mkBigCoreVarTupTy out_ids--        later_tuple = mkBigCoreTup core_later_rets-        later_ty = mkBigCoreVarTupTy later_ids--        rec_tuple = mkBigCoreTup core_rec_rets-        rec_ty = mkBigCoreVarTupTy rec_ids--        out_pair = mkCorePairExpr later_tuple rec_tuple-        out_pair_ty = mkCorePairTy later_ty rec_ty--    mk_pair_fn <- matchEnv out_ids out_pair--    -- ss--    (core_stmts, fv_stmts, env_ids) <- dsfixCmdStmts ids local_vars' out_ids stmts--    -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids)--    rec_id <- newSysLocalDs rec_ty-    let-        env1_id_set = fv_stmts `udfmMinusUFM` getUniqSet rec_id_set-        env1_ids = dVarSetElems env1_id_set-        env1_ty = mkBigCoreVarTupTy env1_ids-        in_pair_ty = mkCorePairTy env1_ty rec_ty-        core_body = mkBigCoreTup (map selectVar env_ids)-          where-            selectVar v-                | v `elemVarSet` rec_id_set-                  = mkTupleSelector rec_ids v rec_id (Var rec_id)-                | otherwise = Var v--    squash_pair_fn <- matchEnvStack env1_ids rec_id core_body--    -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn))--    let-        env_ty = mkBigCoreVarTupTy env_ids-        core_loop = do_loop ids env1_ty later_ty rec_ty-                (do_premap ids in_pair_ty env_ty out_pair_ty-                        squash_pair_fn-                        (do_compose ids env_ty out_ty out_pair_ty-                                core_stmts-                                (do_arr ids out_ty out_pair_ty mk_pair_fn)))--    return (core_loop, env1_id_set, env1_ids)--{--A sequence of statements (as in a rec) is desugared to an arrow between-two environments (no stack)--}--dsfixCmdStmts-        :: DsCmdEnv             -- arrow combinators-        -> IdSet                -- set of local vars available to this statement-        -> [Id]                 -- output vars of these statements-        -> [CmdLStmt Id]        -- statements to desugar-        -> DsM (CoreExpr,       -- desugared expression-                DIdSet,         -- subset of local vars that occur free-                [Id])           -- same local vars as a list--dsfixCmdStmts ids local_vars out_ids stmts-  = trimInput (dsCmdStmts ids local_vars out_ids stmts)-   -- TODO: Add levity polymorphism check for the resulting expression.-   -- But I (Richard E.) don't know enough about arrows to do so.--dsCmdStmts-        :: DsCmdEnv             -- arrow combinators-        -> IdSet                -- set of local vars available to this statement-        -> [Id]                 -- output vars of these statements-        -> [CmdLStmt Id]        -- statements to desugar-        -> [Id]                 -- list of vars in the input to these statements-        -> DsM (CoreExpr,       -- desugared expression-                DIdSet)         -- subset of local vars that occur free--dsCmdStmts ids local_vars out_ids [stmt] env_ids-  = dsCmdLStmt ids local_vars out_ids stmt env_ids--dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do-    let bound_vars  = mkVarSet (collectLStmtBinders stmt)-    let local_vars' = bound_vars `unionVarSet` local_vars-    (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts-    (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids-    return (do_compose ids-                (mkBigCoreVarTupTy env_ids)-                (mkBigCoreVarTupTy env_ids')-                (mkBigCoreVarTupTy out_ids)-                core_stmt-                core_stmts,-              fv_stmt)--dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []"---- Match a list of expressions against a list of patterns, left-to-right.--matchSimplys :: [CoreExpr]              -- Scrutinees-             -> HsMatchContext Name     -- Match kind-             -> [LPat Id]               -- Patterns they should match-             -> CoreExpr                -- Return this if they all match-             -> CoreExpr                -- Return this if they don't-             -> DsM CoreExpr-matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr-matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do-    match_code <- matchSimplys exps ctxt pats result_expr fail_expr-    matchSimply exp ctxt pat match_code fail_expr-matchSimplys _ _ _ _ _ = panic "matchSimplys"---- List of leaf expressions, with set of variables bound in each--leavesMatch :: LMatch Id (Located (body Id)) -> [(Located (body Id), IdSet)]-leavesMatch (L _ (Match _ pats _ (GRHSs grhss (L _ binds))))-  = let-        defined_vars = mkVarSet (collectPatsBinders pats)-                        `unionVarSet`-                       mkVarSet (collectLocalBinders binds)-    in-    [(body,-      mkVarSet (collectLStmtsBinders stmts)-        `unionVarSet` defined_vars)-    | L _ (GRHS stmts body) <- grhss]---- Replace the leaf commands in a match--replaceLeavesMatch-        :: Type                                 -- new result type-        -> [Located (body' Id)]                 -- replacement leaf expressions of that type-        -> LMatch Id (Located (body Id))        -- the matches of a case command-        -> ([Located (body' Id)],               -- remaining leaf expressions-            LMatch Id (Located (body' Id)))     -- updated match-replaceLeavesMatch _res_ty leaves (L loc (Match mf pat mt (GRHSs grhss binds)))-  = let-        (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss-    in-    (leaves', L loc (Match mf pat mt (GRHSs grhss' binds)))--replaceLeavesGRHS-        :: [Located (body' Id)]                 -- replacement leaf expressions of that type-        -> LGRHS Id (Located (body Id))         -- rhss of a case command-        -> ([Located (body' Id)],               -- remaining leaf expressions-            LGRHS Id (Located (body' Id)))      -- updated GRHS-replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts _))-  = (leaves, L loc (GRHS stmts leaf))-replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"---- Balanced fold of a non-empty list.--foldb :: (a -> a -> a) -> [a] -> a-foldb _ [] = error "foldb of empty list"-foldb _ [x] = x-foldb f xs = foldb f (fold_pairs xs)-  where-    fold_pairs [] = []-    fold_pairs [x] = [x]-    fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs--{--Note [Dictionary binders in ConPatOut] See also same Note in HsUtils-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The following functions to collect value variables from patterns are-copied from HsUtils, with one change: we also collect the dictionary-bindings (pat_binds) from ConPatOut.  We need them for cases like--h :: Arrow a => Int -> a (Int,Int) Int-h x = proc (y,z) -> case compare x y of-                GT -> returnA -< z+x--The type checker turns the case into--                case compare x y of-                  GT { p77 = plusInt } -> returnA -< p77 z x--Here p77 is a local binding for the (+) operation.--See comments in HsUtils for why the other version does not include-these bindings.--}--collectPatBinders :: LPat Id -> [Id]-collectPatBinders pat = collectl pat []--collectPatsBinders :: [LPat Id] -> [Id]-collectPatsBinders pats = foldr collectl [] pats------------------------collectl :: LPat Id -> [Id] -> [Id]--- See Note [Dictionary binders in ConPatOut]-collectl (L _ pat) bndrs-  = go pat-  where-    go (VarPat (L _ var))         = var : bndrs-    go (WildPat _)                = bndrs-    go (LazyPat pat)              = collectl pat bndrs-    go (BangPat pat)              = collectl pat bndrs-    go (AsPat (L _ a) pat)        = a : collectl pat bndrs-    go (ParPat  pat)              = collectl pat bndrs--    go (ListPat pats _ _)         = foldr collectl bndrs pats-    go (PArrPat pats _)           = foldr collectl bndrs pats-    go (TuplePat pats _ _)        = foldr collectl bndrs pats-    go (SumPat pat _ _ _)         = collectl pat bndrs--    go (ConPatIn _ ps)            = foldr collectl bndrs (hsConPatArgs ps)-    go (ConPatOut {pat_args=ps, pat_binds=ds}) =-                                    collectEvBinders ds-                                    ++ foldr collectl bndrs (hsConPatArgs ps)-    go (LitPat _)                 = bndrs-    go (NPat {})                  = bndrs-    go (NPlusKPat (L _ n) _ _ _ _ _) = n : bndrs--    go (SigPatIn pat _)           = collectl pat bndrs-    go (SigPatOut pat _)          = collectl pat bndrs-    go (CoPat _ pat _)            = collectl (noLoc pat) bndrs-    go (ViewPat _ pat _)          = collectl pat bndrs-    go p@(SplicePat {})           = pprPanic "collectl/go" (ppr p)--collectEvBinders :: TcEvBinds -> [Id]-collectEvBinders (EvBinds bs)   = foldrBag add_ev_bndr [] bs-collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"--add_ev_bndr :: EvBind -> [Id] -> [Id]-add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b    = b:bs-                                       | otherwise = bs-  -- A worry: what about coercion variable binders??--collectLStmtsBinders :: [LStmt Id body] -> [Id]-collectLStmtsBinders = concatMap collectLStmtBinders--collectLStmtBinders :: LStmt Id body -> [Id]-collectLStmtBinders = collectStmtBinders . unLoc--collectStmtBinders :: Stmt Id body -> [Id]-collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids-collectStmtBinders stmt = HsUtils.collectStmtBinders stmt
− src/Language/Haskell/Liquid/Desugar/DsBinds.hs 
@@ -1,1376 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---Pattern-matching bindings (HsBinds and MonoBinds)--Handles @HsBinds@; those at the top level require different handling,-in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at-lower levels it is preserved with @let@/@letrec@s).--}--{-# LANGUAGE CPP #-}--module Language.Haskell.Liquid.Desugar.DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,-                 dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule-  ) where--import {-# SOURCE #-}   Language.Haskell.Liquid.Desugar.DsExpr( dsLExpr )-import {-# SOURCE #-}   Language.Haskell.Liquid.Desugar.Match( matchWrapper )--import Language.Haskell.Liquid.Desugar.DsMonad-import Language.Haskell.Liquid.Desugar.DsGRHSs-import Language.Haskell.Liquid.Desugar.DsUtils--import HsSyn            -- lots of things-import CoreSyn          -- lots of things-import Literal          ( Literal(MachStr) )-import CoreOpt          ( simpleOptExpr )-import OccurAnal        ( occurAnalyseExpr )-import MkCore-import CoreUtils-import CoreArity ( etaExpand )-import CoreUnfold-import CoreFVs-import Digraph--import PrelNames-import TyCon-import TcEvidence-import TcType-import Type-import Coercion-import TysWiredIn ( typeNatKind, typeSymbolKind )-import Id-import MkId(proxyHashId)-import Class-import Name-import VarSet-import Rules-import VarEnv-import Outputable-import Module-import SrcLoc-import Maybes-import OrdList-import Bag-import BasicTypes-import DynFlags-import FastString-import Util-import MonadUtils-import qualified GHC.LanguageExtensions as LangExt-import Control.Monad--{-**********************************************************************-*                                                                      *-           Desugaring a MonoBinds-*                                                                      *-**********************************************************************-}---- | Desugar top level binds, strict binds are treated like normal--- binds since there is no good time to force before first usage.-dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))-dsTopLHsBinds binds-     -- see Note [Strict binds checks]-  | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds)-  = do { mapBagM_ (top_level_err "bindings for unlifted types") unlifted_binds-       ; mapBagM_ (top_level_err "strict pattern bindings")    bang_binds-       ; return nilOL }--  | otherwise-  = do { (_, prs) <- dsLHsBinds binds-       ; return (toOL prs) }--  where-    unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds-    bang_binds     = filterBag (isBangedPatBind  . unLoc) binds--    top_level_err desc (L loc bind)-      = putSrcSpanDs loc $-        errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:")-                  2 (ppr bind))----- | Desugar all other kind of bindings, Ids of strict binds are returned to--- later be forced in the binding group body, see Note [Desugar Strict binds]-dsLHsBinds :: LHsBinds Id -> DsM ([Id], [(Id,CoreExpr)])-dsLHsBinds binds-  = do { ds_bs <- mapBagM dsLHsBind binds-       ; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b'))-                         id ([], []) ds_bs) }---------------------------dsLHsBind :: LHsBind Id-          -> DsM ([Id], [(Id,CoreExpr)])-dsLHsBind (L loc bind) = do dflags <- getDynFlags-                            putSrcSpanDs loc $ dsHsBind dflags bind---- | Desugar a single binding (or group of recursive binds).-dsHsBind :: DynFlags-         -> HsBind Id-         -> DsM ([Id], [(Id,CoreExpr)])-         -- ^ The Ids of strict binds, to be forced in the body of the-         -- binding group see Note [Desugar Strict binds] and all-         -- bindings and their desugared right hand sides.--dsHsBind dflags-         (VarBind { var_id = var-                  , var_rhs = expr-                  , var_inline = inline_regardless })-  = do  { core_expr <- dsLExpr expr-                -- Dictionary bindings are always VarBinds,-                -- so we only need do this here-        ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr-                   | otherwise         = var-        ; let core_bind@(id,_) = makeCorePair dflags var' False 0 core_expr-              force_var = if xopt LangExt.Strict dflags-                          then [id]-                          else []-        ; return (force_var, [core_bind]) }--dsHsBind dflags-         b@(FunBind { fun_id = L _ fun, fun_matches = matches-                    , fun_co_fn = co_fn, fun_tick = tick })- = do   { (args, body) <- matchWrapper-                           (mkPrefixFunRhs (noLoc $ idName fun))-                           Nothing matches-        ; core_wrap <- dsHsWrapper co_fn-        ; let body' = mkOptTickBox tick body-              rhs   = core_wrap (mkLams args body')-              core_binds@(id,_) = makeCorePair dflags fun False 0 rhs-              force_var-                  -- Bindings are strict when -XStrict is enabled-                | xopt LangExt.Strict dflags-                , matchGroupArity matches == 0 -- no need to force lambdas-                = [id]-                | isBangedBind b-                = [id]-                | otherwise-                = []-        ; --pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun) $$ ppr (mg_alts matches) $$ ppr args $$ ppr core_binds) $-           return (force_var, [core_binds]) }--dsHsBind dflags-         (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty-                  , pat_ticks = (rhs_tick, var_ticks) })-  = do  { body_expr <- dsGuarded grhss ty-        ; let body' = mkOptTickBox rhs_tick body_expr-              pat'  = decideBangHood dflags pat-        ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body'-          -- We silently ignore inline pragmas; no makeCorePair-          -- Not so cool, but really doesn't matter-        ; let force_var' = if isBangedLPat pat'-                           then [force_var]-                           else []-        ; return (force_var', sel_binds) }--        -- A common case: one exported variable, only non-strict binds-        -- Non-recursive bindings come through this way-        -- So do self-recursive bindings-        -- Bindings with complete signatures are AbsBindsSigs, below-dsHsBind dflags-         (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts-                   , abs_exports = [export]-                   , abs_ev_binds = ev_binds, abs_binds = binds })-  | ABE { abe_wrap = wrap, abe_poly = global-        , abe_mono = local, abe_prags = prags } <- export-  , not (xopt LangExt.Strict dflags)             -- Handle strict binds-  , not (anyBag (isBangedBind . unLoc) binds)    --        in the next case-  = -- See Note [AbsBinds wrappers] in HsBinds-    addDictsDs (toTcTypeBag (listToBag dicts)) $-         -- addDictsDs: push type constraints deeper for pattern match check-    do { (_, bind_prs) <- dsLHsBinds binds-       ; let core_bind = Rec bind_prs-       ; ds_binds <- dsTcEvBinds_s ev_binds-       ; core_wrap <- dsHsWrapper wrap -- Usually the identity--       ; let rhs = core_wrap $-                   mkLams tyvars $ mkLams dicts $-                   mkCoreLets ds_binds $-                   mkLet core_bind $-                   Var local-       ; (spec_binds, rules) <- dsSpecs rhs prags--       ; let   global'  = addIdSpecialisations global rules-               main_bind = makeCorePair dflags global' (isDefaultMethod prags)-                                        (dictArity dicts) rhs--       ; return ([], main_bind : fromOL spec_binds) }--        -- Another common case: no tyvars, no dicts-        -- In this case we can have a much simpler desugaring-dsHsBind dflags-         (AbsBinds { abs_tvs = [], abs_ev_vars = []-                   , abs_exports = exports-                   , abs_ev_binds = ev_binds, abs_binds = binds })-  = do { (force_vars, bind_prs) <- dsLHsBinds binds-       ; let mk_bind (ABE { abe_wrap = wrap-                          , abe_poly = global-                          , abe_mono = local-                          , abe_prags = prags })-              = do { core_wrap <- dsHsWrapper wrap-                   ; return (makeCorePair dflags global-                                          (isDefaultMethod prags)-                                          0 (core_wrap (Var local))) }-       ; main_binds <- mapM mk_bind exports--       ; ds_binds <- dsTcEvBinds_s ev_binds-       ; return (force_vars, flattenBinds ds_binds ++ bind_prs ++ main_binds) }--dsHsBind dflags-         (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts-                   , abs_exports = exports, abs_ev_binds = ev_binds-                   , abs_binds = binds })-         -- See Note [Desugaring AbsBinds]-  = addDictsDs (toTcTypeBag (listToBag dicts)) $-         -- addDictsDs: push type constraints deeper for pattern match check-     do { (local_force_vars, bind_prs) <- dsLHsBinds binds-        ; let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs-                              | (lcl_id, rhs) <- bind_prs ]-                -- Monomorphic recursion possible, hence Rec-              new_force_vars = get_new_force_vars local_force_vars-              locals       = map abe_mono exports-              all_locals   = locals ++ new_force_vars-              tup_expr     = mkBigCoreVarTup all_locals-              tup_ty       = exprType tup_expr-        ; ds_binds <- dsTcEvBinds_s ev_binds-        ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $-                             mkCoreLets ds_binds $-                             mkLet core_bind $-                             tup_expr--        ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)--        -- Find corresponding global or make up a new one: sometimes-        -- we need to make new export to desugar strict binds, see-        -- Note [Desugar Strict binds]-        ; (exported_force_vars, extra_exports) <- get_exports local_force_vars--        ; let mk_bind (ABE { abe_wrap = wrap-                           , abe_poly = global-                           , abe_mono = local, abe_prags = spec_prags })-                         -- See Note [AbsBinds wrappers] in HsBinds-                = do { tup_id  <- newSysLocalDs tup_ty-                     ; core_wrap <- dsHsWrapper wrap-                     ; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $-                                 mkTupleSelector all_locals local tup_id $-                                 mkVarApps (Var poly_tup_id) (tyvars ++ dicts)-                           rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs-                     ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags-                     ; let global' = (global `setInlinePragma` defaultInlinePragma)-                                             `addIdSpecialisations` rules-                           -- Kill the INLINE pragma because it applies to-                           -- the user written (local) function.  The global-                           -- Id is just the selector.  Hmm.-                     ; return ((global', rhs) : fromOL spec_binds) }--        ; export_binds_s <- mapM mk_bind (exports ++ extra_exports)--        ; return (exported_force_vars-                 ,(poly_tup_id, poly_tup_rhs) :-                   concat export_binds_s) }-  where-    inline_env :: IdEnv Id   -- Maps a monomorphic local Id to one with-                             -- the inline pragma from the source-                             -- The type checker put the inline pragma-                             -- on the *global* Id, so we need to transfer it-    inline_env-      = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag)-                 | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports-                 , let prag = idInlinePragma gbl_id ]--    add_inline :: Id -> Id    -- tran-    add_inline lcl_id = lookupVarEnv inline_env lcl_id-                        `orElse` lcl_id--    global_env :: IdEnv Id -- Maps local Id to its global exported Id-    global_env =-      mkVarEnv [ (local, global)-               | ABE { abe_mono = local, abe_poly = global } <- exports-               ]--    -- find variables that are not exported-    get_new_force_vars lcls =-      foldr (\lcl acc -> case lookupVarEnv global_env lcl of-                           Just _ -> acc-                           Nothing -> lcl:acc)-            [] lcls--    -- find exports or make up new exports for force variables-    get_exports :: [Id] -> DsM ([Id], [ABExport Id])-    get_exports lcls =-      foldM (\(glbls, exports) lcl ->-              case lookupVarEnv global_env lcl of-                Just glbl -> return (glbl:glbls, exports)-                Nothing   -> do export <- mk_export lcl-                                let glbl = abe_poly export-                                return (glbl:glbls, export:exports))-            ([],[]) lcls--    mk_export local =-      do global <- newSysLocalDs-                     (exprType (mkLams tyvars (mkLams dicts (Var local))))-         return (ABE {abe_poly = global-                     ,abe_mono = local-                     ,abe_wrap = WpHole-                     ,abe_prags = SpecPrags []})---- AbsBindsSig is a combination of AbsBinds and FunBind-dsHsBind dflags (AbsBindsSig { abs_tvs = tyvars, abs_ev_vars = dicts-                             , abs_sig_export  = global-                             , abs_sig_prags   = prags-                             , abs_sig_ev_bind = ev_bind-                             , abs_sig_bind    = bind })-  | L bind_loc FunBind { fun_matches = matches-                       , fun_co_fn   = co_fn-                       , fun_tick    = tick } <- bind-  = putSrcSpanDs bind_loc $-    addDictsDs (toTcTypeBag (listToBag dicts)) $-             -- addDictsDs: push type constraints deeper for pattern match check-    do { (args, body) <- matchWrapper-                           (mkPrefixFunRhs (noLoc $ idName global))-                           Nothing matches-       ; core_wrap <- dsHsWrapper co_fn-       ; let body'   = mkOptTickBox tick body-             fun_rhs = core_wrap (mkLams args body')-             force_vars-               | xopt LangExt.Strict dflags-               , matchGroupArity matches == 0 -- no need to force lambdas-               = [global]-               | isBangedBind (unLoc bind)-               = [global]-               | otherwise-               = []--       ; ds_binds <- dsTcEvBinds ev_bind-       ; let rhs = mkLams tyvars $-                   mkLams dicts $-                   mkCoreLets ds_binds $-                   fun_rhs--       ; (spec_binds, rules) <- dsSpecs rhs prags-       ; let global' = addIdSpecialisations global rules-             main_bind = makeCorePair dflags global' (isDefaultMethod prags)-                                      (dictArity dicts) rhs--       ; return (force_vars, main_bind : fromOL spec_binds) }--  | otherwise-  = pprPanic "dsHsBind: AbsBindsSig" (ppr bind)--dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"------ | This is where we apply INLINE and INLINABLE pragmas. All we need to--- do is to attach the unfolding information to the Id.------ Other decisions about whether to inline are made in--- `calcUnfoldingGuidance` but the decision about whether to then expose--- the unfolding in the interface file is made in `TidyPgm.addExternal`--- using this information.--------------------------makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)-makeCorePair dflags gbl_id is_default_method dict_arity rhs-  | is_default_method                 -- Default methods are *always* inlined-  = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)--  | otherwise-  = case inlinePragmaSpec inline_prag of-          EmptyInlineSpec -> (gbl_id, rhs)-          NoInline        -> (gbl_id, rhs)-          Inlinable       -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)-          Inline          -> inline_pair--  where-    inline_prag   = idInlinePragma gbl_id-    inlinable_unf = mkInlinableUnfolding dflags rhs-    inline_pair-       | Just arity <- inlinePragmaSat inline_prag-        -- Add an Unfolding for an INLINE (but not for NOINLINE)-        -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]-       , let real_arity = dict_arity + arity-        -- NB: The arity in the InlineRule takes account of the dictionaries-       = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity real_arity rhs-         , etaExpand real_arity rhs)--       | otherwise-       = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $-         (gbl_id `setIdUnfolding` mkInlineUnfolding rhs, rhs)--dictArity :: [Var] -> Arity--- Don't count coercion variables in arity-dictArity dicts = count isId dicts--{--Note [Desugaring AbsBinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~-In the general AbsBinds case we desugar the binding to this:--       tup a (d:Num a) = let fm = ...gm...-                             gm = ...fm...-                         in (fm,gm)-       f a d = case tup a d of { (fm,gm) -> fm }-       g a d = case tup a d of { (fm,gm) -> fm }--Note [Rules and inlining]-~~~~~~~~~~~~~~~~~~~~~~~~~-Common special case: no type or dictionary abstraction-This is a bit less trivial than you might suppose-The naive way woudl be to desguar to something like-        f_lcl = ...f_lcl...     -- The "binds" from AbsBinds-        M.f = f_lcl             -- Generated from "exports"-But we don't want that, because if M.f isn't exported,-it'll be inlined unconditionally at every call site (its rhs is-trivial).  That would be ok unless it has RULES, which would-thereby be completely lost.  Bad, bad, bad.--Instead we want to generate-        M.f = ...f_lcl...-        f_lcl = M.f-Now all is cool. The RULES are attached to M.f (by SimplCore),-and f_lcl is rapidly inlined away.--This does not happen in the same way to polymorphic binds,-because they desugar to-        M.f = /\a. let f_lcl = ...f_lcl... in f_lcl-Although I'm a bit worried about whether full laziness might-float the f_lcl binding out and then inline M.f at its call site--Note [Specialising in no-dict case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Even if there are no tyvars or dicts, we may have specialisation pragmas.-Class methods can generate-      AbsBinds [] [] [( ... spec-prag]-         { AbsBinds [tvs] [dicts] ...blah }-So the overloading is in the nested AbsBinds. A good example is in GHC.Float:--  class  (Real a, Fractional a) => RealFrac a  where-    round :: (Integral b) => a -> b--  instance  RealFrac Float  where-    {-# SPECIALIZE round :: Float -> Int #-}--The top-level AbsBinds for $cround has no tyvars or dicts (because the-instance does not).  But the method is locally overloaded!--Note [Abstracting over tyvars only]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When abstracting over type variable only (not dictionaries), we don't really need to-built a tuple and select from it, as we do in the general case. Instead we can take--        AbsBinds [a,b] [ ([a,b], fg, fl, _),-                         ([b],   gg, gl, _) ]-                { fl = e1-                  gl = e2-                   h = e3 }--and desugar it to--        fg = /\ab. let B in e1-        gg = /\b. let a = () in let B in S(e2)-        h  = /\ab. let B in e3--where B is the *non-recursive* binding-        fl = fg a b-        gl = gg b-        h  = h a b    -- See (b); note shadowing!--Notice (a) g has a different number of type variables to f, so we must-             use the mkArbitraryType thing to fill in the gaps.-             We use a type-let to do that.--         (b) The local variable h isn't in the exports, and rather than-             clone a fresh copy we simply replace h by (h a b), where-             the two h's have different types!  Shadowing happens here,-             which looks confusing but works fine.--         (c) The result is *still* quadratic-sized if there are a lot of-             small bindings.  So if there are more than some small-             number (10), we filter the binding set B by the free-             variables of the particular RHS.  Tiresome.--Why got to this trouble?  It's a common case, and it removes the-quadratic-sized tuple desugaring.  Less clutter, hopefully faster-compilation, especially in a case where there are a *lot* of-bindings.---Note [Eta-expanding INLINE things]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   foo :: Eq a => a -> a-   {-# INLINE foo #-}-   foo x = ...--If (foo d) ever gets floated out as a common sub-expression (which can-happen as a result of method sharing), there's a danger that we never-get to do the inlining, which is a Terribly Bad thing given that the-user said "inline"!--To avoid this we pre-emptively eta-expand the definition, so that foo-has the arity with which it is declared in the source code.  In this-example it has arity 2 (one for the Eq and one for x). Doing this-should mean that (foo d) is a PAP and we don't share it.--Note [Nested arities]-~~~~~~~~~~~~~~~~~~~~~-For reasons that are not entirely clear, method bindings come out looking like-this:--  AbsBinds [] [] [$cfromT <= [] fromT]-    $cfromT [InlPrag=INLINE] :: T Bool -> Bool-    { AbsBinds [] [] [fromT <= [] fromT_1]-        fromT :: T Bool -> Bool-        { fromT_1 ((TBool b)) = not b } } }--Note the nested AbsBind.  The arity for the InlineRule on $cfromT should be-gotten from the binding for fromT_1.--It might be better to have just one level of AbsBinds, but that requires more-thought!---Note [Desugar Strict binds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~--Desugaring strict variable bindings looks as follows (core below ==>)--  let !x = rhs-  in  body-==>-  let x = rhs-  in x `seq` body -- seq the variable--and if it is a pattern binding the desugaring looks like--  let !pat = rhs-  in body-==>-  let x = rhs -- bind the rhs to a new variable-      pat = x-  in x `seq` body -- seq the new variable--if there is no variable in the pattern desugaring looks like--  let False = rhs-  in body-==>-  let x = case rhs of {False -> (); _ -> error "Match failed"}-  in x `seq` body--In order to force the Ids in the binding group they are passed around-in the dsHsBind family of functions, and later seq'ed in DsExpr.ds_val_bind.--Consider a recursive group like this--  letrec-     f : g = rhs[f,g]-  in <body>--Without `Strict`, we get a translation like this:--  let t = /\a. letrec tm = rhs[fm,gm]-                      fm = case t of fm:_ -> fm-                      gm = case t of _:gm -> gm-                in-                (fm,gm)--  in let f = /\a. case t a of (fm,_) -> fm-  in let g = /\a. case t a of (_,gm) -> gm-  in <body>--Here `tm` is the monomorphic binding for `rhs`.--With `Strict`, we want to force `tm`, but NOT `fm` or `gm`.-Alas, `tm` isn't in scope in the `in <body>` part.--The simplest thing is to return it in the polymorphic-tuple `t`, thus:--  let t = /\a. letrec tm = rhs[fm,gm]-                      fm = case t of fm:_ -> fm-                      gm = case t of _:gm -> gm-                in-                (tm, fm, gm)--  in let f = /\a. case t a of (_,fm,_) -> fm-  in let g = /\a. case t a of (_,_,gm) -> gm-  in let tm = /\a. case t a of (tm,_,_) -> tm-  in tm `seq` <body>---See https://ghc.haskell.org/trac/ghc/wiki/StrictPragma for a more-detailed explanation of the desugaring of strict bindings.--Note [Strict binds checks]-~~~~~~~~~~~~~~~~~~~~~~~~~~-There are several checks around properly formed strict bindings. They-all link to this Note. These checks must be here in the desugarer because-we cannot know whether or not a type is unlifted until after zonking, due-to levity polymorphism. These checks all used to be handled in the typechecker-in checkStrictBinds (before Jan '17).--We define an "unlifted bind" to be any bind that binds an unlifted id. Note that--  x :: Char-  (# True, x #) = blah--is *not* an unlifted bind. Unlifted binds are detected by HsUtils.isUnliftedHsBind.--Define a "banged bind" to have a top-level bang. Detected by HsPat.isBangedPatBind.-Define a "strict bind" to be either an unlifted bind or a banged bind.--The restrictions are:-  1. Strict binds may not be top-level. Checked in dsTopLHsBinds.--  2. Unlifted binds must also be banged. (There is no trouble to compile an unbanged-     unlifted bind, but an unbanged bind looks lazy, and we don't want users to be-     surprised by the strictness of an unlifted bind.) Checked in first clause-     of DsExpr.ds_val_bind.--  3. Unlifted binds may not have polymorphism (#6078). (That is, no quantified type-     variables or constraints.) Checked in first clause-     of DsExpr.ds_val_bind.--  4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind.---}---------------------------dsSpecs :: CoreExpr     -- Its rhs-        -> TcSpecPrags-        -> DsM ( OrdList (Id,CoreExpr)  -- Binding for specialised Ids-               , [CoreRule] )           -- Rules for the Global Ids--- See Note [Handling SPECIALISE pragmas] in TcBinds-dsSpecs _ IsDefaultMethod = return (nilOL, [])-dsSpecs poly_rhs (SpecPrags sps)-  = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps-       ; let (spec_binds_s, rules) = unzip pairs-       ; return (concatOL spec_binds_s, rules) }--dsSpec :: Maybe CoreExpr        -- Just rhs => RULE is for a local binding-                                -- Nothing => RULE is for an imported Id-                                --            rhs is in the Id's unfolding-       -> Located TcSpecPrag-       -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))-dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))-  | isJust (isClassOpId_maybe poly_id)-  = putSrcSpanDs loc $-    do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector"-                          <+> quotes (ppr poly_id))-       ; return Nothing  }  -- There is no point in trying to specialise a class op-                            -- Moreover, classops don't (currently) have an inl_sat arity set-                            -- (it would be Just 0) and that in turn makes makeCorePair bleat--  | no_act_spec && isNeverActive rule_act-  = putSrcSpanDs loc $-    do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for NOINLINE function:"-                          <+> quotes (ppr poly_id))-       ; return Nothing  }  -- Function is NOINLINE, and the specialiation inherits that-                            -- See Note [Activation pragmas for SPECIALISE]--  | otherwise-  = putSrcSpanDs loc $-    do { uniq <- newUnique-       ; let poly_name = idName poly_id-             spec_occ  = mkSpecOcc (getOccName poly_name)-             spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)-             (spec_bndrs, spec_app) = collectHsWrapBinders spec_co-               -- spec_co looks like-               --         \spec_bndrs. [] spec_args-               -- perhaps with the body of the lambda wrapped in some WpLets-               -- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2--       ; core_app <- dsHsWrapper spec_app--       ; let ds_lhs  = core_app (Var poly_id)-             spec_ty = mkLamTypes spec_bndrs (exprType ds_lhs)-       ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id-         --                         , text "spec_co:" <+> ppr spec_co-         --                         , text "ds_rhs:" <+> ppr ds_lhs ]) $-         case decomposeRuleLhs spec_bndrs ds_lhs of {-           Left msg -> do { warnDs NoReason msg; return Nothing } ;-           Right (rule_bndrs, _fn, args) -> do--       { dflags <- getDynFlags-       ; this_mod <- getModule-       ; let fn_unf    = realIdUnfolding poly_id-             spec_unf  = specUnfolding spec_bndrs core_app arity_decrease fn_unf-             spec_id   = mkLocalId spec_name spec_ty-                            `setInlinePragma` inl_prag-                            `setIdUnfolding`  spec_unf-             arity_decrease = count isValArg args - count isId spec_bndrs--       ; rule <- dsMkUserRule this_mod is_local_id-                        (mkFastString ("SPEC " ++ showPpr dflags poly_name))-                        rule_act poly_name-                        rule_bndrs args-                        (mkVarApps (Var spec_id) spec_bndrs)--       ; let spec_rhs = mkLams spec_bndrs (core_app poly_rhs)---- Commented out: see Note [SPECIALISE on INLINE functions]---       ; when (isInlinePragma id_inl)---              (warnDs $ text "SPECIALISE pragma on INLINE function probably won't fire:"---                        <+> quotes (ppr poly_name))--       ; return (Just (unitOL (spec_id, spec_rhs), rule))-            -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because-            --     makeCorePair overwrites the unfolding, which we have-            --     just created using specUnfolding-       } } }-  where-    is_local_id = isJust mb_poly_rhs-    poly_rhs | Just rhs <-  mb_poly_rhs-             = rhs          -- Local Id; this is its rhs-             | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)-             = unfolding    -- Imported Id; this is its unfolding-                            -- Use realIdUnfolding so we get the unfolding-                            -- even when it is a loop breaker.-                            -- We want to specialise recursive functions!-             | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)-                            -- The type checker has checked that it *has* an unfolding--    id_inl = idInlinePragma poly_id--    -- See Note [Activation pragmas for SPECIALISE]-    inl_prag | not (isDefaultInlinePragma spec_inl)    = spec_inl-             | not is_local_id  -- See Note [Specialising imported functions]-                                 -- in OccurAnal-             , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma-             | otherwise                               = id_inl-     -- Get the INLINE pragma from SPECIALISE declaration, or,-     -- failing that, from the original Id--    spec_prag_act = inlinePragmaActivation spec_inl--    -- See Note [Activation pragmas for SPECIALISE]-    -- no_act_spec is True if the user didn't write an explicit-    -- phase specification in the SPECIALISE pragma-    no_act_spec = case inlinePragmaSpec spec_inl of-                    NoInline -> isNeverActive  spec_prag_act-                    _        -> isAlwaysActive spec_prag_act-    rule_act | no_act_spec = inlinePragmaActivation id_inl   -- Inherit-             | otherwise   = spec_prag_act                   -- Specified by user---dsMkUserRule :: Module -> Bool -> RuleName -> Activation-       -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule-dsMkUserRule this_mod is_local name act fn bndrs args rhs = do-    let rule = mkRule this_mod False is_local name act fn bndrs args rhs-    dflags <- getDynFlags-    when (isOrphan (ru_orphan rule) && wopt Opt_WarnOrphans dflags) $-        warnDs (Reason Opt_WarnOrphans) (ruleOrphWarn rule)-    return rule--ruleOrphWarn :: CoreRule -> SDoc-ruleOrphWarn rule = text "Orphan rule:" <+> ppr rule--{- Note [SPECIALISE on INLINE functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We used to warn that using SPECIALISE for a function marked INLINE-would be a no-op; but it isn't!  Especially with worker/wrapper split-we might have-   {-# INLINE f #-}-   f :: Ord a => Int -> a -> ...-   f d x y = case x of I# x' -> $wf d x' y--We might want to specialise 'f' so that we in turn specialise '$wf'.-We can't even /name/ '$wf' in the source code, so we can't specialise-it even if we wanted to.  Trac #10721 is a case in point.--Note [Activation pragmas for SPECIALISE]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-From a user SPECIALISE pragma for f, we generate-  a) A top-level binding    spec_fn = rhs-  b) A RULE                 f dOrd = spec_fn--We need two pragma-like things:--* spec_fn's inline pragma: inherited from f's inline pragma (ignoring-                           activation on SPEC), unless overriden by SPEC INLINE--* Activation of RULE: from SPECIALISE pragma (if activation given)-                      otherwise from f's inline pragma--This is not obvious (see Trac #5237)!--Examples      Rule activation   Inline prag on spec'd fn-----------------------------------------------------------------------SPEC [n] f :: ty            [n]   Always, or NOINLINE [n]-                                  copy f's prag--NOINLINE f-SPEC [n] f :: ty            [n]   NOINLINE-                                  copy f's prag--NOINLINE [k] f-SPEC [n] f :: ty            [n]   NOINLINE [k]-                                  copy f's prag--INLINE [k] f-SPEC [n] f :: ty            [n]   INLINE [k]-                                  copy f's prag--SPEC INLINE [n] f :: ty     [n]   INLINE [n]-                                  (ignore INLINE prag on f,-                                  same activation for rule and spec'd fn)--NOINLINE [k] f-SPEC f :: ty                [n]   INLINE [k]---************************************************************************-*                                                                      *-\subsection{Adding inline pragmas}-*                                                                      *-************************************************************************--}--decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr])--- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE,--- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs--- may add some extra dictionary binders (see Note [Free dictionaries])------ Returns an error message if the LHS isn't of the expected shape--- Note [Decomposing the left-hand side of a RULE]-decomposeRuleLhs orig_bndrs orig_lhs-  | not (null unbound)    -- Check for things unbound on LHS-                          -- See Note [Unused spec binders]-  = Left (vcat (map dead_msg unbound))-  | Var funId <- fun2-  , Just con <- isDataConId_maybe funId-  = Left (constructor_msg con) -- See Note [No RULES on datacons]-  | Just (fn_id, args) <- decompose fun2 args2-  , let extra_bndrs = mk_extra_bndrs fn_id args-  = -- pprTrace "decmposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs-    --                                  , text "orig_lhs:" <+> ppr orig_lhs-    --                                  , text "lhs1:"     <+> ppr lhs1-    --                                  , text "extra_dict_bndrs:" <+> ppr extra_dict_bndrs-    --                                  , text "fn_id:" <+> ppr fn_id-    --                                  , text "args:"   <+> ppr args]) $-    Right (orig_bndrs ++ extra_bndrs, fn_id, args)--  | otherwise-  = Left bad_shape_msg- where-   lhs1         = drop_dicts orig_lhs-   lhs2         = simpleOptExpr lhs1  -- See Note [Simplify rule LHS]-   (fun2,args2) = collectArgs lhs2--   lhs_fvs    = exprFreeVars lhs2-   unbound    = filterOut (`elemVarSet` lhs_fvs) orig_bndrs--   orig_bndr_set = mkVarSet orig_bndrs--        -- Add extra tyvar binders: Note [Free tyvars in rule LHS]-        -- and extra dict binders: Note [Free dictionaries in rule LHS]-   mk_extra_bndrs fn_id args-     = toposortTyVars unbound_tvs ++ unbound_dicts-     where-       unbound_tvs   = [ v | v <- unbound_vars, isTyVar v ]-       unbound_dicts = [ mkLocalId (localiseName (idName d)) (idType d)-                       | d <- unbound_vars, isDictId d ]-       unbound_vars  = [ v | v <- exprsFreeVarsList args-                           , not (v `elemVarSet` orig_bndr_set)-                           , not (v == fn_id) ]-         -- fn_id: do not quantify over the function itself, which may-         -- itself be a dictionary (in pathological cases, Trac #10251)--   decompose (Var fn_id) args-      | not (fn_id `elemVarSet` orig_bndr_set)-      = Just (fn_id, args)--   decompose _ _ = Nothing--   bad_shape_msg = hang (text "RULE left-hand side too complicated to desugar")-                      2 (vcat [ text "Optimised lhs:" <+> ppr lhs2-                              , text "Orig lhs:" <+> ppr orig_lhs])-   dead_msg bndr = hang (sep [ text "Forall'd" <+> pp_bndr bndr-                             , text "is not bound in RULE lhs"])-                      2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs-                              , text "Orig lhs:" <+> ppr orig_lhs-                              , text "optimised lhs:" <+> ppr lhs2 ])-   pp_bndr bndr-    | isTyVar bndr                      = text "type variable" <+> quotes (ppr bndr)-    | Just pred <- evVarPred_maybe bndr = text "constraint" <+> quotes (ppr pred)-    | otherwise                         = text "variable" <+> quotes (ppr bndr)--   constructor_msg con = vcat-     [ text "A constructor," <+> ppr con <>-         text ", appears as outermost match in RULE lhs."-     , text "This rule will be ignored." ]--   drop_dicts :: CoreExpr -> CoreExpr-   drop_dicts e-       = wrap_lets needed bnds body-     where-       needed = orig_bndr_set `minusVarSet` exprFreeVars body-       (bnds, body) = split_lets (occurAnalyseExpr e)-           -- The occurAnalyseExpr drops dead bindings which is-           -- crucial to ensure that every binding is used later;-           -- which in turn makes wrap_lets work right--   split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)-   split_lets (Let (NonRec d r) body)-     | isDictId d-     = ((d,r):bs, body')-     where (bs, body') = split_lets body--    -- handle "unlifted lets" too, needed for "map/coerce"-   split_lets (Case r d _ [(DEFAULT, _, body)])-     | isCoVar d-     = ((d,r):bs, body')-     where (bs, body') = split_lets body--   split_lets e = ([], e)--   wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr-   wrap_lets _ [] body = body-   wrap_lets needed ((d, r) : bs) body-     | rhs_fvs `intersectsVarSet` needed = mkCoreLet (NonRec d r) (wrap_lets needed' bs body)-     | otherwise                         = wrap_lets needed bs body-     where-       rhs_fvs = exprFreeVars r-       needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d--{--Note [Decomposing the left-hand side of a RULE]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There are several things going on here.-* drop_dicts: see Note [Drop dictionary bindings on rule LHS]-* simpleOptExpr: see Note [Simplify rule LHS]-* extra_dict_bndrs: see Note [Free dictionaries]--Note [Free tyvars on rule LHS]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  data T a = C--  foo :: T a -> Int-  foo C = 1--  {-# RULES "myrule"  foo C = 1 #-}--After type checking the LHS becomes (foo alpha (C alpha)), where alpha-is an unbound meta-tyvar.  The zonker in TcHsSyn is careful not to-turn the free alpha into Any (as it usually does).  Instead it turns it-into a TyVar 'a'.  See TcHsSyn Note [Zonking the LHS of a RULE].--Now we must quantify over that 'a'.  It's /really/ inconvenient to do that-in the zonker, because the HsExpr data type is very large.  But it's /easy/-to do it here in the desugarer.--Moreover, we have to do something rather similar for dictionaries;-see Note [Free dictionaries on rule LHS].   So that's why we look for-type variables free on the LHS, and quantify over them.--Note [Free dictionaries on rule LHS]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,-which is presumably in scope at the function definition site, we can quantify-over it too.  *Any* dict with that type will do.--So for example when you have-        f :: Eq a => a -> a-        f = <rhs>-        ... SPECIALISE f :: Int -> Int ...--Then we get the SpecPrag-        SpecPrag (f Int dInt)--And from that we want the rule--        RULE forall dInt. f Int dInt = f_spec-        f_spec = let f = <rhs> in f Int dInt--But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External-Name, and you can't bind them in a lambda or forall without getting things-confused.   Likewise it might have an InlineRule or something, which would be-utterly bogus. So we really make a fresh Id, with the same unique and type-as the old one, but with an Internal name and no IdInfo.--Note [Drop dictionary bindings on rule LHS]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-drop_dicts drops dictionary bindings on the LHS where possible.-   E.g.  let d:Eq [Int] = $fEqList $fEqInt in f d-     --> f d-   Reasoning here is that there is only one d:Eq [Int], and so we can-   quantify over it. That makes 'd' free in the LHS, but that is later-   picked up by extra_dict_bndrs (Note [Dead spec binders]).--   NB 1: We can only drop the binding if the RHS doesn't bind-         one of the orig_bndrs, which we assume occur on RHS.-         Example-            f :: (Eq a) => b -> a -> a-            {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-}-         Here we want to end up with-            RULE forall d:Eq a.  f ($dfEqList d) = f_spec d-         Of course, the ($dfEqlist d) in the pattern makes it less likely-         to match, but there is no other way to get d:Eq a--   NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all-         the evidence bindings to be wrapped around the outside of the-         LHS.  (After simplOptExpr they'll usually have been inlined.)-         dsHsWrapper does dependency analysis, so that civilised ones-         will be simple NonRec bindings.  We don't handle recursive-         dictionaries!--    NB3: In the common case of a non-overloaded, but perhaps-polymorphic-         specialisation, we don't need to bind *any* dictionaries for use-         in the RHS. For example (Trac #8331)-             {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-}-             useAbstractMonad :: MonadAbstractIOST m => m Int-         Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code-         but the RHS uses no dictionaries, so we want to end up with-             RULE forall s (d :: MonadAbstractIOST (ReaderT s)).-                useAbstractMonad (ReaderT s) d = $suseAbstractMonad s--   Trac #8848 is a good example of where there are some intersting-   dictionary bindings to discard.--The drop_dicts algorithm is based on these observations:--  * Given (let d = rhs in e) where d is a DictId,-    matching 'e' will bind e's free variables.--  * So we want to keep the binding if one of the needed variables (for-    which we need a binding) is in fv(rhs) but not already in fv(e).--  * The "needed variables" are simply the orig_bndrs.  Consider-       f :: (Eq a, Show b) => a -> b -> String-       ... SPECIALISE f :: (Show b) => Int -> b -> String ...-    Then orig_bndrs includes the *quantified* dictionaries of the type-    namely (dsb::Show b), but not the one for Eq Int--So we work inside out, applying the above criterion at each step.---Note [Simplify rule LHS]-~~~~~~~~~~~~~~~~~~~~~~~~-simplOptExpr occurrence-analyses and simplifies the LHS:--   (a) Inline any remaining dictionary bindings (which hopefully-       occur just once)--   (b) Substitute trivial lets, so that they don't get in the way.-       Note that we substitute the function too; we might-       have this as a LHS:  let f71 = M.f Int in f71--   (c) Do eta reduction.  To see why, consider the fold/build rule,-       which without simplification looked like:-          fold k z (build (/\a. g a))  ==>  ...-       This doesn't match unless you do eta reduction on the build argument.-       Similarly for a LHS like-         augment g (build h)-       we do not want to get-         augment (\a. g a) (build h)-       otherwise we don't match when given an argument like-          augment (\a. h a a) (build h)--Note [Matching seqId]-~~~~~~~~~~~~~~~~~~~-The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack-and this code turns it back into an application of seq!-See Note [Rules for seq] in MkId for the details.--Note [Unused spec binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-        f :: a -> a-        ... SPECIALISE f :: Eq a => a -> a ...-It's true that this *is* a more specialised type, but the rule-we get is something like this:-        f_spec d = f-        RULE: f = f_spec d-Note that the rule is bogus, because it mentions a 'd' that is-not bound on the LHS!  But it's a silly specialisation anyway, because-the constraint is unused.  We could bind 'd' to (error "unused")-but it seems better to reject the program because it's almost certainly-a mistake.  That's what the isDeadBinder call detects.--Note [No RULES on datacons]-~~~~~~~~~~~~~~~~~~~~~~~~~~~--Previously, `RULES` like--    "JustNothing" forall x . Just x = Nothing--were allowed. Simon Peyton Jones says this seems to have been a-mistake, that such rules have never been supported intentionally,-and that he doesn't know if they can break in horrible ways.-Furthermore, Ben Gamari and Reid Barton are considering trying to-detect the presence of "static data" that the simplifier doesn't-need to traverse at all. Such rules do not play well with that.-So for now, we ban them altogether as requested by #13290. See also #7398.---************************************************************************-*                                                                      *-                Desugaring evidence-*                                                                      *-************************************************************************---}--dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)-dsHsWrapper WpHole            = return $ \e -> e-dsHsWrapper (WpTyApp ty)      = return $ \e -> App e (Type ty)-dsHsWrapper (WpEvLam ev)      = return $ Lam ev-dsHsWrapper (WpTyLam tv)      = return $ Lam tv-dsHsWrapper (WpLet ev_binds)  = do { bs <- dsTcEvBinds ev_binds-                                   ; return (mkCoreLets bs) }-dsHsWrapper (WpCompose c1 c2) = do { w1 <- dsHsWrapper c1-                                   ; w2 <- dsHsWrapper c2-                                   ; return (w1 . w2) }- -- See comments on WpFun in TcEvidence for an explanation of what- -- the specification of this clause is-dsHsWrapper (WpFun c1 c2 t1 doc)-                              = do { x  <- newSysLocalDsNoLP t1-                                   ; w1 <- dsHsWrapper c1-                                   ; w2 <- dsHsWrapper c2-                                   ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a-                                         arg     = w1 (Var x)-                                   ; (_, ok) <- askNoErrsDs $ dsNoLevPolyExpr arg doc-                                   ; if ok-                                     then return (\e -> (Lam x (w2 (app e arg))))-                                     else return id }  -- this return is irrelevant-dsHsWrapper (WpCast co)       = return $ \e -> mkCastDs e co-dsHsWrapper (WpEvApp tm)      = do { core_tm <- dsEvTerm tm-                                   ; return (\e -> App e core_tm) }-----------------------------------------dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind]-dsTcEvBinds_s []       = return []-dsTcEvBinds_s (b:_)    = dsTcEvBinds b--dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]-dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds"    -- Zonker has got rid of this-dsTcEvBinds (EvBinds bs)   = dsEvBinds bs--dsEvBinds :: Bag EvBind -> DsM [CoreBind]-dsEvBinds bs = mapM ds_scc (sccEvBinds bs)-  where-    ds_scc (AcyclicSCC (EvBind { eb_lhs = v, eb_rhs = r}))-                          = liftM (NonRec v) (dsEvTerm r)-    ds_scc (CyclicSCC bs) = liftM Rec (mapM dsEvBind bs)--dsEvBind :: EvBind -> DsM (Id, CoreExpr)-dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r)--{-**********************************************************************-*                                                                      *-           Desugaring EvTerms-*                                                                      *-**********************************************************************-}--dsEvTerm :: EvTerm -> DsM CoreExpr-dsEvTerm (EvId v)           = return (Var v)-dsEvTerm (EvCallStack cs)   = dsEvCallStack cs-dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev-dsEvTerm (EvLit (EvNum n))  = mkNaturalExpr n-dsEvTerm (EvLit (EvStr s))  = mkStringExprFS s--dsEvTerm (EvCast tm co)-  = do { tm' <- dsEvTerm tm-       ; return $ mkCastDs tm' co }--dsEvTerm (EvDFunApp df tys tms)-  = do { tms' <- mapM dsEvTerm tms-       ; return $ Var df `mkTyApps` tys `mkApps` tms' }-  -- The use of mkApps here is OK vis-a-vis levity polymorphism because-  -- the terms are always evidence variables with types of kind Constraint--dsEvTerm (EvCoercion co) = return (Coercion co)-dsEvTerm (EvSuperClass d n)-  = do { d' <- dsEvTerm d-       ; let (cls, tys) = getClassPredTys (exprType d')-             sc_sel_id  = classSCSelId cls n    -- Zero-indexed-       ; return $ Var sc_sel_id `mkTyApps` tys `App` d' }--dsEvTerm (EvSelector sel_id tys tms)-  = do { tms' <- mapM dsEvTerm tms-       ; return $ Var sel_id `mkTyApps` tys `mkApps` tms' }--dsEvTerm (EvDelayedError ty msg) = return $ dsEvDelayedError ty msg--dsEvDelayedError :: Type -> FastString -> CoreExpr-dsEvDelayedError ty msg-  = Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg]-  where-    errorId = tYPE_ERROR_ID-    litMsg  = Lit (MachStr (fastStringToByteString msg))--{-**********************************************************************-*                                                                      *-           Desugaring Typeable dictionaries-*                                                                      *-**********************************************************************-}--dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr--- Return a CoreExpr :: Typeable ty--- This code is tightly coupled to the representation--- of TypeRep, in base library Data.Typeable.Internals-dsEvTypeable ty ev-  = do { tyCl <- dsLookupTyCon typeableClassName    -- Typeable-       ; let kind = typeKind ty-             Just typeable_data_con-                 = tyConSingleDataCon_maybe tyCl    -- "Data constructor"-                                                    -- for Typeable--       ; rep_expr <- ds_ev_typeable ty ev           -- :: TypeRep a--       -- Package up the method as `Typeable` dictionary-       ; return $ mkConApp typeable_data_con [Type kind, Type ty, rep_expr] }--type TypeRepExpr = CoreExpr---- | Returns a @CoreExpr :: TypeRep ty@-ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr-ds_ev_typeable ty (EvTypeableTyCon tc kind_ev)-  = do { mkTrCon <- dsLookupGlobalId mkTrConName-                    -- mkTrCon :: forall k (a :: k). TyCon -> TypeRep k -> TypeRep a-       ; someTypeRepTyCon <- dsLookupTyCon someTypeRepTyConName-       ; someTypeRepDataCon <- dsLookupDataCon someTypeRepDataConName-                    -- SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep--       ; tc_rep <- tyConRep tc                      -- :: TyCon-       ; let ks = tyConAppArgs ty-             -- Construct a SomeTypeRep-             toSomeTypeRep :: Type -> EvTerm -> DsM CoreExpr-             toSomeTypeRep t ev = do-                 rep <- getRep ev t-                 return $ mkCoreConApps someTypeRepDataCon [Type (typeKind t), Type t, rep]-       ; kind_arg_reps <- sequence $ zipWith toSomeTypeRep ks kind_ev   -- :: TypeRep t-       ; let -- :: [SomeTypeRep]-             kind_args = mkListExpr (mkTyConTy someTypeRepTyCon) kind_arg_reps--         -- Note that we use the kind of the type, not the TyCon from which it-         -- is constructed since the latter may be kind polymorphic whereas the-         -- former we know is not (we checked in the solver).-       ; return $ mkApps (Var mkTrCon) [ Type (typeKind ty)-                                       , Type ty-                                       , tc_rep-                                       , kind_args ]-       }--ds_ev_typeable ty (EvTypeableTyApp ev1 ev2)-  | Just (t1,t2) <- splitAppTy_maybe ty-  = do { e1  <- getRep ev1 t1-       ; e2  <- getRep ev2 t2-       ; mkTrApp <- dsLookupGlobalId mkTrAppName-                    -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).-                    --            TypeRep a -> TypeRep b -> TypeRep (a b)-       ; let (k1, k2) = splitFunTy (typeKind t1)-       ; return $ mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ])-                         [ e1, e2 ] }--ds_ev_typeable ty (EvTypeableTrFun ev1 ev2)-  | Just (t1,t2) <- splitFunTy_maybe ty-  = do { e1 <- getRep ev1 t1-       ; e2 <- getRep ev2 t2-       ; mkTrFun <- dsLookupGlobalId mkTrFunName-                    -- mkTrFun :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2).-                    --            TypeRep a -> TypeRep b -> TypeRep (a -> b)-       ; let r1 = getRuntimeRep t1-             r2 = getRuntimeRep t2-       ; return $ mkApps (mkTyApps (Var mkTrFun) [r1, r2, t1, t2])-                         [ e1, e2 ]-       }--ds_ev_typeable ty (EvTypeableTyLit ev)-  = do { fun  <- dsLookupGlobalId tr_fun-       ; dict <- dsEvTerm ev       -- Of type KnownNat/KnownSym-       ; let proxy = mkTyApps (Var proxyHashId) [ty_kind, ty]-       ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict, proxy ]) }-  where-    ty_kind = typeKind ty--    -- tr_fun is the Name of-    --       typeNatTypeRep    :: KnownNat    a => Proxy# a -> TypeRep a-    -- of    typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep a-    tr_fun | ty_kind `eqType` typeNatKind    = typeNatTypeRepName-           | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName-           | otherwise = panic "dsEvTypeable: unknown type lit kind"--ds_ev_typeable ty ev-  = pprPanic "dsEvTypeable" (ppr ty $$ ppr ev)--getRep :: EvTerm          -- ^ EvTerm for @Typeable ty@-       -> Type            -- ^ The type @ty@-       -> DsM TypeRepExpr -- ^ Return @CoreExpr :: TypeRep ty@-                          -- namely @typeRep# dict@--- Remember that---   typeRep# :: forall k (a::k). Typeable k a -> TypeRep a-getRep ev ty-  = do { typeable_expr <- dsEvTerm ev-       ; typeRepId     <- dsLookupGlobalId typeRepIdName-       ; let ty_args = [typeKind ty, ty]-       ; return (mkApps (mkTyApps (Var typeRepId) ty_args) [ typeable_expr ]) }--tyConRep :: TyCon -> DsM CoreExpr--- Returns CoreExpr :: TyCon-tyConRep tc-  | Just tc_rep_nm <- tyConRepName_maybe tc-  = do { tc_rep_id <- dsLookupGlobalId tc_rep_nm-       ; return (Var tc_rep_id) }-  | otherwise-  = pprPanic "tyConRep" (ppr tc)--{- Note [Memoising typeOf]-~~~~~~~~~~~~~~~~~~~~~~~~~~-See #3245, #9203--IMPORTANT: we don't want to recalculate the TypeRep once per call with-the proxy argument.  This is what went wrong in #3245 and #9203. So we-help GHC by manually keeping the 'rep' *outside* the lambda.--}---{-**********************************************************************-*                                                                      *-           Desugaring EvCallStack evidence-*                                                                      *-**********************************************************************-}--dsEvCallStack :: EvCallStack -> DsM CoreExpr--- See Note [Overview of implicit CallStacks] in TcEvidence.hs-dsEvCallStack cs = do-  df            <- getDynFlags-  m             <- getModule-  srcLocDataCon <- dsLookupDataCon srcLocDataConName-  let mkSrcLoc l =-        liftM (mkCoreConApps srcLocDataCon)-              (sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m)-                        , mkStringExprFS (moduleNameFS $ moduleName m)-                        , mkStringExprFS (srcSpanFile l)-                        , return $ mkIntExprInt df (srcSpanStartLine l)-                        , return $ mkIntExprInt df (srcSpanStartCol l)-                        , return $ mkIntExprInt df (srcSpanEndLine l)-                        , return $ mkIntExprInt df (srcSpanEndCol l)-                        ])--  emptyCS <- Var <$> dsLookupGlobalId emptyCallStackName--  pushCSVar <- dsLookupGlobalId pushCallStackName-  let pushCS name loc rest =-        mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest]--  let mkPush name loc tm = do-        nameExpr <- mkStringExprFS name-        locExpr <- mkSrcLoc loc-        case tm of-          EvCallStack EvCsEmpty -> return (pushCS nameExpr locExpr emptyCS)-          _ -> do tmExpr  <- dsEvTerm tm-                  -- at this point tmExpr :: IP sym CallStack-                  -- but we need the actual CallStack to pass to pushCS,-                  -- so we use unwrapIP to strip the dictionary wrapper-                  -- See Note [Overview of implicit CallStacks]-                  let ip_co = unwrapIP (exprType tmExpr)-                  return (pushCS nameExpr locExpr (mkCastDs tmExpr ip_co))-  case cs of-    EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm-    EvCsEmpty -> return emptyCS
− src/Language/Haskell/Liquid/Desugar/DsCCall.hs 
@@ -1,369 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The AQUA Project, Glasgow University, 1994-1998---Desugaring foreign calls--}--{-# LANGUAGE CPP #-}-module Language.Haskell.Liquid.Desugar.DsCCall-        ( dsCCall-        , mkFCall-        , unboxArg-        , boxResult-        , resultWrapper-        ) where---import CoreSyn--import Language.Haskell.Liquid.Desugar.DsMonad-import CoreUtils-import MkCore-import MkId-import ForeignCall-import DataCon-import Language.Haskell.Liquid.Desugar.DsUtils--import TcType-import Type-import Id   ( Id )-import Coercion-import PrimOp-import TysPrim-import TyCon-import TysWiredIn-import BasicTypes-import Literal-import PrelNames-import DynFlags-import Outputable--import Data.Maybe--{--Desugaring of @ccall@s consists of adding some state manipulation,-unboxing any boxed primitive arguments and boxing the result if-desired.--The state stuff just consists of adding in-@PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place.--The unboxing is straightforward, as all information needed to unbox is-available from the type.  For each boxed-primitive argument, we-transform:-\begin{verbatim}-   _ccall_ foo [ r, t1, ... tm ] e1 ... em-   |-   |-   V-   case e1 of { T1# x1# ->-   ...-   case em of { Tm# xm# -> xm#-   ccall# foo [ r, t1#, ... tm# ] x1# ... xm#-   } ... }-\end{verbatim}--The reboxing of a @_ccall_@ result is a bit tricker: the types don't-contain information about the state-pairing functions so we have to-keep a list of \tr{(type, s-p-function)} pairs.  We transform as-follows:-\begin{verbatim}-   ccall# foo [ r, t1#, ... tm# ] e1# ... em#-   |-   |-   V-   \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of-          (StateAnd<r># result# state#) -> (R# result#, realWorld#)-\end{verbatim}--}--dsCCall :: CLabelString -- C routine to invoke-        -> [CoreExpr]   -- Arguments (desugared)-                        -- Precondition: none have levity-polymorphic types-        -> Safety       -- Safety of the call-        -> Type         -- Type of the result: IO t-        -> DsM CoreExpr -- Result, of type ???--dsCCall lbl args may_gc result_ty-  = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args-       (ccall_result_ty, res_wrapper) <- boxResult result_ty-       uniq <- newUnique-       dflags <- getDynFlags-       let-           target = StaticTarget NoSourceText lbl Nothing True-           the_fcall    = CCall (CCallSpec target CCallConv may_gc)-           the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty-       return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)--mkFCall :: DynFlags -> Unique -> ForeignCall-        -> [CoreExpr]     -- Args-        -> Type           -- Result type-        -> CoreExpr--- Construct the ccall.  The only tricky bit is that the ccall Id should have--- no free vars, so if any of the arg tys do we must give it a polymorphic type.---      [I forget *why* it should have no free vars!]--- For example:---      mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char]------ Here we build a ccall thus---      (ccallid::(forall a b.  StablePtr (a -> b) -> Addr -> Char -> IO Addr))---                      a b s x c-mkFCall dflags uniq the_fcall val_args res_ty-  = mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args-  where-    arg_tys = map exprType val_args-    body_ty = (mkFunTys arg_tys res_ty)-    tyvars  = tyCoVarsOfTypeWellScoped body_ty-    ty      = mkInvForAllTys tyvars body_ty-    the_fcall_id = mkFCallId dflags uniq the_fcall ty--unboxArg :: CoreExpr                    -- The supplied argument, not levity-polymorphic-         -> DsM (CoreExpr,              -- To pass as the actual argument-                 CoreExpr -> CoreExpr   -- Wrapper to unbox the arg-                )--- Example: if the arg is e::Int, unboxArg will return---      (x#::Int#, \W. case x of I# x# -> W)--- where W is a CoreExpr that probably mentions x#---- always returns a non-levity-polymorphic expression--unboxArg arg-  -- Primtive types: nothing to unbox-  | isPrimitiveType arg_ty-  = return (arg, \body -> body)--  -- Recursive newtypes-  | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty-  = unboxArg (mkCastDs arg co)--  -- Booleans-  | Just tc <- tyConAppTyCon_maybe arg_ty,-    tc `hasKey` boolTyConKey-  = do dflags <- getDynFlags-       prim_arg <- newSysLocalDs intPrimTy-       return (Var prim_arg,-              \ body -> Case (mkWildCase arg arg_ty intPrimTy-                                       [(DataAlt falseDataCon,[],mkIntLit dflags 0),-                                        (DataAlt trueDataCon, [],mkIntLit dflags 1)])-                                        -- In increasing tag order!-                             prim_arg-                             (exprType body)-                             [(DEFAULT,[],body)])--  -- Data types with a single constructor, which has a single, primitive-typed arg-  -- This deals with Int, Float etc; also Ptr, ForeignPtr-  | is_product_type && data_con_arity == 1-  = do case_bndr <- newSysLocalDs arg_ty-       prim_arg <- newSysLocalDs data_con_arg_ty1-       return (Var prim_arg,-               \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]-              )--  -- Byte-arrays, both mutable and otherwise; hack warning-  -- We're looking for values of type ByteArray, MutableByteArray-  --    data ByteArray          ix = ByteArray        ix ix ByteArray#-  --    data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)-  | is_product_type &&-    data_con_arity == 3 &&-    isJust maybe_arg3_tycon &&-    (arg3_tycon ==  byteArrayPrimTyCon ||-     arg3_tycon ==  mutableByteArrayPrimTyCon)-  = do case_bndr <- newSysLocalDs arg_ty-       vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys-       return (Var arr_cts_var,-               \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]-              )--  | otherwise-  = do l <- getSrcSpanDs-       pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)-  where-    arg_ty                                      = exprType arg-    maybe_product_type                          = splitDataProductType_maybe arg_ty-    is_product_type                             = isJust maybe_product_type-    Just (_, _, data_con, data_con_arg_tys)     = maybe_product_type-    data_con_arity                              = dataConSourceArity data_con-    (data_con_arg_ty1 : _)                      = data_con_arg_tys--    (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys-    maybe_arg3_tycon               = tyConAppTyCon_maybe data_con_arg_ty3-    Just arg3_tycon                = maybe_arg3_tycon--boxResult :: Type-          -> DsM (Type, CoreExpr -> CoreExpr)---- Takes the result of the user-level ccall:---      either (IO t),---      or maybe just t for an side-effect-free call--- Returns a wrapper for the primitive ccall itself, along with the--- type of the result of the primitive ccall.  This result type--- will be of the form---      State# RealWorld -> (# State# RealWorld, t' #)--- where t' is the unwrapped form of t.  If t is simply (), then--- the result type will be---      State# RealWorld -> (# State# RealWorld #)--boxResult result_ty-  | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty-        -- isIOType_maybe handles the case where the type is a-        -- simple wrapping of IO.  E.g.-        --      newtype Wrap a = W (IO a)-        -- No coercion necessary because its a non-recursive newtype-        -- (If we wanted to handle a *recursive* newtype too, we'd need-        -- another case, and a coercion.)-        -- The result is IO t, so wrap the result in an IO constructor-  = do  { res <- resultWrapper io_res_ty-        ; let extra_result_tys-                = case res of-                     (Just ty,_)-                       | isUnboxedTupleType ty-                       -> let Just ls = tyConAppArgs_maybe ty in tail ls-                     _ -> []--              return_result state anss-                = mkCoreUbxTup-                    (realWorldStatePrimTy : io_res_ty : extra_result_tys)-                    (state : anss)--        ; (ccall_res_ty, the_alt) <- mk_alt return_result res--        ; state_id <- newSysLocalDs realWorldStatePrimTy-        ; let io_data_con = head (tyConDataCons io_tycon)-              toIOCon     = dataConWrapId io_data_con--              wrap the_call =-                              mkApps (Var toIOCon)-                                     [ Type io_res_ty,-                                       Lam state_id $-                                       mkWildCase (App the_call (Var state_id))-                                             ccall_res_ty-                                             (coreAltType the_alt)-                                             [the_alt]-                                     ]--        ; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) }--boxResult result_ty-  = do -- It isn't IO, so do unsafePerformIO-       -- It's not conveniently available, so we inline it-       res <- resultWrapper result_ty-       (ccall_res_ty, the_alt) <- mk_alt return_result res-       let-           wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId))-                                           ccall_res_ty-                                           (coreAltType the_alt)-                                           [the_alt]-       return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)-  where-    return_result _ [ans] = ans-    return_result _ _     = panic "return_result: expected single result"---mk_alt :: (Expr Var -> [Expr Var] -> Expr Var)-       -> (Maybe Type, Expr Var -> Expr Var)-       -> DsM (Type, (AltCon, [Id], Expr Var))-mk_alt return_result (Nothing, wrap_result)-  = do -- The ccall returns ()-       state_id <- newSysLocalDs realWorldStatePrimTy-       let-             the_rhs = return_result (Var state_id)-                                     [wrap_result (panic "boxResult")]--             ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy]-             the_alt      = (DataAlt (tupleDataCon Unboxed 1), [state_id], the_rhs)--       return (ccall_res_ty, the_alt)--mk_alt return_result (Just prim_res_ty, wrap_result)-  = -- The ccall returns a non-() value-    do { result_id <- newSysLocalDs prim_res_ty-       ; state_id <- newSysLocalDs realWorldStatePrimTy-       ; let the_rhs = return_result (Var state_id)-                                [wrap_result (Var result_id)]-             ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty]-             the_alt      = (DataAlt (tupleDataCon Unboxed 2), [state_id, result_id], the_rhs)-       ; return (ccall_res_ty, the_alt) }---resultWrapper :: Type-              -> DsM (Maybe Type,               -- Type of the expected result, if any-                      CoreExpr -> CoreExpr)     -- Wrapper for the result--- resultWrapper deals with the result *value*--- E.g. foreign import foo :: Int -> IO T--- Then resultWrapper deals with marshalling the 'T' part--- So if    resultWrapper ty = (Just ty_rep, marshal)---  then      marshal (e :: ty_rep) :: ty--- That is, 'marshal' wrape the result returned by the foreign call,--- of type ty_rep, into the value Haskell expected, of type 'ty'------ Invariant: ty_rep is always a primitive type---            i.e. (isPrimitiveType ty_rep) is True--resultWrapper result_ty-  -- Base case 1: primitive types-  | isPrimitiveType result_ty-  = return (Just result_ty, \e -> e)--  -- Base case 2: the unit type ()-  | Just (tc,_) <- maybe_tc_app-  , tc `hasKey` unitTyConKey-  = return (Nothing, \_ -> Var unitDataConId)--  -- Base case 3: the boolean type-  | Just (tc,_) <- maybe_tc_app-  , tc `hasKey` boolTyConKey-  = do { dflags <- getDynFlags-       ; let marshal_bool e-               = mkWildCase e intPrimTy boolTy-                   [ (DEFAULT                    ,[],Var trueDataConId )-                   , (LitAlt (mkMachInt dflags 0),[],Var falseDataConId)]-       ; return (Just intPrimTy, marshal_bool) }--  -- Newtypes-  | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty-  = do { (maybe_ty, wrapper) <- resultWrapper rep_ty-       ; return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co)) }--  -- The type might contain foralls (eg. for dummy type arguments,-  -- referring to 'Ptr a' is legal).-  | Just (tyvar, rest) <- splitForAllTy_maybe result_ty-  = do { (maybe_ty, wrapper) <- resultWrapper rest-       ; return (maybe_ty, \e -> Lam tyvar (wrapper e)) }--  -- Data types with a single constructor, which has a single arg-  -- This includes types like Ptr and ForeignPtr-  | Just (tycon, tycon_arg_tys) <- maybe_tc_app-  , Just data_con <- isDataProductTyCon_maybe tycon  -- One construtor, no existentials-  , [unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys  -- One argument-  = do { dflags <- getDynFlags-       ; (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty-       ; let narrow_wrapper = maybeNarrow dflags tycon-             marshal_con e  = Var (dataConWrapId data_con)-                              `mkTyApps` tycon_arg_tys-                              `App` wrapper (narrow_wrapper e)-       ; return (maybe_ty, marshal_con) }--  | otherwise-  = pprPanic "resultWrapper" (ppr result_ty)-  where-    maybe_tc_app = splitTyConApp_maybe result_ty---- When the result of a foreign call is smaller than the word size, we--- need to sign- or zero-extend the result up to the word size.  The C--- standard appears to say that this is the responsibility of the--- caller, not the callee.--maybeNarrow :: DynFlags -> TyCon -> (CoreExpr -> CoreExpr)-maybeNarrow dflags tycon-  | tycon `hasKey` int8TyConKey   = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e-  | tycon `hasKey` int16TyConKey  = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e-  | tycon `hasKey` int32TyConKey-         && wORD_SIZE dflags > 4         = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e--  | tycon `hasKey` word8TyConKey  = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e-  | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e-  | tycon `hasKey` word32TyConKey-         && wORD_SIZE dflags > 4         = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e-  | otherwise                     = id
− src/Language/Haskell/Liquid/Desugar/DsExpr.hs 
@@ -1,1057 +0,0 @@-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-Desugaring expressions.
--}
-
-{-# LANGUAGE CPP, MultiWayIf #-}
-
-module Language.Haskell.Liquid.Desugar.DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds
-              , dsValBinds, dsLit, dsSyntaxExpr ) where
-
-import Language.Haskell.Liquid.Desugar.Match
-import Language.Haskell.Liquid.Desugar.MatchLit
-import Language.Haskell.Liquid.Desugar.DsBinds
-import Language.Haskell.Liquid.Desugar.DsGRHSs
-import Language.Haskell.Liquid.Desugar.DsListComp
-import Language.Haskell.Liquid.Desugar.DsUtils
-import Language.Haskell.Liquid.Desugar.DsArrows
-import Language.Haskell.Liquid.Desugar.DsMonad
-import Name
-import NameEnv
-import FamInstEnv( topNormaliseType )
-import Language.Haskell.Liquid.Desugar.DsMeta
-import HsSyn
-
--- NB: The desugarer, which straddles the source and Core worlds, sometimes
---     needs to see source types
-import TcType
-import TcEvidence
-import TcRnMonad
-import TcHsSyn
-import Type
-import CoreSyn
-import CoreUtils
-import MkCore
-
-import DynFlags
-import CostCentre
-import Id
-import MkId
-import Module
-import ConLike
-import DataCon
-import TysWiredIn
-import PrelNames
-import BasicTypes
-import Maybes
-import VarEnv
-import SrcLoc
-import Util
-import Bag
-import Outputable
-import PatSyn
-
-import Control.Monad
-
-{-
-************************************************************************
-*                                                                      *
-                dsLocalBinds, dsValBinds
-*                                                                      *
-************************************************************************
--}
-
-dsLocalBinds :: LHsLocalBinds Id -> CoreExpr -> DsM CoreExpr
-dsLocalBinds (L _   EmptyLocalBinds)    body = return body
-dsLocalBinds (L loc (HsValBinds binds)) body = putSrcSpanDs loc $
-                                               dsValBinds binds body
-dsLocalBinds (L _ (HsIPBinds binds))    body = dsIPBinds  binds body
-
--------------------------
--- caller sets location
-dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
-dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
-dsValBinds (ValBindsIn {})       _    = panic "dsValBinds ValBindsIn"
-
--------------------------
-dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
-dsIPBinds (IPBinds ip_binds ev_binds) body
-  = do  { ds_binds <- dsTcEvBinds ev_binds
-        ; let inner = mkCoreLets ds_binds body
-                -- The dict bindings may not be in
-                -- dependency order; hence Rec
-        ; foldrM ds_ip_bind inner ip_binds }
-  where
-    ds_ip_bind (L _ (IPBind ~(Right n) e)) body
-      = do e' <- dsLExpr e
-           return (Let (NonRec n e') body)
-
--------------------------
--- caller sets location
-ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
--- Special case for bindings which bind unlifted variables
--- We need to do a case right away, rather than building
--- a tuple and doing selections.
--- Silently ignore INLINE and SPECIALISE pragmas...
-ds_val_bind (NonRecursive, hsbinds) body
-  | [L loc bind] <- bagToList hsbinds
-        -- Non-recursive, non-overloaded bindings only come in ones
-        -- ToDo: in some bizarre case it's conceivable that there
-        --       could be dict binds in the 'binds'.  (See the notes
-        --       below.  Then pattern-match would fail.  Urk.)
-  , isUnliftedHsBind bind
-  = putSrcSpanDs loc $
-     -- see Note [Strict binds checks] in DsBinds
-    if is_polymorphic bind
-    then errDsCoreExpr (poly_bind_err bind)
-            -- data Ptr a = Ptr Addr#
-            -- f x = let p@(Ptr y) = ... in ...
-            -- Here the binding for 'p' is polymorphic, but does
-            -- not mix with an unlifted binding for 'y'.  You should
-            -- use a bang pattern.  Trac #6078.
-
-    else do { when (looksLazyPatBind bind) $
-              warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind)
-        -- Complain about a binding that looks lazy
-        --    e.g.    let I# y = x in ...
-        -- Remember, in checkStrictBinds we are going to do strict
-        -- matching, so (for software engineering reasons) we insist
-        -- that the strictness is manifest on each binding
-        -- However, lone (unboxed) variables are ok
-
-
-            ; dsUnliftedBind bind body }
-  where
-    is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })
-                     = not (null tvs && null evs)
-    is_polymorphic (AbsBindsSig { abs_tvs = tvs, abs_ev_vars = evs })
-                     = not (null tvs && null evs)
-    is_polymorphic _ = False
-
-    unlifted_must_be_bang bind
-      = hang (text "Pattern bindings containing unlifted types should use" $$
-              text "an outermost bang pattern:")
-           2 (ppr bind)
-
-    poly_bind_err bind
-      = hang (text "You can't mix polymorphic and unlifted bindings:")
-           2 (ppr bind) $$
-        text "Probable fix: add a type signature"
-
-ds_val_bind (_, binds) _body
-  | anyBag (isUnliftedHsBind . unLoc) binds  -- see Note [Strict binds checks] in DsBinds
-  = errDsCoreExpr $
-    hang (text "Recursive bindings for unlifted types aren't allowed:")
-       2 (vcat (map ppr (bagToList binds)))
-
--- Ordinary case for bindings; none should be unlifted
-ds_val_bind (_, binds) body
-  = do  { (force_vars,prs) <- dsLHsBinds binds
-        ; let body' = foldr seqVar body force_vars
-        ; case prs of
-            [] -> return body
-            _  -> return (Let (Rec prs) body') }
-        -- Use a Rec regardless of is_rec.
-        -- Why? Because it allows the binds to be all
-        -- mixed up, which is what happens in one rare case
-        -- Namely, for an AbsBind with no tyvars and no dicts,
-        --         but which does have dictionary bindings.
-        -- See notes with TcSimplify.inferLoop [NO TYVARS]
-        -- It turned out that wrapping a Rec here was the easiest solution
-        --
-        -- NB The previous case dealt with unlifted bindings, so we
-        --    only have to deal with lifted ones now; so Rec is ok
-
-------------------
-dsUnliftedBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
-dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
-               , abs_exports = exports
-               , abs_ev_binds = ev_binds
-               , abs_binds = lbinds }) body
-  = do { let body1 = foldr bind_export body exports
-             bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
-       ; body2 <- foldlBagM (\body lbind -> dsUnliftedBind (unLoc lbind) body)
-                            body1 lbinds
-       ; ds_binds <- dsTcEvBinds_s ev_binds
-       ; return (mkCoreLets ds_binds body2) }
-
-dsUnliftedBind (AbsBindsSig { abs_tvs         = []
-                            , abs_ev_vars     = []
-                            , abs_sig_export  = poly
-                            , abs_sig_ev_bind = ev_bind
-                            , abs_sig_bind    = L _ bind }) body
-  = do { ds_binds <- dsTcEvBinds ev_bind
-       ; body' <- dsUnliftedBind (bind { fun_id = noLoc poly }) body
-       ; return (mkCoreLets ds_binds body') }
-
-dsUnliftedBind (FunBind { fun_id = L l fun
-                        , fun_matches = matches
-                        , fun_tick = tick }) body
-               -- Can't be a bang pattern (that looks like a PatBind)
-               -- so must be simply unboxed
-  = do { (_, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun))
-                                     Nothing matches
-       ; let rhs' = mkOptTickBox tick rhs
-       ; return (bindNonRec fun rhs' body) }
-
-dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
-  =     -- let C x# y# = rhs in body
-        -- ==> case rhs of C x# y# -> body
-    do { rhs <- dsGuarded grhss ty
-       ; let upat = unLoc pat
-             eqn = EqnInfo { eqn_pats = [upat],
-                             eqn_rhs = cantFailMatchResult body }
-       ; var    <- selectMatchVar upat
-       ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
-       ; return (bindNonRec var rhs result) }
-
-dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
-
-{-
-************************************************************************
-*                                                                      *
-\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
-*                                                                      *
-************************************************************************
--}
-
-dsLExpr :: LHsExpr Id -> DsM CoreExpr
-
-dsLExpr (L loc e)
-  = do ce <- putSrcSpanDs loc $ dsExpr e
-       m <- getModule
-       return $ Tick (srcSpanTick m loc) ce 
-
-srcSpanTick :: Module -> SrcSpan -> Tickish a
-srcSpanTick m loc
-  = ProfNote (AllCafsCC m loc) False True
--- | Variant of 'dsLExpr' that ensures that the result is not levity
--- polymorphic. This should be used when the resulting expression will
--- be an argument to some other function.
--- See Note [Levity polymorphism checking] in DsMonad
--- See Note [Levity polymorphism invariants] in CoreSyn
-dsLExprNoLP :: LHsExpr Id -> DsM CoreExpr
-dsLExprNoLP (L loc e)
-  = putSrcSpanDs loc $
-    do { e' <- dsExpr e
-       ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e)
-       ; return e' }
-
-dsExpr :: HsExpr Id -> DsM CoreExpr
-dsExpr (HsPar e)              = dsLExpr e
-dsExpr (ExprWithTySigOut e _) = dsLExpr e
-dsExpr (HsVar (L _ var))      = return (varToCoreExpr var)
-                                -- See Note [Desugaring vars]
-dsExpr (HsUnboundVar {})      = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
-dsExpr (HsConLikeOut con)     = return (dsConLike con)
-dsExpr (HsIPVar _)            = panic "dsExpr: HsIPVar"
-dsExpr (HsOverLabel{})        = panic "dsExpr: HsOverLabel"
-dsExpr (HsLit lit)            = dsLit lit
-dsExpr (HsOverLit lit)        = dsOverLit lit
-
-dsExpr (HsWrap co_fn e)
-  = do { e' <- dsExpr e
-       ; wrap' <- dsHsWrapper co_fn
-       ; dflags <- getDynFlags
-       ; let wrapped_e = wrap' e'
-       ; warnAboutIdentities dflags e' (exprType wrapped_e)
-       ; return wrapped_e }
-
-dsExpr (NegApp (L loc (HsOverLit lit@(OverLit { ol_val = HsIntegral src i })))
-                neg_expr)
-  = do { expr' <- putSrcSpanDs loc $ do
-          { dflags <- getDynFlags
-          ; warnAboutOverflowedLiterals dflags
-                                        (lit { ol_val = HsIntegral src (-i) })
-          ; dsOverLit' dflags lit }
-       ; dsSyntaxExpr neg_expr [expr'] }
-
-dsExpr (NegApp expr neg_expr)
-  = do { expr' <- dsLExpr expr
-       ; dsSyntaxExpr neg_expr [expr'] }
-
-dsExpr (HsLam a_Match)
-  = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match
-
-dsExpr (HsLamCase matches)
-  = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
-       ; return $ Lam discrim_var matching_code }
-
-dsExpr e@(HsApp fun arg)
-  = do { fun' <- dsLExpr fun
-       ; dsWhenNoErrs (dsLExprNoLP arg)
-                      (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') }
-
-dsExpr (HsAppTypeOut e _)
-    -- ignore type arguments here; they're in the wrappers instead at this point
-  = dsLExpr e
-
-
-{-
-Note [Desugaring vars]
-~~~~~~~~~~~~~~~~~~~~~~
-In one situation we can get a *coercion* variable in a HsVar, namely
-the support method for an equality superclass:
-   class (a~b) => C a b where ...
-   instance (blah) => C (T a) (T b) where ..
-Then we get
-   $dfCT :: forall ab. blah => C (T a) (T b)
-   $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah)
-
-   $c$p1C :: forall ab. blah => (T a ~ T b)
-   $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g
-
-That 'g' in the 'in' part is an evidence variable, and when
-converting to core it must become a CO.
-
-Operator sections.  At first it looks as if we can convert
-\begin{verbatim}
-        (expr op)
-\end{verbatim}
-to
-\begin{verbatim}
-        \x -> op expr x
-\end{verbatim}
-
-But no!  expr might be a redex, and we can lose laziness badly this
-way.  Consider
-\begin{verbatim}
-        map (expr op) xs
-\end{verbatim}
-for example.  So we convert instead to
-\begin{verbatim}
-        let y = expr in \x -> op y x
-\end{verbatim}
-If \tr{expr} is actually just a variable, say, then the simplifier
-will sort it out.
--}
-
-dsExpr e@(OpApp e1 op _ e2)
-  = -- for the type of y, we need the type of op's 2nd argument
-    do { op' <- dsLExpr op
-       ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2])
-                      (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') }
-
-dsExpr (SectionL expr op)       -- Desugar (e !) to ((!) e)
-  = do { op' <- dsLExpr op
-       ; dsWhenNoErrs (dsLExprNoLP expr)
-                      (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') }
-
--- dsLExpr (SectionR op expr)   -- \ x -> op x expr
-dsExpr e@(SectionR op expr) = do
-    core_op <- dsLExpr op
-    -- for the type of x, we need the type of op's 2nd argument
-    let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
-        -- See comment with SectionL
-    y_core <- dsLExpr expr
-    dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty])
-                 (\[x_id, y_id] -> bindNonRec y_id y_core $
-                                   Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e)
-                                                          core_op [Var x_id, Var y_id]))
-
-dsExpr (ExplicitTuple tup_args boxity)
-  = do { let go (lam_vars, args) (L _ (Missing ty))
-                    -- For every missing expression, we need
-                    -- another lambda in the desugaring.
-               = do { lam_var <- newSysLocalDsNoLP ty
-                    ; return (lam_var : lam_vars, Var lam_var : args) }
-             go (lam_vars, args) (L _ (Present expr))
-                    -- Expressions that are present don't generate
-                    -- lambdas, just arguments.
-               = do { core_expr <- dsLExpr expr
-                    ; return (lam_vars, core_expr : args) }
-
-       ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)
-                -- The reverse is because foldM goes left-to-right
-
-       ; return $ mkCoreLams lam_vars $
-                  mkCoreTupBoxity boxity args }
-
-dsExpr (ExplicitSum alt arity expr types)
-  = do { core_expr <- dsLExpr expr
-       ; return $ mkCoreConApps (sumDataCon alt arity)
-                                (map (Type . getRuntimeRep) types ++
-                                 map Type types ++
-                                 [core_expr]) }
-
-dsExpr (HsSCC _ cc expr@(L loc _)) = do
-    dflags <- getDynFlags
-    if gopt Opt_SccProfilingOn dflags
-      then do
-        mod_name <- getModule
-        count <- goptM Opt_ProfCountEntries
-#ifdef DETERMINISTIC_PROFILING
-        let nm = sl_fs cc
-        flavour <- ExprCC <$> getCCIndexM nm
-        Tick (ProfNote (mkUserCC nm mod_name loc flavour) count True)
-#else
-        uniq <- newUnique
-        Tick (ProfNote (mkUserCC (sl_fs cc) mod_name loc uniq) count True)
-#endif
-               <$> dsLExpr expr
-      else dsLExpr expr
-
-dsExpr (HsCoreAnn _ _ expr)
-  = dsLExpr expr
-
-dsExpr (HsCase discrim matches)
-  = do { core_discrim <- dsLExpr discrim
-       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches
-       ; return (bindNonRec discrim_var core_discrim matching_code) }
-
--- Pepe: The binds are in scope in the body but NOT in the binding group
---       This is to avoid silliness in breakpoints
-dsExpr (HsLet binds body) = do
-    body' <- dsLExpr body
-    dsLocalBinds binds body'
-
--- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
--- because the interpretation of `stmts' depends on what sort of thing it is.
---
-dsExpr (HsDo ListComp     (L _ stmts) res_ty) = dsListComp stmts res_ty
-dsExpr (HsDo PArrComp     (L _ stmts) _)      = dsPArrComp (map unLoc stmts)
-dsExpr (HsDo DoExpr       (L _ stmts) _)      = dsDo stmts
-dsExpr (HsDo GhciStmtCtxt (L _ stmts) _)      = dsDo stmts
-dsExpr (HsDo MDoExpr      (L _ stmts) _)      = dsDo stmts
-dsExpr (HsDo MonadComp    (L _ stmts) _)      = dsMonadComp stmts
-
-dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
-  = do { pred <- dsLExpr guard_expr
-       ; b1 <- dsLExpr then_expr
-       ; b2 <- dsLExpr else_expr
-       ; case mb_fun of
-           Just fun -> dsSyntaxExpr fun [pred, b1, b2]
-           Nothing  -> return $ mkIfThenElse pred b1 b2 }
-
-dsExpr (HsMultiIf res_ty alts)
-  | null alts
-  = mkErrorExpr
-
-  | otherwise
-  = do { match_result <- liftM (foldr1 combineMatchResults)
-                               (mapM (dsGRHS IfAlt res_ty) alts)
-       ; error_expr   <- mkErrorExpr
-       ; extractMatchResult match_result error_expr }
-  where
-    mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty
-                               (text "multi-way if")
-
-{-
-\noindent
-\underline{\bf Various data construction things}
-             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--}
-
-dsExpr (ExplicitList elt_ty wit xs)
-  = dsExplicitList elt_ty wit xs
-
--- We desugar [:x1, ..., xn:] as
---   singletonP x1 +:+ ... +:+ singletonP xn
---
-dsExpr (ExplicitPArr ty []) = do
-    emptyP <- dsDPHBuiltin emptyPVar
-    return (Var emptyP `App` Type ty)
-dsExpr (ExplicitPArr ty xs) = do
-    singletonP <- dsDPHBuiltin singletonPVar
-    appP       <- dsDPHBuiltin appPVar
-    xs'        <- mapM dsLExprNoLP xs
-    let unary  fn x   = mkApps (Var fn) [Type ty, x]
-        binary fn x y = mkApps (Var fn) [Type ty, x, y]
-
-    return . foldr1 (binary appP) $ map (unary singletonP) xs'
-
-dsExpr (ArithSeq expr witness seq)
-  = case witness of
-     Nothing -> dsArithSeq expr seq
-     Just fl -> do { newArithSeq <- dsArithSeq expr seq
-                   ; dsSyntaxExpr fl [newArithSeq] }
-
-dsExpr (PArrSeq expr (FromTo from to))
-  = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, to]
-
-dsExpr (PArrSeq expr (FromThenTo from thn to))
-  = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn, to]
-
-dsExpr (PArrSeq _ _)
-  = panic "DsExpr.dsExpr: Infinite parallel array!"
-    -- the parser shouldn't have generated it and the renamer and typechecker
-    -- shouldn't have let it through
-
-{-
-Static Pointers
-~~~~~~~~~~~~~~~
-
-See Note [Grand plan for static forms] in StaticPtrTable for an overview.
-
-    g = ... static f ...
-==>
-    g = ... makeStatic loc f ...
--}
-
-dsExpr (HsStatic _ expr@(L loc _)) = do
-    expr_ds <- dsLExprNoLP expr
-    let ty = exprType expr_ds
-    makeStaticId <- dsLookupGlobalId makeStaticName
-
-    dflags <- getDynFlags
-    let (line, col) = case loc of
-           RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r
-                            , srcLocCol  $ realSrcSpanStart r
-                            )
-           _             -> (0, 0)
-        srcLoc = mkCoreConApps (tupleDataCon Boxed 2)
-                     [ Type intTy              , Type intTy
-                     , mkIntExprInt dflags line, mkIntExprInt dflags col
-                     ]
-
-    putSrcSpanDs loc $ return $
-      mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ]
-
-{-
-\noindent
-\underline{\bf Record construction and update}
-             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For record construction we do this (assuming T has three arguments)
-\begin{verbatim}
-        T { op2 = e }
-==>
-        let err = /\a -> recConErr a
-        T (recConErr t1 "M.hs/230/op1")
-          e
-          (recConErr t1 "M.hs/230/op3")
-\end{verbatim}
-@recConErr@ then converts its argument string into a proper message
-before printing it as
-\begin{verbatim}
-        M.hs, line 230: missing field op1 was evaluated
-\end{verbatim}
-
-We also handle @C{}@ as valid construction syntax for an unlabelled
-constructor @C@, setting all of @C@'s fields to bottom.
--}
-
-dsExpr (RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds
-                  , rcon_con_like = con_like })
-  = do { con_expr' <- dsExpr con_expr
-       ; let
-             (arg_tys, _) = tcSplitFunTys (exprType con_expr')
-             -- A newtype in the corner should be opaque;
-             -- hence TcType.tcSplitFunTys
-
-             mk_arg (arg_ty, fl)
-               = case findField (rec_flds rbinds) (flSelector fl) of
-                   (rhs:_) -> dsLExprNoLP rhs
-                   []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))
-             unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty
-
-             labels = conLikeFieldLabels con_like
-
-       ; con_args <- if null labels
-                     then mapM unlabelled_bottom arg_tys
-                     else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
-
-       ; return (mkCoreApps con_expr' con_args) }
-
-{-
-Record update is a little harder. Suppose we have the decl:
-\begin{verbatim}
-        data T = T1 {op1, op2, op3 :: Int}
-               | T2 {op4, op2 :: Int}
-               | T3
-\end{verbatim}
-Then we translate as follows:
-\begin{verbatim}
-        r { op2 = e }
-===>
-        let op2 = e in
-        case r of
-          T1 op1 _ op3 -> T1 op1 op2 op3
-          T2 op4 _     -> T2 op4 op2
-          other        -> recUpdError "M.hs/230"
-\end{verbatim}
-It's important that we use the constructor Ids for @T1@, @T2@ etc on the
-RHSs, and do not generate a Core constructor application directly, because the constructor
-might do some argument-evaluation first; and may have to throw away some
-dictionaries.
-
-Note [Update for GADTs]
-~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   data T a b where
-     T1 :: { f1 :: a } -> T a Int
-
-Then the wrapper function for T1 has type
-   $WT1 :: a -> T a Int
-But if x::T a b, then
-   x { f1 = v } :: T a b   (not T a Int!)
-So we need to cast (T a Int) to (T a b).  Sigh.
-
--}
-
-dsExpr      (RecordUpd { rupd_expr = record_expr, rupd_flds = fields
-                       , rupd_cons = cons_to_upd
-                       , rupd_in_tys = in_inst_tys, rupd_out_tys = out_inst_tys
-                       , rupd_wrap = dict_req_wrap } )
-  | null fields
-  = dsLExpr record_expr
-  | otherwise
-  = do  { record_expr' <- dsLExpr record_expr
-        ; field_binds' <- mapM ds_field fields
-        ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
-              upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']
-
-        -- It's important to generate the match with matchWrapper,
-        -- and the right hand sides with applications of the wrapper Id
-        -- so that everything works when we are doing fancy unboxing on the
-        -- constructor arguments.
-        ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
-        ; ([discrim_var], matching_code)
-                <- matchWrapper RecUpd Nothing (MG { mg_alts = noLoc alts
-                                                   , mg_arg_tys = [in_ty]
-                                                   , mg_res_ty = out_ty, mg_origin = FromSource })
-                                                   -- FromSource is not strictly right, but we
-                                                   -- want incomplete pattern-match warnings
-
-        ; return (add_field_binds field_binds' $
-                  bindNonRec discrim_var record_expr' matching_code) }
-  where
-    ds_field :: LHsRecUpdField Id -> DsM (Name, Id, CoreExpr)
-      -- Clone the Id in the HsRecField, because its Name is that
-      -- of the record selector, and we must not make that a local binder
-      -- else we shadow other uses of the record selector
-      -- Hence 'lcl_id'.  Cf Trac #2735
-    ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
-                                  ; let fld_id = unLoc (hsRecUpdFieldId rec_field)
-                                  ; lcl_id <- newSysLocalDs (idType fld_id)
-                                  ; return (idName fld_id, lcl_id, rhs) }
-
-    add_field_binds [] expr = expr
-    add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
-
-        -- Awkwardly, for families, the match goes
-        -- from instance type to family type
-    (in_ty, out_ty) =
-      case (head cons_to_upd) of
-        RealDataCon data_con ->
-          let tycon = dataConTyCon data_con in
-          (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys)
-        PatSynCon pat_syn ->
-          ( patSynInstResTy pat_syn in_inst_tys
-          , patSynInstResTy pat_syn out_inst_tys)
-    mk_alt upd_fld_env con
-      = do { let (univ_tvs, ex_tvs, eq_spec,
-                  prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con
-                 subst = zipTvSubst univ_tvs in_inst_tys
-
-                -- I'm not bothering to clone the ex_tvs
-           ; eqs_vars   <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
-           ; theta_vars <- mapM newPredVarDs (substTheta subst prov_theta)
-           ; arg_ids    <- newSysLocalsDs (substTysUnchecked subst arg_tys)
-           ; let field_labels = conLikeFieldLabels con
-                 val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
-                                         field_labels arg_ids
-                 mk_val_arg fl pat_arg_id
-                     = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id)
-
-                 inst_con = noLoc $ HsWrap wrap (HsConLikeOut con)
-                        -- Reconstruct with the WrapId so that unpacking happens
-                 -- The order here is because of the order in `TcPatSyn`.
-                 wrap = mkWpEvVarApps theta_vars                                <.>
-                        dict_req_wrap                                           <.>
-                        mkWpTyApps    (mkTyVarTys ex_tvs)                       <.>
-                        mkWpTyApps    [ ty
-                                      | (tv, ty) <- univ_tvs `zip` out_inst_tys
-                                      , not (tv `elemVarEnv` wrap_subst) ]
-                 rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
-
-                        -- Tediously wrap the application in a cast
-                        -- Note [Update for GADTs]
-                 wrapped_rhs =
-                  case con of
-                    RealDataCon data_con ->
-                      let
-                        wrap_co =
-                          mkTcTyConAppCo Nominal
-                            (dataConTyCon data_con)
-                            [ lookup tv ty
-                              | (tv,ty) <- univ_tvs `zip` out_inst_tys ]
-                        lookup univ_tv ty =
-                          case lookupVarEnv wrap_subst univ_tv of
-                            Just co' -> co'
-                            Nothing  -> mkTcReflCo Nominal ty
-                        in if null eq_spec
-                             then rhs
-                             else mkLHsWrap (mkWpCastN wrap_co) rhs
-                    -- eq_spec is always null for a PatSynCon
-                    PatSynCon _ -> rhs
-
-                 wrap_subst =
-                  mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var))
-                           | (spec, eq_var) <- eq_spec `zip` eqs_vars
-                           , let tv = eqSpecTyVar spec ]
-
-                 req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys
-
-                 pat = noLoc $ ConPatOut { pat_con = noLoc con
-                                         , pat_tvs = ex_tvs
-                                         , pat_dicts = eqs_vars ++ theta_vars
-                                         , pat_binds = emptyTcEvBinds
-                                         , pat_args = PrefixCon $ map nlVarPat arg_ids
-                                         , pat_arg_tys = in_inst_tys
-                                         , pat_wrap = req_wrap }
-           ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) }
-
--- Here is where we desugar the Template Haskell brackets and escapes
-
--- Template Haskell stuff
-
-dsExpr (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut"
-dsExpr (HsTcBracketOut x ps) = dsBracket x ps
-dsExpr (HsSpliceE s)  = pprPanic "dsExpr:splice" (ppr s)
-
--- Arrow notation extension
-dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
-
--- Hpc Support
-
-dsExpr (HsTick tickish e) = do
-  e' <- dsLExpr e
-  return (Tick tickish e')
-
--- There is a problem here. The then and else branches
--- have no free variables, so they are open to lifting.
--- We need someway of stopping this.
--- This will make no difference to binary coverage
--- (did you go here: YES or NO), but will effect accurate
--- tick counting.
-
-dsExpr (HsBinTick ixT ixF e) = do
-  e2 <- dsLExpr e
-  do { mkBinaryTickBox ixT ixF e2
-     }
-
-dsExpr (HsTickPragma _ _ _ expr) = do
-  dflags <- getDynFlags
-  if gopt Opt_Hpc dflags
-    then panic "dsExpr:HsTickPragma"
-    else dsLExpr expr
-
--- HsSyn constructs that just shouldn't be here:
-dsExpr (ExprWithTySig {})  = panic "dsExpr:ExprWithTySig"
-dsExpr (HsBracket     {})  = panic "dsExpr:HsBracket"
-dsExpr (HsArrApp      {})  = panic "dsExpr:HsArrApp"
-dsExpr (HsArrForm     {})  = panic "dsExpr:HsArrForm"
-dsExpr (EWildPat      {})  = panic "dsExpr:EWildPat"
-dsExpr (EAsPat        {})  = panic "dsExpr:EAsPat"
-dsExpr (EViewPat      {})  = panic "dsExpr:EViewPat"
-dsExpr (ELazyPat      {})  = panic "dsExpr:ELazyPat"
-dsExpr (HsAppType     {})  = panic "dsExpr:HsAppType" -- removed by typechecker
-dsExpr (HsDo          {})  = panic "dsExpr:HsDo"
-dsExpr (HsRecFld      {})  = panic "dsExpr:HsRecFld"
-
-------------------------------
-dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr
-dsSyntaxExpr (SyntaxExpr { syn_expr      = expr
-                         , syn_arg_wraps = arg_wraps
-                         , syn_res_wrap  = res_wrap })
-             arg_exprs
-  = do { fun            <- dsExpr expr
-       ; core_arg_wraps <- mapM dsHsWrapper arg_wraps
-       ; core_res_wrap  <- dsHsWrapper res_wrap
-       ; let wrapped_args = zipWith ($) core_arg_wraps arg_exprs
-       ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ])
-                      (\_ -> core_res_wrap (mkApps fun wrapped_args)) }
-  where
-    mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr)
-
-findField :: [LHsRecField Id arg] -> Name -> [arg]
-findField rbinds sel
-  = [hsRecFieldArg fld | L _ fld <- rbinds
-                       , sel == idName (unLoc $ hsRecFieldId fld) ]
-
-{-
-%--------------------------------------------------------------------
-
-Note [Desugaring explicit lists]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Explicit lists are desugared in a cleverer way to prevent some
-fruitless allocations.  Essentially, whenever we see a list literal
-[x_1, ..., x_n] we generate the corresponding expression in terms of
-build:
-
-Explicit lists (literals) are desugared to allow build/foldr fusion when
-beneficial. This is a bit of a trade-off,
-
- * build/foldr fusion can generate far larger code than the corresponding
-   cons-chain (e.g. see #11707)
-
- * even when it doesn't produce more code, build can still fail to fuse,
-   requiring that the simplifier do more work to bring the expression
-   back into cons-chain form; this costs compile time
-
- * when it works, fusion can be a significant win. Allocations are reduced
-   by up to 25% in some nofib programs. Specifically,
-
-        Program           Size    Allocs   Runtime  CompTime
-        rewrite          +0.0%    -26.3%      0.02     -1.8%
-           ansi          -0.3%    -13.8%      0.00     +0.0%
-           lift          +0.0%     -8.7%      0.00     -2.3%
-
-At the moment we use a simple heuristic to determine whether build will be
-fruitful: for small lists we assume the benefits of fusion will be worthwhile;
-for long lists we assume that the benefits will be outweighted by the cost of
-code duplication. This magic length threshold is @maxBuildLength@. Also, fusion
-won't work at all if rewrite rules are disabled, so we don't use the build-based
-desugaring in this case.
-
-We used to have a more complex heuristic which would try to break the list into
-"static" and "dynamic" parts and only build-desugar the dynamic part.
-Unfortunately, determining "static-ness" reliably is a bit tricky and the
-heuristic at times produced surprising behavior (see #11710) so it was dropped.
--}
-
-{- | The longest list length which we will desugar using @build@.
-
-This is essentially a magic number and its setting is unfortunate rather
-arbitrary. The idea here, as mentioned in Note [Desugaring explicit lists],
-is to avoid deforesting large static data into large(r) code. Ideally we'd
-want a smaller threshold with larger consumers and vice-versa, but we have no
-way of knowing what will be consuming our list in the desugaring impossible to
-set generally correctly.
-
-The effect of reducing this number will be that 'build' fusion is applied
-less often. From a runtime performance perspective, applying 'build' more
-liberally on "moderately" sized lists should rarely hurt and will often it can
-only expose further optimization opportunities; if no fusion is possible it will
-eventually get rule-rewritten back to a list). We do, however, pay in compile
-time.
--}
-maxBuildLength :: Int
-maxBuildLength = 32
-
-dsExplicitList :: Type -> Maybe (SyntaxExpr Id) -> [LHsExpr Id]
-               -> DsM CoreExpr
--- See Note [Desugaring explicit lists]
-dsExplicitList elt_ty Nothing xs
-  = do { dflags <- getDynFlags
-       ; xs' <- mapM dsLExprNoLP xs
-       ; if length xs' > maxBuildLength
-                -- Don't generate builds if the list is very long.
-         || length xs' == 0
-                -- Don't generate builds when the [] constructor will do
-         || not (gopt Opt_EnableRewriteRules dflags)  -- Rewrite rules off
-                -- Don't generate a build if there are no rules to eliminate it!
-                -- See Note [Desugaring RULE left hand sides] in Desugar
-         then return $ mkListExpr elt_ty xs'
-         else mkBuildExpr elt_ty (mk_build_list xs') }
-  where
-    mk_build_list xs' (cons, _) (nil, _)
-      = return (foldr (App . App (Var cons)) (Var nil) xs')
-
-dsExplicitList elt_ty (Just fln) xs
-  = do { list <- dsExplicitList elt_ty Nothing xs
-       ; dflags <- getDynFlags
-       ; dsSyntaxExpr fln [mkIntExprInt dflags (length xs), list] }
-
-dsArithSeq :: PostTcExpr -> (ArithSeqInfo Id) -> DsM CoreExpr
-dsArithSeq expr (From from)
-  = App <$> dsExpr expr <*> dsLExprNoLP from
-dsArithSeq expr (FromTo from to)
-  = do dflags <- getDynFlags
-       warnAboutEmptyEnumerations dflags from Nothing to
-       expr' <- dsExpr expr
-       from' <- dsLExprNoLP from
-       to'   <- dsLExprNoLP to
-       return $ mkApps expr' [from', to']
-dsArithSeq expr (FromThen from thn)
-  = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn]
-dsArithSeq expr (FromThenTo from thn to)
-  = do dflags <- getDynFlags
-       warnAboutEmptyEnumerations dflags from (Just thn) to
-       expr' <- dsExpr expr
-       from' <- dsLExprNoLP from
-       thn'  <- dsLExprNoLP thn
-       to'   <- dsLExprNoLP to
-       return $ mkApps expr' [from', thn', to']
-
-{-
-Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
-handled in DsListComp).  Basically does the translation given in the
-Haskell 98 report:
--}
-
-dsDo :: [ExprLStmt Id] -> DsM CoreExpr
-dsDo stmts
-  = goL stmts
-  where
-    goL [] = panic "dsDo"
-    goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
-
-    go _ (LastStmt body _ _) _
-      = dsLExpr body
-        -- The 'return' op isn't used for 'do' expressions
-
-    go _ (BodyStmt rhs then_expr _ _) stmts
-      = do { rhs2 <- dsLExpr rhs
-           ; warnDiscardedDoBindings rhs (exprType rhs2)
-           ; rest <- goL stmts
-           ; dsSyntaxExpr then_expr [rhs2, rest] }
-
-    go _ (LetStmt binds) stmts
-      = do { rest <- goL stmts
-           ; dsLocalBinds binds rest }
-
-    go _ (BindStmt pat rhs bind_op fail_op res1_ty) stmts
-      = do  { body     <- goL stmts
-            ; rhs'     <- dsLExpr rhs
-            ; var   <- selectSimpleMatchVarL pat
-            ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
-                                      res1_ty (cantFailMatchResult body)
-            ; match_code <- handle_failure pat match fail_op
-            ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
-
-    go _ (ApplicativeStmt args mb_join body_ty) stmts
-      = do {
-             let
-               (pats, rhss) = unzip (map (do_arg . snd) args)
-
-               do_arg (ApplicativeArgOne pat expr) =
-                 (pat, dsLExpr expr)
-               do_arg (ApplicativeArgMany stmts ret pat) =
-                 (pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
-
-               arg_tys = map hsLPatType pats
-
-           ; rhss' <- sequence rhss
-
-           ; let body' = noLoc $ HsDo DoExpr (noLoc stmts) body_ty
-
-           ; let fun = L noSrcSpan $ HsLam $
-                   MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats
-                                                       body']
-                      , mg_arg_tys = arg_tys
-                      , mg_res_ty = body_ty
-                      , mg_origin = Generated }
-
-           ; fun' <- dsLExpr fun
-           ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r]
-           ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss')
-           ; case mb_join of
-               Nothing -> return expr
-               Just join_op -> dsSyntaxExpr join_op [expr] }
-
-    go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
-                    , recS_rec_ids = rec_ids, recS_ret_fn = return_op
-                    , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
-                    , recS_bind_ty = bind_ty
-                    , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts
-      = goL (new_bind_stmt : stmts)  -- rec_ids can be empty; eg  rec { print 'x' }
-      where
-        new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTupId later_pats)
-                                         mfix_app bind_op
-                                         noSyntaxExpr  -- Tuple cannot fail
-                                         bind_ty
-
-        tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids
-        tup_ty       = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
-        rec_tup_pats = map nlVarPat tup_ids
-        later_pats   = rec_tup_pats
-        rets         = map noLoc rec_rets
-        mfix_app     = nlHsSyntaxApps mfix_op [mfix_arg]
-        mfix_arg     = noLoc $ HsLam
-                           (MG { mg_alts = noLoc [mkSimpleMatch
-                                                    LambdaExpr
-                                                    [mfix_pat] body]
-                               , mg_arg_tys = [tup_ty], mg_res_ty = body_ty
-                               , mg_origin = Generated })
-        mfix_pat     = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats
-        body         = noLoc $ HsDo
-                                DoExpr (noLoc (rec_stmts ++ [ret_stmt])) body_ty
-        ret_app      = nlHsSyntaxApps return_op [mkBigLHsTupId rets]
-        ret_stmt     = noLoc $ mkLastStmt ret_app
-                     -- This LastStmt will be desugared with dsDo,
-                     -- which ignores the return_op in the LastStmt,
-                     -- so we must apply the return_op explicitly
-
-    go _ (ParStmt   {}) _ = panic "dsDo ParStmt"
-    go _ (TransStmt {}) _ = panic "dsDo TransStmt"
-
-handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
-    -- In a do expression, pattern-match failure just calls
-    -- the monadic 'fail' rather than throwing an exception
-handle_failure pat match fail_op
-  | matchCanFail match
-  = do { dflags <- getDynFlags
-       ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
-       ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]
-       ; extractMatchResult match fail_expr }
-  | otherwise
-  = extractMatchResult match (error "It can't fail")
-
-mk_fail_msg :: DynFlags -> Located e -> String
-mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
-                         showPpr dflags (getLoc pat)
-
-{-
-************************************************************************
-*                                                                      *
-   Desugaring ConLikes
-*                                                                      *
-************************************************************************
--}
-
-dsConLike :: ConLike -> CoreExpr
-dsConLike (RealDataCon dc) = Var (dataConWrapId dc)
-dsConLike (PatSynCon ps) = case patSynBuilder ps of
-  Just (id, add_void)
-    | add_void  -> mkCoreApp (text "dsConLike" <+> ppr ps) (Var id) (Var voidPrimId)
-    | otherwise -> Var id
-  _ -> pprPanic "dsConLike" (ppr ps)
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Errors and contexts}
-*                                                                      *
-************************************************************************
--}
-
--- Warn about certain types of values discarded in monadic bindings (#3263)
-warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM ()
-warnDiscardedDoBindings rhs rhs_ty
-  | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
-  = do { warn_unused <- woptM Opt_WarnUnusedDoBind
-       ; warn_wrong <- woptM Opt_WarnWrongDoBind
-       ; when (warn_unused || warn_wrong) $
-    do { fam_inst_envs <- dsGetFamInstEnvs
-       ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty
-
-           -- Warn about discarding non-() things in 'monadic' binding
-       ; if warn_unused && not (isUnitTy norm_elt_ty)
-         then warnDs (Reason Opt_WarnUnusedDoBind)
-                     (badMonadBind rhs elt_ty)
-         else
-
-           -- Warn about discarding m a things in 'monadic' binding of the same type,
-           -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
-           when warn_wrong $
-                do { case tcSplitAppTy_maybe norm_elt_ty of
-                         Just (elt_m_ty, _)
-                            | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty
-                            -> warnDs (Reason Opt_WarnWrongDoBind)
-                                      (badMonadBind rhs elt_ty)
-                         _ -> return () } } }
-
-  | otherwise   -- RHS does have type of form (m ty), which is weird
-  = return ()   -- but at lesat this warning is irrelevant
-
-badMonadBind :: LHsExpr Id -> Type -> SDoc
-badMonadBind rhs elt_ty
-  = vcat [ hang (text "A do-notation statement discarded a result of type")
-              2 (quotes (ppr elt_ty))
-         , hang (text "Suppress this warning by saying")
-              2 (quotes $ text "_ <-" <+> ppr rhs)
-         ]

− src/Language/Haskell/Liquid/Desugar/DsExpr.hs-boot 
@@ -1,10 +0,0 @@-module Language.Haskell.Liquid.Desugar.DsExpr where-import HsSyn    ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr )-import Var      ( Id )-import Language.Haskell.Liquid.Desugar.DsMonad  ( DsM )-import CoreSyn  ( CoreExpr )--dsExpr  :: HsExpr  Id -> DsM CoreExpr-dsLExpr, dsLExprNoLP :: LHsExpr Id -> DsM CoreExpr-dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr-dsLocalBinds :: LHsLocalBinds Id -> CoreExpr -> DsM CoreExpr
− src/Language/Haskell/Liquid/Desugar/DsForeign.hs 
@@ -1,800 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The AQUA Project, Glasgow University, 1998---Desugaring foreign declarations (see also DsCCall).--}--{-# LANGUAGE CPP #-}--module Language.Haskell.Liquid.Desugar.DsForeign ( dsForeigns ) where--import TcRnMonad        -- temp--import CoreSyn--import Language.Haskell.Liquid.Desugar.DsCCall-import Language.Haskell.Liquid.Desugar.DsMonad--import HsSyn-import DataCon-import CoreUnfold-import Id-import Literal-import Module-import Name-import Type-import RepType-import TyCon-import Coercion-import TcEnv-import TcType--import CmmExpr-import CmmUtils-import HscTypes-import ForeignCall-import TysWiredIn-import TysPrim-import PrelNames-import BasicTypes-import SrcLoc-import Outputable-import FastString-import DynFlags-import Platform-import Config-import OrdList-import Pair-import Hooks-import Encoding--import Data.Maybe-import Data.List--{--Desugaring of @foreign@ declarations is naturally split up into-parts, an @import@ and an @export@  part. A @foreign import@-declaration-\begin{verbatim}-  foreign import cc nm f :: prim_args -> IO prim_res-\end{verbatim}-is the same as-\begin{verbatim}-  f :: prim_args -> IO prim_res-  f a1 ... an = _ccall_ nm cc a1 ... an-\end{verbatim}-so we reuse the desugaring code in @DsCCall@ to deal with these.--}--type Binding = (Id, CoreExpr)   -- No rec/nonrec structure;-                                -- the occurrence analyser will sort it all out--dsForeigns :: [LForeignDecl Id]-           -> DsM (ForeignStubs, OrdList Binding)-dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos)--dsForeigns' :: [LForeignDecl Id]-            -> DsM (ForeignStubs, OrdList Binding)-dsForeigns' []-  = return (NoStubs, nilOL)-dsForeigns' fos = do-    fives <- mapM do_ldecl fos-    let-        (hs, cs, idss, bindss) = unzip4 fives-        fe_ids = concat idss-        fe_init_code = map foreignExportInitialiser fe_ids-    ---    return (ForeignStubs-             (vcat hs)-             (vcat cs $$ vcat fe_init_code),-            foldr (appOL . toOL) nilOL bindss)-  where-   do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)--   do_decl (ForeignImport { fd_name = id, fd_co = co, fd_fi = spec }) = do-      traceIf (text "fi start" <+> ppr id)-      let id' = unLoc id-      (bs, h, c) <- dsFImport id' co spec-      traceIf (text "fi end" <+> ppr id)-      return (h, c, [], bs)--   do_decl (ForeignExport { fd_name = L _ id, fd_co = co-                          , fd_fe = CExport (L _ (CExportStatic _ ext_nm cconv)) _ }) = do-      (h, c, _, _) <- dsFExport id co ext_nm cconv False-      return (h, c, [id], [])--{--************************************************************************-*                                                                      *-\subsection{Foreign import}-*                                                                      *-************************************************************************--Desugaring foreign imports is just the matter of creating a binding-that on its RHS unboxes its arguments, performs the external call-(using the @CCallOp@ primop), before boxing the result up and returning it.--However, we create a worker/wrapper pair, thus:--        foreign import f :: Int -> IO Int-==>-        f x = IO ( \s -> case x of { I# x# ->-                         case fw s x# of { (# s1, y# #) ->-                         (# s1, I# y# #)}})--        fw s x# = ccall f s x#--The strictness/CPR analyser won't do this automatically because it doesn't look-inside returned tuples; but inlining this wrapper is a Really Good Idea-because it exposes the boxing to the call site.--}--dsFImport :: Id-          -> Coercion-          -> ForeignImport-          -> DsM ([Binding], SDoc, SDoc)-dsFImport id co (CImport cconv safety mHeader spec _) =-    dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader--dsCImport :: Id-          -> Coercion-          -> CImportSpec-          -> CCallConv-          -> Safety-          -> Maybe Header-          -> DsM ([Binding], SDoc, SDoc)-dsCImport id co (CLabel cid) cconv _ _ = do-   dflags <- getDynFlags-   let ty  = pFst $ coercionKind co-       fod = case tyConAppTyCon_maybe (dropForAlls ty) of-             Just tycon-              | tyConUnique tycon == funPtrTyConKey ->-                 IsFunction-             _ -> IsData-   (_resTy, foRhs) <- resultWrapper ty-   let-        rhs = foRhs (Lit (MachLabel cid stdcall_info fod))-        rhs' = Cast rhs co-        stdcall_info = fun_type_arg_stdcall_info dflags cconv ty-    in-    return ([(id, rhs')], empty, empty)--dsCImport id co (CFunction target) cconv@PrimCallConv safety _-  = dsPrimCall id co (CCall (CCallSpec target cconv safety))-dsCImport id co (CFunction target) cconv safety mHeader-  = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader-dsCImport id co CWrapper cconv _ _-  = dsFExportDynamic id co cconv---- For stdcall labels, if the type was a FunPtr or newtype thereof,--- then we need to calculate the size of the arguments in order to add--- the @n suffix to the label.-fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int-fun_type_arg_stdcall_info dflags StdCallConv ty-  | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,-    tyConUnique tc == funPtrTyConKey-  = let-       (bndrs, _) = tcSplitPiTys arg_ty-       fe_arg_tys = mapMaybe binderRelevantType_maybe bndrs-    in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys)-fun_type_arg_stdcall_info _ _other_conv _-  = Nothing--{--************************************************************************-*                                                                      *-\subsection{Foreign calls}-*                                                                      *-************************************************************************--}--dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header-        -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)-dsFCall fn_id co fcall mDeclHeader = do-    let-        ty                   = pFst $ coercionKind co-        (tv_bndrs, rho)      = tcSplitForAllTyVarBndrs ty-        (arg_tys, io_res_ty) = tcSplitFunTys rho--    args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism-    (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)--    let-        work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars--    (ccall_result_ty, res_wrapper) <- boxResult io_res_ty--    ccall_uniq <- newUnique-    work_uniq  <- newUnique--    dflags <- getDynFlags-    (fcall', cDoc) <--              case fcall of-              CCall (CCallSpec (StaticTarget _ cName mUnitId isFun)-                               CApiConv safety) ->-               do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName)-                  let fcall' = CCall (CCallSpec-                                      (StaticTarget NoSourceText-                                                    wrapperName mUnitId-                                                    True)-                                      CApiConv safety)-                      c = includes-                       $$ fun_proto <+> braces (cRet <> semi)-                      includes = vcat [ text "#include <" <> ftext h <> text ">"-                                      | Header _ h <- nub headers ]-                      fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes-                      cRet-                       | isVoidRes =                   cCall-                       | otherwise = text "return" <+> cCall-                      cCall = if isFun-                              then ppr cName <> parens argVals-                              else if null arg_tys-                                    then ppr cName-                                    else panic "dsFCall: Unexpected arguments to FFI value import"-                      raw_res_ty = case tcSplitIOType_maybe io_res_ty of-                                   Just (_ioTyCon, res_ty) -> res_ty-                                   Nothing                 -> io_res_ty-                      isVoidRes = raw_res_ty `eqType` unitTy-                      (mHeader, cResType)-                       | isVoidRes = (Nothing, text "void")-                       | otherwise = toCType raw_res_ty-                      pprCconv = ccallConvAttribute CApiConv-                      mHeadersArgTypeList-                          = [ (header, cType <+> char 'a' <> int n)-                            | (t, n) <- zip arg_tys [1..]-                            , let (header, cType) = toCType t ]-                      (mHeaders, argTypeList) = unzip mHeadersArgTypeList-                      argTypes = if null argTypeList-                                 then text "void"-                                 else hsep $ punctuate comma argTypeList-                      mHeaders' = mDeclHeader : mHeader : mHeaders-                      headers = catMaybes mHeaders'-                      argVals = hsep $ punctuate comma-                                    [ char 'a' <> int n-                                    | (_, n) <- zip arg_tys [1..] ]-                  return (fcall', c)-              _ ->-                  return (fcall, empty)-    let-        -- Build the worker-        worker_ty     = mkForAllTys tv_bndrs (mkFunTys (map idType work_arg_ids) ccall_result_ty)-        tvs           = map binderVar tv_bndrs-        the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty-        work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)-        work_id       = mkSysLocal (fsLit "$wccall") work_uniq worker_ty--        -- Build the wrapper-        work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args-        wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers-        wrap_rhs     = mkLams (tvs ++ args) wrapper_body-        wrap_rhs'    = Cast wrap_rhs co-        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity-                                                (length args) wrap_rhs'--    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc)--{--************************************************************************-*                                                                      *-\subsection{Primitive calls}-*                                                                      *-************************************************************************--This is for `@foreign import prim@' declarations.--Currently, at the core level we pretend that these primitive calls are-foreign calls. It may make more sense in future to have them as a distinct-kind of Id, or perhaps to bundle them with PrimOps since semantically and-for calling convention they are really prim ops.--}--dsPrimCall :: Id -> Coercion -> ForeignCall-           -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)-dsPrimCall fn_id co fcall = do-    let-        ty                   = pFst $ coercionKind co-        (tvs, fun_ty)        = tcSplitForAllTys ty-        (arg_tys, io_res_ty) = tcSplitFunTys fun_ty--    args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism--    ccall_uniq <- newUnique-    dflags <- getDynFlags-    let-        call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty-        rhs      = mkLams tvs (mkLams args call_app)-        rhs'     = Cast rhs co-    return ([(fn_id, rhs')], empty, empty)--{--************************************************************************-*                                                                      *-\subsection{Foreign export}-*                                                                      *-************************************************************************--The function that does most of the work for `@foreign export@' declarations.-(see below for the boilerplate code a `@foreign export@' declaration expands- into.)--For each `@foreign export foo@' in a module M we generate:-\begin{itemize}-\item a C function `@foo@', which calls-\item a Haskell stub `@M.\$ffoo@', which calls-\end{itemize}-the user-written Haskell function `@M.foo@'.--}--dsFExport :: Id                 -- Either the exported Id,-                                -- or the foreign-export-dynamic constructor-          -> Coercion           -- Coercion between the Haskell type callable-                                -- from C, and its representation type-          -> CLabelString       -- The name to export to C land-          -> CCallConv-          -> Bool               -- True => foreign export dynamic-                                --         so invoke IO action that's hanging off-                                --         the first argument's stable pointer-          -> DsM ( SDoc         -- contents of Module_stub.h-                 , SDoc         -- contents of Module_stub.c-                 , String       -- string describing type to pass to createAdj.-                 , Int          -- size of args to stub function-                 )--dsFExport fn_id co ext_name cconv isDyn = do-    let-       ty                     = pSnd $ coercionKind co-       (bndrs, orig_res_ty)   = tcSplitPiTys ty-       fe_arg_tys'            = mapMaybe binderRelevantType_maybe bndrs-       -- We must use tcSplits here, because we want to see-       -- the (IO t) in the corner of the type!-       fe_arg_tys | isDyn     = tail fe_arg_tys'-                  | otherwise = fe_arg_tys'--       -- Look at the result type of the exported function, orig_res_ty-       -- If it's IO t, return         (t, True)-       -- If it's plain t, return      (t, False)-       (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of-                                -- The function already returns IO t-                                Just (_ioTyCon, res_ty) -> (res_ty, True)-                                -- The function returns t-                                Nothing                 -> (orig_res_ty, False)--    dflags <- getDynFlags-    return $-      mkFExportCBits dflags ext_name-                     (if isDyn then Nothing else Just fn_id)-                     fe_arg_tys res_ty is_IO_res_ty cconv--{--@foreign import "wrapper"@ (previously "foreign export dynamic") lets-you dress up Haskell IO actions of some fixed type behind an-externally callable interface (i.e., as a C function pointer). Useful-for callbacks and stuff.--\begin{verbatim}-type Fun = Bool -> Int -> IO Int-foreign import "wrapper" f :: Fun -> IO (FunPtr Fun)---- Haskell-visible constructor, which is generated from the above:--- SUP: No check for NULL from createAdjustor anymore???--f :: Fun -> IO (FunPtr Fun)-f cback =-   bindIO (newStablePtr cback)-          (\StablePtr sp# -> IO (\s1# ->-              case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of-                 (# s2#, a# #) -> (# s2#, A# a# #)))--foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)---- and the helper in C: (approximately; see `mkFExportCBits` below)--f_helper(StablePtr s, HsBool b, HsInt i)-{-        Capability *cap;-        cap = rts_lock();-        rts_evalIO(&cap,-                   rts_apply(rts_apply(deRefStablePtr(s),-                                       rts_mkBool(b)), rts_mkInt(i)));-        rts_unlock(cap);-}-\end{verbatim}--}--dsFExportDynamic :: Id-                 -> Coercion-                 -> CCallConv-                 -> DsM ([Binding], SDoc, SDoc)-dsFExportDynamic id co0 cconv = do-    mod <- getModule-    dflags <- getDynFlags-    let fe_nm = mkFastString $ zEncodeString-            (moduleStableString mod ++ "$" ++ toCName dflags id)-        -- Construct the label based on the passed id, don't use names-        -- depending on Unique. See #13807 and Note [Unique Determinism].-    cback <- newSysLocalDs arg_ty-    newStablePtrId <- dsLookupGlobalId newStablePtrName-    stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName-    let-        stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]-        export_ty     = mkFunTy stable_ptr_ty arg_ty-    bindIOId <- dsLookupGlobalId bindIOName-    stbl_value <- newSysLocalDs stable_ptr_ty-    (h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True-    let-         {--          The arguments to the external function which will-          create a little bit of (template) code on the fly-          for allowing the (stable pointed) Haskell closure-          to be entered using an external calling convention-          (stdcall, ccall).-         -}-        adj_args      = [ mkIntLitInt dflags (ccallConvToInt cconv)-                        , Var stbl_value-                        , Lit (MachLabel fe_nm mb_sz_args IsFunction)-                        , Lit (mkMachString typestring)-                        ]-          -- name of external entry point providing these services.-          -- (probably in the RTS.)-        adjustor   = fsLit "createAdjustor"--          -- Determine the number of bytes of arguments to the stub function,-          -- so that we can attach the '@N' suffix to its label if it is a-          -- stdcall on Windows.-        mb_sz_args = case cconv of-                        StdCallConv -> Just args_size-                        _           -> Nothing--    ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])-        -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback--    let io_app = mkLams tvs                  $-                 Lam cback                   $-                 mkApps (Var bindIOId)-                        [ Type stable_ptr_ty-                        , Type res_ty-                        , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]-                        , Lam stbl_value ccall_adj-                        ]--        fed = (id `setInlineActivation` NeverActive, Cast io_app co0)-               -- Never inline the f.e.d. function, because the litlit-               -- might not be in scope in other modules.--    return ([fed], h_code, c_code)-- where-  ty                       = pFst (coercionKind co0)-  (tvs,sans_foralls)       = tcSplitForAllTys ty-  ([arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls-  Just (io_tc, res_ty)     = tcSplitIOType_maybe fn_res_ty-        -- Must have an IO type; hence Just---toCName :: DynFlags -> Id -> String-toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i)))--{--*--\subsection{Generating @foreign export@ stubs}--*--For each @foreign export@ function, a C stub function is generated.-The C stub constructs the application of the exported Haskell function-using the hugs/ghc rts invocation API.--}--mkFExportCBits :: DynFlags-               -> FastString-               -> Maybe Id      -- Just==static, Nothing==dynamic-               -> [Type]-               -> Type-               -> Bool          -- True <=> returns an IO type-               -> CCallConv-               -> (SDoc,-                   SDoc,-                   String,      -- the argument reps-                   Int          -- total size of arguments-                  )-mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc- = (header_bits, c_bits, type_string,-    sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args-         -- NB. the calculation here isn't strictly speaking correct.-         -- We have a primitive Haskell type (eg. Int#, Double#), and-         -- we want to know the size, when passed on the C stack, of-         -- the associated C type (eg. HsInt, HsDouble).  We don't have-         -- this information to hand, but we know what GHC's conventions-         -- are for passing around the primitive Haskell types, so we-         -- use that instead.  I hope the two coincide --SDM-    )- where-  -- list the arguments to the C function-  arg_info :: [(SDoc,           -- arg name-                SDoc,           -- C type-                Type,           -- Haskell type-                CmmType)]       -- the CmmType-  arg_info  = [ let stg_type = showStgType ty in-                (arg_cname n stg_type,-                 stg_type,-                 ty,-                 typeCmmType dflags (getPrimTyOf ty))-              | (ty,n) <- zip arg_htys [1::Int ..] ]--  arg_cname n stg_ty-        | libffi    = char '*' <> parens (stg_ty <> char '*') <>-                      text "args" <> brackets (int (n-1))-        | otherwise = text ('a':show n)--  -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled-  libffi = cLibFFI && isNothing maybe_target--  type_string-      -- libffi needs to know the result type too:-      | libffi    = primTyDescChar dflags res_hty : arg_type_string-      | otherwise = arg_type_string--  arg_type_string = [primTyDescChar dflags ty | (_,_,ty,_) <- arg_info]-                -- just the real args--  -- add some auxiliary args; the stable ptr in the wrapper case, and-  -- a slot for the dummy return address in the wrapper + ccall case-  aug_arg_info-    | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info-    | otherwise              = arg_info--  stable_ptr_arg =-        (text "the_stableptr", text "StgStablePtr", undefined,-         typeCmmType dflags (mkStablePtrPrimTy alphaTy))--  -- stuff to do with the return type of the C function-  res_hty_is_unit = res_hty `eqType` unitTy     -- Look through any newtypes--  cResType | res_hty_is_unit = text "void"-           | otherwise       = showStgType res_hty--  -- when the return type is integral and word-sized or smaller, it-  -- must be assigned as type ffi_arg (#3516).  To see what type-  -- libffi is expecting here, take a look in its own testsuite, e.g.-  -- libffi/testsuite/libffi.call/cls_align_ulonglong.c-  ffi_cResType-     | is_ffi_arg_type = text "ffi_arg"-     | otherwise       = cResType-     where-       res_ty_key = getUnique (getName (typeTyCon res_hty))-       is_ffi_arg_type = res_ty_key `notElem`-              [floatTyConKey, doubleTyConKey,-               int64TyConKey, word64TyConKey]--  -- Now we can cook up the prototype for the exported function.-  pprCconv = ccallConvAttribute cc--  header_bits = text "extern" <+> fun_proto <> semi--  fun_args-    | null aug_arg_info = text "void"-    | otherwise         = hsep $ punctuate comma-                               $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info--  fun_proto-    | libffi-      = text "void" <+> ftext c_nm <>-          parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr")-    | otherwise-      = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args--  -- the target which will form the root of what we ask rts_evalIO to run-  the_cfun-     = case maybe_target of-          Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"-          Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"--  cap = text "cap" <> comma--  -- the expression we give to rts_evalIO-  expr_to_run-     = foldl appArg the_cfun arg_info -- NOT aug_arg_info-       where-          appArg acc (arg_cname, _, arg_hty, _)-             = text "rts_apply"-               <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))--  -- various other bits for inside the fn-  declareResult = text "HaskellObj ret;"-  declareCResult | res_hty_is_unit = empty-                 | otherwise       = cResType <+> text "cret;"--  assignCResult | res_hty_is_unit = empty-                | otherwise       =-                        text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi--  -- an extern decl for the fn being called-  extern_decl-     = case maybe_target of-          Nothing -> empty-          Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi---  -- finally, the whole darn thing-  c_bits =-    space $$-    extern_decl $$-    fun_proto  $$-    vcat-     [ lbrace-     ,   text "Capability *cap;"-     ,   declareResult-     ,   declareCResult-     ,   text "cap = rts_lock();"-          -- create the application + perform it.-     ,   text "rts_evalIO" <> parens (-                char '&' <> cap <>-                text "rts_apply" <> parens (-                    cap <>-                    text "(HaskellObj)"-                 <> ptext (if is_IO_res_ty-                                then (sLit "runIO_closure")-                                else (sLit "runNonIO_closure"))-                 <> comma-                 <> expr_to_run-                ) <+> comma-               <> text "&ret"-             ) <> semi-     ,   text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)-                                                <> comma <> text "cap") <> semi-     ,   assignCResult-     ,   text "rts_unlock(cap);"-     ,   ppUnless res_hty_is_unit $-         if libffi-                  then char '*' <> parens (ffi_cResType <> char '*') <>-                       text "resp = cret;"-                  else text "return cret;"-     , rbrace-     ]---foreignExportInitialiser :: Id -> SDoc-foreignExportInitialiser hs_fn =-   -- Initialise foreign exports by registering a stable pointer from an-   -- __attribute__((constructor)) function.-   -- The alternative is to do this from stginit functions generated in-   -- codeGen/CodeGen.hs; however, stginit functions have a negative impact-   -- on binary sizes and link times because the static linker will think that-   -- all modules that are imported directly or indirectly are actually used by-   -- the program.-   -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)-   vcat-    [ text "static void stginit_export_" <> ppr hs_fn-         <> text "() __attribute__((constructor));"-    , text "static void stginit_export_" <> ppr hs_fn <> text "()"-    , braces (text "foreignExportStablePtr"-       <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")-       <> semi)-    ]---mkHObj :: Type -> SDoc-mkHObj t = text "rts_mk" <> text (showFFIType t)--unpackHObj :: Type -> SDoc-unpackHObj t = text "rts_get" <> text (showFFIType t)--showStgType :: Type -> SDoc-showStgType t = text "Hs" <> text (showFFIType t)--showFFIType :: Type -> String-showFFIType t = getOccString (getName (typeTyCon t))--toCType :: Type -> (Maybe Header, SDoc)-toCType = f False-    where f voidOK t-           -- First, if we have (Ptr t) of (FunPtr t), then we need to-           -- convert t to a C type and put a * after it. If we don't-           -- know a type for t, then "void" is fine, though.-           | Just (ptr, [t']) <- splitTyConApp_maybe t-           , tyConName ptr `elem` [ptrTyConName, funPtrTyConName]-              = case f True t' of-                (mh, cType') ->-                    (mh, cType' <> char '*')-           -- Otherwise, if we have a type constructor application, then-           -- see if there is a C type associated with that constructor.-           -- Note that we aren't looking through type synonyms or-           -- anything, as it may be the synonym that is annotated.-           | Just tycon <- tyConAppTyConPicky_maybe t-           , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon-              = (mHeader, ftext cType)-           -- If we don't know a C type for this type, then try looking-           -- through one layer of type synonym etc.-           | Just t' <- coreView t-              = f voidOK t'-           -- Otherwise we don't know the C type. If we are allowing-           -- void then return that; otherwise something has gone wrong.-           | voidOK = (Nothing, text "void")-           | otherwise-              = pprPanic "toCType" (ppr t)--typeTyCon :: Type -> TyCon-typeTyCon ty-  | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty)-  = tc-  | otherwise-  = pprPanic "DsForeign.typeTyCon" (ppr ty)--insertRetAddr :: DynFlags -> CCallConv-              -> [(SDoc, SDoc, Type, CmmType)]-              -> [(SDoc, SDoc, Type, CmmType)]-insertRetAddr dflags CCallConv args-    = case platformArch platform of-      ArchX86_64-       | platformOS platform == OSMinGW32 ->-          -- On other Windows x86_64 we insert the return address-          -- after the 4th argument, because this is the point-          -- at which we need to flush a register argument to the stack-          -- (See rts/Adjustor.c for details).-          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]-                        -> [(SDoc, SDoc, Type, CmmType)]-              go 4 args = ret_addr_arg dflags : args-              go n (arg:args) = arg : go (n+1) args-              go _ [] = []-          in go 0 args-       | otherwise ->-          -- On other x86_64 platforms we insert the return address-          -- after the 6th integer argument, because this is the point-          -- at which we need to flush a register argument to the stack-          -- (See rts/Adjustor.c for details).-          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]-                        -> [(SDoc, SDoc, Type, CmmType)]-              go 6 args = ret_addr_arg dflags : args-              go n (arg@(_,_,_,rep):args)-               | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args-               | otherwise  = arg : go n     args-              go _ [] = []-          in go 0 args-      _ ->-          ret_addr_arg dflags : args-    where platform = targetPlatform dflags-insertRetAddr _ _ args = args--ret_addr_arg :: DynFlags -> (SDoc, SDoc, Type, CmmType)-ret_addr_arg dflags = (text "original_return_addr", text "void*", undefined,-                       typeCmmType dflags addrPrimTy)---- This function returns the primitive type associated with the boxed--- type argument to a foreign export (eg. Int ==> Int#).-getPrimTyOf :: Type -> UnaryType-getPrimTyOf ty-  | isBoolTy rep_ty = intPrimTy-  -- Except for Bool, the types we are interested in have a single constructor-  -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).-  | otherwise =-  case splitDataProductType_maybe rep_ty of-     Just (_, _, _data_con, [prim_ty]) ->-        prim_ty-     _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)-  where-        rep_ty = unwrapType ty---- represent a primitive type as a Char, for building a string that--- described the foreign function type.  The types are size-dependent,--- e.g. 'W' is a signed 32-bit integer.-primTyDescChar :: DynFlags -> Type -> Char-primTyDescChar dflags ty- | ty `eqType` unitTy = 'v'- | otherwise- = case typePrimRep1 (getPrimTyOf ty) of-     IntRep      -> signed_word-     WordRep     -> unsigned_word-     Int64Rep    -> 'L'-     Word64Rep   -> 'l'-     AddrRep     -> 'p'-     FloatRep    -> 'f'-     DoubleRep   -> 'd'-     _           -> pprPanic "primTyDescChar" (ppr ty)-  where-    (signed_word, unsigned_word)-       | wORD_SIZE dflags == 4  = ('W','w')-       | wORD_SIZE dflags == 8  = ('L','l')-       | otherwise              = panic "primTyDescChar"
− src/Language/Haskell/Liquid/Desugar/DsGRHSs.hs 
@@ -1,159 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---Matching guarded right-hand-sides (GRHSs)--}--{-# LANGUAGE CPP #-}--module Language.Haskell.Liquid.Desugar.DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where--import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr  ( dsLExpr, dsLocalBinds )-import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.Match   ( matchSinglePat )--import HsSyn-import MkCore-import CoreSyn-import Var--import Language.Haskell.Liquid.Desugar.DsMonad-import Language.Haskell.Liquid.Desugar.DsUtils-import TysWiredIn-import PrelNames-import Type   ( Type )-import Module-import Name-import SrcLoc-import Outputable--{--@dsGuarded@ is used for both @case@ expressions and pattern bindings.-It desugars:-\begin{verbatim}-        | g1 -> e1-        ...-        | gn -> en-        where binds-\end{verbatim}-producing an expression with a runtime error in the corner if-necessary.  The type argument gives the type of the @ei@.--}--dsGuarded :: GRHSs Id (LHsExpr Id) -> Type -> DsM CoreExpr--dsGuarded grhss rhs_ty = do-    match_result <- dsGRHSs PatBindRhs [] grhss rhs_ty-    error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty-    extractMatchResult match_result error_expr---- In contrast, @dsGRHSs@ produces a @MatchResult@.--dsGRHSs :: HsMatchContext Name -> [Pat Id]      -- These are to build a MatchContext from-        -> GRHSs Id (LHsExpr Id)                -- Guarded RHSs-        -> Type                                 -- Type of RHS-        -> DsM MatchResult-dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty-  = do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss-       ; let match_result1 = foldr1 combineMatchResults match_results-             match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1-                             -- NB: nested dsLet inside matchResult-       ; return match_result2 }--dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id (LHsExpr Id) -> DsM MatchResult-dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs))-  = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty--{--************************************************************************-*                                                                      *-*  matchGuard : make a MatchResult from a guarded RHS                  *-*                                                                      *-************************************************************************--}--matchGuards :: [GuardStmt Id]       -- Guard-            -> HsStmtContext Name   -- Context-            -> LHsExpr Id           -- RHS-            -> Type                 -- Type of RHS of guard-            -> DsM MatchResult---- See comments with HsExpr.Stmt re what a BodyStmt means--- Here we must be in a guard context (not do-expression, nor list-comp)--matchGuards [] _ rhs _-  = do  { core_rhs <- dsLExpr rhs-        ; return (cantFailMatchResult core_rhs) }--        -- BodyStmts must be guards-        -- Turn an "otherwise" guard is a no-op.  This ensures that-        -- you don't get a "non-exhaustive eqns" message when the guards-        -- finish in "otherwise".-        -- NB:  The success of this clause depends on the typechecker not-        --      wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors-        --      If it does, you'll get bogus overlap warnings-matchGuards (BodyStmt e _ _ _ : stmts) ctx rhs rhs_ty-  | Just addTicks <- isTrueLHsExpr e = do-    match_result <- matchGuards stmts ctx rhs rhs_ty-    return (adjustMatchResultDs addTicks match_result)-matchGuards (BodyStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do-    match_result <- matchGuards stmts ctx rhs rhs_ty-    pred_expr <- dsLExpr expr-    return (mkGuardedMatchResult pred_expr match_result)--matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty = do-    match_result <- matchGuards stmts ctx rhs rhs_ty-    return (adjustMatchResultDs (dsLocalBinds binds) match_result)-        -- NB the dsLet occurs inside the match_result-        -- Reason: dsLet takes the body expression as its argument-        --         so we can't desugar the bindings without the-        --         body expression in hand--matchGuards (BindStmt pat bind_rhs _ _ _ : stmts) ctx rhs rhs_ty = do-    match_result <- matchGuards stmts ctx rhs rhs_ty-    core_rhs <- dsLExpr bind_rhs-    matchSinglePat core_rhs (StmtCtxt ctx) pat rhs_ty match_result--matchGuards (LastStmt  {} : _) _ _ _ = panic "matchGuards LastStmt"-matchGuards (ParStmt   {} : _) _ _ _ = panic "matchGuards ParStmt"-matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"-matchGuards (RecStmt   {} : _) _ _ _ = panic "matchGuards RecStmt"-matchGuards (ApplicativeStmt {} : _) _ _ _ =-  panic "matchGuards ApplicativeLastStmt"--isTrueLHsExpr :: LHsExpr Id -> Maybe (CoreExpr -> DsM CoreExpr)---- Returns Just {..} if we're sure that the expression is True--- I.e.   * 'True' datacon---        * 'otherwise' Id---        * Trivial wappings of these--- The arguments to Just are any HsTicks that we have found,--- because we still want to tick then, even it they are always evaluated.-isTrueLHsExpr (L _ (HsVar (L _ v))) |  v `hasKey` otherwiseIdKey-                                    || v `hasKey` getUnique trueDataConId-                                            = Just return-        -- trueDataConId doesn't have the same unique as trueDataCon-isTrueLHsExpr (L _ (HsConLikeOut con)) | con `hasKey` getUnique trueDataCon = Just return-isTrueLHsExpr (L _ (HsTick tickish e))-    | Just ticks <- isTrueLHsExpr e-    = Just (\x -> do wrapped <- ticks x-                     return (Tick tickish wrapped))-   -- This encodes that the result is constant True for Hpc tick purposes;-   -- which is specifically what isTrueLHsExpr is trying to find out.-isTrueLHsExpr (L _ (HsBinTick ixT _ e))-    | Just ticks <- isTrueLHsExpr e-    = Just (\x -> do e <- ticks x-                     this_mod <- getModule-                     return (Tick (HpcTick this_mod ixT) e))--isTrueLHsExpr (L _ (HsPar e))         = isTrueLHsExpr e-isTrueLHsExpr _                       = Nothing--{--Should {\em fail} if @e@ returns @D@-\begin{verbatim}-f x | p <- e', let C y# = e, f y# = r1-    | otherwise          = r2-\end{verbatim}--}
− src/Language/Haskell/Liquid/Desugar/DsListComp.hs 
@@ -1,877 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---Desugaring list comprehensions, monad comprehensions and array comprehensions--}--{-# LANGUAGE CPP, NamedFieldPuns #-}--module Language.Haskell.Liquid.Desugar.DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where--import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )--import HsSyn-import TcHsSyn-import CoreSyn-import MkCore--import Language.Haskell.Liquid.Desugar.DsMonad          -- the monadery used in the desugarer-import Language.Haskell.Liquid.Desugar.DsUtils--import DynFlags-import CoreUtils-import Id-import Type-import TysWiredIn-import Language.Haskell.Liquid.Desugar.Match-import PrelNames-import SrcLoc-import Outputable-import TcType-import ListSetOps( getNth )--- import Util--{--List comprehensions may be desugared in one of two ways: ``ordinary''-(as you would expect if you read SLPJ's book) and ``with foldr/build-turned on'' (if you read Gill {\em et al.}'s paper on the subject).--There will be at least one ``qualifier'' in the input.--}--dsListComp :: [ExprLStmt Id]-           -> Type              -- Type of entire list-           -> DsM CoreExpr-dsListComp lquals res_ty = do-    dflags <- getDynFlags-    let quals = map unLoc lquals-        elt_ty = case tcTyConAppArgs res_ty of-                   [elt_ty] -> elt_ty-                   _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals)--    if not (gopt Opt_EnableRewriteRules dflags) || gopt Opt_IgnoreInterfacePragmas dflags-       -- Either rules are switched off, or we are ignoring what there are;-       -- Either way foldr/build won't happen, so use the more efficient-       -- Wadler-style desugaring-       || isParallelComp quals-       -- Foldr-style desugaring can't handle parallel list comprehensions-        then deListComp quals (mkNilExpr elt_ty)-        else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals)-             -- Foldr/build should be enabled, so desugar-             -- into foldrs and builds--  where-    -- We must test for ParStmt anywhere, not just at the head, because an extension-    -- to list comprehensions would be to add brackets to specify the associativity-    -- of qualifier lists. This is really easy to do by adding extra ParStmts into the-    -- mix of possibly a single element in length, so we do this to leave the possibility open-    isParallelComp = any isParallelStmt--    isParallelStmt (ParStmt {}) = True-    isParallelStmt _            = False----- This function lets you desugar a inner list comprehension and a list of the binders--- of that comprehension that we need in the outer comprehension into such an expression--- and the type of the elements that it outputs (tuples of binders)-dsInnerListComp :: (ParStmtBlock Id Id) -> DsM (CoreExpr, Type)-dsInnerListComp (ParStmtBlock stmts bndrs _)-  = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs-             list_ty          = mkListTy bndrs_tuple_type--             -- really use original bndrs below!-       ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty--       ; return (expr, bndrs_tuple_type) }---- This function factors out commonality between the desugaring strategies for GroupStmt.--- Given such a statement it gives you back an expression representing how to compute the transformed--- list and the tuple that you need to bind from that list in order to proceed with your desugaring-dsTransStmt :: ExprStmt Id -> DsM (CoreExpr, LPat Id)-dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap-                       , trS_by = by, trS_using = using }) = do-    let (from_bndrs, to_bndrs) = unzip binderMap--    let from_bndrs_tys  = map idType from_bndrs-        to_bndrs_tys    = map idType to_bndrs--        to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys--    -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders-    (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock stmts from_bndrs noSyntaxExpr)--    -- Work out what arguments should be supplied to that expression: i.e. is an extraction-    -- function required? If so, create that desugared function and add to arguments-    usingExpr' <- dsLExpr using-    usingArgs' <- case by of-                    Nothing   -> return [expr']-                    Just by_e -> do { by_e' <- dsLExpr by_e-                                    ; lam' <- matchTuple from_bndrs by_e'-                                    ; return [lam', expr'] }--    -- Create an unzip function for the appropriate arity and element types and find "map"-    unzip_stuff' <- mkUnzipBind form from_bndrs_tys-    map_id <- dsLookupGlobalId mapName--    -- Generate the expressions to build the grouped list-    let -- First we apply the grouping function to the inner list-        inner_list_expr' = mkApps usingExpr' usingArgs'-        -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists-        -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and-        -- the "b" to be a tuple of "to" lists!-        -- Then finally we bind the unzip function around that expression-        bound_unzipped_inner_list_expr'-          = case unzip_stuff' of-              Nothing -> inner_list_expr'-              Just (unzip_fn', unzip_rhs') ->-                Let (Rec [(unzip_fn', unzip_rhs')]) $-                mkApps (Var map_id) $-                [ Type (mkListTy from_tup_ty)-                , Type to_bndrs_tup_ty-                , Var unzip_fn'-                , inner_list_expr' ]--    dsNoLevPoly (tcFunResultTyN (length usingArgs') (exprType usingExpr'))-      (text "In the result of a" <+> quotes (text "using") <+> text "function:" <+> ppr using)--    -- Build a pattern that ensures the consumer binds into the NEW binders,-    -- which hold lists rather than single values-    let pat = mkBigLHsVarPatTupId to_bndrs  -- NB: no '!-    return (bound_unzipped_inner_list_expr', pat)--dsTransStmt _ = panic "dsTransStmt: Not given a TransStmt"--{--************************************************************************-*                                                                      *-\subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions}-*                                                                      *-************************************************************************--Just as in Phil's chapter~7 in SLPJ, using the rules for-optimally-compiled list comprehensions.  This is what Kevin followed-as well, and I quite happily do the same.  The TQ translation scheme-transforms a list of qualifiers (either boolean expressions or-generators) into a single expression which implements the list-comprehension.  Because we are generating 2nd-order polymorphic-lambda-calculus, calls to NIL and CONS must be applied to a type-argument, as well as their usual value arguments.-\begin{verbatim}-TE << [ e | qs ] >>  =  TQ << [ e | qs ] ++ Nil (typeOf e) >>--(Rule C)-TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <<e>> TE <<L>>--(Rule B)-TQ << [ e | b , qs ] ++ L >> =-    if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>--(Rule A')-TQ << [ e | p <- L1, qs ]  ++  L2 >> =-  letrec-    h = \ u1 ->-          case u1 of-            []        ->  TE << L2 >>-            (u2 : u3) ->-                  (( \ TE << p >> -> ( TQ << [e | qs]  ++  (h u3) >> )) u2)-                    [] (h u3)-  in-    h ( TE << L1 >> )--"h", "u1", "u2", and "u3" are new variables.-\end{verbatim}--@deListComp@ is the TQ translation scheme.  Roughly speaking, @dsExpr@-is the TE translation scheme.  Note that we carry around the @L@ list-already desugared.  @dsListComp@ does the top TE rule mentioned above.--To the above, we add an additional rule to deal with parallel list-comprehensions.  The translation goes roughly as follows:-     [ e | p1 <- e11, let v1 = e12, p2 <- e13-         | q1 <- e21, let v2 = e22, q2 <- e23]-     =>-     [ e | ((x1, .., xn), (y1, ..., ym)) <--               zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13]-                   [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]]-where (x1, .., xn) are the variables bound in p1, v1, p2-      (y1, .., ym) are the variables bound in q1, v2, q2--In the translation below, the ParStmt branch translates each parallel branch-into a sub-comprehension, and desugars each independently.  The resulting lists-are fed to a zip function, we create a binding for all the variables bound in all-the comprehensions, and then we hand things off the the desugarer for bindings.-The zip function is generated here a) because it's small, and b) because then we-don't have to deal with arbitrary limits on the number of zip functions in the-prelude, nor which library the zip function came from.-The introduced tuples are Boxed, but only because I couldn't get it to work-with the Unboxed variety.--}--deListComp :: [ExprStmt Id] -> CoreExpr -> DsM CoreExpr--deListComp [] _ = panic "deListComp"--deListComp (LastStmt body _ _ : _) list-  =     -- Figure 7.4, SLPJ, p 135, rule C above-    do { core_body <- dsLExpr body-       ; return (mkConsExpr (exprType core_body) core_body list) }--        -- Non-last: must be a guard-deListComp (BodyStmt guard _ _ _ : quals) list = do  -- rule B above-    core_guard <- dsLExpr guard-    core_rest <- deListComp quals list-    return (mkIfThenElse core_guard core_rest list)---- [e | let B, qs] = let B in [e | qs]-deListComp (LetStmt binds : quals) list = do-    core_rest <- deListComp quals list-    dsLocalBinds binds core_rest--deListComp (stmt@(TransStmt {}) : quals) list = do-    (inner_list_expr, pat) <- dsTransStmt stmt-    deBindComp pat inner_list_expr quals list--deListComp (BindStmt pat list1 _ _ _ : quals) core_list2 = do -- rule A' above-    core_list1 <- dsLExprNoLP list1-    deBindComp pat core_list1 quals core_list2--deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list-  = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs-       ; let (exps, qual_tys) = unzip exps_and_qual_tys--       ; (zip_fn, zip_rhs) <- mkZipBind qual_tys--        -- Deal with [e | pat <- zip l1 .. ln] in example above-       ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))-                    quals list }-  where-        bndrs_s = [bs | ParStmtBlock _ bs _ <- stmtss_w_bndrs]--        -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above-        pat  = mkBigLHsPatTupId pats-        pats = map mkBigLHsVarPatTupId bndrs_s--deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"--deListComp (ApplicativeStmt {} : _) _ =-  panic "deListComp ApplicativeStmt"--deBindComp :: OutPat Id-           -> CoreExpr-           -> [ExprStmt Id]-           -> CoreExpr-           -> DsM (Expr Id)-deBindComp pat core_list1 quals core_list2 = do-    let u3_ty@u1_ty = exprType core_list1       -- two names, same thing--        -- u1_ty is a [alpha] type, and u2_ty = alpha-    let u2_ty = hsLPatType pat--    let res_ty = exprType core_list2-        h_ty   = u1_ty `mkFunTy` res_ty--       -- no levity polymorphism here, as list comprehensions don't work-       -- with RebindableSyntax. NB: These are *not* monad comps.-    [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]--    -- the "fail" value ...-    let-        core_fail   = App (Var h) (Var u3)-        letrec_body = App (Var h) core_list1--    rest_expr <- deListComp quals core_fail-    core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail--    let-        rhs = Lam u1 $-              Case (Var u1) u1 res_ty-                   [(DataAlt nilDataCon,  [],       core_list2),-                    (DataAlt consDataCon, [u2, u3], core_match)]-                        -- Increasing order of tag--    return (Let (Rec [(h, rhs)]) letrec_body)--{--************************************************************************-*                                                                      *-\subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}-*                                                                      *-************************************************************************--@dfListComp@ are the rules used with foldr/build turned on:--\begin{verbatim}-TE[ e | ]            c n = c e n-TE[ e | b , q ]      c n = if b then TE[ e | q ] c n else n-TE[ e | p <- l , q ] c n = let-                                f = \ x b -> case x of-                                                  p -> TE[ e | q ] c b-                                                  _ -> b-                           in-                           foldr f n l-\end{verbatim}--}--dfListComp :: Id -> Id         -- 'c' and 'n'-           -> [ExprStmt Id]    -- the rest of the qual's-           -> DsM CoreExpr--dfListComp _ _ [] = panic "dfListComp"--dfListComp c_id n_id (LastStmt body _ _ : _)-  = do { core_body <- dsLExprNoLP body-       ; return (mkApps (Var c_id) [core_body, Var n_id]) }--        -- Non-last: must be a guard-dfListComp c_id n_id (BodyStmt guard _ _ _  : quals) = do-    core_guard <- dsLExpr guard-    core_rest <- dfListComp c_id n_id quals-    return (mkIfThenElse core_guard core_rest (Var n_id))--dfListComp c_id n_id (LetStmt binds : quals) = do-    -- new in 1.3, local bindings-    core_rest <- dfListComp c_id n_id quals-    dsLocalBinds binds core_rest--dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do-    (inner_list_expr, pat) <- dsTransStmt stmt-    -- Anyway, we bind the newly grouped list via the generic binding function-    dfBindComp c_id n_id (pat, inner_list_expr) quals--dfListComp c_id n_id (BindStmt pat list1 _ _ _ : quals) = do-    -- evaluate the two lists-    core_list1 <- dsLExpr list1--    -- Do the rest of the work in the generic binding builder-    dfBindComp c_id n_id (pat, core_list1) quals--dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt"-dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"-dfListComp _ _ (ApplicativeStmt {} : _) =-  panic "dfListComp ApplicativeStmt"--dfBindComp :: Id -> Id          -- 'c' and 'n'-           -> (LPat Id, CoreExpr)-           -> [ExprStmt Id]     -- the rest of the qual's-           -> DsM CoreExpr-dfBindComp c_id n_id (pat, core_list1) quals = do-    -- find the required type-    let x_ty   = hsLPatType pat-    let b_ty   = idType n_id--    -- create some new local id's-    b <- newSysLocalDs b_ty-    x <- newSysLocalDs x_ty--    -- build rest of the comprehesion-    core_rest <- dfListComp c_id b quals--    -- build the pattern match-    core_expr <- matchSimply (Var x) (StmtCtxt ListComp)-                pat core_rest (Var b)--    -- now build the outermost foldr, and return-    mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1--{--************************************************************************-*                                                                      *-\subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring}-*                                                                      *-************************************************************************--}--mkZipBind :: [Type] -> DsM (Id, CoreExpr)--- mkZipBind [t1, t2]--- = (zip, \as1:[t1] as2:[t2]---         -> case as1 of---              [] -> []---              (a1:as'1) -> case as2 of---                              [] -> []---                              (a2:as'2) -> (a1, a2) : zip as'1 as'2)]--mkZipBind elt_tys = do-    ass  <- mapM newSysLocalDs  elt_list_tys-    as'  <- mapM newSysLocalDs  elt_tys-    as's <- mapM newSysLocalDs  elt_list_tys--    zip_fn <- newSysLocalDs zip_fn_ty--    let inner_rhs = mkConsExpr elt_tuple_ty-                        (mkBigCoreVarTup as')-                        (mkVarApps (Var zip_fn) as's)-        zip_body  = foldr mk_case inner_rhs (zip3 ass as' as's)--    return (zip_fn, mkLams ass zip_body)-  where-    elt_list_tys      = map mkListTy elt_tys-    elt_tuple_ty      = mkBigCoreTupTy elt_tys-    elt_tuple_list_ty = mkListTy elt_tuple_ty--    zip_fn_ty         = mkFunTys elt_list_tys elt_tuple_list_ty--    mk_case (as, a', as') rest-          = Case (Var as) as elt_tuple_list_ty-                  [(DataAlt nilDataCon,  [],        mkNilExpr elt_tuple_ty),-                   (DataAlt consDataCon, [a', as'], rest)]-                        -- Increasing order of tag---mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr))--- mkUnzipBind [t1, t2]--- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2])---     -> case ax of---      (x1, x2) -> case axs of---                (xs1, xs2) -> (x1 : xs1, x2 : xs2))---      ([], [])---      ys)------ We use foldr here in all cases, even if rules are turned off, because we may as well!-mkUnzipBind ThenForm _- = return Nothing    -- No unzipping for ThenForm-mkUnzipBind _ elt_tys-  = do { ax  <- newSysLocalDs elt_tuple_ty-       ; axs <- newSysLocalDs elt_list_tuple_ty-       ; ys  <- newSysLocalDs elt_tuple_list_ty-       ; xs  <- mapM newSysLocalDs elt_tys-       ; xss <- mapM newSysLocalDs elt_list_tys--       ; unzip_fn <- newSysLocalDs unzip_fn_ty--       ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]--       ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)-             concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))-             tupled_concat_expression = mkBigCoreTup concat_expressions--             folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs)-             folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax)-             folder_body = mkLams [ax, axs] folder_body_outer_case--       ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)-       ; return (Just (unzip_fn, mkLams [ys] unzip_body)) }-  where-    elt_tuple_ty       = mkBigCoreTupTy elt_tys-    elt_tuple_list_ty  = mkListTy elt_tuple_ty-    elt_list_tys       = map mkListTy elt_tys-    elt_list_tuple_ty  = mkBigCoreTupTy elt_list_tys--    unzip_fn_ty        = elt_tuple_list_ty `mkFunTy` elt_list_tuple_ty--    mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail--{--************************************************************************-*                                                                      *-\subsection[DsPArrComp]{Desugaring of array comprehensions}-*                                                                      *-************************************************************************--}---- entry point for desugaring a parallel array comprehension------   [:e | qss:] = <<[:e | qss:]>> () [:():]----dsPArrComp :: [ExprStmt Id]-            -> DsM CoreExpr---- Special case for parallel comprehension-dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals---- Special case for simple generators:------  <<[:e' | p <- e, qs:]>> = <<[: e' | qs :]>> p e------ if matching again p cannot fail, or else------  <<[:e' | p <- e, qs:]>> =---    <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e)----dsPArrComp (BindStmt p e _ _ _ : qs) = do-    filterP <- dsDPHBuiltin filterPVar-    ce <- dsLExprNoLP e-    let ety'ce  = parrElemType ce-        false   = Var falseDataConId-        true    = Var trueDataConId-    v <- newSysLocalDs ety'ce-    pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false-    let gen | isIrrefutableHsPat p = ce-            | otherwise            = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]-    dePArrComp qs p gen--dsPArrComp qs = do -- no ParStmt in `qs'-    sglP <- dsDPHBuiltin singletonPVar-    let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []]-    dePArrComp qs (noLoc $ WildPat unitTy) unitArray------ the work horse----dePArrComp :: [ExprStmt Id]-           -> LPat Id           -- the current generator pattern-           -> CoreExpr          -- the current generator expression-           -> DsM CoreExpr--dePArrComp [] _ _ = panic "dePArrComp"-------  <<[:e' | :]>> pa ea = mapP (\pa -> e') ea----dePArrComp (LastStmt e' _ _ : _) pa cea-  = do { mapP <- dsDPHBuiltin mapPVar-       ; let ty = parrElemType cea-       ; (clam, ty'e') <- deLambda ty pa e'-       ; return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea] }------  <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)----dePArrComp (BodyStmt b _ _ _ : qs) pa cea = do-    filterP <- dsDPHBuiltin filterPVar-    let ty = parrElemType cea-    (clam,_) <- deLambda ty pa b-    dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea])-------  <<[:e' | p <- e, qs:]>> pa ea =---    let ef = \pa -> e---    in---    <<[:e' | qs:]>> (pa, p) (crossMap ea ef)------ if matching again p cannot fail, or else------  <<[:e' | p <- e, qs:]>> pa ea =---    let ef = \pa -> filterP (\x -> case x of {p -> True; _ -> False}) e---    in---    <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)----dePArrComp (BindStmt p e _ _ _ : qs) pa cea = do-    filterP <- dsDPHBuiltin filterPVar-    crossMapP <- dsDPHBuiltin crossMapPVar-    ce <- dsLExpr e-    let ety'cea = parrElemType cea-        ety'ce  = parrElemType ce-        false   = Var falseDataConId-        true    = Var trueDataConId-    v <- newSysLocalDs ety'ce-    pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false-    let cef | isIrrefutableHsPat p = ce-            | otherwise            = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]-    (clam, _) <- mkLambda ety'cea pa cef-    let ety'cef = ety'ce                    -- filter doesn't change the element type-        pa'     = mkLHsPatTup [pa, p]--    dePArrComp qs pa' (mkApps (Var crossMapP)-                                 [Type ety'cea, Type ety'cef, cea, clam])------  <<[:e' | let ds, qs:]>> pa ea =---    <<[:e' | qs:]>> (pa, (x_1, ..., x_n))---                    (mapP (\v@pa -> let ds in (v, (x_1, ..., x_n))) ea)---  where---    {x_1, ..., x_n} = DV (ds)         -- Defined Variables----dePArrComp (LetStmt lds@(L _ ds) : qs) pa cea = do-    mapP <- dsDPHBuiltin mapPVar-    let xs = collectLocalBinders ds-        ty'cea = parrElemType cea-    v <- newSysLocalDs ty'cea-    clet <- dsLocalBinds lds (mkCoreTup (map Var xs))-    let'v <- newSysLocalDs (exprType clet)-    let projBody = mkCoreLet (NonRec let'v clet) $-                   mkCoreTup [Var v, Var let'v]-        errTy    = exprType projBody-        errMsg   = text "DsListComp.dePArrComp: internal error!"-    cerr <- mkErrorAppDs pAT_ERROR_ID errTy errMsg-    ccase <- matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr-    let pa'    = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)]-        proj   = mkLams [v] ccase-    dePArrComp qs pa' (mkApps (Var mapP)-                                   [Type ty'cea, Type errTy, proj, cea])------ The parser guarantees that parallel comprehensions can only appear as--- singleton qualifier lists, which we already special case in the caller.--- So, encountering one here is a bug.----dePArrComp (ParStmt {} : _) _ _ =-  panic "DsListComp.dePArrComp: malformed comprehension AST: ParStmt"-dePArrComp (TransStmt {} : _) _ _ = panic "DsListComp.dePArrComp: TransStmt"-dePArrComp (RecStmt   {} : _) _ _ = panic "DsListComp.dePArrComp: RecStmt"-dePArrComp (ApplicativeStmt   {} : _) _ _ =-  panic "DsListComp.dePArrComp: ApplicativeStmt"----  <<[:e' | qs | qss:]>> pa ea =---    <<[:e' | qss:]>> (pa, (x_1, ..., x_n))---                     (zipP ea <<[:(x_1, ..., x_n) | qs:]>>)---    where---      {x_1, ..., x_n} = DV (qs)----dePArrParComp :: [ParStmtBlock Id Id] -> [ExprStmt Id] -> DsM CoreExpr-dePArrParComp qss quals = do-    (pQss, ceQss) <- deParStmt qss-    dePArrComp quals pQss ceQss-  where-    deParStmt []             =-      -- empty parallel statement lists have no source representation-      panic "DsListComp.dePArrComp: Empty parallel list comprehension"-    deParStmt (ParStmtBlock qs xs _:qss) = do        -- first statement-      let res_expr = mkLHsVarTuple xs-      cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])-      parStmts qss (mkLHsVarPatTup xs) cqs-    ----    parStmts []             pa cea = return (pa, cea)-    parStmts (ParStmtBlock qs xs _:qss) pa cea = do  -- subsequent statements (zip'ed)-      zipP <- dsDPHBuiltin zipPVar-      let pa'      = mkLHsPatTup [pa, mkLHsVarPatTup xs]-          ty'cea   = parrElemType cea-          res_expr = mkLHsVarTuple xs-      cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])-      let ty'cqs = parrElemType cqs-          cea'   = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]-      parStmts qss pa' cea'---- generate Core corresponding to `\p -> e'----deLambda :: Type                       -- type of the argument (not levity-polymorphic)-         -> LPat Id                    -- argument pattern-         -> LHsExpr Id                 -- body-         -> DsM (CoreExpr, Type)-deLambda ty p e =-    mkLambda ty p =<< dsLExpr e---- generate Core for a lambda pattern match, where the body is already in Core----mkLambda :: Type                        -- type of the argument (not levity-polymorphic)-         -> LPat Id                     -- argument pattern-         -> CoreExpr                    -- desugared body-         -> DsM (CoreExpr, Type)-mkLambda ty p ce = do-    v <- newSysLocalDs ty-    let errMsg = text "DsListComp.deLambda: internal error!"-        ce'ty  = exprType ce-    cerr <- mkErrorAppDs pAT_ERROR_ID ce'ty errMsg-    res <- matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr-    return (mkLams [v] res, ce'ty)---- obtain the element type of the parallel array produced by the given Core--- expression----parrElemType   :: CoreExpr -> Type-parrElemType e  =-  case splitTyConApp_maybe (exprType e) of-    Just (tycon, [ty]) | tycon == parrTyCon -> ty-    _                                                     -> panic-      "DsListComp.parrElemType: not a parallel array type"---- Translation for monad comprehensions---- Entry point for monad comprehension desugaring-dsMonadComp :: [ExprLStmt Id] -> DsM CoreExpr-dsMonadComp stmts = dsMcStmts stmts--dsMcStmts :: [ExprLStmt Id] -> DsM CoreExpr-dsMcStmts []                    = panic "dsMcStmts"-dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)------------------dsMcStmt :: ExprStmt Id -> [ExprLStmt Id] -> DsM CoreExpr--dsMcStmt (LastStmt body _ ret_op) _-  = do { body' <- dsLExpr body-       ; dsSyntaxExpr ret_op [body'] }----   [ .. | let binds, stmts ]-dsMcStmt (LetStmt binds) stmts-  = do { rest <- dsMcStmts stmts-       ; dsLocalBinds binds rest }----   [ .. | a <- m, stmts ]-dsMcStmt (BindStmt pat rhs bind_op fail_op bind_ty) stmts-  = do { rhs' <- dsLExpr rhs-       ; dsMcBindStmt pat rhs' bind_op fail_op bind_ty stmts }---- Apply `guard` to the `exp` expression------   [ .. | exp, stmts ]----dsMcStmt (BodyStmt exp then_exp guard_exp _) stmts-  = do { exp'       <- dsLExpr exp-       ; rest       <- dsMcStmts stmts-       ; guard_exp' <- dsSyntaxExpr guard_exp [exp']-       ; dsSyntaxExpr then_exp [guard_exp', rest] }---- Group statements desugar like this:------   [| (q, then group by e using f); rest |]---   --->  f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup ->---         case unzip n_tup of qv' -> [| rest |]------ where   variables (v1:t1, ..., vk:tk) are bound by q---         qv = (v1, ..., vk)---         qt = (t1, ..., tk)---         (>>=) :: m2 a -> (a -> m3 b) -> m3 b---         f :: forall a. (a -> t) -> m1 a -> m2 (n a)---         n_tup :: n qt---         unzip :: n qt -> (n t1, ..., n tk)    (needs Functor n)--dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs-                    , trS_by = by, trS_using = using-                    , trS_ret = return_op, trS_bind = bind_op-                    , trS_bind_arg_ty = n_tup_ty'  -- n (a,b,c)-                    , trS_fmap = fmap_op, trS_form = form }) stmts_rest-  = do { let (from_bndrs, to_bndrs) = unzip bndrs--       ; let from_bndr_tys = map idType from_bndrs     -- Types ty---       -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders-       ; expr' <- dsInnerMonadComp stmts from_bndrs return_op--       -- Work out what arguments should be supplied to that expression: i.e. is an extraction-       -- function required? If so, create that desugared function and add to arguments-       ; usingExpr' <- dsLExpr using-       ; usingArgs' <- case by of-                         Nothing   -> return [expr']-                         Just by_e -> do { by_e' <- dsLExpr by_e-                                         ; lam' <- matchTuple from_bndrs by_e'-                                         ; return [lam', expr'] }--       -- Generate the expressions to build the grouped list-       -- Build a pattern that ensures the consumer binds into the NEW binders,-       -- which hold monads rather than single values-       ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs--       ; body        <- dsMcStmts stmts_rest-       ; n_tup_var'  <- newSysLocalDsNoLP n_tup_ty'-       ; tup_n_var'  <- newSysLocalDs tup_n_ty'-       ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys-       ; us          <- newUniqueSupply-       ; let rhs'  = mkApps usingExpr' usingArgs'-             body' = mkTupleCase us to_bndrs body tup_n_var' tup_n_expr'--       ; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] }---- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel--- statements, for example:------   [ body | qs1 | qs2 | qs3 ]---     ->  [ body | (bndrs1, (bndrs2, bndrs3))---                     <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ]------ where `mzip` has type---   mzip :: forall a b. m a -> m b -> m (a,b)--- NB: we need a polymorphic mzip because we call it several times--dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest- = do  { exps_w_tys  <- mapM ds_inner blocks   -- Pairs (exp :: m ty, ty)-       ; mzip_op'    <- dsExpr mzip_op--       ; let -- The pattern variables-             pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ bs _ <- blocks]-             -- Pattern with tuples of variables-             -- [v1,v2,v3]  =>  (v1, (v2, v3))-             pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats-             (rhs, _) = foldr1 (\(e1,t1) (e2,t2) ->-                                 (mkApps mzip_op' [Type t1, Type t2, e1, e2],-                                  mkBoxedTupleTy [t1,t2]))-                               exps_w_tys--       ; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest }-  where-    ds_inner (ParStmtBlock stmts bndrs return_op)-       = do { exp <- dsInnerMonadComp stmts bndrs return_op-            ; return (exp, mkBigCoreVarTupTy bndrs) }--dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)---matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr--- (matchTuple [a,b,c] body)---       returns the Core term---  \x. case x of (a,b,c) -> body-matchTuple ids body-  = do { us <- newUniqueSupply-       ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids)-       ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) }---- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a--- desugared `CoreExpr`-dsMcBindStmt :: LPat Id-             -> CoreExpr        -- ^ the desugared rhs of the bind statement-             -> SyntaxExpr Id-             -> SyntaxExpr Id-             -> Type            -- ^ S in (>>=) :: Q -> (R -> S) -> T-             -> [ExprLStmt Id]-             -> DsM CoreExpr-dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts-  = do  { body     <- dsMcStmts stmts-        ; var      <- selectSimpleMatchVarL pat-        ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat-                                  res1_ty (cantFailMatchResult body)-        ; match_code <- handle_failure pat match fail_op-        ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }--  where-    -- In a monad comprehension expression, pattern-match failure just calls-    -- the monadic `fail` rather than throwing an exception-    handle_failure pat match fail_op-      | matchCanFail match-        = do { dflags <- getDynFlags-             ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)-             ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]-             ; extractMatchResult match fail_expr }-      | otherwise-        = extractMatchResult match (error "It can't fail")--    mk_fail_msg :: DynFlags -> Located e -> String-    mk_fail_msg dflags pat-        = "Pattern match failure in monad comprehension at " ++-          showPpr dflags (getLoc pat)---- Desugar nested monad comprehensions, for example in `then..` constructs---    dsInnerMonadComp quals [a,b,c] ret_op--- returns the desugaring of---       [ (a,b,c) | quals ]--dsInnerMonadComp :: [ExprLStmt Id]-                 -> [Id]            -- Return a tuple of these variables-                 -> SyntaxExpr Id   -- The monomorphic "return" operator-                 -> DsM CoreExpr-dsInnerMonadComp stmts bndrs ret_op-  = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTupId bndrs) False ret_op)])----- The `unzip` function for `GroupStmt` in a monad comprehensions------   unzip :: m (a,b,..) -> (m a,m b,..)---   unzip m_tuple = ( liftM selN1 m_tuple---                   , liftM selN2 m_tuple---                   , .. )------   mkMcUnzipM fmap ys [t1, t2]---     = ( fmap (selN1 :: (t1, t2) -> t1) ys---       , fmap (selN2 :: (t1, t2) -> t2) ys )--mkMcUnzipM :: TransForm-           -> HsExpr TcId       -- fmap-           -> Id                -- Of type n (a,b,c)-           -> [Type]            -- [a,b,c]   (not levity-polymorphic)-           -> DsM CoreExpr      -- Of type (n a, n b, n c)-mkMcUnzipM ThenForm _ ys _-  = return (Var ys) -- No unzipping to do--mkMcUnzipM _ fmap_op ys elt_tys-  = do { fmap_op' <- dsExpr fmap_op-       ; xs       <- mapM newSysLocalDs elt_tys-       ; let tup_ty = mkBigCoreTupTy elt_tys-       ; tup_xs   <- newSysLocalDs tup_ty--       ; let mk_elt i = mkApps fmap_op'  -- fmap :: forall a b. (a -> b) -> n a -> n b-                           [ Type tup_ty, Type (getNth elt_tys i)-                           , mk_sel i, Var ys]--             mk_sel n = Lam tup_xs $-                        mkTupleSelector xs (getNth xs n) tup_xs (Var tup_xs)--       ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) }
− src/Language/Haskell/Liquid/Desugar/DsMeta.hs 
@@ -1,2511 +0,0 @@-{-# LANGUAGE CPP, TypeFamilies #-}------------------------------------------------------------------------------------- (c) The University of Glasgow 2006------ The purpose of this module is to transform an HsExpr into a CoreExpr which--- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the--- input HsExpr. We do this in the DsM monad, which supplies access to--- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.------ It also defines a bunch of knownKeyNames, in the same way as is done--- in prelude/PrelNames.  It's much more convenient to do it here, because--- otherwise we have to recompile PrelNames whenever we add a Name, which is--- a Royal Pain (triggers other recompilation).--------------------------------------------------------------------------------module Language.Haskell.Liquid.Desugar.DsMeta( dsBracket ) where--import {-# SOURCE #-}   Language.Haskell.Liquid.Desugar.DsExpr ( dsExpr )--import Language.Haskell.Liquid.Desugar.MatchLit-import Language.Haskell.Liquid.Desugar.DsMonad--import qualified Language.Haskell.TH as TH--import HsSyn-import Class-import PrelNames--- To avoid clashes with DsMeta.varName we must make a local alias for--- OccName.varName we do this by removing varName from the import of--- OccName above, making a qualified instance of OccName and using--- OccNameAlias.varName where varName ws previously used in this file.-import qualified OccName( isDataOcc, isVarOcc, isTcOcc )--import Module-import Id-import Name hiding( isVarOcc, isTcOcc, varName, tcName )-import THNames-import NameEnv-import NameSet-import TcType-import TyCon-import TysWiredIn-import CoreSyn-import MkCore-import CoreUtils-import SrcLoc-import Unique-import BasicTypes-import Outputable-import Bag-import DynFlags-import FastString-import ForeignCall-import Util-import Maybes-import MonadUtils--import Data.ByteString ( unpack )-import Control.Monad-import Data.List--------------------------------------------------------------------------------dsBracket :: HsBracket Name -> [PendingTcSplice] -> DsM CoreExpr--- Returns a CoreExpr of type TH.ExpQ--- The quoted thing is parameterised over Name, even though it has--- been type checked.  We don't want all those type decorations!--dsBracket brack splices-  = dsExtendMetaEnv new_bit (do_brack brack)-  where-    new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices]--    do_brack (VarBr _ n) = do { MkC e1  <- lookupOcc n ; return e1 }-    do_brack (ExpBr e)   = do { MkC e1  <- repLE e     ; return e1 }-    do_brack (PatBr p)   = do { MkC p1  <- repTopP p   ; return p1 }-    do_brack (TypBr t)   = do { MkC t1  <- repLTy t    ; return t1 }-    do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }-    do_brack (DecBrL _)  = panic "dsBracket: unexpected DecBrL"-    do_brack (TExpBr e)  = do { MkC e1  <- repLE e     ; return e1 }--{- -------------- Examples ----------------------  [| \x -> x |]-====>-  gensym (unpackString "x"#) `bindQ` \ x1::String ->-  lam (pvar x1) (var x1)---  [| \x -> $(f [| x |]) |]-====>-  gensym (unpackString "x"#) `bindQ` \ x1::String ->-  lam (pvar x1) (f (var x1))--}-------------------------------------------------------------                      Declarations----------------------------------------------------------repTopP :: LPat Name -> DsM (Core TH.PatQ)-repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)-                 ; pat' <- addBinds ss (repLP pat)-                 ; wrapGenSyms ss pat' }--repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))-repTopDs group@(HsGroup { hs_valds   = valds-                        , hs_splcds  = splcds-                        , hs_tyclds  = tyclds-                        , hs_derivds = derivds-                        , hs_fixds   = fixds-                        , hs_defds   = defds-                        , hs_fords   = fords-                        , hs_warnds  = warnds-                        , hs_annds   = annds-                        , hs_ruleds  = ruleds-                        , hs_vects   = vects-                        , hs_docs    = docs })- = do { let { bndrs  = hsSigTvBinders valds-                       ++ hsGroupBinders group-                       ++ hsPatSynSelectors valds-            ; instds = tyclds >>= group_instds } ;-        ss <- mkGenSyms bndrs ;--        -- Bind all the names mainly to avoid repeated use of explicit strings.-        -- Thus we get-        --      do { t :: String <- genSym "T" ;-        --           return (Data t [] ...more t's... }-        -- The other important reason is that the output must mention-        -- only "T", not "Foo:T" where Foo is the current module--        decls <- addBinds ss (-                  do { val_ds   <- rep_val_binds valds-                     ; _        <- mapM no_splice splcds-                     ; tycl_ds  <- mapM repTyClD (tyClGroupTyClDecls tyclds)-                     ; role_ds  <- mapM repRoleD (concatMap group_roles tyclds)-                     ; inst_ds  <- mapM repInstD instds-                     ; deriv_ds <- mapM repStandaloneDerivD derivds-                     ; fix_ds   <- mapM repFixD fixds-                     ; _        <- mapM no_default_decl defds-                     ; for_ds   <- mapM repForD fords-                     ; _        <- mapM no_warn (concatMap (wd_warnings . unLoc)-                                                           warnds)-                     ; ann_ds   <- mapM repAnnD annds-                     ; rule_ds  <- mapM repRuleD (concatMap (rds_rules . unLoc)-                                                            ruleds)-                     ; _        <- mapM no_vect vects-                     ; _        <- mapM no_doc docs--                        -- more needed-                     ;  return (de_loc $ sort_by_loc $-                                val_ds ++ catMaybes tycl_ds ++ role_ds-                                       ++ (concat fix_ds)-                                       ++ inst_ds ++ rule_ds ++ for_ds-                                       ++ ann_ds ++ deriv_ds) }) ;--        decl_ty <- lookupType decQTyConName ;-        let { core_list = coreList' decl_ty decls } ;--        dec_ty <- lookupType decTyConName ;-        q_decs  <- repSequenceQ dec_ty core_list ;--        wrapGenSyms ss q_decs-      }-  where-    no_splice (L loc _)-      = notHandledL loc "Splices within declaration brackets" empty-    no_default_decl (L loc decl)-      = notHandledL loc "Default declarations" (ppr decl)-    no_warn (L loc (Warning thing _))-      = notHandledL loc "WARNING and DEPRECATION pragmas" $-                    text "Pragma for declaration of" <+> ppr thing-    no_vect (L loc decl)-      = notHandledL loc "Vectorisation pragmas" (ppr decl)-    no_doc (L loc _)-      = notHandledL loc "Haddock documentation" empty--hsSigTvBinders :: HsValBinds Name -> [Name]--- See Note [Scoped type variables in bindings]-hsSigTvBinders binds-  = concatMap get_scoped_tvs sigs-  where-    get_scoped_tvs :: LSig Name -> [Name]-    -- Both implicit and explicit quantified variables-    -- We need the implicit ones for   f :: forall (a::k). blah-    --    here 'k' scopes too-    get_scoped_tvs (L _ (TypeSig _ sig))-       | HsIB { hsib_vars = implicit_vars-              , hsib_body = hs_ty } <- hswc_body sig-       , (explicit_vars, _) <- splitLHsForAllTy hs_ty-       = implicit_vars ++ map hsLTyVarName explicit_vars-    get_scoped_tvs _ = []--    sigs = case binds of-             ValBindsIn  _ sigs -> sigs-             ValBindsOut _ sigs -> sigs--{- Notes--Note [Scoped type variables in bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   f :: forall a. a -> a-   f x = x::a-Here the 'forall a' brings 'a' into scope over the binding group.-To achieve this we--  a) Gensym a binding for 'a' at the same time as we do one for 'f'-     collecting the relevant binders with hsSigTvBinders--  b) When processing the 'forall', don't gensym--The relevant places are signposted with references to this Note--Note [Binders and occurrences]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we desugar [d| data T = MkT |]-we want to get-        Data "T" [] [Con "MkT" []] []-and *not*-        Data "Foo:T" [] [Con "Foo:MkT" []] []-That is, the new data decl should fit into whatever new module it is-asked to fit in.   We do *not* clone, though; no need for this:-        Data "T79" ....--But if we see this:-        data T = MkT-        foo = reifyDecl T--then we must desugar to-        foo = Data "Foo:T" [] [Con "Foo:MkT" []] []--So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.-And we use lookupOcc, rather than lookupBinder-in repTyClD and repC.--Note [Don't quantify implicit type variables in quotes]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If you're not careful, it's suprisingly easy to take this quoted declaration:--  [d| idProxy :: forall proxy (b :: k). proxy b -> proxy b-      idProxy x = x-    |]--and have Template Haskell turn it into this:--  idProxy :: forall k proxy (b :: k). proxy b -> proxy b-  idProxy x = x--Notice that we explicitly quantified the variable `k`! This is quite bad, as the-latter declaration requires -XTypeInType, while the former does not. Not to-mention that the latter declaration isn't even what the user wrote in the-first place.--Usually, the culprit behind these bugs is taking implicitly quantified type-variables (often from the hsib_vars field of HsImplicitBinders) and putting-them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123.--}---- represent associated family instances----repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))--repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ repFamilyDecl (L loc fam)--repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))-  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]-       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->-                repSynDecl tc1 bndrs rhs-       ; return (Just (loc, dec)) }--repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn }))-  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]-       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->-                repDataDefn tc1 bndrs Nothing defn-       ; return (Just (loc, dec)) }--repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,-                             tcdTyVars = tvs, tcdFDs = fds,-                             tcdSigs = sigs, tcdMeths = meth_binds,-                             tcdATs = ats, tcdATDefs = atds }))-  = do { cls1 <- lookupLOcc cls         -- See note [Binders and occurrences]-       ; dec  <- addTyVarBinds tvs $ \bndrs ->-           do { cxt1   <- repLContext cxt-              ; sigs1  <- rep_sigs sigs-              ; binds1 <- rep_binds meth_binds-              ; fds1   <- repLFunDeps fds-              ; ats1   <- repFamilyDecls ats-              ; atds1  <- repAssocTyFamDefaults atds-              ; decls1 <- coreList decQTyConName (ats1 ++ atds1 ++ sigs1 ++ binds1)-              ; repClass cxt1 cls1 bndrs fds1 decls1-              }-       ; return $ Just (loc, dec)-       }----------------------------repRoleD :: LRoleAnnotDecl Name -> DsM (SrcSpan, Core TH.DecQ)-repRoleD (L loc (RoleAnnotDecl tycon roles))-  = do { tycon1 <- lookupLOcc tycon-       ; roles1 <- mapM repRole roles-       ; roles2 <- coreList roleTyConName roles1-       ; dec <- repRoleAnnotD tycon1 roles2-       ; return (loc, dec) }----------------------------repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr]-            -> Maybe (Core [TH.TypeQ])-            -> HsDataDefn Name-            -> DsM (Core TH.DecQ)-repDataDefn tc bndrs opt_tys-          (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig-                      , dd_cons = cons, dd_derivs = mb_derivs })-  = do { cxt1     <- repLContext cxt-       ; derivs1  <- repDerivs mb_derivs-       ; case (new_or_data, cons) of-           (NewType, [con])  -> do { con'  <- repC con-                                   ; ksig' <- repMaybeLKind ksig-                                   ; repNewtype cxt1 tc bndrs opt_tys ksig' con'-                                                derivs1 }-           (NewType, _) -> failWithDs (text "Multiple constructors for newtype:"-                                       <+> pprQuotedList-                                       (getConNames $ unLoc $ head cons))-           (DataType, _) -> do { ksig' <- repMaybeLKind ksig-                               ; consL <- mapM repC cons-                               ; cons1 <- coreList conQTyConName consL-                               ; repData cxt1 tc bndrs opt_tys ksig' cons1-                                         derivs1 }-       }--repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr]-           -> LHsType Name-           -> DsM (Core TH.DecQ)-repSynDecl tc bndrs ty-  = do { ty1 <- repLTy ty-       ; repTySyn tc bndrs ty1 }--repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)-repFamilyDecl decl@(L loc (FamilyDecl { fdInfo      = info,-                                        fdLName     = tc,-                                        fdTyVars    = tvs,-                                        fdResultSig = L _ resultSig,-                                        fdInjectivityAnn = injectivity }))-  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]-       ; let mkHsQTvs :: [LHsTyVarBndr Name] -> LHsQTyVars Name-             mkHsQTvs tvs = HsQTvs { hsq_implicit = [], hsq_explicit = tvs-                                   , hsq_dependent = emptyNameSet }-             resTyVar = case resultSig of-                     TyVarSig bndr -> mkHsQTvs [bndr]-                     _             -> mkHsQTvs []-       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->-                addTyClTyVarBinds resTyVar $ \_ ->-           case info of-             ClosedTypeFamily Nothing ->-                 notHandled "abstract closed type family" (ppr decl)-             ClosedTypeFamily (Just eqns) ->-               do { eqns1  <- mapM repTyFamEqn eqns-                  ; eqns2  <- coreList tySynEqnQTyConName eqns1-                  ; result <- repFamilyResultSig resultSig-                  ; inj    <- repInjectivityAnn injectivity-                  ; repClosedFamilyD tc1 bndrs result inj eqns2 }-             OpenTypeFamily ->-               do { result <- repFamilyResultSig resultSig-                  ; inj    <- repInjectivityAnn injectivity-                  ; repOpenFamilyD tc1 bndrs result inj }-             DataFamily ->-               do { kind <- repFamilyResultSigToMaybeKind resultSig-                  ; repDataFamilyD tc1 bndrs kind }-       ; return (loc, dec)-       }---- | Represent result signature of a type family-repFamilyResultSig :: FamilyResultSig Name -> DsM (Core TH.FamilyResultSig)-repFamilyResultSig  NoSig          = repNoSig-repFamilyResultSig (KindSig ki)    = do { ki' <- repLKind ki-                                        ; repKindSig ki' }-repFamilyResultSig (TyVarSig bndr) = do { bndr' <- repTyVarBndr bndr-                                        ; repTyVarSig bndr' }---- | Represent result signature using a Maybe Kind. Used with data families,--- where the result signature can be either missing or a kind but never a named--- result variable.-repFamilyResultSigToMaybeKind :: FamilyResultSig Name-                              -> DsM (Core (Maybe TH.Kind))-repFamilyResultSigToMaybeKind NoSig =-    do { coreNothing kindTyConName }-repFamilyResultSigToMaybeKind (KindSig ki) =-    do { ki' <- repLKind ki-       ; coreJust kindTyConName ki' }-repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind"---- | Represent injectivity annotation of a type family-repInjectivityAnn :: Maybe (LInjectivityAnn Name)-                  -> DsM (Core (Maybe TH.InjectivityAnn))-repInjectivityAnn Nothing =-    do { coreNothing injAnnTyConName }-repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) =-    do { lhs'   <- lookupBinder (unLoc lhs)-       ; rhs1   <- mapM (lookupBinder . unLoc) rhs-       ; rhs2   <- coreList nameTyConName rhs1-       ; injAnn <- rep2 injectivityAnnName [unC lhs', unC rhs2]-       ; coreJust injAnnTyConName injAnn }--repFamilyDecls :: [LFamilyDecl Name] -> DsM [Core TH.DecQ]-repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)--repAssocTyFamDefaults :: [LTyFamDefltEqn Name] -> DsM [Core TH.DecQ]-repAssocTyFamDefaults = mapM rep_deflt-  where-     -- very like repTyFamEqn, but different in the details-    rep_deflt :: LTyFamDefltEqn Name -> DsM (Core TH.DecQ)-    rep_deflt (L _ (TyFamEqn { tfe_tycon = tc-                             , tfe_pats  = bndrs-                             , tfe_rhs   = rhs }))-      = addTyClTyVarBinds bndrs $ \ _ ->-        do { tc1  <- lookupLOcc tc-           ; tys1 <- repLTys (hsLTyVarBndrsToTypes bndrs)-           ; tys2 <- coreList typeQTyConName tys1-           ; rhs1 <- repLTy rhs-           ; eqn1 <- repTySynEqn tys2 rhs1-           ; repTySynInst tc1 eqn1 }------------------------------ represent fundeps----repLFunDeps :: [Located (FunDep (Located Name))] -> DsM (Core [TH.FunDep])-repLFunDeps fds = repList funDepTyConName repLFunDep fds--repLFunDep :: Located (FunDep (Located Name)) -> DsM (Core TH.FunDep)-repLFunDep (L _ (xs, ys))-   = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs-        ys' <- repList nameTyConName (lookupBinder . unLoc) ys-        repFunDep xs' ys'---- Represent instance declarations----repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)-repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))-  = do { dec <- repTyFamInstD fi_decl-       ; return (loc, dec) }-repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))-  = do { dec <- repDataFamInstD fi_decl-       ; return (loc, dec) }-repInstD (L loc (ClsInstD { cid_inst = cls_decl }))-  = do { dec <- repClsInstD cls_decl-       ; return (loc, dec) }--repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ)-repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds-                         , cid_sigs = prags, cid_tyfam_insts = ats-                         , cid_datafam_insts = adts-                         , cid_overlap_mode = overlap-                         })-  = addSimpleTyVarBinds tvs $-            -- We must bring the type variables into scope, so their-            -- occurrences don't fail, even though the binders don't-            -- appear in the resulting data structure-            ---            -- But we do NOT bring the binders of 'binds' into scope-            -- because they are properly regarded as occurrences-            -- For example, the method names should be bound to-            -- the selector Ids, not to fresh names (Trac #5410)-            ---            do { cxt1 <- repLContext cxt-               ; inst_ty1 <- repLTy inst_ty-               ; binds1 <- rep_binds binds-               ; prags1 <- rep_sigs prags-               ; ats1 <- mapM (repTyFamInstD . unLoc) ats-               ; adts1 <- mapM (repDataFamInstD . unLoc) adts-               ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)-               ; rOver <- repOverlap (fmap unLoc overlap)-               ; repInst rOver cxt1 inst_ty1 decls }- where-   (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty--repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ)-repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat-                                      , deriv_type     = ty }))-  = do { dec <- addSimpleTyVarBinds tvs $-                do { cxt'     <- repLContext cxt-                   ; strat'   <- repDerivStrategy strat-                   ; inst_ty' <- repLTy inst_ty-                   ; repDeriv strat' cxt' inst_ty' }-       ; return (loc, dec) }-  where-    (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty--repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)-repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })-  = do { let tc_name = tyFamInstDeclLName decl-       ; tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]-       ; eqn1 <- repTyFamEqn eqn-       ; repTySynInst tc eqn1 }--repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)-repTyFamEqn (L _ (TyFamEqn { tfe_pats = HsIB { hsib_body = tys-                                             , hsib_vars = var_names }-                           , tfe_rhs = rhs }))-  = do { let hs_tvs = HsQTvs { hsq_implicit = var_names-                             , hsq_explicit = []-                             , hsq_dependent = emptyNameSet }   -- Yuk-       ; addTyClTyVarBinds hs_tvs $ \ _ ->-         do { tys1 <- repLTys tys-            ; tys2 <- coreList typeQTyConName tys1-            ; rhs1 <- repLTy rhs-            ; repTySynEqn tys2 rhs1 } }--repDataFamInstD :: DataFamInstDecl Name -> DsM (Core TH.DecQ)-repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name-                                 , dfid_pats = HsIB { hsib_body = tys, hsib_vars = var_names }-                                 , dfid_defn = defn })-  = do { tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]-       ; let hs_tvs = HsQTvs { hsq_implicit = var_names-                             , hsq_explicit = []-                             , hsq_dependent = emptyNameSet }   -- Yuk-       ; addTyClTyVarBinds hs_tvs $ \ bndrs ->-         do { tys1 <- repList typeQTyConName repLTy tys-            ; repDataDefn tc bndrs (Just tys1) defn } }--repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)-repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ-                              , fd_fi = CImport (L _ cc) (L _ s) mch cis _ }))- = do MkC name' <- lookupLOcc name-      MkC typ' <- repHsSigType typ-      MkC cc' <- repCCallConv cc-      MkC s' <- repSafety s-      cis' <- conv_cimportspec cis-      MkC str <- coreStringLit (static ++ chStr ++ cis')-      dec <- rep2 forImpDName [cc', s', str, name', typ']-      return (loc, dec)- where-    conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))-    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"-    conv_cimportspec (CFunction (StaticTarget _ fs _ True))-                            = return (unpackFS fs)-    conv_cimportspec (CFunction (StaticTarget _ _  _ False))-                            = panic "conv_cimportspec: values not supported yet"-    conv_cimportspec CWrapper = return "wrapper"-    -- these calling conventions do not support headers and the static keyword-    raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv-    static = case cis of-                 CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static "-                 _ -> ""-    chStr = case mch of-            Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "-            _ -> ""-repForD decl = notHandled "Foreign declaration" (ppr decl)--repCCallConv :: CCallConv -> DsM (Core TH.Callconv)-repCCallConv CCallConv          = rep2 cCallName []-repCCallConv StdCallConv        = rep2 stdCallName []-repCCallConv CApiConv           = rep2 cApiCallName []-repCCallConv PrimCallConv       = rep2 primCallName []-repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []--repSafety :: Safety -> DsM (Core TH.Safety)-repSafety PlayRisky = rep2 unsafeName []-repSafety PlayInterruptible = rep2 interruptibleName []-repSafety PlaySafe = rep2 safeName []--repFixD :: LFixitySig Name -> DsM [(SrcSpan, Core TH.DecQ)]-repFixD (L loc (FixitySig names (Fixity _ prec dir)))-  = do { MkC prec' <- coreIntLit prec-       ; let rep_fn = case dir of-                        InfixL -> infixLDName-                        InfixR -> infixRDName-                        InfixN -> infixNDName-       ; let do_one name-              = do { MkC name' <- lookupLOcc name-                   ; dec <- rep2 rep_fn [prec', name']-                   ; return (loc,dec) }-       ; mapM do_one names }--repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)-repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))-  = do { let bndr_names = concatMap ruleBndrNames bndrs-       ; ss <- mkGenSyms bndr_names-       ; rule1 <- addBinds ss $-                  do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs-                     ; n'   <- coreStringLit $ unpackFS $ snd $ unLoc n-                     ; act' <- repPhases act-                     ; lhs' <- repLE lhs-                     ; rhs' <- repLE rhs-                     ; repPragRule n' bndrs' lhs' rhs' act' }-       ; rule2 <- wrapGenSyms ss rule1-       ; return (loc, rule2) }--ruleBndrNames :: LRuleBndr Name -> [Name]-ruleBndrNames (L _ (RuleBndr n))      = [unLoc n]-ruleBndrNames (L _ (RuleBndrSig n sig))-  | HsWC { hswc_body = HsIB { hsib_vars = vars }} <- sig-  = unLoc n : vars--repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ)-repRuleBndr (L _ (RuleBndr n))-  = do { MkC n' <- lookupLBinder n-       ; rep2 ruleVarName [n'] }-repRuleBndr (L _ (RuleBndrSig n sig))-  = do { MkC n'  <- lookupLBinder n-       ; MkC ty' <- repLTy (hsSigWcType sig)-       ; rep2 typedRuleVarName [n', ty'] }--repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ)-repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp)))-  = do { target <- repAnnProv ann_prov-       ; exp'   <- repE exp-       ; dec    <- repPragAnn target exp'-       ; return (loc, dec) }--repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)-repAnnProv (ValueAnnProvenance (L _ n))-  = do { MkC n' <- globalVar n  -- ANNs are allowed only at top-level-       ; rep2 valueAnnotationName [ n' ] }-repAnnProv (TypeAnnProvenance (L _ n))-  = do { MkC n' <- globalVar n-       ; rep2 typeAnnotationName [ n' ] }-repAnnProv ModuleAnnProvenance-  = rep2 moduleAnnotationName []------------------------------------------------------------                      Constructors----------------------------------------------------------repC :: LConDecl Name -> DsM (Core TH.ConQ)-repC (L _ (ConDeclH98 { con_name = con-                      , con_qvars = Nothing, con_cxt = Nothing-                      , con_details = details }))-  = repDataCon con details--repC (L _ (ConDeclH98 { con_name = con-                      , con_qvars = mcon_tvs, con_cxt = mcxt-                      , con_details = details }))-  = do { let con_tvs = fromMaybe emptyLHsQTvs mcon_tvs-             ctxt    = unLoc $ fromMaybe (noLoc []) mcxt-       ; addTyVarBinds con_tvs $ \ ex_bndrs ->-         do { c'    <- repDataCon con details-            ; ctxt' <- repContext ctxt-            ; if isEmptyLHsQTvs con_tvs && null ctxt-              then return c'-              else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])-            }-       }--repC (L _ (ConDeclGADT { con_names = cons-                       , con_type = res_ty@(HsIB { hsib_vars = imp_tvs })}))-  | (details, res_ty', L _ [] , []) <- gadtDetails-  , [] <- imp_tvs-    -- no implicit or explicit variables, no context = no need for a forall-  = do { let doc = text "In the constructor for " <+> ppr (head cons)-       ; (hs_details, gadt_res_ty) <--           updateGadtResult failWithDs doc details res_ty'-       ; repGadtDataCons cons hs_details gadt_res_ty }--  | (details,res_ty',ctxt, exp_tvs) <- gadtDetails-  = do { let doc = text "In the constructor for " <+> ppr (head cons)-             con_tvs = HsQTvs { hsq_implicit  = imp_tvs-                              , hsq_explicit  = exp_tvs-                              , hsq_dependent = emptyNameSet }-             -- NB: Don't put imp_tvs into the hsq_explicit field above-             -- See Note [Don't quantify implicit type variables in quotes]-       ; addTyVarBinds con_tvs $ \ ex_bndrs -> do-       { (hs_details, gadt_res_ty) <--           updateGadtResult failWithDs doc details res_ty'-       ; c'    <- repGadtDataCons cons hs_details gadt_res_ty-       ; ctxt' <- repContext (unLoc ctxt)-       ; if null exp_tvs && null (unLoc ctxt)-         then return c'-         else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } }-  where-     gadtDetails = gadtDeclDetails res_ty--repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ)-repSrcUnpackedness SrcUnpack   = rep2 sourceUnpackName         []-repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName       []-repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName []--repSrcStrictness :: SrcStrictness -> DsM (Core TH.SourceStrictnessQ)-repSrcStrictness SrcLazy     = rep2 sourceLazyName         []-repSrcStrictness SrcStrict   = rep2 sourceStrictName       []-repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName []--repBangTy :: LBangType Name -> DsM (Core (TH.BangTypeQ))-repBangTy ty = do-  MkC u <- repSrcUnpackedness su'-  MkC s <- repSrcStrictness ss'-  MkC b <- rep2 bangName [u, s]-  MkC t <- repLTy ty'-  rep2 bangTypeName [b, t]-  where-    (su', ss', ty') = case ty of-            L _ (HsBangTy (HsSrcBang _ su ss) ty) -> (su, ss, ty)-            _ -> (NoSrcUnpack, NoSrcStrict, ty)------------------------------------------------------------                      Deriving clauses----------------------------------------------------------repDerivs :: HsDeriving Name -> DsM (Core [TH.DerivClauseQ])-repDerivs (L _ clauses) = repList derivClauseQTyConName repDerivClause clauses--repDerivClause :: LHsDerivingClause Name-               -> DsM (Core TH.DerivClauseQ)-repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs-                                      , deriv_clause_tys      = L _ dct }))-  = do MkC dcs' <- repDerivStrategy dcs-       MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct-       rep2 derivClauseName [dcs',dct']-  where-    rep_deriv_ty :: LHsType Name -> DsM (Core TH.TypeQ)-    rep_deriv_ty (L _ ty) = repTy ty------------------------------------------------------------   Signatures in a class decl, or a group of bindings----------------------------------------------------------rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]-rep_sigs sigs = do locs_cores <- rep_sigs' sigs-                   return $ de_loc $ sort_by_loc locs_cores--rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]-        -- We silently ignore ones we don't recognise-rep_sigs' = concatMapM rep_sig--rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]-rep_sig (L loc (TypeSig nms ty))      = mapM (rep_wc_ty_sig sigDName loc ty) nms-rep_sig (L loc (PatSynSig nms ty))    = mapM (rep_patsyn_ty_sig loc ty) nms-rep_sig (L loc (ClassOpSig is_deflt nms ty))-  | is_deflt                          = mapM (rep_ty_sig defaultSigDName loc ty) nms-  | otherwise                         = mapM (rep_ty_sig sigDName loc ty) nms-rep_sig d@(L _ (IdSig {}))            = pprPanic "rep_sig IdSig" (ppr d)-rep_sig (L _   (FixSig {}))           = return [] -- fixity sigs at top level-rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc-rep_sig (L loc (SpecSig nm tys ispec))-  = concatMapM (\t -> rep_specialise nm t ispec loc) tys-rep_sig (L loc (SpecInstSig _ ty))    = rep_specialiseInst ty loc-rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty-rep_sig (L _   (SCCFunSig {}))        = notHandled "SCC pragmas" empty-rep_sig (L loc (CompleteMatchSig _st cls mty)) = rep_complete_sig cls mty loc---rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> Located Name-           -> DsM (SrcSpan, Core TH.DecQ)-rep_ty_sig mk_sig loc sig_ty nm-  = do { nm1 <- lookupLOcc nm-       ; ty1 <- repHsSigType sig_ty-       ; sig <- repProto mk_sig nm1 ty1-       ; return (loc, sig) }--rep_patsyn_ty_sig :: SrcSpan -> LHsSigType Name -> Located Name-                  -> DsM (SrcSpan, Core TH.DecQ)--- represents a pattern synonym type signature;--- see Note [Pattern synonym type signatures and Template Haskell] in Convert-rep_patsyn_ty_sig loc sig_ty nm-  = do { nm1 <- lookupLOcc nm-       ; ty1 <- repHsPatSynSigType sig_ty-       ; sig <- repProto patSynSigDName nm1 ty1-       ; return (loc, sig) }--rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> Located Name-              -> DsM (SrcSpan, Core TH.DecQ)-    -- We must special-case the top-level explicit for-all of a TypeSig-    -- See Note [Scoped type variables in bindings]-rep_wc_ty_sig mk_sig loc sig_ty nm-  | HsIB { hsib_body = hs_ty } <- hswc_body sig_ty-  , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty-  = do { nm1 <- lookupLOcc nm-       ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)-                                     ; repTyVarBndrWithKind tv name }-       ; th_explicit_tvs <- repList tyVarBndrTyConName rep_in_scope_tv-                                    explicit_tvs-         -- NB: Don't pass any implicit type variables to repList above-         -- See Note [Don't quantify implicit type variables in quotes]--       ; th_ctxt <- repLContext ctxt-       ; th_ty   <- repLTy ty-       ; ty1 <- if null explicit_tvs && null (unLoc ctxt)-                then return th_ty-                else repTForall th_explicit_tvs th_ctxt th_ty-       ; sig <- repProto mk_sig nm1 ty1-       ; return (loc, sig) }--rep_inline :: Located Name-           -> InlinePragma      -- Never defaultInlinePragma-           -> SrcSpan-           -> DsM [(SrcSpan, Core TH.DecQ)]-rep_inline nm ispec loc-  = do { nm1    <- lookupLOcc nm-       ; inline <- repInline $ inl_inline ispec-       ; rm     <- repRuleMatch $ inl_rule ispec-       ; phases <- repPhases $ inl_act ispec-       ; pragma <- repPragInl nm1 inline rm phases-       ; return [(loc, pragma)]-       }--rep_specialise :: Located Name -> LHsSigType Name -> InlinePragma -> SrcSpan-               -> DsM [(SrcSpan, Core TH.DecQ)]-rep_specialise nm ty ispec loc-  = do { nm1 <- lookupLOcc nm-       ; ty1 <- repHsSigType ty-       ; phases <- repPhases $ inl_act ispec-       ; let inline = inl_inline ispec-       ; pragma <- if isEmptyInlineSpec inline-                   then -- SPECIALISE-                     repPragSpec nm1 ty1 phases-                   else -- SPECIALISE INLINE-                     do { inline1 <- repInline inline-                        ; repPragSpecInl nm1 ty1 inline1 phases }-       ; return [(loc, pragma)]-       }--rep_specialiseInst :: LHsSigType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]-rep_specialiseInst ty loc-  = do { ty1    <- repHsSigType ty-       ; pragma <- repPragSpecInst ty1-       ; return [(loc, pragma)] }--repInline :: InlineSpec -> DsM (Core TH.Inline)-repInline NoInline  = dataCon noInlineDataConName-repInline Inline    = dataCon inlineDataConName-repInline Inlinable = dataCon inlinableDataConName-repInline spec      = notHandled "repInline" (ppr spec)--repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)-repRuleMatch ConLike = dataCon conLikeDataConName-repRuleMatch FunLike = dataCon funLikeDataConName--repPhases :: Activation -> DsM (Core TH.Phases)-repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i-                                  ; dataCon' beforePhaseDataConName [arg] }-repPhases (ActiveAfter _ i)  = do { MkC arg <- coreIntLit i-                                  ; dataCon' fromPhaseDataConName [arg] }-repPhases _                  = dataCon allPhasesDataConName--rep_complete_sig :: Located [Located Name]-                 -> Maybe (Located Name)-                 -> SrcSpan-                 -> DsM [(SrcSpan, Core TH.DecQ)]-rep_complete_sig (L _ cls) mty loc-  = do { mty' <- rep_maybe_name mty-       ; cls' <- repList nameTyConName lookupLOcc cls-       ; sig <- repPragComplete cls' mty'-       ; return [(loc, sig)] }-  where-    rep_maybe_name Nothing = coreNothing nameTyConName-    rep_maybe_name (Just n) = do-      cn <- lookupLOcc n-      coreJust nameTyConName cn------------------------------------------------------------                      Types----------------------------------------------------------addSimpleTyVarBinds :: [Name]                -- the binders to be added-                    -> DsM (Core (TH.Q a))   -- action in the ext env-                    -> DsM (Core (TH.Q a))-addSimpleTyVarBinds names thing_inside-  = do { fresh_names <- mkGenSyms names-       ; term <- addBinds fresh_names thing_inside-       ; wrapGenSyms fresh_names term }--addTyVarBinds :: LHsQTyVars Name                            -- the binders to be added-              -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env-              -> DsM (Core (TH.Q a))--- gensym a list of type variables and enter them into the meta environment;--- the computations passed as the second argument is executed in that extended--- meta environment and gets the *new* names on Core-level as an argument--addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs }) m-  = do { fresh_imp_names <- mkGenSyms imp_tvs-       ; fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs)-       ; let fresh_names = fresh_imp_names ++ fresh_exp_names-       ; term <- addBinds fresh_names $-                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr-                                     (exp_tvs `zip` fresh_exp_names)-                    ; m kbs }-       ; wrapGenSyms fresh_names term }-  where-    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)--addTyClTyVarBinds :: LHsQTyVars Name-                  -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))-                  -> DsM (Core (TH.Q a))---- Used for data/newtype declarations, and family instances,--- so that the nested type variables work right---    instance C (T a) where---      type W (T a) = blah--- The 'a' in the type instance is the one bound by the instance decl-addTyClTyVarBinds tvs m-  = do { let tv_names = hsAllLTyVarNames tvs-       ; env <- dsGetMetaEnv-       ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)-            -- Make fresh names for the ones that are not already in scope-            -- This makes things work for family declarations--       ; term <- addBinds freshNames $-                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvExplicit tvs)-                    ; m kbs }--       ; wrapGenSyms freshNames term }-  where-    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)-                       ; repTyVarBndrWithKind tv v }---- Produce kinded binder constructors from the Haskell tyvar binders----repTyVarBndrWithKind :: LHsTyVarBndr Name-                     -> Core TH.Name -> DsM (Core TH.TyVarBndr)-repTyVarBndrWithKind (L _ (UserTyVar _)) nm-  = repPlainTV nm-repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm-  = repLKind ki >>= repKindedTV nm---- | Represent a type variable binder-repTyVarBndr :: LHsTyVarBndr Name -> DsM (Core TH.TyVarBndr)-repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm-                                             ; repPlainTV nm' }-repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm-                                                  ; ki' <- repLKind ki-                                                  ; repKindedTV nm' ki' }---- represent a type context----repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)-repLContext (L _ ctxt) = repContext ctxt--repContext :: HsContext Name -> DsM (Core TH.CxtQ)-repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt-                     repCtxt preds--repHsSigType :: LHsSigType Name -> DsM (Core TH.TypeQ)-repHsSigType (HsIB { hsib_vars = implicit_tvs-                   , hsib_body = body })-  | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body-  = addTyVarBinds (HsQTvs { hsq_implicit = implicit_tvs-                          , hsq_explicit = explicit_tvs-                          , hsq_dependent = emptyNameSet })-    -- NB: Don't pass implicit_tvs to the hsq_explicit field above-    -- See Note [Don't quantify implicit type variables in quotes]-                  $ \ th_explicit_tvs ->-    do { th_ctxt <- repLContext ctxt-       ; th_ty   <- repLTy ty-       ; if null explicit_tvs && null (unLoc ctxt)-         then return th_ty-         else repTForall th_explicit_tvs th_ctxt th_ty }--repHsPatSynSigType :: LHsSigType Name -> DsM (Core TH.TypeQ)-repHsPatSynSigType (HsIB { hsib_vars = implicit_tvs-                         , hsib_body = body })-  = addTyVarBinds (newTvs implicit_tvs univs) $ \th_univs ->-      addTyVarBinds (newTvs [] exis) $ \th_exis ->-    do { th_reqs  <- repLContext reqs-       ; th_provs <- repLContext provs-       ; th_ty    <- repLTy ty-       ; repTForall th_univs th_reqs =<< (repTForall th_exis th_provs th_ty) }-  where-    newTvs impl_tvs expl_tvs = HsQTvs-      { hsq_implicit  = impl_tvs-      , hsq_explicit  = expl_tvs-      , hsq_dependent = emptyNameSet }-    -- NB: Don't pass impl_tvs to the hsq_explicit field above-    -- See Note [Don't quantify implicit type variables in quotes]--    (univs, reqs, exis, provs, ty) = splitLHsPatSynTy body--repHsSigWcType :: LHsSigWcType Name -> DsM (Core TH.TypeQ)-repHsSigWcType (HsWC { hswc_body = sig1 })-  = repHsSigType sig1---- yield the representation of a list of types-repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]-repLTys tys = mapM repLTy tys---- represent a type-repLTy :: LHsType Name -> DsM (Core TH.TypeQ)-repLTy (L _ ty) = repTy ty--repForall :: HsType Name -> DsM (Core TH.TypeQ)--- Arg of repForall is always HsForAllTy or HsQualTy-repForall ty- | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)- = addTyVarBinds (HsQTvs { hsq_implicit = [], hsq_explicit = tvs-                         , hsq_dependent = emptyNameSet }) $ \bndrs ->-   do { ctxt1  <- repLContext ctxt-      ; ty1    <- repLTy tau-      ; repTForall bndrs ctxt1 ty1 }--repTy :: HsType Name -> DsM (Core TH.TypeQ)-repTy ty@(HsForAllTy {}) = repForall ty-repTy ty@(HsQualTy {})   = repForall ty--repTy (HsTyVar _ (L _ n))-  | isTvOcc occ   = do tv1 <- lookupOcc n-                       repTvar tv1-  | isDataOcc occ = do tc1 <- lookupOcc n-                       repPromotedDataCon tc1-  | n == eqTyConName = repTequality-  | otherwise     = do tc1 <- lookupOcc n-                       repNamedTyCon tc1-  where-    occ = nameOccName n--repTy (HsAppTy f a)         = do-                                f1 <- repLTy f-                                a1 <- repLTy a-                                repTapp f1 a1-repTy (HsFunTy f a)         = do-                                f1   <- repLTy f-                                a1   <- repLTy a-                                tcon <- repArrowTyCon-                                repTapps tcon [f1, a1]-repTy (HsListTy t)          = do-                                t1   <- repLTy t-                                tcon <- repListTyCon-                                repTapp tcon t1-repTy (HsPArrTy t)     = do-                           t1   <- repLTy t-                           tcon <- repTy (HsTyVar NotPromoted-                                                  (noLoc (tyConName parrTyCon)))-                           repTapp tcon t1-repTy (HsTupleTy HsUnboxedTuple tys) = do-                                tys1 <- repLTys tys-                                tcon <- repUnboxedTupleTyCon (length tys)-                                repTapps tcon tys1-repTy (HsTupleTy _ tys)     = do tys1 <- repLTys tys-                                 tcon <- repTupleTyCon (length tys)-                                 repTapps tcon tys1-repTy (HsSumTy tys)         = do tys1 <- repLTys tys-                                 tcon <- repUnboxedSumTyCon (length tys)-                                 repTapps tcon tys1-repTy (HsOpTy ty1 n ty2)    = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)-                                   `nlHsAppTy` ty2)-repTy (HsParTy t)           = repLTy t-repTy (HsEqTy t1 t2) = do-                         t1' <- repLTy t1-                         t2' <- repLTy t2-                         eq  <- repTequality-                         repTapps eq [t1', t2']-repTy (HsKindSig t k)       = do-                                t1 <- repLTy t-                                k1 <- repLKind k-                                repTSig t1 k1-repTy (HsSpliceTy splice _)     = repSplice splice-repTy (HsExplicitListTy _ _ tys) = do-                                    tys1 <- repLTys tys-                                    repTPromotedList tys1-repTy (HsExplicitTupleTy _ tys) = do-                                    tys1 <- repLTys tys-                                    tcon <- repPromotedTupleTyCon (length tys)-                                    repTapps tcon tys1-repTy (HsTyLit lit) = do-                        lit' <- repTyLit lit-                        repTLit lit'-repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard--repTy ty                      = notHandled "Exotic form of type" (ppr ty)--repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)-repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i-                            rep2 numTyLitName [iExpr]-repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s-                            ; rep2 strTyLitName [s']-                            }---- represent a kind----repLKind :: LHsKind Name -> DsM (Core TH.Kind)-repLKind ki-  = do { let (kis, ki') = splitHsFunType ki-       ; kis_rep <- mapM repLKind kis-       ; ki'_rep <- repNonArrowLKind ki'-       ; kcon <- repKArrow-       ; let f k1 k2 = repKApp kcon k1 >>= flip repKApp k2-       ; foldrM f ki'_rep kis_rep-       }---- | Represent a kind wrapped in a Maybe-repMaybeLKind :: Maybe (LHsKind Name)-              -> DsM (Core (Maybe TH.Kind))-repMaybeLKind Nothing =-    do { coreNothing kindTyConName }-repMaybeLKind (Just ki) =-    do { ki' <- repLKind ki-       ; coreJust kindTyConName ki' }--repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind)-repNonArrowLKind (L _ ki) = repNonArrowKind ki--repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind)-repNonArrowKind (HsTyVar _ (L _ name))-  | isLiftedTypeKindTyConName name       = repKStar-  | name `hasKey` constraintKindTyConKey = repKConstraint-  | isTvOcc (nameOccName name)      = lookupOcc name >>= repKVar-  | otherwise                       = lookupOcc name >>= repKCon-repNonArrowKind (HsAppTy f a)       = do  { f' <- repLKind f-                                          ; a' <- repLKind a-                                          ; repKApp f' a'-                                          }-repNonArrowKind (HsListTy k)        = do  { k' <- repLKind k-                                          ; kcon <- repKList-                                          ; repKApp kcon k'-                                          }-repNonArrowKind (HsTupleTy _ ks)    = do  { ks' <- mapM repLKind ks-                                          ; kcon <- repKTuple (length ks)-                                          ; repKApps kcon ks'-                                          }-repNonArrowKind k                   = notHandled "Exotic form of kind" (ppr k)--repRole :: Located (Maybe Role) -> DsM (Core TH.Role)-repRole (L _ (Just Nominal))          = rep2 nominalRName []-repRole (L _ (Just Representational)) = rep2 representationalRName []-repRole (L _ (Just Phantom))          = rep2 phantomRName []-repRole (L _ Nothing)                 = rep2 inferRName []----------------------------------------------------------------------------------              Splices--------------------------------------------------------------------------------repSplice :: HsSplice Name -> DsM (Core a)--- See Note [How brackets and nested splices are handled] in TcSplice--- We return a CoreExpr of any old type; the context should know-repSplice (HsTypedSplice   _ n _) = rep_splice n-repSplice (HsUntypedSplice _ n _) = rep_splice n-repSplice (HsQuasiQuote n _ _ _)  = rep_splice n-repSplice e@(HsSpliced _ _)       = pprPanic "repSplice" (ppr e)--rep_splice :: Name -> DsM (Core a)-rep_splice splice_name- = do { mb_val <- dsLookupMetaEnv splice_name-       ; case mb_val of-           Just (DsSplice e) -> do { e' <- dsExpr e-                                   ; return (MkC e') }-           _ -> pprPanic "HsSplice" (ppr splice_name) }-                        -- Should not happen; statically checked----------------------------------------------------------------------------------              Expressions--------------------------------------------------------------------------------repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])-repLEs es = repList expQTyConName repLE es---- FIXME: some of these panics should be converted into proper error messages---        unless we can make sure that constructs, which are plainly not---        supported in TH already lead to error messages at an earlier stage-repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)-repLE (L loc e) = putSrcSpanDs loc (repE e)--repE :: HsExpr Name -> DsM (Core TH.ExpQ)-repE (HsVar (L _ x))            =-  do { mb_val <- dsLookupMetaEnv x-     ; case mb_val of-        Nothing            -> do { str <- globalVar x-                                 ; repVarOrCon x str }-        Just (DsBound y)   -> repVarOrCon x (coreVar y)-        Just (DsSplice e)  -> do { e' <- dsExpr e-                                 ; return (MkC e') } }-repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)-repE e@(HsOverLabel{}) = notHandled "Overloaded labels" (ppr e)--repE e@(HsRecFld f) = case f of-  Unambiguous _ x -> repE (HsVar (noLoc x))-  Ambiguous{}     -> notHandled "Ambiguous record selectors" (ppr e)--        -- Remember, we're desugaring renamer output here, so-        -- HsOverlit can definitely occur-repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }-repE (HsLit l)     = do { a <- repLiteral l;           repLit a }-repE (HsLam (MG { mg_alts = L _ [m] })) = repLambda m-repE (HsLamCase (MG { mg_alts = L _ ms }))-                   = do { ms' <- mapM repMatchTup ms-                        ; core_ms <- coreList matchQTyConName ms'-                        ; repLamCase core_ms }-repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}-repE (HsAppType e t) = do { a <- repLE e-                          ; s <- repLTy (hswc_body t)-                          ; repAppType a s }--repE (OpApp e1 op _ e2) =-  do { arg1 <- repLE e1;-       arg2 <- repLE e2;-       the_op <- repLE op ;-       repInfixApp arg1 the_op arg2 }-repE (NegApp x _)        = do-                              a         <- repLE x-                              negateVar <- lookupOcc negateName >>= repVar-                              negateVar `repApp` a-repE (HsPar x)            = repLE x-repE (SectionL x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b }-repE (SectionR x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }-repE (HsCase e (MG { mg_alts = L _ ms }))-                          = do { arg <- repLE e-                               ; ms2 <- mapM repMatchTup ms-                               ; core_ms2 <- coreList matchQTyConName ms2-                               ; repCaseE arg core_ms2 }-repE (HsIf _ x y z)         = do-                              a <- repLE x-                              b <- repLE y-                              c <- repLE z-                              repCond a b c-repE (HsMultiIf _ alts)-  = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts-       ; expr' <- repMultiIf (nonEmptyCoreList alts')-       ; wrapGenSyms (concat binds) expr' }-repE (HsLet (L _ bs) e)         = do { (ss,ds) <- repBinds bs-                                     ; e2 <- addBinds ss (repLE e)-                                     ; z <- repLetE ds e2-                                     ; wrapGenSyms ss z }---- FIXME: I haven't got the types here right yet-repE e@(HsDo ctxt (L _ sts) _)- | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }- = do { (ss,zs) <- repLSts sts;-        e'      <- repDoE (nonEmptyCoreList zs);-        wrapGenSyms ss e' }-- | ListComp <- ctxt- = do { (ss,zs) <- repLSts sts;-        e'      <- repComp (nonEmptyCoreList zs);-        wrapGenSyms ss e' }--  | otherwise-  = notHandled "mdo, monad comprehension and [: :]" (ppr e)--repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }-repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)-repE e@(ExplicitTuple es boxed)-  | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)-  | isBoxed boxed  = do { xs <- repLEs [e | L _ (Present e) <- es]; repTup xs }-  | otherwise      = do { xs <- repLEs [e | L _ (Present e) <- es]-                        ; repUnboxedTup xs }--repE (ExplicitSum alt arity e _)- = do { e1 <- repLE e-      ; repUnboxedSum e1 alt arity }--repE (RecordCon { rcon_con_name = c, rcon_flds = flds })- = do { x <- lookupLOcc c;-        fs <- repFields flds;-        repRecCon x fs }-repE (RecordUpd { rupd_expr = e, rupd_flds = flds })- = do { x <- repLE e;-        fs <- repUpdFields flds;-        repRecUpd x fs }--repE (ExprWithTySig e ty)-  = do { e1 <- repLE e-       ; t1 <- repHsSigWcType ty-       ; repSigExp e1 t1 }--repE (ArithSeq _ _ aseq) =-  case aseq of-    From e              -> do { ds1 <- repLE e; repFrom ds1 }-    FromThen e1 e2      -> do-                             ds1 <- repLE e1-                             ds2 <- repLE e2-                             repFromThen ds1 ds2-    FromTo   e1 e2      -> do-                             ds1 <- repLE e1-                             ds2 <- repLE e2-                             repFromTo ds1 ds2-    FromThenTo e1 e2 e3 -> do-                             ds1 <- repLE e1-                             ds2 <- repLE e2-                             ds3 <- repLE e3-                             repFromThenTo ds1 ds2 ds3--repE (HsSpliceE splice)    = repSplice splice-repE (HsStatic _ e)        = repLE e >>= rep2 staticEName . (:[]) . unC-repE (HsUnboundVar uv)     = do-                               occ   <- occNameLit (unboundVarOcc uv)-                               sname <- repNameS occ-                               repUnboundVar sname--repE e@(PArrSeq {})        = notHandled "Parallel arrays" (ppr e)-repE e@(HsCoreAnn {})      = notHandled "Core annotations" (ppr e)-repE e@(HsSCC {})          = notHandled "Cost centres" (ppr e)-repE e@(HsTickPragma {})   = notHandled "Tick Pragma" (ppr e)-repE e@(HsTcBracketOut {}) = notHandled "TH brackets" (ppr e)-repE e                     = notHandled "Expression form" (ppr e)---------------------------------------------------------------------------------- Building representations of auxillary structures like Match, Clause, Stmt,--repMatchTup ::  LMatch Name (LHsExpr Name) -> DsM (Core TH.MatchQ)-repMatchTup (L _ (Match _ [p] _ (GRHSs guards (L _ wheres)))) =-  do { ss1 <- mkGenSyms (collectPatBinders p)-     ; addBinds ss1 $ do {-     ; p1 <- repLP p-     ; (ss2,ds) <- repBinds wheres-     ; addBinds ss2 $ do {-     ; gs    <- repGuards guards-     ; match <- repMatch p1 gs ds-     ; wrapGenSyms (ss1++ss2) match }}}-repMatchTup _ = panic "repMatchTup: case alt with more than one arg"--repClauseTup ::  LMatch Name (LHsExpr Name) -> DsM (Core TH.ClauseQ)-repClauseTup (L _ (Match _ ps _ (GRHSs guards (L _ wheres)))) =-  do { ss1 <- mkGenSyms (collectPatsBinders ps)-     ; addBinds ss1 $ do {-       ps1 <- repLPs ps-     ; (ss2,ds) <- repBinds wheres-     ; addBinds ss2 $ do {-       gs <- repGuards guards-     ; clause <- repClause ps1 gs ds-     ; wrapGenSyms (ss1++ss2) clause }}}--repGuards ::  [LGRHS Name (LHsExpr Name)] ->  DsM (Core TH.BodyQ)-repGuards [L _ (GRHS [] e)]-  = do {a <- repLE e; repNormal a }-repGuards other-  = do { zs <- mapM repLGRHS other-       ; let (xs, ys) = unzip zs-       ; gd <- repGuarded (nonEmptyCoreList ys)-       ; wrapGenSyms (concat xs) gd }--repLGRHS :: LGRHS Name (LHsExpr Name) -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))-repLGRHS (L _ (GRHS [L _ (BodyStmt e1 _ _ _)] e2))-  = do { guarded <- repLNormalGE e1 e2-       ; return ([], guarded) }-repLGRHS (L _ (GRHS ss rhs))-  = do { (gs, ss') <- repLSts ss-       ; rhs' <- addBinds gs $ repLE rhs-       ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'-       ; return (gs, guarded) }--repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])-repFields (HsRecFields { rec_flds = flds })-  = repList fieldExpQTyConName rep_fld flds-  where-    rep_fld :: LHsRecField Name (LHsExpr Name) -> DsM (Core (TH.Q TH.FieldExp))-    rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)-                           ; e  <- repLE (hsRecFieldArg fld)-                           ; repFieldExp fn e }--repUpdFields :: [LHsRecUpdField Name] -> DsM (Core [TH.Q TH.FieldExp])-repUpdFields = repList fieldExpQTyConName rep_fld-  where-    rep_fld :: LHsRecUpdField Name -> DsM (Core (TH.Q TH.FieldExp))-    rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of-      Unambiguous _ sel_name -> do { fn <- lookupLOcc (L l sel_name)-                                   ; e  <- repLE (hsRecFieldArg fld)-                                   ; repFieldExp fn e }-      _                      -> notHandled "Ambiguous record updates" (ppr fld)------------------------------------------------------------------------------------ Representing Stmt's is tricky, especially if bound variables--- shadow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]--- First gensym new names for every variable in any of the patterns.--- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))--- if variables didn't shaddow, the static gensym wouldn't be necessary--- and we could reuse the original names (x and x).------ do { x'1 <- gensym "x"---    ; x'2 <- gensym "x"---    ; doE [ BindSt (pvar x'1) [| f 1 |]---          , BindSt (pvar x'2) [| f x |]---          , NoBindSt [| g x |]---          ]---    }---- The strategy is to translate a whole list of do-bindings by building a--- bigger environment, and a bigger set of meta bindings--- (like:  x'1 <- gensym "x" ) and then combining these with the translations--- of the expressions within the Do---------------------------------------------------------------------------------- The helper function repSts computes the translation of each sub expression--- and a bunch of prefix bindings denoting the dynamic renaming.--repLSts :: [LStmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ])-repLSts stmts = repSts (map unLoc stmts)--repSts :: [Stmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ])-repSts (BindStmt p e _ _ _ : ss) =-   do { e2 <- repLE e-      ; ss1 <- mkGenSyms (collectPatBinders p)-      ; addBinds ss1 $ do {-      ; p1 <- repLP p;-      ; (ss2,zs) <- repSts ss-      ; z <- repBindSt p1 e2-      ; return (ss1++ss2, z : zs) }}-repSts (LetStmt (L _ bs) : ss) =-   do { (ss1,ds) <- repBinds bs-      ; z <- repLetSt ds-      ; (ss2,zs) <- addBinds ss1 (repSts ss)-      ; return (ss1++ss2, z : zs) }-repSts (BodyStmt e _ _ _ : ss) =-   do { e2 <- repLE e-      ; z <- repNoBindSt e2-      ; (ss2,zs) <- repSts ss-      ; return (ss2, z : zs) }-repSts (ParStmt stmt_blocks _ _ _ : ss) =-   do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks-      ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1-            ss1 = concat ss_s-      ; z <- repParSt stmt_blocks2-      ; (ss2, zs) <- addBinds ss1 (repSts ss)-      ; return (ss1++ss2, z : zs) }-   where-     rep_stmt_block :: ParStmtBlock Name Name -> DsM ([GenSymBind], Core [TH.StmtQ])-     rep_stmt_block (ParStmtBlock stmts _ _) =-       do { (ss1, zs) <- repSts (map unLoc stmts)-          ; zs1 <- coreList stmtQTyConName zs-          ; return (ss1, zs1) }-repSts [LastStmt e _ _]-  = do { e2 <- repLE e-       ; z <- repNoBindSt e2-       ; return ([], [z]) }-repSts []    = return ([],[])-repSts other = notHandled "Exotic statement" (ppr other)-----------------------------------------------------------------                      Bindings--------------------------------------------------------------repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])-repBinds EmptyLocalBinds-  = do  { core_list <- coreList decQTyConName []-        ; return ([], core_list) }--repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)--repBinds (HsValBinds decs)- = do   { let { bndrs = hsSigTvBinders decs ++ collectHsValBinders decs }-                -- No need to worry about detailed scopes within-                -- the binding group, because we are talking Names-                -- here, so we can safely treat it as a mutually-                -- recursive group-                -- For hsSigTvBinders see Note [Scoped type variables in bindings]-        ; ss        <- mkGenSyms bndrs-        ; prs       <- addBinds ss (rep_val_binds decs)-        ; core_list <- coreList decQTyConName-                                (de_loc (sort_by_loc prs))-        ; return (ss, core_list) }--rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]--- Assumes: all the binders of the binding are already in the meta-env-rep_val_binds (ValBindsOut binds sigs)- = do { core1 <- rep_binds' (unionManyBags (map snd binds))-      ; core2 <- rep_sigs' sigs-      ; return (core1 ++ core2) }-rep_val_binds (ValBindsIn _ _)- = panic "rep_val_binds: ValBindsIn"--rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]-rep_binds binds = do { binds_w_locs <- rep_binds' binds-                     ; return (de_loc (sort_by_loc binds_w_locs)) }--rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]-rep_binds' = mapM rep_bind . bagToList--rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)--- Assumes: all the binders of the binding are already in the meta-env---- Note GHC treats declarations of a variable (not a pattern)--- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match--- with an empty list of patterns-rep_bind (L loc (FunBind-                 { fun_id = fn,-                   fun_matches = MG { mg_alts-                           = L _ [L _ (Match _ [] _-                                             (GRHSs guards (L _ wheres)))] } }))- = do { (ss,wherecore) <- repBinds wheres-        ; guardcore <- addBinds ss (repGuards guards)-        ; fn'  <- lookupLBinder fn-        ; p    <- repPvar fn'-        ; ans  <- repVal p guardcore wherecore-        ; ans' <- wrapGenSyms ss ans-        ; return (loc, ans') }--rep_bind (L loc (FunBind { fun_id = fn-                         , fun_matches = MG { mg_alts = L _ ms } }))- =   do { ms1 <- mapM repClauseTup ms-        ; fn' <- lookupLBinder fn-        ; ans <- repFun fn' (nonEmptyCoreList ms1)-        ; return (loc, ans) }--rep_bind (L loc (PatBind { pat_lhs = pat-                         , pat_rhs = GRHSs guards (L _ wheres) }))- =   do { patcore <- repLP pat-        ; (ss,wherecore) <- repBinds wheres-        ; guardcore <- addBinds ss (repGuards guards)-        ; ans  <- repVal patcore guardcore wherecore-        ; ans' <- wrapGenSyms ss ans-        ; return (loc, ans') }--rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))- =   do { v' <- lookupBinder v-        ; e2 <- repLE e-        ; x <- repNormal e2-        ; patcore <- repPvar v'-        ; empty_decls <- coreList decQTyConName []-        ; ans <- repVal patcore x empty_decls-        ; return (srcLocSpan (getSrcLoc v), ans) }--rep_bind (L _ (AbsBinds {}))  = panic "rep_bind: AbsBinds"-rep_bind (L _ (AbsBindsSig {})) = panic "rep_bind: AbsBindsSig"-rep_bind (L loc (PatSynBind (PSB { psb_id   = syn-                                 , psb_fvs  = _fvs-                                 , psb_args = args-                                 , psb_def  = pat-                                 , psb_dir  = dir })))-  = do { syn'      <- lookupLBinder syn-       ; dir'      <- repPatSynDir dir-       ; ss        <- mkGenArgSyms args-       ; patSynD'  <- addBinds ss (-         do { args'  <- repPatSynArgs args-            ; pat'   <- repLP pat-            ; repPatSynD syn' args' dir' pat' })-       ; patSynD'' <- wrapGenArgSyms args ss patSynD'-       ; return (loc, patSynD'') }-  where-    mkGenArgSyms :: HsPatSynDetails (Located Name) -> DsM [GenSymBind]-    -- for Record Pattern Synonyms we want to conflate the selector-    -- and the pattern-only names in order to provide a nicer TH-    -- API. Whereas inside GHC, record pattern synonym selectors and-    -- their pattern-only bound right hand sides have different names,-    -- we want to treat them the same in TH. This is the reason why we-    -- need an adjusted mkGenArgSyms in the `RecordPatSyn` case below.-    mkGenArgSyms (PrefixPatSyn args)     = mkGenSyms (map unLoc args)-    mkGenArgSyms (InfixPatSyn arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]-    mkGenArgSyms (RecordPatSyn fields)-      = do { let pats = map (unLoc . recordPatSynPatVar) fields-                 sels = map (unLoc . recordPatSynSelectorId) fields-           ; ss <- mkGenSyms sels-           ; return $ replaceNames (zip sels pats) ss }--    replaceNames selsPats genSyms-      = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats-                    , sel == sel' ]--    wrapGenArgSyms :: HsPatSynDetails (Located Name)-                   -> [GenSymBind] -> Core TH.DecQ -> DsM (Core TH.DecQ)-    wrapGenArgSyms (RecordPatSyn _) _  dec = return dec-    wrapGenArgSyms _                ss dec = wrapGenSyms ss dec--repPatSynD :: Core TH.Name-           -> Core TH.PatSynArgsQ-           -> Core TH.PatSynDirQ-           -> Core TH.PatQ-           -> DsM (Core TH.DecQ)-repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)-  = rep2 patSynDName [syn, args, dir, pat]--repPatSynArgs :: HsPatSynDetails (Located Name) -> DsM (Core TH.PatSynArgsQ)-repPatSynArgs (PrefixPatSyn args)-  = do { args' <- repList nameTyConName lookupLOcc args-       ; repPrefixPatSynArgs args' }-repPatSynArgs (InfixPatSyn arg1 arg2)-  = do { arg1' <- lookupLOcc arg1-       ; arg2' <- lookupLOcc arg2-       ; repInfixPatSynArgs arg1' arg2' }-repPatSynArgs (RecordPatSyn fields)-  = do { sels' <- repList nameTyConName lookupLOcc sels-       ; repRecordPatSynArgs sels' }-  where sels = map recordPatSynSelectorId fields--repPrefixPatSynArgs :: Core [TH.Name] -> DsM (Core TH.PatSynArgsQ)-repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms]--repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> DsM (Core TH.PatSynArgsQ)-repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2]--repRecordPatSynArgs :: Core [TH.Name]-                    -> DsM (Core TH.PatSynArgsQ)-repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels]--repPatSynDir :: HsPatSynDir Name -> DsM (Core TH.PatSynDirQ)-repPatSynDir Unidirectional        = rep2 unidirPatSynName []-repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []-repPatSynDir (ExplicitBidirectional (MG { mg_alts = L _ clauses }))-  = do { clauses' <- mapM repClauseTup clauses-       ; repExplBidirPatSynDir (nonEmptyCoreList clauses') }--repExplBidirPatSynDir :: Core [TH.ClauseQ] -> DsM (Core TH.PatSynDirQ)-repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]----------------------------------------------------------------------------------- Since everything in a Bind is mutually recursive we need rename all--- all the variables simultaneously. For example:--- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to--- do { f'1 <- gensym "f"---    ; g'2 <- gensym "g"---    ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},---        do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}---      ]}--- This requires collecting the bindings (f'1 <- gensym "f"), and the--- environment ( f |-> f'1 ) from each binding, and then unioning them--- together. As we do this we collect GenSymBinds's which represent the renamed--- variables bound by the Bindings. In order not to lose track of these--- representations we build a shadow datatype MB with the same structure as--- MonoBinds, but which has slots for the representations----------------------------------------------------------------------------------- GHC allows a more general form of lambda abstraction than specified--- by Haskell 98. In particular it allows guarded lambda's like :--- (\  x | even x -> 0 | odd x -> 1) at the moment we can't represent this in--- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like--- (\ p1 .. pn -> exp) by causing an error.--repLambda :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ExpQ)-repLambda (L _ (Match _ ps _ (GRHSs [L _ (GRHS [] e)] (L _ EmptyLocalBinds))))- = do { let bndrs = collectPatsBinders ps ;-      ; ss  <- mkGenSyms bndrs-      ; lam <- addBinds ss (-                do { xs <- repLPs ps; body <- repLE e; repLam xs body })-      ; wrapGenSyms ss lam }--repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch m)-----------------------------------------------------------------------------------                      Patterns--- repP deals with patterns.  It assumes that we have already--- walked over the pattern(s) once to collect the binders, and--- have extended the environment.  So every pattern-bound--- variable should already appear in the environment.---- Process a list of patterns-repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])-repLPs ps = repList patQTyConName repLP ps--repLP :: LPat Name -> DsM (Core TH.PatQ)-repLP (L _ p) = repP p--repP :: Pat Name -> DsM (Core TH.PatQ)-repP (WildPat _)       = repPwild-repP (LitPat l)        = do { l2 <- repLiteral l; repPlit l2 }-repP (VarPat (L _ x))  = do { x' <- lookupBinder x; repPvar x' }-repP (LazyPat p)       = do { p1 <- repLP p; repPtilde p1 }-repP (BangPat p)       = do { p1 <- repLP p; repPbang p1 }-repP (AsPat x p)       = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }-repP (ParPat p)        = repLP p-repP (ListPat ps _ Nothing)    = do { qs <- repLPs ps; repPlist qs }-repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE (syn_expr e); repPview e' p}-repP (TuplePat ps boxed _)-  | isBoxed boxed       = do { qs <- repLPs ps; repPtup qs }-  | otherwise           = do { qs <- repLPs ps; repPunboxedTup qs }-repP (SumPat p alt arity _) = do { p1 <- repLP p; repPunboxedSum p1 alt arity }-repP (ConPatIn dc details)- = do { con_str <- lookupLOcc dc-      ; case details of-         PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }-         RecCon rec   -> do { fps <- repList fieldPatQTyConName rep_fld (rec_flds rec)-                            ; repPrec con_str fps }-         InfixCon p1 p2 -> do { p1' <- repLP p1;-                                p2' <- repLP p2;-                                repPinfix p1' con_str p2' }-   }- where-   rep_fld :: LHsRecField Name (LPat Name) -> DsM (Core (TH.Name,TH.PatQ))-   rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)-                          ; MkC p <- repLP (hsRecFieldArg fld)-                          ; rep2 fieldPatName [v,p] }--repP (NPat (L _ l) Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a }-repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }-repP p@(NPat _ (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p)-repP (SigPatIn p t) = do { p' <- repLP p-                         ; t' <- repLTy (hsSigWcType t)-                         ; repPsig p' t' }-repP (SplicePat splice) = repSplice splice--repP other = notHandled "Exotic pattern" (ppr other)--------------------------------------------------------------- Declaration ordering helpers--sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]-sort_by_loc xs = sortBy comp xs-    where comp x y = compare (fst x) (fst y)--de_loc :: [(a, b)] -> [b]-de_loc = map snd---------------------------------------------------------------      The meta-environment---- A name/identifier association for fresh names of locally bound entities-type GenSymBind = (Name, Id)    -- Gensym the string and bind it to the Id-                                -- I.e.         (x, x_id) means-                                --      let x_id = gensym "x" in ...---- Generate a fresh name for a locally bound entity--mkGenSyms :: [Name] -> DsM [GenSymBind]--- We can use the existing name.  For example:---      [| \x_77 -> x_77 + x_77 |]--- desugars to---      do { x_77 <- genSym "x"; .... }--- We use the same x_77 in the desugared program, but with the type Bndr--- instead of Int------ We do make it an Internal name, though (hence localiseName)------ Nevertheless, it's monadic because we have to generate nameTy-mkGenSyms ns = do { var_ty <- lookupType nameTyConName-                  ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }---addBinds :: [GenSymBind] -> DsM a -> DsM a--- Add a list of fresh names for locally bound entities to the--- meta environment (which is part of the state carried around--- by the desugarer monad)-addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m---- Look up a locally bound name----lookupLBinder :: Located Name -> DsM (Core TH.Name)-lookupLBinder (L _ n) = lookupBinder n--lookupBinder :: Name -> DsM (Core TH.Name)-lookupBinder = lookupOcc-  -- Binders are brought into scope before the pattern or what-not is-  -- desugared.  Moreover, in instance declaration the binder of a method-  -- will be the selector Id and hence a global; so we need the-  -- globalVar case of lookupOcc---- Look up a name that is either locally bound or a global name------  * If it is a global name, generate the "original name" representation (ie,---   the <module>:<name> form) for the associated entity----lookupLOcc :: Located Name -> DsM (Core TH.Name)--- Lookup an occurrence; it can't be a splice.--- Use the in-scope bindings if they exist-lookupLOcc (L _ n) = lookupOcc n--lookupOcc :: Name -> DsM (Core TH.Name)-lookupOcc n-  = do {  mb_val <- dsLookupMetaEnv n ;-          case mb_val of-                Nothing           -> globalVar n-                Just (DsBound x)  -> return (coreVar x)-                Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n)-    }--globalVar :: Name -> DsM (Core TH.Name)--- Not bound by the meta-env--- Could be top-level; or could be local---      f x = $(g [| x |])--- Here the x will be local-globalVar name-  | isExternalName name-  = do  { MkC mod <- coreStringLit name_mod-        ; MkC pkg <- coreStringLit name_pkg-        ; MkC occ <- nameLit name-        ; rep2 mk_varg [pkg,mod,occ] }-  | otherwise-  = do  { MkC occ <- nameLit name-        ; MkC uni <- coreIntLit (getKey (getUnique name))-        ; rep2 mkNameLName [occ,uni] }-  where-      mod = nameModule name-      name_mod = moduleNameString (moduleName mod)-      name_pkg = unitIdString (moduleUnitId mod)-      name_occ = nameOccName name-      mk_varg | OccName.isDataOcc name_occ = mkNameG_dName-              | OccName.isVarOcc  name_occ = mkNameG_vName-              | OccName.isTcOcc   name_occ = mkNameG_tcName-              | otherwise                  = pprPanic "DsMeta.globalVar" (ppr name)--lookupType :: Name      -- Name of type constructor (e.g. TH.ExpQ)-           -> DsM Type  -- The type-lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;-                          return (mkTyConApp tc []) }--wrapGenSyms :: [GenSymBind]-            -> Core (TH.Q a) -> DsM (Core (TH.Q a))--- wrapGenSyms [(nm1,id1), (nm2,id2)] y---      --> bindQ (gensym nm1) (\ id1 ->---          bindQ (gensym nm2 (\ id2 ->---          y))--wrapGenSyms binds body@(MkC b)-  = do  { var_ty <- lookupType nameTyConName-        ; go var_ty binds }-  where-    [elt_ty] = tcTyConAppArgs (exprType b)-        -- b :: Q a, so we can get the type 'a' by looking at the-        -- argument type. NB: this relies on Q being a data/newtype,-        -- not a type synonym--    go _ [] = return body-    go var_ty ((name,id) : binds)-      = do { MkC body'  <- go var_ty binds-           ; lit_str    <- nameLit name-           ; gensym_app <- repGensym lit_str-           ; repBindQ var_ty elt_ty-                      gensym_app (MkC (Lam id body')) }--nameLit :: Name -> DsM (Core String)-nameLit n = coreStringLit (occNameString (nameOccName n))--occNameLit :: OccName -> DsM (Core String)-occNameLit name = coreStringLit (occNameString name)----- %*********************************************************************--- %*                                                                   *---              Constructing code--- %*                                                                   *--- %*********************************************************************---------------------------------------------------------------------------------- PHANTOM TYPES for consistency. In order to make sure we do this correct--- we invent a new datatype which uses phantom types.--newtype Core a = MkC CoreExpr-unC :: Core a -> CoreExpr-unC (MkC x) = x--rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)-rep2 n xs = do { id <- dsLookupGlobalId n-               ; return (MkC (foldl App (Var id) xs)) }--dataCon' :: Name -> [CoreExpr] -> DsM (Core a)-dataCon' n args = do { id <- dsLookupDataCon n-                     ; return $ MkC $ mkCoreConApps id args }--dataCon :: Name -> DsM (Core a)-dataCon n = dataCon' n []----- %*********************************************************************--- %*                                                                   *---              The 'smart constructors'--- %*                                                                   *--- %*********************************************************************----------------- Patterns ------------------repPlit   :: Core TH.Lit -> DsM (Core TH.PatQ)-repPlit (MkC l) = rep2 litPName [l]--repPvar :: Core TH.Name -> DsM (Core TH.PatQ)-repPvar (MkC s) = rep2 varPName [s]--repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)-repPtup (MkC ps) = rep2 tupPName [ps]--repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)-repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]--repPunboxedSum :: Core TH.PatQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.PatQ)--- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here-repPunboxedSum (MkC p) alt arity- = do { dflags <- getDynFlags-      ; rep2 unboxedSumPName [ p-                             , mkIntExprInt dflags alt-                             , mkIntExprInt dflags arity ] }--repPcon   :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)-repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]--repPrec   :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)-repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]--repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)-repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]--repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)-repPtilde (MkC p) = rep2 tildePName [p]--repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)-repPbang (MkC p) = rep2 bangPName [p]--repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)-repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]--repPwild  :: DsM (Core TH.PatQ)-repPwild = rep2 wildPName []--repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)-repPlist (MkC ps) = rep2 listPName [ps]--repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)-repPview (MkC e) (MkC p) = rep2 viewPName [e,p]--repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)-repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]----------------- Expressions ------------------repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)-repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str-                   | otherwise                  = repVar str--repVar :: Core TH.Name -> DsM (Core TH.ExpQ)-repVar (MkC s) = rep2 varEName [s]--repCon :: Core TH.Name -> DsM (Core TH.ExpQ)-repCon (MkC s) = rep2 conEName [s]--repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)-repLit (MkC c) = rep2 litEName [c]--repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repApp (MkC x) (MkC y) = rep2 appEName [x,y]--repAppType :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)-repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y]--repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]--repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)-repLamCase (MkC ms) = rep2 lamCaseEName [ms]--repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)-repTup (MkC es) = rep2 tupEName [es]--repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)-repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]--repUnboxedSum :: Core TH.ExpQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.ExpQ)--- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here-repUnboxedSum (MkC e) alt arity- = do { dflags <- getDynFlags-      ; rep2 unboxedSumEName [ e-                             , mkIntExprInt dflags alt-                             , mkIntExprInt dflags arity ] }--repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]--repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ)-repMultiIf (MkC alts) = rep2 multiIfEName [alts]--repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]--repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)-repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]--repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)-repDoE (MkC ss) = rep2 doEName [ss]--repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)-repComp (MkC ss) = rep2 compEName [ss]--repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)-repListExp (MkC es) = rep2 listEName [es]--repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)-repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]--repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)-repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]--repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)-repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]--repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))-repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]--repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]--repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]--repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]-------------- Right hand sides (guarded expressions) -----repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)-repGuarded (MkC pairs) = rep2 guardedBName [pairs]--repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)-repNormal (MkC e) = rep2 normalBName [e]-------------- Guards -----repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))-repLNormalGE g e = do g' <- repLE g-                      e' <- repLE e-                      repNormalGE g' e'--repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))-repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]--repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))-repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]--------------- Stmts --------------------repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)-repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]--repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)-repLetSt (MkC ds) = rep2 letSName [ds]--repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)-repNoBindSt (MkC e) = rep2 noBindSName [e]--repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ)-repParSt (MkC sss) = rep2 parSName [sss]---------------- Range (Arithmetic sequences) ------------repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)-repFrom (MkC x) = rep2 fromEName [x]--repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]--repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]--repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]-------------- Match and Clause Tuples ------------repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)-repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]--repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)-repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]---------------- Dec ------------------------------repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)-repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]--repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)-repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]--repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]-        -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind)-        -> Core [TH.ConQ] -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ)-repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC cons) (MkC derivs)-  = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]-repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC cons)-        (MkC derivs)-  = rep2 dataInstDName [cxt, nm, tys, ksig, cons, derivs]--repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]-           -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind)-           -> Core TH.ConQ -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ)-repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC con)-           (MkC derivs)-  = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]-repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC con)-           (MkC derivs)-  = rep2 newtypeInstDName [cxt, nm, tys, ksig, con, derivs]--repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]-         -> Core TH.TypeQ -> DsM (Core TH.DecQ)-repTySyn (MkC nm) (MkC tvs) (MkC rhs)-  = rep2 tySynDName [nm, tvs, rhs]--repInst :: Core (Maybe TH.Overlap) ->-           Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)-repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName-                                                              [o, cxt, ty, ds]--repDerivStrategy :: Maybe (Located DerivStrategy)-                 -> DsM (Core (Maybe TH.DerivStrategy))-repDerivStrategy mds =-  case mds of-    Nothing -> nothing-    Just (L _ ds) ->-      case ds of-        StockStrategy    -> just =<< dataCon stockStrategyDataConName-        AnyclassStrategy -> just =<< dataCon anyclassStrategyDataConName-        NewtypeStrategy  -> just =<< dataCon newtypeStrategyDataConName-  where-  nothing = coreNothing derivStrategyTyConName-  just    = coreJust    derivStrategyTyConName--repOverlap :: Maybe OverlapMode -> DsM (Core (Maybe TH.Overlap))-repOverlap mb =-  case mb of-    Nothing -> nothing-    Just o ->-      case o of-        NoOverlap _    -> nothing-        Overlappable _ -> just =<< dataCon overlappableDataConName-        Overlapping _  -> just =<< dataCon overlappingDataConName-        Overlaps _     -> just =<< dataCon overlapsDataConName-        Incoherent _   -> just =<< dataCon incoherentDataConName-  where-  nothing = coreNothing overlapTyConName-  just    = coreJust overlapTyConName---repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]-         -> Core [TH.FunDep] -> Core [TH.DecQ]-         -> DsM (Core TH.DecQ)-repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)-  = rep2 classDName [cxt, cls, tvs, fds, ds]--repDeriv :: Core (Maybe TH.DerivStrategy)-         -> Core TH.CxtQ -> Core TH.TypeQ-         -> DsM (Core TH.DecQ)-repDeriv (MkC ds) (MkC cxt) (MkC ty)-  = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty]--repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch-           -> Core TH.Phases -> DsM (Core TH.DecQ)-repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)-  = rep2 pragInlDName [nm, inline, rm, phases]--repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases-            -> DsM (Core TH.DecQ)-repPragSpec (MkC nm) (MkC ty) (MkC phases)-  = rep2 pragSpecDName [nm, ty, phases]--repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline-               -> Core TH.Phases -> DsM (Core TH.DecQ)-repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)-  = rep2 pragSpecInlDName [nm, ty, inline, phases]--repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ)-repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]--repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> DsM (Core TH.DecQ)-repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty]--repPragRule :: Core String -> Core [TH.RuleBndrQ] -> Core TH.ExpQ-            -> Core TH.ExpQ -> Core TH.Phases -> DsM (Core TH.DecQ)-repPragRule (MkC nm) (MkC bndrs) (MkC lhs) (MkC rhs) (MkC phases)-  = rep2 pragRuleDName [nm, bndrs, lhs, rhs, phases]--repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ)-repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]--repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ)-repTySynInst (MkC nm) (MkC eqn)-    = rep2 tySynInstDName [nm, eqn]--repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndr]-               -> Core (Maybe TH.Kind) -> DsM (Core TH.DecQ)-repDataFamilyD (MkC nm) (MkC tvs) (MkC kind)-    = rep2 dataFamilyDName [nm, tvs, kind]--repOpenFamilyD :: Core TH.Name-               -> Core [TH.TyVarBndr]-               -> Core TH.FamilyResultSig-               -> Core (Maybe TH.InjectivityAnn)-               -> DsM (Core TH.DecQ)-repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj)-    = rep2 openTypeFamilyDName [nm, tvs, result, inj]--repClosedFamilyD :: Core TH.Name-                 -> Core [TH.TyVarBndr]-                 -> Core TH.FamilyResultSig-                 -> Core (Maybe TH.InjectivityAnn)-                 -> Core [TH.TySynEqnQ]-                 -> DsM (Core TH.DecQ)-repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns)-    = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns]--repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)-repTySynEqn (MkC lhs) (MkC rhs)-  = rep2 tySynEqnName [lhs, rhs]--repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ)-repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]--repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)-repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]--repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)-repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]--repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)-repCtxt (MkC tys) = rep2 cxtName [tys]--repDataCon :: Located Name-           -> HsConDeclDetails Name-           -> DsM (Core TH.ConQ)-repDataCon con details-    = do con' <- lookupLOcc con -- See Note [Binders and occurrences]-         repConstr details Nothing [con']--repGadtDataCons :: [Located Name]-                -> HsConDeclDetails Name-                -> LHsType Name-                -> DsM (Core TH.ConQ)-repGadtDataCons cons details res_ty-    = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]-         repConstr details (Just res_ty) cons'---- Invariant:---   * for plain H98 data constructors second argument is Nothing and third---     argument is a singleton list---   * for GADTs data constructors second argument is (Just return_type) and---     third argument is a non-empty list-repConstr :: HsConDeclDetails Name-          -> Maybe (LHsType Name)-          -> [Core TH.Name]-          -> DsM (Core TH.ConQ)-repConstr (PrefixCon ps) Nothing [con]-    = do arg_tys  <- repList bangTypeQTyConName repBangTy ps-         rep2 normalCName [unC con, unC arg_tys]--repConstr (PrefixCon ps) (Just (L _ res_ty)) cons-    = do arg_tys     <- repList bangTypeQTyConName repBangTy ps-         res_ty' <- repTy res_ty-         rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty']--repConstr (RecCon (L _ ips)) resTy cons-    = do args     <- concatMapM rep_ip ips-         arg_vtys <- coreList varBangTypeQTyConName args-         case resTy of-           Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]-           Just (L _ res_ty) -> do-             res_ty' <- repTy res_ty-             rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys,-                                unC res_ty']--    where-      rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)--      rep_one_ip :: LBangType Name -> LFieldOcc Name -> DsM (Core a)-      rep_one_ip t n = do { MkC v  <- lookupOcc (selectorFieldOcc $ unLoc n)-                          ; MkC ty <- repBangTy  t-                          ; rep2 varBangTypeName [v,ty] }--repConstr (InfixCon st1 st2) Nothing [con]-    = do arg1 <- repBangTy st1-         arg2 <- repBangTy st2-         rep2 infixCName [unC arg1, unC con, unC arg2]--repConstr (InfixCon {}) (Just _) _ =-    panic "repConstr: infix GADT constructor should be in a PrefixCon"-repConstr _ _ _ =-    panic "repConstr: invariant violated"-------------- Types ---------------------repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ-           -> DsM (Core TH.TypeQ)-repTForall (MkC tvars) (MkC ctxt) (MkC ty)-    = rep2 forallTName [tvars, ctxt, ty]--repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)-repTvar (MkC s) = rep2 varTName [s]--repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)-repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]--repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)-repTapps f []     = return f-repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }--repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ)-repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]--repTequality :: DsM (Core TH.TypeQ)-repTequality = rep2 equalityTName []--repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ)-repTPromotedList []     = repPromotedNilTyCon-repTPromotedList (t:ts) = do  { tcon <- repPromotedConsTyCon-                              ; f <- repTapp tcon t-                              ; t' <- repTPromotedList ts-                              ; repTapp f t'-                              }--repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ)-repTLit (MkC lit) = rep2 litTName [lit]--repTWildCard :: DsM (Core TH.TypeQ)-repTWildCard = rep2 wildCardTName []----------- Type constructors ----------------repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)-repNamedTyCon (MkC s) = rep2 conTName [s]--repTupleTyCon :: Int -> DsM (Core TH.TypeQ)--- Note: not Core Int; it's easier to be direct here-repTupleTyCon i = do dflags <- getDynFlags-                     rep2 tupleTName [mkIntExprInt dflags i]--repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)--- Note: not Core Int; it's easier to be direct here-repUnboxedTupleTyCon i = do dflags <- getDynFlags-                            rep2 unboxedTupleTName [mkIntExprInt dflags i]--repUnboxedSumTyCon :: TH.SumArity -> DsM (Core TH.TypeQ)--- Note: not Core TH.SumArity; it's easier to be direct here-repUnboxedSumTyCon arity = do dflags <- getDynFlags-                              rep2 unboxedSumTName [mkIntExprInt dflags arity]--repArrowTyCon :: DsM (Core TH.TypeQ)-repArrowTyCon = rep2 arrowTName []--repListTyCon :: DsM (Core TH.TypeQ)-repListTyCon = rep2 listTName []--repPromotedDataCon :: Core TH.Name -> DsM (Core TH.TypeQ)-repPromotedDataCon (MkC s) = rep2 promotedTName [s]--repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ)-repPromotedTupleTyCon i = do dflags <- getDynFlags-                             rep2 promotedTupleTName [mkIntExprInt dflags i]--repPromotedNilTyCon :: DsM (Core TH.TypeQ)-repPromotedNilTyCon = rep2 promotedNilTName []--repPromotedConsTyCon :: DsM (Core TH.TypeQ)-repPromotedConsTyCon = rep2 promotedConsTName []-------------- Kinds ---------------------repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr)-repPlainTV (MkC nm) = rep2 plainTVName [nm]--repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr)-repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]--repKVar :: Core TH.Name -> DsM (Core TH.Kind)-repKVar (MkC s) = rep2 varKName [s]--repKCon :: Core TH.Name -> DsM (Core TH.Kind)-repKCon (MkC s) = rep2 conKName [s]--repKTuple :: Int -> DsM (Core TH.Kind)-repKTuple i = do dflags <- getDynFlags-                 rep2 tupleKName [mkIntExprInt dflags i]--repKArrow :: DsM (Core TH.Kind)-repKArrow = rep2 arrowKName []--repKList :: DsM (Core TH.Kind)-repKList = rep2 listKName []--repKApp :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)-repKApp (MkC k1) (MkC k2) = rep2 appKName [k1, k2]--repKApps :: Core TH.Kind -> [Core TH.Kind] -> DsM (Core TH.Kind)-repKApps f []     = return f-repKApps f (k:ks) = do { f' <- repKApp f k; repKApps f' ks }--repKStar :: DsM (Core TH.Kind)-repKStar = rep2 starKName []--repKConstraint :: DsM (Core TH.Kind)-repKConstraint = rep2 constraintKName []---------------------------------------------------------------       Type family result signature--repNoSig :: DsM (Core TH.FamilyResultSig)-repNoSig = rep2 noSigName []--repKindSig :: Core TH.Kind -> DsM (Core TH.FamilyResultSig)-repKindSig (MkC ki) = rep2 kindSigName [ki]--repTyVarSig :: Core TH.TyVarBndr -> DsM (Core TH.FamilyResultSig)-repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr]---------------------------------------------------------------              Literals--repLiteral :: HsLit -> DsM (Core TH.Lit)-repLiteral (HsStringPrim _ bs)-  = do dflags   <- getDynFlags-       word8_ty <- lookupType word8TyConName-       let w8s = unpack bs-           w8s_expr = map (\w8 -> mkCoreConApps word8DataCon-                                  [mkWordLit dflags (toInteger w8)]) w8s-       rep2 stringPrimLName [mkListExpr word8_ty w8s_expr]-repLiteral lit-  = do lit' <- case lit of-                   HsIntPrim _ i    -> mk_integer i-                   HsWordPrim _ w   -> mk_integer w-                   HsInt _ i        -> mk_integer i-                   HsFloatPrim r    -> mk_rational r-                   HsDoublePrim r   -> mk_rational r-                   HsCharPrim _ c   -> mk_char c-                   _ -> return lit-       lit_expr <- dsLit lit'-       case mb_lit_name of-          Just lit_name -> rep2 lit_name [lit_expr]-          Nothing -> notHandled "Exotic literal" (ppr lit)-  where-    mb_lit_name = case lit of-                 HsInteger _ _ _  -> Just integerLName-                 HsInt     _ _    -> Just integerLName-                 HsIntPrim _ _    -> Just intPrimLName-                 HsWordPrim _ _   -> Just wordPrimLName-                 HsFloatPrim _    -> Just floatPrimLName-                 HsDoublePrim _   -> Just doublePrimLName-                 HsChar _ _       -> Just charLName-                 HsCharPrim _ _   -> Just charPrimLName-                 HsString _ _     -> Just stringLName-                 HsRat _ _        -> Just rationalLName-                 _                -> Nothing--mk_integer :: Integer -> DsM HsLit-mk_integer  i = do integer_ty <- lookupType integerTyConName-                   return $ HsInteger NoSourceText i integer_ty-mk_rational :: FractionalLit -> DsM HsLit-mk_rational r = do rat_ty <- lookupType rationalTyConName-                   return $ HsRat r rat_ty-mk_string :: FastString -> DsM HsLit-mk_string s = return $ HsString NoSourceText s--mk_char :: Char -> DsM HsLit-mk_char c = return $ HsChar NoSourceText c--repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)-repOverloadedLiteral (OverLit { ol_val = val})-  = do { lit <- mk_lit val; repLiteral lit }-        -- The type Rational will be in the environment, because-        -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,-        -- and rationalL is sucked in when any TH stuff is used--mk_lit :: OverLitVal -> DsM HsLit-mk_lit (HsIntegral _ i)   = mk_integer  i-mk_lit (HsFractional f)   = mk_rational f-mk_lit (HsIsString _ s)   = mk_string   s--repNameS :: Core String -> DsM (Core TH.Name)-repNameS (MkC name) = rep2 mkNameSName [name]----------------- Miscellaneous ---------------------repGensym :: Core String -> DsM (Core (TH.Q TH.Name))-repGensym (MkC lit_str) = rep2 newNameName [lit_str]--repBindQ :: Type -> Type        -- a and b-         -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))-repBindQ ty_a ty_b (MkC x) (MkC y)-  = rep2 bindQName [Type ty_a, Type ty_b, x, y]--repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))-repSequenceQ ty_a (MkC list)-  = rep2 sequenceQName [Type ty_a, list]--repUnboundVar :: Core TH.Name -> DsM (Core TH.ExpQ)-repUnboundVar (MkC name) = rep2 unboundVarEName [name]-------------- Lists ---------------------- turn a list of patterns into a single pattern matching a list--repList :: Name -> (a  -> DsM (Core b))-                -> [a] -> DsM (Core [b])-repList tc_name f args-  = do { args1 <- mapM f args-       ; coreList tc_name args1 }--coreList :: Name        -- Of the TyCon of the element type-         -> [Core a] -> DsM (Core [a])-coreList tc_name es-  = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }--coreList' :: Type       -- The element type-          -> [Core a] -> Core [a]-coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))--nonEmptyCoreList :: [Core a] -> Core [a]-  -- The list must be non-empty so we can get the element type-  -- Otherwise use coreList-nonEmptyCoreList []           = panic "coreList: empty argument"-nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))--coreStringLit :: String -> DsM (Core String)-coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }--------------------- Maybe ---------------------- | Construct Core expression for Nothing of a given type name-coreNothing :: Name        -- ^ Name of the TyCon of the element type-            -> DsM (Core (Maybe a))-coreNothing tc_name =-    do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) }---- | Construct Core expression for Nothing of a given type-coreNothing' :: Type       -- ^ The element type-             -> Core (Maybe a)-coreNothing' elt_ty = MkC (mkNothingExpr elt_ty)---- | Store given Core expression in a Just of a given type name-coreJust :: Name        -- ^ Name of the TyCon of the element type-         -> Core a -> DsM (Core (Maybe a))-coreJust tc_name es-  = do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) }---- | Store given Core expression in a Just of a given type-coreJust' :: Type       -- ^ The element type-          -> Core a -> Core (Maybe a)-coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es))-------------- Literals & Variables ---------------------coreIntLit :: Int -> DsM (Core Int)-coreIntLit i = do dflags <- getDynFlags-                  return (MkC (mkIntExprInt dflags i))--coreVar :: Id -> Core TH.Name   -- The Id has type Name-coreVar id = MkC (Var id)------------------- Failure ------------------------notHandledL :: SrcSpan -> String -> SDoc -> DsM a-notHandledL loc what doc-  | isGoodSrcSpan loc-  = putSrcSpanDs loc $ notHandled what doc-  | otherwise-  = notHandled what doc--notHandled :: String -> SDoc -> DsM a-notHandled what doc = failWithDs msg-  where-    msg = hang (text what <+> text "not (yet) handled by Template Haskell")-             2 doc
− src/Language/Haskell/Liquid/Desugar/DsMeta.hs-boot 
@@ -1,8 +0,0 @@-module Language.Haskell.Liquid.Desugar.DsMeta (dsBracket) where--import CoreSyn-import Language.Haskell.Liquid.Desugar.DsMonad-import HsExpr-import Name--dsBracket :: HsBracket Name -> [PendingTcSplice] -> DsM CoreExpr
− src/Language/Haskell/Liquid/Desugar/DsMonad.hs 
@@ -1,759 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---@DsMonad@: monadery used in desugaring--}--{-# LANGUAGE FlexibleInstances, FlexibleContexts, CPP #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an orphan--module Language.Haskell.Liquid.Desugar.DsMonad (-        DsM, mapM, mapAndUnzipM,-        initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs,-        foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM,-        Applicative(..),(<$>),--        duplicateLocalDs, newSysLocalDsNoLP, newSysLocalDs,-        newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId,-        newFailLocalDs, newPredVarDs,-        getSrcSpanDs, putSrcSpanDs,-        mkPrintUnqualifiedDs,-        newUnique,-        UniqSupply, newUniqueSupply,-        getGhcModeDs, dsGetFamInstEnvs,-        dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon,-        dsLookupDataCon, dsLookupConLike,--        PArrBuiltin(..),-        dsLookupDPHRdrEnv, dsLookupDPHRdrEnv_maybe,-        dsInitPArrBuiltin,--        DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,--        -- Getting and setting EvVars and term constraints in local environment-        getDictsDs, addDictsDs, getTmCsDs, addTmCsDs,--        -- Iterations for pm checking-        incrCheckPmIterDs, resetPmIterDs, dsGetCompleteMatches,--        -- Warnings and errors-        DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr,-        failWithDs, failDs, discardWarningsDs,-        askNoErrsDs,--        -- Data types-        DsMatchContext(..),-        EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,-        CanItFail(..), orFail,--        -- Levity polymorphism-        dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs-    ) where--import TcRnMonad-import FamInstEnv-import CoreSyn-import MkCore    ( unitExpr )-import CoreUtils ( exprType, isExprLevPoly )-import HsSyn-import TcIface-import TcMType ( checkForLevPolyX, formatLevPolyErr )-import LoadIface-import Finder-import PrelNames-import RdrName-import HscTypes-import Bag-import DataCon-import ConLike-import TyCon-import PmExpr-import Id-import Module-import Outputable-import SrcLoc-import Type-import UniqSupply-import Name-import NameEnv-import DynFlags-import ErrUtils-import FastString-import Maybes-import Var (EvVar)-import qualified GHC.LanguageExtensions as LangExt-import UniqFM ( lookupWithDefaultUFM )-#ifdef DETERMINISTIC_PROFILING-import CostCentreState-#endif--import Data.IORef-import Control.Monad--{--************************************************************************-*                                                                      *-                Data types for the desugarer-*                                                                      *-************************************************************************--}--data DsMatchContext-  = DsMatchContext (HsMatchContext Name) SrcSpan-  deriving ()--instance Outputable DsMatchContext where-  ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match--data EquationInfo-  = EqnInfo { eqn_pats :: [Pat Id],     -- The patterns for an eqn-              eqn_rhs  :: MatchResult } -- What to do after match--instance Outputable EquationInfo where-    ppr (EqnInfo pats _) = ppr pats--type DsWrapper = CoreExpr -> CoreExpr-idDsWrapper :: DsWrapper-idDsWrapper e = e---- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult---      \fail. wrap (case vs of { pats -> rhs fail })--- where vs are not bound by wrap----- A MatchResult is an expression with a hole in it-data MatchResult-  = MatchResult-        CanItFail       -- Tells whether the failure expression is used-        (CoreExpr -> DsM CoreExpr)-                        -- Takes a expression to plug in at the-                        -- failure point(s). The expression should-                        -- be duplicatable!--data CanItFail = CanFail | CantFail--orFail :: CanItFail -> CanItFail -> CanItFail-orFail CantFail CantFail = CantFail-orFail _        _        = CanFail--{--************************************************************************-*                                                                      *-                Monad functions-*                                                                      *-************************************************************************--}---- Compatibility functions-fixDs :: (a -> DsM a) -> DsM a-fixDs    = fixM--type DsWarning = (SrcSpan, SDoc)-        -- Not quite the same as a WarnMsg, we have an SDoc here-        -- and we'll do the print_unqual stuff later on to turn it-        -- into a Doc.---- | Run a 'DsM' action inside the 'TcM' monad.-initDsTc :: DsM a -> TcM a-initDsTc thing_inside-  = do { tcg_env  <- getGblEnv-       ; msg_var  <- getErrsVar-       ; hsc_env  <- getTopEnv-       ; envs     <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env-       ; setEnvs envs $ initDPH thing_inside-       }---- | Run a 'DsM' action inside the 'IO' monad.-initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a)-initDs hsc_env tcg_env thing_inside-  = do { msg_var <- newIORef emptyMessages-       ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env-       ; runDs hsc_env envs thing_inside-       }---- | Build a set of desugarer environments derived from a 'TcGblEnv'.-mkDsEnvsFromTcGbl :: MonadIO m-                  => HscEnv -> IORef Messages -> TcGblEnv-                  -> m (DsGblEnv, DsLclEnv)-mkDsEnvsFromTcGbl hsc_env msg_var tcg_env-  = do { pm_iter_var <- liftIO $ newIORef 0-#ifdef DETERMINISTIC_PROFILING-       ; cc_st_var   <- liftIO $ newIORef newCostCentreState-#endif-       ; let dflags   = hsc_dflags hsc_env-             this_mod = tcg_mod tcg_env-             type_env = tcg_type_env tcg_env-             rdr_env  = tcg_rdr_env tcg_env-             fam_inst_env = tcg_fam_inst_env tcg_env-             complete_matches = hptCompleteSigs hsc_env-                                ++ tcg_complete_matches tcg_env-       ; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env-#ifdef DETERMINISTIC_PROFILING-                           msg_var pm_iter_var cc_st_var complete_matches-#else-                           msg_var pm_iter_var complete_matches-#endif-       }--runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)-runDs hsc_env (ds_gbl, ds_lcl) thing_inside-  = do { res    <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl-                              (initDPH $ tryM thing_inside)-       ; msgs   <- readIORef (ds_msgs ds_gbl)-       ; let final_res-               | errorsFound dflags msgs = Nothing-               | Right r <- res          = Just r-               | otherwise               = panic "initDs"-       ; return (msgs, final_res)-       }-  where dflags = hsc_dflags hsc_env---- | Run a 'DsM' action in the context of an existing 'ModGuts'-initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)-initDsWithModGuts hsc_env guts thing_inside-  = do { pm_iter_var <- newIORef 0-#ifdef DETERMINISTIC_PROFILING-       ; cc_st_var   <- newIORef newCostCentreState-#endif-       ; msg_var <- newIORef emptyMessages-       ; let dflags   = hsc_dflags hsc_env-             type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)-             rdr_env  = mg_rdr_env guts-             fam_inst_env = mg_fam_inst_env guts-             this_mod = mg_module guts-             complete_matches = hptCompleteSigs hsc_env-                                ++ mg_complete_sigs guts--             bindsToIds (NonRec v _)   = [v]-             bindsToIds (Rec    binds) = map fst binds-             ids = concatMap bindsToIds (mg_binds guts)--             envs  = mkDsEnvs dflags this_mod rdr_env type_env-                              fam_inst_env msg_var pm_iter_var-#ifdef DETERMINISTIC_PROFILING-                              cc_st_var complete_matches-#else-                              complete_matches-#endif-       ; runDs hsc_env envs thing_inside-       }--initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a)--- Spin up a TcM context so that we can run the constraint solver--- Returns any error messages generated by the constraint solver--- and (Just res) if no error happened; Nothing if an error happened------ Simon says: I'm not very happy about this.  We spin up a complete TcM monad---             only to immediately refine it to a TcS monad.--- Better perhaps to make TcS into its own monad, rather than building on TcS--- But that may in turn interact with plugins--initTcDsForSolver thing_inside-  = do { (gbl, lcl) <- getEnvs-       ; hsc_env    <- getTopEnv--       ; let DsGblEnv { ds_mod = mod-                      , ds_fam_inst_env = fam_inst_env } = gbl--             DsLclEnv { dsl_loc = loc }                  = lcl--       ; liftIO $ initTc hsc_env HsSrcFile False mod loc $-         updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env }) $-         thing_inside }--mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv-#ifdef DETERMINISTIC_PROFILING-         -> IORef Messages -> IORef Int -> IORef CostCentreState-         -> [CompleteMatch] -> (DsGblEnv, DsLclEnv)-mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar cc_st_var-#else-         -> IORef Messages -> IORef Int -> [CompleteMatch]-         -> (DsGblEnv, DsLclEnv)-mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar-#endif-         complete_matches-  = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs",-                             if_rec_types = Just (mod, return type_env) }-        if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)-                             False -- not boot!-        real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)-        completeMatchMap = mkCompleteMatchMap complete_matches-        gbl_env = DsGblEnv { ds_mod     = mod-                           , ds_fam_inst_env = fam_inst_env-                           , ds_if_env  = (if_genv, if_lenv)-                           , ds_unqual  = mkPrintUnqualified dflags rdr_env-                           , ds_msgs    = msg_var-                           , ds_dph_env = emptyGlobalRdrEnv-                           , ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi"-                           , ds_complete_matches = completeMatchMap-#ifdef DETERMINISTIC_PROFILING-                           , ds_cc_st   = cc_st_var-#endif-                           }-        lcl_env = DsLclEnv { dsl_meta    = emptyNameEnv-                           , dsl_loc     = real_span-                           , dsl_dicts   = emptyBag-                           , dsl_tm_cs   = emptyBag-                           , dsl_pm_iter = pmvar-                           }-    in (gbl_env, lcl_env)---{--************************************************************************-*                                                                      *-                Operations in the monad-*                                                                      *-************************************************************************--And all this mysterious stuff is so we can occasionally reach out and-grab one or more names.  @newLocalDs@ isn't exported---exported-functions are defined with it.  The difference in name-strings makes-it easier to read debugging output.--Note [Levity polymorphism checking]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-According to the Levity Polymorphism paper-<http://cs.brynmawr.edu/~rae/papers/2017/levity/levity.pdf>, levity-polymorphism is forbidden in precisely two places: in the type of a bound-term-level argument and in the type of an argument to a function. The paper-explains it more fully, but briefly: expressions in these contexts need to be-stored in registers, and it's hard (read, impossible) to store something-that's levity polymorphic.--We cannot check for bad levity polymorphism conveniently in the type checker,-because we can't tell, a priori, which levity metavariables will be solved.-At one point, I (Richard) thought we could check in the zonker, but it's hard-to know where precisely are the abstracted variables and the arguments. So-we check in the desugarer, the only place where we can see the Core code and-still report respectable syntax to the user. This covers the vast majority-of cases; see calls to DsMonad.dsNoLevPoly and friends.--Levity polymorphism is also prohibited in the types of binders, and the-desugarer checks for this in GHC-generated Ids. (The zonker handles-the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP.-The newSysLocalDs variant is used in the vast majority of cases where-the binder is obviously not levity polymorphic, omitting the check.-It would be nice to ASSERT that there is no levity polymorphism here,-but we can't, because of the fixM in DsArrows. It's all OK, though:-Core Lint will catch an error here.--However, the desugarer is the wrong place for certain checks. In particular,-the desugarer can't report a sensible error message if an HsWrapper is malformed.-After all, GHC itself produced the HsWrapper. So we store some message text-in the appropriate HsWrappers (e.g. WpFun) that we can print out in the-desugarer.--There are a few more checks in places where Core is generated outside the-desugarer. For example, in datatype and class declarations, where levity-polymorphism is checked for during validity checking. It would be nice to-have one central place for all this, but that doesn't seem possible while-still reporting nice error messages.---}---- Make a new Id with the same print name, but different type, and new unique-newUniqueId :: Id -> Type -> DsM Id-newUniqueId id = mk_local (occNameFS (nameOccName (idName id)))--duplicateLocalDs :: Id -> DsM Id-duplicateLocalDs old_local-  = do  { uniq <- newUnique-        ; return (setIdUnique old_local uniq) }--newPredVarDs :: PredType -> DsM Var-newPredVarDs pred- = newSysLocalDs pred--newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id-newSysLocalDsNoLP  = mk_local (fsLit "ds")---- this variant should be used when the caller can be sure that the variable type--- is not levity-polymorphic. It is necessary when the type is knot-tied because--- of the fixM used in DsArrows. See Note [Levity polymorphism checking]-newSysLocalDs = mkSysLocalOrCoVarM (fsLit "ds")-newFailLocalDs = mkSysLocalOrCoVarM (fsLit "fail")-  -- the fail variable is used only in a situation where we can tell that-  -- levity-polymorphism is impossible.--newSysLocalsDsNoLP, newSysLocalsDs :: [Type] -> DsM [Id]-newSysLocalsDsNoLP = mapM newSysLocalDsNoLP-newSysLocalsDs = mapM newSysLocalDs--mk_local :: FastString -> Type -> DsM Id-mk_local fs ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+>-                                      ppr ty)  -- could improve the msg with another-                                               -- parameter indicating context-                    ; mkSysLocalOrCoVarM fs ty }--{--We can also reach out and either set/grab location information from-the @SrcSpan@ being carried around.--}--getGhcModeDs :: DsM GhcMode-getGhcModeDs =  getDynFlags >>= return . ghcMode---- | Get in-scope type constraints (pm check)-getDictsDs :: DsM (Bag EvVar)-getDictsDs = do { env <- getLclEnv; return (dsl_dicts env) }---- | Add in-scope type constraints (pm check)-addDictsDs :: Bag EvVar -> DsM a -> DsM a-addDictsDs ev_vars-  = updLclEnv (\env -> env { dsl_dicts = unionBags ev_vars (dsl_dicts env) })---- | Get in-scope term constraints (pm check)-getTmCsDs :: DsM (Bag SimpleEq)-getTmCsDs = do { env <- getLclEnv; return (dsl_tm_cs env) }---- | Add in-scope term constraints (pm check)-addTmCsDs :: Bag SimpleEq -> DsM a -> DsM a-addTmCsDs tm_cs-  = updLclEnv (\env -> env { dsl_tm_cs = unionBags tm_cs (dsl_tm_cs env) })---- | Increase the counter for elapsed pattern match check iterations.--- If the current counter is already over the limit, fail-incrCheckPmIterDs :: DsM Int-incrCheckPmIterDs = do-  env <- getLclEnv-  cnt <- readTcRef (dsl_pm_iter env)-  max_iters <- maxPmCheckIterations <$> getDynFlags-  if cnt >= max_iters-    then failM-    else updTcRef (dsl_pm_iter env) (+1)-  return cnt---- | Reset the counter for pattern match check iterations to zero-resetPmIterDs :: DsM ()-resetPmIterDs = do { env <- getLclEnv; writeTcRef (dsl_pm_iter env) 0 }--getSrcSpanDs :: DsM SrcSpan-getSrcSpanDs = do { env <- getLclEnv-                  ; return (RealSrcSpan (dsl_loc env)) }--putSrcSpanDs :: SrcSpan -> DsM a -> DsM a-putSrcSpanDs (UnhelpfulSpan {}) thing_inside-  = thing_inside-putSrcSpanDs (RealSrcSpan real_span) thing_inside-  = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside---- | Emit a warning for the current source location--- NB: Warns whether or not -Wxyz is set-warnDs :: WarnReason -> SDoc -> DsM ()-warnDs reason warn-  = do { env <- getGblEnv-       ; loc <- getSrcSpanDs-       ; dflags <- getDynFlags-       ; let msg = makeIntoWarning reason $-                   mkWarnMsg dflags loc (ds_unqual env) warn-       ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }---- | Emit a warning only if the correct WarnReason is set in the DynFlags-warnIfSetDs :: WarningFlag -> SDoc -> DsM ()-warnIfSetDs flag warn-  = whenWOptM flag $-    warnDs (Reason flag) warn--errDs :: SDoc -> DsM ()-errDs err-  = do  { env <- getGblEnv-        ; loc <- getSrcSpanDs-        ; dflags <- getDynFlags-        ; let msg = mkErrMsg dflags loc (ds_unqual env) err-        ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) }---- | Issue an error, but return the expression for (), so that we can continue--- reporting errors.-errDsCoreExpr :: SDoc -> DsM CoreExpr-errDsCoreExpr err-  = do { errDs err-       ; return unitExpr }--failWithDs :: SDoc -> DsM a-failWithDs err-  = do  { errDs err-        ; failM }--failDs :: DsM a-failDs = failM---- (askNoErrsDs m) runs m--- If m fails,---    then (askNoErrsDs m) fails--- If m succeeds with result r,---    then (askNoErrsDs m) succeeds with result (r, b),---         where b is True iff m generated no errors--- Regardless of success or failure,---   propagate any errors/warnings generated by m------ c.f. TcRnMonad.askNoErrs-askNoErrsDs :: DsM a -> DsM (a, Bool)-askNoErrsDs thing_inside- = do { errs_var <- newMutVar emptyMessages-      ; env <- getGblEnv-      ; mb_res <- tryM $  -- Be careful to catch exceptions-                          -- so that we propagate errors correctly-                          -- (Trac #13642)-                  setGblEnv (env { ds_msgs = errs_var }) $-                  thing_inside--      -- Propagate errors-      ; msgs@(warns, errs) <- readMutVar errs_var-      ; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs))--      -- And return-      ; case mb_res of-           Left _    -> failM-           Right res -> do { dflags <- getDynFlags-                           ; let errs_found = errorsFound dflags msgs-                           ; return (res, not errs_found) } }--mkPrintUnqualifiedDs :: DsM PrintUnqualified-mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv--instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where-    lookupThing = dsLookupGlobal---- | Attempt to load the given module and return its exported entities if--- successful.-dsLoadModule :: SDoc -> Module -> DsM GlobalRdrEnv-dsLoadModule doc mod-  = do { env    <- getGblEnv-       ; setEnvs (ds_if_env env) $ do-       { iface <- loadInterface doc mod ImportBySystem-       ; case iface of-           Failed err      -> pprPanic "DsMonad.dsLoadModule: failed to load" (err $$ doc)-           Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface-       } }-  where-    prov     = Just (ImpSpec { is_decl = imp_spec, is_item = ImpAll })-    imp_spec = ImpDeclSpec { is_mod = name, is_qual = True,-                             is_dloc = wiredInSrcSpan, is_as = name }-    name = moduleName mod--dsLookupGlobal :: Name -> DsM TyThing--- Very like TcEnv.tcLookupGlobal-dsLookupGlobal name-  = do  { env <- getGblEnv-        ; setEnvs (ds_if_env env)-                  (tcIfaceGlobal name) }--dsLookupGlobalId :: Name -> DsM Id-dsLookupGlobalId name-  = tyThingId <$> dsLookupGlobal name--dsLookupTyCon :: Name -> DsM TyCon-dsLookupTyCon name-  = tyThingTyCon <$> dsLookupGlobal name--dsLookupDataCon :: Name -> DsM DataCon-dsLookupDataCon name-  = tyThingDataCon <$> dsLookupGlobal name--dsLookupConLike :: Name -> DsM ConLike-dsLookupConLike name-  = tyThingConLike <$> dsLookupGlobal name---dsGetFamInstEnvs :: DsM FamInstEnvs--- Gets both the external-package inst-env--- and the home-pkg inst env (includes module being compiled)-dsGetFamInstEnvs-  = do { eps <- getEps; env <- getGblEnv-       ; return (eps_fam_inst_env eps, ds_fam_inst_env env) }--dsGetMetaEnv :: DsM (NameEnv DsMetaVal)-dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }---- | The @COMPLETE@ pragams provided by the user for a given `TyCon`.-dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]-dsGetCompleteMatches tc = do-  eps <- getEps-  env <- getGblEnv-  let lookup_completes ufm = lookupWithDefaultUFM ufm [] tc-      eps_matches_list = lookup_completes $ eps_complete_matches eps-      env_matches_list = lookup_completes $ ds_complete_matches env-  return $ eps_matches_list ++ env_matches_list--dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)-dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }--dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a-dsExtendMetaEnv menv thing_inside-  = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside--discardWarningsDs :: DsM a -> DsM a--- Ignore warnings inside the thing inside;--- used to ignore inaccessable cases etc. inside generated code-discardWarningsDs thing_inside-  = do  { env <- getGblEnv-        ; old_msgs <- readTcRef (ds_msgs env)--        ; result <- thing_inside--        -- Revert messages to old_msgs-        ; writeTcRef (ds_msgs env) old_msgs--        ; return result }---- | Fail with an error message if the type is levity polymorphic.-dsNoLevPoly :: Type -> SDoc -> DsM ()--- See Note [Levity polymorphism checking]-dsNoLevPoly ty doc = checkForLevPolyX errDs doc ty---- | Check an expression for levity polymorphism, failing if it is--- levity polymorphic.-dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM ()--- See Note [Levity polymorphism checking]-dsNoLevPolyExpr e doc-  | isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc)-  | otherwise       = return ()---- | Runs the thing_inside. If there are no errors, then returns the expr--- given. Otherwise, returns unitExpr. This is useful for doing a bunch--- of levity polymorphism checks and then avoiding making a core App.--- (If we make a core App on a levity polymorphic argument, detecting how--- to handle the let/app invariant might call isUnliftedType, which panics--- on a levity polymorphic type.)--- See #12709 for an example of why this machinery is necessary.-dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr-dsWhenNoErrs thing_inside mk_expr-  = do { (result, no_errs) <- askNoErrsDs thing_inside-       ; return $ if no_errs-                  then mk_expr result-                  else unitExpr }-------------------------------------------------------------------------------                  Data Parallel Haskell------------------------------------------------------------------------------- | Run a 'DsM' with DPH things in scope if necessary.-initDPH :: DsM a -> DsM a-initDPH = loadDAP . initDPHBuiltins---- | Extend the global environment with a 'GlobalRdrEnv' containing the exported--- entities of,------   * 'Data.Array.Parallel'      iff '-XParallelArrays' specified (see also 'checkLoadDAP').---   * 'Data.Array.Parallel.Prim' iff '-fvectorise' specified.-loadDAP :: DsM a -> DsM a-loadDAP thing_inside-  = do { dapEnv  <- loadOneModule dATA_ARRAY_PARALLEL_NAME      checkLoadDAP          paErr-       ; dappEnv <- loadOneModule dATA_ARRAY_PARALLEL_PRIM_NAME (goptM Opt_Vectorise) veErr-       ; updGblEnv (\env -> env {ds_dph_env = dapEnv `plusOccEnv` dappEnv }) thing_inside-       }-  where-    loadOneModule :: ModuleName           -- the module to load-                  -> DsM Bool             -- under which condition-                  -> MsgDoc               -- error message if module not found-                  -> DsM GlobalRdrEnv     -- empty if condition 'False'-    loadOneModule modname check err-      = do { doLoad <- check-           ; if not doLoad-             then return emptyGlobalRdrEnv-             else do {-           ; hsc_env <- getTopEnv-           ; result <- liftIO $ findImportedModule hsc_env modname Nothing-           ; case result of-               Found _ mod -> dsLoadModule err mod-               _           -> pprPgmError "Unable to use Data Parallel Haskell (DPH):" err-           } }--    paErr       = text "To use ParallelArrays," <+> specBackend $$ hint1 $$ hint2-    veErr       = text "To use -fvectorise," <+> specBackend $$ hint1 $$ hint2-    specBackend = text "you must specify a DPH backend package"-    hint1       = text "Look for packages named 'dph-lifted-*' with 'ghc-pkg'"-    hint2       = text "You may need to install them with 'cabal install dph-examples'"---- | If '-XParallelArrays' given, we populate the builtin table for desugaring--- those.-initDPHBuiltins :: DsM a -> DsM a-initDPHBuiltins thing_inside-  = do { doInitBuiltins <- checkLoadDAP-       ; if doInitBuiltins-         then dsInitPArrBuiltin thing_inside-         else thing_inside-       }--checkLoadDAP :: DsM Bool-checkLoadDAP-  = do { paEnabled <- xoptM LangExt.ParallelArrays-       ; mod <- getModule-         -- do not load 'Data.Array.Parallel' iff compiling 'base:GHC.PArr' or a-         -- module called 'dATA_ARRAY_PARALLEL_NAME'; see also the comments at the top-         -- of 'base:GHC.PArr' and 'Data.Array.Parallel' in the DPH libraries-       ; return $ paEnabled &&-                  mod /= gHC_PARR' &&-                  moduleName mod /= dATA_ARRAY_PARALLEL_NAME-       }---- | Populate 'ds_parr_bi' from 'ds_dph_env'.----dsInitPArrBuiltin :: DsM a -> DsM a-dsInitPArrBuiltin thing_inside-  = do { lengthPVar         <- externalVar (fsLit "lengthP")-       ; replicatePVar      <- externalVar (fsLit "replicateP")-       ; singletonPVar      <- externalVar (fsLit "singletonP")-       ; mapPVar            <- externalVar (fsLit "mapP")-       ; filterPVar         <- externalVar (fsLit "filterP")-       ; zipPVar            <- externalVar (fsLit "zipP")-       ; crossMapPVar       <- externalVar (fsLit "crossMapP")-       ; indexPVar          <- externalVar (fsLit "!:")-       ; emptyPVar          <- externalVar (fsLit "emptyP")-       ; appPVar            <- externalVar (fsLit "+:+")-       -- ; enumFromToPVar     <- externalVar (fsLit "enumFromToP")-       -- ; enumFromThenToPVar <- externalVar (fsLit "enumFromThenToP")-       ; enumFromToPVar     <- return arithErr-       ; enumFromThenToPVar <- return arithErr--       ; updGblEnv (\env -> env {ds_parr_bi = PArrBuiltin-                                              { lengthPVar         = lengthPVar-                                              , replicatePVar      = replicatePVar-                                              , singletonPVar      = singletonPVar-                                              , mapPVar            = mapPVar-                                              , filterPVar         = filterPVar-                                              , zipPVar            = zipPVar-                                              , crossMapPVar       = crossMapPVar-                                              , indexPVar          = indexPVar-                                              , emptyPVar          = emptyPVar-                                              , appPVar            = appPVar-                                              , enumFromToPVar     = enumFromToPVar-                                              , enumFromThenToPVar = enumFromThenToPVar-                                              } })-                   thing_inside-       }-  where-    externalVar :: FastString -> DsM Var-    externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId--    arithErr = panic "Arithmetic sequences have to wait until we support type classes"---- |Get a name from "Data.Array.Parallel" for the desugarer, from the--- 'ds_parr_bi' component of the global desugerar environment.----dsDPHBuiltin :: (PArrBuiltin -> a) -> DsM a-dsDPHBuiltin sel = (sel . ds_parr_bi) <$> getGblEnv---- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim'.---  Panic if there isn't one, or if it is defined multiple times.-dsLookupDPHRdrEnv :: OccName -> DsM Name-dsLookupDPHRdrEnv occ-  = liftM (fromMaybe (pprPanic nameNotFound (ppr occ)))-  $ dsLookupDPHRdrEnv_maybe occ-  where nameNotFound  = "Name not found in 'Data.Array.Parallel' or 'Data.Array.Parallel.Prim':"---- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim',---  returning `Nothing` if it's not defined. Panic if it's defined multiple times.-dsLookupDPHRdrEnv_maybe :: OccName -> DsM (Maybe Name)-dsLookupDPHRdrEnv_maybe occ-  = do { env <- ds_dph_env <$> getGblEnv-       ; let gres = lookupGlobalRdrEnv env occ-       ; case gres of-           []    -> return $ Nothing-           [gre] -> return $ Just $ gre_name gre-           _     -> pprPanic multipleNames (ppr occ)-       }-  where multipleNames = "Multiple definitions in 'Data.Array.Parallel' and 'Data.Array.Parallel.Prim':"
− src/Language/Haskell/Liquid/Desugar/DsUtils.hs 
@@ -1,1004 +0,0 @@-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-Utilities for desugaring
-
-This module exports some utility functions of no great interest.
--}
-
-{-# LANGUAGE CPP #-}
-
--- | Utility functions for constructing Core syntax, principally for desugaring
-module Language.Haskell.Liquid.Desugar.DsUtils (
-        EquationInfo(..),
-        firstPat, shiftEqns,
-
-        MatchResult(..), CanItFail(..), CaseAlt(..),
-        cantFailMatchResult, alwaysFailMatchResult,
-        extractMatchResult, combineMatchResults,
-        adjustMatchResult,  adjustMatchResultDs,
-        mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
-        matchCanFail, mkEvalMatchResult,
-        mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,
-        wrapBind, wrapBinds,
-
-        mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs,
-
-        seqVar,
-
-        -- LHs tuples
-        mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat,
-        mkBigLHsVarTupId, mkBigLHsTupId, mkBigLHsVarPatTupId, mkBigLHsPatTupId,
-
-        mkSelectorBinds,
-
-        selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
-        mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang
-    ) where
-
-import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.Match  ( matchSimply )
-import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr ( dsLExpr )
-
-import HsSyn
-import TcHsSyn
-import TcType( tcSplitTyConApp )
-import CoreSyn
-import Language.Haskell.Liquid.Desugar.DsMonad
-
-import CoreUtils
-import MkCore
-import MkId
-import Id
-import Literal
-import TyCon
-import DataCon
-import PatSyn
-import Type
-import Coercion
-import TysPrim
-import TysWiredIn
-import BasicTypes
-import ConLike
-import UniqSet
-import UniqSupply
-import Module
-import PrelNames
-import Name( isInternalName )
-import Outputable
-import SrcLoc
-import Util
-import DynFlags
-import FastString
-import qualified GHC.LanguageExtensions as LangExt
-
-import TcEvidence
-
-import Control.Monad    ( zipWithM )
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{ Selecting match variables}
-*                                                                      *
-************************************************************************
-
-We're about to match against some patterns.  We want to make some
-@Ids@ to use as match variables.  If a pattern has an @Id@ readily at
-hand, which should indeed be bound to the pattern as a whole, then use it;
-otherwise, make one up.
--}
-
-selectSimpleMatchVarL :: LPat Id -> DsM Id
-selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
-
--- (selectMatchVars ps tys) chooses variables of type tys
--- to use for matching ps against.  If the pattern is a variable,
--- we try to use that, to save inventing lots of fresh variables.
---
--- OLD, but interesting note:
---    But even if it is a variable, its type might not match.  Consider
---      data T a where
---        T1 :: Int -> T Int
---        T2 :: a   -> T a
---
---      f :: T a -> a -> Int
---      f (T1 i) (x::Int) = x
---      f (T2 i) (y::a)   = 0
---    Then we must not choose (x::Int) as the matching variable!
--- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat
-
-selectMatchVars :: [Pat Id] -> DsM [Id]
-selectMatchVars ps = mapM selectMatchVar ps
-
-selectMatchVar :: Pat Id -> DsM Id
-selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
-selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
-selectMatchVar (ParPat pat)  = selectMatchVar (unLoc pat)
-selectMatchVar (VarPat var)  = return (localiseId (unLoc var))
-                                  -- Note [Localise pattern binders]
-selectMatchVar (AsPat var _) = return (unLoc var)
-selectMatchVar other_pat     = newSysLocalDsNoLP (hsPatType other_pat)
-                                  -- OK, better make up one...
-
-{-
-Note [Localise pattern binders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider     module M where
-               [Just a] = e
-After renaming it looks like
-             module M where
-               [Just M.a] = e
-
-We don't generalise, since it's a pattern binding, monomorphic, etc,
-so after desugaring we may get something like
-             M.a = case e of (v:_) ->
-                   case v of Just M.a -> M.a
-Notice the "M.a" in the pattern; after all, it was in the original
-pattern.  However, after optimisation those pattern binders can become
-let-binders, and then end up floated to top level.  They have a
-different *unique* by then (the simplifier is good about maintaining
-proper scoping), but it's BAD to have two top-level bindings with the
-External Name M.a, because that turns into two linker symbols for M.a.
-It's quite rare for this to actually *happen* -- the only case I know
-of is tc003 compiled with the 'hpc' way -- but that only makes it
-all the more annoying.
-
-To avoid this, we craftily call 'localiseId' in the desugarer, which
-simply turns the External Name for the Id into an Internal one, but
-doesn't change the unique.  So the desugarer produces this:
-             M.a{r8} = case e of (v:_) ->
-                       case v of Just a{r8} -> M.a{r8}
-The unique is still 'r8', but the binding site in the pattern
-is now an Internal Name.  Now the simplifier's usual mechanisms
-will propagate that Name to all the occurrence sites, as well as
-un-shadowing it, so we'll get
-             M.a{r8} = case e of (v:_) ->
-                       case v of Just a{s77} -> a{s77}
-In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr
-runs on the output of the desugarer, so all is well by the end of
-the desugaring pass.
-
-
-************************************************************************
-*                                                                      *
-* type synonym EquationInfo and access functions for its pieces        *
-*                                                                      *
-************************************************************************
-\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
-
-The ``equation info'' used by @match@ is relatively complicated and
-worthy of a type synonym and a few handy functions.
--}
-
-firstPat :: EquationInfo -> Pat Id
-firstPat eqn = head (eqn_pats eqn)
-
-shiftEqns :: [EquationInfo] -> [EquationInfo]
--- Drop the first pattern in each equation
-shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
-
--- Functions on MatchResults
-
-matchCanFail :: MatchResult -> Bool
-matchCanFail (MatchResult CanFail _)  = True
-matchCanFail (MatchResult CantFail _) = False
-
-alwaysFailMatchResult :: MatchResult
-alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail)
-
-cantFailMatchResult :: CoreExpr -> MatchResult
-cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr)
-
-extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
-extractMatchResult (MatchResult CantFail match_fn) _
-  = match_fn (error "It can't fail!")
-
-extractMatchResult (MatchResult CanFail match_fn) fail_expr = do
-    (fail_bind, if_it_fails) <- mkFailurePair fail_expr
-    body <- match_fn if_it_fails
-    return (mkCoreLet fail_bind body)
-
-
-combineMatchResults :: MatchResult -> MatchResult -> MatchResult
-combineMatchResults (MatchResult CanFail      body_fn1)
-                    (MatchResult can_it_fail2 body_fn2)
-  = MatchResult can_it_fail2 body_fn
-  where
-    body_fn fail = do body2 <- body_fn2 fail
-                      (fail_bind, duplicatable_expr) <- mkFailurePair body2
-                      body1 <- body_fn1 duplicatable_expr
-                      return (Let fail_bind body1)
-
-combineMatchResults match_result1@(MatchResult CantFail _) _
-  = match_result1
-
-adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult
-adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
-  = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail)
-
-adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
-adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
-  = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail)
-
-wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
-wrapBinds [] e = e
-wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
-
-wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
-wrapBind new old body   -- NB: this function must deal with term
-  | new==old    = body  -- variables, type variables or coercion variables
-  | otherwise   = Let (NonRec new (varToCoreExpr old)) body
-
-seqVar :: Var -> CoreExpr -> CoreExpr
-seqVar var body = Case (Var var) var (exprType body)
-                        [(DEFAULT, [], body)]
-
-mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
-mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
-
--- (mkViewMatchResult var' viewExpr mr) makes the expression
--- let var' = viewExpr in mr
-mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult
-mkViewMatchResult var' viewExpr =
-    adjustMatchResult (mkCoreLet (NonRec var' viewExpr))
-
-mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
-mkEvalMatchResult var ty
-  = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])
-
-mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
-mkGuardedMatchResult pred_expr (MatchResult _ body_fn)
-  = MatchResult CanFail (\fail -> do body <- body_fn fail
-                                     return (mkIfThenElse pred_expr body fail))
-
-mkCoPrimCaseMatchResult :: Id                        -- Scrutinee
-                        -> Type                      -- Type of the case
-                        -> [(Literal, MatchResult)]  -- Alternatives
-                        -> MatchResult               -- Literals are all unlifted
-mkCoPrimCaseMatchResult var ty match_alts
-  = MatchResult CanFail mk_case
-  where
-    mk_case fail = do
-        alts <- mapM (mk_alt fail) sorted_alts
-        return (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
-
-    sorted_alts = sortWith fst match_alts       -- Right order for a Case
-    mk_alt fail (lit, MatchResult _ body_fn)
-       = do body <- body_fn fail
-            return (LitAlt lit, [], body)
-
-data CaseAlt a = MkCaseAlt{ alt_pat :: a,
-                            alt_bndrs :: [Var],
-                            alt_wrapper :: HsWrapper,
-                            alt_result :: MatchResult }
-
-mkCoAlgCaseMatchResult
-  :: DynFlags
-  -> Id                 -- Scrutinee
-  -> Type               -- Type of exp
-  -> [CaseAlt DataCon]  -- Alternatives (bndrs *include* tyvars, dicts)
-  -> MatchResult
-mkCoAlgCaseMatchResult dflags var ty match_alts
-  | isNewtype  -- Newtype case; use a let
-  = mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
-
-  | isPArrFakeAlts match_alts
-  = MatchResult CanFail $ mkPArrCase dflags var ty (sort_alts match_alts)
-  | otherwise
-  = mkDataConCase var ty match_alts
-  where
-    isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1))
-
-        -- [Interesting: because of GADTs, we can't rely on the type of
-        --  the scrutinised Id to be sufficiently refined to have a TyCon in it]
-
-    alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 }
-      = head match_alts
-    -- Stuff for newtype
-    arg_id1       = head arg_ids1
-    var_ty        = idType var
-    (tc, ty_args) = tcSplitTyConApp var_ty      -- Don't look through newtypes
-                                                -- (not that splitTyConApp does, these days)
-    newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
-
-        --- Stuff for parallel arrays
-        --
-        -- Concerning `isPArrFakeAlts':
-        --
-        --  * it is *not* sufficient to just check the type of the type
-        --   constructor, as we have to be careful not to confuse the real
-        --   representation of parallel arrays with the fake constructors;
-        --   moreover, a list of alternatives must not mix fake and real
-        --   constructors (this is checked earlier on)
-        --
-        -- FIXME: We actually go through the whole list and make sure that
-        --        either all or none of the constructors are fake parallel
-        --        array constructors.  This is to spot equations that mix fake
-        --        constructors with the real representation defined in
-        --        `PrelPArr'.  It would be nicer to spot this situation
-        --        earlier and raise a proper error message, but it can really
-        --        only happen in `PrelPArr' anyway.
-        --
-
-    isPArrFakeAlts :: [CaseAlt DataCon] -> Bool
-    isPArrFakeAlts [alt] = isPArrFakeCon (alt_pat alt)
-    isPArrFakeAlts (alt:alts) =
-      case (isPArrFakeCon (alt_pat alt), isPArrFakeAlts alts) of
-        (True , True ) -> True
-        (False, False) -> False
-        _              -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns"
-    isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"
-
-mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult
-mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt
-
-sort_alts :: [CaseAlt DataCon] -> [CaseAlt DataCon]
-sort_alts = sortWith (dataConTag . alt_pat)
-
-mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr
-mkPatSynCase var ty alt fail = do
-    matcher <- dsLExpr $ mkLHsWrap wrapper $
-                         nlHsTyApp matcher [getRuntimeRep ty, ty]
-    let MatchResult _ mkCont = match_result
-    cont <- mkCoreLams bndrs <$> mkCont fail
-    return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
-  where
-    MkCaseAlt{ alt_pat = psyn,
-               alt_bndrs = bndrs,
-               alt_wrapper = wrapper,
-               alt_result = match_result} = alt
-    (matcher, needs_void_lam) = patSynMatcher psyn
-
-    -- See Note [Matchers and builders for pattern synonyms] in PatSyns
-    -- on these extra Void# arguments
-    ensure_unstrict cont | needs_void_lam = Lam voidArgId cont
-                         | otherwise      = cont
-
-mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult
-mkDataConCase _   _  []            = panic "mkDataConCase: no alternatives"
-mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case
-  where
-    con1          = alt_pat alt1
-    tycon         = dataConTyCon con1
-    data_cons     = tyConDataCons tycon
-    match_results = map alt_result alts
-
-    sorted_alts :: [CaseAlt DataCon]
-    sorted_alts  = sort_alts alts
-
-    var_ty       = idType var
-    (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes
-                                          -- (not that splitTyConApp does, these days)
-
-    mk_case :: CoreExpr -> DsM CoreExpr
-    mk_case fail = do
-        alts <- mapM (mk_alt fail) sorted_alts
-        return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts)
-
-    mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt
-    mk_alt fail MkCaseAlt{ alt_pat = con,
-                           alt_bndrs = args,
-                           alt_result = MatchResult _ body_fn }
-      = do { body <- body_fn fail
-           ; case dataConBoxer con of {
-                Nothing -> return (DataAlt con, args, body) ;
-                Just (DCB boxer) ->
-        do { us <- newUniqueSupply
-           ; let (rep_ids, binds) = initUs_ us (boxer ty_args args)
-           ; return (DataAlt con, rep_ids, mkLets binds body) } } }
-
-    mk_default :: CoreExpr -> [CoreAlt]
-    mk_default fail | exhaustive_case = []
-                    | otherwise       = [(DEFAULT, [], fail)]
-
-    fail_flag :: CanItFail
-    fail_flag | exhaustive_case
-              = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
-              | otherwise
-              = CanFail
-
-    mentioned_constructors = mkUniqSet $ map alt_pat alts
-    un_mentioned_constructors
-        = mkUniqSet data_cons `minusUniqSet` mentioned_constructors
-    exhaustive_case = isEmptyUniqSet un_mentioned_constructors
-
---- Stuff for parallel arrays
---
---  * the following is to desugar cases over fake constructors for
---   parallel arrays, which are introduced by `tidy1' in the `PArrPat'
---   case
---
-mkPArrCase :: DynFlags -> Id -> Type -> [CaseAlt DataCon] -> CoreExpr -> DsM CoreExpr
-mkPArrCase dflags var ty sorted_alts fail = do
-    lengthP <- dsDPHBuiltin lengthPVar
-    alt <- unboxAlt
-    return (mkWildCase (len lengthP) intTy ty [alt])
-  where
-    elemTy      = case splitTyConApp (idType var) of
-        (_, [elemTy]) -> elemTy
-        _             -> panic panicMsg
-    panicMsg    = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
-    len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
-    --
-    unboxAlt = do
-        l      <- newSysLocalDs intPrimTy
-        indexP <- dsDPHBuiltin indexPVar
-        alts   <- mapM (mkAlt indexP) sorted_alts
-        return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts))
-      where
-        dft  = (DEFAULT, [], fail)
-
-    --
-    -- each alternative matches one array length (corresponding to one
-    -- fake array constructor), so the match is on a literal; each
-    -- alternative's body is extended by a local binding for each
-    -- constructor argument, which are bound to array elements starting
-    -- with the first
-    --
-    mkAlt indexP alt@MkCaseAlt{alt_result = MatchResult _ bodyFun} = do
-        body <- bodyFun fail
-        return (LitAlt lit, [], mkCoreLets binds body)
-      where
-        lit   = MachInt $ toInteger (dataConSourceArity (alt_pat alt))
-        binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] (alt_bndrs alt)]
-        --
-        indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr dflags i]
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Desugarer's versions of some Core functions}
-*                                                                      *
-************************************************************************
--}
-
-mkErrorAppDs :: Id              -- The error function
-             -> Type            -- Type to which it should be applied
-             -> SDoc            -- The error message string to pass
-             -> DsM CoreExpr
-
-mkErrorAppDs err_id ty msg = do
-    src_loc <- getSrcSpanDs
-    dflags <- getDynFlags
-    let
-        full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])
-        core_msg = Lit (mkMachString full_msg)
-        -- mkMachString returns a result of type String#
-    return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg])
-
-{-
-'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'.
-
-Note [Desugaring seq (1)]  cf Trac #1031
-~~~~~~~~~~~~~~~~~~~~~~~~~
-   f x y = x `seq` (y `seq` (# x,y #))
-
-The [CoreSyn let/app invariant] means that, other things being equal, because
-the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:
-
-   f x y = case (y `seq` (# x,y #)) of v -> x `seq` v
-
-But that is bad for two reasons:
-  (a) we now evaluate y before x, and
-  (b) we can't bind v to an unboxed pair
-
-Seq is very, very special!  So we recognise it right here, and desugar to
-        case x of _ -> case y of _ -> (# x,y #)
-
-Note [Desugaring seq (2)]  cf Trac #2273
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   let chp = case b of { True -> fst x; False -> 0 }
-   in chp `seq` ...chp...
-Here the seq is designed to plug the space leak of retaining (snd x)
-for too long.
-
-If we rely on the ordinary inlining of seq, we'll get
-   let chp = case b of { True -> fst x; False -> 0 }
-   case chp of _ { I# -> ...chp... }
-
-But since chp is cheap, and the case is an alluring contet, we'll
-inline chp into the case scrutinee.  Now there is only one use of chp,
-so we'll inline a second copy.  Alas, we've now ruined the purpose of
-the seq, by re-introducing the space leak:
-    case (case b of {True -> fst x; False -> 0}) of
-      I# _ -> ...case b of {True -> fst x; False -> 0}...
-
-We can try to avoid doing this by ensuring that the binder-swap in the
-case happens, so we get his at an early stage:
-   case chp of chp2 { I# -> ...chp2... }
-But this is fragile.  The real culprit is the source program.  Perhaps we
-should have said explicitly
-   let !chp2 = chp in ...chp2...
-
-But that's painful.  So the code here does a little hack to make seq
-more robust: a saturated application of 'seq' is turned *directly* into
-the case expression, thus:
-   x  `seq` e2 ==> case x of x -> e2    -- Note shadowing!
-   e1 `seq` e2 ==> case x of _ -> e2
-
-So we desugar our example to:
-   let chp = case b of { True -> fst x; False -> 0 }
-   case chp of chp { I# -> ...chp... }
-And now all is well.
-
-The reason it's a hack is because if you define mySeq=seq, the hack
-won't work on mySeq.
-
-Note [Desugaring seq (3)] cf Trac #2409
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The isLocalId ensures that we don't turn
-        True `seq` e
-into
-        case True of True { ... }
-which stupidly tries to bind the datacon 'True'.
--}
-
--- NB: Make sure the argument is not levity polymorphic
-mkCoreAppDs  :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
-mkCoreAppDs _ (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
-  | f `hasKey` seqIdKey            -- Note [Desugaring seq (1), (2)]
-  = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]
-  where
-    case_bndr = case arg1 of
-                   Var v1 | isInternalName (idName v1)
-                          -> v1        -- Note [Desugaring seq (2) and (3)]
-                   _      -> mkWildValBinder ty1
-
-mkCoreAppDs s fun arg = mkCoreApp s fun arg  -- The rest is done in MkCore
-
--- NB: No argument can be levity polymorphic
-mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
-mkCoreAppsDs s fun args = foldl (mkCoreAppDs s) fun args
-
-mkCastDs :: CoreExpr -> Coercion -> CoreExpr
--- We define a desugarer-specific version of CoreUtils.mkCast,
--- because in the immediate output of the desugarer, we can have
--- apparently-mis-matched coercions:  E.g.
---     let a = b
---     in (x :: a) |> (co :: b ~ Int)
--- Lint know about type-bindings for let and does not complain
--- So here we do not make the assertion checks that we make in
--- CoreUtils.mkCast; and we do less peephole optimisation too
-mkCastDs e co | isReflCo co = e
-              | otherwise   = Cast e co
-
-{-
-************************************************************************
-*                                                                      *
-               Tuples and selector bindings
-*                                                                      *
-************************************************************************
-
-This is used in various places to do with lazy patterns.
-For each binder $b$ in the pattern, we create a binding:
-\begin{verbatim}
-    b = case v of pat' -> b'
-\end{verbatim}
-where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
-
-ToDo: making these bindings should really depend on whether there's
-much work to be done per binding.  If the pattern is complex, it
-should be de-mangled once, into a tuple (and then selected from).
-Otherwise the demangling can be in-line in the bindings (as here).
-
-Boring!  Boring!  One error message per binder.  The above ToDo is
-even more helpful.  Something very similar happens for pattern-bound
-expressions.
-
-Note [mkSelectorBinds]
-~~~~~~~~~~~~~~~~~~~~~~
-mkSelectorBinds is used to desugar a pattern binding {p = e},
-in a binding group:
-  let { ...; p = e; ... } in body
-where p binds x,y (this list of binders can be empty).
-There are two cases.
-
------- Special case (A) -------
-  For a pattern that is just a variable,
-     let !x = e in body
-  ==>
-     let x = e in x `seq` body
-  So we return the binding, with 'x' as the variable to seq.
-
------- Special case (B) -------
-  For a pattern that is essentially just a tuple:
-      * A product type, so cannot fail
-      * Only one level, so that
-          - generating multiple matches is fine
-          - seq'ing it evaluates the same as matching it
-  Then instead we generate
-       { v = e
-       ; x = case v of p -> x
-       ; y = case v of p -> y }
-  with 'v' as the variable to force
-
------- General case (C) -------
-  In the general case we generate these bindings:
-       let { ...; p = e; ... } in body
-  ==>
-       let { t = case e of p -> (x,y)
-           ; x = case t of (x,y) -> x
-           ; y = case t of (x,y) -> y }
-       in t `seq` body
-
-  Note that we return 't' as the variable to force if the pattern
-  is strict (i.e. with -XStrict or an outermost-bang-pattern)
-
-  Note that (A) /includes/ the situation where
-
-   * The pattern binds exactly one variable
-        let !(Just (Just x) = e in body
-     ==>
-       let { t = case e of Just (Just v) -> Unit v
-           ; v = case t of Unit v -> v }
-       in t `seq` body
-    The 'Unit' is a one-tuple; see Note [One-tuples] in TysWiredIn
-    Note that forcing 't' makes the pattern match happen,
-    but does not force 'v'.
-
-  * The pattern binds no variables
-        let !(True,False) = e in body
-    ==>
-        let t = case e of (True,False) -> ()
-        in t `seq` body
-
-
------- Examples ----------
-  *   !(_, (_, a)) = e
-    ==>
-      t = case e of (_, (_, a)) -> Unit a
-      a = case t of Unit a -> a
-
-    Note that
-     - Forcing 't' will force the pattern to match fully;
-       e.g. will diverge if (snd e) is bottom
-     - But 'a' itself is not forced; it is wrapped in a one-tuple
-       (see Note [One-tuples] in TysWiredIn)
-
-  *   !(Just x) = e
-    ==>
-      t = case e of Just x -> Unit x
-      x = case t of Unit x -> x
-
-    Again, forcing 't' will fail if 'e' yields Nothing.
-
-Note that even though this is rather general, the special cases
-work out well:
-
-* One binder, not -XStrict:
-
-    let Just (Just v) = e in body
-  ==>
-    let t = case e of Just (Just v) -> Unit v
-        v = case t of Unit v -> v
-    in body
-  ==>
-    let v = case (case e of Just (Just v) -> Unit v) of
-              Unit v -> v
-    in body
-  ==>
-    let v = case e of Just (Just v) -> v
-    in body
-
-* Non-recursive, -XStrict
-     let p = e in body
-  ==>
-     let { t = case e of p -> (x,y)
-         ; x = case t of (x,y) -> x
-         ; y = case t of (x,y) -> x }
-     in t `seq` body
-  ==> {inline seq, float x,y bindings inwards}
-     let t = case e of p -> (x,y) in
-     case t of t' ->
-     let { x = case t' of (x,y) -> x
-         ; y = case t' of (x,y) -> x } in
-     body
-  ==> {inline t, do case of case}
-     case e of p ->
-     let t = (x,y) in
-     let { x = case t' of (x,y) -> x
-         ; y = case t' of (x,y) -> x } in
-     body
-  ==> {case-cancellation, drop dead code}
-     case e of p -> body
-
-* Special case (B) is there to avoid fruitlessly taking the tuple
-  apart and rebuilding it. For example, consider
-     { K x y = e }
-  where K is a product constructor.  Then general case (A) does:
-     { t = case e of K x y -> (x,y)
-     ; x = case t of (x,y) -> x
-     ; y = case t of (x,y) -> y }
-  In the lazy case we can't optimise out this fruitless taking apart
-  and rebuilding.  Instead (B) builds
-     { v = e
-     ; x = case v of K x y -> x
-     ; y = case v of K x y -> y }
-  which is better.
--}
-
-mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly
-                -> LPat Id        -- ^ The pattern
-                -> CoreExpr       -- ^ Expression to which the pattern is bound
-                -> DsM (Id,[(Id,CoreExpr)])
-                -- ^ Id the rhs is bound to, for desugaring strict
-                -- binds (see Note [Desugar Strict binds] in DsBinds)
-                -- and all the desugared binds
-
-mkSelectorBinds ticks pat val_expr
-  | L _ (VarPat (L _ v)) <- pat'     -- Special case (A)
-  = return (v, [(v, val_expr)])
-
-  | is_flat_prod_lpat pat'           -- Special case (B)
-  = do { let pat_ty = hsLPatType pat'
-       ; val_var <- newSysLocalDsNoLP pat_ty
-
-       ; let mk_bind tick bndr_var
-               -- (mk_bind sv bv)  generates  bv = case sv of { pat -> bv }
-               -- Remember, 'pat' binds 'bv'
-               = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat'
-                                       (Var bndr_var)
-                                       (Var bndr_var)  -- Neat hack
-                      -- Neat hack: since 'pat' can't fail, the
-                      -- "fail-expr" passed to matchSimply is not
-                      -- used. But it /is/ used for its type, and for
-                      -- that bndr_var is just the ticket.
-                    ; return (bndr_var, mkOptTickBox tick rhs_expr) }
-
-       ; binds <- zipWithM mk_bind ticks' binders
-       ; return ( val_var, (val_var, val_expr) : binds) }
-
-  | otherwise                          -- General case (C)
-  = do { tuple_var  <- newSysLocalDs tuple_ty
-       ; error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat')
-       ; tuple_expr <- matchSimply val_expr PatBindRhs pat
-                                   local_tuple error_expr
-       ; let mk_tup_bind tick binder
-               = (binder, mkOptTickBox tick $
-                          mkTupleSelector1 local_binders binder
-                                           tuple_var (Var tuple_var))
-             tup_binds = zipWith mk_tup_bind ticks' binders
-       ; return (tuple_var, (tuple_var, tuple_expr) : tup_binds) }
-  where
-    pat' = strip_bangs pat
-           -- Strip the bangs before looking for case (A) or (B)
-           -- The incoming pattern may well have a bang on it
-
-    binders = collectPatBinders pat'
-    ticks'  = ticks ++ repeat []
-
-    local_binders = map localiseId binders      -- See Note [Localise pattern binders]
-    local_tuple   = mkBigCoreVarTup1 binders
-    tuple_ty      = exprType local_tuple
-
-strip_bangs :: LPat a -> LPat a
--- Remove outermost bangs and parens
-strip_bangs (L _ (ParPat p))  = strip_bangs p
-strip_bangs (L _ (BangPat p)) = strip_bangs p
-strip_bangs lp                = lp
-
-is_flat_prod_lpat :: LPat a -> Bool
-is_flat_prod_lpat p = is_flat_prod_pat (unLoc p)
-
-is_flat_prod_pat :: Pat a -> Bool
-is_flat_prod_pat (ParPat p)            = is_flat_prod_lpat p
-is_flat_prod_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
-is_flat_prod_pat (ConPatOut { pat_con = L _ pcon, pat_args = ps})
-  | RealDataCon con <- pcon
-  , isProductTyCon (dataConTyCon con)
-  = all is_triv_lpat (hsConPatArgs ps)
-is_flat_prod_pat _ = False
-
-is_triv_lpat :: LPat a -> Bool
-is_triv_lpat p = is_triv_pat (unLoc p)
-
-is_triv_pat :: Pat a -> Bool
-is_triv_pat (VarPat _)  = True
-is_triv_pat (WildPat _) = True
-is_triv_pat (ParPat p)  = is_triv_lpat p
-is_triv_pat _           = False
-
-
-{- *********************************************************************
-*                                                                      *
-  Creating big tuples and their types for full Haskell expressions.
-  They work over *Ids*, and create tuples replete with their types,
-  which is whey they are not in HsUtils.
-*                                                                      *
-********************************************************************* -}
-
-mkLHsPatTup :: [LPat Id] -> LPat Id
-mkLHsPatTup []     = noLoc $ mkVanillaTuplePat [] Boxed
-mkLHsPatTup [lpat] = lpat
-mkLHsPatTup lpats  = L (getLoc (head lpats)) $
-                     mkVanillaTuplePat lpats Boxed
-
-mkLHsVarPatTup :: [Id] -> LPat Id
-mkLHsVarPatTup bs  = mkLHsPatTup (map nlVarPat bs)
-
-mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
--- A vanilla tuple pattern simply gets its type from its sub-patterns
-mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats)
-
--- The Big equivalents for the source tuple expressions
-mkBigLHsVarTupId :: [Id] -> LHsExpr Id
-mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids)
-
-mkBigLHsTupId :: [LHsExpr Id] -> LHsExpr Id
-mkBigLHsTupId = mkChunkified mkLHsTupleExpr
-
--- The Big equivalents for the source tuple patterns
-mkBigLHsVarPatTupId :: [Id] -> LPat Id
-mkBigLHsVarPatTupId bs = mkBigLHsPatTupId (map nlVarPat bs)
-
-mkBigLHsPatTupId :: [LPat Id] -> LPat Id
-mkBigLHsPatTupId = mkChunkified mkLHsPatTup
-
-{-
-************************************************************************
-*                                                                      *
-        Code for pattern-matching and other failures
-*                                                                      *
-************************************************************************
-
-Generally, we handle pattern matching failure like this: let-bind a
-fail-variable, and use that variable if the thing fails:
-\begin{verbatim}
-        let fail.33 = error "Help"
-        in
-        case x of
-                p1 -> ...
-                p2 -> fail.33
-                p3 -> fail.33
-                p4 -> ...
-\end{verbatim}
-Then
-\begin{itemize}
-\item
-If the case can't fail, then there'll be no mention of @fail.33@, and the
-simplifier will later discard it.
-
-\item
-If it can fail in only one way, then the simplifier will inline it.
-
-\item
-Only if it is used more than once will the let-binding remain.
-\end{itemize}
-
-There's a problem when the result of the case expression is of
-unboxed type.  Then the type of @fail.33@ is unboxed too, and
-there is every chance that someone will change the let into a case:
-\begin{verbatim}
-        case error "Help" of
-          fail.33 -> case ....
-\end{verbatim}
-
-which is of course utterly wrong.  Rather than drop the condition that
-only boxed types can be let-bound, we just turn the fail into a function
-for the primitive case:
-\begin{verbatim}
-        let fail.33 :: Void -> Int#
-            fail.33 = \_ -> error "Help"
-        in
-        case x of
-                p1 -> ...
-                p2 -> fail.33 void
-                p3 -> fail.33 void
-                p4 -> ...
-\end{verbatim}
-
-Now @fail.33@ is a function, so it can be let-bound.
-
-We would *like* to use join points here; in fact, these "fail variables" are
-paradigmatic join points! Sadly, this breaks pattern synonyms, which desugar as
-CPS functions - i.e. they take "join points" as parameters. It's not impossible
-to imagine extending our type system to allow passing join points around (very
-carefully), but we certainly don't support it now.
-
-99.99% of the time, the fail variables wind up as join points in short order
-anyway, and the Void# doesn't do much harm.
--}
-
-mkFailurePair :: CoreExpr       -- Result type of the whole case expression
-              -> DsM (CoreBind, -- Binds the newly-created fail variable
-                                -- to \ _ -> expression
-                      CoreExpr) -- Fail variable applied to realWorld#
--- See Note [Failure thunks and CPR]
-mkFailurePair expr
-  = do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkFunTy` ty)
-       ; fail_fun_arg <- newSysLocalDs voidPrimTy
-       ; let real_arg = setOneShotLambda fail_fun_arg
-       ; return (NonRec fail_fun_var (Lam real_arg expr),
-                 App (Var fail_fun_var) (Var voidPrimId)) }
-  where
-    ty = exprType expr
-
-{-
-Note [Failure thunks and CPR]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-(This note predates join points as formal entities (hence the quotation marks).
-We can't use actual join points here (see above); if we did, this would also
-solve the CPR problem, since join points don't get CPR'd. See Note [Don't CPR
-join points] in WorkWrap.)
-
-When we make a failure point we ensure that it
-does not look like a thunk. Example:
-
-   let fail = \rw -> error "urk"
-   in case x of
-        [] -> fail realWorld#
-        (y:ys) -> case ys of
-                    [] -> fail realWorld#
-                    (z:zs) -> (y,z)
-
-Reason: we know that a failure point is always a "join point" and is
-entered at most once.  Adding a dummy 'realWorld' token argument makes
-it clear that sharing is not an issue.  And that in turn makes it more
-CPR-friendly.  This matters a lot: if you don't get it right, you lose
-the tail call property.  For example, see Trac #3403.
-
-
-************************************************************************
-*                                                                      *
-              Ticks
-*                                                                      *
-********************************************************************* -}
-
-mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr
-mkOptTickBox = flip (foldr Tick)
-
-mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
-mkBinaryTickBox ixT ixF e = do
-       uq <- newUnique
-       this_mod <- getModule
-       let bndr1 = mkSysLocal (fsLit "t1") uq boolTy
-       let
-           falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId)
-           trueBox  = Tick (HpcTick this_mod ixT) (Var trueDataConId)
-       --
-       return $ Case e bndr1 boolTy
-                       [ (DataAlt falseDataCon, [], falseBox)
-                       , (DataAlt trueDataCon,  [], trueBox)
-                       ]
-
-
-
--- *******************************************************************
-
--- | Use -XStrict to add a ! or remove a ~
---
--- Examples:
--- ~pat    => pat    -- when -XStrict (even if pat = ~pat')
--- !pat    => !pat   -- always
--- pat     => !pat   -- when -XStrict
--- pat     => pat    -- otherwise
-decideBangHood :: DynFlags
-               -> LPat id  -- ^ Original pattern
-               -> LPat id  -- Pattern with bang if necessary
-decideBangHood dflags lpat
-  | not (xopt LangExt.Strict dflags)
-  = lpat
-  | otherwise   --  -XStrict
-  = go lpat
-  where
-    go lp@(L l p)
-      = case p of
-           ParPat p    -> L l (ParPat (go p))
-           LazyPat lp' -> lp'
-           BangPat _   -> lp
-           _           -> L l (BangPat lp)
-
--- | Unconditionally make a 'Pat' strict.
-addBang :: LPat id -- ^ Original pattern
-        -> LPat id -- ^ Banged pattern
-addBang = go
-  where
-    go lp@(L l p)
-      = case p of
-           ParPat p    -> L l (ParPat (go p))
-           LazyPat lp' -> L l (BangPat lp')
-           BangPat _   -> lp
-           _           -> L l (BangPat lp)

− src/Language/Haskell/Liquid/Desugar/HscMain.hs 
@@ -1,95 +0,0 @@-------------------------------------------------------------------------------------- | Main API for compiling plain Haskell source code.------ This module implements compilation of a Haskell source. It is--- /not/ concerned with preprocessing of source files; this is handled--- in "DriverPipeline".------ There are various entry points depending on what mode we're in:--- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and--- "interactive" mode (GHCi). There are also entry points for--- individual passes: parsing, typechecking/renaming, desugaring, and--- simplification.------ All the functions here take an 'HscEnv' as a parameter, but none of--- them return a new one: 'HscEnv' is treated as an immutable value--- from here on in (although it has mutable components, for the--- caches).------ Warning messages are dealt with consistently throughout this API:--- during compilation warnings are collected, and before any function--- in @HscMain@ returns, the warnings are either printed, or turned--- into a real compialtion error if the @-Werror@ flag is enabled.------ (c) The GRASP/AQUA Project, Glasgow University, 1993-2000-------------------------------------------------------------------------------------module Language.Haskell.Liquid.Desugar.HscMain (hscDesugarWithLoc) where--import Language.Haskell.Liquid.Desugar.Desugar (deSugar)-import Prelude hiding (error)-import Module-import TcRnMonad--import ErrUtils--import DynFlags-import HscTypes-import Bag-import Exception----- -------------------------------------------------------------------------------getWarnings :: Hsc WarningMessages-getWarnings = Hsc $ \_ w -> return (w, w)--clearWarnings :: Hsc ()-clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)--logWarnings :: WarningMessages -> Hsc ()-logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)------ | Throw some errors.-throwErrors :: ErrorMessages -> Hsc a-throwErrors = liftIO . throwIO . mkSrcErr------- | Convert a typechecked module to Core-hscDesugarWithLoc :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts-hscDesugarWithLoc hsc_env mod_summary tc_result =-    runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result--hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts-hscDesugar' mod_location tc_result = do-    hsc_env <- getHscEnv-    r <- ioMsgMaybe $-      {-# SCC "deSugar" #-}-      deSugar hsc_env mod_location tc_result--    -- always check -Werror after desugaring, this is the last opportunity for-    -- warnings to arise before the backend.-    handleWarnings-    return r--getHscEnv :: Hsc HscEnv-getHscEnv = Hsc $ \e w -> return (e, w)--handleWarnings :: Hsc ()-handleWarnings = do-    dflags <- getDynFlags-    w <- getWarnings-    liftIO $ printOrThrowWarnings dflags w-    clearWarnings--ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a-ioMsgMaybe ioA = do-    ((warns,errs), mb_r) <- liftIO ioA-    logWarnings warns-    case mb_r of-        Nothing -> throwErrors errs-        Just r  -> return r
− src/Language/Haskell/Liquid/Desugar/Match.hs 
@@ -1,1126 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---The @match@ function--}--{-# LANGUAGE CPP #-}--module Language.Haskell.Liquid.Desugar.Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where--import {-#SOURCE#-} Language.Haskell.Liquid.Desugar.DsExpr (dsLExpr, dsSyntaxExpr)--import DynFlags-import HsSyn-import TcHsSyn-import TcEvidence-import TcRnMonad-import Language.Haskell.Liquid.Desugar.Check-import CoreSyn-import Literal-import CoreUtils-import MkCore-import Language.Haskell.Liquid.Desugar.DsMonad-import Language.Haskell.Liquid.Desugar.DsBinds-import Language.Haskell.Liquid.Desugar.DsGRHSs-import Language.Haskell.Liquid.Desugar.DsUtils-import Id-import ConLike-import DataCon-import PatSyn-import Language.Haskell.Liquid.Desugar.MatchCon-import Language.Haskell.Liquid.Desugar.MatchLit-import Type-import Coercion ( eqCoercion )-import TcType ( toTcTypeBag )-import TyCon( isNewTyCon )-import TysWiredIn-import ListSetOps-import SrcLoc-import Maybes-import Util-import Name-import Outputable-import BasicTypes ( isGenerated, fl_value )-import FastString-import Unique-import UniqDFM--import Control.Monad( when, unless )-import qualified Data.Map as Map--{--************************************************************************-*                                                                      *-                The main matching function-*                                                                      *-************************************************************************--The function @match@ is basically the same as in the Wadler chapter,-except it is monadised, to carry around the name supply, info about-annotations, etc.--Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:-\begin{enumerate}-\item-A list of $n$ variable names, those variables presumably bound to the-$n$ expressions being matched against the $n$ patterns.  Using the-list of $n$ expressions as the first argument showed no benefit and-some inelegance.--\item-The second argument, a list giving the ``equation info'' for each of-the $m$ equations:-\begin{itemize}-\item-the $n$ patterns for that equation, and-\item-a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on-the front'' of the matching code, as in:-\begin{verbatim}-let <binds>-in  <matching-code>-\end{verbatim}-\item-and finally: (ToDo: fill in)--The right way to think about the ``after-match function'' is that it-is an embryonic @CoreExpr@ with a ``hole'' at the end for the-final ``else expression''.-\end{itemize}--There is a data type, @EquationInfo@, defined in module @DsMonad@.--An experiment with re-ordering this information about equations (in-particular, having the patterns available in column-major order)-showed no benefit.--\item-A default expression---what to evaluate if the overall pattern-match-fails.  This expression will (almost?) always be-a measly expression @Var@, unless we know it will only be used once-(as we do in @glue_success_exprs@).--Leaving out this third argument to @match@ (and slamming in lots of-@Var "fail"@s) is a positively {\em bad} idea, because it makes it-impossible to share the default expressions.  (Also, it stands no-chance of working in our post-upheaval world of @Locals@.)-\end{enumerate}--Note: @match@ is often called via @matchWrapper@ (end of this module),-a function that does much of the house-keeping that goes with a call-to @match@.--It is also worth mentioning the {\em typical} way a block of equations-is desugared with @match@.  At each stage, it is the first column of-patterns that is examined.  The steps carried out are roughly:-\begin{enumerate}-\item-Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add-bindings to the second component of the equation-info):-\begin{itemize}-\item-Remove the `as' patterns from column~1.-\item-Make all constructor patterns in column~1 into @ConPats@, notably-@ListPats@ and @TuplePats@.-\item-Handle any irrefutable (or ``twiddle'') @LazyPats@.-\end{itemize}-\item-Now {\em unmix} the equations into {\em blocks} [w\/ local function-@unmix_eqns@], in which the equations in a block all have variable-patterns in column~1, or they all have constructor patterns in ...-(see ``the mixture rule'' in SLPJ).-\item-Call @matchEqnBlock@ on each block of equations; it will do the-appropriate thing for each kind of column-1 pattern, usually ending up-in a recursive call to @match@.-\end{enumerate}--We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)-than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).-And gluing the ``success expressions'' together isn't quite so pretty.--This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@-(a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and-(b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em-un}mixes the equations], producing a list of equation-info-blocks, each block having as its first column of patterns either all-constructors, or all variables (or similar beasts), etc.--@match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the-Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@-corresponds roughly to @matchVarCon@.--Note [Match Ids]-~~~~~~~~~~~~~~~~-Most of the matching fuctions take an Id or [Id] as argument.  This Id-is the scrutinee(s) of the match. The desugared expression may-sometimes use that Id in a local binding or as a case binder.  So it-should not have an External name; Lint rejects non-top-level binders-with External names (Trac #13043).--}--type MatchId = Id   -- See Note [Match Ids]--match :: [MatchId]        -- Variables rep\'ing the exprs we\'re matching with-                          -- See Note [Match Ids]-      -> Type             -- Type of the case expression-      -> [EquationInfo]   -- Info about patterns, etc. (type synonym below)-      -> DsM MatchResult  -- Desugared result!--match [] _ eqns-  = return (foldr1 combineMatchResults match_results)-  where-    match_results = [ eqn_rhs eqn-                    | eqn <- eqns ]--match vars@(v:_) ty eqns    -- Eqns *can* be empty-  = do  { dflags <- getDynFlags-                -- Tidy the first pattern, generating-                -- auxiliary bindings if necessary-        ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns--                -- Group the equations and match each group in turn-        ; let grouped = groupEquations dflags tidy_eqns--         -- print the view patterns that are commoned up to help debug-        ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped)--        ; match_results <- match_groups grouped-        ; return (adjustMatchResult (foldr (.) id aux_binds) $-                  foldr1 combineMatchResults match_results) }-  where-    dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo]-    dropGroup = map snd--    match_groups :: [[(PatGroup,EquationInfo)]] -> DsM [MatchResult]-    -- Result list of [MatchResult] is always non-empty-    match_groups [] = matchEmpty v ty-    match_groups gs = mapM match_group gs--    match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult-    match_group [] = panic "match_group"-    match_group eqns@((group,_) : _)-        = case group of-            PgCon {}  -> matchConFamily  vars ty (subGroupUniq [(c,e) | (PgCon c, e) <- eqns])-            PgSyn {}  -> matchPatSyn     vars ty (dropGroup eqns)-            PgLit {}  -> matchLiterals   vars ty (subGroupOrd [(l,e) | (PgLit l, e) <- eqns])-            PgAny     -> matchVariables  vars ty (dropGroup eqns)-            PgN {}    -> matchNPats      vars ty (dropGroup eqns)-            PgOverS {}-> matchNPats      vars ty (dropGroup eqns)-            PgNpK {}  -> matchNPlusKPats vars ty (dropGroup eqns)-            PgBang    -> matchBangs      vars ty (dropGroup eqns)-            PgCo {}   -> matchCoercion   vars ty (dropGroup eqns)-            PgView {} -> matchView       vars ty (dropGroup eqns)-            PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns)--    -- FIXME: we should also warn about view patterns that should be-    -- commoned up but are not--    -- print some stuff to see what's getting grouped-    -- use -dppr-debug to see the resolution of overloaded literals-    debug eqns =-        let gs = map (\group -> foldr (\ (p,_) -> \acc ->-                                           case p of PgView e _ -> e:acc-                                                     _ -> acc) [] group) eqns-            maybeWarn [] = return ()-            maybeWarn l = warnDs NoReason (vcat l)-        in-          maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))-                       (filter (not . null) gs))--matchEmpty :: MatchId -> Type -> DsM [MatchResult]--- See Note [Empty case expressions]-matchEmpty var res_ty-  = return [MatchResult CanFail mk_seq]-  where-    mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty-                                      [(DEFAULT, [], fail)]--matchVariables :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult--- Real true variables, just like in matchVar, SLPJ p 94--- No binding to do: they'll all be wildcards by now (done in tidy)-matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns)-matchVariables [] _ _ = panic "matchVariables"--matchBangs :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult-matchBangs (var:vars) ty eqns-  = do  { match_result <- match (var:vars) ty $-                          map (decomposeFirstPat getBangPat) eqns-        ; return (mkEvalMatchResult var ty match_result) }-matchBangs [] _ _ = panic "matchBangs"--matchCoercion :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult--- Apply the coercion to the match variable and then match that-matchCoercion (var:vars) ty (eqns@(eqn1:_))-  = do  { let CoPat co pat _ = firstPat eqn1-        ; let pat_ty' = hsPatType pat-        ; var' <- newUniqueId var pat_ty'-        ; match_result <- match (var':vars) ty $-                          map (decomposeFirstPat getCoPat) eqns-        ; core_wrap <- dsHsWrapper co-        ; let bind = NonRec var' (core_wrap (Var var))-        ; return (mkCoLetMatchResult bind match_result) }-matchCoercion _ _ _ = panic "matchCoercion"--matchView :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult--- Apply the view function to the match variable and then match that-matchView (var:vars) ty (eqns@(eqn1:_))-  = do  { -- we could pass in the expr from the PgView,-         -- but this needs to extract the pat anyway-         -- to figure out the type of the fresh variable-         let ViewPat viewExpr (L _ pat) _ = firstPat eqn1-         -- do the rest of the compilation-        ; let pat_ty' = hsPatType pat-        ; var' <- newUniqueId var pat_ty'-        ; match_result <- match (var':vars) ty $-                          map (decomposeFirstPat getViewPat) eqns-         -- compile the view expressions-        ; viewExpr' <- dsLExpr viewExpr-        ; return (mkViewMatchResult var'-                    (mkCoreAppDs (text "matchView") viewExpr' (Var var))-                    match_result) }-matchView _ _ _ = panic "matchView"--matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult-matchOverloadedList (var:vars) ty (eqns@(eqn1:_))--- Since overloaded list patterns are treated as view patterns,--- the code is roughly the same as for matchView-  = do { let ListPat _ elt_ty (Just (_,e)) = firstPat eqn1-       ; var' <- newUniqueId var (mkListTy elt_ty)  -- we construct the overall type by hand-       ; match_result <- match (var':vars) ty $-                            map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern-       ; e' <- dsSyntaxExpr e [Var var]-       ; return (mkViewMatchResult var' e' match_result) }-matchOverloadedList _ _ _ = panic "matchOverloadedList"---- decompose the first pattern and leave the rest alone-decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo-decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))-        = eqn { eqn_pats = extractpat pat : pats}-decomposeFirstPat _ _ = panic "decomposeFirstPat"--getCoPat, getBangPat, getViewPat, getOLPat :: Pat Id -> Pat Id-getCoPat (CoPat _ pat _)     = pat-getCoPat _                   = panic "getCoPat"-getBangPat (BangPat pat  )   = unLoc pat-getBangPat _                 = panic "getBangPat"-getViewPat (ViewPat _ pat _) = unLoc pat-getViewPat _                 = panic "getViewPat"-getOLPat (ListPat pats ty (Just _)) = ListPat pats ty Nothing-getOLPat _                   = panic "getOLPat"--{--Note [Empty case alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The list of EquationInfo can be empty, arising from-    case x of {}   or    \case {}-In that situation we desugar to-    case x of { _ -> error "pattern match failure" }-The *desugarer* isn't certain whether there really should be no-alternatives, so it adds a default case, as it always does.  A later-pass may remove it if it's inaccessible.  (See also Note [Empty case-alternatives] in CoreSyn.)--We do *not* desugar simply to-   error "empty case"-or some such, because 'x' might be bound to (error "hello"), in which-case we want to see that "hello" exception, not (error "empty case").-See also Note [Case elimination: lifted case] in Simplify.---************************************************************************-*                                                                      *-                Tidying patterns-*                                                                      *-************************************************************************--Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@-which will be scrutinised.  This means:-\begin{itemize}-\item-Replace variable patterns @x@ (@x /= v@) with the pattern @_@,-together with the binding @x = v@.-\item-Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@.-\item-Removing lazy (irrefutable) patterns (you don't want to know...).-\item-Converting explicit tuple-, list-, and parallel-array-pats into ordinary-@ConPats@.-\item-Convert the literal pat "" to [].-\end{itemize}--The result of this tidying is that the column of patterns will include-{\em only}:-\begin{description}-\item[@WildPats@:]-The @VarPat@ information isn't needed any more after this.--\item[@ConPats@:]-@ListPats@, @TuplePats@, etc., are all converted into @ConPats@.--\item[@LitPats@ and @NPats@:]-@LitPats@/@NPats@ of ``known friendly types'' (Int, Char,-Float,  Double, at least) are converted to unboxed form; e.g.,-\tr{(NPat (HsInt i) _ _)} is converted to:-\begin{verbatim}-(ConPat I# _ _ [LitPat (HsIntPrim i)])-\end{verbatim}-\end{description}--}--tidyEqnInfo :: Id -> EquationInfo-            -> DsM (DsWrapper, EquationInfo)-        -- DsM'd because of internal call to dsLHsBinds-        --      and mkSelectorBinds.-        -- "tidy1" does the interesting stuff, looking at-        -- one pattern and fiddling the list of bindings.-        ---        -- POST CONDITION: head pattern in the EqnInfo is-        --      WildPat-        --      ConPat-        --      NPat-        --      LitPat-        --      NPlusKPat-        -- but no other--tidyEqnInfo _ (EqnInfo { eqn_pats = [] })-  = panic "tidyEqnInfo"--tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats })-  = do { (wrap, pat') <- tidy1 v pat-       ; return (wrap, eqn { eqn_pats = do pat' : pats }) }--tidy1 :: Id               -- The Id being scrutinised-      -> Pat Id           -- The pattern against which it is to be matched-      -> DsM (DsWrapper,  -- Extra bindings to do before the match-              Pat Id)     -- Equivalent pattern------------------------------------------------------------      (pat', mr') = tidy1 v pat mr--- tidies the *outer level only* of pat, giving pat'--- It eliminates many pattern forms (as-patterns, variable patterns,--- list patterns, etc) yielding one of:---      WildPat---      ConPatOut---      LitPat---      NPat---      NPlusKPat--tidy1 v (ParPat pat)      = tidy1 v (unLoc pat)-tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat)-tidy1 _ (WildPat ty)      = return (idDsWrapper, WildPat ty)-tidy1 v (BangPat (L l p)) = tidy_bang_pat v l p--        -- case v of { x -> mr[] }-        -- = case v of { _ -> let x=v in mr[] }-tidy1 v (VarPat (L _ var))-  = return (wrapBind var v, WildPat (idType var))--        -- case v of { x@p -> mr[] }-        -- = case v of { p -> let x=v in mr[] }-tidy1 v (AsPat (L _ var) pat)-  = do  { (wrap, pat') <- tidy1 v (unLoc pat)-        ; return (wrapBind var v . wrap, pat') }--{- now, here we handle lazy patterns:-    tidy1 v ~p bs = (v, v1 = case v of p -> v1 :-                        v2 = case v of p -> v2 : ... : bs )--    where the v_i's are the binders in the pattern.--    ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?--    The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr--}--tidy1 v (LazyPat pat)-    -- This is a convenient place to check for unlifted types under a lazy pattern.-    -- Doing this check during type-checking is unsatisfactory because we may-    -- not fully know the zonked types yet. We sure do here.-  = do  { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders pat)-        ; unless (null unlifted_bndrs) $-          putSrcSpanDs (getLoc pat) $-          errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$-                       text "Unlifted variables:")-                    2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id))-                                 unlifted_bndrs)))--        ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v)-        ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]-        ; return (mkCoreLets sel_binds, WildPat (idType v)) }--tidy1 _ (ListPat pats ty Nothing)-  = return (idDsWrapper, unLoc list_ConPat)-  where-    list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])-                        (mkNilPat ty)-                        pats---- Introduce fake parallel array constructors to be able to handle parallel--- arrays with the existing machinery for constructor pattern-tidy1 _ (PArrPat pats ty)-  = return (idDsWrapper, unLoc parrConPat)-  where-    arity      = length pats-    parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty]--tidy1 _ (TuplePat pats boxity tys)-  = return (idDsWrapper, unLoc tuple_ConPat)-  where-    arity = length pats-    tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys--tidy1 _ (SumPat pat alt arity tys)-  = return (idDsWrapper, unLoc sum_ConPat)-  where-    sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys---- LitPats: we *might* be able to replace these w/ a simpler form-tidy1 _ (LitPat lit)-  = return (idDsWrapper, tidyLitPat lit)---- NPats: we *might* be able to replace these w/ a simpler form-tidy1 _ (NPat (L _ lit) mb_neg eq ty)-  = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq ty)---- Everything else goes through unchanged...--tidy1 _ non_interesting_pat-  = return (idDsWrapper, non_interesting_pat)-----------------------tidy_bang_pat :: Id -> SrcSpan -> Pat Id -> DsM (DsWrapper, Pat Id)---- Discard par/sig under a bang-tidy_bang_pat v _ (ParPat (L l p))      = tidy_bang_pat v l p-tidy_bang_pat v _ (SigPatOut (L l p) _) = tidy_bang_pat v l p---- Push the bang-pattern inwards, in the hope that--- it may disappear next time-tidy_bang_pat v l (AsPat v' p)  = tidy1 v (AsPat v' (L l (BangPat p)))-tidy_bang_pat v l (CoPat w p t) = tidy1 v (CoPat w (BangPat (L l p)) t)---- Discard bang around strict pattern-tidy_bang_pat v _ p@(LitPat {})    = tidy1 v p-tidy_bang_pat v _ p@(ListPat {})   = tidy1 v p-tidy_bang_pat v _ p@(TuplePat {})  = tidy1 v p-tidy_bang_pat v _ p@(SumPat {})    = tidy1 v p-tidy_bang_pat v _ p@(PArrPat {})   = tidy1 v p---- Data/newtype constructors-tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc)-                               , pat_args = args-                               , pat_arg_tys = arg_tys })-  -- Newtypes: push bang inwards (Trac #9844)-  =-    if isNewTyCon (dataConTyCon dc)-      then tidy1 v (p { pat_args = push_bang_into_newtype_arg l ty args })-      else tidy1 v p  -- Data types: discard the bang-    where-      (ty:_) = dataConInstArgTys dc arg_tys------------------------ Default case, leave the bang there:---    VarPat,---    LazyPat,---    WildPat,---    ViewPat,---    pattern synonyms (ConPatOut with PatSynCon)---    NPat,---    NPlusKPat------ For LazyPat, remember that it's semantically like a VarPat---  i.e.  !(~p) is not like ~p, or p!  (Trac #8952)------ NB: SigPatIn, ConPatIn should not happen--tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p))----------------------push_bang_into_newtype_arg :: SrcSpan-                           -> Type -- The type of the argument we are pushing-                                   -- onto-                           -> HsConPatDetails Id -> HsConPatDetails Id--- See Note [Bang patterns and newtypes]--- We are transforming   !(N p)   into   (N !p)-push_bang_into_newtype_arg l _ty (PrefixCon (arg:_))-  = PrefixCon [L l (BangPat arg)]-push_bang_into_newtype_arg l _ty (RecCon rf)-  | HsRecFields { rec_flds = L lf fld : _ } <- rf-  , HsRecField { hsRecFieldArg = arg } <- fld-  = RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg = L l (BangPat arg) })] })-push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})-  | HsRecFields { rec_flds = [] } <- rf-  = PrefixCon [L l (BangPat (noLoc (WildPat ty)))]-push_bang_into_newtype_arg _ _ cd-  = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)--{--Note [Bang patterns and newtypes]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For the pattern  !(Just pat)  we can discard the bang, because-the pattern is strict anyway. But for !(N pat), where-  newtype NT = N Int-we definitely can't discard the bang.  Trac #9844.--So what we do is to push the bang inwards, in the hope that it will-get discarded there.  So we transform-   !(N pat)   into    (N !pat)--But what if there is nothing to push the bang onto? In at least one instance-a user has written !(N {}) which we translate into (N !_). See #13215---\noindent-{\bf Previous @matchTwiddled@ stuff:}--Now we get to the only interesting part; note: there are choices for-translation [from Simon's notes]; translation~1:-\begin{verbatim}-deTwiddle [s,t] e-\end{verbatim}-returns-\begin{verbatim}-[ w = e,-  s = case w of [s,t] -> s-  t = case w of [s,t] -> t-]-\end{verbatim}--Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple-evaluation of \tr{e}.  An alternative translation (No.~2):-\begin{verbatim}-[ w = case e of [s,t] -> (s,t)-  s = case w of (s,t) -> s-  t = case w of (s,t) -> t-]-\end{verbatim}--************************************************************************-*                                                                      *-\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}-*                                                                      *-************************************************************************--We might be able to optimise unmixing when confronted by-only-one-constructor-possible, of which tuples are the most notable-examples.  Consider:-\begin{verbatim}-f (a,b,c) ... = ...-f d ... (e:f) = ...-f (g,h,i) ... = ...-f j ...       = ...-\end{verbatim}-This definition would normally be unmixed into four equation blocks,-one per equation.  But it could be unmixed into just one equation-block, because if the one equation matches (on the first column),-the others certainly will.--You have to be careful, though; the example-\begin{verbatim}-f j ...       = ...---------------------f (a,b,c) ... = ...-f d ... (e:f) = ...-f (g,h,i) ... = ...-\end{verbatim}-{\em must} be broken into two blocks at the line shown; otherwise, you-are forcing unnecessary evaluation.  In any case, the top-left pattern-always gives the cue.  You could then unmix blocks into groups of...-\begin{description}-\item[all variables:]-As it is now.-\item[constructors or variables (mixed):]-Need to make sure the right names get bound for the variable patterns.-\item[literals or variables (mixed):]-Presumably just a variant on the constructor case (as it is now).-\end{description}--************************************************************************-*                                                                      *-*  matchWrapper: a convenient way to call @match@                      *-*                                                                      *-************************************************************************-\subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}--Calls to @match@ often involve similar (non-trivial) work; that work-is collected here, in @matchWrapper@.  This function takes as-arguments:-\begin{itemize}-\item-Typchecked @Matches@ (of a function definition, or a case or lambda-expression)---the main input;-\item-An error message to be inserted into any (runtime) pattern-matching-failure messages.-\end{itemize}--As results, @matchWrapper@ produces:-\begin{itemize}-\item-A list of variables (@Locals@) that the caller must ``promise'' to-bind to appropriate values; and-\item-a @CoreExpr@, the desugared output (main result).-\end{itemize}--The main actions of @matchWrapper@ include:-\begin{enumerate}-\item-Flatten the @[TypecheckedMatch]@ into a suitable list of-@EquationInfo@s.-\item-Create as many new variables as there are patterns in a pattern-list-(in any one of the @EquationInfo@s).-\item-Create a suitable ``if it fails'' expression---a call to @error@ using-the error-string input; the {\em type} of this fail value can be found-by examining one of the RHS expressions in one of the @EquationInfo@s.-\item-Call @match@ with all of this information!-\end{enumerate}--}--matchWrapper :: HsMatchContext Name         -- For shadowing warning messages-             -> Maybe (LHsExpr Id)          -- The scrutinee, if we check a case expr-             -> MatchGroup Id (LHsExpr Id)  -- Matches being desugared-             -> DsM ([Id], CoreExpr)        -- Results--{-- There is one small problem with the Lambda Patterns, when somebody- writes something similar to:-\begin{verbatim}-    (\ (x:xs) -> ...)-\end{verbatim}- he/she don't want a warning about incomplete patterns, that is done with- the flag @opt_WarnSimplePatterns@.- This problem also appears in the:-\begin{itemize}-\item @do@ patterns, but if the @do@ can fail-      it creates another equation if the match can fail-      (see @DsExpr.doDo@ function)-\item @let@ patterns, are treated by @matchSimply@-   List Comprension Patterns, are treated by @matchSimply@ also-\end{itemize}--We can't call @matchSimply@ with Lambda patterns,-due to the fact that lambda patterns can have more than-one pattern, and match simply only accepts one pattern.--JJQC 30-Nov-1997--}--matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches-                             , mg_arg_tys = arg_tys-                             , mg_res_ty = rhs_ty-                             , mg_origin = origin })-  = do  { dflags <- getDynFlags-        ; locn   <- getSrcSpanDs--        ; new_vars    <- case matches of-                           []    -> mapM newSysLocalDsNoLP arg_tys-                           (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m))--        ; eqns_info   <- mapM (mk_eqn_info new_vars) matches--        -- pattern match check warnings-        ; unless (isGenerated origin) $-          when (isAnyPmCheckEnabled dflags (DsMatchContext ctxt locn)) $-          addTmCsDs (genCaseTmCs1 mb_scr new_vars) $-              -- See Note [Type and Term Equality Propagation]-          checkMatches dflags (DsMatchContext ctxt locn) new_vars matches--        ; result_expr <- handleWarnings $-                         matchEquations ctxt new_vars eqns_info rhs_ty-        ; return (new_vars, result_expr) }-  where-    mk_eqn_info vars (L _ (Match ctx pats _ grhss))-      = do { dflags <- getDynFlags-           ; let add_bang-                   | FunRhs {mc_strictness=SrcStrict} <- ctx-                   = pprTrace "addBang" empty addBang-                   | otherwise-                   = decideBangHood dflags-                 upats = map (unLoc . add_bang) pats-                 dicts = toTcTypeBag (collectEvVarsPats upats) -- Only TcTyVars-           ; tm_cs <- genCaseTmCs2 mb_scr upats vars-           ; match_result <- addDictsDs dicts $ -- See Note [Type and Term Equality Propagation]-                             addTmCsDs tm_cs  $ -- See Note [Type and Term Equality Propagation]-                             dsGRHSs ctxt upats grhss rhs_ty-           ; return (EqnInfo { eqn_pats = upats, eqn_rhs  = match_result}) }--    handleWarnings = if isGenerated origin-                     then discardWarningsDs-                     else id---matchEquations  :: HsMatchContext Name-                -> [MatchId] -> [EquationInfo] -> Type-                -> DsM CoreExpr-matchEquations ctxt vars eqns_info rhs_ty-  = do  { let error_doc = matchContextErrString ctxt--        ; match_result <- match vars rhs_ty eqns_info--        ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc-        ; extractMatchResult match_result fail_expr }--{--************************************************************************-*                                                                      *-\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}-*                                                                      *-************************************************************************--@mkSimpleMatch@ is a wrapper for @match@ which deals with the-situation where we want to match a single expression against a single-pattern. It returns an expression.--}--matchSimply :: CoreExpr                 -- Scrutinee-            -> HsMatchContext Name      -- Match kind-            -> LPat Id                  -- Pattern it should match-            -> CoreExpr                 -- Return this if it matches-            -> CoreExpr                 -- Return this if it doesn't-            -> DsM CoreExpr--- Do not warn about incomplete patterns; see matchSinglePat comments-matchSimply scrut hs_ctx pat result_expr fail_expr = do-    let-      match_result = cantFailMatchResult result_expr-      rhs_ty       = exprType fail_expr-        -- Use exprType of fail_expr, because won't refine in the case of failure!-    match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result-    extractMatchResult match_result' fail_expr--matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id-               -> Type -> MatchResult -> DsM MatchResult--- matchSinglePat ensures that the scrutinee is a variable--- and then calls match_single_pat_var------ matchSinglePat does not warn about incomplete patterns--- Used for things like [ e | pat <- stuff ], where--- incomplete patterns are just fine--matchSinglePat (Var var) ctx pat ty match_result-  | not (isExternalName (idName var))-  = match_single_pat_var var ctx pat ty match_result--matchSinglePat scrut hs_ctx pat ty match_result-  = do { var           <- selectSimpleMatchVarL pat-       ; match_result' <- match_single_pat_var var hs_ctx pat ty match_result-       ; return (adjustMatchResult (bindNonRec var scrut) match_result') }--match_single_pat_var :: Id   -- See Note [Match Ids]-                     -> HsMatchContext Name -> LPat Id-                     -> Type -> MatchResult -> DsM MatchResult-match_single_pat_var var ctx pat ty match_result-  = do { dflags <- getDynFlags-       ; locn   <- getSrcSpanDs--                    -- Pattern match check warnings-       ; checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat)--       ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]-                                , eqn_rhs  = match_result }-       ; match [var] ty [eqn_info] }---{--************************************************************************-*                                                                      *-                Pattern classification-*                                                                      *-************************************************************************--}--data PatGroup-  = PgAny               -- Immediate match: variables, wildcards,-                        --                  lazy patterns-  | PgCon DataCon       -- Constructor patterns (incl list, tuple)-  | PgSyn PatSyn [Type] -- See Note [Pattern synonym groups]-  | PgLit Literal       -- Literal patterns-  | PgN   Rational      -- Overloaded numeric literals;-                        -- see Note [Don't use Literal for PgN]-  | PgOverS FastString  -- Overloaded string literals-  | PgNpK Integer       -- n+k patterns-  | PgBang              -- Bang patterns-  | PgCo Type           -- Coercion patterns; the type is the type-                        --      of the pattern *inside*-  | PgView (LHsExpr Id) -- view pattern (e -> p):-                        -- the LHsExpr is the expression e-           Type         -- the Type is the type of p (equivalently, the result type of e)-  | PgOverloadedList--{- Note [Don't use Literal for PgN]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Previously we had, as PatGroup constructors--  | ...-  | PgN   Literal       -- Overloaded literals-  | PgNpK Literal       -- n+k patterns-  | ...--But Literal is really supposed to represent an *unboxed* literal, like Int#.-We were sticking the literal from, say, an overloaded numeric literal pattern-into a MachInt constructor. This didn't really make sense; and we now have-the invariant that value in a MachInt must be in the range of the target-machine's Int# type, and an overloaded literal could meaningfully be larger.--Solution: For pattern grouping purposes, just store the literal directly in-the PgN constructor as a Rational if numeric, and add a PgOverStr constructor-for overloaded strings.--}--groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]]--- If the result is of form [g1, g2, g3],--- (a) all the (pg,eq) pairs in g1 have the same pg--- (b) none of the gi are empty--- The ordering of equations is unchanged-groupEquations dflags eqns-  = runs same_gp [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns]-  where-    same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool-    (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2--subGroup :: (m -> [[EquationInfo]]) -- Map.elems-         -> m -- Map.empty-         -> (a -> m -> Maybe [EquationInfo]) -- Map.lookup-         -> (a -> [EquationInfo] -> m -> m) -- Map.insert-         -> [(a, EquationInfo)] -> [[EquationInfo]]--- Input is a particular group.  The result sub-groups the--- equations by with particular constructor, literal etc they match.--- Each sub-list in the result has the same PatGroup--- See Note [Take care with pattern order]--- Parameterized by map operations to allow different implementations--- and constraints, eg. types without Ord instance.-subGroup elems empty lookup insert group-    = map reverse $ elems $ foldl accumulate empty group-  where-    accumulate pg_map (pg, eqn)-      = case lookup pg pg_map of-          Just eqns -> insert pg (eqn:eqns) pg_map-          Nothing   -> insert pg [eqn]      pg_map-    -- pg_map :: Map a [EquationInfo]-    -- Equations seen so far in reverse order of appearance--subGroupOrd :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]-subGroupOrd = subGroup Map.elems Map.empty Map.lookup Map.insert--subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [[EquationInfo]]-subGroupUniq =-  subGroup eltsUDFM emptyUDFM (flip lookupUDFM) (\k v m -> addToUDFM m k v)--{- Note [Pattern synonym groups]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we see-  f (P a) = e1-  f (P b) = e2-    ...-where P is a pattern synonym, can we put (P a -> e1) and (P b -> e2) in the-same group?  We can if P is a constructor, but /not/ if P is a pattern synonym.-Consider (Trac #11224)-   -- readMaybe :: Read a => String -> Maybe a-   pattern PRead :: Read a => () => a -> String-   pattern PRead a <- (readMaybe -> Just a)--   f (PRead (x::Int))  = e1-   f (PRead (y::Bool)) = e2-This is all fine: we match the string by trying to read an Int; if that-fails we try to read a Bool. But clearly we can't combine the two into a single-match.--Conclusion: we can combine when we invoke PRead /at the same type/.  Hence-in PgSyn we record the instantiaing types, and use them in sameGroup.--Note [Take care with pattern order]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the subGroup function we must be very careful about pattern re-ordering,-Consider the patterns [ (True, Nothing), (False, x), (True, y) ]-Then in bringing together the patterns for True, we must not-swap the Nothing and y!--}--sameGroup :: PatGroup -> PatGroup -> Bool--- Same group means that a single case expression--- or test will suffice to match both, *and* the order--- of testing within the group is insignificant.-sameGroup PgAny         PgAny         = True-sameGroup PgBang        PgBang        = True-sameGroup (PgCon _)     (PgCon _)     = True    -- One case expression-sameGroup (PgSyn p1 t1) (PgSyn p2 t2) = p1==p2 && eqTypes t1 t2-                                                -- eqTypes: See Note [Pattern synonym groups]-sameGroup (PgLit _)     (PgLit _)     = True    -- One case expression-sameGroup (PgN l1)      (PgN l2)      = l1==l2  -- Order is significant-sameGroup (PgOverS s1)  (PgOverS s2)  = s1==s2-sameGroup (PgNpK l1)    (PgNpK l2)    = l1==l2  -- See Note [Grouping overloaded literal patterns]-sameGroup (PgCo t1)     (PgCo t2)     = t1 `eqType` t2-        -- CoPats are in the same goup only if the type of the-        -- enclosed pattern is the same. The patterns outside the CoPat-        -- always have the same type, so this boils down to saying that-        -- the two coercions are identical.-sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2)-       -- ViewPats are in the same group iff the expressions-       -- are "equal"---conservatively, we use syntactic equality-sameGroup _          _          = False---- An approximation of syntactic equality used for determining when view--- exprs are in the same group.--- This function can always safely return false;--- but doing so will result in the application of the view function being repeated.------ Currently: compare applications of literals and variables---            and anything else that we can do without involving other---            HsSyn types in the recursion------ NB we can't assume that the two view expressions have the same type.  Consider---   f (e1 -> True) = ...---   f (e2 -> "hi") = ...-viewLExprEq :: (LHsExpr Id,Type) -> (LHsExpr Id,Type) -> Bool-viewLExprEq (e1,_) (e2,_) = lexp e1 e2-  where-    lexp :: LHsExpr Id -> LHsExpr Id -> Bool-    lexp e e' = exp (unLoc e) (unLoc e')--    ----------    exp :: HsExpr Id -> HsExpr Id -> Bool-    -- real comparison is on HsExpr's-    -- strip parens-    exp (HsPar (L _ e)) e'   = exp e e'-    exp e (HsPar (L _ e'))   = exp e e'-    -- because the expressions do not necessarily have the same type,-    -- we have to compare the wrappers-    exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e'-    exp (HsVar i) (HsVar i') =  i == i'-    exp (HsConLikeOut c) (HsConLikeOut c') = c == c'-    -- the instance for IPName derives using the id, so this works if the-    -- above does-    exp (HsIPVar i) (HsIPVar i') = i == i'-    exp (HsOverLabel l x) (HsOverLabel l' x') = l == l' && x == x'-    exp (HsOverLit l) (HsOverLit l') =-        -- Overloaded lits are equal if they have the same type-        -- and the data is the same.-        -- this is coarser than comparing the SyntaxExpr's in l and l',-        -- which resolve the overloading (e.g., fromInteger 1),-        -- because these expressions get written as a bunch of different variables-        -- (presumably to improve sharing)-        eqType (overLitType l) (overLitType l') && l == l'-    exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2'-    -- the fixities have been straightened out by now, so it's safe-    -- to ignore them?-    exp (OpApp l o _ ri) (OpApp l' o' _ ri') =-        lexp l l' && lexp o o' && lexp ri ri'-    exp (NegApp e n) (NegApp e' n') = lexp e e' && syn_exp n n'-    exp (SectionL e1 e2) (SectionL e1' e2') =-        lexp e1 e1' && lexp e2 e2'-    exp (SectionR e1 e2) (SectionR e1' e2') =-        lexp e1 e1' && lexp e2 e2'-    exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) =-        eq_list tup_arg es1 es2-    exp (ExplicitSum _ _ e _) (ExplicitSum _ _ e' _) = lexp e e'-    exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') =-        lexp e e' && lexp e1 e1' && lexp e2 e2'--    -- Enhancement: could implement equality for more expressions-    --   if it seems useful-    -- But no need for HsLit, ExplicitList, ExplicitTuple,-    -- because they cannot be functions-    exp _ _  = False--    ----------    syn_exp :: SyntaxExpr Id -> SyntaxExpr Id -> Bool-    syn_exp (SyntaxExpr { syn_expr      = expr1-                        , syn_arg_wraps = arg_wraps1-                        , syn_res_wrap  = res_wrap1 })-            (SyntaxExpr { syn_expr      = expr2-                        , syn_arg_wraps = arg_wraps2-                        , syn_res_wrap  = res_wrap2 })-      = exp expr1 expr2 &&-        and (zipWithEqual "viewLExprEq" wrap arg_wraps1 arg_wraps2) &&-        wrap res_wrap1 res_wrap2--    ----------    tup_arg (L _ (Present e1)) (L _ (Present e2)) = lexp e1 e2-    tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2-    tup_arg _ _ = False--    ----------    wrap :: HsWrapper -> HsWrapper -> Bool-    -- Conservative, in that it demands that wrappers be-    -- syntactically identical and doesn't look under binders-    ---    -- Coarser notions of equality are possible-    -- (e.g., reassociating compositions,-    --        equating different ways of writing a coercion)-    wrap WpHole WpHole = True-    wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'-    wrap (WpFun w1 w2 _ _) (WpFun w1' w2' _ _) = wrap w1 w1' && wrap w2 w2'-    wrap (WpCast co)       (WpCast co')        = co `eqCoercion` co'-    wrap (WpEvApp et1)     (WpEvApp et2)       = et1 `ev_term` et2-    wrap (WpTyApp t)       (WpTyApp t')        = eqType t t'-    -- Enhancement: could implement equality for more wrappers-    --   if it seems useful (lams and lets)-    wrap _ _ = False--    ----------    ev_term :: EvTerm -> EvTerm -> Bool-    ev_term (EvId a)       (EvId b)       = a==b-    ev_term (EvCoercion a) (EvCoercion b) = a `eqCoercion` b-    ev_term _ _ = False--    ----------    eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool-    eq_list _  []     []     = True-    eq_list _  []     (_:_)  = False-    eq_list _  (_:_)  []     = False-    eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys--patGroup :: DynFlags -> Pat Id -> PatGroup-patGroup _ (ConPatOut { pat_con = L _ con-                      , pat_arg_tys = tys })- | RealDataCon dcon <- con              = PgCon dcon- | PatSynCon psyn <- con                = PgSyn psyn tys-patGroup _ (WildPat {})                 = PgAny-patGroup _ (BangPat {})                 = PgBang-patGroup _ (NPat (L _ OverLit {ol_val=oval}) mb_neg _ _) =-  case (oval, isJust mb_neg) of-   (HsIntegral _ i, False) -> PgN (fromInteger i)-   (HsIntegral _ i, True ) -> PgN (-fromInteger i)-   (HsFractional r, False) -> PgN (fl_value r)-   (HsFractional r, True ) -> PgN (-fl_value r)-   (HsIsString _ s, _) -> PgOverS s-patGroup _ (NPlusKPat _ (L _ OverLit {ol_val=oval}) _ _ _ _) =-  case oval of-   HsIntegral _ i -> PgNpK i-   _ -> pprPanic "patGroup NPlusKPat" (ppr oval)-patGroup _ (CoPat _ p _)                = PgCo  (hsPatType p) -- Type of innelexp pattern-patGroup _ (ViewPat expr p _)           = PgView expr (hsPatType (unLoc p))-patGroup _ (ListPat _ _ (Just _))       = PgOverloadedList-patGroup dflags (LitPat lit)            = PgLit (hsLitKey dflags lit)-patGroup _ pat                          = pprPanic "patGroup" (ppr pat)--{--Note [Grouping overloaded literal patterns]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-WATCH OUT!  Consider--        f (n+1) = ...-        f (n+2) = ...-        f (n+1) = ...--We can't group the first and third together, because the second may match-the same thing as the first.  Same goes for *overloaded* literal patterns-        f 1 True = ...-        f 2 False = ...-        f 1 False = ...-If the first arg matches '1' but the second does not match 'True', we-cannot jump to the third equation!  Because the same argument might-match '2'!-Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.--}
− src/Language/Haskell/Liquid/Desugar/Match.hs-boot 
@@ -1,34 +0,0 @@-module Language.Haskell.Liquid.Desugar.Match where-import Var      ( Id )-import TcType   ( Type )-import Language.Haskell.Liquid.Desugar.DsMonad  ( DsM, EquationInfo, MatchResult )-import CoreSyn  ( CoreExpr )-import HsSyn    ( LPat, HsMatchContext, MatchGroup, LHsExpr )-import Name     ( Name )--match   :: [Id]-        -> Type-        -> [EquationInfo]-        -> DsM MatchResult--matchWrapper-        :: HsMatchContext Name-        -> Maybe (LHsExpr Id)-        -> MatchGroup Id (LHsExpr Id)-        -> DsM ([Id], CoreExpr)--matchSimply-        :: CoreExpr-        -> HsMatchContext Name-        -> LPat Id-        -> CoreExpr-        -> CoreExpr-        -> DsM CoreExpr--matchSinglePat-        :: CoreExpr-        -> HsMatchContext Name-        -> LPat Id-        -> Type-        -> MatchResult-        -> DsM MatchResult
− src/Language/Haskell/Liquid/Desugar/MatchCon.hs 
@@ -1,281 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---Pattern-matching constructors--}--{-# LANGUAGE CPP #-}--module Language.Haskell.Liquid.Desugar.MatchCon ( matchConFamily, matchPatSyn ) where--import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.Match     ( match )--import HsSyn-import Language.Haskell.Liquid.Desugar.DsBinds-import ConLike-import TcType-import Language.Haskell.Liquid.Desugar.DsMonad-import Language.Haskell.Liquid.Desugar.DsUtils-import MkCore   ( mkCoreLets )-import Util-import ListSetOps ( runs )-import Id-import NameEnv-import FieldLabel ( flSelector )-import SrcLoc-import DynFlags-import Outputable-import Control.Monad(liftM)--{--We are confronted with the first column of patterns in a set of-equations, all beginning with constructors from one ``family'' (e.g.,-@[]@ and @:@ make up the @List@ ``family'').  We want to generate the-alternatives for a @Case@ expression.  There are several choices:-\begin{enumerate}-\item-Generate an alternative for every constructor in the family, whether-they are used in this set of equations or not; this is what the Wadler-chapter does.-\begin{description}-\item[Advantages:]-(a)~Simple.  (b)~It may also be that large sparsely-used constructor-families are mainly handled by the code for literals.-\item[Disadvantages:]-(a)~Not practical for large sparsely-used constructor families, e.g.,-the ASCII character set.  (b)~Have to look up a list of what-constructors make up the whole family.-\end{description}--\item-Generate an alternative for each constructor used, then add a default-alternative in case some constructors in the family weren't used.-\begin{description}-\item[Advantages:]-(a)~Alternatives aren't generated for unused constructors.  (b)~The-STG is quite happy with defaults.  (c)~No lookup in an environment needed.-\item[Disadvantages:]-(a)~A spurious default alternative may be generated.-\end{description}--\item-``Do it right:'' generate an alternative for each constructor used,-and add a default alternative if all constructors in the family-weren't used.-\begin{description}-\item[Advantages:]-(a)~You will get cases with only one alternative (and no default),-which should be amenable to optimisation.  Tuples are a common example.-\item[Disadvantages:]-(b)~Have to look up constructor families in TDE (as above).-\end{description}-\end{enumerate}--We are implementing the ``do-it-right'' option for now.  The arguments-to @matchConFamily@ are the same as to @match@; the extra @Int@-returned is the number of constructors in the family.--The function @matchConFamily@ is concerned with this-have-we-used-all-the-constructors? question; the local function-@match_cons_used@ does all the real work.--}--matchConFamily :: [Id]-               -> Type-               -> [[EquationInfo]]-               -> DsM MatchResult--- Each group of eqns is for a single constructor-matchConFamily (var:vars) ty groups-  = do dflags <- getDynFlags-       alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups-       return (mkCoAlgCaseMatchResult dflags var ty alts)-  where-    toRealAlt alt = case alt_pat alt of-        RealDataCon dcon -> alt{ alt_pat = dcon }-        _ -> panic "matchConFamily: not RealDataCon"-matchConFamily [] _ _ = panic "matchConFamily []"--matchPatSyn :: [Id]-            -> Type-            -> [EquationInfo]-            -> DsM MatchResult-matchPatSyn (var:vars) ty eqns-  = do alt <- fmap toSynAlt $ matchOneConLike vars ty eqns-       return (mkCoSynCaseMatchResult var ty alt)-  where-    toSynAlt alt = case alt_pat alt of-        PatSynCon psyn -> alt{ alt_pat = psyn }-        _ -> panic "matchPatSyn: not PatSynCon"-matchPatSyn _ _ _ = panic "matchPatSyn []"--type ConArgPats = HsConDetails (LPat Id) (HsRecFields Id (LPat Id))--matchOneConLike :: [Id]-                -> Type-                -> [EquationInfo]-                -> DsM (CaseAlt ConLike)-matchOneConLike vars ty (eqn1 : eqns)   -- All eqns for a single constructor-  = do  { let inst_tys = arg_tys ++ mkTyVarTys tvs1--              val_arg_tys = conLikeInstOrigArgTys con1 inst_tys-        -- dataConInstOrigArgTys takes the univ and existential tyvars-        -- and returns the types of the *value* args, which is what we want--              match_group :: [Id]-                          -> [(ConArgPats, EquationInfo)] -> DsM MatchResult-              -- All members of the group have compatible ConArgPats-              match_group arg_vars arg_eqn_prs-                = do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs)-                     ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs-                     ; match_result <- match (group_arg_vars ++ vars) ty eqns'-                     ; return (adjustMatchResult (foldr1 (.) wraps) match_result) }--              shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds,-                                                             pat_binds = bind, pat_args = args-                                                  } : pats }))-                = do ds_bind <- dsTcEvBinds bind-                     return ( wrapBinds (tvs `zip` tvs1)-                            . wrapBinds (ds  `zip` dicts1)-                            . mkCoreLets ds_bind-                            , eqn { eqn_pats = conArgPats val_arg_tys args ++ pats }-                            )-              shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)--        ; arg_vars <- selectConMatchVars val_arg_tys args1-                -- Use the first equation as a source of-                -- suggestions for the new variables--        -- Divide into sub-groups; see Note [Record patterns]-        ; let groups :: [[(ConArgPats, EquationInfo)]]-              groups = runs compatible_pats [ (pat_args (firstPat eqn), eqn)-                                            | eqn <- eqn1:eqns ]--        ; match_results <- mapM (match_group arg_vars) groups--        ; return $ MkCaseAlt{ alt_pat = con1,-                              alt_bndrs = tvs1 ++ dicts1 ++ arg_vars,-                              alt_wrapper = wrapper1,-                              alt_result = foldr1 combineMatchResults match_results } }-  where-    ConPatOut { pat_con = L _ con1, pat_arg_tys = arg_tys, pat_wrap = wrapper1,-                pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }-              = firstPat eqn1-    fields1 = map flSelector (conLikeFieldLabels con1)----     ex_tvs = conLikeExTyVars con1--    -- Choose the right arg_vars in the right order for this group-    -- Note [Record patterns]-    select_arg_vars :: [Id] -> [(ConArgPats, EquationInfo)] -> [Id]-    select_arg_vars arg_vars ((arg_pats, _) : _)-      | RecCon flds <- arg_pats-      , let rpats = rec_flds flds-      , not (null rpats)     -- Treated specially; cf conArgPats-      = map lookup_fld rpats-      | otherwise-      = arg_vars-      where-        fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars-        lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env-                                            (idName (unLoc (hsRecFieldId rpat)))-    select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"-matchOneConLike _ _ [] = panic "matchOneCon []"--------------------compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool--- Two constructors have compatible argument patterns if the number--- and order of sub-matches is the same in both cases-compatible_pats (RecCon flds1, _) (RecCon flds2, _) = same_fields flds1 flds2-compatible_pats (RecCon flds1, _) _                 = null (rec_flds flds1)-compatible_pats _                 (RecCon flds2, _) = null (rec_flds flds2)-compatible_pats _                 _                 = True -- Prefix or infix con--same_fields :: HsRecFields Id (LPat Id) -> HsRecFields Id (LPat Id) -> Bool-same_fields flds1 flds2-  = all2 (\(L _ f1) (L _ f2)-                          -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))-         (rec_flds flds1) (rec_flds flds2)---------------------selectConMatchVars :: [Type] -> ConArgPats -> DsM [Id]-selectConMatchVars arg_tys (RecCon {})      = newSysLocalsDsNoLP arg_tys-selectConMatchVars _       (PrefixCon ps)   = selectMatchVars (map unLoc ps)-selectConMatchVars _       (InfixCon p1 p2) = selectMatchVars [unLoc p1, unLoc p2]--conArgPats :: [Type]      -- Instantiated argument types-                          -- Used only to fill in the types of WildPats, which-                          -- are probably never looked at anyway-           -> ConArgPats-           -> [Pat Id]-conArgPats _arg_tys (PrefixCon ps)   = map unLoc ps-conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2]-conArgPats  arg_tys (RecCon (HsRecFields { rec_flds = rpats }))-  | null rpats = map WildPat arg_tys-        -- Important special case for C {}, which can be used for a-        -- datacon that isn't declared to have fields at all-  | otherwise  = map (unLoc . hsRecFieldArg . unLoc) rpats--{--Note [Record patterns]-~~~~~~~~~~~~~~~~~~~~~~-Consider-         data T = T { x,y,z :: Bool }--         f (T { y=True, x=False }) = ...--We must match the patterns IN THE ORDER GIVEN, thus for the first-one we match y=True before x=False.  See Trac #246; or imagine-matching against (T { y=False, x=undefined }): should fail without-touching the undefined.--Now consider:--         f (T { y=True, x=False }) = ...-         f (T { x=True, y= False}) = ...--In the first we must test y first; in the second we must test x-first.  So we must divide even the equations for a single constructor-T into sub-goups, based on whether they match the same field in the-same order.  That's what the (runs compatible_pats) grouping.--All non-record patterns are "compatible" in this sense, because the-positional patterns (T a b) and (a `T` b) all match the arguments-in order.  Also T {} is special because it's equivalent to (T _ _).-Hence the (null rpats) checks here and there.---Note [Existentials in shift_con_pat]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-        data T = forall a. Ord a => T a (a->Int)--        f (T x f) True  = ...expr1...-        f (T y g) False = ...expr2..--When we put in the tyvars etc we get--        f (T a (d::Ord a) (x::a) (f::a->Int)) True =  ...expr1...-        f (T b (e::Ord b) (y::a) (g::a->Int)) True =  ...expr2...--After desugaring etc we'll get a single case:--        f = \t::T b::Bool ->-            case t of-               T a (d::Ord a) (x::a) (f::a->Int)) ->-            case b of-                True  -> ...expr1...-                False -> ...expr2...--*** We have to substitute [a/b, d/e] in expr2! **-Hence-                False -> ....((/\b\(e:Ord b).expr2) a d)....--Originally I tried to use-        (\b -> let e = d in expr2) a-to do this substitution.  While this is "correct" in a way, it fails-Lint, because e::Ord b but d::Ord a.---}
− src/Language/Haskell/Liquid/Desugar/MatchLit.hs 
@@ -1,452 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---Pattern-matching literal patterns--}--{-# LANGUAGE CPP, ScopedTypeVariables #-}--module Language.Haskell.Liquid.Desugar.MatchLit ( dsLit, dsOverLit, dsOverLit', hsLitKey-                , tidyLitPat, tidyNPat-                , matchLiterals, matchNPlusKPats, matchNPats-                , warnAboutIdentities, warnAboutOverflowedLiterals-                , warnAboutEmptyEnumerations-                ) where--import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.Match  ( match )-import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr ( dsExpr, dsSyntaxExpr )--import Language.Haskell.Liquid.Desugar.DsMonad-import Language.Haskell.Liquid.Desugar.DsUtils--import HsSyn--import Id-import CoreSyn-import MkCore-import TyCon-import DataCon-import TcHsSyn ( shortCutLit )-import TcType-import Name-import Type-import PrelNames-import TysWiredIn-import Literal-import SrcLoc-import Data.Ratio-import Outputable-import BasicTypes-import DynFlags-import Util-import FastString-import qualified GHC.LanguageExtensions as LangExt--import Control.Monad-import Data.Int-import Data.Word--{--************************************************************************-*                                                                      *-                Desugaring literals-        [used to be in DsExpr, but DsMeta needs it,-         and it's nice to avoid a loop]-*                                                                      *-************************************************************************--We give int/float literals type @Integer@ and @Rational@, respectively.-The typechecker will (presumably) have put \tr{from{Integer,Rational}s}-around them.--ToDo: put in range checks for when converting ``@i@''-(or should that be in the typechecker?)--For numeric literals, we try to detect there use at a standard type-(@Int@, @Float@, etc.) are directly put in the right constructor.-[NB: down with the @App@ conversion.]--See also below where we look for @DictApps@ for \tr{plusInt}, etc.--}--dsLit :: HsLit -> DsM CoreExpr-dsLit (HsStringPrim _ s) = return (Lit (MachStr s))-dsLit (HsCharPrim   _ c) = return (Lit (MachChar c))-dsLit (HsIntPrim    _ i) = return (Lit (MachInt i))-dsLit (HsWordPrim   _ w) = return (Lit (MachWord w))-dsLit (HsInt64Prim  _ i) = return (Lit (MachInt64 i))-dsLit (HsWord64Prim _ w) = return (Lit (MachWord64 w))-dsLit (HsFloatPrim    f) = return (Lit (MachFloat (fl_value f)))-dsLit (HsDoublePrim   d) = return (Lit (MachDouble (fl_value d)))--dsLit (HsChar _ c)       = return (mkCharExpr c)-dsLit (HsString _ str)   = mkStringExprFS str-dsLit (HsInteger _ i _)  = mkIntegerExpr i-dsLit (HsInt _ i)        = do dflags <- getDynFlags-                              return (mkIntExpr dflags i)--dsLit (HsRat r ty) = do-   num   <- mkIntegerExpr (numerator (fl_value r))-   denom <- mkIntegerExpr (denominator (fl_value r))-   return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])-  where-    (ratio_data_con, integer_ty)-        = case tcSplitTyConApp ty of-                (tycon, [i_ty]) -> (head (tyConDataCons tycon), i_ty)-                x -> pprPanic "dsLit" (ppr x)--dsOverLit :: HsOverLit Id -> DsM CoreExpr-dsOverLit lit = do { dflags <- getDynFlags-                   ; warnAboutOverflowedLiterals dflags lit-                   ; dsOverLit' dflags lit }--dsOverLit' :: DynFlags -> HsOverLit Id -> DsM CoreExpr--- Post-typechecker, the HsExpr field of an OverLit contains--- (an expression for) the literal value itself-dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable-                           , ol_witness = witness, ol_type = ty })-  | not rebindable-  , Just expr <- shortCutLit dflags val ty = dsExpr expr        -- Note [Literal short cut]-  | otherwise                              = dsExpr witness--{--Note [Literal short cut]-~~~~~~~~~~~~~~~~~~~~~~~~-The type checker tries to do this short-cutting as early as possible, but-because of unification etc, more information is available to the desugarer.-And where it's possible to generate the correct literal right away, it's-much better to do so.---************************************************************************-*                                                                      *-                 Warnings about overflowed literals-*                                                                      *-************************************************************************--Warn about functions like toInteger, fromIntegral, that convert-between one type and another when the to- and from- types are the-same.  Then it's probably (albeit not definitely) the identity--}--warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM ()-warnAboutIdentities dflags (Var conv_fn) type_of_conv-  | wopt Opt_WarnIdentities dflags-  , idName conv_fn `elem` conversionNames-  , Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv-  , arg_ty `eqType` res_ty  -- So we are converting  ty -> ty-  = warnDs (Reason Opt_WarnIdentities)-           (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv-                 , nest 2 $ text "can probably be omitted"-           ])-warnAboutIdentities _ _ _ = return ()--conversionNames :: [Name]-conversionNames-  = [ toIntegerName, toRationalName-    , fromIntegralName, realToFracName ]- -- We can't easily add fromIntegerName, fromRationalName,- -- because they are generated by literals--warnAboutOverflowedLiterals :: DynFlags -> HsOverLit Id -> DsM ()-warnAboutOverflowedLiterals dflags lit- | wopt Opt_WarnOverflowedLiterals dflags- , Just (i, tc) <- getIntegralLit lit-  = if      tc == intTyConName    then check i tc (undefined :: Int)-    else if tc == int8TyConName   then check i tc (undefined :: Int8)-    else if tc == int16TyConName  then check i tc (undefined :: Int16)-    else if tc == int32TyConName  then check i tc (undefined :: Int32)-    else if tc == int64TyConName  then check i tc (undefined :: Int64)-    else if tc == wordTyConName   then check i tc (undefined :: Word)-    else if tc == word8TyConName  then check i tc (undefined :: Word8)-    else if tc == word16TyConName then check i tc (undefined :: Word16)-    else if tc == word32TyConName then check i tc (undefined :: Word32)-    else if tc == word64TyConName then check i tc (undefined :: Word64)-    else return ()--  | otherwise = return ()-  where-    check :: forall a. (Bounded a, Integral a) => Integer -> Name -> a -> DsM ()-    check i tc _proxy-      = when (i < minB || i > maxB) $ do-        warnDs (Reason Opt_WarnOverflowedLiterals)-               (vcat [ text "Literal" <+> integer i-                       <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range")-                       <+> integer minB <> text ".." <> integer maxB-                     , sug ])-      where-        minB = toInteger (minBound :: a)-        maxB = toInteger (maxBound :: a)-        sug | minB == -i   -- Note [Suggest NegativeLiterals]-            , i > 0-            , not (xopt LangExt.NegativeLiterals dflags)-            = text "If you are trying to write a large negative literal, use NegativeLiterals"-            | otherwise = Outputable.empty--{--Note [Suggest NegativeLiterals]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If you write-  x :: Int8-  x = -128-it'll parse as (negate 128), and overflow.  In this case, suggest NegativeLiterals.-We get an erroneous suggestion for-  x = 128-but perhaps that does not matter too much.--}--warnAboutEmptyEnumerations :: DynFlags -> LHsExpr Id -> Maybe (LHsExpr Id) -> LHsExpr Id -> DsM ()--- Warns about [2,3 .. 1] which returns the empty list--- Only works for integral types, not floating point-warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr-  | wopt Opt_WarnEmptyEnumerations dflags-  , Just (from,tc) <- getLHsIntegralLit fromExpr-  , Just mThn      <- traverse getLHsIntegralLit mThnExpr-  , Just (to,_)    <- getLHsIntegralLit toExpr-  , let check :: forall a. (Enum a, Num a) => a -> DsM ()-        check _proxy-          = when (null enumeration) $-            warnDs (Reason Opt_WarnEmptyEnumerations) (text "Enumeration is empty")-          where-            enumeration :: [a]-            enumeration = case mThn of-                            Nothing      -> [fromInteger from                    .. fromInteger to]-                            Just (thn,_) -> [fromInteger from, fromInteger thn   .. fromInteger to]--  = if      tc == intTyConName    then check (undefined :: Int)-    else if tc == int8TyConName   then check (undefined :: Int8)-    else if tc == int16TyConName  then check (undefined :: Int16)-    else if tc == int32TyConName  then check (undefined :: Int32)-    else if tc == int64TyConName  then check (undefined :: Int64)-    else if tc == wordTyConName   then check (undefined :: Word)-    else if tc == word8TyConName  then check (undefined :: Word8)-    else if tc == word16TyConName then check (undefined :: Word16)-    else if tc == word32TyConName then check (undefined :: Word32)-    else if tc == word64TyConName then check (undefined :: Word64)-    else if tc == integerTyConName then check (undefined :: Integer)-    else return ()--  | otherwise = return ()--getLHsIntegralLit :: LHsExpr Id -> Maybe (Integer, Name)--- See if the expression is an Integral literal--- Remember to look through automatically-added tick-boxes! (Trac #8384)-getLHsIntegralLit (L _ (HsPar e))            = getLHsIntegralLit e-getLHsIntegralLit (L _ (HsTick _ e))         = getLHsIntegralLit e-getLHsIntegralLit (L _ (HsBinTick _ _ e))    = getLHsIntegralLit e-getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit-getLHsIntegralLit _ = Nothing--getIntegralLit :: HsOverLit Id -> Maybe (Integer, Name)-getIntegralLit (OverLit { ol_val = HsIntegral _ i, ol_type = ty })-  | Just tc <- tyConAppTyCon_maybe ty-  = Just (i, tyConName tc)-getIntegralLit _ = Nothing--{--************************************************************************-*                                                                      *-        Tidying lit pats-*                                                                      *-************************************************************************--}--tidyLitPat :: HsLit -> Pat Id--- Result has only the following HsLits:---      HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim---      HsDoublePrim, HsStringPrim, HsString---  * HsInteger, HsRat, HsInt can't show up in LitPats---  * We get rid of HsChar right here-tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c)-tidyLitPat (HsString src s)-  | lengthFS s <= 1     -- Short string literals only-  = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon-                                             [mkCharLitPat src c, pat] [charTy])-                  (mkNilPat charTy) (unpackFS s)-        -- The stringTy is the type of the whole pattern, not-        -- the type to instantiate (:) or [] with!-tidyLitPat lit = LitPat lit-------------------tidyNPat :: (HsLit -> Pat Id)   -- How to tidy a LitPat-                 -- We need this argument because tidyNPat is called-                 -- both by Match and by Check, but they tidy LitPats-                 -- slightly differently; and we must desugar-                 -- literals consistently (see Trac #5117)-         -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Type-         -> Pat Id-tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty-        -- False: Take short cuts only if the literal is not using rebindable syntax-        ---        -- Once that is settled, look for cases where the type of the-        -- entire overloaded literal matches the type of the underlying literal,-        -- and in that case take the short cut-        -- NB: Watch out for weird cases like Trac #3382-        --        f :: Int -> Int-        --        f "blah" = 4-        --     which might be ok if we have 'instance IsString Int'-        ---  | not type_change, isIntTy ty,    Just int_lit <- mb_int_lit-                 = mk_con_pat intDataCon    (HsIntPrim    NoSourceText int_lit)-  | not type_change, isWordTy ty,   Just int_lit <- mb_int_lit-                 = mk_con_pat wordDataCon   (HsWordPrim   NoSourceText int_lit)-  | not type_change, isStringTy ty, Just str_lit <- mb_str_lit-                 = tidy_lit_pat (HsString NoSourceText str_lit)-     -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3-     -- If we do convert to the constructor form, we'll generate a case-     -- expression on a Float# or Double# and that's not allowed in Core; see-     -- Trac #9238 and Note [Rules for floating-point comparisons] in PrelRules-  where-    -- Sometimes (like in test case-    -- overloadedlists/should_run/overloadedlistsrun04), the SyntaxExprs include-    -- type-changing wrappers (for example, from Id Int to Int, for the identity-    -- type family Id). In these cases, we can't do the short-cut.-    type_change = not (outer_ty `eqType` ty)--    mk_con_pat :: DataCon -> HsLit -> Pat Id-    mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] [])--    mb_int_lit :: Maybe Integer-    mb_int_lit = case (mb_neg, val) of-                   (Nothing, HsIntegral _ i) -> Just i-                   (Just _,  HsIntegral _ i) -> Just (-i)-                   _ -> Nothing--    mb_str_lit :: Maybe FastString-    mb_str_lit = case (mb_neg, val) of-                   (Nothing, HsIsString _ s) -> Just s-                   _ -> Nothing--tidyNPat _ over_lit mb_neg eq outer_ty-  = NPat (noLoc over_lit) mb_neg eq outer_ty--{--************************************************************************-*                                                                      *-                Pattern matching on LitPat-*                                                                      *-************************************************************************--}--matchLiterals :: [Id]-              -> Type                   -- Type of the whole case expression-              -> [[EquationInfo]]       -- All PgLits-              -> DsM MatchResult--matchLiterals (var:vars) ty sub_groups-  = do  {       -- Deal with each group-        ; alts <- mapM match_group sub_groups--                -- Combine results.  For everything except String-                -- we can use a case expression; for String we need-                -- a chain of if-then-else-        ; if isStringTy (idType var) then-            do  { eq_str <- dsLookupGlobalId eqStringName-                ; mrs <- mapM (wrap_str_guard eq_str) alts-                ; return (foldr1 combineMatchResults mrs) }-          else-            return (mkCoPrimCaseMatchResult var ty alts)-        }-  where-    match_group :: [EquationInfo] -> DsM (Literal, MatchResult)-    match_group eqns-        = do dflags <- getDynFlags-             let LitPat hs_lit = firstPat (head eqns)-             match_result <- match vars ty (shiftEqns eqns)-             return (hsLitKey dflags hs_lit, match_result)--    wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult-        -- Equality check for string literals-    wrap_str_guard eq_str (MachStr s, mr)-        = do { -- We now have to convert back to FastString. Perhaps there-               -- should be separate MachBytes and MachStr constructors?-               let s'  = mkFastStringByteString s-             ; lit    <- mkStringExprFS s'-             ; let pred = mkApps (Var eq_str) [Var var, lit]-             ; return (mkGuardedMatchResult pred mr) }-    wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)--matchLiterals [] _ _ = panic "matchLiterals []"------------------------------hsLitKey :: DynFlags -> HsLit -> Literal--- Get the Core literal corresponding to a HsLit.--- It only works for primitive types and strings;--- others have been removed by tidy--- For HsString, it produces a MachStr, which really represents an _unboxed_--- string literal; and we deal with it in matchLiterals above. Otherwise, it--- produces a primitive Literal of type matching the original HsLit.--- In the case of the fixed-width numeric types, we need to wrap here--- because Literal has an invariant that the literal is in range, while--- HsLit does not.-hsLitKey dflags (HsIntPrim    _ i) = mkMachIntWrap  dflags i-hsLitKey dflags (HsWordPrim   _ w) = mkMachWordWrap dflags w-hsLitKey _      (HsInt64Prim  _ i) = mkMachInt64Wrap       i-hsLitKey _      (HsWord64Prim _ w) = mkMachWord64Wrap      w-hsLitKey _      (HsCharPrim   _ c) = mkMachChar            c-hsLitKey _      (HsFloatPrim    f) = mkMachFloat           (fl_value f)-hsLitKey _      (HsDoublePrim   d) = mkMachDouble          (fl_value d)-hsLitKey _      (HsString _ s)     = MachStr (fastStringToByteString s)-hsLitKey _      l                  = pprPanic "hsLitKey" (ppr l)--{--************************************************************************-*                                                                      *-                Pattern matching on NPat-*                                                                      *-************************************************************************--}--matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult-matchNPats (var:vars) ty (eqn1:eqns)    -- All for the same literal-  = do  { let NPat (L _ lit) mb_neg eq_chk _ = firstPat eqn1-        ; lit_expr <- dsOverLit lit-        ; neg_lit <- case mb_neg of-                            Nothing  -> return lit_expr-                            Just neg -> dsSyntaxExpr neg [lit_expr]-        ; pred_expr <- dsSyntaxExpr eq_chk [Var var, neg_lit]-        ; match_result <- match vars ty (shiftEqns (eqn1:eqns))-        ; return (mkGuardedMatchResult pred_expr match_result) }-matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))--{--************************************************************************-*                                                                      *-                Pattern matching on n+k patterns-*                                                                      *-************************************************************************--For an n+k pattern, we use the various magic expressions we've been given.-We generate:-\begin{verbatim}-    if ge var lit then-        let n = sub var lit-        in  <expr-for-a-successful-match>-    else-        <try-next-pattern-or-whatever>-\end{verbatim}--}--matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult--- All NPlusKPats, for the *same* literal k-matchNPlusKPats (var:vars) ty (eqn1:eqns)-  = do  { let NPlusKPat (L _ n1) (L _ lit1) lit2 ge minus _ = firstPat eqn1-        ; lit1_expr   <- dsOverLit lit1-        ; lit2_expr   <- dsOverLit lit2-        ; pred_expr   <- dsSyntaxExpr ge    [Var var, lit1_expr]-        ; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr]-        ; let (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)-        ; match_result <- match vars ty eqns'-        ; return  (mkGuardedMatchResult pred_expr               $-                   mkCoLetMatchResult (NonRec n1 minusk_expr)   $-                   adjustMatchResult (foldr1 (.) wraps)         $-                   match_result) }-  where-    shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ _ _ : pats })-        = (wrapBind n n1, eqn { eqn_pats = pats })-        -- The wrapBind is a no-op for the first equation-    shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)--matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns))
− src/Language/Haskell/Liquid/Desugar/StaticPtrTable.hs 
@@ -1,97 +0,0 @@--- | Code generation for the Static Pointer Table------ (c) 2014 I/O Tweag------ Each module that uses 'static' keyword declares an initialization function of--- the form hs_spt_init_<module>() which is emitted into the _stub.c file and--- annotated with __attribute__((constructor)) so that it gets executed at--- startup time.------ The function's purpose is to call hs_spt_insert to insert the static--- pointers of this module in the hashtable of the RTS, and it looks something--- like this:------ > static void hs_hpc_init_Main(void) __attribute__((constructor));--- > static void hs_hpc_init_Main(void) {--- >--- >   static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};--- >   extern StgPtr Main_sptEntryZC0_closure;--- >   hs_spt_insert(k0, &Main_sptEntryZC0_closure);--- >--- >   static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};--- >   extern StgPtr Main_sptEntryZC1_closure;--- >   hs_spt_insert(k1, &Main_sptEntryZC1_closure);--- >--- > }------ where the constants are fingerprints produced from the static forms.------ There is also a finalization function for the time when the module is--- unloaded.------ > static void hs_hpc_fini_Main(void) __attribute__((destructor));--- > static void hs_hpc_fini_Main(void) {--- >--- >   static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};--- >   hs_spt_remove(k0);--- >--- >   static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};--- >   hs_spt_remove(k1);--- >--- > }----module Language.Haskell.Liquid.Desugar.StaticPtrTable (sptInitCode) where--import CoreSyn-import Module-import Outputable-import Id-import CLabel-import GHC.Fingerprint----- | @sptInitCode module statics@ is a C stub to insert the static entries--- @statics@ of @module@ into the static pointer table.------ Each entry contains the fingerprint used to locate the entry and the--- top-level binding for the entry.----sptInitCode :: Module -> [(Fingerprint, (Id,CoreExpr))] -> SDoc-sptInitCode _ [] = Outputable.empty-sptInitCode this_mod entries = vcat-    [ text "static void hs_spt_init_" <> ppr this_mod-           <> text "(void) __attribute__((constructor));"-    , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)"-    , braces $ vcat $-        [  text "static StgWord64 k" <> int i <> text "[2] = "-           <> pprFingerprint fp <> semi-        $$ text "extern StgPtr "-           <> (ppr $ mkClosureLabel (idName n) (idCafInfo n)) <> semi-        $$ text "hs_spt_insert" <> parens-             (hcat $ punctuate comma-                [ char 'k' <> int i-                , char '&' <> ppr (mkClosureLabel (idName n) (idCafInfo n))-                ]-             )-        <> semi-        |  (i, (fp, (n, _))) <- zip [0..] entries-        ]-    , text "static void hs_spt_fini_" <> ppr this_mod-           <> text "(void) __attribute__((destructor));"-    , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)"-    , braces $ vcat $-        [  text "StgWord64 k" <> int i <> text "[2] = "-           <> pprFingerprint fp <> semi-        $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi-        | (i, (fp, _)) <- zip [0..] entries-        ]-    ]--  where--    pprFingerprint :: Fingerprint -> SDoc-    pprFingerprint (Fingerprint w1 w2) =-      braces $ hcat $ punctuate comma-                 [ integer (fromIntegral w1) <> text "ULL"-                 , integer (fromIntegral w2) <> text "ULL"-                 ]
− src/Language/Haskell/Liquid/Desugar/TmOracle.hs 
@@ -1,255 +0,0 @@-{--Author: George Karachalias <george.karachalias@cs.kuleuven.be>--The term equality oracle. The main export of the module is function `tmOracle'.--}--{-# LANGUAGE CPP, MultiWayIf #-}--module Language.Haskell.Liquid.Desugar.TmOracle (--        -- re-exported from PmExpr-        PmExpr(..), PmLit(..), SimpleEq, ComplexEq, PmVarEnv, falsePmExpr,-        eqPmLit, filterComplex, isNotPmExprOther, runPmPprM, lhsExprToPmExpr,-        hsExprToPmExpr, pprPmExprWithParens,--        -- the term oracle-        tmOracle, TmState, initialTmState, solveOneEq, extendSubst, canDiverge,--        -- misc.-        toComplex, exprDeepLookup, pmLitType, flattenPmVarEnv-    ) where--import PmExpr--import Id-import Name-import Type-import HsLit-import TcHsSyn-import MonadUtils-import Util--import NameEnv--{--%************************************************************************-%*                                                                      *-                      The term equality oracle-%*                                                                      *-%************************************************************************--}---- | The type of substitutions.-type PmVarEnv = NameEnv PmExpr---- | The environment of the oracle contains---     1. A Bool (are there any constraints we cannot handle? (PmExprOther)).---     2. A substitution we extend with every step and return as a result.-type TmOracleEnv = (Bool, PmVarEnv)---- | Check whether a constraint (x ~ BOT) can succeed,--- given the resulting state of the term oracle.-canDiverge :: Name -> TmState -> Bool-canDiverge x (standby, (_unhandled, env))-  -- If the variable seems not evaluated, there is a possibility for-  -- constraint x ~ BOT to be satisfiable.-  | PmExprVar y <- varDeepLookup env x -- seems not forced-  -- If it is involved (directly or indirectly) in any equality in the-  -- worklist, we can assume that it is already indirectly evaluated,-  -- as a side-effect of equality checking. If not, then we can assume-  -- that the constraint is satisfiable.-  = not $ any (isForcedByEq x) standby || any (isForcedByEq y) standby-  -- Variable x is already in WHNF so the constraint is non-satisfiable-  | otherwise = False--  where-    isForcedByEq :: Name -> ComplexEq -> Bool-    isForcedByEq y (e1, e2) = varIn y e1 || varIn y e2---- | Check whether a variable is in the free variables of an expression-varIn :: Name -> PmExpr -> Bool-varIn x e = case e of-  PmExprVar y    -> x == y-  PmExprCon _ es -> any (x `varIn`) es-  PmExprLit _    -> False-  PmExprEq e1 e2 -> (x `varIn` e1) || (x `varIn` e2)-  PmExprOther _  -> False---- | Flatten the DAG (Could be improved in terms of performance.).-flattenPmVarEnv :: PmVarEnv -> PmVarEnv-flattenPmVarEnv env = mapNameEnv (exprDeepLookup env) env---- | The state of the term oracle (includes complex constraints that cannot--- progress unless we get more information).-type TmState = ([ComplexEq], TmOracleEnv)---- | Initial state of the oracle.-initialTmState :: TmState-initialTmState = ([], (False, emptyNameEnv))---- | Solve a complex equality (top-level).-solveOneEq :: TmState -> ComplexEq -> Maybe TmState-solveOneEq solver_env@(_,(_,env)) complex-  = solveComplexEq solver_env -- do the actual *merging* with existing state-  $ simplifyComplexEq               -- simplify as much as you can-  $ applySubstComplexEq env complex -- replace everything we already know---- | Solve a complex equality.-solveComplexEq :: TmState -> ComplexEq -> Maybe TmState-solveComplexEq solver_state@(standby, (unhandled, env)) eq@(e1, e2) = case eq of-  -- We cannot do a thing about these cases-  (PmExprOther _,_)            -> Just (standby, (True, env))-  (_,PmExprOther _)            -> Just (standby, (True, env))--  (PmExprLit l1, PmExprLit l2) -> case eqPmLit l1 l2 of-    -- See Note [Undecidable Equality for Overloaded Literals]-    True  -> Just solver_state-    False -> Nothing--  (PmExprCon c1 ts1, PmExprCon c2 ts2)-    | c1 == c2  -> foldlM solveComplexEq solver_state (zip ts1 ts2)-    | otherwise -> Nothing-  (PmExprCon _ [], PmExprEq t1 t2)-    | isTruePmExpr e1  -> solveComplexEq solver_state (t1, t2)-    | isFalsePmExpr e1 -> Just (eq:standby, (unhandled, env))-  (PmExprEq t1 t2, PmExprCon _ [])-    | isTruePmExpr e2   -> solveComplexEq solver_state (t1, t2)-    | isFalsePmExpr e2  -> Just (eq:standby, (unhandled, env))--  (PmExprVar x, PmExprVar y)-    | x == y    -> Just solver_state-    | otherwise -> extendSubstAndSolve x e2 solver_state--  (PmExprVar x, _) -> extendSubstAndSolve x e2 solver_state-  (_, PmExprVar x) -> extendSubstAndSolve x e1 solver_state--  (PmExprEq _ _, PmExprEq _ _) -> Just (eq:standby, (unhandled, env))--  _ -> Just (standby, (True, env)) -- I HATE CATCH-ALLS---- | Extend the substitution and solve the (possibly updated) constraints.-extendSubstAndSolve :: Name -> PmExpr -> TmState -> Maybe TmState-extendSubstAndSolve x e (standby, (unhandled, env))-  = foldlM solveComplexEq new_incr_state (map simplifyComplexEq changed)-  where-    -- Apply the substitution to the worklist and partition them to the ones-    -- that had some progress and the rest. Then, recurse over the ones that-    -- had some progress. Careful about performance:-    -- See Note [Representation of Term Equalities] in deSugar/Check.hs-    (changed, unchanged) = partitionWith (substComplexEq x e) standby-    new_incr_state       = (unchanged, (unhandled, extendNameEnv env x e))---- | When we know that a variable is fresh, we do not actually have to--- check whether anything changes, we know that nothing does. Hence,--- `extendSubst` simply extends the substitution, unlike what--- `extendSubstAndSolve` does.-extendSubst :: Id -> PmExpr -> TmState -> TmState-extendSubst y e (standby, (unhandled, env))-  | isNotPmExprOther simpl_e-  = (standby, (unhandled, extendNameEnv env x simpl_e))-  | otherwise = (standby, (True, env))-  where-    x = idName y-    simpl_e = fst $ simplifyPmExpr $ exprDeepLookup env e---- | Simplify a complex equality.-simplifyComplexEq :: ComplexEq -> ComplexEq-simplifyComplexEq (e1, e2) = (fst $ simplifyPmExpr e1, fst $ simplifyPmExpr e2)---- | Simplify an expression. The boolean indicates if there has been any--- simplification or if the operation was a no-op.-simplifyPmExpr :: PmExpr -> (PmExpr, Bool)--- See Note [Deep equalities]-simplifyPmExpr e = case e of-  PmExprCon c ts -> case mapAndUnzip simplifyPmExpr ts of-                      (ts', bs) -> (PmExprCon c ts', or bs)-  PmExprEq t1 t2 -> simplifyEqExpr t1 t2-  _other_expr    -> (e, False) -- the others are terminals---- | Simplify an equality expression. The equality is given in parts.-simplifyEqExpr :: PmExpr -> PmExpr -> (PmExpr, Bool)--- See Note [Deep equalities]-simplifyEqExpr e1 e2 = case (e1, e2) of-  -- Varables-  (PmExprVar x, PmExprVar y)-    | x == y -> (truePmExpr, True)--  -- Literals-  (PmExprLit l1, PmExprLit l2) -> case eqPmLit l1 l2 of-    -- See Note [Undecidable Equality for Overloaded Literals]-    True  -> (truePmExpr,  True)-    False -> (falsePmExpr, True)--  -- Can potentially be simplified-  (PmExprEq {}, _) -> case (simplifyPmExpr e1, simplifyPmExpr e2) of-    ((e1', True ), (e2', _    )) -> simplifyEqExpr e1' e2'-    ((e1', _    ), (e2', True )) -> simplifyEqExpr e1' e2'-    ((e1', False), (e2', False)) -> (PmExprEq e1' e2', False) -- cannot progress-  (_, PmExprEq {}) -> case (simplifyPmExpr e1, simplifyPmExpr e2) of-    ((e1', True ), (e2', _    )) -> simplifyEqExpr e1' e2'-    ((e1', _    ), (e2', True )) -> simplifyEqExpr e1' e2'-    ((e1', False), (e2', False)) -> (PmExprEq e1' e2', False) -- cannot progress--  -- Constructors-  (PmExprCon c1 ts1, PmExprCon c2 ts2)-    | c1 == c2 ->-        let (ts1', bs1) = mapAndUnzip simplifyPmExpr ts1-            (ts2', bs2) = mapAndUnzip simplifyPmExpr ts2-            (tss, _bss) = zipWithAndUnzip simplifyEqExpr ts1' ts2'-            worst_case  = PmExprEq (PmExprCon c1 ts1') (PmExprCon c2 ts2')-        in  if | not (or bs1 || or bs2) -> (worst_case, False) -- no progress-               | all isTruePmExpr  tss  -> (truePmExpr, True)-               | any isFalsePmExpr tss  -> (falsePmExpr, True)-               | otherwise              -> (worst_case, False)-    | otherwise -> (falsePmExpr, True)--  -- We cannot do anything about the rest..-  _other_equality -> (original, False)--  where-    original = PmExprEq e1 e2 -- reconstruct equality---- | Apply an (un-flattened) substitution to a simple equality.-applySubstComplexEq :: PmVarEnv -> ComplexEq -> ComplexEq-applySubstComplexEq env (e1,e2) = (exprDeepLookup env e1, exprDeepLookup env e2)---- | Apply an (un-flattened) substitution to a variable.-varDeepLookup :: PmVarEnv -> Name -> PmExpr-varDeepLookup env x-  | Just e <- lookupNameEnv env x = exprDeepLookup env e -- go deeper-  | otherwise                  = PmExprVar x          -- terminal-{-# INLINE varDeepLookup #-}---- | Apply an (un-flattened) substitution to an expression.-exprDeepLookup :: PmVarEnv -> PmExpr -> PmExpr-exprDeepLookup env (PmExprVar x)    = varDeepLookup env x-exprDeepLookup env (PmExprCon c es) = PmExprCon c (map (exprDeepLookup env) es)-exprDeepLookup env (PmExprEq e1 e2) = PmExprEq (exprDeepLookup env e1)-                                               (exprDeepLookup env e2)-exprDeepLookup _   other_expr       = other_expr -- PmExprLit, PmExprOther---- | External interface to the term oracle.-tmOracle :: TmState -> [ComplexEq] -> Maybe TmState-tmOracle tm_state eqs = foldlM solveOneEq tm_state eqs---- | Type of a PmLit-pmLitType :: PmLit -> Type -- should be in PmExpr but gives cyclic imports :(-pmLitType (PmSLit   lit) = hsLitType   lit-pmLitType (PmOLit _ lit) = overLitType lit--{- Note [Deep equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~-Solving nested equalities is the most difficult part. The general strategy-is the following:--  * Equalities of the form (True ~ (e1 ~ e2)) are transformed to just-    (e1 ~ e2) and then treated recursively.--  * Equalities of the form (False ~ (e1 ~ e2)) cannot be analyzed unless-    we know more about the inner equality (e1 ~ e2). That's exactly what-    `simplifyEqExpr' tries to do: It takes e1 and e2 and either returns-    truePmExpr, falsePmExpr or (e1' ~ e2') in case it is uncertain. Note-    that it is not e but rather e', since it may perform some-    simplifications deeper.--}
+ src/Language/Haskell/Liquid/GHC.hs view
@@ -0,0 +1,6 @@+-- | 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
@@ -0,0 +1,47 @@+-- | This module re-exports a bunch of the GHC API.++module Language.Haskell.Liquid.GHC.API (module Ghc) where ++import GHC            as Ghc+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 NameSet        as Ghc+import InstEnv        as Ghc +import Type           as Ghc hiding (typeKind) +import TyCoRep        as Ghc +import Class          as Ghc+import Unique         as Ghc+import RdrName        as Ghc+import SrcLoc         as Ghc +import Name           as Ghc hiding (varName) +++-- import TyCon          as Ghc +-- import DataCon        as Ghc ++import TysPrim        as Ghc+import HscTypes       as Ghc+import HscMain        as Ghc +import Id             as Ghc hiding (lazySetIdInfo, setIdExported, setIdNotExported) ++-- 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)+
src/Language/Haskell/Liquid/GHC/Interface.hs view
@@ -5,19 +5,23 @@ {-# LANGUAGE TupleSections              #-} {-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE PartialTypeSignatures      #-}  module Language.Haskell.Liquid.GHC.Interface ( -  -- * extract all information needed for verification-    getGhcInfos+  -- * Determine the build-order for target files+   realTargets++  -- * Extract all information needed for verification+  , getGhcInfos   , runLiquidGhc -  -- * printer+  -- * Printer   , pprintCBs    -- * predicates-  , isExportedVar-  , exportedVars+  -- , isExportedVar+  -- , exportedVars   ) where  import Prelude hiding (error)@@ -26,7 +30,9 @@ import GHC hiding (Target, Located, desugarModule) import qualified GHC import GHC.Paths (libdir)+import GHC.Serialized +import qualified Language.Haskell.Liquid.GHC.API as Ghc import Annotations import Class import CoreMonad@@ -42,11 +48,14 @@ import InstEnv import Module import Panic (throwGhcExceptionIO)-import Serialized+-- import Serialized import TcRnTypes import Var-import NameSet+-- import NameSet import FastString+import FamInstEnv+import FamInst+import qualified TysPrim import GHC.LanguageExtensions  import Control.Exception@@ -60,37 +69,85 @@ import Data.Generics.Aliases (mkT) import Data.Generics.Schemes (everywhere) -import qualified Data.HashSet as S-import qualified Data.Map as M+import qualified Data.HashSet        as S+import qualified Data.Map            as M  import System.Console.CmdArgs.Verbosity hiding (Loud) import System.Directory import System.FilePath import System.IO.Temp- import Text.Parsec.Pos-import Text.PrettyPrint.HughesPJ hiding (first)--import Language.Fixpoint.Types hiding (panic, Error, Result, Expr)-import Language.Fixpoint.Misc-+import Text.PrettyPrint.HughesPJ        hiding (first, (<>))+import Language.Fixpoint.Types          hiding (panic, Error, Result, Expr)+import qualified Language.Fixpoint.Misc as Misc import Language.Haskell.Liquid.Bare import Language.Haskell.Liquid.GHC.Misc import Language.Haskell.Liquid.GHC.Play-import qualified Language.Haskell.Liquid.Measure as Ms-import Language.Haskell.Liquid.Misc+import Language.Haskell.Liquid.WiredIn (isDerivedInstance) +import qualified Language.Haskell.Liquid.Measure  as Ms+import qualified Language.Haskell.Liquid.Misc     as Misc import Language.Haskell.Liquid.Parse import Language.Haskell.Liquid.Transforms.ANF-import Language.Haskell.Liquid.Types-import Language.Haskell.Liquid.Types.PrettyPrint-import Language.Haskell.Liquid.Types.Visitors+import Language.Haskell.Liquid.Types hiding (Spec)+-- import Language.Haskell.Liquid.Types.PrettyPrint+-- import Language.Haskell.Liquid.Types.Visitors import Language.Haskell.Liquid.UX.CmdLine import Language.Haskell.Liquid.UX.Config (totalityCheck) import Language.Haskell.Liquid.UX.QuasiQuoter import Language.Haskell.Liquid.UX.Tidy import Language.Fixpoint.Utils.Files +import qualified Debug.Trace as Debug + --------------------------------------------------------------------------------+{- | @realTargets mE cfg targets@ uses `Interface.configureGhcTargets` to +     return a list of files++       [i1, i2, ... ] ++ [f1, f2, ...]++     1. Where each file only (transitively imports) PRECEDIING ones; +     2. `f1..` are a permutation of the original `targets`;+     3. `i1..` either don't have "fresh" .bspec files. ++ -}+--------------------------------------------------------------------------------+realTargets :: Maybe HscEnv -> Config -> [FilePath] -> IO [FilePath] +realTargets  mbEnv cfg tgtFs +  | noCheckImports cfg = return tgtFs+  | otherwise          = do +    incDir   <- Misc.getIncludeDir +    allFs    <- orderTargets mbEnv cfg tgtFs+    let srcFs = filter (not . Misc.isIncludeFile incDir) allFs+    realFs   <- filterM check srcFs+    dir      <- getCurrentDirectory+    return      (makeRelative dir <$> realFs)+  where +    check f    = not <$> skipTarget tgts f +    tgts       = S.fromList tgtFs++orderTargets :: Maybe HscEnv -> Config -> [FilePath] -> IO [FilePath] +orderTargets mbEnv cfg tgtFiles = runLiquidGhc mbEnv cfg $ do +  homeModules <- configureGhcTargets tgtFiles+  return         (modSummaryHsFile <$> mgModSummaries homeModules)+++skipTarget :: S.HashSet FilePath -> FilePath -> IO Bool+skipTarget tgts f +  | S.member f tgts = return False          -- Always check target file +  | otherwise       = hasFreshBinSpec f     -- But skip an import with fresh .bspec++hasFreshBinSpec :: FilePath -> IO Bool+hasFreshBinSpec srcF = do +  let specF = extFileName BinSpec srcF+  srcMb    <- Misc.lastModified srcF +  specMb   <- Misc.lastModified specF +  case (srcMb, specMb) of +    (Just srcT, Just specT) -> return (srcT < specT)+    _                       -> return False++++-------------------------------------------------------------------------------- -- | GHC Interface Pipeline ---------------------------------------------------- -------------------------------------------------------------------------------- @@ -105,11 +162,9 @@ checkFilePresent :: FilePath -> IO () checkFilePresent f = do   b <- doesFileExist f-  when (not b) $ panic Nothing ("Cannot find file: " ++ f)+  unless b $ panic Nothing ("Cannot find file: " ++ f) -getGhcInfos' :: Config -> Either Error LogicMap-            -> [FilePath]-            -> Ghc ([GhcInfo], HscEnv)+getGhcInfos' :: Config -> LogicMap -> [FilePath] -> Ghc ([GhcInfo], HscEnv) getGhcInfos' cfg logicMap tgtFiles = do   _           <- compileCFiles cfg   homeModules <- configureGhcTargets tgtFiles@@ -119,13 +174,12 @@   return (ghcInfos, hscEnv)  createTempDirectoryIfMissing :: FilePath -> IO ()-createTempDirectoryIfMissing tgtFile = tryIgnore "create temp directory" $+createTempDirectoryIfMissing tgtFile = Misc.tryIgnore "create temp directory" $   createDirectoryIfMissing False $ tempDirectory tgtFile  -------------------------------------------------------------------------------- -- | GHC Configuration & Setup ------------------------------------------------- --------------------------------------------------------------------------------- runLiquidGhc :: Maybe HscEnv -> Config -> Ghc a -> IO a runLiquidGhc hscEnv cfg act =   withSystemTempDirectory "liquid" $ \tmp ->@@ -134,6 +188,9 @@       df <- configureDynFlags cfg tmp       prettyPrintGhcErrors df act +updateIncludePaths :: DynFlags -> [FilePath] -> IncludeSpecs +updateIncludePaths df ps = addGlobalInclude (includePaths df) ps + configureDynFlags :: Config -> FilePath -> Ghc DynFlags configureDynFlags cfg tmp = do   df <- getSessionDynFlags@@ -141,12 +198,13 @@   loud <- liftIO isLoud   let df'' = df' { importPaths  = nub $ idirs cfg ++ importPaths df'                  , libraryPaths = nub $ idirs cfg ++ libraryPaths df'-                 , includePaths = nub $ idirs cfg ++ includePaths df'+                 , includePaths = updateIncludePaths df' (idirs cfg) -- addGlobalInclude (includePaths df') (idirs cfg)                   , packageFlags = ExposePackage ""                                                 (PackageArg "ghc-prim")                                                 (ModRenaming True [])                                 : (packageFlags df') +                 , debugLevel   = 1               -- insert SourceNotes                  -- , profAuto     = ProfAutoCalls                  , ghcLink      = LinkInMemory                  , hscTarget    = HscInterpreted@@ -161,6 +219,7 @@                  , stubDir      = Just tmp                  } `gopt_set` Opt_ImplicitImportQualified                    `gopt_set` Opt_PIC+                   `gopt_set` Opt_DeferTypedHoles                    `xopt_set` MagicHash                    `xopt_set` DeriveGeneric                    `xopt_set` StandaloneDeriving@@ -171,20 +230,14 @@ configureGhcTargets tgtFiles = do   targets         <- mapM (`guessTarget` Nothing) tgtFiles   _               <- setTargets targets-  moduleGraph     <- depanal [] False-                     -- NOTE: drop hs-boot files from the graph.-                     -- we do it manually rather than using the flag to topSortModuleGraph-                     -- because otherwise the order of mutually recursive modules depends-                     -- on the modulename, e.g. given-                     --   Bar.hs --> Foo.hs --> Bar.hs-boot-                     -- we'll get-                     --   [Bar.hs, Foo.hs]-                     -- wich is backwards..+  moduleGraph     <- depanal [] False -- see [NOTE:DROP-BOOT-FILES]+   let homeModules  = filter (not . isBootSummary) $                      flattenSCCs $ topSortModuleGraph False moduleGraph Nothing   let homeNames    = moduleName . ms_mod <$> homeModules   _               <- setTargetModules homeNames-  return homeModules+  liftIO $ whenLoud $ print    ("Module Dependencies", homeNames)+  return $ mkModuleGraph homeModules  setTargetModules :: [ModuleName] -> Ghc () setTargetModules modNames = setTargets $ mkTarget <$> modNames@@ -195,7 +248,7 @@ compileCFiles cfg = do   df  <- getSessionDynFlags   _   <- setSessionDynFlags $-           df { includePaths = nub $ idirs cfg ++ includePaths df+           df { includePaths = updateIncludePaths df (idirs cfg)                , importPaths  = nub $ idirs cfg ++ importPaths df               , libraryPaths = nub $ idirs cfg ++ libraryPaths df }   hsc <- getSession@@ -203,6 +256,19 @@   df  <- getSessionDynFlags   void $ setSessionDynFlags $ df { ldInputs = nub $ map (FileOption "") os ++ ldInputs df } +{- | [NOTE:DROP-BOOT-FILES] Drop hs-boot files from the graph.+      We do it manually rather than using the flag to topSortModuleGraph+      because otherwise the order of mutually recursive modules depends+      on the modulename, e.g. given++      Bar.hs --> Foo.hs --> Bar.hs-boot++      we'll get+      +      [Bar.hs, Foo.hs]+    +      which is backwards..+ -} -------------------------------------------------------------------------------- -- Home Module Dependency Graph ------------------------------------------------ --------------------------------------------------------------------------------@@ -212,15 +278,15 @@  reachableModules :: DepGraph -> Module -> [Module] reachableModules depGraph mod =-  snd3 <$> tail (reachableG depGraph ((), mod, []))+  node_key <$> tail (reachableG depGraph (DigraphNode () mod []))  buildDepGraph :: ModuleGraph -> Ghc DepGraph buildDepGraph homeModules =-  graphFromEdgedVerticesOrd <$> mapM mkDepGraphNode homeModules+  graphFromEdgedVerticesOrd <$> mapM mkDepGraphNode (mgModSummaries homeModules)  mkDepGraphNode :: ModSummary -> Ghc DepGraphNode-mkDepGraphNode modSummary = ((), ms_mod modSummary, ) <$>-  (filterM isHomeModule =<< modSummaryImports modSummary)+mkDepGraphNode modSummary = +  DigraphNode () (ms_mod modSummary) <$> (filterM isHomeModule =<< modSummaryImports modSummary)  isHomeModule :: Module -> Ghc Bool isHomeModule mod = do@@ -249,27 +315,28 @@ -- | Extract Ids --------------------------------------------------------------- -------------------------------------------------------------------------------- -exportedVars :: GhcInfo -> [Var]-exportedVars info = filter (isExportedVar info) (defVars info)--isExportedVar :: GhcInfo -> Var -> Bool-isExportedVar info v = n `elemNameSet` ns-  where-    n                = getName v-    ns               = gsExports (spec info)-- classCons :: Maybe [ClsInst] -> [Id] classCons Nothing   = [] classCons (Just cs) = concatMap (dataConImplicitIds . head . tyConDataCons . classTyCon . is_cls) cs -derivedVars :: CoreProgram -> Maybe [DFunId] -> [Id]-derivedVars cbs (Just fds) = concatMap (derivedVs cbs) fds-derivedVars _   Nothing    = []+derivedVars :: Config -> MGIModGuts -> [Var]  +derivedVars cfg mg  = concatMap (dFunIdVars cbs . is_dfun) derInsts +  where +    derInsts        +      | checkDer    = insts +      | otherwise   = filter isDerivedInstance insts+    insts           = mgClsInstances mg +    checkDer        = checkDerived cfg+    cbs             = mgi_binds mg+                -derivedVs :: CoreProgram -> DFunId -> [Id]-derivedVs cbs fd   = concatMap bindersOf cbs' ++ deps+mgClsInstances :: MGIModGuts -> [ClsInst]+mgClsInstances = fromMaybe [] . mgi_cls_inst ++dFunIdVars :: CoreProgram -> DFunId -> [Id]+dFunIdVars cbs fd  = notracepp msg $ concatMap bindersOf cbs' ++ deps   where+    msg            = "DERIVED-VARS-OF: " ++ showpp fd     cbs'           = filter f cbs     f (NonRec x _) = eqFd x     f (Rec xes)    = any eqFd (fst <$> xes)@@ -288,8 +355,8 @@ importVars :: CoreProgram -> [Id] importVars = freeVars S.empty -definedVars :: CoreProgram -> [Id]-definedVars = concatMap defs+_definedVars :: CoreProgram -> [Id]+_definedVars = concatMap defs   where     defs (NonRec x _) = [x]     defs (Rec xes)    = map fst xes@@ -300,21 +367,18 @@  type SpecEnv = ModuleEnv (ModName, Ms.BareSpec) -processModules :: Config -> Either Error LogicMap -> [FilePath] -> DepGraph-               -> ModuleGraph-               -> Ghc [GhcInfo]+processModules :: Config -> LogicMap -> [FilePath] -> DepGraph -> ModuleGraph -> Ghc [GhcInfo] processModules cfg logicMap tgtFiles depGraph homeModules = do   -- DO NOT DELETE: liftIO $ putStrLn $ "Process Modules: TargetFiles = " ++ show tgtFiles-  catMaybes . snd <$> mapAccumM go emptyModuleEnv homeModules-  where+  catMaybes . snd <$> Misc.mapAccumM go emptyModuleEnv (mgModSummaries homeModules)+  where                                                  go = processModule cfg logicMap (S.fromList tgtFiles) depGraph -processModule :: Config -> Either Error LogicMap -> S.HashSet FilePath -> DepGraph-              -> SpecEnv -> ModSummary+processModule :: Config -> LogicMap -> S.HashSet FilePath -> DepGraph -> SpecEnv -> ModSummary               -> Ghc (SpecEnv, Maybe GhcInfo) processModule cfg logicMap tgtFiles depGraph specEnv modSummary = do   let mod              = ms_mod modSummary-  -- DO-NOT-DELETE _                <- liftIO $ putStrLn $ "Process Module: " ++ showPpr (moduleName mod)+  -- DO-NOT-DELETE _                <- liftIO $ whenLoud $ putStrLn $ "Process Module: " ++ showPpr (moduleName mod)   file                <- liftIO $ canonicalizePath $ modSummaryHsFile modSummary   let isTarget         = file `S.member` tgtFiles   _                   <- loadDependenciesOf $ moduleName mod@@ -324,14 +388,20 @@   let specQuotes       = extractSpecQuotes typechecked   _                   <- loadModule' typechecked   (modName, commSpec) <- either throw return $ hsSpecificationP (moduleName mod) specComments specQuotes-  liftedSpec          <- liftIO $ if isTarget then return mempty else loadLiftedSpec cfg file -- modName-  let bareSpec         = commSpec `mappend` liftedSpec+  liftedSpec          <- liftIO $ if isTarget || null specComments then return Nothing else loadLiftedSpec cfg file +  let bareSpec         = updLiftedSpec commSpec liftedSpec   _                   <- checkFilePragmas $ Ms.pragmas bareSpec   let specEnv'         = extendModuleEnv specEnv mod (modName, noTerm bareSpec)   (specEnv', ) <$> if isTarget                      then Just <$> processTargetModule cfg logicMap depGraph specEnv file typechecked bareSpec                      else return Nothing +updLiftedSpec :: Ms.BareSpec -> Maybe Ms.BareSpec -> Ms.BareSpec +updLiftedSpec s1 Nothing   = s1 +updLiftedSpec s1 (Just s2) = (clear s1) `mappend` s2 +  where +    clear s                = s { sigs = [], aliases = [], ealiases = [], qualifiers = [], dataDecls = [] }+ keepRawTokenStream :: ModSummary -> ModSummary keepRawTokenStream modSummary = modSummary   { ms_hspp_opts = ms_hspp_opts modSummary `gopt_set` Opt_KeepRawTokenStream }@@ -353,74 +423,154 @@     pm'  = pm { pm_mod_summary = ms' }     tm'  = tm { tm_parsed_module = pm' } -processTargetModule :: Config -> Either Error LogicMap -> DepGraph-                    -> SpecEnv-                    -> FilePath -> TypecheckedModule -> Ms.BareSpec++processTargetModule :: Config -> LogicMap -> DepGraph -> SpecEnv -> FilePath -> TypecheckedModule -> Ms.BareSpec                     -> Ghc GhcInfo processTargetModule cfg0 logicMap depGraph specEnv file typechecked bareSpec = do-  cfg               <- liftIO $ withPragmas cfg0 file $ Ms.pragmas bareSpec-  let modSummary     = pm_mod_summary $ tm_parsed_module typechecked-  let mod            = ms_mod modSummary-  let modName        = ModName Target $ moduleName mod-  desugared         <- desugarModule typechecked-  let modGuts        = makeMGIModGuts desugared+  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++---------------------------------------------------------------------------------------+-- | @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   hscEnv            <- getSession+  -- _                 <- liftIO $ whenLoud $ dumpRdrEnv hscEnv modGuts+  -- _                 <- liftIO $ whenLoud $ dumpTypeEnv typechecked    coreBinds         <- liftIO $ anormalize cfg hscEnv modGuts'-  _                 <- liftIO $ whenNormal $ donePhase Loud "A-Normalization"+  _                 <- liftIO $ whenNormal $ Misc.donePhase Misc.Loud "A-Normalization"   let dataCons       = concatMap (map dataConWorkId . tyConDataCons) (mgi_tcs modGuts)-  let impVs          = importVars coreBinds ++ classCons (mgi_cls_inst modGuts)-  let defVs          = definedVars coreBinds-  let useVs          = readVars coreBinds-  let letVs          = letVars coreBinds-  let derVs          = derivedVars coreBinds $ ((is_dfun <$>) <$>) $ mgi_cls_inst modGuts-  let paths          = nub $ idirs cfg ++ importPaths (ms_hspp_opts modSummary)-  _                 <- liftIO $ whenLoud $ putStrLn $ "paths = " ++ show paths-  let reachable      = reachableModules depGraph mod-  specSpecs         <- findAndParseSpecFiles cfg paths modSummary reachable-  let homeSpecs      = cachedBareSpecs specEnv reachable-  let impSpecs       = specSpecs ++ homeSpecs-  (spc, imps, incs) <- toGhcSpec cfg file coreBinds (impVs ++ defVs) letVs modName modGuts bareSpec logicMap impSpecs-  _                 <- liftIO $ whenLoud $ putStrLn $ "Module Imports: " ++ show imps-  hqualsFiles       <- moduleHquals modGuts paths file imps incs-  return GI { target    = file-            , targetMod = moduleName mod-            , env       = hscEnv-            , cbs       = coreBinds-            , derVars   = derVs-            , impVars   = impVs-            , defVars   = letVs ++ dataCons-            , useVars   = useVs-            , hqFiles   = hqualsFiles-            , imports   = imps-            , includes  = incs-            , spec      = spc-            }+  -- let defVs          = definedVars coreBinds+  (fiTcs, fiDcs)    <- liftIO $ makeFamInstEnv hscEnv +  things            <- lookupTyThings hscEnv typechecked modGuts +  -- _                 <- liftIO $ print (showpp things)+  let impVars        = importVars coreBinds ++ classCons (mgi_cls_inst modGuts)+  incDir            <- liftIO $ Misc.getIncludeDir+  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 ] +    } -toGhcSpec :: GhcMonad m-          => Config-          -> FilePath-          -> [CoreBind]-          -> [Var]-          -> [Var]-          -> ModName-          -> MGIModGuts-          -> Ms.BareSpec-          -> Either Error LogicMap-          -> [(ModName, Ms.BareSpec)]-          -> m (GhcSpec, [String], [FilePath])-toGhcSpec cfg file cbs vars letVs tgtMod mgi tgtSpec logicMap impSpecs = do-  let tgtCxt    = IIModule $ getModName tgtMod-  let impCxt    = map (IIDecl . qualImportDecl . getModName . fst) impSpecs-  _            <- setContext (tgtCxt : impCxt)-  hsc          <- getSession-  let impNames  = map (getModString . fst) impSpecs-  let exports   = mgi_exports mgi-  let specs     = (tgtMod, tgtSpec) : impSpecs-  let imps      = sortNub $ impNames ++ [ symbolString x | (_, sp) <- specs, x <- Ms.imports sp ]-  ghcSpec      <- liftIO $ makeGhcSpec cfg file tgtMod cbs (mgi_tcs mgi) (mgi_cls_inst mgi) vars letVs exports hsc logicMap specs-  return (ghcSpec, imps, Ms.includes tgtSpec)+    +_impThings :: [Var] -> [TyThing] -> [TyThing]+_impThings vars  = filter ok+  where+    vs          = S.fromList vars +    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) ++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+                                          , let decl   = unLoc i+                                          , let m      = unLoc (ideclName decl)  +                                          , qm        <- maybeToList (unLoc <$> ideclAs decl) +                                          , let [n,qn] = symbol <$> [m, qm] +                                          ]++qImports :: [(Symbol, Symbol)] -> QImports +qImports qns  = QImports +  { qiNames   = Misc.group qns +  , qiModules = S.fromList (snd <$> qns) +  }+++---------------------------------------------------------------------------------------+-- | @lookupTyThings@ grabs all the @Name@s and associated @TyThing@ known to GHC +--   for this module; we will use this to create our name-resolution environment +--   (see `Bare.Resolve`)                                          +---------------------------------------------------------------------------------------+lookupTyThings :: 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++-- lookupName        :: GhcMonad m => Name -> m (Maybe TyThing) +-- hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)+-- modInfoLookupName :: GhcMonad m => ModuleInfo -> Name -> m (Maybe TyThing)  +-- lookupGlobalName  :: GhcMonad m => Name -> m (Maybe TyThing)  ++_dumpTypeEnv :: TypecheckedModule -> IO () +_dumpTypeEnv tm = do +  print "DUMP-TYPE-ENV"+  print (showpp <$> tcmTyThings tm)++tcmTyThings :: TypecheckedModule -> Maybe [Name] +tcmTyThings +  = id +  -- typeEnvElts +  -- . tcg_type_env . fst +  -- . md_types . snd+  -- . tm_internals_+  . modInfoTopLevelScope+  . tm_checked_module_info+++_dumpRdrEnv :: HscEnv -> MGIModGuts -> IO () +_dumpRdrEnv _hscEnv modGuts = do +  print "DUMP-RDR-ENV" +  print (mgNames modGuts)+  -- print (hscNames hscEnv) +  -- print (mgDeps modGuts) +  where +    _mgDeps   = Ghc.dep_mods . mgi_deps +    _hscNames = fmap showPpr . Ghc.ic_tythings . Ghc.hsc_IC++mgNames :: MGIModGuts -> [Ghc.Name] +mgNames  = fmap Ghc.gre_name . Ghc.globalRdrEnvElts .  mgi_rdr_env ++---------------------------------------------------------------------------------------+-- | @makeBareSpecs@ loads BareSpec for target and imported modules +---------------------------------------------------------------------------------------+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)+  _            <- 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+ modSummaryHsFile :: ModSummary -> FilePath modSummaryHsFile modSummary =   fromMaybe@@ -436,7 +586,7 @@     err m                    = impossible Nothing ("lookupBareSpec: missing module " ++ showPpr m)  checkFilePragmas :: [Located String] -> Ghc ()-checkFilePragmas = applyNonNull (return ()) throw . mapMaybe err+checkFilePragmas = Misc.applyNonNull (return ()) throw . mapMaybe err   where     err pragma       | check (val pragma) = Just (ErrFilePragma $ fSrcSpan pragma :: Error)@@ -449,6 +599,21 @@       ]  --------------------------------------------------------------------------------+-- | Family instance information+--------------------------------------------------------------------------------+makeFamInstEnv :: HscEnv -> IO ([GHC.TyCon], [(Symbol, DataCon)])+makeFamInstEnv env = do+  famInsts <- getFamInstances env+  let fiTcs = [ tc            | FamInst { fi_flavor = DataFamilyInst tc } <- famInsts ]+  let fiDcs = [ (symbol d, d) | tc <- fiTcs, d <- tyConDataCons tc ]+  return (fiTcs, fiDcs)++getFamInstances :: HscEnv -> IO [FamInst]+getFamInstances env = do+  (_, Just (pkg_fie, home_fie)) <- runTcInteractive env tcGetFamInstEnvs+  return $ famInstEnvElts home_fie ++ famInstEnvElts pkg_fie+ +-------------------------------------------------------------------------------- -- | Extract Specifications from GHC ------------------------------------------- -------------------------------------------------------------------------------- extractSpecComments :: ParsedModule -> [(SourcePos, String)]@@ -488,7 +653,7 @@     mod = ms_mod $ pm_mod_summary $ tm_parsed_module typechecked  extractSpecQuote :: AnnPayload -> Maybe BPspec-extractSpecQuote payload =+extractSpecQuote payload =    case fromSerialized deserializeWithData payload of     Nothing -> Nothing     Just qt -> Just $ refreshSymbols $ liquidQuoteSpec qt@@ -516,13 +681,13 @@   imps'    <- filterM ((not <$>) . isHomeModule) imps''   let imps  = m2s <$> imps'   fs'      <- moduleFiles Spec paths imps-  -- liftIO    $ print ("moduleFiles-imps'': "  ++ show (m2s <$> imps''))-  -- liftIO    $ print ("moduleFiles-imps' : "  ++ show (m2s <$> imps'))-  -- liftIO    $ print ("moduleFiles-imps  : "  ++ show imps)-  -- liftIO    $ print ("moduleFiles-Paths : "  ++ show paths)-  -- liftIO    $ print ("moduleFiles-Specs : "  ++ show fs')-  patSpec  <- getPatSpec paths $ totalityCheck cfg-  rlSpec   <- getRealSpec paths $ not $ linear cfg+  -- 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)   let fs    = patSpec ++ rlSpec ++ fs'   transParseSpecs paths mempty mempty fs   where@@ -544,11 +709,13 @@     notRealSpecName = "NotReal"  transParseSpecs :: [FilePath]-                -> S.HashSet FilePath -> [(ModName, Ms.BareSpec)]+                -> S.HashSet FilePath +                -> [(ModName, Ms.BareSpec)]                 -> [FilePath]                 -> Ghc [(ModName, Ms.BareSpec)] transParseSpecs _ _ specs [] = return specs transParseSpecs paths seenFiles specs newFiles = do+  -- liftIO $ print ("TRANS-PARSE-SPECS", seenFiles, newFiles)   newSpecs      <- liftIO $ mapM parseSpecFile newFiles   impFiles      <- moduleFiles Spec paths $ specsImports newSpecs   let seenFiles' = seenFiles `S.union` S.fromList newFiles@@ -562,21 +729,21 @@ noTerm spec = spec { Ms.decr = mempty, Ms.lazy = mempty, Ms.termexprs = mempty }  parseSpecFile :: FilePath -> IO (ModName, Ms.BareSpec)-parseSpecFile file = either throw return . specSpecificationP file =<< readFile file+parseSpecFile file = either throw return . specSpecificationP file =<< Misc.sayReadFile file  -- Find Hquals Files ----------------------------------------------------------- -moduleHquals :: MGIModGuts+_moduleHquals :: MGIModGuts              -> [FilePath]              -> FilePath              -> [String]              -> [FilePath]              -> Ghc [FilePath]-moduleHquals mgi paths target imps incs = do+_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 $ sortNub $ hqs'' ++ hqs ++ hqs'+  return $ Misc.sortNub $ hqs'' ++ hqs ++ hqs'  -- Find Files for Modules ------------------------------------------------------ @@ -586,7 +753,7 @@ moduleFile :: Ext -> [FilePath] -> String -> Ghc (Maybe FilePath) moduleFile ext paths name   | ext `elem` [Hs, LHs] = do-    graph <- getModuleGraph+    graph <- mgModSummaries <$> getModuleGraph     case find (\m -> not (isBootSummary m) &&                      name == moduleNameString (ms_mod_name m)) graph of       Nothing -> liftIO $ getFileInDirs (extModuleName name ext) paths@@ -601,7 +768,7 @@     mfile <- getFileInDirs f paths     case mfile of       Just file -> return file-      Nothing -> panic Nothing $ "cannot find " ++ f ++ " in " ++ show paths+      Nothing   -> panic Nothing $ "cannot find " ++ f ++ " in " ++ show paths  reqFile :: Ext -> FilePath -> Maybe FilePath reqFile ext s@@ -616,14 +783,28 @@ makeMGIModGuts desugared = miModGuts deriv modGuts   where     modGuts = coreModule desugared-    deriv = Just $ instEnvElts $ mg_inst_env modGuts+    deriv   = Just $ instEnvElts $ mg_inst_env modGuts -makeLogicMap :: IO (Either Error LogicMap)+makeLogicMap :: IO LogicMap makeLogicMap = do-  lg    <- getCoreToLogicPath-  lspec <- readFile lg-  return $ parseSymbolToLogic lg lspec+  lg    <- Misc.getCoreToLogicPath+  lspec <- Misc.sayReadFile lg+  case parseSymbolToLogic lg lspec of +    Left e   -> throw e +    Right lm -> return (lm <> listLMap) +listLMap :: LogicMap -- TODO-REBARE: move to wiredIn+listLMap  = toLogicMap [ (dummyLoc nilName , []     , hNil)+                       , (dummyLoc consName, [x, xs], hCons (EVar <$> [x, xs])) ]+  where+    x     = "x"+    xs    = "xs"+    hNil  = mkEApp (dcSym Ghc.nilDataCon ) []+    hCons = mkEApp (dcSym Ghc.consDataCon)+    dcSym = dummyLoc . dropModuleUnique . symbol+++ -------------------------------------------------------------------------------- -- | Pretty Printing ----------------------------------------------------------- --------------------------------------------------------------------------------@@ -631,30 +812,30 @@ instance PPrint GhcSpec where   pprintTidy k spec = vcat     [ "******* Target Variables ********************"-    , pprintTidy k $ gsTgtVars spec+    , pprintTidy k $ gsTgtVars (gsVars spec)     , "******* Type Signatures *********************"-    , pprintLongList k (gsTySigs spec)+    , pprintLongList k (gsTySigs (gsSig spec))     , "******* Assumed Type Signatures *************"-    , pprintLongList k (gsAsmSigs spec)+    , pprintLongList k (gsAsmSigs (gsSig spec))     , "******* DataCon Specifications (Measure) ****"-    , pprintLongList k (gsCtors spec)+    , pprintLongList k (gsCtors (gsData spec))     , "******* Measure Specifications **************"-    , pprintLongList k (gsMeas spec)                   ]+    , pprintLongList k (gsMeas (gsData spec))       ]  instance PPrint GhcInfo where   pprintTidy k info = vcat-    [ "*************** Imports *********************"-    , intersperse comma $ text <$> imports info-    , "*************** Includes ********************"-    , intersperse comma $ text <$> includes info-    , "*************** Imported Variables **********"-    , pprDoc $ impVars info+    [ -- "*************** Imports *********************"+      -- , intersperse comma $ text <$> imports info+      -- , "*************** Includes ********************"+      -- , intersperse comma $ text <$> includes info+      "*************** Imported Variables **********"+    , pprDoc $ giImpVars (giSrc info)     , "*************** Defined Variables ***********"-    , pprDoc $ defVars info+    , pprDoc $ giDefVars (giSrc info)     , "*************** Specification ***************"-    , pprintTidy k $ spec info+    , pprintTidy k $ giSpec info     , "*************** Core Bindings ***************"-    , pprintCBs $ cbs info                          ]+    , pprintCBs $ giCbs (giSrc info)                ]  -- RJ: the silly guards below are to silence the unused-var checker pprintCBs :: [CoreBind] -> Doc
src/Language/Haskell/Liquid/GHC/Misc.hs view
@@ -18,12 +18,14 @@  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           DataCon                                    (isTupleDataCon)+import qualified DataCon                                    -- (dataConInstArgTys, isTupleDataCon) import           Prelude                                    hiding (error) import           Avail                                      (availsToNameSet) import           BasicTypes                                 (Arity, noOccInfo)@@ -54,7 +56,7 @@   import           RdrName-import           Type                                       (isClassPred, isEqPred, liftedTypeKind)+import           Type                                       (expandTypeSynonyms, isClassPred, isEqPred, liftedTypeKind) import           TyCoRep import           Var import           IdInfo@@ -75,10 +77,12 @@ import qualified Text.PrettyPrint.HughesPJ                  as PJ import           Language.Fixpoint.Types                    hiding (L, panic, Loc (..), SrcSpan, Constant, SESearch (..)) import qualified Language.Fixpoint.Types                    as F-import           Language.Fixpoint.Misc                     (safeHead, safeLast, safeInit)+import           Language.Fixpoint.Misc                     (safeHead) -- , safeLast, safeInit)+import           Language.Haskell.Liquid.Misc               (keyDiff)  import           Control.DeepSeq import           Language.Haskell.Liquid.Types.Errors-import           Language.Haskell.Liquid.Desugar.HscMain+-- import           Language.Haskell.Liquid.Desugar.HscMain+import           HscMain import           Id                                         (isExportedId, idOccInfo, setIdInfo)  @@ -98,8 +102,8 @@ -------------------------------------------------------------------------------- -- | Datatype For Holding GHC ModGuts ------------------------------------------ ---------------------------------------------------------------------------------data MGIModGuts = MI {-    mgi_binds     :: !CoreProgram+data MGIModGuts = MI +  { mgi_binds     :: !CoreProgram   , mgi_module    :: !Module   , mgi_deps      :: !Dependencies   , mgi_dir_imps  :: ![ModuleName]@@ -111,8 +115,8 @@   }  miModGuts :: Maybe [ClsInst] -> ModGuts -> MGIModGuts-miModGuts cls mg  = MI {-    mgi_binds     = mg_binds mg+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@@ -149,8 +153,9 @@ -- FIXME: reusing uniques like this is really dangerous stringTyVar :: String -> TyVar stringTyVar s = mkTyVar name liftedTypeKind-  where name = mkInternalName (mkUnique 'x' 24)  occ noSrcSpan-        occ  = mkTyVarOcc s+  where +    name      = mkInternalName (mkUnique 'x' 24)  occ noSrcSpan+    occ       = mkTyVarOcc s  -- FIXME: reusing uniques like this is really dangerous stringVar :: String -> Type -> Var@@ -181,6 +186,12 @@ isBaseType (AppTy t1 t2)   = isBaseType t1 && isBaseType t2 isBaseType _               = False +isTmpVar :: Var -> Bool +isTmpVar = isTmpSymbol . dropModuleNamesAndUnique . symbol ++isTmpSymbol    :: Symbol -> Bool+isTmpSymbol x  = any (`isPrefixOfSym` x) [anfPrefix, tempPrefix, "ds_"]+ validTyVar :: String -> Bool validTyVar s@(c:_) = isLower c && all (not . isSpace) s validTyVar _       = False@@ -208,11 +219,9 @@ isFractionalClass :: Class -> Bool isFractionalClass clas = classKey clas `elem` fractionalClassKeys - -------------------------------------------------------------------------------- -- | Pretty Printers ----------------------------------------------------------- --------------------------------------------------------------------------------- notracePpr :: Outputable a => String -> a -> a notracePpr _ x = x @@ -273,6 +282,9 @@ fSrcSpan :: (F.Loc a) => a -> SrcSpan fSrcSpan = fSrcSpanSrcSpan . F.srcSpan +fSourcePos :: (F.Loc a) => a -> F.SourcePos +fSourcePos = F.sp_start . F.srcSpan + fSrcSpanSrcSpan :: F.SrcSpan -> SrcSpan fSrcSpanSrcSpan (F.SS p p') = sourcePos2SrcSpan p p' @@ -315,6 +327,7 @@ srcSpanEndLoc :: RealSrcSpan -> Loc srcSpanEndLoc l    = L (srcSpanEndLine l, srcSpanEndCol l) + oneLine :: RealSrcSpan -> Bool oneLine l          = srcSpanStartLine l == srcSpanEndLine l @@ -348,8 +361,11 @@     l          = getSourcePos  x     lE         = getSourcePosE x +instance F.Loc Var where +  srcSpan v = SS (getSourcePos v) (getSourcePosE v) + namedLocSymbol :: (F.Symbolic a, NamedThing a) => a -> F.Located F.Symbol-namedLocSymbol d = {- dropModuleNamesAndUnique . -} F.symbol <$> locNamedThing d+namedLocSymbol d = F.symbol <$> locNamedThing d  varLocInfo :: (Type -> a) -> Var -> F.Located a varLocInfo f x = f . varType <$> locNamedThing x@@ -396,20 +412,20 @@ --------------------------------------------------------------------------------  isTupleId :: Id -> Bool-isTupleId = maybe False isTupleDataCon . idDataConM+isTupleId = maybe False DataCon.isTupleDataCon . idDataConM  idDataConM :: Id -> Maybe DataCon idDataConM x = case idDetails x of   DataConWorkId d -> Just d   DataConWrapId d -> Just d-  _               -> Nothing+  _               -> Nothing   isDataConId :: Id -> Bool isDataConId = isJust . idDataConM  getDataConVarUnique :: Var -> Unique getDataConVarUnique v-  | isId v && isDataConId v = getUnique $ idDataCon v+  | isId v && isDataConId v = getUnique (idDataCon v)   | otherwise               = getUnique v  isDictionaryExpression :: Core.Expr Id -> Maybe Id@@ -472,14 +488,18 @@         throwCmdLineErrorS dflags = throwCmdLineError . Out.showSDoc dflags         throwCmdLineError = throwGhcException . CmdLineError -qualImportDecl :: ModuleName -> ImportDecl name-qualImportDecl mn = (simpleImportDecl mn) { ideclQualified = True }+-- qualImportDecl :: ModuleName -> ImportDecl name+-- qualImportDecl mn = (simpleImportDecl mn) { ideclQualified = True }  ignoreInline :: ParsedModule -> ParsedModule ignoreInline x = x {pm_parsed_source = go <$> pm_parsed_source x}-  where go  x = x {hsmodDecls = filter go' $ hsmodDecls x}-        go' x | SigD (InlineSig _ _) <-  unLoc x = False-              | otherwise                        = True+  where +    go :: HsModule GhcPs -> HsModule GhcPs+    go  x      = x {hsmodDecls = filter go' (hsmodDecls x) }+    go' :: LHsDecl GhcPs -> Bool+    go' x +      | SigD _ (InlineSig {}) <-  unLoc x = False+      | otherwise                         = True  -------------------------------------------------------------------------------- -- | Symbol Conversions --------------------------------------------------------@@ -492,8 +512,7 @@ symbolTyCon x i n = stringTyCon x i (symbolString n)  symbolTyVar :: Symbol -> TyVar-symbolTyVar n = stringTyVar (symbolString n)-+symbolTyVar = stringTyVar . symbolString  localVarSymbol ::  Var -> Symbol localVarSymbol v@@ -501,10 +520,12 @@   | otherwise             = suffixSymbol vs us   where     us                    = symbol $ showPpr $ getDataConVarUnique v-    vs                    = exportedVarSymbol v -- TODO:reflect-datacons varSymbol+    vs                    = exportedVarSymbol v   exportedVarSymbol :: Var -> Symbol-exportedVarSymbol = symbol . getName            -- TODO:reflect-datacons varSymbol+exportedVarSymbol x = notracepp msg . symbol . getName $ x            +  where +    msg = "exportedVarSymbol: " ++ showPpr x   qualifiedNameSymbol :: Name -> Symbol qualifiedNameSymbol n = symbol $ concatFS [modFS, occFS, uniqFS]@@ -562,12 +583,16 @@     | isExportedId v = exportedVarSymbol v     | otherwise      = localVarSymbol    v + instance Hashable Var where   hashWithSalt = uniqueHash  instance Hashable TyCon where   hashWithSalt = uniqueHash +instance Hashable DataCon where+  hashWithSalt = uniqueHash+ instance Fixpoint Var where   toFix = pprDoc @@ -601,7 +626,6 @@ instance NFData Var where   rnf t = seq t () - -------------------------------------------------------------------------------- -- | Manipulating Symbols ------------------------------------------------------ --------------------------------------------------------------------------------@@ -613,9 +637,12 @@ dropModuleNamesAndUnique = dropModuleUnique . dropModuleNames  dropModuleNames  :: Symbol -> Symbol+dropModuleNames = dropModuleNamesCorrect +{-  dropModuleNames = mungeNames lastName sepModNames "dropModuleNames: "  where    lastName msg = symbol . safeLast msg+-}  dropModuleNamesCorrect  :: Symbol -> Symbol dropModuleNamesCorrect = F.symbol . go . F.symbolText@@ -627,16 +654,25 @@              Nothing -> s  takeModuleNames  :: Symbol -> Symbol-takeModuleNames  = mungeNames initName sepModNames "takeModuleNames: "+takeModuleNames  = F.symbol . go [] . F.symbolText   where-    initName msg = symbol . T.intercalate "." . safeInit msg+    go acc s = case T.uncons s of+                Just (c,tl) -> if isUpper c && T.any (== '.') tl+                                 then go (getModule s:acc) $ snd $ fromJust $ T.uncons $ T.dropWhile (/= '.') s+                                 else T.intercalate "." (reverse acc) +                Nothing -> T.intercalate "." (reverse acc) +    getModule s = T.takeWhile (/= '.') s +{- +takeModuleNamesOld  = mungeNames initName sepModNames "takeModuleNames: "+  where+    initName msg = symbol . T.intercalate "." . safeInit msg+-} dropModuleUnique :: Symbol -> Symbol dropModuleUnique = mungeNames headName sepUnique   "dropModuleUnique: "   where     headName msg = symbol . safeHead msg - cmpSymbol :: Symbol -> Symbol -> Bool cmpSymbol coreSym logicSym   =  (dropModuleUnique coreSym == dropModuleNamesAndUnique logicSym)@@ -660,6 +696,9 @@   | isParened x    = symbol (wrapParens (m `mappend` "." `mappend` stripParens x))   | otherwise      = symbol (m `mappend` "." `mappend` x) +isQualifiedSym :: Symbol -> Bool+isQualifiedSym (symbolText -> x) = isQualified x + isQualified :: T.Text -> Bool isQualified y = "." `T.isInfixOf` y @@ -672,16 +711,26 @@ isDictionary :: Symbolic a => a -> Bool isDictionary = isPrefixOfSym "$f" . dropModuleNames . symbol +isMethod :: Symbolic a => a -> Bool+isMethod = isPrefixOfSym "$c" . dropModuleNames . symbol+ isInternal :: Symbolic a => a -> Bool isInternal   = isPrefixOfSym "$"  . dropModuleNames . symbol +isWorker :: Symbolic a => a -> Bool +isWorker s = notracepp ("isWorkerSym: s = " ++ ss) $ "$W" `L.isInfixOf` ss +  where +    ss     = symbolString (symbol s)+++ stripParens :: T.Text -> T.Text stripParens t = fromMaybe t (strip t)   where     strip = T.stripPrefix "(" >=> T.stripSuffix ")"  stripParensSym :: Symbol -> Symbol-stripParensSym (symbolText -> t) = symbol $ stripParens t+stripParensSym (symbolText -> t) = symbol (stripParens t)  desugarModule :: TypecheckedModule -> Ghc DesugaredModule desugarModule tcm = do@@ -690,7 +739,7 @@   let (tcg, _) = tm_internals_ tcm   hsc_env <- getSession   let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }-  guts <- liftIO $ hscDesugarWithLoc hsc_env_tmp ms tcg+  guts <- liftIO $ hscDesugar{- WithLoc -} hsc_env_tmp ms tcg   return DesugaredModule { dm_typechecked_module = tcm, dm_core_module = guts }  --------------------------------------------------------------------------------@@ -703,10 +752,8 @@ symbolFastString :: Symbol -> FastString symbolFastString = mkFastStringByteString . T.encodeUtf8 . symbolText -type Prec = TyPrec- lintCoreBindings :: [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc)-lintCoreBindings = CoreLint.lintCoreBindings (defaultDynFlags undefined) CoreDoNothing+lintCoreBindings = CoreLint.lintCoreBindings (defaultDynFlags undefined (undefined "LlvmTargets")) CoreDoNothing  synTyConRhs_maybe :: TyCon -> Maybe Type synTyConRhs_maybe = TC.synTyConRhs_maybe@@ -719,6 +766,19 @@   | untidy    = Out.showSDocDebug unsafeGlobalDynFlags . ppr . tidyCBs   | otherwise = showPpr ++ignoreCoreBinds :: S.HashSet Var -> [CoreBind] -> [CoreBind]+ignoreCoreBinds vs cbs +  | S.null vs         = cbs +  | otherwise         = concatMap go cbs+  where+    go :: CoreBind -> [CoreBind]+    go b@(NonRec x _) +      | S.member x vs = [] +      | otherwise     = [b] +    go (Rec xes)      = [Rec (filter ((`notElem` vs) . fst) xes)]++ findVarDef :: Symbol -> [CoreBind] -> Maybe (Var, CoreExpr) findVarDef x cbs = case xCbs of                      (NonRec v def   : _ ) -> Just (v, def)@@ -740,7 +800,8 @@ binders (NonRec z _) = [z] binders (Rec xes)    = fst <$> xes -+expandVarType :: Var -> Type+expandVarType = expandTypeSynonyms . varType -------------------------------------------------------------------------------- -- | The following functions test if a `CoreExpr` or `CoreVar` are just types --   in disguise, e.g. have `PredType` (in the GHC sense of the word), and so@@ -760,3 +821,18 @@  anyF :: [a -> Bool] -> a -> Bool anyF ps x = or [ p x | p <- ps ]+++-- | 'defaultDataCons t ds' returns the list of '(dc, types)' pairs,+--   corresponding to the _missing_ cases, i.e. _other_ than those in 'ds',+--   that are being handled by DEFAULT.+defaultDataCons :: Type -> [AltCon] -> Maybe [(DataCon, [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 ] ++defaultDataCons _ _ = +  Nothing+
src/Language/Haskell/Liquid/GHC/Play.hs view
@@ -19,9 +19,14 @@  import           Control.Arrow       ((***)) import qualified Data.HashMap.Strict as M+import qualified Data.List           as L  import Language.Haskell.Liquid.GHC.Misc () import Language.Haskell.Liquid.Types.Errors+++isHoleVar :: Var -> Bool +isHoleVar x = L.isPrefixOf "_" (show x)  dataConImplicitIds :: DataCon -> [Id] dataConImplicitIds dc = [ x | AnId x <- dataConImplicitTyThings dc]
src/Language/Haskell/Liquid/GHC/Resugar.hs view
@@ -30,8 +30,9 @@ import qualified PrelNames as PN import           Name         (Name, getName) import qualified Data.List as L---- import qualified Language.Haskell.Liquid.GHC.Misc as GM+import qualified Language.Haskell.Liquid.GHC.Misc as GM+import qualified Language.Fixpoint.Types          as F +import qualified Text.PrettyPrint.HughesPJ        as PJ  -- import           Debug.Trace  --------------------------------------------------------------------------------@@ -77,7 +78,23 @@     , patE     :: !CoreExpr  -- ^ e     } +instance F.PPrint Pattern where +  pprintTidy  = ppPat +ppPat :: F.Tidy -> Pattern -> PJ.Doc +ppPat k (PatReturn e m d t rv) = +  "PatReturn: " +  PJ.$+$ +  F.pprintKVs k+    [ ("rv" :: PJ.Doc, GM.pprDoc rv) +    , ("e " :: PJ.Doc, GM.pprDoc e) +    , ("m " :: PJ.Doc, GM.pprDoc m) +    , ("$d" :: PJ.Doc, GM.pprDoc d) +    , ("t " :: PJ.Doc, GM.pprDoc t) +    ] +ppPat _ _  = "TODO: PATTERN" +    + _mbId :: CoreExpr -> Maybe Var _mbId (Var x)    = Just x _mbId (Tick _ e) = _mbId e@@ -95,13 +112,25 @@   | op `is` PN.bindMName   = Just (PatBind e1 x e2 m d a b op) -exprArgs _e (Var op, [Type m, d, Type t, e])-  | op `is` PN.returnMName-  = Just (PatReturn e m d t op)- exprArgs (Case (Var xe) x t [(DataAlt c, ys, Var y)]) _   | Just i <- y `L.elemIndex` ys   = Just (PatProject xe x t c ys i)+++{- TEMPORARILY DISABLED: TODO-REBARE; in reality it hasn't been working AT ALL +   since at least the GHC 8.2.1 port (?) because the TICKs get in the way +   of recognizing the pattern? Anyways, messes up ++     tests/pattern/pos/Return00.hs  ++   because we treat _all_ types of the form `m a` as "invariant" in the parameter `a`.+   Looks like the above tests only pass in earlier LH versions because this pattern +   was NOT getting tickled!++exprArgs _e (Var op, [Type m, d, Type t, e])+  | op `is` PN.returnMName+  = Just (PatReturn e m d t op)+-}  {- TEMPORARILY DISBLED 
src/Language/Haskell/Liquid/GHC/SpanStack.hs view
@@ -43,10 +43,12 @@ data Span   = Var  !Var.Var           -- ^ binder for whom we are generating constraint   | Tick !(Tickish Var.Var) -- ^ nearest known Source Span+  | Span SrcSpan  instance Show Span where   show (Var x)   = show x   show (Tick tt) = showPpr tt+  show (Span s)  = show s   -------------------------------------------------------------------------------- srcSpan :: SpanStack -> SrcSpan@@ -63,6 +65,7 @@   where     go (Var x)   = getSrcSpan x     go (Tick tt) = tickSrcSpan tt+    go (Span s)  = s   maybeSpan :: Maybe SrcSpan -> SrcSpan -> Maybe SrcSpan maybeSpan d sp
src/Language/Haskell/Liquid/GHC/TypeRep.hs view
@@ -38,8 +38,6 @@ instance Eq Type where   t1 == t2 = eqType' t1 t2 -- eqType' :: Type -> Type -> Bool  eqType' (LitTy l1) (LitTy l2)    = l1 == l2  @@ -149,8 +147,8 @@   = TransCo (subst x tx c1) (subst x tx c2) substCoercion x tx (AxiomRuleCo ca cs)   = AxiomRuleCo (subst x tx ca)  (subst x tx <$> cs)  -substCoercion x tx (NthCo i c)-  = NthCo i (subst x tx c)+substCoercion x tx (NthCo r i c)+  = NthCo r i (subst x tx c) substCoercion x tx (LRCo i c)   = LRCo i (subst x tx c) substCoercion x tx (InstCo c1 c2)@@ -161,7 +159,8 @@   = KindCo (subst x tx c) substCoercion x tx (SubCo c)   = SubCo (subst x tx c)-+substCoercion _ _ (HoleCo _)+  = error "substCoercion: TODO handle HoleCo"  instance SubstTy Role where instance SubstTy (CoAxiom Branched) where
+ src/Language/Haskell/Liquid/LawInstances.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE FlexibleContexts #-}+module Language.Haskell.Liquid.LawInstances ( checkLawInstances ) where++import qualified Data.List                                  as L+import qualified Data.Maybe                                 as Mb+import           Text.PrettyPrint.HughesPJ ++import           Language.Haskell.Liquid.Types+import           Language.Haskell.Liquid.Types.Equality+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 ++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++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] +        _extra = [] -- this breaks on extra super requirements [ (x,i) | (Left x, (Left i, _)) <- insts, not (x `L.elem` laws)] +        mkError = ErrILaw (lilPos li) (pprint c) (pprint $ lilTyArgs li) +        _msgExtra (x,_)      = pprint x <+> text "is not a defined law."+        msgUnfoundLaw i      = pprint i <+> text "is not a defined law."+        msgUnfoundInstance i = pprint i <+> text "is not a defined instance."++checkOneLaw :: Class -> (Var, LocSpecType) -> LawInstance -> [Error]+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.")]+  | otherwise+  = [mkError (text "is not defined.")]+  where +    lix = L.lookup (Left x) (lilEqus li)+    mkError txt = ErrILaw (lilPos li) (pprint c) (pprintXs $ lilTyArgs li)+                          (text "The instance for the law" <+> pprint x <+> txt)+    pprintXs [l] = pprint l +    pprintXs xs  = pprint xs ++unify :: (Doc -> Error) -> Class -> LawInstance -> LocSpecType -> LocSpecType -> [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+       --  text "\nesubt1 = " <+> pprint esubst1  +       -- text "\nesubt = " <+> pprint esubst  +       -- text "\ncompared\n" <+> pprint t11 <+> text "\nWITH\n" <+> pprint t22 +           )]++    t22 = fromRTypeRep (trep2 {ty_vars = [], ty_binds = fst <$> args2, ty_args = snd <$> args2, ty_refts = drop (length tc2) (ty_refts trep2)})+    t11 = fromRTypeRep (trep1 { ty_vars = []+                              , ty_binds = fst <$> args2+                              , ty_args = (tx . snd) <$> args1+                              , ty_refts = F.subst esubst <$> drop (length tc1) (ty_refts trep1)+                              , ty_res = tx $ ty_res trep1})+    tx = subtsSpec tsubst . F.subst esubst+    subtsSpec = subts :: ([(TyVar, Type)] -> SpecType -> SpecType)++    trep1 = toRTypeRep $ val t1 +    trep2 = toRTypeRep $ val t2 +    (tc1, args1) = splitTypeConstraints $ zip (ty_binds trep1) (ty_args trep1)+    (tc2, args2) = splitTypeConstraints $ zip (ty_binds trep2) (ty_args trep2)+    esubst = F.mkSubst (esubst1+                 ++  [(F.symbol x, F.EVar (F.symbol y)) | (Left x, (Left y, _)) <- lilEqus li]+                     )+    esubst1 = zip  (fst <$> args1) ((F.EVar . fst) <$> args2)++    tsubst = reverse $ zip ((\(RTV v) -> v) <$> (findTyVars tc1 ++ (ty_var_value <$> concat argVars)))+                 (toType <$> (argBds ++ (((`RVar` mempty) . ty_var_value) <$>ty_vars trep2)))++    (argVars, argBds) = unzip (splitForall [] . val <$> lilTyArgs li)++    splitForall vs (RAllT v t) = splitForall (v:vs) t +    splitForall vs  t           = (vs, t) ++    findTyVars (((_x, RApp cc as _ _):_ts)) | rtc_tc cc == classTyCon c +      = [v | RVar v _ <- as ]+    findTyVars (_:ts) = findTyVars ts +    findTyVars [] = [] +++splitTypeConstraints :: [(F.Symbol, SpecType)] -> ([(F.Symbol, SpecType)], [(F.Symbol, SpecType)])+splitTypeConstraints = go []  +  where  +    go cs (b@(_x, RApp c _ _ _):ts) +      | isClass c+      = go (b:cs) ts +    go cs r = (reverse cs, map (\(x, t) -> (x, shiftVV t x)) r)
src/Language/Haskell/Liquid/Liquid.hs view
@@ -20,9 +20,10 @@  import           Prelude hiding (error) import           Data.Bifunctor+import qualified Data.HashSet as S  import           System.Exit import           Text.PrettyPrint.HughesPJ--- import           Var                              (Var)+import           Var                              (Var) import           CoreSyn import           HscTypes                         (SourceError) import           GHC (HscEnv)@@ -40,23 +41,31 @@ import           Language.Haskell.Liquid.UX.Errors import           Language.Haskell.Liquid.UX.CmdLine import           Language.Haskell.Liquid.UX.Tidy-import           Language.Haskell.Liquid.GHC.Misc (showCBs) -- howPpr)+import           Language.Haskell.Liquid.GHC.Misc (showCBs, ignoreCoreBinds) -- howPpr) import           Language.Haskell.Liquid.GHC.Interface import           Language.Haskell.Liquid.Constraint.Generate import           Language.Haskell.Liquid.Constraint.ToFixpoint import           Language.Haskell.Liquid.Constraint.Types-import           Language.Haskell.Liquid.Model+-- 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  type MbEnv = Maybe HscEnv ++ -------------------------------------------------------------------------------- liquid :: [String] -> IO b ---------------------------------------------------------------------------------liquid args = getOpts args >>= runLiquid Nothing >>= exitWith . fst+liquid args = do +  cfg     <- getOpts args +  (ec, _) <- runLiquid Nothing cfg+  exitWith ec +-------------------------------------------------------------------------------- liquidConstraints :: Config -> IO (Either [CGInfo] ExitCode) +-------------------------------------------------------------------------------- liquidConstraints cfg = do    z <- actOrDie $ second Just <$> getGhcInfos Nothing cfg (files cfg)   case z of@@ -67,15 +76,37 @@       return $ Left $ map generateConstraints gs  ----------------------------------------------------------------------------------- | This fellow does the real work--------------------------------------------------------------------------------- runLiquid :: MbEnv -> Config -> IO (ExitCode, MbEnv) ---------------------------------------------------------------------------------runLiquid mE cfg = do-  z <- actOrDie $ second Just <$> getGhcInfos mE cfg (files cfg)+runLiquid mE cfg  = do +  reals <- realTargets mE cfg (files cfg)+  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 ++ "]") ""+                       (ec, env') <- runLiquidTargets env cfg [f] +                       case ec of +                         ExitSuccess -> go env' fs+                         _           -> return (ec, env')+++--------------------------------------------------------------------------------+-- | @runLiquid@ checks a *target-list* of files, ASSUMING that we have +--   already  run LH on ALL the (transitive) home imports -- i.e. other +--   imports files for which we have source -- in order to build the .bspec +--   files for those specs.+--------------------------------------------------------------------------------+runLiquidTargets :: MbEnv -> Config -> [FilePath] -> IO (ExitCode, MbEnv)+--------------------------------------------------------------------------------+runLiquidTargets mE cfg targetFiles = do+  z <- actOrDie $ second Just <$> getGhcInfos mE cfg targetFiles   case z of     Left e -> do-      exitWithResult cfg (files cfg) $ mempty { o_result = e }+      exitWithResult cfg targetFiles $ mempty { o_result = e }       return (resultExit e, mE)     Right (gs, mE') -> do       d <- checkMany cfg mempty gs@@ -99,7 +130,7 @@ checkOne cfg g = do   z <- actOrDie $ liquidOne g   case z of-    Left  e -> exitWithResult cfg [target g] $ mempty { o_result = e }+    Left  e -> exitWithResult cfg [giTarget (giSrc g)] $ mempty { o_result = e }     Right r -> return r  @@ -117,37 +148,44 @@ -------------------------------------------------------------------------------- liquidOne :: GhcInfo -> IO (Output Doc) ---------------------------------------------------------------------------------liquidOne info = do-  whenNormal $ donePhase Loud "Extracted Core using GHC"-  let cfg   = getConfig info-  let tgt   = target info-  -- whenLoud  $ do putStrLn $ showpp info+liquidOne info+  | compileSpec cfg = do +    donePhase Loud "Only compiling specifications [skipping verification]"+    exitWithResult cfg [tgt] (mempty { o_result = F.Safe })+  | otherwise = do+    whenNormal $ donePhase Loud "Extracted Core using GHC"+    -- whenLoud  $ do putStrLn $ showpp info                  -- putStrLn "*************** Original CoreBinds ***************************"                  -- putStrLn $ render $ pprintCBs (cbs info)-  let cbs' = cbs info -- scopeTr (cbs info)-  whenNormal $ donePhase Loud "Transformed Core"-  whenLoud  $ do donePhase Loud "transformRecExpr"-                 putStrLn "*************** Transform Rec Expr CoreBinds *****************"-                 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'+    whenNormal $ donePhase Loud "Transformed Core"+    whenLoud  $ do donePhase Loud "transformRecExpr"+                   putStrLn "*************** Transform Rec Expr CoreBinds *****************"+                   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'+  where +    cfg  = getConfig info+    tgt  = giTarget (giSrc info)+    cbs' = giCbs (giSrc info)   newPrune :: Config -> [CoreBind] -> FilePath -> GhcInfo -> 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 <- exportedVars info ]+  | timeBinds cfg = return . Right $ [DC.thin cbs sp [v] | v <- expVars]   | diffcheck cfg = maybeEither cbs <$> DC.slice tgt cbs sp-  | otherwise     = return  (Left cbs)+  | otherwise     = return $ Left (ignoreCoreBinds ignores cbs)   where-    vs            = gsTgtVars sp-    sp            = spec    info+    ignores       = gsIgnoreVars (gsVars sp)+    vs            = gsTgtVars    (gsVars sp)+    sp            = giSpec       info+    expVars       = exportedVars (giSrc info) --- topLevelBinders :: GhcSpec -> [Var]--- topLevelBinders = map fst . tySigs+exportedVars :: GhcSrc -> [Var]+exportedVars src = filter (isExportedVar src) (giDefVars src)  maybeEither :: a -> Maybe b -> Either a [b] maybeEither d Nothing  = Left d@@ -161,18 +199,26 @@  liquidQuery   :: Config -> FilePath -> GhcInfo -> 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 cgi     = {-# SCC "generateConstraints" #-} generateConstraints $! info3    when False (dumpCs cgi)   -- whenLoud $ mapM_ putStrLn [ "****************** CGInfo ********************"                             -- , render (pprint cgi)                            ]-  out   <- timedAction names $ solveCs cfg tgt cgi info' names-  return $  mconcat [oldOut, out]-  where-    cgi    = {-# SCC "generateConstraints" #-} generateConstraints $! info' {cbs = cbs''}-    cbs''  = either id              DC.newBinds                        edc-    info'  = either (const info)    (\z -> info {spec = DC.newSpec z}) edc-    names  = either (const Nothing) (Just . map show . DC.checkedVars) edc-    oldOut = either (const mempty)  DC.oldOutput                       edc+  out        <- timedAction names $ solveCs cfg tgt cgi info3 names+  return      $ mconcat [oldOut, out] +updGhcInfoTermVars    :: GhcInfo -> GhcInfo +updGhcInfoTermVars 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@@ -194,14 +240,15 @@   finfo            <- cgInfoFInfo info cgi   F.Result r sol _ <- solve (fixConfig tgt cfg) finfo   let resErr        = applySolution sol . cinfoError . snd <$> r-  resModel_        <- fmap (e2u sol) <$> getModels info cfg resErr-  let resModel      = resModel_  `addErrors` (e2u sol <$> logErrors cgi)+  -- 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 out0          = mkOutput cfg resModel sol (annotMap cgi)   return            $ out0 { o_vars    = names    }                            { o_result  = resModel } -e2u :: F.FixSolution -> Error -> UserError-e2u s = fmap F.pprint . tidyError s+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
src/Language/Haskell/Liquid/Measure.hs view
@@ -17,108 +17,56 @@    -- * Constructors   , mkM, mkMSpec, mkMSpec'-  , qualifySpec   , dataConTypes   , defRefType+  , bodyPred   ) where  import           DataCon import           GHC                                    hiding (Located) import           Outputable                             (Outputable) import           Prelude                                hiding (error)-import           Text.PrettyPrint.HughesPJ              hiding (first)+import           Text.PrettyPrint.HughesPJ              hiding ((<>))  import           Type import           Var--- import           Data.Serialize                         (Serialize)-import           Data.Binary                            as B-import           GHC.Generics+-- 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           Data.Maybe                             (fromMaybe, isNothing)+import qualified Data.Maybe                             as Mb -- (fromMaybe, isNothing)  import           Language.Fixpoint.Misc import           Language.Fixpoint.Types                hiding (panic, R, DataDecl, SrcSpan) import           Language.Haskell.Liquid.GHC.Misc -- import qualified Language.Haskell.Liquid.Misc as Misc-import           Language.Haskell.Liquid.Types          hiding (GhcInfo(..), GhcSpec (..))+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.Variance+-- import           Language.Haskell.Liquid.Types.Bounds+import           Language.Haskell.Liquid.Types.Specs  import           Language.Haskell.Liquid.UX.Tidy --- MOVE TO TYPES-type BareSpec      = Spec    LocBareType LocSymbol-type BareMeasure   = Measure LocBareType LocSymbol-type SpecMeasure   = Measure LocSpecType DataCon -instance B.Binary BareSpec--data Spec ty bndr  = Spec-  { measures   :: ![Measure ty bndr]            -- ^ User-defined properties for ADTs-  , asmSigs    :: ![(LocSymbol, ty)]            -- ^ Assumed (unchecked) types; including reflected signatures-  , sigs       :: ![(LocSymbol, ty)]            -- ^ Imported functions and types-  , localSigs  :: ![(LocSymbol, ty)]            -- ^ Local type signatures-  , reflSigs   :: ![(LocSymbol, ty)]            -- ^ Reflected type signatures-  , invariants :: ![(Maybe LocSymbol, ty)]      -- ^ Data type invariants; the Maybe is the generating measure-  , ialiases   :: ![(ty, ty)]                   -- ^ Data type invariants to be checked-  , imports    :: ![Symbol]                     -- ^ Loaded spec module names-  , dataDecls  :: ![DataDecl]                   -- ^ Predicated data definitions-  , newtyDecls :: ![DataDecl]                   -- ^ Predicated new type definitions-  , includes   :: ![FilePath]                   -- ^ Included qualifier files-  , aliases    :: ![RTAlias Symbol BareType]    -- ^ RefType aliases-  , ealiases   :: ![RTAlias Symbol Expr]        -- ^ Expression aliases-  , embeds     :: !(TCEmb LocSymbol)            -- ^ GHC-Tycon-to-fixpoint Tycon map-  , qualifiers :: ![Qualifier]                  -- ^ Qualifiers in source/spec files-  , decr       :: ![(LocSymbol, [Int])]          -- ^ Information on decreasing arguments-  , lvars      :: ![LocSymbol]                   -- ^ Variables that should be checked in the environment they are used-  , lazy       :: !(S.HashSet LocSymbol)         -- ^ Ignore Termination Check in these Functions-  , reflects   :: !(S.HashSet LocSymbol)         -- ^ Binders to reflect-  , autois     :: !(M.HashMap LocSymbol (Maybe Int))  -- ^ Automatically instantiate axioms in these Functions with maybe specified fuel-  , hmeas      :: !(S.HashSet LocSymbol)         -- ^ Binders to turn into measures using haskell definitions-  , hbounds    :: !(S.HashSet LocSymbol)         -- ^ Binders to turn into bounds using haskell definitions-  , inlines    :: !(S.HashSet LocSymbol)         -- ^ Binders to turn into logic inline using haskell definitions-  , autosize   :: !(S.HashSet LocSymbol)         -- ^ Type Constructors that get automatically sizing info-  , pragmas    :: ![Located String]              -- ^ Command-line configurations passed in through source-  , cmeasures  :: ![Measure ty ()]               -- ^ Measures attached to a type-class-  , imeasures  :: ![Measure ty bndr]             -- ^ Mappings from (measure,type) -> measure-  , classes    :: ![RClass ty]                   -- ^ Refined Type-Classes-  , termexprs  :: ![(LocSymbol, [Located Expr])] -- ^ Terminating Conditions for functions-  , rinstance  :: ![RInstance ty]-  , dvariance  :: ![(LocSymbol, [Variance])]     -- ^ ? Where do these come from ?!-  , bounds     :: !(RRBEnv ty)-  , defs       :: !(M.HashMap LocSymbol Symbol)  -- ^ Temporary (?) hack to deal with dictionaries in specifications-                                                 --   see tests/pos/NatClass.hs-  , axeqs      :: ![AxiomEq]                     -- ^ AxiomEqualities used for Proof-By-Evaluation-  } deriving (Generic)---qualifySpec :: Symbol -> Spec ty bndr -> Spec ty bndr-qualifySpec name sp = sp { sigs      = [ (tx x, t)  | (x, t)  <- sigs sp]-                         , asmSigs   = [ (tx x, t)  | (x, t)  <- asmSigs sp]-                         }-  where-    tx = fmap (qualifySymbol name)--mkM ::  LocSymbol -> ty -> [Def ty bndr] -> Measure ty bndr-mkM name typ eqns+mkM ::  LocSymbol -> ty -> [Def ty bndr] -> MeasureKind -> UnSortedExprs -> Measure ty bndr+mkM name typ eqns kind u   | all ((name ==) . measure) eqns-  = M name typ eqns+  = M name typ eqns kind u   | otherwise   = panic Nothing $ "invalid measure definition for " ++ show name  mkMSpec' :: Symbolic ctor => [Measure ty ctor] -> MSpec ty ctor mkMSpec' ms = MSpec cm mm M.empty []   where-    cm     = groupMap (symbol . ctor) $ concatMap eqns ms-    mm     = M.fromList [(name m, m) | m <- ms ]+    cm     = groupMap (symbol . ctor) $ concatMap msEqns ms+    mm     = M.fromList [(msName m, m) | m <- ms ]  mkMSpec :: [Measure t LocSymbol] -> [Measure t ()] -> [Measure t LocSymbol] -> MSpec t LocSymbol mkMSpec ms cms ims = MSpec cm mm cmm ims   where-    cm     = groupMap (val . ctor) $ concatMap eqns (ms'++ims)-    mm     = M.fromList [(name m, m) | m <- ms' ]-    cmm    = M.fromList [(name m, m) | m <- cms ]+    cm     = groupMap (val . ctor) $ concatMap msEqns (ms'++ims)+    mm     = M.fromList [(msName m, m) | m <- ms' ]+    cmm    = M.fromList [(msName m, m) | m <- cms ]     ms'    = checkDuplicateMeasure ms  @@ -126,23 +74,18 @@ checkDuplicateMeasure ms   = case M.toList dups of       []         -> ms-      (m,ms):_   -> uError $ err m (name <$> ms)+      (m,ms):_   -> uError $ err m (msName <$> ms)     where-      gms        = group [(name m , m) | m <- ms]+      gms        = group [(msName m , m) | m <- ms]       dups       = M.filter ((1 <) . length) gms       err m ms   = ErrDupMeas (fSrcSpan m) (pprint (val m)) (fSrcSpan <$> ms) -      -- printf "\nDuplicate Measure Definitions for %s\n%s" (showpp m) (showpp $ map (loc . name) ms)-      -- err k1 k2 = ErrDupMeas (fSrcSpan k1) (pprint (val k1)) (fSrcSpan <$> [k1, k2])----- -- MOVE TO TYPES-instance Monoid (Spec ty bndr) where-  mappend s1 s2+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@@ -157,30 +100,37 @@            , ealiases   =           ealiases   s1 ++ ealiases   s2            , qualifiers =           qualifiers s1 ++ qualifiers s2            , decr       =           decr       s1 ++ decr       s2-           , lvars      =           lvars      s1 ++ lvars      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     = M.union   (embeds   s1)  (embeds   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  = []@@ -193,10 +143,10 @@            , includes   = []            , aliases    = []            , ealiases   = []-           , embeds     = M.empty+           , embeds     = mempty            , qualifiers = []            , decr       = []-           , lvars      = []+           , lvars      = S.empty             , lazy       = S.empty            , autois     = M.empty            , hmeas      = S.empty@@ -204,13 +154,16 @@            , 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@@ -220,19 +173,20 @@ dataConTypes :: MSpec (RRType Reft) DataCon -> ([(Var, RRType Reft)], [(LocSymbol, RRType Reft)]) dataConTypes  s = (ctorTys, measTys)   where-    measTys     = [(name m, sort m) | m <- M.elems (measMap s) ++ imeas s]-    ctorTys     = concatMap makeDataConType (snd <$> M.toList (ctorMap s))+    measTys     = [(msName m, msSort m) | m <- M.elems (measMap s) ++ imeas s]+    ctorTys     = concatMap makeDataConType (notracepp "HOHOH" . snd <$> M.toList (ctorMap s))  makeDataConType :: [Def (RRType Reft) DataCon] -> [(Var, RRType Reft)] makeDataConType []   = []-makeDataConType ds | isNothing (dataConWrapId_maybe dc)-  = [(woId, combineDCTypes "cdc0" t ts)]+makeDataConType ds | Mb.isNothing (dataConWrapId_maybe dc)+  = notracepp _msg [(woId, {- notracepp _msg $ -} combineDCTypes "cdc0" t ts)]   where     dc   = ctor (head ds)     woId = dataConWorkId dc     t    = varType woId     ts   = defRefType t <$> ds+    _msg  = "makeDataConType0" ++ showpp (woId, t, ts)  makeDataConType ds   = [(woId, extend loci woRType wrRType), (wrId, extend loci wrRType woRType)]@@ -254,7 +208,7 @@     isWorkerDef def       -- types are missing for arguments, so definition came from a logical measure       -- and it is for the worker datacon-      | any isNothing (snd <$> binds def)+      | any Mb.isNothing (snd <$> binds def)       = True       | otherwise       = length (binds def) == length (fst $ splitFunTys $ snd $ splitForAllTys wot)@@ -266,7 +220,7 @@        -> RType RTyCon RTyVar Reft extend lc t1' t2   | Just su <- mapArgumens lc t1 t2-  = t1 `strengthenResult` subst su (fromMaybe mempty (stripRTypeBase $ resultTy t2))+  = t1 `strengthenResult` subst su (Mb.fromMaybe mempty (stripRTypeBase $ resultTy t2))   | otherwise   = t1   where@@ -293,12 +247,8 @@     xs' = zipWith (\_ i -> symbol ("x" ++ show i)) (ty_binds rep) [1..]     su  = mkSubst $ zip (ty_binds rep) (EVar <$> xs') --- combineDCTypes :: (PPrint r, Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, Reftable (RTProp RTyCon RTyVar r))---                => Type -> [(RType RTyCon RTyVar r)] -> RType RTyCon RTyVar r-combineDCTypes            :: String -> Type -> [RRType Reft] -> RRType Reft-combineDCTypes _msg t0 ts0 = L.foldl' strengthenRefTypeGen (ofType t) ts-  where-    (t, ts) = {- tracepp ("combineDCTypes " ++ msg) -} (t0, ts0)+combineDCTypes :: String -> Type -> [RRType Reft] -> RRType Reft+combineDCTypes _msg t ts = L.foldl' strengthenRefTypeGen (ofType t) ts  mapArgumens :: SourcePos -> RRType Reft -> RRType Reft -> Maybe Subst mapArgumens lc t1 t2 = go xts1' xts2'@@ -320,19 +270,17 @@       = panic (Just $ sourcePosSrcSpan lc) ("The types for the wrapper and worker data constructors cannot be merged\n"           ++ show t1 ++ "\n" ++ show t2 ) +-- should constructors have implicits? probably not defRefType :: Type -> Def (RRType Reft) DataCon -> RRType Reft-defRefType tdc (Def f args dc mt xs body)-                     = notracepp ("defRefType: " ++ showpp f) $ generalize $ mkArrow as [] [] xts t'+defRefType tdc (Def f dc mt xs body)+                    = generalize $ mkArrow as [] [] [] xts t'   where-    xts              = stitchArgs (fSrcSpan f) dc (notracepp ("FIELDS-XS: " ++ showpp f) xs) (notracepp ("FIELDS-TS: " ++ showpp f ++ " tdc = " ++ showpp tdc) ts)-    t                = fromMaybe (ofType tr) mt-    t'               = mkForAlls args $ refineWithCtorBody dc f (fst <$> args) body t-    mkForAlls xts t  = L.foldl' (\t (x, tx) -> RAllE x tx t) t xts-    (αs, ts, tr)     = splitType tdc-    as                = makeRTVar . rTyVar <$> αs-    -- (αs,ps,dcTs,_)   = dataConSig dc-    -- (ts', tr)        = splitFunTys $ snd $ splitForAllTys tdc-    -- ts               = Misc.takeLast (length dcTs) ts'+    xts             = notracepp ("STITCHARGS" ++ showpp (dc, xs, ts)) +                    $ 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  splitType :: Type -> ([TyVar],[Type], Type) splitType t  = (αs, ts, tr)@@ -357,7 +305,6 @@       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 @@ -374,14 +321,13 @@ refineWithCtorBody :: Outputable a                    => a                    -> LocSymbol-                   -> [Symbol]                    -> Body                    -> RType c tv Reft                    -> RType c tv Reft-refineWithCtorBody dc f as body t =+refineWithCtorBody dc f body t =   case stripRTypeBase t of     Just (Reft (v, _)) ->-      strengthen t $ Reft (v, bodyPred (mkEApp f (eVar <$> (as ++ [v]))) body)+      strengthen t $ Reft (v, bodyPred (mkEApp f [eVar v]) body)     Nothing ->       panic Nothing $ "measure mismatch " ++ showpp f ++ " on con " ++ showPpr dc 
src/Language/Haskell/Liquid/Misc.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE TupleSections             #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DoAndIfThenElse #-}  module Language.Haskell.Liquid.Misc where @@ -7,8 +8,10 @@  import Control.Arrow (first) import System.FilePath+import System.Directory   (getModificationTime, doesFileExist)+import System.Environment (getExecutablePath) -import           Control.Exception     (catch, IOException)+import qualified Control.Exception     as Ex --(evaluate, catch, IOException) import qualified Data.HashSet          as S import qualified Data.HashMap.Strict   as M import qualified Data.List             as L@@ -19,7 +22,7 @@ import           Data.Function (on) import qualified Data.ByteString       as B import           Data.ByteString.Char8 (pack, unpack)-import           Text.PrettyPrint.HughesPJ ((<>), char, Doc)+import qualified Text.PrettyPrint.HughesPJ as PJ -- (char, Doc) import           Text.Printf import           Language.Fixpoint.Misc import           Paths_liquidhaskell@@ -119,6 +122,11 @@ zip4 (x1:xs1) (x2:xs2) (x3:xs3) (x4:xs4) = (x1, x2, x3, x4) : zip4 xs1 xs2 xs3 xs4 zip4 _ _ _ _                             = [] +isIncludeFile :: FilePath -> FilePath -> Bool +isIncludeFile incDir src = -- do +  -- incDir <- getIncludeDir +  -- return +  (incDir `L.isPrefixOf` src)  getIncludeDir :: IO FilePath getIncludeDir      = dropFileName <$> getDataFileName ("include" </> "Prelude.spec")@@ -127,9 +135,20 @@ getCssPath         = getDataFileName $ "syntax" </> "liquid.css"  getCoreToLogicPath :: IO FilePath-getCoreToLogicPath = fmap (</> "CoreToLogic.lg") getIncludeDir+getCoreToLogicPath = do+    let fileName = "CoreToLogic.lg" +    -- Try to find it first at executable path+    exePath <- dropFileName <$> getExecutablePath+    let atExe = exePath </> fileName+    exists <- doesFileExist atExe+    +    if exists then +      return atExe+    else +      fmap (</> fileName) getIncludeDir + {-@ type ListN a N = {v:[a] | len v = N} @-} {-@ type ListL a L = ListN a (len L) @-} @@ -161,8 +180,15 @@ zipWithDefM _ []     []     = return [] zipWithDefM _ xs     []     = return xs zipWithDefM _ []     ys     = return ys-zipWithDefM f (x:xs) (y:ys) = liftM2 (:) (f x y) (zipWithDefM f xs ys)+zipWithDefM f (x:xs) (y:ys) = (:) <$> f x y <*> zipWithDefM f xs ys +zipWithDef :: (a -> a -> a) -> [a] -> [a] -> [a]+zipWithDef _ []     []     = []+zipWithDef _ xs     []     = xs+zipWithDef _ []     ys     = ys+zipWithDef f (x:xs) (y:ys) = f x y : zipWithDef f xs ys++ -------------------------------------------------------------------------------- -- Originally part of Fixpoint's Misc: --------------------------------------------------------------------------------@@ -182,15 +208,36 @@ firstMaybes :: [Maybe a] -> Maybe a firstMaybes = listToMaybe . catMaybes +fromFirstMaybes :: a -> [Maybe a] -> a+fromFirstMaybes x = fromMaybe x . firstMaybes +-- fromFirstMaybes x = fromMaybe x . listToMaybe . catMaybes+ hashMapMapWithKey   :: (k -> v1 -> v2) -> M.HashMap k v1 -> M.HashMap k v2 hashMapMapWithKey f = fromJust . M.traverseWithKey (\k v -> Just (f k v)) -hashMapMapKeys      :: (Eq k, Hashable k) => (t -> k) -> M.HashMap t v -> M.HashMap k v-hashMapMapKeys f    = M.fromList . fmap (first f) . M.toList+hashMapMapKeys   :: (Eq k2, Hashable k2) => (k1 -> k2) -> M.HashMap k1 v -> M.HashMap k2 v+hashMapMapKeys f = M.fromList . fmap (first f) . M.toList -concatMapM :: (Monad f, Traversable t) => (a1 -> f [a]) -> t a1 -> f [a]+concatMapM :: (Monad m, Traversable t) => (a -> m [b]) -> t a -> m [b] concatMapM f = fmap concat . mapM f +replaceSubset :: (Eq k, Hashable k) => [(k, a)] -> [(k, a)] -> [(k, a)]+replaceSubset kvs kvs' = M.toList (L.foldl' upd m0 kvs')+  where +    m0                = M.fromList kvs +    upd m (k, v') +      | M.member k m  = M.insert k v' m +      | otherwise     = m ++replaceWith :: (Eq a, Hashable a) => (b -> a) -> [b] -> [b] -> [b]+replaceWith f xs ys = snd <$> replaceSubset xs' ys' +  where +    xs'             = [ (f x, x) | x <- xs ] +    ys'             = [ (f y, y) | y <- ys ] ++++ firstElems ::  [(B.ByteString, B.ByteString)] -> B.ByteString -> Maybe (Int, B.ByteString, (B.ByteString, B.ByteString)) firstElems seps str   = case splitters seps str of@@ -227,17 +274,21 @@     go xs []                 = xs     go [] _                  = [] -angleBrackets :: Doc -> Doc-angleBrackets p    = char '<' <> p <> char '>'+(<->) :: PJ.Doc -> PJ.Doc -> PJ.Doc+x <-> y = x PJ.<> y +angleBrackets :: PJ.Doc -> PJ.Doc+angleBrackets p = PJ.char '<' <-> p <-> PJ.char '>'+ mkGraph :: (Eq a, Eq b, Hashable a, Hashable b) => [(a, b)] -> M.HashMap a (S.HashSet b) mkGraph = fmap S.fromList . group  tryIgnore :: String -> IO () -> IO ()-tryIgnore s a = catch a $ \e ->-                do let err = show (e :: IOException)-                   writeLoud ("Warning: Couldn't do " ++ s ++ ": " ++ err)-                   return ()+tryIgnore s a = +  Ex.catch a $ \e -> do+    let err = show (e :: Ex.IOException)+    writeLoud ("Warning: Couldn't do " ++ s ++ ": " ++ err)+    return ()   condNull :: Bool -> [a] -> [a]@@ -293,3 +344,38 @@  sortOn :: (Ord b) => (a -> b) -> [a] -> [a] sortOn f = L.sortBy (compare `on` f)++firstGroup :: (Eq k, Ord k, Hashable k) => [(k, a)] -> [a] +firstGroup kvs = case groupList kvs of +  []   -> [] +  kvss -> snd . head . sortOn fst $ kvss ++{- mapEither :: (a -> Either b c) -> [a] -> ([b], [c])+mapEither f []     = ([], [])+mapEither f (x:xs) = case f x of +                       Left y  -> (y:ys, zs)+                       Right z -> (ys, z:zs)+                     where +                       (ys, zs) = mapEither f xs +-}++keyDiff :: (Eq k, Hashable k) => (a -> k) -> [a] -> [a] -> [a]+keyDiff f x1s x2s = M.elems (M.difference (m x1s) (m x2s))+  where +    m xs          = M.fromList [(f x, x) | x <- xs] ++concatUnzip :: [([a], [b])] -> ([a], [b])+concatUnzip xsyss = (concatMap fst xsyss, concatMap snd xsyss)+++sayReadFile :: FilePath -> IO String +sayReadFile f = do +  -- print ("SAY-READ-FILE: " ++ f)+  res <- readFile f +  Ex.evaluate res++lastModified :: FilePath -> IO (Maybe UTCTime) +lastModified f = do +  ex  <- doesFileExist f+  if ex then Just <$> getModificationTime f+        else return   Nothing
− src/Language/Haskell/Liquid/Model.hs 
@@ -1,500 +0,0 @@-{-# LANGUAGE BangPatterns              #-}-{-# LANGUAGE ConstraintKinds           #-}-{-# LANGUAGE DeriveDataTypeable        #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE KindSignatures            #-}-{-# LANGUAGE LambdaCase                #-}-{-# LANGUAGE MagicHash                 #-}-{-# LANGUAGE RecordWildCards           #-}-{-# LANGUAGE NamedFieldPuns            #-}-{-# LANGUAGE ScopedTypeVariables       #-}--module Language.Haskell.Liquid.Model where--import GHC.Exts (Constraint)-import           Control.Monad-import           Control.Monad.IO.Class-import           Control.Monad.Reader-import           Control.Monad.State-import           Data.Bifunctor-import qualified Data.HashMap.Strict                   as HM-import           Data.List                        (partition)-import           Data.Maybe-import           Data.Proxy-import           GHC.Prim-import           System.Console.CmdArgs.Verbosity (whenLoud)-import           Text.PrettyPrint.HughesPJ-import           Text.Printf--import           Language.Fixpoint.Types (FixResult(..), mapPredReft, Symbol, symbol, Expr(..),-                                          mkSubst, subst)-import           Language.Fixpoint.Smt.Interface-import qualified Language.Fixpoint.Types.Config as FC-import           Language.Haskell.Liquid.GHC.Interface-import           Language.Haskell.Liquid.GHC.Misc-import           Language.Haskell.Liquid.Types         hiding (var)-import           Language.Haskell.Liquid.Types.RefType-import           Language.Haskell.Liquid.UX.Tidy--import           Test.Target.Monad-import           Test.Target.Targetable-import           Test.Target.Testable---import           Bag-import           GHC hiding (obtainTermFromVal)-import qualified Outputable as GHC-import           DynFlags-import           HscMain hiding (hscParsedStmt, ioMsgMaybe)-import           InstEnv-import           Type-import           TysWiredIn-import           UniqSet-import           VarSet-import           InteractiveEval--import Id-import ByteCodeGen      ( byteCodeGen )-import Linker-import CoreLint         ( lintInteractiveExpr )-import Panic-import ConLike-import CoreSyn-import SrcLoc-import TcRnDriver-import TcRnMonad-import Desugar-import TidyPgm-import CorePrep-import TyCon-import ErrUtils-import HscTypes-import Exception-import Util--{- NV: Currently Unused -import           Unsafe.Coerce-import           OccName-import           RdrName-import           Var-import FastString--}---- import           Debug.Trace--getModels :: GhcInfo -> Config -> FixResult Error -> IO (FixResult Error)-getModels info cfg fi = case fi of-  Unsafe cs-    | cfg `hasOpt` counterExamples-    -> fmap Unsafe . runLiquidGhc mbenv cfg $ do-    df <- getSessionDynFlags-    let df' = df { packageFlags = ExposePackage "" (PackageArg "liquidhaskell")-                                  (ModRenaming True [])-                                : packageFlags df-                 }-    _ <- setSessionDynFlags df'-    imps <- getContext-    setContext ( IIModule (targetMod info)-               : IIDecl ((simpleImportDecl (mkModuleName "Test.Target.Targetable"))-                                           { ideclQualified = True })-               : imps)-    mapM (getModel info cfg) cs-  _         -> return fi-  where-  mbenv = Just (env info)--getModel :: GhcInfo -> Config -> Error -> Ghc Error-getModel info cfg err-  = getModel' info cfg err-    `gcatch`-    \(e :: SomeException) -> do-      liftIO $ whenLoud $-        printf "WARNING: could not generate counter-example: %s\n" (show e)-      return err--getModel' :: GhcInfo -> Config -> Error -> Ghc Error-getModel' info cfg (ErrSubType { pos, msg, ctx, tact, texp }) = do-  let vv  = (symbol "VV", tact `strengthen` (fmap (mapPredReft PNot) (rt_reft texp)))-  let vts = vv : HM.toList ctx--  let (preds, vts') = partition (isPredTy . toType . snd) vts--  vtds <- addDicts (map (toType.snd) preds) vts'--  hsc_env <- getSession-  df <- getDynFlags-  let opts = defaultOpts-  model <- liftIO $ withContext (toFixCfg cfg) (solver opts) (target info) $ \smt -> do-    runTarget opts (initState (target info) (spec info) smt) $ do-      free <- gets freesyms-      let dcs = [ (v, tidySymbol v)-                | iv <- impVars info-                , isDataConId iv-                , let v = symbol iv-                ]-      let su  = mkSubst $ map (second EVar) (free ++ dcs)-      n <- asks depth-      vs <- forM vtds $ \(v, t, md) -> case md of-        Nothing -> do-          -- if we don't have a Targetable instance, just encode it as an Int so-          -- the name is available-          addVariable (v, getType (Proxy :: Proxy Int))-          return v-        Just (TargetDict d@Dict)  -> do-          addVariable (v, getType (dictProxy d))-          query (dictProxy d) n v (subst su t)-      setup-      _ <- liftIO $ command smt CheckSat-      forM (zip vs vtds) $ \(sv, (v, t, md)) -> case md of-        Nothing -> do return (v, NoModel t)-        Just (TargetDict d@Dict) -> do-          x <- decode sv t-          xt <- liftIO $ obtainTermFromVal hsc_env 100 True (toType t) (x `asTypeOfDict` d)-          return (v, WithModel (text (GHC.showPpr df xt)) t)--  let (_, vv_wm) : ctx_model = model-  return (ErrSubTypeModel-          { pos  = pos-          , msg  = msg-          , ctxM  = HM.fromList ctx_model --  `HM.union` fmap NoModel ctx-                   -- HM.union is *left-biased*-          , tactM = case vv_wm of-                      WithModel vv_model _ -> WithModel vv_model tact-                      NoModel _            -> NoModel tact-          , texp = texp-          })--getModel' _ _ err = return err---withContext :: FC.Config -> FC.SMTSolver -> FilePath -> (Context -> IO a) -> IO a-withContext cfg s t act = do-  ctx <- makeContext (cfg{FC.solver = s}) t-  act ctx `finally` cleanupContext ctx---toFixCfg :: Config -> FC.Config-toFixCfg cfg-  = FC.defConfig-     { FC.solver    = fromMaybe FC.Z3 $ smtsolver cfg-     , FC.allowHO   = higherOrderFlag cfg-     , FC.allowHOqs = higherorderqs   cfg-     }--dictProxy :: forall t. Dict (Targetable t) -> Proxy t-dictProxy Dict = Proxy--asTypeOfDict :: forall t. t -> Dict (Targetable t) -> t-x `asTypeOfDict` Dict = x--data Dict :: Constraint -> * where-  Dict :: a => Dict a--data TargetDict = forall t. TargetDict (Dict (Targetable t))--addDicts :: [PredType] -> [(Symbol, SpecType)]-         -> Ghc [(Symbol, SpecType, Maybe TargetDict)]-addDicts preds bnds = mapM (addDict preds) bnds---- TODO: instead of returning Maybe (Symbol, SpecType, TargetDict),--- return (Symbol, SpecType, Maybe TargetDict).--- if Nothing, generate a binder for the value, but no skeleton / model.--- this way we can possibly still generate models for other values in the context-addDict :: [PredType] -> (Symbol, SpecType)-        -> Ghc (Symbol, SpecType, Maybe TargetDict)-addDict preds (v, t) = addDict' preds (v, t) `gcatch`-                       \(_e :: SomeException) -> return (v, t, Nothing)--addDict' :: [PredType] -> (Symbol, SpecType)-         -> Ghc (Symbol, SpecType, Maybe TargetDict)-addDict' _ _ -  = error "TODO"-{-  NV TODO this has noumerous errors on ghc-8 -addDict' _preds (v, t)-  | Type.isFunTy (toType t)-  = return (v, t, Nothing)-addDict' preds (v, t) = do-  -- liftIO $ putStrLn $ showPpr (toType t, preds)-  msu <- monomorphize preds (toType t)-  -- liftIO $ putStrLn $ showPpr msu-  case msu of-    Nothing -> return (v, t, Nothing)-    Just su -> do-      let (tvs, ts) = unzip su-      let mt = substTyWith tvs ts (toType t)-  -- traceShowM (v, t, showPpr mt)-      case tyConAppTyCon_maybe mt of-        Nothing -> return (v, t, Nothing)-        Just tc | isClassTyCon tc || isFunTyCon tc || isPrimTyCon tc-                  || isPromotedDataCon tc || isPromotedTyCon tc-                  -- FIXME: shouldn't be necessary..-                  -- why do we have binders for higher-kinded types??-                  || Type.isFunTy (Type.typeKind mt)-                  -- TODO: cannot handle `Targetable (Fix f)`, see higher-kinded classes e.g. Eq1, Ord1, etc...-                  || any Type.isFunTy (map Var.varType (tyConTyVars tc))-                  -> return (v, t, Nothing)-        Just tc -> do-          getInfo False (getName tc) >>= \case-            Nothing -> return (v, t, Nothing)-            Just (ATyCon tc, _, cis, _) -> do-              genericsMod   <- lookupModule (mkModuleName "GHC.Generics") Nothing-              targetableMod <- lookupModule (mkModuleName "Test.Target.Targetable") Nothing-              modelMod      <- lookupModule (mkModuleName "Language.Haskell.Liquid.Model") Nothing--              let genericClsName    = mkOrig genericsMod (mkClsOcc "Generic")-              let targetableClsName = mkOrig targetableMod (mkClsOcc "Targetable")-              let dictTcName        = mkOrig modelMod (mkTcOcc "Dict")-              let dictDataName      = mkOrig modelMod (mkDataOcc "Dict")--              -- let mt = monomorphize (toType t)--              -- liftIO $ putStrLn $ showPpr tc-              -- maybe add a Targetable instance-              unless ("Test.Target.Targetable.Targetable"-                      `elem` map (showpp.is_cls_nm) cis) $ do--                let tvs =  map (getRdrName) (tyConTyVars tc)-                let tvbnds = userHsTyVarBndrs noSrcSpan tvs--                -- maybe derive a Generic instance-                unless ("GHC.Generics.Generic"-                        `elem` map (showpp.is_cls_nm) cis) $ do-                  let genericInst = nlHsTyConApp genericClsName-                                   [nlHsTyConApp (getRdrName tc) (map nlHsTyVar tvs)]-                  let instType = noLoc $ HsForAllTy Implicit Nothing-                                 (HsQTvs [] tvbnds)-                                 (noLoc []) -- (noLoc (map (nlHsTyConApp genericClsName . pure . nlHsTyVar) tvs))-                                 genericInst-                  let derivDecl = DerivD $ DerivDecl instType Nothing-                  -- liftIO $ putStrLn $ showPpr derivDecl-                  hsc_env <- getSession-                  (_, ic) <- liftIO $ hscParsedDecls hsc_env [noLoc derivDecl]-                  setSession $ hsc_env { hsc_IC = ic }--                let targetInst = nlHsTyConApp targetableClsName-                                 [nlHsTyConApp (getRdrName tc) (map nlHsTyVar tvs)]-                let instType = noLoc $ HsForAllTy Implicit Nothing-                               (HsQTvs [] tvbnds)-                               -- (noLoc [])-                               (noLoc (map (nlHsTyConApp targetableClsName . pure . nlHsTyVar) tvs))-                               targetInst-                let instDecl = InstD $ ClsInstD $ ClsInstDecl-                               instType emptyBag [] [] [] Nothing-                -- liftIO $ putStrLn $ showPpr instDecl-                hsc_env <- getSession-                (_, ic) <- liftIO $ hscParsedDecls hsc_env [noLoc instDecl]-                setSession $ hsc_env { hsc_IC = ic }--              hsc_env <- getSession--              let targetType = nlHsTyConApp targetableClsName [toHsType mt]--              let dictExpr = ExprWithTySig (nlHsVar dictDataName)-                                           (nlHsTyConApp dictTcName [targetType])-                                           PlaceHolder-              let dictStmt = noLoc $ LetStmt $ noLoc $ HsValBinds $ ValBindsIn-                             (listToBag [noLoc $-                                         mkFunBind (noLoc $ mkVarUnqual $ fsLit "_compile")-                                         [mkSimpleMatch [] (noLoc dictExpr)]])-                             []-              -- liftIO $ putStrLn $ showPpr dictStmt-              x <- liftIO $ hscParsedStmt hsc_env dictStmt-              case x of-                Nothing -> return (v, t, Nothing)-                Just (_, hvals_io, _) -> do-                  [hv] <- liftIO hvals_io-                  let d = TargetDict $ unsafeCoerce hv-                  return (v, subts su t, Just d)--            _ -> return (v, t, Nothing)--}--type Su = [(TyVar, Type)]---- FIXME: can't instantiate higher-kinded tvs with 'Int'--- | Attempt to monomorphize a 'Type' according to simple defaulting rules.-monomorphize :: [PredType] -> Type -> Ghc (Maybe Su)-monomorphize preds t = foldM (\s tv -> monomorphizeOne preds tv s)-                             (Just [])-                             (varSetElems $ tyCoVarsOfType t)-  where-    varSetElems _ = []--monomorphizeOne :: [PredType] -> TyVar -> Maybe Su -> Ghc (Maybe Su)-monomorphizeOne _preds _tv Nothing = return Nothing-monomorphizeOne preds tv (Just su)-  | null clss-  = return (monomorphizeFree tv su)--  | otherwise-  = do insts <- concatMapM (fmap (thd4 . fromJust)-                            . getInfo False . getName)-                           clss-       if any (\ClsInst {..} -> length is_tys /= 1) insts-         -- TODO: handle multi-param (/ nullary) classes-         then return Nothing-         else do-         -- liftIO $ putStrLn $ showPpr insts-         let tcs = map (mkUniqSet . map tyConAppTyCon . is_tys) insts-         let common_tcs = uniqSetToList $ foldr1 intersectUniqSets tcs-         -- liftIO $ putStrLn $ showPpr common_tcs-         case common_tcs of-           -- hopefully doesn't happen-           [] -> return Nothing--           tc:_ -> return (Just ((tv, (mkTyConApp tc [])) : su))-  where--  clss = map (fst.getClassPredTys)-       . filter (\p -> tv `elemVarSet` tyCoVarsOfType p)-       $ preds--  thd4 (_,_,c,_) = c--  -- UniqSet tries to be deterministic-  uniqSetToList = nonDetFoldUniqSet (:) []--monomorphizeFree :: TyVar -> Su -> Maybe Su-monomorphizeFree tv su-  | tyVarKind tv == liftedTypeKind-    -- replace (a :: *) with Int-  = Just ((tv, intTy) : su)--  | Just (_, b) <- splitFunTy_maybe (tyVarKind tv)-  , b == liftedTypeKind-    -- replace (a :: * -> *) with []-  = Just ((tv, (mkTyConApp listTyCon [])) : su)--  | otherwise-    -- TODO: higher-kinded types-  = Nothing--------------------------------------------------------------------------- Slightly altered from GHC-------------------------------------------------------------------------hscParsedStmt :: HscEnv-              -> GhciLStmt RdrName  -- ^ The parsed statement-              -> IO ( Maybe ([Id]-                    , IO [HValue]-                    , FixityEnv))-hscParsedStmt hsc_env parsed_stmt = runInteractiveHsc hsc_env $ do--  -- Rename and typecheck it-  hsc_env <- getHscEnv-  (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env parsed_stmt--  -- Desugar it-  ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr-  liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr)-  handleWarnings--  -- Then code-gen, and link it-  -- It's important NOT to have package 'interactive' as thisPackageKey-  -- for linking, else we try to link 'main' and can't find it.-  -- Whereas the linker already knows to ignore 'interactive'-  let  src_span     = srcLocSpan interactiveSrcLoc-  hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr-  let hval_io = unsafeCoerce# hval :: IO [HValue]--  return $ Just (ids, hval_io, fix_env)--handleWarnings :: Hsc ()-handleWarnings = do-    dflags <- getDynFlags-    w <- getWarnings-    liftIO $ printOrThrowWarnings dflags w-    clearWarnings-ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a-ioMsgMaybe ioA = do-    ((warns,errs), mb_r) <- liftIO ioA-    logWarnings warns-    case mb_r of-        Nothing -> throwErrors errs-        Just r  -> return r-throwErrors :: ErrorMessages -> Hsc a-throwErrors = liftIO . throwIO . mkSrcErr-getWarnings :: Hsc WarningMessages-getWarnings = Hsc $ \_ w -> return (w, w)-clearWarnings :: Hsc ()-clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)-logWarnings :: WarningMessages -> Hsc ()-logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)---- hscDeclsWithLocation :: HscEnv---                      -> String -- ^ The statement---                      -> String -- ^ The source---                      -> Int    -- ^ Starting line---                      -> IO ([TyThing], InteractiveContext)-hscParsedDecls :: HscEnv-               -> [LHsDecl RdrName] -> IO ([TyThing], InteractiveContext)-hscParsedDecls hsc_env0 decls =- runInteractiveHsc hsc_env0 $ do--    {- Rename and typecheck it -}-    hsc_env <- getHscEnv-    tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls--    {- Grab the new instances -}-    -- We grab the whole environment because of the overlapping that may have-    -- been done. See the notes at the definition of InteractiveContext-    -- (ic_instances) for more details.-    let defaults = tcg_default tc_gblenv--    {- Desugar it -}-    -- We use a basically null location for iNTERACTIVE-    let iNTERACTIVELoc = ModLocation{ ml_hs_file   = Nothing,-                                      ml_hi_file   = Panic.panic "hsDeclsWithLocation:ml_hi_file",-                                      ml_obj_file  = Panic.panic "hsDeclsWithLocation:ml_hi_file"}-    ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv--    {- Simplify -}-    simpl_mg <- liftIO $ hscSimplify hsc_env ds_result--    {- Tidy -}-    (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg--    let _dflags = hsc_dflags hsc_env-        !CgGuts{ cg_module    = this_mod,-                 cg_binds     = core_binds,-                 cg_tycons    = tycons,-                 cg_modBreaks = mod_breaks } = tidy_cg--        !ModDetails { md_insts     = cls_insts-                    , md_fam_insts = fam_insts } = mod_details-            -- Get the *tidied* cls_insts and fam_insts--        data_tycons = filter isDataTyCon tycons--    {- Prepare For Code Generation -}-    -- Do saturation and convert to A-normal form-    prepd_binds <- {-# SCC "CorePrep" #-}-      liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons--    {- Generate byte code -}-    cbc <- liftIO $ byteCodeGen hsc_env this_mod-                                prepd_binds data_tycons mod_breaks--    let src_span = srcLocSpan interactiveSrcLoc-    liftIO $ linkDecls hsc_env src_span cbc--    let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)-        patsyns = mg_patsyns simpl_mg--        ext_ids = [ id | id <- bindersOfBinds core_binds-                       , isExternalName (idName id)-                       , not (isDFunId id || isImplicitId id) ]-            -- We only need to keep around the external bindings-            -- (as decided by TidyPgm), since those are the only ones-            -- that might be referenced elsewhere.-            -- The DFunIds are in 'cls_insts' (see Note [ic_tythings] in HscTypes-            -- Implicit Ids are implicit in tcs--        tythings =  map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns--    let icontext = hsc_IC hsc_env-        ictxt    = extendInteractiveContext icontext ((AnId <$> ext_ids) ++  (ATyCon <$> tcs))-                                            cls_insts fam_insts defaults emptyFixityEnv-    -- extendInteractiveContext :: InteractiveContext -> [TyThing] -> [ClsInst] -> [FamInst] -> Maybe [Type] -> FixityEnv -> InteractiveContext                                        -    return (tythings, ictxt)
src/Language/Haskell/Liquid/Parse.hs view
@@ -25,32 +25,26 @@ import           Text.Parsec.Error                      (newErrorMessage, Message (..)) import           Text.Parsec.Pos +-- import           Text.Parsec.Char                       (newline)  import qualified Text.Parsec.Token                      as Token import qualified Data.Text                              as T import qualified Data.HashMap.Strict                    as M import qualified Data.HashSet                           as S-import           Data.Monoid+-- import           Data.Monoid import           Data.Data-import           Data.Maybe (isNothing, fromMaybe)--+import qualified Data.Maybe                             as Mb -- (isNothing, fromMaybe) import           Data.Char                              (isSpace, isAlpha, isUpper, isAlphaNum, isDigit) import           Data.List                              (foldl', partition)- import           GHC                                    (ModuleName, mkModuleName)-import           Text.PrettyPrint.HughesPJ              (text )--- import           SrcLoc                                 (noSrcSpan)-+import qualified Text.PrettyPrint.HughesPJ              as PJ +import           Text.PrettyPrint.HughesPJ.Compat       ((<+>))  import           Language.Fixpoint.Types                hiding (panic, SVar, DDecl, DataDecl, DataCtor (..), Error, R, Predicate) import           Language.Haskell.Liquid.GHC.Misc-import           Language.Haskell.Liquid.Types          -- hiding (Axiom)-import qualified Language.Fixpoint.Misc                 as Misc           --  (mapSnd)+import           Language.Haskell.Liquid.Types          +import qualified Language.Fixpoint.Misc                 as Misc       import qualified Language.Haskell.Liquid.Misc           as Misc-import           Language.Haskell.Liquid.Types.RefType-import           Language.Haskell.Liquid.Types.Variance-import           Language.Haskell.Liquid.Types.Bounds import qualified Language.Haskell.Liquid.Measure        as Measure-import           Language.Fixpoint.Parse                hiding (dataDeclP, angles, refBindP, refP, refDefP)+import           Language.Fixpoint.Parse                hiding (stringLiteral, dataDeclP, angles, refBindP, refP, refDefP)  import Control.Monad.State @@ -68,9 +62,8 @@                  -> [BPspec]                  -> Either [Error] (ModName, Measure.BareSpec) ---------------------------------------------------------------------------------- hsSpecificationP _ [] _ = Left [ErrParseAnn noSrcSpan (text "Malformed annotation")] hsSpecificationP modName specComments specQuotes =-  case go ([], []) initPState $ reverse specComments of+  case go ([], []) initPStateWithList $ reverse specComments of     ([], specs) ->       Right $ mkSpec (ModName SrcImport modName) (specs ++ specQuotes)     (errs, _) ->@@ -85,24 +78,32 @@  -- | Used to parse .spec files +initPStateWithList :: PState+initPStateWithList +  = initPState { empList  = Just (EVar ("GHC.Types.[]" :: Symbol))+               , singList = Just (\e -> EApp (EApp (EVar ("GHC.Types.:"  :: Symbol)) e) (EVar ("GHC.Types.[]" :: Symbol)))+               }+ -------------------------------------------------------------------------- specSpecificationP  :: SourceName -> String -> Either Error (ModName, Measure.BareSpec) ---------------------------------------------------------------------------specSpecificationP f s = mapRight snd $  parseWithError initPState specificationP (newPos f 1 1) s+specSpecificationP f s = mapRight snd $  parseWithError initPStateWithList specificationP (newPos f 1 1) s  specificationP :: Parser (ModName, Measure.BareSpec)-specificationP-  = do reserved "module"-       reserved "spec"-       name   <- symbolP-       reserved "where"-       xs     <- grabs (specP <* whiteSpace)-       return $ mkSpec (ModName SpecImport $ mkModuleName $ symbolString name) xs+specificationP = do +  reserved "module"+  reserved "spec"+  name   <- symbolP+  reserved "where"+  xs     <- if True then grabs (specP <* whiteSpace) else sepBy specP newline+  return $ mkSpec (ModName SpecImport $ mkModuleName $ symbolString name) xs +-- debugP = grabs (specP <* whiteSpace)+ ------------------------------------------------------------------------------- singleSpecP :: SourcePos -> String -> Either Error BPspec --------------------------------------------------------------------------------singleSpecP pos = mapRight snd . parseWithError initPState specP pos+singleSpecP pos = mapRight snd . parseWithError initPStateWithList specP pos  mapRight :: (a -> b) -> Either l a -> Either l b mapRight f (Right x) = Right $ f x@@ -128,7 +129,7 @@   where     pos             = errorPos e     sp              = sourcePosSrcSpan pos-    msg             = text $ "Error Parsing Specification from: " ++ sourceName pos+    msg             = "Error Parsing Specification from:" <+> PJ.text (sourceName pos)  --------------------------------------------------------------------------- remParseError       :: SourcePos -> String -> String -> ParseError@@ -159,7 +160,7 @@ --------------------------------------------------------------------------------  parseSymbolToLogic :: SourceName -> String -> Either Error LogicMap-parseSymbolToLogic f = mapRight snd . parseWithError initPState toLogicP (newPos f 1 1)+parseSymbolToLogic f = mapRight snd . parseWithError initPStateWithList toLogicP (newPos f 1 1)  toLogicP :: Parser LogicMap toLogicP@@ -199,7 +200,7 @@ -- | BareTypes ----------------------------------------------------------------- -------------------------------------------------------------------------------- -{- | [NOTE:BARETYPE-PARSE] Fundamentally, a type is ofthe form+{- | [NOTE:BARETYPE-PARSE] Fundamentally, a type is of the form        comp -> comp -> ... -> comp @@ -248,6 +249,11 @@             return (PC sb (rFun b t1 t2)))         <|>          (do+            reservedOp "~>"+            PC _ t2 <- btP+            return (PC sb (rImpF b t1 t2)))+        <|>+         (do             reservedOp "=>"             PC _ t2 <- btP             -- TODO:AZ return an error if s == PcExplicit@@ -255,11 +261,6 @@          <|> return c)  --- _rFun' b t1 t2 = tracepp msg (rFun b t1 t2)- -- where msg    = "RFUN: b = " ++ showpp b ++-                -- " t1 = "     ++ showpp t1 ++-                -- " t2 = "     ++ showpp t2- compP :: Parser ParamComp compP = circleP <* whiteSpace <|> parens btP <?> "compP" @@ -278,8 +279,8 @@ anglesCircleP   = angles $ do       PC sb t <- parens btP-      p <- monoPredicateP-      return $ PC sb (t `strengthen` MkUReft mempty p mempty)+      p       <- monoPredicateP+      return   $ PC sb (t `strengthen` MkUReft mempty p mempty)  holePC :: Parser ParamComp holePC = do@@ -317,13 +318,13 @@  bareTypeBracesP :: Parser ParamComp bareTypeBracesP = do-  t <-  braces (+  t <-  try (braces (             (try (do                ct <- constraintP                return $ Right ct                      ))            <|>-            (try(do+            (do                     x  <- symbolP                     _ <- colon                     -- NOSUBST i  <- freshIntP@@ -334,16 +335,22 @@                     -- su replaces any use of x in the balance of the expression with the unique val                     -- NOSUBST let xi = intSymbol x i                     -- NOSUBST let su v = if v == x then xi else v-                    return $ Left $ PC (PcExplicit x) $ t (Reft (x, ra)) ))-           <|> do t <- ((RHole . uTop . Reft . ("VV",)) <$> (refasHoleP <* spaces))-                  return (Left $ nullPC t)-            )+                    return $ Left $ PC (PcExplicit x) $ t (Reft (x, ra)) )+            )) <|> try (helper holeOrPredsP) <|> helper predP   case t of     Left l -> return l     Right ct -> do       PC _sb tt <- btP       return $ nullPC $ rrTy ct tt+  where+    holeOrPredsP+      = (reserved "_" >> return hole)+     <|> try (pAnd <$> brackets (sepBy predP semi))+    helper p = braces $ do+      t <- ((RHole . uTop . Reft . ("VV",)) <$> (p <* spaces))+      return (Left $ nullPC t) + bareArgP :: Symbol -> Parser BareType bareArgP vvv   =  refDefP vvv refasHoleP bbaseP    -- starts with '{'@@ -469,9 +476,15 @@  <|> mkBTyCon <$> locUpperIdP  <?> "bTyConP" +mkPromotedBTyCon :: LocSymbol -> BTyCon+mkPromotedBTyCon x = BTyCon x False True -- (consSym '\'' <$> x) False True+ classBTyConP :: Parser BTyCon classBTyConP = mkClassBTyCon <$> locUpperIdP +mkClassBTyCon :: LocSymbol -> BTyCon+mkClassBTyCon x = BTyCon x True False+ stratumP :: Parser Strata stratumP   = do reservedOp "^"@@ -506,7 +519,7 @@ bareAtomNoAppP :: Parser BareType bareAtomNoAppP   =  refP bbaseNoAppP- <|> (dummyP (bbaseNoAppP <* spaces))+ <|> (dummyP (bbaseNoAppP <* blanks))  <?> "bareAtomNoAppP"  @@ -516,9 +529,11 @@        t1  <- bareTypeP        reservedOp "<:"        t2  <- bareTypeP-       return $ fromRTypeRep $ RTypeRep [] [] [] ((val . fst <$> xts) ++ [dummySymbol])-                                                 (replicate (length xts + 1) mempty)-                                                 ((snd <$> xts) ++ [t1]) t2+       return $ fromRTypeRep $ RTypeRep [] [] []+                                        [] [] []+                                        ((val . fst <$> xts) ++ [dummySymbol])+                                        (replicate (length xts + 1) mempty)+                                        ((snd <$> xts) ++ [t1]) t2  constraintEnvP :: Parser [(LocSymbol, BareType)] constraintEnvP@@ -787,12 +802,12 @@   | isTauto r  = t   | otherwise  = t `strengthen` (reftUReft r) bTup ts rs r-  | all isNothing (fst <$> ts) || length ts < 2+  | all Mb.isNothing (fst <$> ts) || length ts < 2   = RApp (mkBTyCon $ dummyLoc tupConName) (snd <$> ts) rs (reftUReft r)   | otherwise   = RApp (mkBTyCon $ dummyLoc tupConName) ((top . snd) <$> ts) rs' (reftUReft r)   where-    args       = [(fromMaybe dummySymbol x, mapReft mempty t) | (x,t) <- ts]+    args       = [(Mb.fromMaybe dummySymbol x, mapReft mempty t) | (x,t) <- ts]     makeProp i = RProp (take i args) ((snd <$> ts)!!i)     rs'        = makeProp <$> [1..(length ts-1)] @@ -832,44 +847,141 @@ --------------------------- Measures ----------------------------- ------------------------------------------------------------------ -type BPspec = Pspec (Located BareType) LocSymbol+type BPspec = Pspec LocBareType LocSymbol  data Pspec ty ctor-  = Meas    (Measure ty ctor)-  | Assm    (LocSymbol, ty)-  | Asrt    (LocSymbol, ty)-  | LAsrt   (LocSymbol, ty)-  | Asrts   ([LocSymbol], (ty, Maybe [Located Expr]))-  | Impt    Symbol-  | DDecl   DataDecl-  | NTDecl  DataDecl-  | Incl    FilePath-  | Invt    ty-  | IAlias  (ty, ty)-  | Alias   (RTAlias Symbol BareType)-  | EAlias  (RTAlias Symbol Expr)-  | Embed   (LocSymbol, FTycon)-  | Qualif  Qualifier-  | Decr    (LocSymbol, [Int])-  | LVars   LocSymbol-  | Lazy    LocSymbol-  | Insts   (LocSymbol, Maybe Int)-  | HMeas   LocSymbol-  | Reflect LocSymbol-  | Inline  LocSymbol-  | ASize   LocSymbol-  | HBound  LocSymbol-  | PBound  (Bound ty Expr)-  | Pragma  (Located String)-  | CMeas   (Measure ty ())-  | IMeas   (Measure ty ctor)-  | Class   (RClass ty)-  | RInst   (RInstance ty)-  | Varia   (LocSymbol, [Variance])-  | BFix    ()-  | Define  (LocSymbol, Symbol)-  deriving (Data, Typeable, Show)+  = Meas    (Measure ty ctor)                             -- ^ 'measure' definition+  | Assm    (LocSymbol, ty)                               -- ^ 'assume' signature (unchecked)+  | Asrt    (LocSymbol, ty)                               -- ^ 'assert' signature (checked)+  | LAsrt   (LocSymbol, ty)                               -- ^ 'local' assertion -- RJ: what is this+  | Asrts   ([LocSymbol], (ty, Maybe [Located Expr]))     -- ^ RJ: what is this+  | Impt    Symbol                                        -- ^ 'import' a specification module+  | DDecl   DataDecl                                      -- ^ refined 'data'    declaration +  | NTDecl  DataDecl                                      -- ^ refined 'newtype' declaration+  | Class   (RClass ty)                                   -- ^ refined 'class' definition+  | CLaws   (RClass ty)                                   -- ^ 'class laws' definition+  | ILaws   (RILaws ty)+  | RInst   (RInstance ty)                                -- ^ refined 'instance' definition+  | Incl    FilePath                                      -- ^ 'include' a path -- TODO: deprecate +  | Invt    ty                                            -- ^ 'invariant' specification+  | Using  (ty, ty)                                       -- ^ 'using' declaration (for local invariants on a type) +  | Alias   (Located (RTAlias Symbol BareType))           -- ^ 'type' alias declaration  +  | EAlias  (Located (RTAlias Symbol Expr))               -- ^ 'predicate' alias declaration+  | Embed   (LocSymbol, FTycon, TCArgs)                   -- ^ 'embed' declaration+  | Qualif  Qualifier                                     -- ^ 'qualif' definition+  | Decr    (LocSymbol, [Int])                            -- ^ 'decreasing' annotation -- TODO: deprecate+  | LVars   LocSymbol                                     -- ^ 'lazyvar' annotation, defer checks to *use* sites+  | Lazy    LocSymbol                                     -- ^ 'lazy' annotation, skip termination check on binder+  | Insts   (LocSymbol, Maybe Int)                        -- ^ 'auto-inst' or 'ple' annotation; use ple locally on binder +  | HMeas   LocSymbol                                     -- ^ 'measure' annotation; lift Haskell binder as measure+  | Reflect LocSymbol                                     -- ^ 'reflect' annotation; reflect Haskell binder as function in logic+  | Inline  LocSymbol                                     -- ^ 'inline' annotation;  inline (non-recursive) binder as an alias+  | Ignore  LocSymbol                                     -- ^ 'ignore' annotation; skip all checks inside this binder+  | ASize   LocSymbol                                     -- ^ 'autosize' annotation; automatically generate size metric for this type+  | HBound  LocSymbol                                     -- ^ 'bound' annotation; lift Haskell binder as an abstract-refinement "bound"+  | PBound  (Bound ty Expr)                               -- ^ 'bound' definition+  | Pragma  (Located String)                              -- ^ 'LIQUID' pragma, used to save configuration options in source files+  | CMeas   (Measure ty ())                               -- ^ 'class measure' definition+  | IMeas   (Measure ty ctor)                             -- ^ 'instance measure' definition+  | Varia   (LocSymbol, [Variance])                       -- ^ 'variance' annotations, marking type constructor params as co-, contra-, or in-variant+  | BFix    ()                                            -- ^ fixity annotation+  | Define  (LocSymbol, Symbol)                           -- ^ 'define' annotation for specifying aliases c.f. `include-CoreToLogic.lg`+  deriving (Data, Typeable) +instance (PPrint ty, PPrint ctor) => PPrint (Pspec ty ctor) where +  pprintTidy = ppPspec ++splice :: PJ.Doc -> [PJ.Doc] -> PJ.Doc+splice sep = PJ.hcat . PJ.punctuate sep++ppAsserts :: (PPrint t) => Tidy -> [LocSymbol] -> t -> Maybe [Located Expr] -> PJ.Doc+ppAsserts k lxs t les +  = PJ.hcat [ splice ", " (pprintTidy k <$> (val <$> lxs))+            , " :: " +            , pprintTidy k t   +            , ppLes les +            ]+  where +    ppLes Nothing    = ""+    ppLes (Just les) = "/" <+> pprintTidy k (val <$> les)++ppPspec :: (PPrint t, PPrint c) => Tidy -> Pspec t c -> PJ.Doc+ppPspec k (Meas m)        +  = "measure" <+> pprintTidy k m +ppPspec k (Assm (lx, t))  +  = "assume"  <+> pprintTidy k (val lx) <+> "::" <+> pprintTidy k t +ppPspec k (Asrt (lx, t))  +  = "assert"  <+> pprintTidy k (val lx) <+> "::" <+> pprintTidy k t +ppPspec k (LAsrt (lx, t)) +  = "local assert"  <+> pprintTidy k (val lx) <+> "::" <+> pprintTidy k t +ppPspec k (Asrts (lxs, (t, les))) +  = ppAsserts k lxs t les+ppPspec k (Impt  x) +  = "import" <+> pprintTidy k x +ppPspec k (DDecl d) +  = pprintTidy k d +ppPspec k (NTDecl d) +  = "newtype" <+> pprintTidy k d +ppPspec _ (Incl f) +  = "include" <+> "<" PJ.<> PJ.text f PJ.<> ">"+ppPspec k (Invt t)+  = "invariant" <+> pprintTidy k t +ppPspec k (Using (t1, t2)) +  = "using" <+> pprintTidy k t1 <+> "as" <+> pprintTidy k t2+ppPspec k (Alias   (Loc _ _ rta)) +  = "type" <+> pprintTidy k rta +ppPspec k (EAlias  (Loc _ _ rte)) +  = "predicate" <+> pprintTidy k rte +ppPspec k (Embed   (lx, tc, NoArgs)) +  = "embed" <+> pprintTidy k (val lx)         <+> "as" <+> pprintTidy k tc +ppPspec k (Embed   (lx, tc, WithArgs)) +  = "embed" <+> pprintTidy k (val lx) <+> "*" <+> "as" <+> pprintTidy k tc +ppPspec k (Qualif  q)              +  = pprintTidy k q +ppPspec k (Decr (lx, ns))        +  = "decreasing" <+> pprintTidy k (val lx) <+> pprintTidy k ns+ppPspec k (LVars   lx) +  = "lazyvar" <+> pprintTidy k (val lx) +ppPspec k (Lazy   lx) +  = "lazy" <+> pprintTidy k (val lx) +ppPspec k (Insts   (lx, mbN)) +  = "automatic-instances" <+> pprintTidy k (val lx) <+> maybe "" (("with" <+>) . pprintTidy k) mbN +ppPspec k (HMeas   lx) +  = "measure" <+> pprintTidy k (val lx) +ppPspec k (Reflect lx) +  = "reflect" <+> pprintTidy k (val lx) +ppPspec k (Inline  lx) +  = "inline" <+> pprintTidy k (val lx) +ppPspec k (Ignore  lx) +  = "ignore" <+> pprintTidy k (val lx) +ppPspec k (HBound  lx) +  = "bound" <+> pprintTidy k (val lx) +ppPspec k (ASize   lx) +  = "autosize" <+> pprintTidy k (val lx) +ppPspec k (PBound  bnd) +  = pprintTidy k bnd +ppPspec _ (Pragma  (Loc _ _ s)) +  = "LIQUID" <+> PJ.text s +ppPspec k (CMeas   m) +  = "class measure" <+> pprintTidy k m+ppPspec k (IMeas   m) +  = "instance  measure" <+> pprintTidy k m+ppPspec k (Class   cls) +  = pprintTidy k cls +ppPspec k (CLaws  cls) +  = pprintTidy k cls +ppPspec k (RInst   inst) +  = pprintTidy k inst +ppPspec k (Varia   (lx, vs))  +  = "data variance" <+> pprintTidy k (val lx) <+> splice " " (pprintTidy k <$> vs) +ppPspec _ (BFix    _)           -- +  = "fixity"+ppPspec k (Define  (lx, y))     +  = "define" <+> pprintTidy k (val lx) <+> "=" <+> pprintTidy k y +ppPspec _ (ILaws {}) +  = "TBD-INSTANCE-LAWS"++ -- | For debugging {-instance Show (Pspec a b) where   show (Meas   _) = "Meas"@@ -878,11 +990,11 @@   show (LAsrt  _) = "LAsrt"   show (Asrts  _) = "Asrts"   show (Impt   _) = "Impt"-  show (DDecl  _) = "DDecl"+  shcl  _) = "DDecl"   show (NTDecl _) = "NTDecl"   show (Incl   _) = "Incl"   show (Invt   _) = "Invt"-  show (IAlias _) = "IAlias"+  show (Using _) = "Using"   show (Alias  _) = "Alias"   show (EAlias _) = "EAlias"   show (Embed  _) = "Embed"@@ -907,39 +1019,51 @@   show (BFix   _) = "BFix"   show (Define _) = "Define"-} -mkSpec :: ModName -> [BPspec] -> (ModName, Measure.Spec (Located BareType) LocSymbol)-mkSpec name xs         = (name,) $ Measure.qualifySpec (symbol name) Measure.Spec+qualifySpec :: Symbol -> Spec ty bndr -> Spec ty bndr+qualifySpec name sp = sp { sigs      = [ (tx x, t)  | (x, t)  <- sigs sp]+                         -- , asmSigs   = [ (tx x, t)  | (x, t)  <- asmSigs sp]+                         }+  where+    tx = fmap (qualifySymbol name)++mkSpec :: ModName -> [BPspec] -> (ModName, Measure.Spec LocBareType LocSymbol)+mkSpec name xs         = (name,) $ qualifySpec (symbol name) Measure.Spec   { Measure.measures   = [m | Meas   m <- xs]   , Measure.asmSigs    = [a | Assm   a <- xs]   , Measure.sigs       = [a | Asrt   a <- xs]                       ++ [(y, t) | Asrts (ys, (t, _)) <- xs, y <- ys]   , Measure.localSigs  = []   , Measure.reflSigs   = []+  , Measure.impSigs    = []+  , Measure.expSigs    = []    , Measure.invariants = [(Nothing, t) | Invt   t <- xs]-  , Measure.ialiases   = [t | IAlias t <- xs]+  , Measure.ialiases   = [t | Using t <- xs]   , Measure.imports    = [i | Impt   i <- xs]   , Measure.dataDecls  = [d | DDecl  d <- xs] ++ [d | NTDecl d <- xs]   , Measure.newtyDecls = [d | NTDecl d <- xs]   , Measure.includes   = [q | Incl   q <- xs]   , Measure.aliases    = [a | Alias  a <- xs]   , Measure.ealiases   = [e | EAlias e <- xs]-  , Measure.embeds     = M.fromList [(c, fTyconSort tc) | Embed (c, tc) <- xs]+  , Measure.embeds     = tceFromList [(c, (fTyconSort tc, a)) | Embed (c, tc, a) <- xs]   , Measure.qualifiers = [q | Qualif q <- xs]   , Measure.decr       = [d | Decr d   <- xs]-  , Measure.lvars      = [d | LVars d  <- xs]+  , Measure.lvars      = S.fromList [d | LVars d  <- xs]   , Measure.autois     = M.fromList [s | Insts s <- xs]   , Measure.pragmas    = [s | Pragma s <- xs]   , Measure.cmeasures  = [m | CMeas  m <- xs]   , Measure.imeasures  = [m | IMeas  m <- xs]   , Measure.classes    = [c | Class  c <- xs]+  , Measure.claws      = [c | CLaws  c <- xs]   , Measure.dvariance  = [v | Varia  v <- xs]   , Measure.rinstance  = [i | RInst  i <- xs]+  , Measure.ilaws      = [i | ILaws  i <- xs]   , Measure.termexprs  = [(y, es) | Asrts (ys, (_, Just es)) <- xs, y <- ys]   , Measure.lazy       = S.fromList [s | Lazy   s <- xs]   , Measure.bounds     = M.fromList [(bname i, i) | PBound i <- xs]   , Measure.reflects   = S.fromList [s | Reflect s <- xs]   , Measure.hmeas      = S.fromList [s | HMeas  s <- xs]   , Measure.inlines    = S.fromList [s | Inline s <- xs]+  , Measure.ignores    = S.fromList [s | Ignore s <- xs]   , Measure.autosize   = S.fromList [s | ASize  s <- xs]   , Measure.hbounds    = S.fromList [s | HBound s <- xs]   , Measure.defs       = M.fromList [d | Define d <- xs]@@ -965,15 +1089,18 @@     <|> (reserved "infixr"        >> liftM BFix    infixrP  )     <|> (reserved "infix"         >> liftM BFix    infixP   )     <|> (fallbackSpecP "inline"     (liftM Inline  inlineP  ))+    <|> (fallbackSpecP "ignore"     (liftM Ignore  inlineP  ))      <|> (fallbackSpecP "bound"    (((liftM PBound  boundP   )                                 <|> (liftM HBound  hboundP  ))))     <|> (reserved "class"          >> ((reserved "measure"  >> liftM CMeas  cMeasureP )-                                 <|> liftM Class  classP    ))+         <|> (reserved "laws"     >> liftM CLaws  classP)+         <|> liftM Class  classP                            ))     <|> (reserved "instance"          >> ((reserved "measure"  >> liftM IMeas  iMeasureP )-                                 <|> liftM RInst  instanceP ))+         <|> (reserved "laws"     >> liftM ILaws instanceLawP)+         <|> liftM RInst  instanceP ))      <|> (reserved "import"        >> liftM Impt   symbolP   ) @@ -984,7 +1111,7 @@     <|> (reserved "newtype"       >> liftM NTDecl dataDeclP )     <|> (reserved "include"       >> liftM Incl   filePathP )     <|> (fallbackSpecP "invariant"  (liftM Invt   invariantP))-    <|> (reserved "using"         >> liftM IAlias invaliasP )+    <|> (reserved "using"         >> liftM Using invaliasP )     <|> (reserved "type"          >> liftM Alias  aliasP    )      -- TODO: Next two are basically synonyms@@ -1064,11 +1191,16 @@         <?> "Invalid variance annotation\t Use one of bivariant, invariant, covariant, contravariant"  tyBindsP :: Parser ([LocSymbol], (Located BareType, Maybe [Located Expr]))-tyBindsP = xyP (sepBy (locParserP binderP) comma) dcolon termBareTypeP+tyBindsP = do +  (xs, z) <- xyP (sepBy (locParserP binderP) comma) dcolon termBareTypeP+  when (null xs) (parserFail $ "Type signature " ++ show z ++ " must have non-empty list of binders!") +  return (xs, z) + tyBindNoLocP :: Parser (LocSymbol, BareType) tyBindNoLocP = second val <$> tyBindP + tyBindP    :: Parser (LocSymbol, Located BareType) tyBindP    = xyP xP dcolon tP   where@@ -1103,20 +1235,25 @@ genBareTypeP :: Parser BareType genBareTypeP = bareTypeP -embedP :: Parser (Located Symbol, FTycon)-embedP-  = xyP locUpperIdP (reserved "as") fTyConP+embedP :: Parser (Located Symbol, FTycon, TCArgs)+embedP = do +  x <- locUpperIdP +  a <- try (reserved "*" >> return WithArgs) <|> return NoArgs +  _ <- spaces >> reserved "as"+  t <- fTyConP   +  return (x, t, a)+  --  = xyP locUpperIdP symbolTCArgs (reserved "as") fTyConP  -aliasP :: Parser (RTAlias Symbol BareType)+aliasP :: Parser (Located (RTAlias Symbol BareType)) aliasP  = rtAliasP id     bareTypeP -ealiasP :: Parser (RTAlias Symbol Expr)+ealiasP :: Parser (Located (RTAlias Symbol Expr)) ealiasP = try (rtAliasP symbol predP)       <|> rtAliasP symbol exprP       <?> "ealiasP" -rtAliasP :: (Symbol -> tv) -> Parser ty -> Parser (RTAlias tv ty)+rtAliasP :: (Symbol -> tv) -> Parser ty -> Parser (Located (RTAlias tv ty)) rtAliasP f bodyP   -- TODO:AZ pretty sure that all the 'spaces' can be removed below, given   --         proper use of reserved and reservedOp now@@ -1128,7 +1265,7 @@        body <- bodyP        posE <- getPosition        let (tArgs, vArgs) = partition (isSmall . headSym) args-       return $ RTA name (f <$> tArgs) vArgs body pos posE+       return $ Loc pos posE (RTA name (f <$> tArgs) vArgs body)  aliasIdP :: Parser Symbol aliasIdP = condIdP (letter <|> char '_') alphaNums (isAlpha . head)@@ -1143,23 +1280,22 @@        ty <- locParserP genBareTypeP        whiteSpace        eqns <- grabs $ measureDefP (rawBodyP <|> tyBodyP ty)-       return (Meas $ Measure.mkM b ty eqns))+       return (Meas $ Measure.mkM b ty eqns MsMeasure mempty))     <|> (return (HMeas b))     )  measureP :: Parser (Measure (Located BareType) LocSymbol)-measureP-  = do (x, ty) <- tyBindP-       whiteSpace-       eqns    <- grabs $ measureDefP (rawBodyP <|> tyBodyP ty)-       return   $ Measure.mkM x ty eqns-+measureP = do +  (x, ty) <- tyBindP+  whiteSpace+  eqns    <- grabs $ measureDefP (rawBodyP <|> tyBodyP ty)+  return   $ Measure.mkM x ty eqns MsMeasure mempty  -- | class measure cMeasureP :: Parser (Measure (Located BareType) ()) cMeasureP   = do (x, ty) <- tyBindP-       return $ Measure.mkM x ty []+       return $ Measure.mkM x ty [] MsClass mempty   iMeasureP :: Parser (Measure (Located BareType) LocSymbol) iMeasureP = measureP@@ -1174,6 +1310,30 @@                <|> ((:) <$> (fmap bTyVar <$> locLowerIdP) <*> classParams)     sing x      = [x] +instanceLawP :: Parser (RILaws (Located BareType))+instanceLawP+  = do l1   <- getPosition+       sups <- supersP+       c    <- classBTyConP+       spaces+       tvs  <- manyTill (locParserP bareTypeP) (try $ reserved "where")+       spaces+       ms   <- grabs eqBinderP+       spaces+       l2   <- getPosition+       return $ RIL c sups tvs ms (Loc l1 l2 ())+  where+    superP   = locParserP (toRCls <$> bareAtomBindP)+    supersP  = try (((parens (superP `sepBy1` comma)) <|> fmap pure superP)+                       <* reservedOp "=>")+               <|> return []+    toRCls x = x++    eqBinderP = xyP xP (spaces >> string "=" <* spaces) (xP <* spaces)+      +    xP = locParserP binderP+    + instanceP :: Parser (RInstance (Located BareType)) instanceP   = do _    <- supersP@@ -1206,17 +1366,15 @@         return (x, RISig t)  <?> "riMethodSigP" -- classP :: Parser (RClass (Located BareType)) classP   = do sups <- supersP        c    <- classBTyConP        spaces        tvs  <- manyTill (bTyVar <$> tyVarIdP) (try $ reserved "where")-       ms   <- grabs tyBindP+       ms   <- try (grabs tyBindP) -- <|> sepBy tyBindP semi        spaces-       return $ RClass c sups tvs ms -- sups tvs ms+       return $ RClass c sups tvs ms   where     superP   = locParserP (toRCls <$> bareAtomBindP)     supersP  = try (((parens (superP `sepBy1` comma)) <|> fmap pure superP)@@ -1240,6 +1398,7 @@       _         -> E <$> exprP     where outTy (RAllT _ t)    = outTy t           outTy (RAllP _ t)    = outTy t+          outTy (RImpF _ _ t _)= Just t           outTy (RFun _ _ t _) = Just t           outTy _              = Nothing @@ -1294,7 +1453,7 @@        body    <- bodyP        whiteSpace        let xs'  = (symbol . val) <$> xs-       return   $ Def mname [] (symbol <$> c) Nothing ((, Nothing) <$> xs') body+       return   $ Def mname (symbol <$> c) Nothing ((, Nothing) <$> xs') body  measurePatP :: Parser (LocSymbol, [LocSymbol]) measurePatP@@ -1357,20 +1516,25 @@ bbindP   :: Parser Symbol bbindP   = lowerIdP <* dcolon -dataConP :: Parser DataCtor-dataConP = do+dataConP :: [Symbol] -> Parser DataCtor+dataConP as = do   x   <- locParserP dataConNameP   spaces   xts <- dataConFieldsP-  return $ DataCtor x [] xts Nothing+  return $ DataCtor x as [] xts Nothing -adtDataConP :: Parser DataCtor-adtDataConP = do+adtDataConP :: [Symbol] -> Parser DataCtor+adtDataConP as = do   x     <- locParserP dataConNameP   dcolon   tr    <- toRTypeRep <$> bareTypeP-  return $ DataCtor x [] (tRepFields tr) (Just $ ty_res tr)+  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 +  [] -> as +  vs -> symbol . ty_var_value <$> vs + tRepFields :: RTypeRep c tv r -> [(Symbol, RType c tv r)] tRepFields tr = zip (ty_binds tr) (ty_args tr) @@ -1399,7 +1563,7 @@  emptyDecl :: LocSymbol -> SourcePos -> Maybe SizeFun -> DataDecl emptyDecl x pos fsize@(Just _)-  = D (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@@ -1408,12 +1572,12 @@ dataDeclBodyP :: SourcePos -> LocSymbol -> Maybe SizeFun -> Parser DataDecl dataDeclBodyP pos x fsize = do   vanilla    <- null <$> sepBy locUpperIdP blanks-  ts         <- sepBy noWhere blanks+  as         <- sepBy noWhere blanks   ps         <- predVarDefsP-  (pTy, dcs) <- dataCtorsP+  (pTy, dcs) <- dataCtorsP as   let dn      = dataDeclName pos x vanilla dcs   whiteSpace-  return      $ D dn ts 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@@ -1422,11 +1586,11 @@   where     msg                  = "You should specify at least one data constructor for a family instance" -dataCtorsP :: Parser (Maybe BareType, [DataCtor])-dataCtorsP = do-  (pTy, dcs) <-     (reservedOp "="     >> ((Nothing, ) <$>                 sepBy dataConP    (reservedOp "|")))-                <|> (reserved   "where" >> ((Nothing, ) <$>                 sepBy adtDataConP (reservedOp "|")))-                <|> (                      ((,)         <$> dataPropTyP <*> sepBy adtDataConP (reservedOp "|")))+dataCtorsP :: [Symbol] -> Parser (Maybe BareType, [DataCtor])+dataCtorsP as = do+  (pTy, dcs) <-     (reservedOp "="     >> ((Nothing, ) <$>                 sepBy (dataConP    as) (reservedOp "|")))+                <|> (reserved   "where" >> ((Nothing, ) <$>                 sepBy (adtDataConP as) (reservedOp "|")))+                <|> (                      ((,)         <$> dataPropTyP <*> sepBy (adtDataConP as) (reservedOp "|")))   return (pTy, Misc.sortOn (val . dcName) dcs)  noWhere :: Parser Symbol
+ src/Language/Haskell/Liquid/Termination/Structural.hs view
@@ -0,0 +1,352 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++module Language.Haskell.Liquid.Termination.Structural (terminationVars) where++import Language.Haskell.Liquid.Types hiding (terminationCheck, isDecreasing)+import Language.Haskell.Liquid.GHC.Misc (showPpr)++import CoreSyn+import Var+import Name (getSrcSpan)+import VarSet+import CoreSubst (deShadowBinds)++import Text.PrettyPrint.HughesPJ hiding ((<>))++import qualified Data.HashSet as HS+import Data.HashSet (HashSet)+import qualified Data.Map.Strict as M+import Data.Map.Strict (Map)+import qualified Data.List as L++import Control.Monad (liftM, ap)+import Data.Foldable (fold)++terminationVars :: GhcInfo -> [Var]+terminationVars info = failingBinds info >>= allBoundVars++failingBinds :: GhcInfo -> [CoreBind]+failingBinds info = filter (hasErrors . checkBind) structBinds+  where +    structCheckWholeProgram = structuralTerm info+    program = giCbs . giSrc $ info+    structFuns = gsStTerm . gsTerm . giSpec $ info+    structBinds+      | structCheckWholeProgram = program+      | otherwise = findStructBinds structFuns program++checkBind :: CoreBind -> Result ()+checkBind bind = do+  srcCallInfo <- getCallInfoBind emptyEnv (deShadowBind bind)+  let structCallInfo = fmap toStructCall <$> srcCallInfo+  fold $ mapWithFun structDecreasing structCallInfo++deShadowBind :: CoreBind -> CoreBind+deShadowBind bind = head $ deShadowBinds [bind]++findStructBinds :: HashSet Var -> CoreProgram -> [CoreBind]+findStructBinds structFuns program = filter isStructBind program+  where+    isStructBind (NonRec f _) = f `HS.member` structFuns+    isStructBind (Rec []) = False+    isStructBind (Rec ((f,_):xs)) = f `HS.member` structFuns || isStructBind (Rec xs)++allBoundVars :: CoreBind -> [Var]+allBoundVars (NonRec v e) = v : (nextBinds e >>= allBoundVars)+allBoundVars (Rec binds) = map fst binds ++ (map snd binds >>= nextBinds >>= allBoundVars)++nextBinds :: CoreExpr -> [CoreBind]+nextBinds = \case+  App e a -> nextBinds e ++ nextBinds a+  Lam _ e -> nextBinds e+  Let b e -> [b] ++ nextBinds e+  Case scrut _ _ alts -> nextBinds scrut ++ ([body | (_, _, body) <- alts] >>= nextBinds)+  Cast e _ -> nextBinds e+  Tick _ e -> nextBinds e+  Var{} -> []+  Lit{} -> []+  Coercion{} -> []+  Type{} -> []++------------------------------------------------------------------------------------------++-- Note that this is *not* the Either/Maybe monad, since it's important that we+-- collect all errors, not just the first error.+data Result a = Result+  { resultVal :: a+  , resultErrors :: [TermError]+  } deriving (Show)++data TermError = TE +  { teVar   :: Var+  , teError :: UserError+  } deriving (Show)++hasErrors :: Result a -> Bool+hasErrors = not . null . resultErrors++addError :: Var -> Doc -> Result a -> Result a+addError fun expl (Result x errs) = Result x (mkTermError fun expl : errs)++mkTermError :: Var -> Doc -> TermError+mkTermError fun expl = TE+  { teVar   = fun+  , teError = ErrStTerm (getSrcSpan fun) (text $ showPpr fun) expl+  }++instance Monoid a => Monoid (Result a) where+  mempty  = Result mempty []++instance Semigroup a => Semigroup (Result a) where+  Result x e1 <> Result y e2 = Result (x <> y) (e1 ++ e2)++instance Monad Result where+  Result x e1 >>= f =+    let Result y e2 = f x in+    Result y (e2 ++ e1)++instance Applicative Result where+  pure x = Result x []+  (<*>) = ap++instance Functor Result where+  fmap = liftM++--------------------------------------------------------------------------------++data Env = Env+  { envCurrentFun :: Maybe Var+  , envCurrentArgs :: [CoreArg]+  , envCheckedFuns :: [Fun]+  }++data Fun = Fun+  { funName :: Var+  , funParams :: [Param]+  }++data Param = Param+  { paramNames :: VarSet+  , paramSubterms :: VarSet+  } deriving (Eq)++emptyEnv :: Env+emptyEnv = Env+  { envCurrentFun = Nothing+  , envCurrentArgs = []+  , envCheckedFuns = []+  }++mkFun :: Var -> Fun+mkFun name = Fun+  { funName = name+  , funParams = []+  }++mkParam :: Var -> Param+mkParam name = Param+  { paramNames = unitVarSet name+  , paramSubterms = emptyVarSet+  }++lookupFun :: Env -> Var -> Maybe Fun+lookupFun env name = L.find (\fun -> funName fun == name) $ envCheckedFuns env++clearCurrentArgs :: Env -> Env+clearCurrentArgs env = env { envCurrentArgs = [] }++setCurrentFun :: Var -> Env -> Env+setCurrentFun fun env = env { envCurrentFun = Just fun }++clearCurrentFun :: Env -> Env+clearCurrentFun env = env { envCurrentFun = Nothing }++addArg :: CoreArg -> Env -> Env+addArg arg env = env { envCurrentArgs = arg:envCurrentArgs env }++addParam :: Var -> Env -> Env+addParam param env = case envCurrentFun env of+  Nothing -> env+  Just name -> env { envCheckedFuns = updateFunNamed name <$> envCheckedFuns env }+  where+    updateFunNamed name fun+      | funName fun == name = fun { funParams = mkParam param : funParams fun }+      | otherwise = fun++addSynonym :: Var -> Var -> Env -> Env+addSynonym oldName newName env = env { envCheckedFuns = updateFun <$> envCheckedFuns env }+  where+    updateFun fun = fun { funParams = updateParam <$> funParams fun }+    updateParam param+      | oldName `elemVarSet` paramNames param = param { paramNames = paramNames param `extendVarSet` newName }+      | oldName `elemVarSet` paramSubterms param = param { paramSubterms = paramSubterms param `extendVarSet` newName }+      | otherwise = param++addSubterms :: Var -> [Var] -> Env -> Env+addSubterms var subterms env = env { envCheckedFuns = updateFun <$> envCheckedFuns env }+  where+    updateFun fun = fun { funParams = updateParam <$> funParams fun }+    updateParam param+      | var `elemVarSet` paramNames param || var `elemVarSet` paramSubterms param = param { paramSubterms = paramSubterms param `extendVarSetList` subterms }+      | otherwise = param++addCheckedFun :: Var -> Env -> Env+addCheckedFun name env = env { envCheckedFuns = mkFun name : envCheckedFuns env }++isParam :: Var -> Param -> Bool+var `isParam` param = var `elemVarSet` paramNames param++isParamSubterm :: Var -> Param -> Bool+var `isParamSubterm` param = var `elemVarSet` paramSubterms param++--------------------------------------------------------------------------------++newtype FunInfo a = FunInfo (Map Var a)++data SrcCall = SrcCall+  { srcCallFun :: Var+  , srcCallArgs :: [(Param, CoreArg)]+  }++instance Semigroup a => Semigroup (FunInfo a) where+  FunInfo xs <> FunInfo ys = FunInfo $ M.unionWith (<>) xs ys++instance Semigroup a => Monoid (FunInfo a) where+  mempty = FunInfo M.empty++instance Functor FunInfo where+  fmap f (FunInfo xs) = FunInfo (fmap f xs)++instance Foldable FunInfo where+  foldMap f (FunInfo m) = foldMap f m++mapWithFun :: (Var -> a -> b) -> FunInfo a -> FunInfo b+mapWithFun f (FunInfo x) = FunInfo (M.mapWithKey f x)++mkFunInfo :: Var -> a -> FunInfo a+mkFunInfo fun x = FunInfo $ M.singleton fun x++mkSrcCall :: Var -> [(Param, CoreArg)] -> SrcCall+mkSrcCall fun args = SrcCall+  { srcCallFun = fun+  , srcCallArgs = args+  }++toVar :: CoreExpr -> Maybe Var+toVar (Var x) = Just x+toVar (Cast e _) = toVar e+toVar (Tick _ e) = toVar e+toVar _ = Nothing++zipExact :: [a] -> [b] -> Maybe [(a, b)]+zipExact [] [] = Just []+zipExact (x:xs) (y:ys) = ((x, y):) <$> zipExact xs ys+zipExact _ _ = Nothing++-- Collect information about all of the recursive calls in a function+-- definition which will be needed to check for structural termination.+getCallInfoExpr :: Env -> CoreExpr -> Result (FunInfo [SrcCall])+getCallInfoExpr env = \case+  Var (lookupFun env -> Just fun) ->+    case zipExact (funParams fun) (reverse $ envCurrentArgs env) of+      Just args -> pure $ mkFunInfo (funName fun) [mkSrcCall (funName fun) args]+      Nothing -> addError (funName fun) "Unsaturated call to function" mempty++  App e a+    | isTypeArg a -> getCallInfoExpr env e+    | otherwise -> getCallInfoExpr argEnv a <> getCallInfoExpr appEnv e+      where+        argEnv = clearCurrentFun . clearCurrentArgs $ env+        appEnv = clearCurrentFun . addArg a $ env++  Lam x e+    | isTyVar x -> getCallInfoExpr env e+    | otherwise -> getCallInfoExpr (addParam x env) e++  Let bind e -> getCallInfoBind env bind <> getCallInfoExpr env e++  Case (toVar -> Just var) bndr _ alts -> foldMap getCallInfoAlt alts+    where+      getCallInfoAlt (_, subterms, body) = getCallInfoExpr (branchEnv subterms) body+      branchEnv subterms = addSubterms var subterms . addSynonym var bndr $ env++  Case scrut _ _ alts -> getCallInfoExpr env scrut <> foldMap getCallInfoAlt alts+    where+      getCallInfoAlt (_, _, body) = getCallInfoExpr env body++  Cast e _ -> getCallInfoExpr env e+  Tick _ e -> getCallInfoExpr env e++  Var{} -> pure mempty+  Lit{} -> pure mempty+  Coercion{} -> pure mempty+  Type{} -> pure mempty++getCallInfoBind :: Env -> CoreBind -> Result (FunInfo [SrcCall])+getCallInfoBind env = \case+  NonRec _ e -> getCallInfoExpr (clearCurrentFun env) e+  Rec [] -> pure mempty+  Rec [(f, e)] -> getCallInfoExpr (addCheckedFun f . setCurrentFun f $ env) e+  Rec binds -> foldMap failBind binds+    where failBind (f, e) =+            addError f "Structural checking of mutually-recursive functions is not supported" $+            getCallInfoExpr (clearCurrentFun env) e++--------------------------------------------------------------------------------++data StructInfo = Unchanged Int | Decreasing Int++unStructInfo :: StructInfo -> Int+unStructInfo (Unchanged p) = p+unStructInfo (Decreasing p) = p++isDecreasing :: StructInfo -> Bool+isDecreasing (Decreasing _) = True+isDecreasing (Unchanged _) = False++data StructCall = StructCall+  { structCallFun :: Var+  , structCallArgs :: [Int]+  , structCallDecArgs :: [Int]+  }++mkStructCall :: Var -> [StructInfo] -> StructCall+mkStructCall fun sis = StructCall+  { structCallFun = fun+  , structCallArgs = map unStructInfo sis+  , structCallDecArgs = map unStructInfo . filter isDecreasing $ sis+  }++-- This is where we  check a function call. We go through  the list of arguments+-- and find the  indices of those which are decreasing.  Note that this approach+-- is only guaranteed to  work when the arguments to the  function are named, so+-- e.g.+-- foo (x:xs) (y:ys) = foo xs (y:ys)+-- won't necessarily work, but+-- foo (x:xs) yys@(y:ys) = foo xs yys+-- will.+toStructCall :: SrcCall -> StructCall+toStructCall srcCall = mkStructCall (srcCallFun srcCall) $ toStructArgs 0 (srcCallArgs srcCall)+  where+    toStructArgs _ [] = []+    toStructArgs index ((param, toVar -> Just v):args)+      | v `isParam` param = Unchanged index : toStructArgs (index + 1) args+      | v `isParamSubterm` param = Decreasing index : toStructArgs (index + 1) args+    toStructArgs index (_:args) = toStructArgs (index + 1) args++-- Check if there is some way to lexicographically order the arguments so that+-- they are structurally decreasing. Essentially, in order for there to be, we+-- must be able to find some argument which is always either unchanged or+-- decreasing. We can then remove every call where that argument is decreasing+-- and recurse.+structDecreasing :: Var -> [StructCall] -> Result ()+structDecreasing _ [] = mempty+structDecreasing funName calls+  | null sharedArgs = addError funName "Non-structural recursion" mempty+  | otherwise = structDecreasing funName $ (map removeSharedArgs . filter noneDecreasing) calls+  where+    sharedArgs = foldl1 L.intersect (structCallArgs <$> calls)+    noneDecreasing call = null $ structCallDecArgs call `L.intersect` sharedArgs+    removeSharedArgs call = call { structCallArgs = structCallArgs call L.\\ sharedArgs }
src/Language/Haskell/Liquid/Transforms/ANF.hs view
@@ -28,7 +28,7 @@ import           Language.Haskell.Liquid.GHC.TypeRep import           Type                             (mkForAllTys, substTy, mkForAllTys, mkTvSubstPrs, isTyVar) import           TyCon                            (tyConDataCons_maybe)-import           DataCon                          (dataConInstArgTys)+-- import           DataCon                          (dataConInstArgTys) import           VarEnv                           (VarEnv, emptyVarEnv, extendVarEnv, lookupWithDefaultVarEnv) import           UniqSupply                       (MonadUnique, getUniqueM) import           Unique                           (getKey)@@ -37,9 +37,9 @@ import qualified Language.Fixpoint.Misc     as F import qualified Language.Fixpoint.Types    as F -import           Language.Haskell.Liquid.UX.Config  as UX -- (Config, untidyCore, expandFlag, patternFlag)-import           Language.Haskell.Liquid.Misc       (concatMapM)-import           Language.Haskell.Liquid.GHC.Misc   (tracePpr, showCBs, showPpr, symbolFastString)+import           Language.Haskell.Liquid.UX.Config  as UX+import qualified Language.Haskell.Liquid.Misc       as Misc +import           Language.Haskell.Liquid.GHC.Misc   as GM import           Language.Haskell.Liquid.Transforms.Rec import           Language.Haskell.Liquid.Transforms.Rewrite import           Language.Haskell.Liquid.Types.Errors@@ -48,8 +48,8 @@ import qualified Language.Haskell.Liquid.GHC.Resugar   as Rs import           Data.Maybe                       (fromMaybe) import           Data.List                        (sortBy, (\\))--+import           Data.Function                    (on)+import qualified Text.Printf as Printf   -------------------------------------------------------------------------------- -- | A-Normalize a module ------------------------------------------------------@@ -59,15 +59,15 @@ anormalize cfg hscEnv modGuts = do   whenLoud $ do     putStrLn "***************************** GHC CoreBinds ***************************"-    putStrLn $ showCBs untidy (mg_binds modGuts)+    putStrLn $ GM.showCBs untidy (mg_binds modGuts)     putStrLn "***************************** REC CoreBinds ***************************"-    putStrLn $ showCBs untidy orig_cbs+    putStrLn $ GM.showCBs untidy orig_cbs     putStrLn "***************************** RWR CoreBinds ***************************"-    putStrLn $ showCBs untidy rwr_cbs+    putStrLn $ GM.showCBs untidy rwr_cbs   (fromMaybe err . snd) <$> initDsWithModGuts hscEnv modGuts act -- hscEnv m grEnv tEnv emptyFamInstEnv act     where       err      = panic Nothing "Oops, cannot A-Normalize GHC Core!"-      act      = concatMapM (normalizeTopBind γ0) rwr_cbs+      act      = Misc.concatMapM (normalizeTopBind γ0) rwr_cbs       γ0       = emptyAnfEnv cfg       rwr_cbs  = rewriteBinds cfg orig_cbs       orig_cbs = transformRecExpr $ mg_binds modGuts@@ -104,13 +104,15 @@  normalizeTyVars :: Bind Id -> Bind Id normalizeTyVars (NonRec x e) = NonRec (setVarType x t') $ normalizeForAllTys e-  where t'       = subst msg as as' bt-        msg      = "WARNING unable to renameVars on " ++ showPpr x-        as'      = fst $ splitForAllTys $ exprType e-        (as, bt) = splitForAllTys (varType x)+  where +    t'       = subst msg as as' bt+    msg      = "WARNING: unable to renameVars on " ++ GM.showPpr x+    as'      = fst $ splitForAllTys $ exprType e+    (as, bt) = splitForAllTys (varType x) normalizeTyVars (Rec xes)    = Rec xes'-  where nrec = normalizeTyVars <$> ((\(x, e) -> NonRec x e) <$> xes)-        xes' = (\(NonRec x e) -> (x, e)) <$> nrec+  where +    nrec     = normalizeTyVars <$> ((\(x, e) -> NonRec x e) <$> xes)+    xes'     = (\(NonRec x e) -> (x, e)) <$> nrec  subst :: String -> [TyVar] -> [TyVar] -> Type -> Type subst msg as as' bt@@ -185,10 +187,9 @@        return $ Var x  shouldNormalize :: Literal -> Bool-shouldNormalize l = case l of-  LitInteger _ _ -> True-  MachStr _ -> True-  _ -> False+shouldNormalize (LitNumber {})  = True +shouldNormalize (MachStr {})    = True +shouldNormalize _               = False  add :: [CoreBind] -> DsMW () add w = modify $ \s -> s { st_binds = st_binds s ++ w}@@ -223,10 +224,10 @@   = do n     <- normalizeName γ e        x'    <- lift $ freshNormalVar γ τx -- rename "wild" to avoid shadowing        let γ' = extendAnfEnv γ x x'-       as'   <- forM as $ \(c, xs, e') -> liftM (c, xs,) (stitch γ' e')+       as'   <- forM as $ \(c, xs, e') -> liftM (c, xs,) (stitch (incrCaseDepth c γ') e')        as''  <- lift $ expandDefaultCase γ τx as'        return $ Case n x' t as''-    where τx = varType x+    where τx = GM.expandVarType x  normalize γ (Var x)   = return $ Var (lookupAnfEnv γ x x)@@ -267,7 +268,7 @@ _mkCoreLets' :: [CoreBind] -> CoreExpr -> CoreExpr _mkCoreLets' bs e = mkCoreLets bs1 e1   where-    (e1, bs1)    = tracePpr "MKCORELETS" (e, bs)+    (e1, bs1)    = GM.tracePpr "MKCORELETS" (e, bs)  -------------------------------------------------------------------------------- normalizePattern :: AnfEnv -> Rs.Pattern -> DsMW CoreExpr@@ -292,53 +293,73 @@   e'    <- normalize γ (Rs.patE p)   return $ Rs.lower p { Rs.patE = e' } + --------------------------------------------------------------------------------+expandDefault :: AnfEnv -> Bool +--------------------------------------------------------------------------------+expandDefault γ = aeCaseDepth γ <= maxCaseExpand γ ++-------------------------------------------------------------------------------- expandDefaultCase :: AnfEnv                   -> Type                   -> [(AltCon, [Id], CoreExpr)]                   -> DsM [(AltCon, [Id], CoreExpr)] ---------------------------------------------------------------------------------expandDefaultCase γ tyapp zs@((DEFAULT, _ ,_) : _) | UX.expandFlag γ+expandDefaultCase γ tyapp zs@((DEFAULT, _ ,_) : _) | expandDefault γ   = expandDefaultCase' γ tyapp zs  expandDefaultCase γ tyapp@(TyConApp tc _) z@((DEFAULT, _ ,_):dcs)   = case tyConDataCons_maybe tc of        Just ds -> do let ds' = ds \\ [ d | (DataAlt d, _ , _) <- dcs]-                     if (length ds') == 1-                      then expandDefaultCase' γ tyapp z-                      else return z+                     let n   = length ds'+                     if n == 1+                       then expandDefaultCase' γ tyapp z+                       else if maxCaseExpand γ /= 2 +                            then return z +                            else return (trace (expandMessage False γ n) z)         Nothing -> return z --  expandDefaultCase _ _ z    = return z -expandDefaultCase' :: AnfEnv -> Type -> [(AltCon, [Id], c)] -> DsM [(AltCon, [Id], c)]-expandDefaultCase' γ (TyConApp tc argτs) z@((DEFAULT, _ ,e) : dcs)-  = case tyConDataCons_maybe tc of-       Just ds -> do let ds' = ds \\ [ d | (DataAlt d, _ , _) <- dcs]-                     dcs'   <- forM ds' $ cloneCase γ argτs e-                     return $ sortCases $ dcs' ++ dcs-       Nothing -> return z ---+expandDefaultCase' +  :: AnfEnv -> Type -> [(AltCon, [Id], c)] -> DsM [(AltCon, [Id], c)]+expandDefaultCase' γ t ((DEFAULT, _, e) : dcs)+  | Just dtss <- GM.defaultDataCons t (F.fst3 <$> dcs) = do +      dcs'    <- warnCaseExpand γ <$> forM dtss (cloneCase γ e)+      return   $ sortCases (dcs' ++ dcs) expandDefaultCase' _ _ z-   = return z+   = return z  -cloneCase :: AnfEnv -> [Type] -> t -> DataCon -> DsM (AltCon, [Id], t)-cloneCase γ argτs e d-  = do xs  <- mapM (freshNormalVar γ) $ dataConInstArgTys d argτs-       return (DataAlt d, xs, e)+cloneCase :: AnfEnv -> e -> (DataCon, [Type]) -> DsM (AltCon, [Id], e)+cloneCase γ e (d, ts) = do +  xs  <- mapM (freshNormalVar γ) ts +  return (DataAlt d, xs, e)  sortCases :: [(AltCon, b, c)] -> [(AltCon, b, c)]-sortCases = sortBy (\x y -> cmpAltCon (F.fst3 x) (F.fst3 y))+sortCases = sortBy (cmpAltCon `on` F.fst3)  +warnCaseExpand :: AnfEnv -> [a] -> [a] +warnCaseExpand γ xs  +  | 10 < n          = trace (expandMessage True γ n) xs +  | otherwise       = xs+  where +   n                = length xs  +expandMessage :: Bool -> AnfEnv -> Int -> String +expandMessage expand γ n = unlines [msg1, msg2]   +  where +    msg1            = Printf.printf "WARNING: (%s) %s DEFAULT with %d cases at depth %d" (showPpr sp) v1 n d +    msg2            = Printf.printf "%s expansion with --max-case-expand=%d" v2 d' +    (v1, v2, d') +      | expand      = ("Expanding"    , "Disable", d-1) :: (String, String, Int)+      | otherwise   = ("Not expanding", "Enable" , d+1) +    d               = aeCaseDepth γ+    sp              = Sp.srcSpan (aeSrcSpan γ)+ -------------------------------------------------------------------------------- -- | ANF Environments ---------------------------------------------------------- ------------------------------------------------------------------------------------ freshNormalVar :: Type -> DsM Id--- freshNormalVar = mkSysLocalM (symbolFastString anfPrefix)- freshNormalVar :: AnfEnv -> Type -> DsM Id freshNormalVar γ t = do   u     <- getUniqueM@@ -347,25 +368,35 @@   return (mkUserLocal (anfOcc i) u t sp)  anfOcc :: Int -> OccName-anfOcc = mkVarOccFS . symbolFastString . F.intSymbol F.anfPrefix+anfOcc = mkVarOccFS . GM.symbolFastString . F.intSymbol F.anfPrefix  data AnfEnv = AnfEnv-  { aeVarEnv  :: VarEnv Id-  , aeSrcSpan :: Sp.SpanStack-  , aeCfg     :: UX.Config+  { aeVarEnv    :: VarEnv Id+  , aeSrcSpan   :: Sp.SpanStack+  , aeCfg       :: UX.Config+  , aeCaseDepth :: !Int   }  instance UX.HasConfig AnfEnv where   getConfig = aeCfg  emptyAnfEnv :: UX.Config -> AnfEnv-emptyAnfEnv = AnfEnv emptyVarEnv Sp.empty+emptyAnfEnv cfg = AnfEnv +  { aeVarEnv    = emptyVarEnv +  , aeSrcSpan   = Sp.empty +  , aeCfg       = cfg +  , aeCaseDepth = 1+  }  lookupAnfEnv :: AnfEnv -> Id -> Id -> Id lookupAnfEnv γ x y = lookupWithDefaultVarEnv (aeVarEnv γ) x y  extendAnfEnv :: AnfEnv -> Id -> Id -> AnfEnv extendAnfEnv γ x y = γ { aeVarEnv = extendVarEnv (aeVarEnv γ) x y }++incrCaseDepth :: AltCon -> AnfEnv -> AnfEnv +incrCaseDepth DEFAULT γ = γ { aeCaseDepth = 1 + aeCaseDepth γ }+incrCaseDepth _       γ = γ   at :: AnfEnv -> Tickish Id -> AnfEnv at γ tt = γ { aeSrcSpan = Sp.push (Sp.Tick tt) (aeSrcSpan γ)}
src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs view
@@ -12,8 +12,9 @@   , runToLogic   , runToLogicWithBoolBinds   , logicType-  , strengthenResult-  , strengthenResult'+  , inlineSpecType  +  , measureSpecType+  , weakenResult   , normalize   ) where @@ -22,109 +23,113 @@ import           Prelude                               hiding (error) import           Type import           Language.Haskell.Liquid.GHC.TypeRep+-- import qualified Id  import qualified Var+import qualified TyCon  import           Coercion 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) +import qualified Data.Text                             as T+import qualified Data.Char +import qualified Text.Printf as Printf  import           Data.Text.Encoding import           Data.Text.Encoding.Error- import           TysWiredIn-+import           Name                                  (getSrcSpan) import           Control.Monad.State import           Control.Monad.Except import           Control.Monad.Identity-import           Language.Fixpoint.Misc                (snd3, mapSnd, mapFst)-import           Language.Fixpoint.Types               hiding (Error, R, simplify)+import qualified Language.Fixpoint.Misc                as Misc +import           Language.Fixpoint.Types               hiding (panic, Error, R, simplify) import qualified Language.Fixpoint.Types               as F-import           Language.Haskell.Liquid.GHC.Misc-import           Language.Haskell.Liquid.Bare.Misc-import           Language.Haskell.Liquid.Bare.Env+import qualified Language.Haskell.Liquid.GHC.Misc      as GM+++import           Language.Haskell.Liquid.Bare.Types +import           Language.Haskell.Liquid.Bare.DataType +import           Language.Haskell.Liquid.Bare.Misc     (simpleSymbolVar) import           Language.Haskell.Liquid.GHC.Play-import           Language.Haskell.Liquid.Types         hiding (GhcInfo(..), GhcSpec (..), LM)+import           Language.Haskell.Liquid.Types.Types   --     hiding (GhcInfo(..), GhcSpec (..), LM) import           Language.Haskell.Liquid.Types.RefType --- import           Language.Haskell.Liquid.WiredIn--- import           CoreUtils                                     (exprType)- import qualified Data.HashMap.Strict                   as M -varType :: Var -> Type-varType = expandTypeSynonyms . Var.varType- logicType :: (Reftable r) => Type -> RRType r logicType τ      = fromRTypeRep $ t { ty_binds = bs, ty_args = as, ty_refts = rs}   where     t            = toRTypeRep $ ofType τ-    (bs, as, rs) = unzip3 $ dropWhile (isClassType.snd3) $ zip3 (ty_binds t) (ty_args t) (ty_refts t)--{- [NOTE:strengthenResult type]: the refinement depends on whether the result type is a Bool or not:--   CASE1: measure f@logic :: X -> Prop <=> f@haskell :: x:X -> {v:Bool | (Prop v) <=> (f@logic x)}--   CASE2: measure f@logic :: X -> Y    <=> f@haskell :: x:X -> {v:Y    | v = (f@logic x)}--}+    (bs, as, rs) = unzip3 $ dropWhile (isClassType . Misc.snd3) $ zip3 (ty_binds t) (ty_args t) (ty_refts t) -strengthenResult :: Var -> SpecType-strengthenResult v-  | isBool res-  = -- traceShow ("Type for " ++ showPpr v ++ "\t OF \t" ++ show (ty_binds rep)) $-    fromRTypeRep $ rep{ty_res = res `strengthen` r , ty_binds = xs}-  | otherwise-  = -- traceShow ("Type for " ++ showPpr v ++ "\t OF \t" ++ show (ty_binds rep)) $-    fromRTypeRep $ rep{ty_res = res `strengthen` r', ty_binds = xs}+{- | [NOTE:inlineSpecType type]: the refinement depends on whether the result type is a Bool or not:+      CASE1: measure f@logic :: X -> Bool <=> f@haskell :: x:X -> {v:Bool | v <=> (f@logic x)}+     CASE2: measure f@logic :: X -> Y    <=> f@haskell :: x:X -> {v:Y    | v = (f@logic x)}+ -}+-- formerly: strengthenResult+inlineSpecType :: Var -> SpecType+inlineSpecType v = fromRTypeRep $ rep {ty_res = res `strengthen` r , ty_binds = xs}   where-    rep = toRTypeRep t-    res = ty_res rep-    xs  = intSymbol (symbol ("x" :: String)) <$> [1..length $ ty_binds rep]-    r'  = MkUReft (exprReft (mkEApp f (mkA <$> vxs))) mempty mempty-    r   = MkUReft (propReft (mkEApp f (mkA <$> vxs))) mempty mempty-    vxs = dropWhile (isClassType . snd) $ zip xs (ty_args rep)-    f   = dummyLoc $ symbol v -- dropModuleNames $ simplesymbol v-    t   = (ofType $ varType v) :: SpecType-    mkA = EVar . fst -- if isBool t then EApp (dummyLoc propConName) [(EVar x)] else EVar x---strengthenResult' :: Var -> SpecType-strengthenResult' v-  | isBool $ ty_res $ toRTypeRep t-  = go mkProp [] [1..] t-  | otherwise-  = go mkExpr [] [1..] t-  where f   = dummyLoc $ symbol v -- dropModuleNames $ simplesymbol v-        t   = (ofType $ varType v) :: SpecType+    r              = MkUReft (mkR (mkEApp f (mkA <$> vxs))) mempty mempty+    rep            = toRTypeRep t+    res            = ty_res rep+    xs             = intSymbol (symbol ("x" :: String)) <$> [1..length $ ty_binds rep]+    vxs            = dropWhile (isClassType . snd) $ zip xs (ty_args rep)+    f              = dummyLoc (symbol v)+    t              = ofType (GM.expandVarType v) :: SpecType+    mkA            = EVar . fst +    mkR            = if isBool res then propReft else exprReft  -        -- refine types of measures: keep going until you find the last data con!-        -- this code is a hack! we refine the last data constructor,-        -- it got complicated to support both-        -- 1. multi parameter measures     (see tests/pos/HasElem.hs)-        -- 2. measures returning functions (fromReader :: Reader r a -> (r -> a) )-        -- to simplify, drop support for multi parameter measures-        go f args i (RAllT a t)-          = RAllT a $ go f args i t-        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-        go f args i t@(RFun _ t1 t2 r)-          | hasRApps t-          = let x' = intSymbol (symbol ("x" :: String)) (head i)-            in RFun x' t1 (go f (x':args) (tail i) t2) r-        go f args _ t-          = t `strengthen` f args+-- | Refine types of measures: keep going until you find the last data con!+--   this code is a hack! we refine the last data constructor,+--   it got complicated to support both+--   1. multi parameter measures     (see tests/pos/HasElem.hs)+--   2. measures returning functions (fromReader :: Reader r a -> (r -> a) )+--   TODO: SIMPLIFY by dropping support for multi parameter measures -        hasRApps (RApp {})        = True-        hasRApps (RFun _ t1 t2 _) = hasRApps t1 || hasRApps t2-        hasRApps _                = False+-- formerly: strengthenResult'+measureSpecType :: Var -> SpecType+measureSpecType v = go mkT [] [1..] t+  where +    mkR | boolRes   = propReft +        | otherwise = exprReft  +    mkT xs          = MkUReft (mkR $ mkEApp f (EVar <$> reverse xs)) mempty mempty+    f               = dummyLoc (symbol v) +    t               = ofType (GM.expandVarType v) :: SpecType+    boolRes         =  isBool $ ty_res $ toRTypeRep t  -        mkExpr xs = MkUReft (exprReft $ mkEApp f (EVar <$> reverse xs)) mempty mempty-        mkProp xs = MkUReft (propReft $ mkEApp f (EVar <$> reverse xs)) mempty mempty+    go f args i (RAllT a t)      = RAllT a $ go f args i t+    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+    go f args i t@(RFun _ t1 t2 r)+     | hasRApps t               = RFun x' t1 (go f (x':args) (tail i) t2) r+                                       where x' = intSymbol (symbol ("x" :: String)) (head i)+    go f args _ t                = t `strengthen` f args +    hasRApps (RFun _ t1 t2 _) = hasRApps t1 || hasRApps t2+    hasRApps (RApp {})        = True+    hasRApps _                = False+    +   +-- | 'weakenResult foo t' drops the singleton constraint `v = foo x y` +--   that is added, e.g. for measures in /strengthenResult'. +--   This should only be used _when_ checking the body of 'foo' +--   where the output, is, by definition, equal to the singleton.+weakenResult :: Var -> SpecType -> SpecType +weakenResult v t = F.notracepp msg t'+  where +    msg          = "weakenResult v =" ++ GM.showPpr v ++ " t = " ++ showpp t+    t'           = fromRTypeRep $ rep { ty_res = mapExprReft weaken (ty_res rep) } +    rep          = toRTypeRep t+    weaken x     = pAnd . filter ((Just vE /=) . isSingletonExpr x) . conjuncts +    vE           = mkEApp vF xs+    xs           = EVar . fst <$> dropWhile (isClassType . snd) xts +    xts          = zip (ty_binds rep) (ty_args rep)+    vF           = dummyLoc (symbol v)  type LogicM = ExceptT Error (StateT LState Identity) @@ -161,35 +166,82 @@       , lsDCMap  = dm       } +coreAltToDef :: (Reftable r) => LocSymbol -> Var -> [Var] -> Var -> Type -> [C.CoreAlt] +             -> LogicM [Def (Located (RRType r)) DataCon]+coreAltToDef x z zs y t alts  +  | not (null litAlts) = measureFail x "Cannot lift definition with literal alternatives" +  | otherwise          = do +      d1s <- F.notracepp "coreAltDefs-1" <$> mapM (mkAlt x cc myArgs z) dataAlts +      d2s <- F.notracepp "coreAltDefs-2" <$>       mkDef x cc myArgs z  defAlts defExpr +      return (d1s ++ d2s)+  where +    myArgs   = reverse zs+    cc       = if eqType t boolTy then P else E +    defAlts  = GM.defaultDataCons (GM.expandVarType y) (Misc.fst3 <$> alts)+    defExpr  = listToMaybe [ e |   (C.DEFAULT  , _, e) <- alts ]+    dataAlts =             [ a | a@(C.DataAlt _, _, _) <- alts ]+    litAlts  =             [ a | a@(C.LitAlt _, _, _) <- alts ]++    -- mkAlt :: LocSymbol -> (Expr -> Body) -> [Var] -> Var -> (C.AltCon, [Var], C.CoreExpr)+    mkAlt x ctor _args dx (C.DataAlt d, xs, e)+      = Def x {- (toArgs id args) -} d (Just $ varRType dx) (toArgs Just xs) +      . ctor +      . (`subst1` (F.symbol dx, F.mkEApp (GM.namedLocSymbol d) (F.eVar <$> xs))) +     <$> coreToLg e+    mkAlt _ _ _ _ alt +      = throw $ "Bad alternative" ++ GM.showPpr alt++    mkDef x ctor _args dx (Just dtss) (Just e) = do  +      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 ]+    +    mkDef _ _ _ _ _ _ = +      return [] ++toArgs :: Reftable r => (Located (RRType r) -> b) -> [Var] -> [(Symbol, b)]+toArgs f args = [(symbol x, f $ varRType x) | x <- args]++defArgs :: Monoid r => LocSymbol -> [Type] -> [(Symbol, Maybe (Located (RRType r)))]+defArgs x     = zipWith (\i t -> (defArg i, defRTyp t)) [0..] +  where +    defArg    = tempSymbol (val x)+    defRTyp   = Just . F.atLoc x . ofType+ coreToDef :: Reftable r => LocSymbol -> Var -> C.CoreExpr           -> LogicM [Def (Located (RRType r)) DataCon]-coreToDef x _ e = go [] $ inline_preds $ simplify e+coreToDef x _ e                   = go [] $ inlinePreds $ simplify e   where-    go args (C.Lam  x e) = go (x:args) e-    go args (C.Tick _ e) = go args e-    go args (C.Case _ _ t alts)-      | eqType t boolTy  = mapM (goalt_prop (reverse $ tail args) (head args)) alts-      | otherwise        = mapM (goalt      (reverse $ tail args) (head args)) alts-    go _ _               = throw "Measure Functions should have a case at top level"+    go args   (C.Lam  x e)        = go (x:args) e+    go args   (C.Tick _ e)        = go args e+    go (z:zs) (C.Case _ y t alts) = coreAltToDef x z zs y t alts +    go (z:zs) e                   +      | Just t <- isMeasureArg z  = coreAltToDef x z zs z t [(C.DEFAULT, [], e)]+    go _ _                        = measureFail x "Does not have a case-of at the top-level"  -    goalt args dx (C.DataAlt d, xs, e)-      = Def x (toArgs id args) d (Just $ varRType dx) (toArgs Just xs) . E-        <$> coreToLg e-    goalt _ _ alt-       = throw $ "Bad alternative" ++ showPpr alt+    inlinePreds   = inline (eqType boolTy . GM.expandVarType) -    goalt_prop args dx (C.DataAlt d, xs, e)-      = Def x (toArgs id args) d (Just $ varRType dx) (toArgs Just xs) . P-        <$> coreToLg  e-    goalt_prop _ _ alt-      = throw $ "Bad alternative" ++ showPpr alt+measureFail       :: LocSymbol -> String -> a+measureFail x msg = panic sp e +  where +    sp            = Just (GM.fSrcSpan x)+    e             = Printf.printf "Cannot create measure '%s': %s" (F.showpp x) msg+     -    toArgs f args = [(symbol x, f $ varRType x) | x <- args]+-- | 'isMeasureArg x' returns 'Just t' if 'x' is a valid argument for a measure.+isMeasureArg :: Var -> Maybe Type +isMeasureArg x +  | Just tc <- tcMb +  , TyCon.isAlgTyCon tc = F.notracepp "isMeasureArg" $ Just t +  | otherwise           = Nothing +  where +    t                   = GM.expandVarType x  +    tcMb                = tyConAppTyCon_maybe t -    inline_preds = inline (eqType boolTy . varType)  varRType :: (Reftable r) => Var -> Located (RRType r)-varRType = varLocInfo ofType+varRType = GM.varLocInfo ofType  coreToFun :: LocSymbol -> Var -> C.CoreExpr ->  LogicM ([Var], Either Expr Expr) coreToFun _ _v e = go [] $ normalize e@@ -199,9 +251,10 @@     go acc (C.Lam x e)  = go (x:acc) e     go acc (C.Tick _ e) = go acc e     go acc e            = (reverse acc,) . Right <$> coreToLg e+      instance Show C.CoreExpr where-  show = showPpr+  show = GM.showPpr  coreToLogic :: C.CoreExpr -> LogicM Expr coreToLogic cb = coreToLg (normalize cb)@@ -219,19 +272,19 @@   | otherwise                  = (lsSymMap <$> getState) >>= eVarWithMap x coreToLg e@(C.App _ _)         = toPredApp e coreToLg (C.Case e b _ alts)-  | eqType (varType b) boolTy  = checkBoolAlts alts >>= coreToIte e+  | eqType (GM.expandVarType b) boolTy  = checkBoolAlts alts >>= coreToIte e coreToLg (C.Lam x e)           = do p     <- coreToLg e                                     tce   <- lsEmb <$> getState-                                    return $ ELam (symbol x, typeSort tce (varType x)) p+                                    return $ ELam (symbol x, typeSort tce (GM.expandVarType x)) p coreToLg (C.Case e b _ alts)   = do p <- coreToLg e                                     casesToLg b p alts coreToLg (C.Lit l)             = case mkLit l of-                                   Nothing -> throw $ "Bad Literal in measure definition" ++ showPpr l+                                   Nothing -> throw $ "Bad Literal in measure definition" ++ GM.showPpr l                                    Just i  -> return i coreToLg (C.Cast e c)          = do (s, t) <- coerceToLg c                                     e'     <- coreToLg   e                                     return (ECoerc s t e')-coreToLg e                     = throw ("Cannot transform to Logic:\t" ++ showPpr e)+coreToLg e                     = throw ("Cannot transform to Logic:\t" ++ GM.showPpr e)   @@ -241,19 +294,15 @@  coercionTypeEq :: Coercion -> (Type, Type) coercionTypeEq co-  | Pair.Pair s t <- {- tracePpr ("coercion-type-eq-1: " ++ showPpr co) $ -}+  | Pair.Pair s t <- -- GM.tracePpr ("coercion-type-eq-1: " ++ GM.showPpr co) $                        coercionKind co   = (s, t)  typeEqToLg :: (Type, Type) -> LogicM (Sort, Sort) typeEqToLg (s, t) = do   tce   <- gets lsEmb-  return (typeSort tce s, typeSort tce t)--  -- Pair t1 t2 <- coercionKind co-  -- getCoVar_maybe :: Coercion -> Maybe CoVar-  -- getTyVar_maybe :: Type -> Maybe TyVar-  -- coVarTypes :: CoVar -> (Type, Type)+  let tx = typeSort tce . expandTypeSynonyms+  return $ F.notracepp "TYPE-EQ-TO-LOGIC" (tx s, tx t)  checkBoolAlts :: [C.CoreAlt] -> LogicM (C.CoreExpr, C.CoreExpr) checkBoolAlts [(C.DataAlt false, [], efalse), (C.DataAlt true, [], etrue)]@@ -264,44 +313,52 @@   | false == falseDataCon, true == trueDataCon   = return (efalse, etrue) checkBoolAlts alts-  = throw ("checkBoolAlts failed on " ++ showPpr alts)+  = throw ("checkBoolAlts failed on " ++ GM.showPpr alts)  casesToLg :: Var -> Expr -> [C.CoreAlt] -> LogicM Expr-casesToLg v e alts-  = mapM (altToLg e) alts >>= go+casesToLg v e alts = mapM (altToLg e) normAlts >>= go   where+    normAlts       = normalizeAlts alts     go :: [(C.AltCon, Expr)] -> LogicM Expr     go [(_,p)]     = return (p `subst1` su)     go ((d,p):dps) = do c <- checkDataAlt d e                         e' <- go dps                         return (EIte c p e' `subst1` su)-    go []          = throw "Bah"+    go []          = panic (Just (getSrcSpan v)) "Unexpected empty cases in casesToLg"     su             = (symbol v, e)  checkDataAlt :: C.AltCon -> Expr -> LogicM Expr checkDataAlt (C.DataAlt d) e = return $ EApp (EVar (makeDataConChecker d)) e checkDataAlt C.DEFAULT     _ = return PTrue-checkDataAlt (C.LitAlt _)  _ = throw "Oops, not yet handled: checkDataAlt on Lit"+checkDataAlt (C.LitAlt l)  e +  | Just le <- mkLit l       = return (EEq le e)  +  | otherwise                = throw $ "Oops, not yet handled: checkDataAlt on Lit: " ++ GM.showPpr l +-- | 'altsDefault' reorders the CoreAlt to ensure that 'DEFAULT' is at the end.+normalizeAlts :: [C.CoreAlt] -> [C.CoreAlt]+normalizeAlts alts      = ctorAlts ++ defAlts +  where +    (defAlts, ctorAlts) = L.partition isDefault alts +    isDefault (c,_,_)   = c == C.DEFAULT + altToLg :: Expr -> C.CoreAlt -> LogicM (C.AltCon, Expr)-altToLg de (a@(C.DataAlt d), xs, e)-  = do p  <- coreToLg e-       dm <- gets lsDCMap-       let su = mkSubst $ concat [ f dm x i | (x, i) <- zip xs [1..]]-       return (a, subst su p)-  where-    f dm x i = let t = EApp (EVar $ makeDataConSelector (Just dm) d i) de-               in [(symbol x, t), (simplesymbol x, t)]+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..]]+  return (a, subst su p)  altToLg _ (a, _, e)   = (a, ) <$> coreToLg e +dataConProj :: DataConMap -> Expr -> DataCon -> Var -> Int -> [(Symbol, Expr)]+dataConProj dm de d x i = [(symbol x, t), (GM.simplesymbol x, t)]+  where+    t | primDataCon  d  = de +      | otherwise       = EApp (EVar $ makeDataConSelector (Just dm) d i) de ---- altToLg _ (C.LitAlt _, _, _)-  --- = throw "altToLg on Lit"---- altToLg _ (C.DEFAULT, _, e)-  --- = throw ("Cannot reflect functions with Default pattern matching." ++-           --- "\n\t Suggestion: Make sure your function is total and is not pattern matching on integer values.")+primDataCon :: DataCon -> Bool +primDataCon d = d == intDataCon  coreToIte :: C.CoreExpr -> (C.CoreExpr, C.CoreExpr) -> LogicM Expr coreToIte e (efalse, etrue)@@ -311,9 +368,9 @@        return $ EIte p e2 e1  toPredApp :: C.CoreExpr -> LogicM Expr-toPredApp p = go . mapFst opSym . splitArgs $ p+toPredApp p = go . Misc.mapFst opSym . splitArgs $ p   where-    opSym = fmap dropModuleNames . tomaybesymbol+    opSym = fmap GM.dropModuleNames . tomaybesymbol     go (Just f, [e1, e2])       | Just rel <- M.lookup f brels       = PAtom rel <$> coreToLg e1 <*> coreToLg e2@@ -343,7 +400,8 @@                   lmap <- lsSymMap <$> getState                   def  <- (`mkEApp` args) <$> tosymbol f                   ((\x -> makeApp def lmap x args) <$> (tosymbol' f))-    _       -> do (fe : args) <- mapM coreToLg (f:es)+    _       -> do fe   <- coreToLg f+                  args <- mapM coreToLg es                   return $ foldl EApp fe args  makeApp :: Expr -> LogicMap -> Located Symbol-> [Expr] -> Expr@@ -368,7 +426,7 @@   | isPolyCst t = mkEApp (dummyLoc s) []   | otherwise   = EVar s   where-    t           = varType x+    t           = GM.expandVarType x     s           = symbol x  isPolyCst :: Type -> Bool@@ -419,29 +477,30 @@ tosymbol e  = case tomaybesymbol e of     Just x -> return $ dummyLoc x-    _      -> throw ("Bad Measure Definition:\n" ++ showPpr e ++ "\t cannot be applied")+    _      -> throw ("Bad Measure Definition:\n" ++ GM.showPpr e ++ "\t cannot be applied")  tosymbol' :: C.CoreExpr -> LogicM (Located Symbol)-tosymbol' (C.Var x) = return $ dummyLoc $ symbol x -- simpleSymbolVar' x-tosymbol' e        = throw ("Bad Measure Definition:\n" ++ showPpr e ++ "\t cannot be applied")+tosymbol' (C.Var x) = return $ dummyLoc $ symbol x +tosymbol' e        = throw ("Bad Measure Definition:\n" ++ GM.showPpr e ++ "\t cannot be applied")  makesub :: C.CoreBind -> LogicM (Symbol, Expr) makesub (C.NonRec x e) =  (symbol x,) <$> coreToLg e makesub  _             = throw "Cannot make Logical Substitution of Recursive Definitions"  mkLit :: Literal -> Maybe Expr-mkLit (MachInt    n)   = mkI n-mkLit (MachInt64  n)   = mkI n-mkLit (MachWord   n)   = mkI n-mkLit (MachWord64 n)   = mkI n-mkLit (MachFloat  n)   = mkR n-mkLit (MachDouble n)   = mkR n-mkLit (LitInteger n _) = mkI n-mkLit (MachStr s)      = mkS s-mkLit _                = Nothing -- ELit sym sort+mkLit (LitNumber _ n _) = mkI n+-- mkLit (MachInt64  n)    = mkI n+-- mkLit (MachWord   n)    = mkI n+-- mkLit (MachWord64 n)    = mkI n+-- mkLit (LitInteger n _)  = mkI n+mkLit (MachFloat  n)    = mkR n+mkLit (MachDouble n)    = mkR n+mkLit (MachStr    s)    = mkS s+mkLit (MachChar   c)    = mkC c +mkLit _                 = Nothing -- ELit sym sort  mkI :: Integer -> Maybe Expr-mkI                    = Just . ECon . I+mkI = Just . ECon . I  mkR :: Rational -> Maybe Expr mkR                    = Just . ECon . F.R . fromRational@@ -449,19 +508,35 @@ mkS :: ByteString -> Maybe Expr mkS                    = Just . ESym . SL  . decodeUtf8With lenientDecode +mkC :: Char -> Maybe Expr+mkC                    = Just . ECon . (`F.L` F.charSort)  . repr +  where +    repr               = T.pack . show . Data.Char.ord + ignoreVar :: Id -> Bool-ignoreVar i = simpleSymbolVar i `elem` ["I#"]+ignoreVar i = simpleSymbolVar i `elem` ["I#", "D#"] -_simpleSymbolVar' :: Id -> Symbol-_simpleSymbolVar' = simplesymbol --symbol . {- showPpr . -} getName+isBangInteger :: [C.CoreAlt] -> Bool +isBangInteger [(C.DataAlt s, _, _), (C.DataAlt jp,_,_), (C.DataAlt jn,_,_)] +  =  symbol s  == "GHC.Integer.Type.S#" +  && symbol jp == "GHC.Integer.Type.Jp#" +  && symbol jn == "GHC.Integer.Type.Jn#"  +isBangInteger _ = False   isErasable :: Id -> Bool-isErasable v = isPrefixOfSym (symbol ("$" :: String)) (simpleSymbolVar v)-  -- where-    -- v         = F.tracepp _msg v0-    -- _msg      = Printf.printf "isErasable: isCoVar %s = %s" (showPpr v0) (show $ isCoVar v0)+isErasable v = F.notracepp msg $ isGhcSplId v && not (isDCId v) +  where +    msg      = "isErasable: " ++ GM.showPpr (v, Var.idDetails v) +isGhcSplId :: Id -> Bool+isGhcSplId v = isPrefixOfSym (symbol ("$" :: String)) (simpleSymbolVar v) +isDCId :: Id -> Bool+isDCId v = case Var.idDetails v of +  DataConWorkId _ -> True +  DataConWrapId _ -> True +  _               -> False + isANF :: Id -> Bool isANF      v = isPrefixOfSym (symbol ("lq_anf" :: String)) (simpleSymbolVar v) @@ -475,7 +550,7 @@   normalize :: a -> a   normalize = inline_preds . inline_anf . simplify    where-    inline_preds = inline (eqType boolTy . varType)+    inline_preds = inline (eqType boolTy . GM.expandVarType)     inline_anf   = inline isANF  instance Simplify C.CoreExpr where@@ -503,6 +578,9 @@     = simplify e   simplify (C.Let xes e)     = C.Let (simplify xes) (simplify e)+  simplify (C.Case e x _t alts@[(_,_,ee),_,_]) | isBangInteger alts+    = Misc.traceShow ("To simplify case") $ +       sub (M.singleton x (simplify e)) (simplify ee)   simplify (C.Case e x t alts)     = C.Case (simplify e) x t (filter (not . isUndefined) (simplify <$> alts))   simplify (C.Cast e c)@@ -541,10 +619,10 @@  instance Simplify C.CoreBind where   simplify (C.NonRec x e) = C.NonRec x (simplify e)-  simplify (C.Rec xes)    = C.Rec (mapSnd simplify <$> xes )+  simplify (C.Rec xes)    = C.Rec (Misc.mapSnd simplify <$> xes )    inline p (C.NonRec x e) = C.NonRec x (inline p e)-  inline p (C.Rec xes)    = C.Rec (mapSnd (inline p) <$> xes)+  inline p (C.Rec xes)    = C.Rec (Misc.mapSnd (inline p) <$> xes)  instance Simplify C.CoreAlt where   simplify (c, xs, e) = (c, xs, simplify e)
src/Language/Haskell/Liquid/Transforms/Rec.hs view
@@ -12,7 +12,8 @@      , isIdTRecBound, setIdTRecBound      ) where -import           Bag+-- import           Bag+-- import           ErrUtils import           Coercion import           Control.Arrow                        (second) import           Control.Monad.State@@ -20,7 +21,6 @@ import           CoreUtils import qualified Data.HashMap.Strict                  as M import           Data.Hashable-import           ErrUtils import           Id import           IdInfo import           Language.Haskell.Liquid.GHC.Misc@@ -30,7 +30,7 @@ import           Language.Haskell.Liquid.Types.Errors import           MkCore                               (mkCoreLams) import           Name                                 (isSystemName)-import           Outputable                           (SDoc)+-- import           Outputable                           (SDoc) import           Prelude                              hiding (error) import           SrcLoc import           Type                                 (mkForAllTys, splitForAllTys)@@ -38,21 +38,21 @@ import           Unique                               hiding (deriveUnique) import           Var -import           Data.List                            (foldl', isInfixOf)-+-- import qualified Data.List                            (foldl', isInfixOf)  import qualified Data.List                            as L   transformRecExpr :: CoreProgram -> CoreProgram-transformRecExpr cbs-  | isEmptyBag $ filterBag isTypeError e-  =  {-trace "new cbs"-} pg-  | otherwise-  = panic Nothing ("Type-check" ++ showSDoc (pprMessageBag e))-  where pg0    = evalState (transPg (inlineLoopBreaker <$> cbs)) initEnv-        (_, e) = lintCoreBindings [] pg-        pg     = inlineFailCases pg0+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))+  where +    pg     = inlineFailCases pg0+    pg0    = evalState (transPg (inlineLoopBreaker <$> cbs)) initEnv+    -- (_, e) = lintCoreBindings [] pg   @@ -63,7 +63,7 @@   where     (αs, as, be) = collectTyAndValBinders e -    e' = foldl' App (foldl' App (Var x) ((Type . TyVarTy) <$> αs)) (Var <$> as)+    e' = L.foldl' App (L.foldl' App (Var x) ((Type . TyVarTy) <$> αs)) (Var <$> as)      hasLoopBreaker (Let (Rec [(x1, e1)]) (Var x2)) | isLoopBreaker x1 && x1 == x2 = Just (x1, e1)     hasLoopBreaker _                               = Nothing@@ -98,9 +98,9 @@     addFailExpr x (Lam _ e) su = (x, e):su     addFailExpr _ _         _  = impossible Nothing "internal error" -- this cannot happen -isTypeError :: SDoc -> Bool-isTypeError s | isInfixOf "Non term variable" (showSDoc s) = False-isTypeError _ = True+-- isTypeError :: SDoc -> Bool+-- isTypeError s | isInfixOf "Non term variable" (showSDoc s) = False+-- isTypeError _ = True  -- No need for this transformation after ghc-8!!! transformScope :: [Bind Id] -> [Bind Id]@@ -207,7 +207,7 @@ makeTrans _ _ _ = panic Nothing "TransformRec.makeTrans called with invalid input"  mkRecBinds :: [(b, Expr b)] -> Bind b -> Expr b -> Expr b-mkRecBinds xes rs e = Let rs (foldl' f e xes)+mkRecBinds xes rs e = Let rs (L.foldl' f e xes)   where f e (x, xe) = Let (NonRec x xe) e  mkSubs :: (Eq k, Hashable k)
src/Language/Haskell/Liquid/Transforms/RefSplit.hs view
@@ -29,6 +29,11 @@ splitRType f (RVar a r) = (RVar a r1, RVar a r2)   where         (r1, r2) = splitRef f r+splitRType f (RImpF x tx t r) = (RImpF x tx1 t1 r1, RImpF x tx2 t2 r2)+  where+        (tx1, tx2) = splitRType f tx+        (t1,  t2)  = splitRType f t+        (r1,  r2)  = splitRef   f r splitRType f (RFun x tx t r) = (RFun x tx1 t1 r1, RFun x tx2 t2 r2)   where         (tx1, tx2) = splitRType f tx
src/Language/Haskell/Liquid/Transforms/Rewrite.hs view
@@ -416,9 +416,9 @@   = Nothing  isIrrefutErrorVar :: Var -> Bool-isIrrefutErrorVar x = MkCore.iRREFUT_PAT_ERROR_ID == x--+-- isIrrefutErrorVar _x = False -- MkCore.iRREFUT_PAT_ERROR_ID == x -- TODO:GHC-863+isIrrefutErrorVar x = x == MkCore.pAT_ERROR_ID+  -------------------------------------------------------------------------------- -- | `substTuple xs ys e'` returns e' [y1 := x1,...,yn := xn] --------------------------------------------------------------------------------
src/Language/Haskell/Liquid/Types.hs view
@@ -1,2239 +1,20 @@-{-# LANGUAGE StandaloneDeriving         #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE DeriveTraversable          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE TypeSynonymInstances       #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE UndecidableInstances       #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE RecordWildCards            #-}-{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE TupleSections              #-}---- | This module should contain all the global type definitions and basic instances.--module Language.Haskell.Liquid.Types (--  -- * Options-    Config (..)-  , HasConfig (..)--  -- * Ghc Information-  , GhcInfo (..)-  , GhcSpec (..)-  , TargetVars (..)--  -- * F.Located Things-  , F.Located (..)-  , F.dummyLoc--  -- * Symbols-  , F.LocSymbol-  , F.LocText--  -- * Default unknown name-  , F.dummyName-  , F.isDummy--  -- * Bare Type Constructors and Variables-  , BTyCon(..)-  , mkBTyCon, mkClassBTyCon, mkPromotedBTyCon-  , isClassBTyCon-  , BTyVar(..)--  -- * Refined Type Constructors-  , RTyCon (RTyCon, rtc_tc, rtc_info)-  , TyConInfo(..), defaultTyConInfo-  , rTyConPVs-  , rTyConPropVs-  -- , isClassRTyCon-  , isClassType, isEqType, isRVar, isBool--  -- * Refinement Types-  , RType (..), Ref(..), RTProp, rPropP-  , RTyVar (..)-  , RTAlias (..)-  , OkRT-  , lmapEAlias--  -- * Worlds-  , HSeg (..)-  , World (..)--  -- * Classes describing operations on `RTypes`-  , TyConable (..)-  , SubsTy (..)--  -- * Type Variables-  , RTVar (..), RTVInfo (..)-  , makeRTVar, mapTyVarValue-  , dropTyVarInfo, rTVarToBind--  -- * Predicate Variables-  , PVar (PV, pname, parg, ptype, pargs), isPropPV, pvType-  , PVKind (..)-  , Predicate (..)--  -- * Refinements-  , UReft(..)--  -- * Parse-time entities describing refined data types-  , SizeFun  (..), szFun-  , DataDecl (..)-  , DataName (..), dataNameSymbol-  , DataCtor (..)-  , DataConP (..)-  , HasDataDecl (..), hasDecl-  , DataDeclKind (..)-  , TyConP   (..)--  -- * Pre-instantiated RType-  , RRType, RRProp-  , BRType, BRProp-  , BSort, BPVar-  , RTVU, PVU--  -- * Instantiated RType-  , BareType, PrType-  , SpecType, SpecProp-  , SpecRep-  , LocBareType, LocSpecType-  , RSort-  , UsedPVar, RPVar, RReft-  , REnv (..)--  -- * Constructing & Destructing RTypes-  , RTypeRep(..), fromRTypeRep, toRTypeRep-  , mkArrow, bkArrowDeep, bkArrow, safeBkArrow-  , mkUnivs, bkUniv, bkClass-  , rFun, rCls, rRCls--  -- * Manipulating `Predicates`-  , pvars, pappSym, pApp--  -- * Some tests on RTypes-  , isBase-  , isFunTy-  , isTrivial--  -- * Traversing `RType`-  , efoldReft, foldReft, foldReft'-  , mapReft, mapReftM, mapPropM-  , mapExprReft-  , mapBot, mapBind-  , foldRType---  -- * ???-  , Oblig(..)-  , ignoreOblig-  , addInvCond--  -- * Inferred Annotations-  , AnnInfo (..)-  , Annot (..)--  -- * Overall Output-  , Output (..)--  -- * Refinement Hole-  , hole, isHole, hasHole--  -- * Converting To and From Sort-  , ofRSort, toRSort-  , rTypeValueVar-  , rTypeReft-  , stripRTypeBase-  , topRTypeBase--  -- * Class for values that can be pretty printed-  , F.PPrint (..)-  , F.pprint-  , F.showpp--  -- * Printer Configuration-  , PPEnv (..)-  , ppEnv-  , ppEnvShort--  -- * Modules and Imports-  , ModName (..), ModType (..)-  , isSrcImport, isSpecImport-  , getModName, getModString, qualifyModName--  -- * Refinement Type Aliases-  , RTEnv (..)-  , mapRT, mapRE--  -- * Errors and Error Messages-  , module Language.Haskell.Liquid.Types.Errors-  , Error-  , ErrorResult--  -- * Source information (associated with constraints)-  , Cinfo (..)--  -- * Measures-  , Measure (..)-  , CMeasure (..)-  , Def (..)-  , Body (..)-  , MSpec (..)--  -- * Type Classes-  , RClass (..)--  -- * KV Profiling-  , KVKind (..)   -- types of kvars-  , KVProf        -- profile table-  , emptyKVProf   -- empty profile-  , updKVProf     -- extend profile--  -- * Misc-  , mapRTAVars-  , insertsSEnv--  -- * Strata-  , Stratum(..), Strata-  , isSVar-  , getStrata-  , makeDivType, makeFinType--  -- * CoreToLogic-  , LogicMap(..), toLogicMap, eAppWithMap, LMap(..)--  -- * Refined Instances-  , RDEnv, DEnv(..), RInstance(..), RISig(..)--  -- * Ureftable Instances-  , UReftable(..)--  -- * String Literals-  , liquidBegin, liquidEnd--  , Axiom(..), HAxiom, AxiomEq -- (..)--  -- , rtyVarUniqueSymbol, tyVarUniqueSymbol-  , rtyVarType-  )-  where--import           Class-import           CoreSyn                                (CoreBind, CoreExpr)-import           Data.String-import           DataCon-import           GHC                                    (HscEnv, ModuleName, moduleNameString)-import           GHC.Generics-import           Module                                 (moduleNameFS)-import           NameSet-import           PrelInfo                               (isNumericClass)-import Prelude                          hiding  (error)-import           SrcLoc                                 (SrcSpan)-import           TyCon-import           Type                                   (getClassPredTys_maybe)-import           Language.Haskell.Liquid.GHC.TypeRep                          hiding  (maybeParen, pprArrowChain)-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-import qualified Data.Foldable                          as F-import           Data.Hashable-import qualified Data.HashMap.Strict                    as M-import qualified Data.HashSet                           as S-import           Data.Maybe                             (fromMaybe, mapMaybe)--import           Data.List                              (foldl', nub)-import           Data.Text                              (Text)----import           Text.PrettyPrint.HughesPJ              hiding (first)-import           Text.Printf--import           Language.Fixpoint.Misc--- import           Language.Fixpoint.Types                hiding (SmtSort (..), DataDecl, Error, SrcSpan, Result, Predicate, R)--import qualified Language.Fixpoint.Types as F---import           Language.Haskell.Liquid.GHC.Misc-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---------------------------------------------------------------------------------- | Printer ------------------------------------------------------------------------------------------------------------------------------------------------data PPEnv-  = PP { ppPs    :: Bool-       , ppTyVar :: Bool -- TODO if set to True all Bare fails-       , ppSs    :: Bool-       , ppShort :: Bool-       }-    deriving (Show)--ppEnv :: PPEnv-ppEnv = ppEnvCurrent -- { ppTyVar = True } use True TO SEE UNIQUE SUFFIX ON TYVar--ppEnvCurrent :: PPEnv-ppEnvCurrent    = PP False False False False--_ppEnvPrintPreds :: PPEnv-_ppEnvPrintPreds = PP True False False False--ppEnvShort :: PPEnv -> PPEnv-ppEnvShort pp   = pp { ppShort = True }------------------------------------------------------------------------- | GHC Information :  Code & Spec ---------------------------------------------------------------------------------------------------data GhcInfo = GI-  { target   :: !FilePath       -- ^ Source file for module-  , targetMod:: !ModuleName     -- ^ Name for module-  , env      :: !HscEnv         -- ^ GHC Env used to resolve names for module-  , cbs      :: ![CoreBind]     -- ^ Source Code-  , derVars  :: ![Var]          -- ^ ?-  , impVars  :: ![Var]          -- ^ Binders that are _read_ in module (but not defined?)-  , defVars  :: ![Var]          -- ^ (Top-level) binders that are _defined_ in module-  , useVars  :: ![Var]          -- ^ Binders that are _read_ in module---   , tyCons   :: ![TyCon]        -- ^ Types that are defined inside module-  , hqFiles  :: ![FilePath]     -- ^ Imported .hqual files-  , imports  :: ![String]       -- ^ ??? dead?-  , includes :: ![FilePath]     -- ^ ??? dead?-  , spec     :: !GhcSpec        -- ^ All specification information for module-  }--instance HasConfig GhcInfo where-  getConfig = getConfig . spec---type Expr      = F.Expr-type Symbol    = F.Symbol-type Qualifier = F.Qualifier--- | The following is the overall type for /specifications/ obtained from--- parsing the target source and dependent libraries--data GhcSpec = SP {-    gsTySigs   :: ![(Var, LocSpecType)]          -- ^ Asserted Reftypes-  , gsAsmSigs  :: ![(Var, LocSpecType)]          -- ^ Assumed Reftypes-  , gsInSigs   :: ![(Var, LocSpecType)]          -- ^ Auto generated Signatures-  , gsCtors    :: ![(Var, LocSpecType)]          -- ^ Data Constructor Measure Sigs-  , gsLits     :: ![(Symbol, LocSpecType)]       -- ^ Literals/Constants-                                                 -- e.g. datacons: EQ, GT, string lits: "zombie",...-  , gsMeas     :: ![(Symbol, LocSpecType)]       -- ^ Measure Types-                                                 -- eg.  len :: [a] -> Int-  , gsInvariants :: ![(Maybe Var, LocSpecType)]  -- ^ Data Type Invariants that came from the definition of var measure-                                                 -- eg.  forall a. {v: [a] | len(v) >= 0}-  , gsIaliases   :: ![(LocSpecType, LocSpecType)]-- ^ Data Type Invariant Aliases-  , gsDconsP     :: ![F.Located DataCon]           -- ^ Predicated Data-Constructors-                                                 -- e.g. see tests/pos/Map.hs-  , gsTconsP     :: ![(TyCon, TyConP)]           -- ^ Predicated Type-Constructors-                                                 -- eg.  see tests/pos/Map.hs-  , gsFreeSyms   :: ![(Symbol, Var)]             -- ^ List of `Symbol` free in spec and corresponding GHC var-                                                 -- eg. (Cons, Cons#7uz) from tests/pos/ex1.hs-  , gsTcEmbeds   :: F.TCEmb TyCon                  -- ^ How to embed GHC Tycons into fixpoint sorts-                                                 -- e.g. "embed Set as Set_set" from include/Data/Set.spec-  , gsQualifiers :: ![Qualifier]                 -- ^ Qualifiers in Source/Spec files-                                                 -- e.g tests/pos/qualTest.hs-  , gsADTs       :: ![F.DataDecl]                -- ^ ADTs extracted from Haskell 'data' definitions-  , gsTgtVars    :: ![Var]                       -- ^ Top-level Binders To Verify (empty means ALL binders)-  , gsDecr       :: ![(Var, [Int])]              -- ^ Lexicographically ordered size witnesses for termination-  , gsTexprs     :: ![(Var, [F.Located Expr])]     -- ^ Lexicographically ordered expressions for termination-  , gsNewTypes   :: ![(TyCon, LocSpecType)]      -- ^ Mapping of 'newtype' type constructors with their refined types.-  , gsLvars      :: !(S.HashSet Var)             -- ^ Variables that should be checked in the environment they are used-  , gsLazy       :: !(S.HashSet Var)             -- ^ Binders to IGNORE during termination checking-  , gsAutosize   :: !(S.HashSet TyCon)           -- ^ Binders to IGNORE during termination checking-  , gsAutoInst   :: !(M.HashMap Var (Maybe Int))  -- ^ Binders to expand with automatic axiom instances maybe with specified fuel-  , gsConfig     :: !Config                      -- ^ Configuration Options-  , gsExports    :: !NameSet                       -- ^ `Name`s exported by the module being verified-  , gsMeasures   :: [Measure SpecType DataCon]-  , gsTyconEnv   :: M.HashMap TyCon RTyCon-  , gsDicts      :: DEnv Var SpecType              -- ^ Dictionary Environment-  , gsAxioms     :: [AxiomEq]                      -- ^ Axioms from reflected functions-  , gsReflects   :: [Var]                          -- ^ Binders for reflected functions-  , gsLogicMap   :: LogicMap-  , gsProofType  :: Maybe Type-  , gsRTAliases  :: !RTEnv                         -- ^ Refinement type aliases-  }--instance HasConfig GhcSpec where-  getConfig = gsConfig---- axiom_map ===> lmVarSyms---- [NOTE:LIFTED-VAR-SYMBOLS]: Following NOTE:REFLECT-IMPORTS, by default--- each (lifted) `Var` is mapped to its `Symbol` via the `Symbolic Var`--- instance. For _generated_ vars, we may want a custom name e.g. see---   tests/pos/NatClass.hs--- and we maintain that map in `lmVarSyms` with the `Just s` case.--- Ideally, this bandaid should be replaced so we don't have these--- hacky corner cases.--data LogicMap = LM-  { lmSymDefs  :: M.HashMap Symbol LMap        -- ^ Map from symbols to equations they define-  , lmVarSyms  :: M.HashMap Var (Maybe Symbol) -- ^ Map from (lifted) Vars to `Symbol`; see:-                                              --   NOTE:LIFTED-VAR-SYMBOLS and NOTE:REFLECT-IMPORTs-  } deriving (Show)--instance Monoid LogicMap where-  mempty                        = LM M.empty M.empty-  mappend (LM x1 x2) (LM y1 y2) = LM (M.union x1 y1) (M.union x2 y2)--data LMap = LMap-  { lmVar  :: F.LocSymbol-  , lmArgs :: [Symbol]-  , lmExpr :: Expr-  }--instance Show LMap where-  show (LMap x xs e) = show x ++ " " ++ show xs ++ "\t |-> \t" ++ show e--toLogicMap :: [(F.LocSymbol, [Symbol], Expr)] -> LogicMap-toLogicMap ls = mempty {lmSymDefs = M.fromList $ map toLMap ls}-  where-    toLMap (x, ys, e) = (F.val x, LMap {lmVar = x, lmArgs = ys, lmExpr = e})--eAppWithMap :: LogicMap -> F.Located Symbol -> [Expr] -> Expr -> Expr-eAppWithMap lmap f es def-  | Just (LMap _ xs e) <- M.lookup (F.val f) (lmSymDefs lmap)-  , length xs == length es-  = F.subst (F.mkSubst $ zip xs es) e-  | Just (LMap _ xs e) <- M.lookup (F.val f) (lmSymDefs lmap)-  , isApp e-  = F.subst (F.mkSubst $ zip xs es) $ dropApp e (length xs - length es)-  | otherwise-  = def--dropApp :: Expr -> Int -> Expr-dropApp e i | i <= 0 = e-dropApp (F.EApp e _) i = dropApp e (i-1)-dropApp _ _          = errorstar "impossible"--isApp :: Expr -> Bool-isApp (F.EApp (F.EVar _) (F.EVar _)) = True-isApp (F.EApp e (F.EVar _))          = isApp e-isApp _                              = False--data TyConP = TyConP-  { ty_loc       :: !F.SourcePos-  , freeTyVarsTy :: ![RTyVar]-  , freePredTy   :: ![PVar RSort]-  , freeLabelTy  :: ![Symbol]-  , varianceTs   :: !VarianceInfo-  , variancePs   :: !VarianceInfo-  , sizeFun      :: !(Maybe SizeFun)-  } deriving (Generic, Data, Typeable)---- TODO: just use Located instead of dc_loc, dc_locE-data DataConP = DataConP-  { dc_loc     :: !F.SourcePos-  , freeTyVars :: ![RTyVar]               -- ^ Type parameters-  , freePred   :: ![PVar RSort]           -- ^ Abstract Refinement parameters-  , freeLabels :: ![Symbol]               -- ^ ? strata stuff-  , tyConstrs  :: ![SpecType]             -- ^ ? Class constraints (via `dataConStupidTheta`)-  , tyArgs     :: ![(Symbol, SpecType)]   -- ^ Value parameters-  , tyRes      :: !SpecType               -- ^ Result type-  -- , tyData     :: !SpecType               -- ^ The 'generic' ADT, see [NOTE:DataCon-Data]-  , dcpIsGadt  :: !Bool                   -- ^ Was this specified in GADT style (if so, DONT use function names as fields)-  , dcpModule  :: !F.Symbol               -- ^ Which module was this defined in-  , dc_locE    :: !F.SourcePos-  } deriving (Generic, Data, Typeable)---- | [NOTE:DataCon-Data] for each 'DataConP' we also---   store the type of the constructed data. This is---   *the same as* 'tyRes' for *vanilla* ADTs---   (e.g. List, Maybe etc.) but may differ for GADTs.---   For example,------      data Thing a where---        X  :: Thing Int---        Y  :: Thing Bool------   Here the 'DataConP' associated with 'X' (resp. 'Y')---   has 'tyRes' corresponding to 'Thing Int' (resp. 'Thing Bool'),---   but in both cases, the 'tyData' should be 'Thing a'.------instance F.Loc DataConP where-  srcSpan d = F.SS (dc_loc d) (dc_locE d)---- | Which Top-Level Binders Should be Verified-data TargetVars = AllVars | Only ![Var]-------------------------------------------------------------------------- | Abstract Predicate Variables ---------------------------------------------------------------------------------------------------------data PVar t = PV-  { pname :: !Symbol-  , ptype :: !(PVKind t)-  , parg  :: !Symbol-  , pargs :: ![(t, Symbol, Expr)]-  } deriving (Generic, Data, Typeable, Show, Functor)--instance Eq (PVar t) where-  pv == pv' = pname pv == pname pv' {- UNIFY: What about: && eqArgs pv pv' -}--instance Ord (PVar t) where-  compare (PV n _ _ _)  (PV n' _ _ _) = compare n n'--instance B.Binary t => B.Binary (PVar t)-instance NFData t   => NFData   (PVar t)--instance Hashable (PVar a) where-  hashWithSalt i (PV n _ _ _) = hashWithSalt i n--pvType :: PVar t -> t-pvType p = case ptype p of-             PVProp t -> t-             PVHProp  -> panic Nothing "pvType on HProp-PVar"--data PVKind t-  = PVProp t-  | PVHProp-  deriving (Generic, Data, Typeable, Functor, F.Foldable, Traversable, Show)--instance B.Binary a => B.Binary (PVKind a)-instance NFData a   => NFData   (PVKind a)-------------------------------------------------------------------------------------- | Predicates ---------------------------------------------------------------------------------------------------------------------------------------------------type UsedPVar      = PVar ()--newtype Predicate  = Pr [UsedPVar] deriving (Generic, Data, Typeable)--instance B.Binary Predicate--instance NFData Predicate where-  rnf _ = ()--instance Monoid Predicate where-  mempty       = pdTrue-  mappend p p' = pdAnd [p, p']--instance (Monoid a) => Monoid (UReft a) where-  mempty                         = MkUReft mempty mempty mempty-  mappend (MkUReft x y z) (MkUReft x' y' z') = MkUReft (mappend x x') (mappend y y') (mappend z z')---pdTrue :: Predicate-pdTrue         = Pr []--pdAnd :: Foldable t => t Predicate -> Predicate-pdAnd ps       = Pr (nub $ concatMap pvars ps)--pvars :: Predicate -> [UsedPVar]-pvars (Pr pvs) = pvs--instance F.Subable UsedPVar where-  syms pv         = [ y | (_, x, F.EVar y) <- pargs pv, x /= y ]-  subst s pv      = pv { pargs = mapThd3 (F.subst s)  <$> pargs pv }-  substf f pv     = pv { pargs = mapThd3 (F.substf f) <$> pargs pv }-  substa f pv     = pv { pargs = mapThd3 (F.substa f) <$> pargs pv }---instance F.Subable Predicate where-  syms     (Pr pvs) = concatMap F.syms   pvs-  subst  s (Pr pvs) = Pr (F.subst s  <$> pvs)-  substf f (Pr pvs) = Pr (F.substf f <$> pvs)-  substa f (Pr pvs) = Pr (F.substa f <$> pvs)--instance F.Subable Qualifier where-  syms   = F.syms . F.qBody-  subst  = mapQualBody . F.subst-  substf = mapQualBody . F.substf-  substa = mapQualBody . F.substa--mapQualBody :: (Expr -> Expr) -> Qualifier -> Qualifier-mapQualBody f q = q { F.qBody = f (F.qBody q) }--instance NFData r => NFData (UReft r)---newtype BTyVar = BTV Symbol deriving (Show, Generic, Data, Typeable)--newtype RTyVar = RTV TyVar deriving (Generic, Data, Typeable)--instance Eq BTyVar where-  (BTV x) == (BTV y) = x == y--instance Ord BTyVar where-  compare (BTV x) (BTV y) = compare x y--instance IsString BTyVar where-  fromString = BTV . fromString--instance B.Binary BTyVar-instance Hashable BTyVar-instance NFData   BTyVar-instance NFData   RTyVar--instance F.Symbolic BTyVar where-  symbol (BTV tv) = tv--instance F.Symbolic RTyVar where-  symbol (RTV tv) = F.symbol tv -- tyVarUniqueSymbol tv---- instance F.Symbolic RTyVar where-  -- symbol (RTV tv) = F.symbol . getName $ tv--- rtyVarUniqueSymbol  :: RTyVar -> Symbol--- rtyVarUniqueSymbol (RTV tv) = tyVarUniqueSymbol tv--- tyVarUniqueSymbol :: TyVar -> Symbol--- tyVarUniqueSymbol tv = F.symbol $ show (getName tv) ++ "_" ++ show (varUnique tv)--data BTyCon = BTyCon-  { btc_tc    :: !F.LocSymbol    -- ^ TyCon name with location information-  , btc_class :: !Bool           -- ^ Is this a class type constructor?-  , btc_prom  :: !Bool           -- ^ Is Promoted Data Con?-  }-  deriving (Generic, Data, Typeable)--instance B.Binary BTyCon--data RTyCon = RTyCon-  { rtc_tc    :: TyCon         -- ^ GHC Type Constructor-  , rtc_pvars :: ![RPVar]      -- ^ Predicate Parameters-  , rtc_info  :: !TyConInfo    -- ^ TyConInfo-  }-  deriving (Generic, Data, Typeable)--instance F.Symbolic BTyCon where-  symbol = F.val . btc_tc--instance NFData BTyCon--instance NFData RTyCon--rtyVarType :: RTyVar -> Type-rtyVarType (RTV v) = TyVarTy v--mkBTyCon :: F.LocSymbol -> BTyCon-mkBTyCon x = BTyCon x False False--mkClassBTyCon :: F.LocSymbol -> BTyCon-mkClassBTyCon x = BTyCon x True False--mkPromotedBTyCon :: F.LocSymbol -> BTyCon-mkPromotedBTyCon x = BTyCon x False True----- | Accessors for @RTyCon@--isBool :: RType RTyCon t t1 -> Bool-isBool (RApp (RTyCon{rtc_tc = c}) _ _ _) = c == boolTyCon-isBool _                                 = False--isRVar :: RType c tv r -> Bool-isRVar (RVar _ _) = True-isRVar _          = False--isClassBTyCon :: BTyCon -> Bool-isClassBTyCon = btc_class---- isClassRTyCon :: RTyCon -> Bool--- isClassRTyCon x = (isClassTyCon $ rtc_tc x) || (rtc_tc x == eqPrimTyCon)--rTyConPVs :: RTyCon -> [RPVar]-rTyConPVs     = rtc_pvars--rTyConPropVs :: RTyCon -> [PVar RSort]-rTyConPropVs  = filter isPropPV . rtc_pvars--isPropPV :: PVar t -> Bool-isPropPV      = isProp . ptype--isEqType :: TyConable c => RType c t t1 -> Bool-isEqType (RApp c _ _ _) = isEqual c-isEqType _              = False---isClassType :: TyConable c => RType c t t1 -> Bool-isClassType (RApp c _ _ _) = isClass c-isClassType _              = False---- rTyConPVHPs = filter isHPropPV . rtc_pvars--- isHPropPV   = not . isPropPV--isProp :: PVKind t -> Bool-isProp (PVProp _) = True-isProp _          = False---defaultTyConInfo :: TyConInfo-defaultTyConInfo = TyConInfo [] [] Nothing--instance Default TyConInfo where-  def = defaultTyConInfo----------------------------------------------------------------------------- | Co- and Contra-variance for TyCon ------------------------------------------------------------------------------------------------------------ | Indexes start from 0 and type or predicate arguments can be both---   covariant and contravaariant e.g., for the below Foo dataType------     data Foo a b c d <p :: b -> Prop, q :: Int -> Prop, r :: a -> Prop>---       = F (a<r> -> b<p>) | Q (c -> a) | G (Int<q> -> a<r>)------  there will be:------    varianceTyArgs     = [Bivariant , Covariant, Contravatiant, Invariant]---    variancePsArgs     = [Covariant, Contravatiant, Bivariant]-----data TyConInfo = TyConInfo-  { varianceTyArgs  :: !VarianceInfo      -- ^ variance info for type variables-  , variancePsArgs  :: !VarianceInfo      -- ^ variance info for predicate variables-  , sizeFunction    :: !(Maybe SizeFun)   -- ^ logical UNARY function that computes the size of the structure-  } deriving (Generic, Data, Typeable)--instance NFData TyConInfo--instance Show TyConInfo where-  show (TyConInfo x y _) = show x ++ "\n" ++ show y------------------------------------------------------------------------------------- | Unified Representation of Refinement Types -------------------------------------------------------------------------------------------------------------------type RTVU c tv = RTVar tv (RType c tv ())-type PVU  c tv = PVar     (RType c tv ())--instance Show tv => Show (RTVU c tv) where-  show (RTVar t _) = show t--data RType c tv r-  = RVar {-      rt_var    :: !tv-    , rt_reft   :: !r-    }--  | RFun  {-      rt_bind   :: !Symbol-    , rt_in     :: !(RType c tv r)-    , rt_out    :: !(RType c tv r)-    , rt_reft   :: !r-    }--  | RAllT {-      rt_tvbind :: !(RTVU c tv) -- RTVar tv (RType c tv ()))-    , rt_ty     :: !(RType c tv r)-    }--  -- | "forall x y <z :: Nat, w :: Int> . TYPE"-  --               ^^^^^^^^^^^^^^^^^^^ (rt_pvbind)-  | RAllP {-      rt_pvbind :: !(PVU c tv)  -- ar (RType c tv ()))-    , rt_ty     :: !(RType c tv r)-    }--  -- | "forall <z w> . TYPE"-  --           ^^^^^ (rt_sbind)-  | RAllS {-      rt_sbind  :: !(Symbol)-    , rt_ty     :: !(RType c tv r)-    }--  | RApp  {-      rt_tycon  :: !c-    , rt_args   :: ![RType  c tv r]-    , rt_pargs  :: ![RTProp c tv r]-    , rt_reft   :: !r-    }--  | RAllE {-      rt_bind   :: !Symbol-    , rt_allarg :: !(RType c tv r)-    , rt_ty     :: !(RType c tv r)-    }--  | REx {-      rt_bind   :: !Symbol-    , rt_exarg  :: !(RType c tv r)-    , rt_ty     :: !(RType c tv r)-    }--  | RExprArg (F.Located Expr)                   -- ^ For expression arguments to type aliases-                                                --   see tests/pos/vector2.hs-  | RAppTy{-      rt_arg   :: !(RType c tv r)-    , rt_res   :: !(RType c tv r)-    , rt_reft  :: !r-    }--  | RRTy  {-      rt_env   :: ![(Symbol, RType c tv r)]-    , rt_ref   :: !r-    , rt_obl   :: !Oblig-    , rt_ty    :: !(RType c tv r)-    }--  | RHole r -- ^ let LH match against the Haskell type and add k-vars, e.g. `x:_`-            --   see tests/pos/Holes.hs-  deriving (Generic, Data, Typeable, Functor)--instance (B.Binary c, B.Binary tv, B.Binary r) => B.Binary (RType c tv r)-instance (NFData c, NFData tv, NFData r)       => NFData (RType c tv r)--ignoreOblig :: RType t t1 t2 -> RType t t1 t2-ignoreOblig (RRTy _ _ _ t) = t-ignoreOblig t              = t---makeRTVar :: tv -> RTVar tv s-makeRTVar a = RTVar a RTVNoInfo--instance (Eq tv) => Eq (RTVar tv s) where-  t1 == t2 = (ty_var_value t1) == (ty_var_value t2)--data RTVar tv s = RTVar-  { ty_var_value :: tv-  , ty_var_info  :: RTVInfo s-  } deriving (Generic, Data, Typeable)--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}--data RTVInfo s-  = RTVNoInfo-  | RTVInfo { rtv_name   :: Symbol-            , rtv_kind   :: s-            , rtv_is_val :: Bool-            } deriving (Generic, Data, Typeable, Functor)---rTVarToBind :: RTVar RTyVar s  -> Maybe (Symbol, s)-rTVarToBind = go . ty_var_info-  where-    go (RTVInfo {..}) | rtv_is_val = Just (rtv_name, rtv_kind)-    go _                           = Nothing--ty_var_is_val :: RTVar tv s -> Bool-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--instance (B.Binary tv, B.Binary s) => B.Binary (RTVar tv s)-instance (NFData tv, NFData s)     => NFData   (RTVar tv s)-instance (NFData s)                => NFData   (RTVInfo s)-instance (B.Binary s)              => B.Binary (RTVInfo s)---- | @Ref@ describes `Prop τ` and `HProp` arguments applied to type constructors.---   For example, in [a]<{\h -> v > h}>, we apply (via `RApp`)---   * the `RProp`  denoted by `{\h -> v > h}` to---   * the `RTyCon` denoted by `[]`.---   Thus, @Ref@ is used for abstract-predicate (arguments) that are associated---   with _type constructors_ i.e. whose semantics are _dependent upon_ the data-type.---   In contrast, the `Predicate` argument in `ur_pred` in the @UReft@ applies---   directly to any type and has semantics _independent of_ the data-type.--data Ref τ t = RProp-  { rf_args :: [(Symbol, τ)]-  , rf_body :: t -- ^ Abstract refinement associated with `RTyCon`-  } deriving (Generic, Data, Typeable, Functor)--instance (B.Binary τ, B.Binary t) => B.Binary (Ref τ t)-instance (NFData τ,   NFData t)   => NFData   (Ref τ t)--rPropP :: [(Symbol, τ)] -> r -> Ref τ (RType c tv r)-rPropP τ r = RProp τ (RHole r)---- | @RTProp@ is a convenient alias for @Ref@ that will save a bunch of typing.---   In general, perhaps we need not expose @Ref@ directly at all.-type RTProp c tv r = Ref (RType c tv ()) (RType c tv r)----- | A @World@ is a Separation Logic predicate that is essentially a sequence of binders---   that satisfies two invariants (TODO:LIQUID):---   1. Each `hs_addr :: Symbol` appears at most once,---   2. There is at most one `HVar` in a list.--newtype World t = World [HSeg t]-                deriving (Generic, Data, Typeable)--data    HSeg  t = HBind {hs_addr :: !Symbol, hs_val :: t}-                | HVar UsedPVar-                deriving (Generic, Data, Typeable)--data UReft r = MkUReft-  { ur_reft   :: !r-  , ur_pred   :: !Predicate-  , ur_strata :: !Strata-  }-  deriving (Generic, Data, Typeable, Functor, Foldable, Traversable)--instance B.Binary r => B.Binary (UReft r)--type BRType     = RType BTyCon BTyVar       -- ^ "Bare" parsed version-type RRType     = RType RTyCon RTyVar       -- ^ "Resolved" version-type RRep       = RTypeRep RTyCon RTyVar--type BSort      = BRType    ()-type RSort      = RRType    ()--type BPVar      = PVar      BSort-type RPVar      = PVar      RSort--type RReft       = UReft     F.Reft-type PrType      = RRType    Predicate-type BareType    = BRType    RReft-type SpecType    = RRType    RReft-type SpecRep     = RRep      RReft-type SpecProp    = RRProp    RReft-type RRProp r    = Ref       RSort (RRType r)-type BRProp r    = Ref       BSort (BRType r)--type LocBareType = F.Located BareType-type LocSpecType = F.Located 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--class (Eq c) => TyConable c where-  isFun    :: c -> Bool-  isList   :: c -> Bool-  isTuple  :: c -> Bool-  ppTycon  :: c -> Doc-  isClass  :: c -> Bool-  isEqual  :: c -> Bool--  isNumCls  :: c -> Bool-  isFracCls :: c -> Bool--  isClass   = const False-  isEqual   = const False-  isNumCls  = const False-  isFracCls = const False----- Should just make this a @Pretty@ instance but its too damn tedious--- to figure out all the constraints.--type OkRT c tv r = ( TyConable c-                   , F.PPrint tv, F.PPrint c, F.PPrint r-                   , F.Reftable r, F.Reftable (RTProp c tv ()), F.Reftable (RTProp c tv r)-                   , Eq c, Eq tv-                   , Hashable tv-                   )------------------------------------------------------------------------------------ | TyConable Instances -----------------------------------------------------------------------------------------------------------------------------------------instance TyConable RTyCon where-  isFun      = isFunTyCon . rtc_tc-  isList     = (listTyCon ==) . rtc_tc-  isTuple    = TyCon.isTupleTyCon   . rtc_tc-  isClass    = isClass . rtc_tc -- isClassRTyCon-  isEqual    = isEqual . rtc_tc-  ppTycon    = F.toFix--  isNumCls c  = maybe False (isClassOrSubClass isNumericClass)-                (tyConClass_maybe $ rtc_tc c)-  isFracCls c = maybe False (isClassOrSubClass isFractionalClass)-                (tyConClass_maybe $ rtc_tc c)---instance TyConable TyCon where-  isFun      = isFunTyCon-  isList     = (listTyCon ==)-  isTuple    = TyCon.isTupleTyCon-  isClass c  = isClassTyCon c   || isEqual c -- c == eqPrimTyCon-  isEqual c  = c == eqPrimTyCon || c == eqReprPrimTyCon-  ppTycon    = text . showPpr--  isNumCls c  = maybe False (isClassOrSubClass isNumericClass)-                (tyConClass_maybe $ c)-  isFracCls c = maybe False (isClassOrSubClass isFractionalClass)-                (tyConClass_maybe $ c)---isClassOrSubClass :: (Class -> Bool) -> Class -> Bool-isClassOrSubClass p cls-  = p cls || any (isClassOrSubClass p . fst)-                 (mapMaybe getClassPredTys_maybe (classSCTheta cls))---- MOVE TO TYPES-instance TyConable Symbol where-  isFun   s = F.funConName == s-  isList  s = F.listConName == s-  isTuple s = F.tupConName == s-  ppTycon   = text . F.symbolString--instance TyConable F.LocSymbol where-  isFun   = isFun   . F.val-  isList  = isList  . F.val-  isTuple = isTuple . F.val-  ppTycon = ppTycon . F.val--instance TyConable BTyCon where-  isFun   = isFun . btc_tc-  isList  = isList . btc_tc-  isTuple = isTuple . btc_tc-  isClass = isClassBTyCon-  ppTycon = ppTycon . btc_tc---instance Eq RTyCon where-  x == y = rtc_tc x == rtc_tc y--instance Eq BTyCon where-  x == y = btc_tc x == btc_tc y--instance F.Fixpoint RTyCon where-  toFix (RTyCon c _ _) = text $ showPpr c--instance F.Fixpoint BTyCon where-  toFix = text . F.symbolString . F.val . btc_tc--instance F.Fixpoint Cinfo where-  toFix = text . showPpr . ci_loc--instance F.PPrint RTyCon where-  pprintTidy _ = text . showPpr . rtc_tc--instance F.PPrint BTyCon where-  pprintTidy _ = text . F.symbolString . F.val . btc_tc--instance F.PPrint v => F.PPrint (RTVar v s) where-  pprintTidy k (RTVar x _) = F.pprintTidy k x--instance Show RTyCon where-  show = F.showpp--instance Show BTyCon where-  show = F.showpp------------------------------------------------------------------------------------- | Refined Instances --------------------------------------------------------------------------------------------------------------------------------------------data RInstance t = RI-  { riclass :: BTyCon-  , ritype  :: [t]-  , risigs  :: [(F.LocSymbol, RISig t)]-  } deriving (Generic, Functor, Data, Typeable, Show)--data RISig t = RIAssumed t | RISig t-  deriving (Generic, Functor, Data, Typeable, Show)--instance (B.Binary t) => B.Binary (RInstance t)-instance (B.Binary t) => B.Binary (RISig t)--newtype DEnv x ty = DEnv (M.HashMap x (M.HashMap Symbol (RISig ty)))-                    deriving (Monoid, Show)--type RDEnv = DEnv Var SpecType-------------------------------------------------------------------------------- | Values Related to Specifications -----------------------------------------------------------------------------------------------------------------data Axiom b s e = Axiom-  { aname  :: (Var, Maybe DataCon)-  , rname  :: Maybe b-  , abinds :: [b]-  , atypes :: [s]-  , alhs   :: e-  , arhs   :: e-  }--type HAxiom = Axiom Var    Type CoreExpr--type AxiomEq = F.Equation--instance Show (Axiom Var Type CoreExpr) where-  show (Axiom (n, c) v bs _ts lhs rhs) = "Axiom : " ++-                                         "\nFun Name: " ++ (showPpr n) ++-                                         "\nReal Name: " ++ (showPpr v) ++-                                         "\nData Con: " ++ (showPpr c) ++-                                         "\nArguments:" ++ (showPpr bs)  ++-                                         -- "\nTypes    :" ++ (showPpr ts)  ++-                                         "\nLHS      :" ++ (showPpr lhs) ++-                                         "\nRHS      :" ++ (showPpr rhs)------------------------------------------------------------------------------------- | Data type refinements----------------------------------------------------------------------------------data DataDecl   = D-  { 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)---- | The name of the `TyCon` corresponding to a `DataDecl`-data DataName-  = DnName !F.LocSymbol  -- ^ for 'isVanillyAlgTyCon' we can directly use the `TyCon` name-  | DnCon  !F.LocSymbol  -- ^ for 'FamInst' TyCon we save some `DataCon` name-  deriving (Eq, Ord, Data, Typeable, Generic)---- | Data Constructor-data DataCtor = DataCtor-  { dcName   :: F.LocSymbol               -- ^ DataCon name-  , dcTheta  :: [BareType]                -- ^ The GHC ThetaType corresponding to DataCon.dataConSig-  , dcFields :: [(Symbol, BareType)]      -- ^ [(fieldName, fieldType)]-  , dcResult :: Maybe BareType            -- ^ Possible output (if in GADT form)-  } deriving (Data, Typeable, Generic)---- | Termination expressions-data SizeFun-  = IdSizeFun              -- ^ \x -> F.EVar x-  | SymSizeFun F.LocSymbol -- ^ \x -> f x-  deriving (Data, Typeable, Generic)---- | 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)--instance Show SizeFun where-  show IdSizeFun      = "IdSizeFun"-  show (SymSizeFun x) = "SymSizeFun " ++ show (F.val x)--szFun :: SizeFun -> Symbol -> Expr-szFun IdSizeFun      = F.EVar-szFun (SymSizeFun f) = \x -> F.mkEApp (F.symbol <$> f) [F.EVar x]--data HasDataDecl-  = NoDecl  (Maybe SizeFun)-  | HasDecl-  deriving (Show)--instance F.PPrint HasDataDecl where-  pprintTidy _ HasDecl    = text "HasDecl"-  pprintTidy k (NoDecl z) = text "NoDecl" <+> parens (F.pprintTidy k z)--hasDecl :: DataDecl -> HasDataDecl-hasDecl d-  | null (tycDCons d)-  = NoDecl (tycSFun d)-  -- // | Just s <- tycSFun d, null (tycDCons d)-  -- // = NoDecl (Just s)-  | otherwise-  = HasDecl--instance Hashable DataName where-  hashWithSalt i = hashWithSalt i . F.symbol---instance NFData   SizeFun-instance B.Binary SizeFun-instance NFData   DataDeclKind-instance B.Binary DataDeclKind-instance B.Binary DataName-instance B.Binary DataCtor-instance B.Binary DataDecl--instance Eq DataDecl where-  d1 == d2 = tycName d1 == tycName d2--instance Ord DataDecl where-  compare d1 d2 = compare (tycName d1) (tycName d2)--instance F.Loc DataCtor where-  srcSpan = F.srcSpan . dcName--instance F.Loc DataDecl where-  srcSpan = srcSpanFSrcSpan . sourcePosSrcSpan . tycSrcPos--instance F.Loc DataName where-  srcSpan (DnName z) = F.srcSpan z-  srcSpan (DnCon  z) = F.srcSpan z----- | For debugging.-instance Show DataDecl where-  show dd = printf "DataDecl: data = %s, tyvars = %s, sizeFun = %s, kind = %s" -- [at: %s]"-              (show $ tycName   dd)-              (show $ tycTyVars dd)-              (show $ tycSFun   dd)-              (show $ tycKind   dd)---instance Show DataName where-  show (DnName n) =               show (F.val n)-  show (DnCon  c) = "datacon:" ++ show (F.val c)--instance F.PPrint SizeFun where-  pprintTidy _ (IdSizeFun)    = "[id]"-  pprintTidy _ (SymSizeFun x) = brackets (F.pprint (F.val x))--instance F.Symbolic DataName where-  symbol = F.val . dataNameSymbol--instance F.Symbolic DataDecl where-  symbol = F.symbol . tycName--instance F.PPrint DataName where-  pprintTidy k (DnName n) = F.pprintTidy k (F.val n)-  pprintTidy k (DnCon  n) = F.pprintTidy k (F.val n)--  -- symbol (DnName z) = F.suffixSymbol "DnName" (F.val z)-  -- symbol (DnCon  z) = F.suffixSymbol "DnCon"  (F.val z)--dataNameSymbol :: DataName -> F.LocSymbol-dataNameSymbol (DnName z) = z-dataNameSymbol (DnCon  z) = z------------------------------------------------------------------------------------- | Refinement Type Aliases----------------------------------------------------------------------------------data RTAlias x a = RTA-  { rtName  :: Symbol             -- ^ name of the alias-  , rtTArgs :: [x]                -- ^ type parameters-  , rtVArgs :: [Symbol]           -- ^ value parameters-  , rtBody  :: a                  -- ^ what the alias expands to-  , rtPos   :: F.SourcePos        -- ^ start position-  , rtPosE  :: F.SourcePos        -- ^ end   position-  } deriving (Data, Typeable, Generic)--instance (B.Binary x, B.Binary a) => B.Binary (RTAlias x a)--mapRTAVars :: (a -> tv) -> RTAlias a ty -> RTAlias tv ty-mapRTAVars f rt = rt { rtTArgs = f <$> rtTArgs rt-                     -- , rtVArgs = f <$> rtVArgs rt-                     }--lmapEAlias :: LMap -> RTAlias Symbol Expr-lmapEAlias (LMap v ys e) = RTA (F.val v) [] ys e (F.loc v) (F.loc v)-------------------------------------------------------------------------------------- | Constructor and Destructors for RTypes ----------------------------------------------------------------------------------------------------------------------data RTypeRep c tv r = RTypeRep-  { ty_vars   :: [RTVar tv (RType c tv ())]-  , ty_preds  :: [PVar (RType c tv ())]-  , ty_labels :: [Symbol]-  , ty_binds  :: [Symbol]-  , ty_refts  :: [r]-  , ty_args   :: [RType c tv r]-  , ty_res    :: (RType c tv r)-  }--fromRTypeRep :: RTypeRep c tv r -> RType c tv r-fromRTypeRep (RTypeRep {..})-  = mkArrow ty_vars ty_preds ty_labels arrs ty_res-  where-    arrs = safeZip3WithError ("fromRTypeRep: " ++ show (length ty_binds, length ty_args, length ty_refts)) ty_binds ty_args ty_refts--toRTypeRep           :: RType c tv r -> RTypeRep c tv r-toRTypeRep t         = RTypeRep αs πs ls xs rs ts t''-  where-    (αs, πs, ls, t')  = bkUniv  t-    (xs, ts, rs, t'') = bkArrow t'--mkArrow :: [RTVar tv (RType c tv ())]-        -> [PVar (RType c tv ())]-        -> [Symbol]-        -> [(Symbol, RType c tv r, r)]-        -> RType c tv r-        -> RType c tv r-mkArrow αs πs ls xts = mkUnivs αs πs ls . mkArrs xts-  where-    mkArrs xts t  = foldr (\(b,t1,r) t2 -> RFun b t1 t2 r) t xts--bkArrowDeep :: RType t t1 a -> ([Symbol], [RType t t1 a], [a], RType t t1 a)-bkArrowDeep (RAllT _ t)     = bkArrowDeep t-bkArrowDeep (RAllP _ t)     = bkArrowDeep t-bkArrowDeep (RAllS _ t)     = bkArrowDeep t-bkArrowDeep (RFun x t t' r) = let (xs, ts, rs, t'') = bkArrowDeep t'  in (x:xs, t:ts, r:rs, t'')-bkArrowDeep t               = ([], [], [], t)--bkArrow :: RType t t1 a -> ([Symbol], [RType t t1 a], [a], RType t t1 a)-bkArrow (RFun x t t' r) = let (xs, ts, rs, t'') = bkArrow t'  in (x:xs, t:ts, r:rs, t'')-bkArrow t               = ([], [], [], t)--safeBkArrow :: RType t t1 a -> ([Symbol], [RType t t1 a], [a], RType t t1 a)-safeBkArrow (RAllT _ _) = panic Nothing "safeBkArrow on RAllT"-safeBkArrow (RAllP _ _) = panic Nothing "safeBkArrow on RAllP"-safeBkArrow (RAllS _ t) = safeBkArrow t-safeBkArrow t           = bkArrow t--mkUnivs :: (Foldable t, Foldable t1, Foldable t2)-        => t  (RTVar tv (RType c tv ()))-        -> 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--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)--bkClass :: TyConable c-        => RType c tv r -> ([(c, [RType c tv r])], RType c tv r)-bkClass (RFun _ (RApp c t _ _) t' _)-  | isClass c-  = let (cs, t'') = bkClass t' in ((c, t):cs, t'')-bkClass (RRTy e r o t)-  = let (cs, t') = bkClass t in (cs, RRTy e r o t')-bkClass t-  = ([], t)--rFun :: Monoid r => Symbol -> RType c tv r -> RType c tv r -> RType c tv r-rFun b t t' = RFun b t t' mempty--rCls :: Monoid r => TyCon -> [RType RTyCon tv r] -> RType RTyCon tv r-rCls c ts   = RApp (RTyCon c [] defaultTyConInfo) ts [] mempty--rRCls :: Monoid r => c -> [RType c tv r] -> RType c tv r-rRCls rc ts = RApp rc ts [] mempty--addInvCond :: SpecType -> RReft -> SpecType-addInvCond t r'-  | F.isTauto $ ur_reft r' -- null rv-  = t-  | otherwise-  = fromRTypeRep $ trep {ty_res = RRTy [(x', tbd)] r OInv tbd}-  where-    trep = toRTypeRep t-    tbd  = ty_res trep-    r    = r' {ur_reft = F.Reft (v, rx)}-    su   = (v, F.EVar x')-    x'   = "xInv"-    rx   = F.PIff (F.EVar v) $ F.subst1 rv su-    F.Reft(v, rv) = ur_reft r'-----------------------------------------------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---instance UReftable (UReft F.Reft) where-   ofUReft r = r--instance UReftable () where-   ofUReft _ = mempty--instance (F.PPrint r, F.Reftable r) => F.Reftable (UReft r) where-  isTauto                 = 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--instance F.Expression (UReft ()) where-  expr = F.expr . F.toReft----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)--ppTy_ureft :: F.Reftable r => UReft r -> Doc -> Doc-ppTy_ureft u@(MkUReft r p s) d-  | isTauto_ureft  u  = d-  | otherwise         = ppr_reft r (F.ppTy p d) s--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')-  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)--instance (F.Reftable r, TyConable c) => F.Subable (RTProp c tv r) where-  syms (RProp  ss r)     = (fst <$> ss) ++ F.syms r--  subst su (RProp ss (RHole r)) = RProp ss (RHole (F.subst su r))-  subst su (RProp  ss t) = RProp ss (F.subst su <$> t)--  substf f (RProp ss (RHole r)) = RProp ss (RHole (F.substf f r))-  substf f (RProp  ss t) = RProp ss (F.substf f <$> t)--  substa f (RProp ss (RHole r)) = RProp ss (RHole (F.substa f r))-  substa f (RProp  ss t) = RProp ss (F.substa f <$> t)---instance (F.Subable r, F.Reftable r, TyConable c) => F.Subable (RType c tv r) where-  syms        = foldReft (\_ r acc -> F.syms r ++ acc) []-  substa f    = emapExprArg (\_ -> F.substa f) []      . mapReft  (F.substa f)-  substf f    = emapExprArg (\_ -> F.substf f) []      . emapReft (F.substf . F.substfExcept f) []-  subst su    = emapExprArg (\_ -> F.subst su) []      . emapReft (F.subst  . F.substExcept su) []-  subst1 t su = emapExprArg (\_ e -> F.subst1 e su) [] $ emapReft (\xs r -> F.subst1Except xs r su) [] t---instance F.Reftable Predicate where-  isTauto (Pr ps)      = null ps--  bot (Pr _)           = panic Nothing "No BOT instance for Predicate"-  -- NV: This does not print abstract refinements....-  -- HACK: Hiding to not render types in WEB DEMO. NEED TO FIX.-  ppTy r d | F.isTauto r      = d-           | not (ppPs ppEnv) = d-           | otherwise        = d <> (angleBrackets $ F.pprint r)--  toReft (Pr ps@(p:_))        = F.Reft (parg p, F.pAnd $ pToRef <$> ps)-  toReft _                    = mempty-  params                      = todo Nothing "TODO: instance of params for Predicate"--  ofReft = todo Nothing "TODO: Predicate.ofReft"--pToRef :: PVar a -> F.Expr-pToRef p = pApp (pname p) $ (F.EVar $ parg p) : (thd3 <$> pargs p)--pApp      :: Symbol -> [Expr] -> Expr-pApp p es = F.mkEApp fn (F.EVar p:es)-  where-    fn    = F.dummyLoc (pappSym n)-    n     = length es--pappSym :: Show a => a -> Symbol-pappSym n  = F.symbol $ "papp" ++ show n------------------------------------------------------------------------------------- | Visitors ----------------------------------------------------------------------------------------------------------------------------------------------------mapExprReft :: (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 e)) p s--isTrivial :: (F.Reftable r, TyConable c) => RType c tv r -> Bool-isTrivial t = foldReft (\_ r b -> F.isTauto r && b) True t--mapReft ::  (r1 -> r2) -> RType c tv r1 -> RType c tv r2-mapReft f = emapReft (\_ -> 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 γ (RAllP π t)         = RAllP π (emapReft f γ t)-emapReft f γ (RAllS p t)         = RAllS p (emapReft f γ t)-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)-emapReft f γ (RAllE z t t')      = RAllE z (emapReft f γ t) (emapReft f γ t')-emapReft f γ (REx z t t')        = REx   z (emapReft f γ t) (emapReft f γ t')-emapReft _ _ (RExprArg e)        = RExprArg e-emapReft f γ (RAppTy t t' r)     = RAppTy (emapReft f γ t) (emapReft f γ t') (f γ r)-emapReft f γ (RRTy e r o t)      = RRTy  (mapSnd (emapReft f γ) <$> e) (f γ r) o (emapReft f γ t)-emapReft f γ (RHole r)           = RHole (f γ r)--emapRef :: ([Symbol] -> t -> s) ->  [Symbol] -> RTProp c tv t -> RTProp c tv s-emapRef  f γ (RProp s (RHole r))  = RProp s $ RHole (f γ r)-emapRef  f γ (RProp s t)         = RProp s $ emapReft f γ t--emapExprArg :: ([Symbol] -> Expr -> Expr) -> [Symbol] -> RType c tv r -> RType c tv r-emapExprArg f = go-  where-    go _ t@(RVar {})        = t-    go _ t@(RHole {})       = t-    go γ (RAllT α t)        = RAllT α (go γ t)-    go γ (RAllP π t)        = RAllP π (go γ t)-    go γ (RAllS p t)        = RAllS p (go γ t)-    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-    go γ (RAllE z t t')     = RAllE z (go γ t) (go γ t')-    go γ (REx z t t')       = REx   z (go γ t) (go γ t')-    go γ (RExprArg e)       = RExprArg (f γ <$> F.notracepp "RExprArg" e)-    go γ (RAppTy t t' r)    = RAppTy (go γ t) (go γ t') r-    go γ (RRTy e r o t)     = RRTy  (mapSnd (go γ) <$> e) r o (go γ t)-    mo _ t@(RProp _ (RHole {})) = t-    mo γ (RProp s t)            = RProp s (go γ t)---foldRType :: (acc -> RType c tv r -> acc) -> acc -> RType c tv r -> acc-foldRType f = go-  where-    step a t                = go (f a t) t-    prep a (RProp _ (RHole {})) = a-    prep a (RProp _ t)      = step a t-    go a (RVar {})          = a-    go a (RHole {})         = a-    go a (RExprArg {})      = a-    go a (RAllT _ t)        = step a t-    go a (RAllP _ t)        = step a t-    go a (RAllS _ t)        = step a t-    go a (RFun _ t t' _)    = foldl' step a [t, t']-    go a (RAllE _ t t')     = foldl' step a [t, t']-    go a (REx _ t t')       = foldl' step a [t, t']-    go a (RAppTy t t' _)    = foldl' step a [t, t']-    go a (RApp _ ts rs _)   = foldl' prep (foldl' step a ts) rs-    go a (RRTy e _ _ t)     = foldl' step a (t : (snd <$> e))----------------------------------------------------------------------------------------------------------- isBase' x t = traceShow ("isBase: " ++ showpp x) $ isBase t--- same as GhcMisc isBaseType---- isBase :: RType a -> Bool---- set all types to basic types, haskell `tx -> t` is translated to Arrow tx t--- isBase _ = True--isBase :: RType t t1 t2 -> Bool-isBase (RAllT _ t)      = isBase t-isBase (RAllP _ t)      = isBase t-isBase (RVar _ _)       = True-isBase (RApp _ ts _ _)  = all isBase ts-isBase (RFun _ _ _ _)   = False-isBase (RAppTy t1 t2 _) = isBase t1 && isBase t2-isBase (RRTy _ _ _ t)   = isBase t-isBase (RAllE _ _ t)    = isBase t-isBase (REx _ _ t)      = isBase t-isBase _                = False--isFunTy :: RType t t1 t2 -> Bool-isFunTy (RAllE _ _ t)    = isFunTy t-isFunTy (RAllS _ t)      = isFunTy t-isFunTy (RAllT _ t)      = isFunTy t-isFunTy (RAllP _ t)      = isFunTy t-isFunTy (RFun _ _ _ _)   = True-isFunTy _                = False---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 (RAllP π t)        = liftM   (RAllP π)   (mapReftM f t)-mapReftM f (RAllS s t)        = liftM   (RAllS s)   (mapReftM f t)-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')-mapReftM f (REx z t t')       = liftM2  (REx z)     (mapReftM f t)          (mapReftM f t')-mapReftM _ (RExprArg e)       = return  $ RExprArg e-mapReftM f (RAppTy t t' r)    = liftM3  RAppTy (mapReftM f t) (mapReftM f t') (f r)-mapReftM f (RHole r)          = liftM   RHole       (f r)-mapReftM f (RRTy xts r o t)   = liftM4  RRTy (mapM (mapSndM (mapReftM f)) xts) (f r) (return o) (mapReftM f t)--mapRefM  :: (Monad m) => (t -> m s) -> (RTProp c tv t) -> m (RTProp c tv s)-mapRefM  f (RProp s t)         = liftM   (RProp s)      (mapReftM f t)--mapPropM :: (Monad m) => (RTProp c tv r -> m (RTProp c tv r)) -> RType c tv r -> m (RType c tv r)-mapPropM _ (RVar α r)         = return $ RVar  α r-mapPropM f (RAllT α t)        = liftM   (RAllT α)   (mapPropM f t)-mapPropM f (RAllP π t)        = liftM   (RAllP π)   (mapPropM f t)-mapPropM f (RAllS s t)        = liftM   (RAllS s)   (mapPropM f t)-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')-mapPropM f (REx z t t')       = liftM2  (REx z)     (mapPropM f t)          (mapPropM f t')-mapPropM _ (RExprArg e)       = return  $ RExprArg e-mapPropM f (RAppTy t t' r)    = liftM3  RAppTy (mapPropM f t) (mapPropM f t') (return r)-mapPropM _ (RHole r)          = return $ RHole r-mapPropM f (RRTy xts r o t)   = liftM4  RRTy (mapM (mapSndM (mapPropM f)) xts) (return r) (return o) (mapPropM f t)-------------------------------------------------------------------------------------- foldReft :: (F.Reftable r, TyConable c) => (r -> a -> a) -> a -> RType c tv r -> a------------------------------------------------------------------------------------ foldReft f = efoldReft (\_ _ -> []) (\_ -> ()) (\_ _ -> f) (\_ γ -> γ) emptyF.SEnv-----------------------------------------------------------------------------------foldReft :: (F.Reftable r, TyConable c) => (F.SEnv (RType c tv r) -> r -> a -> a) -> a -> RType c tv r -> a----------------------------------------------------------------------------------foldReft  f = foldReft' (\_ _ -> False) id (\γ _ -> f γ)-----------------------------------------------------------------------------------foldReft' :: (F.Reftable r, TyConable c)-          => (Symbol -> RType c tv r -> Bool)-          -> (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------ 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)-          -> (c  -> [RType c tv r] -> [(Symbol, a)])-          -> (RTVar tv (RType c tv ()) -> [(Symbol, a)])-          -> (RType c tv r -> a)-          -> (F.SEnv a -> Maybe (RType c tv r) -> r -> b -> b)-          -> (PVar (RType c tv ()) -> F.SEnv a -> F.SEnv a)-          -> F.SEnv a-          -> b-          -> RType c tv r-          -> b-efoldReft logicBind 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 (RAllP p t)                  = go (fp p γ) z t-    go γ z (RAllS _ t)                  = go γ z t-    go γ z me@(RFun _ (RApp c ts _ _) t' r)-       | isClass c                      = f γ (Just me) r (go (insertsSEnv γ (cb c ts)) (go' γ z ts) t')-    go γ z me@(RFun x t t' r)-       | logicBind x t                  = f γ (Just me) r (go γ' (go γ z t) t')-       | otherwise                      = f γ (Just me) r (go γ  (go γ z t) t')-       where-         γ'                             = insertSEnv x (g t) γ-    go γ z me@(RApp _ ts rs r)          = f γ (Just me) r (ho' γ (go' (insertSEnv (rTypeValueVar me) (g me) γ) z ts) rs)--    go γ z (RAllE x t t')               = go (insertSEnv x (g t) γ) (go γ z t) t'-    go γ z (REx x t t')                 = go (insertSEnv x (g t) γ) (go γ z t) t'-    go γ z me@(RRTy [] r _ t)          = f γ (Just me) r (go γ z t)-    go γ z me@(RRTy xts r _ t)          = f γ (Just me) r (go γ (go γ z (envtoType xts)) t)-    go γ z me@(RAppTy t t' r)           = f γ (Just me) r (go γ (go γ z t) t')-    go _ z (RExprArg _)                 = z-    go γ z me@(RHole r)                 = f γ (Just me) r z--    -- folding over Ref-    ho  γ z (RProp ss (RHole r))       = f (insertsSEnv γ (mapSnd (g . ofRSort) <$> ss)) Nothing r z-    ho  γ z (RProp ss t)               = go (insertsSEnv γ ((mapSnd (g . ofRSort)) <$> ss)) z t--    -- folding over [RType]-    go' γ z ts                 = foldr (flip $ go γ) z ts--    -- folding over [Ref]-    ho' γ z rs                 = foldr (flip $ ho γ) z rs--    envtoType xts = foldr (\(x,t1) t2 -> rFun x t1 t2) (snd $ last xts) (init xts)--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 (RAllP π t)       = RAllP π (mapBot f t)-mapBot f (RAllS s t)       = RAllS s (mapBot f t)-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-mapBot f (RApp c ts rs r)  = f $ RApp c (mapBot f <$> ts) (mapBotRef f <$> rs) r-mapBot f (REx b t1 t2)     = REx b  (mapBot f t1) (mapBot f t2)-mapBot f (RAllE b t1 t2)   = RAllE b  (mapBot f t1) (mapBot f t2)-mapBot f (RRTy e r o t)    = RRTy (mapSnd (mapBot f) <$> e) r o (mapBot f t)-mapBot f t'                = f t'--mapBotRef :: (RType c tv r -> RType c tv r)-          -> Ref τ (RType c tv r) -> Ref τ (RType c tv r)-mapBotRef _ (RProp s (RHole r)) = RProp s $ RHole r-mapBotRef f (RProp s t)    = RProp  s $ mapBot f t--mapBind :: (Symbol -> Symbol) -> RType c tv r -> RType c tv r-mapBind f (RAllT α t)      = RAllT α (mapBind f t)-mapBind f (RAllP π t)      = RAllP π (mapBind f t)-mapBind f (RAllS s t)      = RAllS s (mapBind f t)-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-mapBind f (RAllE b t1 t2)  = RAllE  (f b) (mapBind f t1) (mapBind f t2)-mapBind f (REx b t1 t2)    = REx    (f b) (mapBind f t1) (mapBind f t2)-mapBind _ (RVar α r)       = RVar α r-mapBind _ (RHole r)        = RHole r-mapBind f (RRTy e r o t)   = RRTy e r o (mapBind f t)-mapBind _ (RExprArg e)     = RExprArg e-mapBind f (RAppTy t t' r)  = RAppTy (mapBind f t) (mapBind f t') r--mapBindRef :: (Symbol -> Symbol)-           -> Ref τ (RType c tv r) -> Ref τ (RType c tv r)-mapBindRef f (RProp s (RHole r)) = RProp (mapFst f <$> s) (RHole r)-mapBindRef f (RProp s t)         = RProp (mapFst f <$> s) $ mapBind f t------------------------------------------------------ofRSort ::  F.Reftable r => RType c tv () -> RType c tv r-ofRSort = fmap mempty--toRSort :: RType c tv r -> RType c tv ()-toRSort = stripAnnotations . mapBind (const F.dummySymbol) . fmap (const ())--stripAnnotations :: RType c tv r -> RType c tv r-stripAnnotations (RAllT α t)      = RAllT α (stripAnnotations t)-stripAnnotations (RAllP _ t)      = stripAnnotations t-stripAnnotations (RAllS _ t)      = stripAnnotations t-stripAnnotations (RAllE _ _ t)    = stripAnnotations t-stripAnnotations (REx _ _ t)      = stripAnnotations t-stripAnnotations (RFun x t t' r)  = RFun x (stripAnnotations t) (stripAnnotations t') r-stripAnnotations (RAppTy t t' r)  = RAppTy (stripAnnotations t) (stripAnnotations t') r-stripAnnotations (RApp c ts rs r) = RApp c (stripAnnotations <$> ts) (stripAnnotationsRef <$> rs) r-stripAnnotations (RRTy _ _ _ t)   = stripAnnotations t-stripAnnotations t                = t--stripAnnotationsRef :: Ref τ (RType c tv r) -> Ref τ (RType c tv r)-stripAnnotationsRef (RProp s (RHole r)) = RProp s (RHole r)-stripAnnotationsRef (RProp s t)         = RProp s $ stripAnnotations t--insertSEnv :: F.Symbol -> a -> F.SEnv a -> F.SEnv a-insertSEnv = F.insertSEnv--insertsSEnv :: F.SEnv a -> [(Symbol, a)] -> F.SEnv a-insertsSEnv  = foldr (\(x, t) γ -> insertSEnv x t γ)--rTypeValueVar :: (F.Reftable r) => RType c tv r -> Symbol-rTypeValueVar t = vv where F.Reft (vv,_) =  rTypeReft t--rTypeReft :: (F.Reftable r) => RType c tv r -> F.Reft-rTypeReft = fromMaybe F.trueReft . fmap F.toReft . stripRTypeBase---- stripRTypeBase ::  RType a -> Maybe a-stripRTypeBase :: RType c tv r -> Maybe r-stripRTypeBase (RApp _ _ _ x)-  = Just x-stripRTypeBase (RVar _ x)-  = Just x-stripRTypeBase (RFun _ _ _ x)-  = Just x-stripRTypeBase (RAppTy _ _ x)-  = Just x-stripRTypeBase _-  = Nothing--topRTypeBase :: (F.Reftable r) => RType c tv r -> RType c tv r-topRTypeBase = mapRBase F.top--mapRBase :: (r -> r) -> RType c tv r -> RType c tv r-mapRBase f (RApp c ts rs r) = RApp c ts rs $ f r-mapRBase f (RVar a r)       = RVar a $ f r-mapRBase f (RFun x t1 t2 r) = RFun x t1 t2 $ f r-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--ppr_pvar :: PVar a -> Doc-ppr_pvar (PV s _ _ xts) = F.pprint s <+> hsep (F.pprint <$> dargs xts)-  where-    dargs               = map thd3 . takeWhile (\(_, x, y) -> F.EVar x /= y)---instance F.PPrint Predicate where-  pprintTidy _ (Pr [])  = text "True"-  pprintTidy k (Pr pvs) = hsep $ punctuate (text "&") (F.pprintTidy k <$> pvs)----- | The type used during constraint generation, used---   also to define contexts for errors, hence in this---   file, and NOT in elsewhere. **DO NOT ATTEMPT TO MOVE**---   Am splitting into---   + global : many bindings, shared across all constraints---   + local  : few bindings, relevant to particular constraints--data REnv = REnv-  { reGlobal :: M.HashMap Symbol SpecType -- ^ the "global" names for module-  , reLocal  :: M.HashMap Symbol SpecType -- ^ the "local" names for sub-exprs-  }--instance NFData REnv where-  rnf (REnv {}) = ()------------------------------------------------------------------------------------- | Error Data Type ----------------------------------------------------------------------------------------------------------------------------------------------type ErrorResult    = F.FixResult UserError-type Error          = TError SpecType---instance NFData a => NFData (TError a)------------------------------------------------------------------------------------- | Source Information Associated With Constraints ---------------------------------------------------------------------------------------------------------------data Cinfo    = Ci { ci_loc :: !SrcSpan-                   , ci_err :: !(Maybe Error)-                   , ci_var :: !(Maybe Var)-                   }-                deriving (Eq, Ord, Generic)--instance F.Loc Cinfo where-  srcSpan = srcSpanFSrcSpan . ci_loc--instance NFData Cinfo------------------------------------------------------------------------------------- | Module Names -------------------------------------------------------------------------------------------------------------------------------------------------data ModName = ModName !ModType !ModuleName deriving (Eq, Ord, Show)--instance F.PPrint ModName where-  pprintTidy _ = text . show--instance Show ModuleName where-  show = moduleNameString--instance F.Symbolic ModName where-  symbol (ModName _ m) = F.symbol m--instance F.Symbolic ModuleName where-  symbol = F.symbol . moduleNameFS--data ModType = Target | SrcImport | SpecImport deriving (Eq,Ord,Show)--isSrcImport :: ModName -> Bool-isSrcImport (ModName SrcImport _) = True-isSrcImport _                     = False--isSpecImport :: ModName -> Bool-isSpecImport (ModName SpecImport _) = True-isSpecImport _                      = False--getModName :: ModName -> ModuleName-getModName (ModName _ m) = m--getModString :: ModName -> String-getModString = moduleNameString . getModName--qualifyModName :: ModName -> Symbol -> Symbol-qualifyModName n = qualifySymbol nSym-  where-    nSym         = F.symbol n------------------------------------------------------------------------------------- | Refinement Type Aliases -------------------------------------------------------------------------------------------------------------------------------------data RTEnv = RTE-  { typeAliases :: M.HashMap Symbol (RTAlias RTyVar SpecType)-  , exprAliases :: M.HashMap Symbol (RTAlias Symbol Expr)-  }--instance Monoid RTEnv where-  mempty                          = RTE M.empty M.empty-  (RTE x y) `mappend` (RTE x' y') = RTE (x `M.union` x') (y `M.union` y')--mapRT :: (M.HashMap Symbol (RTAlias RTyVar SpecType)-       -> M.HashMap Symbol (RTAlias RTyVar SpecType))-       -> RTEnv -> RTEnv-mapRT f e = e { typeAliases = f $ typeAliases e }--mapRE :: (M.HashMap Symbol (RTAlias Symbol Expr)-       -> M.HashMap Symbol (RTAlias Symbol Expr))-      -> RTEnv -> RTEnv-mapRE f e = e { exprAliases = f $ exprAliases e }-------------------------------------------------------------------------------------- | Measures----------------------------------------------------------------------------------data Body-  = E Expr          -- ^ Measure Refinement: {v | v = e }-  | P Expr          -- ^ Measure Refinement: {v | (? v) <=> p }-  | R Symbol Expr   -- ^ Measure Refinement: {v | p}-  deriving (Show, Data, Typeable, Generic, Eq)--data Def ty ctor = Def-  { measure :: F.LocSymbol-  , dparams :: [(Symbol, ty)]          -- measure parameters-  , ctor    :: ctor-  , dsort   :: Maybe ty-  , binds   :: [(Symbol, Maybe ty)]    -- measure binders: the ADT argument fields-  , body    :: Body-  } deriving (Show, Data, Typeable, Generic, Eq, Functor)--data Measure ty ctor = M-  { name :: F.LocSymbol-  , sort :: ty-  , eqns :: [Def ty ctor]-  } deriving (Data, Typeable, Generic, Functor)--instance Bifunctor Def where-  first f (Def m ps c s bs b) =-    Def m (map (second f) ps) c (fmap f s) (map (second (fmap f)) bs) b-  second f (Def m ps c s bs b) =-    Def m ps (f c) s bs b--instance Bifunctor Measure where-  first f (M n s es) =-    M n (f s) (map (first f) es)-  second f (M n s es) =-    M n s (map (second f) es)--instance                             B.Binary Body-instance (B.Binary t, B.Binary c) => B.Binary (Def     t c)-instance (B.Binary t, B.Binary c) => B.Binary (Measure t c)---- NOTE: don't use the TH versions since they seem to cause issues--- building on windows :(--- deriveBifunctor ''Def--- deriveBifunctor ''Measure--data CMeasure ty = CM-  { cName :: F.LocSymbol-  , cSort :: ty-  } deriving (Data, Typeable, Generic, Functor)--instance F.PPrint Body where-  pprintTidy k (E e)   = F.pprintTidy k e-  pprintTidy k (P p)   = F.pprintTidy k p-  pprintTidy k (R v p) = braces (F.pprintTidy k v <+> "|" <+> F.pprintTidy k p)--instance F.PPrint a => F.PPrint (Def t a) where-  pprintTidy k (Def m p c _ bs body)-           = F.pprintTidy k m <+> F.pprintTidy k (fst <$> p) <+> cbsd <+> "=" <+> F.pprintTidy k body-    where-      cbsd = parens (F.pprintTidy k c <> hsep (F.pprintTidy k `fmap` (fst <$> bs)))--instance (F.PPrint t, F.PPrint a) => F.PPrint (Measure t a) where-  pprintTidy k (M n s eqs) =  F.pprintTidy k n <+> {- parens (pprintTidy k (loc n)) <+> -} "::" <+> F.pprintTidy k s-                              $$ vcat (F.pprintTidy k `fmap` eqs)---instance F.PPrint (Measure t a) => Show (Measure t a) where-  show = F.showpp--instance F.PPrint t => F.PPrint (CMeasure t) where-  pprintTidy k (CM n s) =  F.pprintTidy k n <+> "::" <+> F.pprintTidy k s--instance F.PPrint (CMeasure t) => Show (CMeasure t) where-  show = F.showpp---instance F.Subable (Measure ty ctor) where-  syms (M _ _ es)      = concatMap F.syms es-  substa f  (M n s es) = M n s $ F.substa f  <$> es-  substf f  (M n s es) = M n s $ F.substf f  <$> es-  subst  su (M n s es) = M n s $ F.subst  su <$> es--instance F.Subable (Def ty ctor) where-  syms (Def _ sp _ _ sb bd)  = (fst <$> sp) ++ (fst <$> sb) ++ F.syms bd-  substa f  (Def m p c t b bd) = Def m p c t b $ F.substa f  bd-  substf f  (Def m p c t b bd) = Def m p c t b $ F.substf f  bd-  subst  su (Def m p c t b bd) = Def m p c t b $ F.subst  su bd--instance F.Subable Body where-  syms (E e)       = F.syms e-  syms (P e)       = F.syms e-  syms (R s e)     = s : F.syms e--  substa f (E e)   = E   (F.substa f e)-  substa f (P e)   = P   (F.substa f e)-  substa f (R s e) = R s (F.substa f e)--  substf f (E e)   = E   (F.substf f e)-  substf f (P e)   = P   (F.substf f e)-  substf f (R s e) = R s (F.substf f e)--  subst su (E e)   = E   (F.subst su e)-  subst su (P e)   = P   (F.subst su e)-  subst su (R s e) = R s (F.subst su e)--instance F.Subable t => F.Subable (WithModel t) where-  syms (NoModel t)     = F.syms t-  syms (WithModel _ t) = F.syms t-  substa f             = fmap (F.substa f)-  substf f             = fmap (F.substf f)-  subst su             = fmap (F.subst su)--data RClass ty = RClass-  { rcName    :: BTyCon-  , rcSupers  :: [ty]-  , rcTyVars  :: [BTyVar]-  , rcMethods :: [(F.LocSymbol, ty)]-  } deriving (Show, Functor, Data, Typeable, Generic)----instance B.Binary ty => B.Binary (RClass ty)------------------------------------------------------------------------------ | Annotations ----------------------------------------------------------------------------------------------------------------------------------newtype AnnInfo a = AI (M.HashMap SrcSpan [(Maybe Text, a)])-                    deriving (Data, Typeable, Generic, Functor)--data Annot t-  = AnnUse t-  | AnnDef t-  | AnnRDf t-  | AnnLoc SrcSpan-  deriving (Data, Typeable, Generic, Functor)--instance Monoid (AnnInfo a) where-  mempty                  = AI M.empty-  mappend (AI m1) (AI m2) = AI $ M.unionWith (++) m1 m2--instance NFData a => NFData (AnnInfo a)--instance NFData a => NFData (Annot a)------------------------------------------------------------------------------------- | Output -------------------------------------------------------------------------------------------------------------------------------------------------------data Output a = O-  { o_vars   :: Maybe [String]-  -- , o_errors :: ![UserError]-  , o_types  :: !(AnnInfo a)-  , o_templs :: !(AnnInfo a)-  , o_bots   :: ![SrcSpan]-  , o_result :: ErrorResult-  } deriving (Typeable, Generic, Functor)--emptyOutput :: Output a-emptyOutput = O Nothing {- [] -} mempty mempty [] mempty--instance Monoid (Output a) where-  mempty        = emptyOutput-  mappend o1 o2 = O { o_vars   = sortNub <$> mappend (o_vars   o1) (o_vars   o2)-                    -- , o_errors = sortNub  $  mappend (o_errors o1) (o_errors o2)-                    , o_types  =             mappend (o_types  o1) (o_types  o2)-                    , o_templs =             mappend (o_templs o1) (o_templs o2)-                    , o_bots   = sortNub  $  mappend (o_bots o1)   (o_bots   o2)-                    , o_result =             mappend (o_result o1) (o_result o2)-                    }------------------------------------------------------------------------------------- | KVar Profile -------------------------------------------------------------------------------------------------------------------------------------------------data KVKind-  = RecBindE    Var -- ^ Recursive binder      @letrec x = ...@-  | NonRecBindE Var -- ^ Non recursive binder  @let x = ...@-  | TypeInstE-  | PredInstE-  | LamE-  | CaseE       Int -- ^ Int is the number of cases-  | LetE-  | ProjectE        -- ^ Projecting out field of-  deriving (Generic, Eq, Ord, Show, Data, Typeable)--instance Hashable KVKind--newtype KVProf = KVP (M.HashMap KVKind Int) deriving (Generic)--emptyKVProf :: KVProf-emptyKVProf = KVP M.empty--updKVProf :: KVKind -> F.Kuts -> KVProf -> KVProf-updKVProf k kvs (KVP m) = KVP $ M.insert k (kn + n) m-  where-    kn                  = M.lookupDefault 0 k m-    n                   = S.size (F.ksVars kvs)--instance NFData KVKind--instance F.PPrint KVKind where-  pprintTidy _ = text . show--instance F.PPrint KVProf where-  pprintTidy k (KVP m) = F.pprintTidy k (M.toList m)--instance NFData KVProf--hole :: Expr-hole = F.PKVar "HOLE" mempty--isHole :: Expr -> Bool-isHole (F.PKVar ("HOLE") _) = True-isHole _                    = False--hasHole :: F.Reftable r => r -> Bool-hasHole = any isHole . F.conjuncts . F.reftPred . F.toReft---- classToRApp :: SpecType -> SpecType--- classToRApp (RCls cl ts)---   = RApp (RTyCon (classTyCon cl) def def) ts mempty mempty--instance F.Symbolic DataCon where-  symbol = F.symbol . dataConWorkId--instance F.PPrint DataCon where-  pprintTidy _ = text . showPpr--instance Show DataCon where-  show = F.showpp---liquidBegin :: String-liquidBegin = ['{', '-', '@']--liquidEnd :: String-liquidEnd = ['@', '-', '}']--data MSpec ty ctor = MSpec-  { ctorMap  :: M.HashMap Symbol [Def ty ctor]-  , measMap  :: M.HashMap F.LocSymbol (Measure ty ctor)-  , cmeasMap :: M.HashMap F.LocSymbol (Measure ty ())-  , imeas    :: ![Measure ty ctor]-  } deriving (Data, Typeable, Generic, Functor)--instance Bifunctor MSpec   where-  first f (MSpec c m cm im) = MSpec (fmap (fmap (first f)) c)-                                    (fmap (first f) m)-                                    (fmap (first f) cm)-                                    (fmap (first f) im)-  second                    = fmap--instance (F.PPrint t, F.PPrint a) => F.PPrint (MSpec t a) where-  pprintTidy k =  vcat . fmap (F.pprintTidy k) . fmap snd . M.toList . measMap--instance (Show ty, Show ctor, F.PPrint ctor, F.PPrint ty) => Show (MSpec ty ctor) where-  show (MSpec ct m cm im)-    = "\nMSpec:\n" ++-      "\nctorMap:\t "  ++ show ct ++-      "\nmeasMap:\t "  ++ show m  ++-      "\ncmeasMap:\t " ++ show cm ++-      "\nimeas:\t "    ++ show im ++-      "\n"--instance Eq ctor => Monoid (MSpec ty ctor) where-  mempty = MSpec M.empty M.empty M.empty []-  (MSpec c1 m1 cm1 im1) `mappend` (MSpec c2 m2 cm2 im2)-    | (k1, k2) : _ <- dups-      -- = panic Nothing $ err (head dups)-    = uError $ err k1 k2-    | otherwise-    = MSpec (M.unionWith (++) c1 c2) (m1 `M.union` m2) (cm1 `M.union` cm2) (im1 ++ im2)-    where-      dups = [(k1, k2) | k1 <- M.keys m1 , k2 <- M.keys m2, F.val k1 == F.val k2]-      err k1 k2 = ErrDupMeas (fSrcSpan k1) (F.pprint (F.val k1)) (fSrcSpan <$> [k1, k2])---------------------------------------------------------------------------------------- Nasty PP stuff-----------------------------------------------------------------------------------instance F.PPrint BTyVar where-  pprintTidy _ (BTV α) = text (F.symbolString α)--instance F.PPrint RTyVar where-  -- pprintTidy k = pprintTidy k . F.symbol --(RTV α)-  pprintTidy k (RTV α)-   | ppTyVar ppEnv  = F.pprintTidy k (F.symbol α) -- ppr_tyvar α-   | otherwise      = ppr_tyvar_short α-   where-     -- _ppr_tyvar :: Var -> Doc-     -- _ppr_tyvar       = text . tvId--     ppr_tyvar_short :: TyVar -> Doc-     ppr_tyvar_short = text . showPpr--instance (F.PPrint r, F.Reftable r, F.PPrint t, F.PPrint (RType c tv r)) => F.PPrint (Ref t (RType c tv r)) where-  pprintTidy k (RProp ss s) = ppRefArgs k (fst <$> ss) <+> F.pprintTidy k s--ppRefArgs :: F.Tidy -> [Symbol] -> Doc-ppRefArgs _ [] = empty-ppRefArgs k ss = text "\\" <> hsep (ppRefSym k <$> ss ++ [F.vv Nothing]) <+> "->"--ppRefSym :: (Eq a, IsString a, F.PPrint a) => F.Tidy -> a -> Doc-ppRefSym _ "" = text "_"-ppRefSym k s  = F.pprintTidy k s+-- | This module re-exports a bunch of the Types modules ++module Language.Haskell.Liquid.Types (module Types) where ++import Language.Haskell.Liquid.Types.Types          as Types+import Language.Haskell.Liquid.Types.Dictionaries   as Types+import Language.Haskell.Liquid.Types.Fresh          as Types+import Language.Haskell.Liquid.Types.Meet           as Types+import Language.Haskell.Liquid.Types.PredType       as Types+import Language.Haskell.Liquid.Types.RefType        as Types+import Language.Haskell.Liquid.Types.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+import Language.Haskell.Liquid.Types.Specs          as Types+import Language.Haskell.Liquid.Types.Visitors       as Types
+ src/Language/Haskell/Liquid/Types/Annotations.hs view
@@ -0,0 +1,10 @@+{-# 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
@@ -28,8 +28,8 @@ import qualified Data.HashMap.Strict as M  import qualified Language.Fixpoint.Types as F-import Language.Haskell.Liquid.Types-import Language.Fixpoint.Misc  (mapFst, mapSnd)+import qualified Language.Fixpoint.Misc  as Misc -- (mapFst, mapSnd)+import Language.Haskell.Liquid.Types.Types import Language.Haskell.Liquid.Types.RefType  @@ -45,7 +45,6 @@  type RBound        = RRBound RSort type RRBound tv    = Bound tv F.Expr- type RBEnv         = M.HashMap LocSymbol RBound type RRBEnv tv     = M.HashMap LocSymbol (RRBound tv) @@ -70,7 +69,7 @@       ppBsyms k xs = "\\" <+> pprintTidy k xs <+> "->"  instance Bifunctor Bound where-  first  f (Bound s vs ps xs e) = Bound s (f <$> vs) (mapSnd f <$> ps) (mapSnd f <$> xs) e+  first  f (Bound s vs ps xs e) = Bound s (f <$> vs) (Misc.mapSnd f <$> ps) (Misc.mapSnd f <$> xs) e   second f (Bound s vs ps xs e) = Bound s vs ps xs (f e)  makeBound :: (PPrint r, UReftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r)@@ -117,7 +116,7 @@   partitionPs :: [(F.Symbol, F.Symbol)] -> [F.Expr] -> (M.HashMap F.Symbol [UsedPVar], [F.Expr])-partitionPs penv qs = mapFst makeAR $ partition (isPApp penv) qs+partitionPs penv qs = Misc.mapFst makeAR $ partition (isPApp penv) qs   where     makeAR ps       = M.fromListWith (++) $ map (toUsedPVars penv) ps 
src/Language/Haskell/Liquid/Types/Dictionaries.hs view
@@ -1,75 +1,79 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleContexts     #-}-+{-# LANGUAGE TupleSections        #-} module Language.Haskell.Liquid.Types.Dictionaries (     makeDictionaries   , makeDictionary-   , dfromList   , dmapty   , dmap   , dinsert   , dlookup   , dhasinfo-  , mapRISig   , fromRISig   ) where  import           Data.Hashable+-- import           Data.Maybe (catMaybes)+ import           Prelude                                   hiding (error) import           Var import           Name                                      (getName) import qualified Language.Fixpoint.Types as F import           Language.Haskell.Liquid.Types.PrettyPrint ()-import           Language.Haskell.Liquid.GHC.Misc          (dropModuleNamesCorrect)-import           Language.Haskell.Liquid.Types+import qualified Language.Haskell.Liquid.GHC.Misc       as GM +import qualified Language.Haskell.Liquid.GHC.API        as Ghc +import           Language.Haskell.Liquid.Types.Types+-- import           Language.Haskell.Liquid.Types.Visitors (freeVars) import           Language.Haskell.Liquid.Types.RefType () import           Language.Fixpoint.Misc                (mapFst) import qualified Data.HashMap.Strict                       as M -makeDictionaries :: [RInstance SpecType] -> DEnv F.Symbol SpecType+++++makeDictionaries :: [RInstance LocSpecType] -> DEnv F.Symbol LocSpecType makeDictionaries = DEnv . M.fromList . map makeDictionary  -makeDictionary :: RInstance SpecType -> (F.Symbol, M.HashMap F.Symbol (RISig SpecType))+makeDictionary :: RInstance LocSpecType -> (F.Symbol, M.HashMap F.Symbol (RISig LocSpecType)) makeDictionary (RI c ts xts) = (makeDictionaryName (btc_tc c) ts, M.fromList (mapFst val <$> xts)) -makeDictionaryName :: Located F.Symbol -> [SpecType] -> F.Symbol+makeDictionaryName :: LocSymbol -> [LocSpecType] -> F.Symbol makeDictionaryName t ts-  = F.notracepp _msg $ F.symbol ("$f" ++ F.symbolString (val t) ++ concatMap makeDicTypeName ts)+  = F.notracepp _msg $ F.symbol ("$f" ++ F.symbolString (val t) ++ concatMap mkName ts)   where-    _msg = "MAKE-DICTIONARY " ++ F.showpp (val t, ts)+    mkName = makeDicTypeName sp . dropUniv . val +    sp     = GM.fSrcSpan t+    _msg   = "MAKE-DICTIONARY " ++ F.showpp (val t, ts) +-- | @makeDicTypeName@ DOES NOT use show/symbol in the @RVar@ case +--   as those functions add the unique-suffix which then breaks the +--   class resolution. -makeDicTypeName :: SpecType -> String-makeDicTypeName (RFun _ _ _ _)-  = "(->)"-makeDicTypeName (RApp c _ _ _)-  = F.symbolString $ dropModuleNamesCorrect $ F.symbol $ rtc_tc c--- makeDicTypeName (RVar a _)-  -- = show a-makeDicTypeName (RVar (RTV a) _)-  = show (getName a)      -- RJ: DO NOT use show/symbol here as they add the unique-suffix-                          -- which then breaks the class resolution.-makeDicTypeName t-  = panic Nothing ("makeDicTypeName: called with invalid type " ++ show t)+makeDicTypeName :: Ghc.SrcSpan -> SpecType -> String+makeDicTypeName _ (RFun _ _ _ _)   = "(->)"+makeDicTypeName _ (RApp c _ _ _)   = F.symbolString . GM.dropModuleNamesCorrect . F.symbol . rtc_tc $ c+makeDicTypeName _ (RVar (RTV a) _) = show (getName a)      +makeDicTypeName sp t               = panic (Just sp) ("makeDicTypeName: called with invalid type " ++ show t) +dropUniv :: SpecType -> SpecType +dropUniv t = t' where (_,_,_,t') = bkUniv t   -------------------------------------------------------------------------------- -- | Dictionary Environment ---------------------------------------------------- -------------------------------------------------------------------------------- - dfromList :: [(Var, M.HashMap F.Symbol (RISig t))] -> DEnv Var t dfromList = DEnv . M.fromList  dmapty :: (a -> b) -> DEnv v a -> DEnv v b-dmapty f (DEnv e) = DEnv (M.map (M.map (mapRISig f)) e)--mapRISig :: (a -> b) -> RISig a -> RISig b-mapRISig f (RIAssumed t) = RIAssumed (f t)-mapRISig f (RISig     t) = RISig     (f t)+dmapty f (DEnv e) = DEnv (M.map (M.map (fmap f)) e) +-- REBARE: mapRISig :: (a -> b) -> RISig a -> RISig b+-- REBARE: mapRISig f (RIAssumed t) = RIAssumed (f t)+-- REBARE: mapRISig f (RISig     t) = RISig     (f t)  fromRISig :: RISig a -> a fromRISig (RIAssumed t) = t@@ -91,4 +95,4 @@ dhasinfo Nothing _    = Nothing dhasinfo (Just xts) x = M.lookup x' xts   where-     x' = (dropModuleNamesCorrect $ F.symbol x)+     x'               = GM.dropModuleNamesCorrect (F.symbol x)
+ src/Language/Haskell/Liquid/Types/Equality.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances    #-}++-- Syntactic Equality of Types up tp forall type renaming++module Language.Haskell.Liquid.Types.Equality where ++import qualified Language.Fixpoint.Types as F+import           Language.Haskell.Liquid.Types+import qualified Language.Haskell.Liquid.GHC.API as Ghc++import Control.Monad.Writer.Lazy+-- import Control.Monad+import qualified Data.List as L++instance REq SpecType where +  t1 =*= t2 = compareRType t1 t2 +  +compareRType :: SpecType -> SpecType -> Bool +compareRType i1 i2 = res && unify vs   +  where +    unify vs = and (sndEq <$> (L.groupBy (\(x1,_) (x2,_) -> x1 == x2) vs)) +    sndEq [] = True +    sndEq [_] = True +    sndEq ((_,y):xs) = all (==y) (snd <$> xs)++    (res, vs) = runWriter (go i1 i2)+    go :: SpecType -> SpecType -> Writer [(RTyVar, RTyVar)] Bool  +    go (RAllT x1 t1) (RAllT x2 t2)+      | RTV v1 <- ty_var_value x1+      , RTV v2 <- ty_var_value x2 +      = go t1 (subt (v2, Ghc.mkTyVarTy v1) t2) ++    go (RVar v1 r1) (RVar v2 r2) +      = do tell [(v1, v2)]+           return (r1 =*= r2) +     -- = v1 == v2 && r1 =*= r2 +    go (RFun x1 t11 t12 r1) (RFun x2 t21 t22 r2)+      | x1 == x2 && r1 =*= r2+      = liftM2 (&&) (go t11 t21) (go t12 t22)+    go (RImpF x1 t11 t12 r1) (RImpF x2 t21 t22 r2)+      | x1 == x2    && r1 =*= r2+      = liftM2 (&&) (go t11 t21) (go t12 t22)    +    go (RAllP x1 t1) (RAllP x2 t2)+      | x1 == x2 +      = go t1 t2 +    go (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) +      = and <$> (zipWithM go ts1 ts2)+    go (RAllE x1 t11 t12) (RAllE x2 t21 t22) | x1 == x2 +      = liftM2 (&&) (go t11 t21) (go t12 t22) +    go (REx x1 t11 t12) (REx x2 t21 t22) | x1 == x2+      = liftM2 (&&) (go t11 t21) (go t12 t22)+    go (RExprArg e1) (RExprArg e2)+      = return (e1 =*= e2) +    go (RAppTy t11 t12 r1) (RAppTy t21 t22 r2) | r1 =*= r2 +      = liftM2 (&&) (go t11 t21) (go t12 t22)  +    go (RRTy _ _ _ r1) (RRTy _ _ _ r2) +      = return (r1 =*= r2)+    go (RHole r1) (RHole r2)+      = return (r1 =*= r2)  +    go _t1 _t2 +      = return False ++class REq a where +  (=*=) :: a -> a -> Bool ++instance REq t2 => REq (Ref t1 t2) where+    (RProp _ t1) =*= (RProp _ t2) = t1 =*= t2 ++instance REq (UReft F.Reft) where+  (MkUReft r1 p1 _) =*= (MkUReft r2 p2 _)+     = r1 =*= r2 && p1 == p2+  +instance REq F.Reft where +  F.Reft (v1, e1) =*= F.Reft (v2, e2) = F.subst1 e1 (v1, F.EVar v2) =*= e2 ++instance REq F.Expr where +  e1 =*= e2 = go (F.simplify e1) (F.simplify e2)+    where go r1 r2 = F.notracepp ("comparing " ++ showpp (F.toFix r1, F.toFix r2)) $ r1 == r2 ++instance REq r => REq (Located r) where +  t1 =*= t2 = val t1 =*= val t2         +  
src/Language/Haskell/Liquid/Types/Errors.hs view
@@ -17,7 +17,7 @@    -- * Error with Source Context   , CtxError (..)-  , errorWithContext+  , errorsWithContext    -- * Subtyping Obligation Type   , Oblig (..)@@ -38,41 +38,41 @@   -- * Printing Errors   , ppError   , ppError'-  , ppVar+  , ppTicks      -- * SrcSpan Helpers   , realSrcSpan   , unpackRealSrcSpan+  , srcSpanFileMb   ) where  import           Prelude                      hiding (error)-import           SrcLoc                      -- (SrcSpan (..), noSrcSpan)+import           SrcLoc                       import           FastString- import           HscTypes (srcErrorMessages, SourceError) import           ErrUtils import           Bag  import           GHC.Generics import           Control.DeepSeq+import qualified Control.Exception            as Ex import           Data.Typeable                (Typeable) import           Data.Generics                (Data)-import qualified Data.Binary as B-import           Data.Maybe-import           Text.PrettyPrint.HughesPJ-import           Data.Aeson hiding (Result)-import qualified Data.HashMap.Strict as M-import           Language.Fixpoint.Types      (pprint, showpp, Tidy (..), PPrint (..), Symbol, Expr)-import qualified Language.Fixpoint.Misc     as Misc-import           Language.Haskell.Liquid.Misc (intToString)-import           Text.Parsec.Error            (ParseError)-import qualified Control.Exception as Ex+import qualified Data.Binary                  as B+import qualified Data.Maybe                   as Mb+import           Data.Aeson                   hiding (Result)+import qualified Data.HashMap.Strict          as M+import qualified Data.List                    as L  import           System.Directory import           System.FilePath-import Data.List    (intersperse )-import           Text.Parsec.Error (errorMessages, showErrorMessages)-+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           Language.Haskell.Liquid.Misc ((<->))  instance PPrint ParseError where   pprintTidy _ e = vcat $ tail $ text <$> ls@@ -96,42 +96,53 @@   e1 <= e2 = ctErr e1 <= ctErr e2  ---------------------------------------------------------------------------------errorWithContext :: TError Doc -> IO (CtxError Doc)+errorsWithContext :: [TError Doc] -> IO [CtxError Doc] ---------------------------------------------------------------------------------errorWithContext e = CtxError e <$> srcSpanContext (pos e)+errorsWithContext es +  = Misc.concatMapM fileErrors +  $ Misc.groupList [ (srcSpanFileMb (pos e), e) | e <- es ] -srcSpanContext :: SrcSpan -> IO Doc-srcSpanContext sp-  | Just (f, l, c, l', c') <- srcSpanInfo sp-  = makeContext l c c' <$> getFileLines f l l'+fileErrors :: (Maybe FilePath, [TError Doc]) -> IO [CtxError Doc]+fileErrors (fp, errs) = do +  fb  <- getFileBody fp +  return (errorWithContext fb <$> errs) ++errorWithContext :: FileBody -> TError Doc -> CtxError Doc+errorWithContext fb e = CtxError e (srcSpanContext fb (pos e))++srcSpanContext :: FileBody -> SrcSpan -> Doc+srcSpanContext fb sp+  | Just (l, c, l', c') <- srcSpanInfo sp+  = makeContext l c c' (getFileLines fb l l')   | otherwise-  = return empty+  = empty -srcSpanInfo :: SrcSpan -> Maybe (FilePath, Int, Int, Int, Int)-srcSpanInfo (RealSrcSpan s) = Just (f, l, c, l', c')+srcSpanInfo :: SrcSpan -> Maybe (Int, Int, Int, Int)+srcSpanInfo (RealSrcSpan s) +              = Just (l, c, l', c')   where-     f        = unpackFS $ srcSpanFile s      l        = srcSpanStartLine s      c        = srcSpanStartCol  s      l'       = srcSpanEndLine   s      c'       = srcSpanEndCol    s srcSpanInfo _ = Nothing -getFileLines :: FilePath -> Int -> Int -> IO [String]-getFileLines f i j = do-  b <- doesFileExist f-  if b-    then slice (i - 1) (j - 1) . lines <$> readFile f-    else return []+getFileLines :: FileBody -> Int -> Int -> [String]+getFileLines fb i j = slice (i - 1) (j - 1) fb  +getFileBody :: Maybe FilePath -> IO FileBody+getFileBody Nothing  = +  return []+getFileBody (Just f) = do +  b <- doesFileExist f +  if b then lines <$> Misc.sayReadFile f +       else return []++type FileBody = [String]+ slice :: Int -> Int -> [a] -> [a] slice i j xs = take (j - i + 1) (drop i xs) --- getNth :: Int -> [a] -> Maybe a--- getNth i xs--- /  | i < length xs = Just (xs !! i)--- /  | otherwise     = Nothing- makeContext :: Int -> Int -> Int -> [String] -> Doc makeContext _ _ _  []  = empty makeContext l c c' [s] = makeContext1 l c c' s@@ -153,7 +164,7 @@                              ]   where     lnum n            = text (show n) <+> text "|"-    cursor            = blanks (c - 1) <> pointer (max 1 (c' - c))+    cursor            = blanks (c - 1) <-> pointer (max 1 (c' - c))     blanks n          = text $ replicate n ' '     pointer n         = text $ replicate n '^' @@ -212,6 +223,13 @@                , texp :: !t                } -- ^ liquid type error +  | ErrHole    { pos :: !SrcSpan+               , msg :: !Doc+               , ctx :: !(M.HashMap Symbol t)+               , var :: !Doc +               , thl :: !t +               } -- ^ hole type +   | ErrAssType { pos  :: !SrcSpan                , obl  :: !Oblig                , msg  :: !Doc@@ -225,6 +243,7 @@                 } -- ^ specification parse error    | ErrTySpec   { pos :: !SrcSpan+                , knd :: !(Maybe Doc)                 , var :: !Doc                 , typ :: !t                 , msg :: !Doc@@ -234,6 +253,7 @@                 , var  :: !Doc                 , msg  :: !Doc                 , exp  :: !Expr+                , typ  :: !t                 , msg' :: !Doc                 } -- ^ sort error in specification @@ -274,6 +294,11 @@                 , msg :: !Doc                 } -- ^ bad data type specification (?) +  | ErrBadGADT  { pos :: !SrcSpan+                , var :: !Doc+                , msg :: !Doc+                } -- ^ bad data type specification (?)+   | ErrDataCon  { pos :: !SrcSpan                 , var :: !Doc                 , msg :: !Doc@@ -317,11 +342,18 @@                 , msg :: !Doc                 } -- ^ GHC error: parsing or type checking +  | ErrResolve  { pos  :: !SrcSpan+                , kind :: !Doc+                , var  :: !Doc+                , msg  :: !Doc+                } -- ^ Name resolution error +   | ErrMismatch { pos   :: !SrcSpan -- ^ haskell type location                 , var   :: !Doc                 , msg   :: !Doc                 , hs    :: !Doc                 , lqTy  :: !Doc+                , diff  :: !(Maybe (Doc, Doc))  -- ^ specific pair of things that mismatch                 , lqPos :: !SrcSpan -- ^ lq type location                 } -- ^ Mismatch between Liquid and Haskell types @@ -353,11 +385,26 @@                 , msg  :: !Doc                 } -- ^ Termination Error +  | ErrStTerm   { pos  :: !SrcSpan+                , dname :: !Doc+                , msg  :: !Doc+                } -- ^ Termination Error++  | ErrILaw     { pos   :: !SrcSpan+                , cname :: !Doc+                , iname :: !Doc+                , msg   :: !Doc+                } -- ^ Instance Law Error+   | ErrRClass   { pos   :: !SrcSpan                 , cls   :: !Doc                 , insts :: ![(SrcSpan, Doc)]                 } -- ^ Refined Class/Interfaces Conflict +  | ErrMClass   { pos   :: !SrcSpan+                , var   :: !Doc+                } -- ^ Standalone class method refinements+   | ErrBadQual  { pos   :: !SrcSpan                 , qname :: !Doc                 , msg   :: !Doc@@ -384,10 +431,15 @@                 , msg :: !Doc                 } +  | ErrNoSpec   { pos  :: !SrcSpan +                , srcF :: !Doc +                , bspF :: !Doc+                }+   | ErrOther    { pos   :: SrcSpan                 , msg   :: !Doc                 } -- ^ Sigh. Other.-+     deriving (Typeable, Generic , Functor )  errDupSpecs :: Doc -> Misc.ListNE SrcSpan -> TError t@@ -440,20 +492,20 @@ pprRealSrcSpan :: RealSrcSpan -> Doc pprRealSrcSpan span   | sline == eline && scol == ecol =-    hcat [ pathDoc <> colon-         , int sline <> colon+    hcat [ pathDoc <-> colon+         , int sline <-> colon          , int scol          ]   | sline == eline =-    hcat $ [ pathDoc <> colon-           , int sline <> colon+    hcat $ [ pathDoc <-> colon+           , int sline <-> colon            , int scol-           ] ++ if ecol - scol <= 1 then [] else [char '-' <> int (ecol - 1)]+           ] ++ if ecol - scol <= 1 then [] else [char '-' <-> int (ecol - 1)]   | otherwise =-    hcat [ pathDoc <> colon-         , parens (int sline <> comma <> int scol)+    hcat [ pathDoc <-> colon+         , parens (int sline <-> comma <-> int scol)          , char '-'-         , parens (int eline <> comma <> int ecol')+         , parens (int eline <-> comma <-> int ecol')          ]  where    path  = srcSpanFile      span@@ -482,7 +534,7 @@ panic :: {- (?callStack :: CallStack) => -} Maybe SrcSpan -> String -> a panic sp d = panicDoc (sspan sp) (text d)   where-    sspan  = fromMaybe noSrcSpan+    sspan  = Mb.fromMaybe noSrcSpan  -- | Construct and show an Error with an optional SrcSpan, then crash --   This function should be used to mark unimplemented functionality@@ -514,13 +566,13 @@ -------------------------------------------------------------------------------- ppError k dCtx e = ppError' k dSp dCtx e   where-    dSp          = pprint (pos e) <> text ": Error:"+    dSp          = pprint (pos e) <-> text ": Error:"  nests :: Foldable t => Int -> t Doc -> Doc nests n      = foldr (\d acc -> nest n (d $+$ acc)) empty  sepVcat :: Doc -> [Doc] -> Doc-sepVcat d ds = vcat $ intersperse d ds+sepVcat d ds = vcat $ L.intersperse d ds  blankLine :: Doc blankLine    = sizedText 5 " "@@ -536,11 +588,18 @@                 , text "VV :" <+> pprintTidy td tA]       , nests 2 [ text "not a subtype of Required type"                 , text "VV :" <+> pprintTidy td tE]-      , nests 2 [ text "In Context"-                , vsep (map (uncurry (pprintBind td)) (M.toList c))-                ]+      , ppContext td c        ] +ppContext :: PPrint t => Tidy -> M.HashMap Symbol t -> Doc +ppContext td c+  | 0 < length xts = nests 2 [ text "In Context"+                             , vsep (map (uncurry (pprintBind td)) xts)+                             ]+  | otherwise      = empty +  where +    xts            = M.toList c + pprintBind :: PPrint t => Tidy -> Symbol -> t -> Doc pprintBind td v t = pprintTidy td v <+> char ':' <+> pprintTidy td t @@ -558,7 +617,7 @@       ]  vsep :: [Doc] -> Doc-vsep = vcat . intersperse (char ' ')+vsep = vcat . L.intersperse (char ' ')  pprintModel :: PPrint t => Tidy -> Symbol -> WithModel t -> Doc pprintModel td v wm = case wm of@@ -612,6 +671,11 @@     loc1                  = mkRealSrcLoc (fsLit f) l1 c1     loc2                  = mkRealSrcLoc (fsLit f) l2 c2 +srcSpanFileMb :: SrcSpan -> Maybe FilePath+srcSpanFileMb (RealSrcSpan s) = Just $ unpackFS $ srcSpanFile s+srcSpanFileMb _               = Nothing ++ instance ToJSON SrcSpan where   toJSON (RealSrcSpan rsp) = object [ "realSpan" .= True, "spanInfo" .= rsp ]   toJSON (UnhelpfulSpan _) = object [ "realSpan" .= False ]@@ -646,6 +710,15 @@ totalityType :: PPrint a =>  Tidy -> a -> Bool  totalityType td tE = pprintTidy td tE == text "{VV : Addr# | 5 < 4}" +hint :: TError a -> Doc +hint e = maybe empty (\d -> "" $+$ ("HINT:" <+> d)) (go e) +  where +    go (ErrMismatch {}) = Just "Use the hole '_' instead of the mismatched component (in the Liquid specification)"+    go (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 + -------------------------------------------------------------------------------- ppError' :: (PPrint a, Show a) => Tidy -> Doc -> Doc -> TError a -> Doc --------------------------------------------------------------------------------@@ -654,13 +727,17 @@         $+$ dCtx         $+$ (ppFull td $ ppPropInContext td p c) -ppError' td dSp dCtx (ErrSubType _ _ _ _ tE)+ppError' td dSp dCtx err@(ErrSubType _ _ _ _ tE)   | totalityType td tE   = dSp <+> text "Totality Error"         $+$ dCtx         $+$ text "Your function is not total: not all patterns are defined." -        $+$ "Hint: Use \"--no-totality\" to deactivate totality checking."+        $+$ 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 dSp dCtx (ErrSubType _ _ c tA tE)   = dSp <+> text "Liquid Type Mismatch"         $+$ dCtx@@ -681,37 +758,48 @@         $+$ dCtx         $+$ (nest 4 $ pprint e) -ppError' _ dSp dCtx (ErrTySpec _ v t s)-  = dSp <+> text "Illegal type specification for" <+> ppVar v+ppError' _ dSp dCtx (ErrTySpec _ _k v t s)+  = dSp <+> ("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 +      _ppKind (Just d) = d <-> " "  ppError' _ dSp dCtx (ErrLiftExp _ v)-  = dSp <+> text "Cannot lift" <+> ppVar v <+> "into refinement logic"+  = dSp <+> 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"         $+$ dCtx-        $+$ (pprint s <+> "for" <+> ppVar v)+        $+$ (pprint s <+> "for" <+> ppTicks v) +ppError' _ dSp dCtx err@(ErrBadGADT _ v s)+  = dSp <+> text "Bad GADT specification for" <+> ppTicks v+        $+$ dCtx+        $+$ pprint s+        $+$ hint err + ppError' _ dSp dCtx (ErrDataCon _ d s)-  = dSp <+> "Malformed refined data constructor" <+> ppVar d+  = dSp <+> "Malformed refined data constructor" <+> ppTicks d         $+$ dCtx         $+$ s  ppError' _ dSp dCtx (ErrBadQual _ n d)-  = dSp <+> text "Illegal qualifier specification for" <+> ppVar n+  = dSp <+> text "Illegal qualifier specification for" <+> ppTicks n         $+$ dCtx         $+$ pprint d -ppError' _ dSp dCtx (ErrTermSpec _ v msg e s)-  = dSp <+> text "Illegal termination specification for" <+> ppVar v+ppError' _ dSp dCtx (ErrTermSpec _ v msg e t s)+  = dSp <+> text "Illegal termination specification for" <+> ppTicks v         $+$ dCtx-        $+$ (nest 4 $ ((text "Termination metric" <+> pprint e <+> text "is" <+> msg)+        $+$ (nest 4 $ ((text "Termination metric" <+> ppTicks e <+> text "is" <+> msg <+> "in type signature")+                        $+$ nest 4 (pprint t)                         $+$ pprint s))  ppError' _ dSp _ (ErrInvt _ t s)@@ -731,38 +819,38 @@         $+$ (nest 4 $ text "measure " <+> pprint t $+$ pprint s)  ppError' _ dSp dCtx (ErrHMeas _ t s)-  = dSp <+> text "Cannot lift Haskell function" <+> ppVar t <+> text "to logic"+  = dSp <+> 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" <+> ppVar v <+> colon+  = dSp <+> text "Multiple specifications for" <+> ppTicks v <+> colon         $+$ dCtx         $+$ ppSrcSpans ls   ppError' _ dSp dCtx (ErrDupIMeas _ v t ls)-  = dSp <+> text "Multiple instance measures" <+> ppVar v <+> text "for type" <+> ppVar t+  = dSp <+> 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" <+> ppVar v+  = dSp <+> text "Multiple measures named" <+> ppTicks v         $+$ dCtx         $+$ ppSrcSpans ls  ppError' _ dSp dCtx (ErrDupField _ dc x)   = dSp <+> text "Malformed refined data constructor" <+> dc         $+$ dCtx-        $+$ (nest 4 $ text "Duplicated definitions for field" <+> ppVar x)+        $+$ (nest 4 $ text "Duplicated definitions for field" <+> ppTicks x)  ppError' _ dSp dCtx (ErrDupNames _ x ns)-  = dSp <+> text "Ambiguous specification symbol" <+> ppVar x+  = dSp <+> text "Ambiguous specification symbol" <+> ppTicks x         $+$ dCtx         $+$ ppNames ns  ppError' _ dSp dCtx (ErrDupAlias _ k v ls)-  = dSp <+> text "Multiple definitions of" <+> pprint k <+> ppVar v+  = dSp <+> text "Multiple definitions of" <+> pprint k <+> ppTicks v         $+$ dCtx         $+$ ppSrcSpans ls @@ -771,20 +859,24 @@         $+$ dCtx  ppError' _ dSp dCtx (ErrUnbPred _ p)-  = dSp <+> text "Cannot apply unbound abstract refinement" <+> ppVar p+  = dSp <+> text "Cannot apply unbound abstract refinement" <+> ppTicks p         $+$ dCtx - ppError' _ dSp dCtx (ErrGhc _ s)   = dSp <+> text "GHC Error"         $+$ dCtx         $+$ (nest 4 $ pprint s) +ppError' _ dSp dCtx (ErrResolve _ kind v msg)+  = dSp <+> (text "Unknown" <+> kind <+> ppTicks v) +        $+$ dCtx+        $+$ (nest 4 msg)+ ppError' _ dSp dCtx (ErrPartPred _ c p i eN aN)   = dSp <+> text "Malformed predicate application"         $+$ dCtx         $+$ (nest 4 $ vcat-                        [ "The" <+> text (intToString i) <+> "argument of" <+> c <+> "is predicate" <+> ppVar p+                        [ "The" <+> text (Misc.intToString i) <+> "argument of" <+> c <+> "is predicate" <+> ppTicks p                         , "which expects" <+> pprint eN <+> "arguments" <+> "but is given only" <+> pprint aN                         , " "                         , "Abstract predicates cannot be partially applied; for a possible fix see:"@@ -792,8 +884,8 @@                         , nest 4 "https://github.com/ucsd-progsys/liquidhaskell/issues/594"                         ]) -ppError' _ dSp dCtx (ErrMismatch _ x msg τ t hsSp)-  = dSp <+> "Specified type does not refine Haskell type for" <+> ppVar x <+> parens msg+ppError' _ dSp dCtx e@(ErrMismatch _ x msg τ t cause hsSp)+  = dSp <+> "Specified type does not refine Haskell type for" <+> ppTicks x <+> parens msg         $+$ dCtx         $+$ (sepVcat blankLine               [ "The Liquid type"@@ -801,15 +893,24 @@               , "is inconsistent with the Haskell type"               , nest 4 τ               , "defined at" <+> pprint hsSp+              , maybe empty ppCause cause                ])+    where +      ppCause (hsD, lqD) = sepVcat blankLine +              [ "Specifically, the Liquid component" +              , nest 4 lqD +              , "is inconsistent with the Haskell component" +              , nest 4 hsD +              , hint e +              ]   ppError' _ dSp dCtx (ErrAliasCycle _ acycle)-  = dSp <+> text "Cyclic type alias definition for" <+> ppVar n0+  = dSp <+> text "Cyclic type alias definition for" <+> ppTicks n0         $+$ dCtx         $+$ (nest 4 $ sepVcat blankLine (hdr : map describe acycle))   where     hdr             = text "The following alias definitions form a cycle:"-    describe (p, n) = text "*" <+> ppVar n <+> parens (text "defined at:" <+> pprint p)+    describe (p, n) = text "*" <+> ppTicks n <+> parens (text "defined at:" <+> pprint p)     n0              = snd . head $ acycle  ppError' _ dSp dCtx (ErrIllegalAliasApp _ dn dl)@@ -819,9 +920,9 @@         $+$ text "Defined at:" <+> pprint dl  ppError' _ dSp dCtx (ErrAliasApp _ name dl s)-  = dSp <+> text "Malformed application of type alias" <+> ppVar name+  = dSp <+> text "Malformed application of type alias" <+> ppTicks name         $+$ dCtx-        $+$ (nest 4 $ vcat [ text "The alias" <+> ppVar name <+> "defined at:" <+> pprint dl+        $+$ (nest 4 $ vcat [ text "The alias" <+> ppTicks name <+> "defined at:" <+> pprint dl                            , s ] )  ppError' _ dSp dCtx (ErrSaved _ name s)@@ -834,6 +935,14 @@         $+$ dCtx         $+$ text "--idirs, --c-files, and --ghc-option cannot be used in file-level pragmas" +ppError' _ _ _ err@(ErrNoSpec _ srcF bspecF)+  =   vcat [ text "Cannot find .bspec file "+           , nest 4 bspecF +           , text "for the source file "+           , nest 4 srcF +           , hint err +           ]+ ppError' _ dSp dCtx (ErrOther _ s)   = dSp <+> text "Uh oh."         $+$ dCtx@@ -842,8 +951,23 @@ ppError' _ dSp dCtx (ErrTermin _ xs s)   = dSp <+> text "Termination Error"         $+$ dCtx-        <+> (hsep $ intersperse comma xs) $+$ s+        <+> (hsep $ L.intersperse comma xs) $+$ s +ppError' _ dSp dCtx (ErrStTerm _ x s)+  = dSp <+> 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"+        $+$ 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"+    $+$ dCtx+    $+$ (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"     $+$ (nest 4 $ sepVcat blankLine $ describeCls : map describeInst is)@@ -856,7 +980,7 @@       $+$ text "Defined at:" <+> pprint p  ppError' _ dSp dCtx (ErrTyCon _ msg ty)-  = dSp <+> text "Illegal data refinement for" <+> ppVar ty+  = dSp <+> text "Illegal data refinement for" <+> ppTicks ty         $+$ dCtx         $+$ nest 4 msg @@ -865,8 +989,11 @@         $+$ dCtx         $+$ nest 4 msg -ppVar :: PPrint a => a -> Doc-ppVar v = text "`" <> pprint v <> text "`"+ppTicks :: PPrint a => a -> Doc+ppTicks = ticks . pprint ++ticks :: Doc -> Doc +ticks d = text "`" <-> d <-> text "`"  ppSrcSpans :: [SrcSpan] -> Doc ppSrcSpans = ppList (text "Conflicting definitions at")
src/Language/Haskell/Liquid/Types/Fresh.hs view
@@ -36,7 +36,7 @@ import qualified Language.Fixpoint.Types as F -- import           Language.Fixpoint.Types.Visitor (kvars) import           Language.Haskell.Liquid.Misc  (single)-import           Language.Haskell.Liquid.Types+import           Language.Haskell.Liquid.Types.Types import           Language.Haskell.Liquid.Types.RefType  @@ -92,6 +92,9 @@ trueRefType (RAllP π t)   = RAllP π <$> true t +trueRefType (RImpF _ t t' _)+  = rImpF <$> fresh <*> true t <*> true t'+ trueRefType (RFun _ t t' _)   = rFun <$> fresh <*> true t <*> true t' @@ -143,6 +146,10 @@ refreshRefType (RAllP π t)   = RAllP π <$> refresh t +refreshRefType (RImpF b t t' _)+  | b == F.dummySymbol = rImpF <$> fresh <*> refresh t <*> refresh t'+  | otherwise          = rImpF     b     <$> refresh t <*> refresh t'+ refreshRefType (RFun b t t' _)   | b == F.dummySymbol = rFun <$> fresh <*> refresh t <*> refresh t'   | otherwise          = rFun     b     <$> refresh t <*> refresh t'@@ -192,32 +199,41 @@ -------------------------------------------------------------------------------- refreshVV :: FreshM m => SpecType -> m SpecType ---------------------------------------------------------------------------------refreshVV (RAllT a t) = RAllT a <$> refreshVV t-refreshVV (RAllP p t) = RAllP p <$> refreshVV t+refreshVV (RAllT a t) = +  RAllT a <$> refreshVV t -refreshVV (REx x t1 t2)-  = do [t1', t2'] <- mapM refreshVV [t1, t2]-       shiftVV (REx x t1' t2') <$> fresh+refreshVV (RAllP p t) = +  RAllP p <$> refreshVV t -refreshVV (RFun x t1 t2 r)-  = do [t1', t2'] <- mapM refreshVV [t1, t2]-       shiftVV (RFun x t1' t2' r) <$> fresh+refreshVV (REx x t1 t2) = do +  t1' <- refreshVV t1+  t2' <- refreshVV t2+  shiftVV (REx x t1' t2') <$> fresh -refreshVV (RAppTy t1 t2 r)-  = do [t1', t2'] <- mapM refreshVV [t1, t2]-       shiftVV (RAppTy t1' t2' r) <$> fresh+refreshVV (RImpF x t1 t2 r) = do+  t1' <- refreshVV t1+  t2' <- refreshVV t2+  shiftVV (RImpF x t1' t2' r) <$> fresh -refreshVV (RApp c ts rs r)-  = do ts' <- mapM refreshVV ts-       rs' <- mapM refreshVVRef rs-       shiftVV (RApp c ts' rs' r) <$> fresh+refreshVV (RFun x t1 t2 r) = do+  t1' <- refreshVV t1+  t2' <- refreshVV t2+  shiftVV (RFun x t1' t2' r) <$> fresh -refreshVV t-  = shiftVV t <$> fresh+refreshVV (RAppTy t1 t2 r) = do +  t1' <- refreshVV t1+  t2' <- refreshVV t2+  shiftVV (RAppTy t1' t2' r) <$> fresh -refreshVVRef :: Freshable m Integer-             => Ref b (RType RTyCon RTyVar RReft)-             -> m (Ref b (RType RTyCon RTyVar RReft))+refreshVV (RApp c ts rs r) = do +  ts' <- mapM refreshVV    ts+  rs' <- mapM refreshVVRef rs+  shiftVV (RApp c ts' rs' r) <$> fresh++refreshVV t = +  shiftVV t <$> fresh++refreshVVRef :: Freshable m Integer => Ref b SpecType -> m (Ref b SpecType) refreshVVRef (RProp ss (RHole r))   = return $ RProp ss (RHole r) 
src/Language/Haskell/Liquid/Types/Literals.hs view
@@ -1,19 +1,18 @@ {-# LANGUAGE OverloadedStrings #-} -module Language.Haskell.Liquid.Types.Literals (-         literalFRefType-       , literalFReft-       , literalConst--       , mkI, mkS-       ) where+module Language.Haskell.Liquid.Types.Literals +  ( literalFRefType+  , literalFReft+  , literalConst+  , mkI, mkS+  ) where  import Prelude hiding (error) import Language.Haskell.Liquid.GHC.TypeRep import Literal import qualified TyCon  as TC -import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.Types.Types import Language.Haskell.Liquid.Types.RefType import Language.Haskell.Liquid.Transforms.CoreToLogic (mkLit, mkI, mkS) 
src/Language/Haskell/Liquid/Types/Meet.hs view
@@ -2,26 +2,37 @@ --   that are here so that we can throw decent error messages if --   they fail. The module depends on `RefType` and `UX.Tidy`. -module Language.Haskell.Liquid.Types.Meet-     ( meetVarTypes ) where+module Language.Haskell.Liquid.Types.Meet ( meetVarTypes ) where  import           SrcLoc-import           Text.PrettyPrint.HughesPJ (text, Doc)+import           Text.PrettyPrint.HughesPJ (Doc) import qualified Language.Fixpoint.Types as F-import           Language.Haskell.Liquid.Types-import           Language.Haskell.Liquid.Types.RefType-import           Language.Haskell.Liquid.UX.Tidy+import           Language.Haskell.Liquid.Types.Types+import           Language.Haskell.Liquid.Types.RefType ()+-- import           Language.Haskell.Liquid.UX.Tidy+import           TyCon                                  hiding (tyConName) -meetVarTypes :: Doc -> (SrcSpan, SpecType) -> (SrcSpan, SpecType) -> SpecType-meetVarTypes v hs lq = meetError err hsT lqT+meetVarTypes :: F.TCEmb TyCon -> Doc -> (SrcSpan, SpecType) -> (SrcSpan, SpecType) -> SpecType+meetVarTypes _emb _v hs lq = {- meetError emb err -} F.meet hsT lqT   where-    (hsSp, hsT)      = hs-    (lqSp, lqT)      = lq-    err              = ErrMismatch lqSp v (text "meetVarTypes") hsD lqD hsSp-    hsD              = F.pprint ({- toRSort -} hsT)-    lqD              = F.pprint ({- toRSort -} lqT)+    (_hsSp, hsT)      = hs+    (_lqSp, lqT)      = lq+    -- _err              = ErrMismatch lqSp v (text "meetVarTypes") hsD lqD hsSp+    -- _hsD              = F.pprint hsT+    -- _lqD              = F.pprint lqT+{- +  +_meetError :: F.TCEmb TyCon -> Error -> SpecType -> SpecType -> SpecType+_meetError _emb _e t t'+  -- // | meetable emb t t'+  | True              = t `F.meet` t'+  -- // | otherwise         = panicError e -meetError :: Error -> SpecType -> SpecType -> SpecType-meetError e t t'-  | meetable t t' = t `F.meet` t'-  | otherwise     = panicError e+_meetable :: F.TCEmb TyCon -> SpecType -> SpecType -> Bool+_meetable _emb t1 t2 = F.notracepp ("meetable: " ++  showpp (s1, t1, s2, t2)) (s1 == s2)+  where+    s1              = tx t1+    s2              = tx t2+    tx              = rTypeSort _emb . toRSort++-}
src/Language/Haskell/Liquid/Types/PredType.hs view
@@ -12,7 +12,6 @@   , dataConPSpecType   , makeTyConInfo   , replacePreds-   , replacePredsWithRefs   , pVartoRConc @@ -21,7 +20,6 @@    -- * Compute @RType@ of a given @PVar@   , pvarRType-   , substParg   , pApp   , pappSort@@ -35,46 +33,71 @@ import           DataCon import           Name                            (getSrcSpan) import           Text.PrettyPrint.HughesPJ-import qualified TyCon                           as TC+-- import qualified TyCon                           as TC -- import qualified Var import           Type import           Var import           Language.Haskell.Liquid.GHC.TypeRep import           Data.Hashable import qualified Data.HashMap.Strict             as M-import           Data.List                       (foldl', partition)+import qualified Data.Maybe                                 as Mb +import qualified Data.List         as L -- (foldl', partition)+-- import           Data.List                       (nub)  import           Language.Fixpoint.Misc  -- import           Language.Fixpoint.Types         hiding (Expr, Predicate)-import qualified Language.Fixpoint.Types         as F+import qualified Language.Fixpoint.Types                    as F+import qualified Language.Haskell.Liquid.GHC.API            as Ghc  import           Language.Haskell.Liquid.GHC.Misc import           Language.Haskell.Liquid.Misc import           Language.Haskell.Liquid.Types.RefType hiding (generalize)-import           Language.Haskell.Liquid.Types-import           Data.List                       (nub)+import           Language.Haskell.Liquid.Types.Types import           Data.Default -makeTyConInfo :: [(TC.TyCon, TyConP)] -> M.HashMap TC.TyCon RTyCon-makeTyConInfo = hashMapMapWithKey mkRTyCon . M.fromList+makeTyConInfo :: F.TCEmb Ghc.TyCon -> [Ghc.TyCon] -> [TyConP] -> TyConMap+makeTyConInfo tce fiTcs tcps = TyConMap +  { tcmTyRTy    = tcM+  , tcmFIRTy    = tcInstM +  , tcmFtcArity = arities+  }+  where +    tcM         = M.fromList [(tcpCon tcp, mkRTyCon tcp) | tcp <- tcps ]+    tcInstM     = mkFInstRTyCon tce fiTcs tcM +    arities     = safeFromList "makeTyConInfo" [ (c, length ts) | (c, ts) <- M.keys tcInstM ] -mkRTyCon ::  TC.TyCon -> TyConP -> RTyCon-mkRTyCon tc (TyConP _ αs' ps _ tyvariance predvariance size)+mkFInstRTyCon :: F.TCEmb Ghc.TyCon -> [Ghc.TyCon] -> M.HashMap Ghc.TyCon RTyCon -> M.HashMap (Ghc.TyCon, [F.Sort]) RTyCon+mkFInstRTyCon tce fiTcs tcm = M.fromList +  [ ((c, typeSort tce <$> ts), rtc) +    | fiTc    <- fiTcs+    , rtc     <- Mb.maybeToList (M.lookup fiTc tcm)+    , (c, ts) <- Mb.maybeToList (famInstArgs fiTc)+  ] ++mkRTyCon ::  TyConP -> RTyCon+mkRTyCon (TyConP _ tc αs' ps _ tyvariance predvariance size)   = RTyCon tc pvs' (mkTyConInfo tc tyvariance predvariance size)   where     τs   = [rVar α :: RSort |  α <- tyConTyVarsDef tc]     pvs' = subts (zip αs' τs) <$> ps --- TODO: duplicated with Liquid.Measure.makeDataConType-dataConPSpecType :: DataCon -> DataConP -> [(Var, SpecType)]-dataConPSpecType dc dcp = [ (workX, workT), (wrapX, wrapT) ]++-------------------------------------------------------------------------------+-- | @dataConPSpecType@ converts a @DataConP@, LH's internal representation for +--   a (refined) data constructor into a @SpecType@ for that constructor.+--   TODO: duplicated with Liquid.Measure.makeDataConType+-------------------------------------------------------------------------------+dataConPSpecType :: DataConP -> [(Var, SpecType)]+-------------------------------------------------------------------------------+dataConPSpecType dcp    = F.notracepp "dataConPSpecType" [ (workX, workT), (wrapX, wrapT) ]   where     workT | isVanilla   = wrapT-          | otherwise   = dcWorkSpecType dc wrapT-    wrapT               = dcWrapSpecType dc dcp-    workX               = dataConWorkId dc            -- this is the weird one for GADTs-    wrapX               = dataConWrapId dc            -- this is what the user expects to see-    isVanilla           = {- F.notracepp ("IS-Vanilla: " ++ showpp dc) $ -} isVanillaDataCon dc+          | otherwise   = dcWorkSpecType   dc wrapT+    wrapT               = dcWrapSpecType   dc dcp+    workX               = dataConWorkId    dc            -- This is the weird one for GADTs+    wrapX               = dataConWrapId    dc            -- This is what the user expects to see+    isVanilla           = isVanillaDataCon dc+    dc                  = dcpCon dcp  dcWorkSpecType :: DataCon -> SpecType -> SpecType dcWorkSpecType c wrT    = fromRTypeRep (meetWorkWrapRep c wkR wrR)@@ -130,6 +153,7 @@   = workR { ty_binds = xs ++ (ty_binds wrapR)           , ty_args  = ts ++ zipWith strengthenRType ts' (ty_args wrapR)           , ty_res   = strengthenRType (ty_res workR)    (ty_res  wrapR)+          , ty_preds = ty_preds wrapR           }   | otherwise   = panic (Just (getSrcSpan c)) errMsg@@ -145,9 +169,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 ls cs yts rt _ _ _)   = {- F.tracepp ("dcWrapSpecType: " ++ show dc ++ " " ++ F.showpp rt) $ -}-    mkArrow makeVars ps ls ts' rt'+    mkArrow makeVars ps ls [] ts' rt'   where     (xs, ts) = unzip (reverse yts)     mkDSym z = (F.symbol z) `F.suffixSymbol` (F.symbol dc)@@ -163,17 +187,27 @@     makeVars = zipWith (\v a -> RTVar v (rTVarInfo a :: RTVInfo RSort)) vs (fst $ splitForAllTys $ dataConRepType dc)  instance PPrint TyConP where-  pprintTidy k (TyConP _ vs ps ls _ _ _)-    = (parens $ hsep (punctuate comma (pprintTidy k <$> vs))) <+>-      (parens $ hsep (punctuate comma (pprintTidy k <$> ps))) <+>-      (parens $ hsep (punctuate comma (pprintTidy k <$> ls)))+  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))) +ppComm :: PPrint a => F.Tidy -> [a] -> Doc +ppComm k = parens . hsep . punctuate comma . fmap (pprintTidy k)+++    + instance Show TyConP where  show = showpp -- showSDoc . ppr  instance PPrint DataConP where-  pprintTidy k (DataConP _ vs ps ls cs yts t isGadt mname _)-     =  (parens $ hsep (punctuate comma (pprintTidy k <$> vs)))+  pprintTidy k (DataConP _ dc vs ps ls 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)))@@ -200,9 +234,8 @@   = panic Nothing "ofTypePAppTy"  ---------------------------------------------------------------------------------- Interface: Replace Predicate With Uninterprented Function Symbol -----+-- | Interface: Replace Predicate With Uninterpreted Function Symbol ------- ----------------------------------------------------------------------------- replacePredsWithRefs :: (UsedPVar, (F.Symbol, [((), F.Symbol, F.Expr)]) -> F.Expr)                      -> UReft F.Reft -> UReft F.Reft replacePredsWithRefs (p, r) (MkUReft (F.Reft(v, rs)) (Pr ps) s)@@ -210,7 +243,7 @@   where     rs''             = mconcat $ rs : rs'     rs'              = r . (v,) . pargs <$> ps1-    (ps1, ps2)       = partition (== p) ps+    (ps1, ps2)       = L.partition (== p) ps  pVartoRConc :: PVar t -> (F.Symbol, [(a, b, F.Expr)]) -> F.Expr pVartoRConc p (v, args) | length args == length (pargs p)@@ -264,10 +297,10 @@ ------------------------------------------------------------------------------------- replacePreds                 :: String -> SpecType -> [(RPVar, SpecProp)] -> SpecType --------------------------------------------------------------------------------------replacePreds msg                 = foldl' go+replacePreds msg                 = L.foldl' go   where      go _ (_, RProp _ (RHole _)) = panic Nothing "replacePreds on RProp _ (RHole _)"-     go z (π, t) = substPred msg   (π, t)     z+     go z (π, t)                 = substPred msg   (π, t)     z   -- TODO: replace `replacePreds` with@@ -313,7 +346,16 @@   where (r', πs)                = splitRPvar π r -- ps has   , pargs :: ![(t, Symbol, Expr)] +-- AT: just a copy of the other case, mutatis mutandi. (is there a less hacky way?)+substPred msg su@(π,prop) (RImpF x t t' r)+  | null πs                     = RImpF x (substPred msg su t) (substPred msg su t') r+  | otherwise                   =+      let sus = (\π -> F.mkSubst (zip (fst <$> rf_args prop) (thd3 <$> pargs π))) <$> πs in+      foldl (\t su -> t `F.meet` F.subst su (rf_body prop)) (RImpF x (substPred msg su t) (substPred msg su t') r') sus+  where (r', πs)                = splitRPvar π r ++ substPred msg su (RRTy e r o t) = RRTy (mapSnd (substPred msg su) <$> e) r o (substPred msg su t) substPred msg su (RAllE x t t') = RAllE x (substPred msg su t) (substPred msg su t') substPred msg su (REx x t t')   = REx   x (substPred msg su t) (substPred msg su t')@@ -353,7 +395,7 @@     rvs      = foldReft (\_ r acc -> rvReft r : acc) []     rvReft r = let F.Reft(s,_) = F.toReft r in s -substRCon msg su t _ _        = panic Nothing $ msg ++ " substRCon " ++ showpp (su, t)+substRCon msg su t _ _        = {- panic Nothing -} errorP "substRCon: " $ msg ++ " " ++ showpp (su, t)  pad :: [Char] -> (a -> a) -> [a] -> [a] -> ([a], [a]) pad _ f [] ys   = (f <$> ys, ys)@@ -382,14 +424,16 @@ splitRPvar :: PVar t -> UReft r -> (UReft r, [UsedPVar]) splitRPvar pv (MkUReft x (Pr pvs) s) = (MkUReft x (Pr pvs') s, epvs)   where-    (epvs, pvs')               = partition (uPVar pv ==) pvs+    (epvs, pvs')               = L.partition (uPVar pv ==) pvs  -- TODO: rewrite using foldReft freeArgsPs :: PVar (RType t t1 ()) -> RType t t1 (UReft t2) -> [F.Symbol] freeArgsPs p (RVar _ r)   = freeArgsPsRef p r+freeArgsPs p (RImpF _ t1 t2 r)+  = L.nub $  freeArgsPsRef p r ++ freeArgsPs p t1 ++ freeArgsPs p t2 freeArgsPs p (RFun _ t1 t2 r)-  = nub $  freeArgsPsRef p r ++ freeArgsPs p t1 ++ freeArgsPs p t2+  = L.nub $  freeArgsPsRef p r ++ freeArgsPs p t1 ++ freeArgsPs p t2 freeArgsPs p (RAllT _ t)   = freeArgsPs p t freeArgsPs p (RAllS _ t)@@ -398,19 +442,19 @@   | p == p'   = []   | otherwise = freeArgsPs p t freeArgsPs p (RApp _ ts _ r)-  = nub $ freeArgsPsRef p r ++ concatMap (freeArgsPs p) ts+  = L.nub $ freeArgsPsRef p r ++ concatMap (freeArgsPs p) ts freeArgsPs p (RAllE _ t1 t2)-  = nub $ freeArgsPs p t1 ++ freeArgsPs p t2+  = L.nub $ freeArgsPs p t1 ++ freeArgsPs p t2 freeArgsPs p (REx _ t1 t2)-  = nub $ freeArgsPs p t1 ++ freeArgsPs p t2+  = L.nub $ freeArgsPs p t1 ++ freeArgsPs p t2 freeArgsPs p (RAppTy t1 t2 r)-  = nub $ freeArgsPsRef p r ++ freeArgsPs p t1 ++ freeArgsPs p t2+  = L.nub $ freeArgsPsRef p r ++ freeArgsPs p t1 ++ freeArgsPs p t2 freeArgsPs _ (RExprArg _)   = [] freeArgsPs p (RHole r)   = freeArgsPsRef p r freeArgsPs p (RRTy env r _ t)-  = nub $ concatMap (freeArgsPs p) (snd <$> env) ++ freeArgsPsRef p r ++ freeArgsPs p t+  = L.nub $ concatMap (freeArgsPs p) (snd <$> env) ++ freeArgsPsRef p r ++ freeArgsPs p t  freeArgsPsRef :: PVar t1 -> UReft t -> [F.Symbol] freeArgsPsRef p (MkUReft _ (Pr ps) _) = [x | (_, x, w) <- (concatMap pargs ps'),  (F.EVar x) == w]@@ -420,7 +464,7 @@  meetListWithPSubs :: (Foldable t, PPrint t1, F.Reftable b)                   => t (PVar t1) -> [(F.Symbol, RSort)] -> b -> b -> b-meetListWithPSubs πs ss r1 r2    = foldl' (meetListWithPSub ss r1) r2 πs+meetListWithPSubs πs ss r1 r2    = L.foldl' (meetListWithPSub ss r1) r2 πs  meetListWithPSubsRef :: (Foldable t, F.Reftable (RType t1 t2 t3))                      => t (PVar t4)@@ -428,7 +472,7 @@                      -> Ref τ (RType t1 t2 t3)                      -> Ref τ (RType t1 t2 t3)                      -> Ref τ (RType t1 t2 t3)-meetListWithPSubsRef πs ss r1 r2 = foldl' ((meetListWithPSubRef ss) r1) r2 πs+meetListWithPSubsRef πs ss r1 r2 = L.foldl' ((meetListWithPSubRef ss) r1) r2 πs  meetListWithPSub ::  (F.Reftable r, PPrint t) => [(F.Symbol, RSort)]-> r -> r -> PVar t -> r meetListWithPSub ss r1 r2 π
src/Language/Haskell/Liquid/Types/PrettyPrint.hs view
@@ -29,15 +29,15 @@ import           GHC                              (Name, Class) import           HscTypes                         (SourceError) import           Language.Fixpoint.Misc-import qualified Language.Fixpoint.Types          as F -- hiding (Error, SrcSpan, Predicate)+import qualified Language.Fixpoint.Types          as F  import           Language.Haskell.Liquid.GHC.Misc import           Language.Haskell.Liquid.Misc-import           Language.Haskell.Liquid.Types    hiding (sort)+import           Language.Haskell.Liquid.Types.Types     import           Prelude                          hiding (error) import           SrcLoc-import           Text.PrettyPrint.HughesPJ+import           Text.PrettyPrint.HughesPJ        hiding ((<>)) import           TyCon                            (TyCon)-import           Language.Haskell.Liquid.GHC.TypeRep                          hiding (maybeParen)+import           Language.Haskell.Liquid.GHC.TypeRep  hiding (maybeParen) import           Var                              (Var)  --------------------------------------------------------------------------------@@ -54,7 +54,7 @@ -------------------------------------------------------------------------------- pprintSymbol :: F.Symbol -> Doc ---------------------------------------------------------------------------------pprintSymbol x = char '‘' <> pprint x <> char '’'+pprintSymbol x = char '‘' <-> pprint x <-> char '’'   --------------------------------------------------------------------------------@@ -129,31 +129,39 @@                                  , nest 2 $ text "axiom-map"                                  , nest 4 $ pprint am                                  ]+                     -------------------------------------------------------------------------------- -- | Pretty Printing RefType --------------------------------------------------- -------------------------------------------------------------------------------- instance (OkRT c tv r) => PPrint (RType c tv r) where   -- RJ: THIS IS THE CRUCIAL LINE, the following prints short types.   pprintTidy _ = rtypeDoc F.Lossy-  -- pprintTidy _ = ppRType TopPrec+  -- pprintTidy _ = ppRType topPrec  instance (PPrint tv, PPrint ty) => PPrint (RTAlias tv ty) where   pprintTidy = ppAlias  ppAlias :: (PPrint tv, PPrint ty) => F.Tidy -> RTAlias tv ty -> Doc-ppAlias k a = text "type" <+> pprint (rtName a)-                          <+> pprints k space (rtTArgs a)-                          <+> pprints k space (rtVArgs a)-                          <+> text " = "-                          <+> pprint (rtBody a)+ppAlias k a =   pprint (rtName a)+            <+> pprints k space (rtTArgs a)+            <+> pprints k space (rtVArgs a)+            <+> text " = "+            <+> pprint (rtBody a) +instance (F.PPrint tv, F.PPrint t) => F.PPrint (RTEnv tv t) where +  pprintTidy k rte +    =   text "** Type Aliaes *********************" +    $+$ nest 4 (F.pprintTidy k (typeAliases rte)) +    $+$ text "** Expr Aliases ********************" +    $+$ nest 4 (F.pprintTidy k (exprAliases rte))+ pprints :: (PPrint a) => F.Tidy -> Doc -> [a] -> Doc pprints k c = sep . punctuate c . map (pprintTidy k)  -------------------------------------------------------------------------------- rtypeDoc :: (OkRT c tv r) => F.Tidy -> RType c tv r -> Doc ---------------------------------------------------------------------------------rtypeDoc k    = ppr_rtype (ppE k) TopPrec+rtypeDoc k      = ppr_rtype (ppE k) topPrec   where     ppE F.Lossy = ppEnvShort ppEnv     ppE F.Full  = ppEnv@@ -162,6 +170,8 @@   pprintTidy _ F.Full  = "Full"   pprintTidy _ F.Lossy = "Lossy" +type Prec = PprPrec + -------------------------------------------------------------------------------- ppr_rtype :: (OkRT c tv r) => PPEnv -> Prec -> RType c tv r -> Doc --------------------------------------------------------------------------------@@ -173,14 +183,16 @@   = ppr_forall bb p t ppr_rtype _ _ (RVar a r)   = F.ppTy r $ pprint a+ppr_rtype bb p t@(RImpF _ _ _ _)+  = maybeParen p funPrec (ppr_rty_fun bb empty t) ppr_rtype bb p t@(RFun _ _ _ _)-  = maybeParen p FunPrec $ ppr_rty_fun bb empty t+  = maybeParen p funPrec (ppr_rty_fun bb empty t) ppr_rtype bb p (RApp c [t] rs r)   | isList c-  = F.ppTy r $ brackets (ppr_rtype bb p t) <> ppReftPs bb p rs+  = F.ppTy r $ brackets (ppr_rtype bb p t) <-> ppReftPs bb p rs ppr_rtype bb p (RApp c ts rs r)   | isTuple c-  = F.ppTy r $ parens (intersperse comma (ppr_rtype bb p <$> ts)) <> ppReftPs bb p rs+  = F.ppTy r $ parens (intersperse comma (ppr_rtype bb p <$> ts)) <-> ppReftPs bb p rs ppr_rtype bb p (RApp c ts rs r)   | isEmpty rsDoc && isEmpty tsDoc   = F.ppTy r $ ppT c@@ -212,7 +224,7 @@  ppTyConB :: TyConable c => PPEnv -> c -> Doc ppTyConB bb-  | ppShort bb = shortModules . ppTycon+  | ppShort bb = {- shortModules . -} ppTycon   | otherwise  = ppTycon  shortModules :: Doc -> Doc@@ -228,7 +240,7 @@     (env, l) = (init el, last el)     tr   = snd $ r     tl   = snd $ l-    pprint_bind (x, t) = pprint x <+> colon <> colon <+> ppr_rtype bb p t+    pprint_bind (x, t) = pprint x <+> colon <-> colon <+> ppr_rtype bb p t     pprint_env         = hsep $ punctuate comma (pprint_bind <$> env)  -- | From GHC: TypeRep@@ -243,7 +255,7 @@       F.Reftable (RTProp c tv ()))   => PPEnv -> Prec -> RType c tv r -> Doc ppExists bb p t-  = text "exists" <+> brackets (intersperse comma [ppr_dbind bb TopPrec x t | (x, t) <- zs]) <> dot <> ppr_rtype bb p t'+  = text "exists" <+> brackets (intersperse comma [ppr_dbind bb topPrec x t | (x, t) <- zs]) <-> dot <-> ppr_rtype bb p t'     where (zs,  t')               = split [] t           split zs (REx x t t')   = split ((x,t):zs) t'           split zs t                = (reverse zs, t)@@ -252,10 +264,11 @@   :: (OkRT c tv r, PPrint (RType c tv r), PPrint (RType c tv ()))   => PPEnv -> Prec -> RType c tv r -> Doc ppAllExpr bb p t-  = text "forall" <+> brackets (intersperse comma [ppr_dbind bb TopPrec x t | (x, t) <- zs]) <> dot <> ppr_rtype bb p t'-    where (zs,  t')               = split [] t-          split zs (RAllE x t t') = split ((x,t):zs) t'-          split zs t                = (reverse zs, t)+  = text "forall" <+> brackets (intersperse comma [ppr_dbind bb topPrec x t | (x, t) <- zs]) <-> dot <-> ppr_rtype bb p t'+    where +      (zs,  t')               = split [] t+      split zs (RAllE x t t') = split ((x,t):zs) t'+      split zs t              = (reverse zs, t)  ppReftPs   :: (OkRT c tv r, PPrint (RType c tv r), PPrint (RType c tv ()),@@ -273,28 +286,48 @@   | F.isNonSymbol x || (x == F.dummySymbol)   = ppr_rtype bb p t   | otherwise-  = pprint x <> colon <> ppr_rtype bb p t+  = pprint x <-> colon <-> ppr_rtype bb p t  + ppr_rty_fun   :: ( OkRT c tv r, PPrint (RType c tv r), PPrint (RType c tv ()))   => PPEnv -> Doc -> RType c tv r -> Doc+ppr_rty_fun bb prefix t = hsep (prefix : dArgs ++ [dOut])+  where+    dArgs               = concatMap ppArg args+    dOut                = ppr_rtype bb topPrec out+    ppArg (b, t, a)     = [ppr_dbind bb funPrec b t, a]+    (args, out)         = brkFun t++{-  ppr_rty_fun bb prefix t   = prefix <+> ppr_rty_fun' bb t  ppr_rty_fun'   :: ( OkRT c tv r, PPrint (RType c tv r), PPrint (RType c tv ()))   => PPEnv -> RType c tv r -> Doc+ppr_rty_fun' bb (RImpF b t t' r)+  = F.ppTy r $ ppr_dbind bb funPrec b t $+$ ppr_rty_fun bb (text "~>") t' ppr_rty_fun' bb (RFun b t t' r)-  = F.ppTy r $ ppr_dbind bb FunPrec b t <+> ppr_rty_fun bb arrow t'+  = F.ppTy r $ ppr_dbind bb funPrec b t $+$ ppr_rty_fun bb arrow t' ppr_rty_fun' bb t-  = ppr_rtype bb TopPrec t+  = ppr_rtype bb topPrec t+-} +brkFun :: RType c tv r -> ([(F.Symbol, RType c tv r, Doc)], RType c tv r) +brkFun (RImpF b t t' _) = ((b, t, (text "~>")) : args, out)   where (args, out)     = brkFun t'  +brkFun (RFun b t t' _)  = ((b, t, (text "->")) : args, out)   where (args, out)     = brkFun t'  +brkFun out              = ([], out) ++++ ppr_forall :: (OkRT c tv r) => PPEnv -> Prec -> RType c tv r -> Doc-ppr_forall bb p t = maybeParen p FunPrec $ sep [+ppr_forall bb p t = maybeParen p funPrec $ sep [                       ppr_foralls (ppPs bb) (ty_vars trep) (ty_preds trep) (ty_labels trep)                     , ppr_clss cls-                    , ppr_rtype bb TopPrec t'+                    , ppr_rtype bb topPrec t'                     ]   where     trep          = toRTypeRep t@@ -302,7 +335,7 @@      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 True αs πs ss = text "forall" <+> dαs αs <+> dπs (ppPs bb) πs <+> ppr_symbols ss <-> dot      ppr_clss []               = empty     ppr_clss cs               = (parens $ hsep $ punctuate comma (uncurry (ppr_cls bb p) <$> cs)) <+> text "=>"@@ -355,7 +388,7 @@  ppRefArgs :: [F.Symbol] -> Doc ppRefArgs [] = empty-ppRefArgs ss = text "\\" <> hsep (ppRefSym <$> ss ++ [F.vv Nothing]) <+> text "->"+ppRefArgs ss = text "\\" <-> hsep (ppRefSym <$> ss ++ [F.vv Nothing]) <+> arrow   ppRefSym :: (Eq a, IsString a, PPrint a) => a -> Doc ppRefSym "" = text "_"@@ -368,6 +401,6 @@   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+    | otherwise  = pprintTidy k p <-> text " & " <-> pprintTidy k r  --------------------------------------------------------------------------------
src/Language/Haskell/Liquid/Types/RefType.hs view
@@ -20,8 +20,10 @@  module Language.Haskell.Liquid.Types.RefType ( +    TyConMap+   -- * Functions for lifting Reft-values to Spec-values-    uTop, uReft, uRType, uRType', uRTypeGen, uPVar+  , uTop, uReft, uRType, uRType', uRTypeGen, uPVar    -- * Applying a solution to a SpecType   , applySolution@@ -33,7 +35,7 @@   -- * Functions for manipulating `Predicate`s   , pdVar   , findPVar-  , FreeVar, freeTyVars, tyClasses, tyConName+  , FreeVar, allTyVars, freeTyVars, tyClasses, tyConName    -- * Quantifying RTypes   , quantifyRTy@@ -57,7 +59,8 @@   , typeUniqueSymbol   , classBinds   , isSizeable-+  , famInstTyConType+  , famInstArgs    -- * Manipulating Refinements in RTypes   , strengthen@@ -74,7 +77,6 @@   -- , mkDataConIdsTy   , expandProductType   , mkTyConInfo-  , meetable   , strengthenRefTypeGen   , strengthenDataConType   , isBaseTy@@ -86,6 +88,7 @@ -- import           GHC.Stack import TyCoRep import Prelude hiding (error)+-- import qualified Prelude import WwLib import FamInstEnv (emptyFamInstEnv) import Name             hiding (varName)@@ -96,35 +99,37 @@ import Type             (splitFunTys, expandTypeSynonyms, substTyWith, isClassPred, isEqPred, isNomEqPred) import TysWiredIn       (listTyCon, intDataCon, trueDataCon, falseDataCon,                          intTyCon, charTyCon, typeNatKind, typeSymbolKind, stringTy, intTy)--- import TysPrim          (eqPrimTyCon)--- import           Data.Monoid      hiding ((<>)) import           Data.Maybe               (fromMaybe, isJust, fromJust) import           Data.Hashable import qualified Data.HashMap.Strict  as M import qualified Data.HashSet         as S import qualified Data.List as L--import Control.Monad  (void)-import Text.Printf-import Text.PrettyPrint.HughesPJ--import Language.Haskell.Liquid.Types.Errors-import Language.Haskell.Liquid.Types.PrettyPrint+import           Control.Monad  (void)+import           Text.Printf+import           Text.PrettyPrint.HughesPJ hiding ((<>)) +import           Language.Fixpoint.Misc+import           Language.Fixpoint.Types hiding (DataDecl (..), DataCtor (..), panic, shiftVV, Predicate, isNumeric)+import           Language.Fixpoint.Types.Visitor (mapKVars, Visitable) import qualified Language.Fixpoint.Types as F-import Language.Fixpoint.Types hiding (DataDecl (..), DataCtor (..), panic, shiftVV, Predicate, isNumeric)-import Language.Fixpoint.Types.Visitor (mapKVars, Visitable)-import Language.Haskell.Liquid.Types hiding (R, DataConP (..), sort)--import Language.Haskell.Liquid.Types.Variance+import           Language.Haskell.Liquid.Types.Errors+import           Language.Haskell.Liquid.Types.PrettyPrint -import Language.Haskell.Liquid.Misc-import Language.Haskell.Liquid.Types.Names-import Language.Fixpoint.Misc+import           Language.Haskell.Liquid.Types.Types hiding (R, DataConP (..))+import           Language.Haskell.Liquid.Types.Variance+import           Language.Haskell.Liquid.Misc+import           Language.Haskell.Liquid.Types.Names import qualified Language.Haskell.Liquid.GHC.Misc as GM-import Language.Haskell.Liquid.GHC.Play (mapType, stringClassArg) -- , dataConImplicitIds)+import           Language.Haskell.Liquid.GHC.Play (mapType, stringClassArg) -- , dataConImplicitIds)+import qualified Language.Haskell.Liquid.GHC.API        as Ghc   import Data.List (sort, foldl') +++ +++ strengthenDataConType :: (Var, SpecType) -> (Var, SpecType) strengthenDataConType (x, t) = (x, fromRTypeRep trep {ty_res = tres})   where@@ -220,11 +225,22 @@          , SubsTy tv (RType c tv ()) tv          , SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ()))          )+        => Semigroup (RType c tv r)  where+  (<>) = strengthenRefType++-- TODO: remove, use only Semigroup?+instance ( SubsTy tv (RType c tv ()) (RType c tv ())+         , SubsTy tv (RType c tv ()) c+         , OkRT c tv r+         , FreeVar c tv+         , SubsTy tv (RType c tv ()) r+         , SubsTy tv (RType c tv ()) tv+         , SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ()))+         )         => Monoid (RType c tv r)  where   mempty  = panic Nothing "mempty: RType"   mappend = strengthenRefType - -- MOVE TO TYPES instance ( SubsTy tv (RType c tv ()) c          , OkRT c tv r@@ -234,21 +250,32 @@          , SubsTy tv (RType c tv ()) tv          , SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ()))          )-         => Monoid (RTProp c tv r) where-  mempty         = panic Nothing "mempty: RTProp"--  mappend (RProp s1 (RHole r1)) (RProp s2 (RHole r2))+         => Semigroup (RTProp c tv r) where+  (<>) (RProp s1 (RHole r1)) (RProp s2 (RHole r2))     | isTauto r1 = RProp s2 (RHole r2)     | isTauto r2 = RProp s1 (RHole r1)     | otherwise  = RProp s1 $ RHole $ r1 `meet`                                (subst (mkSubst $ zip (fst <$> s2) (EVar . fst <$> s1)) r2) -  mappend (RProp s1 t1) (RProp s2 t2)+  (<>) (RProp s1 t1) (RProp s2 t2)     | isTrivial t1 = RProp s2 t2     | isTrivial t2 = RProp s1 t1     | otherwise    = RProp s1 $ t1  `strengthenRefType`                                 (subst (mkSubst $ zip (fst <$> s2) (EVar . fst <$> s1)) t2) +-- TODO: remove and use only Semigroup?+instance ( SubsTy tv (RType c tv ()) c+         , OkRT c tv r+         , FreeVar c tv+         , SubsTy tv (RType c tv ()) r+         , SubsTy tv (RType c tv ()) (RType c tv ())+         , SubsTy tv (RType c tv ()) tv+         , SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ()))+         )+         => Monoid (RTProp c tv r) where+  mempty  = panic Nothing "mempty: RTProp"+  mappend = (<>)+ {- NV: The following makes ghc diverge thus dublicating the code instance ( OkRT c tv r@@ -522,7 +549,7 @@ bTyVar      = BTV  symbolRTyVar :: Symbol -> RTyVar-symbolRTyVar = rTyVar . GM.stringTyVar . symbolString+symbolRTyVar = rTyVar . GM.symbolTyVar   bareRTyVar :: BTyVar -> RTyVar bareRTyVar (BTV tv) = symbolRTyVar tv@@ -576,6 +603,10 @@ nlzP :: (OkRT c tv r) => [PVar (RType c tv ())] -> RType c tv r -> (RType c tv r, [PVar (RType c tv ())]) nlzP ps t@(RVar _ _ )  = (t, ps)+nlzP ps (RImpF b t1 t2 r)+ = (RImpF b t1' t2' r, ps ++ ps1 ++ ps2)+  where (t1', ps1) = nlzP [] t1+        (t2', ps2) = nlzP [] t2 nlzP ps (RFun b t1 t2 r)  = (RFun b t1' t2' r, ps ++ ps1 ++ ps2)   where (t1', ps1) = nlzP [] t1@@ -635,23 +666,31 @@ pprt_raw :: (OkRT c tv r) => RType c tv r -> String pprt_raw = render . rtypeDoc Full --- NEWISH: with unifying type variables: causes big problems with TUPLES?---strengthenRefType t1 t2 = maybe (errorstar msg) (strengthenRefType_ t1) (unifyShape t1 t2)---  where msg = printf "strengthen on differently shaped reftypes \nt1 = %s [shape = %s]\nt2 = %s [shape = %s]"---                 (render t1) (render (toRSort t1)) (render t2) (render (toRSort t2))+{- [NOTE:StrengthenRefType] disabling the `meetable` check because --- OLD: without unifying type variables, but checking α-equivalence+      (1) It requires the 'TCEmb TyCon' to deal with the fact that sometimes,+          GHC uses the "Family Instance" TyCon e.g. 'R:UniquePerson' and sometimes+          the vanilla TyCon App form, e.g. 'Unique Person'+      (2) We could pass in the TCEmb but that would break the 'Monoid' instance for+          RType. The 'Monoid' instance was was probably a bad idea to begin with,+          and we probably ought to do away with it entirely, but thats a battle I'll+          leave for another day.++    Consequently, its up to users of `strengthenRefType` (and associated functions)+    to make sure that the two types are compatible. For an example, see 'meetVarTypes'.+ -}+ strengthenRefType t1 t2-  | meetable t1 t2+  | True -- _meetable t1 t2   = strengthenRefType_ (\x _ -> x) t1 t2   | otherwise   = panic Nothing msg   where-    msg       = printf "strengthen on differently shaped reftypes \nt1 = %s [shape = %s]\nt2 = %s [shape = %s]"-                  (showpp t1) (showpp (toRSort t1)) (showpp t2) (showpp (toRSort t2))+    msg = printf "strengthen on differently shaped reftypes \nt1 = %s [shape = %s]\nt2 = %s [shape = %s]"+            (showpp t1) (showpp (toRSort t1)) (showpp t2) (showpp (toRSort t2)) -meetable :: (OkRT c tv r) => RType c tv r -> RType c tv r -> Bool-meetable t1 t2 = toRSort t1 == toRSort t2+_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)@@ -692,6 +731,11 @@     where t  = strengthenRefType_ f t1 t2           t' = strengthenRefType_ f t1' t2' +strengthenRefType_ f (RImpF x1 t1 t1' r1) (RImpF x2 t2 t2' r2)+  = RImpF x2 t t' (r1 `meet` r2)+    where t  = strengthenRefType_ f t1 t2+          t' = strengthenRefType_ f (subst1 t1' (x1, EVar x2)) t2'+ strengthenRefType_ f (RFun x1 t1 t1' r1) (RFun x2 t2 t2' r2)   = RFun x2 t t' (r1 `meet` r2)     where t  = strengthenRefType_ f t1 t2@@ -718,6 +762,7 @@ 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 (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 t _                  = t@@ -733,36 +778,34 @@ ------------------------------------------------------------------------- addTyConInfo :: (PPrint r, Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, Reftable (RTProp RTyCon RTyVar r))              => TCEmb TyCon-             -> (M.HashMap TyCon RTyCon)+             -> TyConMap -- (M.HashMap TyCon RTyCon)              -> RRType r              -> RRType r ------------------------------------------------------------------------- addTyConInfo tce tyi = mapBot (expandRApp tce tyi)  --------------------------------------------------------------------------expandRApp :: (PPrint r, Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, Reftable (RTProp RTyCon RTyVar r))-           => TCEmb TyCon-           -> (M.HashMap TyCon RTyCon)-           -> RRType r-           -> RRType r+expandRApp :: (PPrint r, Reftable r, SubsTy RTyVar RSort r, Reftable (RRProp r))+           => TCEmb TyCon -> TyConMap -> RRType r -> RRType r ------------------------------------------------------------------------- expandRApp tce tyi t@(RApp {}) = RApp rc' ts rs' r   where     RApp rc ts rs r            = t-    rc'                        = appRTyCon tce tyi rc as+    (rc', _)                   = appRTyCon tce tyi rc as     pvs                        = rTyConPVs rc'     rs'                        = applyNonNull rs0 (rtPropPV rc pvs) rs     rs0                        = rtPropTop <$> pvs     n                          = length fVs     fVs                        = GM.tyConTyVarsDef $ rtc_tc rc     as                         = choosen n ts (rVar <$> fVs)+expandRApp _ _ t               = t -    choosen 0 _ _           = []-    choosen i (x:xs) (_:ys) = x:choosen (i-1) xs ys-    choosen i []     (y:ys) = y:choosen (i-1) [] ys-    choosen _ _ _           = impossible Nothing "choosen: this cannot happen"+choosen :: Int -> [a] -> [a] -> [a]+choosen 0 _ _           = []+choosen i (x:xs) (_:ys) = x:choosen (i-1) xs ys+choosen i []     (y:ys) = y:choosen (i-1) [] ys+choosen _ _ _           = impossible Nothing "choosen: this cannot happen" -expandRApp _ _ t               = t  rtPropTop   :: (OkRT c tv r,@@ -800,30 +843,115 @@ pvArgs :: PVar t -> [(Symbol, t)] pvArgs pv = [(s, t) | (t, s, _) <- pargs pv] +{- | [NOTE:FamInstPredVars] related to [NOTE:FamInstEmbeds]+     See tests/datacon/pos/T1446.hs +     The function txRefSort converts -appRTyCon :: SubsTy RTyVar (RType c RTyVar ()) RPVar-          => TCEmb TyCon-          -> M.HashMap TyCon RTyCon-          -> RTyCon-          -> [RType c RTyVar r]-          -> RTyCon-appRTyCon tce tyi rc ts = RTyCon c ps' (rtc_info rc'')+        Int<p>              ===> {v:Int | p v}++     which is fine, but also converts++        Field<q> Blob a     ===> {v:Field Blob a | q v}+        +     which is NOT ok, because q expects a different arg.++     The above happens because, thanks to instance-family stuff,+     LH doesn't realize that q is actually an ARG of Field Blob+     Note that Field itself has no args, but Field Blob does...++     That is, it is not enough to store the refined `TyCon` info,+     solely in the `RTyCon` as with family instances, you need BOTH +     the `TyCon` and the args to determine the extra info. +     +     We do so in `TyConMap`, and by crucially extending ++     @RefType.appRTyCon@ whose job is to use the Refined @TyCon@ +     that is, the @RTyCon@ generated from the @TyConP@ to strengthen+     individual occurrences of the TyCon applied to various arguments.++ -}++appRTyCon :: (ToTypeable r) => TCEmb TyCon -> TyConMap -> RTyCon -> [RRType r] -> (RTyCon, [RPVar])+appRTyCon tce tyi rc ts = F.notracepp _msg (resTc, ps'')    where-    c    = rtc_tc rc-    ps'  = subts (zip (RTV <$> αs) ts') <$> rTyConPVs rc'-    ts'  = if null ts then rVar <$> βs else toRSort <$> ts-    rc'  = M.lookupDefault rc c tyi-    αs   = GM.tyConTyVarsDef $ rtc_tc rc'-    βs   = GM.tyConTyVarsDef c-    rc'' = if isNumeric tce rc' then addNumSizeFun rc' else rc'+    _msg  = "appRTyCon-family: " ++ showpp (GHC.isFamilyTyCon c, GHC.tyConArity c, toType <$> ts)+    resTc = RTyCon c ps'' (rtc_info rc'')+    c     = rtc_tc rc+   +    (rc', ps') = rTyConWithPVars tyi rc (rTypeSort tce <$> ts)+    -- TODO:faminst-preds rc'   = M.lookupDefault rc c (tcmTyRTy tyi)+    -- TODO:faminst-preds ps'   = rTyConPVs rc'  +    -- TODO:faminst-preds: these substitutions may be WRONG if we are using FAMINST.+    ps''  = subts (zip (RTV <$> αs) ts') <$> ps' +      where +        ts' = if null ts then rVar <$> βs else toRSort <$> ts+        αs  = GM.tyConTyVarsDef (rtc_tc rc')+        βs  = GM.tyConTyVarsDef c+    +    rc''  = if isNumeric tce rc' then addNumSizeFun rc' else rc' +rTyConWithPVars :: TyConMap -> RTyCon -> [F.Sort] -> (RTyCon, [RPVar])+rTyConWithPVars tyi rc ts = case famInstTyConMb tyi rc ts of +  Just fiRc    -> (rc', rTyConPVs fiRc)       -- use the PVars from the family-instance TyCon+  Nothing      -> (rc', ps')                  -- use the PVars from the origin          TyCon+  where +    (rc', ps') = plainRTyConPVars tyi rc++-- | @famInstTyConMb rc args@ uses the @RTyCon@ AND @args@ to see if +--   this is a family instance @RTyCon@, and if so, returns it.+--   see [NOTE:FamInstPredVars]+--   eg: 'famInstTyConMb tyi Field [Blob, a]' should give 'Just R:FieldBlob' +    +famInstTyConMb :: TyConMap -> RTyCon -> [F.Sort] -> Maybe RTyCon+famInstTyConMb tyi rc ts = do +  let c = rtc_tc rc+  n    <- M.lookup c      (tcmFtcArity tyi)+  M.lookup (c, take n ts) (tcmFIRTy    tyi)++famInstTyConType :: Ghc.TyCon -> Maybe Ghc.Type+famInstTyConType c = uncurry Ghc.mkTyConApp <$> famInstArgs c ++-- | @famInstArgs c@ destructs a family-instance @TyCon@ into its components, e.g. +--   e.g. 'famInstArgs R:FieldBlob' is @(Field, [Blob])@ ++famInstArgs :: Ghc.TyCon -> Maybe (Ghc.TyCon, [Ghc.Type])+famInstArgs c = case Ghc.tyConFamInst_maybe c of+    Just (c', ts) -> F.notracepp ("famInstArgs: " ++ F.showpp (c, cArity, ts)) +                     $ Just (c', take (length ts - cArity) ts) +    Nothing       -> Nothing+    where +      cArity      = Ghc.tyConArity c++-- TODO:faminst-preds: case Ghc.tyConFamInst_maybe c of+-- TODO:faminst-preds:   Just (c', ts) -> F.tracepp ("famInstTyConType: " ++ F.showpp (c, Ghc.tyConArity c, ts)) +-- TODO:faminst-preds:                    $ Just (famInstType (Ghc.tyConArity c) c' ts)+-- TODO:faminst-preds:   Nothing       -> Nothing++-- TODO:faminst-preds: famInstType :: Int -> Ghc.TyCon -> [Ghc.Type] -> Ghc.Type+-- TODO:faminst-preds: famInstType n c ts = Ghc.mkTyConApp c (take (length ts - n) ts)+++++-- | @plainTyConPVars@ uses the @TyCon@ to return the +--   "refined" @RTyCon@ and @RPVars@ from the refined +--   'data' definition for the @TyCon@, e.g. will use +--   'List Int' to return 'List<p> Int' (if List has an abs-ref).+plainRTyConPVars :: TyConMap -> RTyCon -> (RTyCon, [RPVar])+plainRTyConPVars tyi rc = (rc', rTyConPVs rc') +  where +    rc'                   = M.lookupDefault rc (rtc_tc rc) (tcmTyRTy tyi)+++ -- RJ: The code of `isNumeric` is incomprehensible. -- Please fix it to use intSort instead of intFTyCon isNumeric :: TCEmb TyCon -> RTyCon -> Bool isNumeric tce c = mySort == FTC F.intFTyCon || mySort == F.FInt   where-    mySort      = M.lookupDefault def rc tce+    -- mySort      = M.lookupDefault def rc tce+    mySort      = maybe def fst (F.tceLookup rc tce)     def         = FTC . symbolFTycon . dummyLoc . tyConName $ rc     rc          = rtc_tc c @@ -835,10 +963,17 @@ generalize :: (Eq tv) => RType c tv r -> RType c tv r generalize t = mkUnivs (freeTyVars t) [] [] t +allTyVars :: (Ord tv) => RType c tv r -> [tv]+allTyVars t = sortNub . fmap ty_var_value $ vs ++ vs'+  where+    vs      = fst4 . 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 (RImpF _ t t' _)= freeTyVars t `L.union` freeTyVars t' freeTyVars (RFun _ t t' _) = freeTyVars t `L.union` freeTyVars t' freeTyVars (RApp _ ts _ _) = L.nub $ concatMap freeTyVars ts freeTyVars (RVar α _)      = [makeRTVar α]@@ -856,6 +991,7 @@ tyClasses (RAllT _ t)     = tyClasses t tyClasses (RAllE _ _ t)   = tyClasses t tyClasses (REx _ _ t)     = tyClasses t+tyClasses (RImpF _ t t' _) = tyClasses t ++ tyClasses t' tyClasses (RFun _ t t' _) = tyClasses t ++ tyClasses t' tyClasses (RAppTy t t' _) = tyClasses t ++ tyClasses t' tyClasses (RApp c ts _ _)@@ -960,11 +1096,14 @@ subsFree m s z@(a, τ, _) (RAllT α t)   -- subt inside the type variable instantiates the kind of the variable   = RAllT (subt (a, τ) α) $ subsFree m (ty_var_value α `S.insert` s) z t+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)   = RFun x (subsFree m s z t) (subsFree m s z t') (subt (α, τ) r) subsFree m s z@(α, τ, _) (RApp c ts rs r)-  = RApp (subt z' c) (subsFree m s z <$> ts) (subsFreeRef m s z <$> rs) (subt (α, τ) r)+  = RApp c' (subsFree m s z <$> ts) (subsFreeRef m s z <$> rs) (subt (α, τ) r)     where z' = (α, τ) -- UNIFY: why instantiating INSIDE parameters?+          c' = if α `S.member` s then c else subt z' c subsFree meet s (α', τ, t') (RVar α r)   | α == α' && not (α `S.member` s)   = if meet then t' `strengthen` (subt (α, τ) r) else t'@@ -1015,8 +1154,14 @@ subsFreeRAppTy _ _ t t' r'   = RAppTy t t' r' -mkRApp-  :: (Eq tv, Hashable tv, Reftable r, TyConable c,++-- | @mkRApp@ is the refined variant of GHC's @mkTyConApp@ which ensures that +--    that applications of the "function" type constructor are normalized to +--    the special case @FunTy@ representation. The extra `_rep1`, and `_rep2` +--    parameters come from the "levity polymorphism" changes in GHC 8.6 (?)+--    See [NOTE:Levity-Polymorphism]++mkRApp :: (Eq tv, Hashable tv, Reftable r, TyConable c,       SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,       SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,       SubsTy tv (RType c tv ()) tv,@@ -1030,13 +1175,55 @@   -> r   -> RType c tv r mkRApp m s c ts rs r r'-  | isFun c, [t1, t2] <- ts-  = RFun dummySymbol t1 t2 $ refAppTyToFun r'+  | isFun c, [_rep1, _rep2, t1, t2] <- ts+  = RFun dummySymbol t1 t2 (refAppTyToFun r')   | otherwise-  = subsFrees m s zs $ RApp c ts rs $ r `meet` r' -- (refAppTyToApp r')+  = subsFrees m s zs (RApp c ts rs (r `meet` r'))   where     zs = [(tv, toRSort t, t) | (tv, t) <- zip (freeVars c) ts] +{-| [NOTE:Levity-Polymorphism] + +     Thanks to Joachim Brietner and Simon Peyton-Jones!+     With GHC's "levity polymorphism feature", see more here ++         https://stackoverflow.com/questions/35318562/what-is-levity-polymorphism     ++     The function type constructor actually has type++        (->) :: forall (r1::RuntimeRep) (r2::RuntimeRep).  TYPE r1 -> TYPE r2 -> TYPE LiftedRep++     so we have to be careful to follow GHC's @mkTyConApp@ +     +        https://hackage.haskell.org/package/ghc-8.6.4/docs/src/Type.html#mkTyConApp++     which normalizes applications of the `FunTyCon` constructor to use the special +     case `FunTy` representation thus, so that we are not stuck with incompatible +     representations e.g. ++        thing -> thing                                                  ... (using RFun)++     and ++        (-> 'GHC.Types.LiftedRep 'GHC.Types.LiftedRep thing thing)      ... (using RApp)+++     More details from Joachim Brietner:++     Now you might think that the function arrow has the following kind: `(->) :: * -> * -> *`.+     But that is not the full truth: You can have functions that accept or return things with +     different representations than just the usual lifted one.++     So the function arrow actually has kind `(->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> *`.+     And in `(-> 'GHC.Types.LiftedRep 'GHC.Types.LiftedRep thing thing)`  you see this spelled +     out explicitly. But it really is just `(thing -> thing)`, just printed with more low-level detail.++     Also see++       • https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#levity-polymorphism+       • and other links from https://stackoverflow.com/a/35320729/946226 (edited) + -}+ refAppTyToFun :: Reftable r => r -> r refAppTyToFun r   | isTauto r = r@@ -1133,13 +1320,9 @@  instance SubsTy RTyVar RSort Sort where   subt (v, sv) (FObj s)-    | -- rtyVarUniqueSymbol v == s ||-      symbol v == s-    = typeSort M.empty $ toType sv-    | otherwise-    = FObj s-  subt _ s-    = s+    | symbol v == s = typeSort mempty (toType sv)+    | otherwise     = FObj s+  subt _ s          = s  instance (SubsTy tv ty ty) => SubsTy tv ty (PVKind ty) where   subt su (PVProp t) = PVProp (subt su t)@@ -1240,10 +1423,15 @@     go (CoercionTy _)       = errorstar "Coercion is currently not supported" -ofLitType :: (Monoid r) => (TyCon -> [t] -> [p] -> r -> t) -> TyLit -> t-ofLitType rF (NumTyLit _) = rF intTyCon [] [] mempty-ofLitType rF (StrTyLit _) = rF listTyCon [rF charTyCon [] [] mempty] [] mempty+ofLitType :: (Monoid r) => (TyCon -> [RType c tv r] -> [p] -> r -> RType c tv r) -> TyLit -> RType c tv r+ofLitType rF (NumTyLit _)  = rF intTyCon [] [] mempty+ofLitType rF t@(StrTyLit _)+  | t == holeLit           = RHole mempty +  | otherwise              = rF listTyCon [rF charTyCon [] [] mempty] [] mempty +holeLit :: TyLit+holeLit = StrTyLit "$LH_RHOLE"+ data TyConv c tv r = TyConv   { tcFVar  :: TyVar -> RType c tv r   , tcFTVar :: TyVar -> RTVar tv (RType c tv ())@@ -1312,6 +1500,8 @@  -- TODO: remove toType, generalize typeSort toType  :: (ToTypeable r) => RRType r -> Type+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@@ -1339,10 +1529,43 @@   = impossible Nothing $ "CANNOT HAPPEN: RefType.toType called with: " ++ show t toType (RRTy _ _ _ t)   = toType t-toType t-  = impossible Nothing $ "RefType.toType cannot handle: " ++ show t+toType (RHole _)+  = LitTy holeLit  +-- toType t+--  = {- impossible Nothing -} Prelude.error $ "RefType.toType cannot handle: " ++ show t +{- | [NOTE:Hole-Lit]  +We use `toType` to convert RType to GHC.Type to expand any GHC +related type-aliases, e.g. in Bare.Resolve.expandRTypeSynonyms. +If the RType has a RHole then what to do?++We, encode `RHole` as `LitTy "LH_HOLE"` -- which is a bit of +a *hack*. The only saving grace is it is used *temporarily* +and then swiftly turned back into an `RHole` via `ofType` +(after GHC has done its business of expansion).++Of course, we hope this doesn't break any GHC invariants!+See issue #1476 and #1477 ++The other option is to *not* use `toType` on things that have+holes in them, but this seems worse, e.g. because you may define +a plain GHC alias like:++    type ToNat a = a -> Nat ++and then you might write refinement types like:++    {-@ foo :: ToNat {v:_ | 0 <= v} @-}++and we'd want to expand the above to++    {-@ foo :: {v:_ | 0 <= v} -> Nat @-}++and then resolve the hole using the (GHC) type of `foo`.++-}+ -------------------------------------------------------------------------------- -- | Annotations and Solutions ------------------------------------------------- --------------------------------------------------------------------------------@@ -1369,13 +1592,18 @@     f k        = Just $ M.lookupDefault PTop k s  ---------------------------------------------------------------------------------shiftVV :: SpecType -> Symbol -> SpecType+-- shiftVV :: Int -- SpecType -> Symbol -> SpecType+shiftVV :: (TyConable c, F.Reftable (f Reft), Functor f) +        => RType c tv (f Reft) -> Symbol -> RType c tv (f Reft)  -------------------------------------------------------------------------------- shiftVV t@(RApp _ ts rs r) vv'   = t { rt_args  = subst1 ts (rTypeValueVar t, EVar vv') }       { rt_pargs = subst1 rs (rTypeValueVar t, EVar vv') }       { rt_reft  = (`F.shiftVV` vv') <$> r } +shiftVV t@(RImpF _ _ _ r) vv'+  = t { rt_reft = (`F.shiftVV` vv') <$> r }+ shiftVV t@(RFun _ _ _ r) vv'   = t { rt_reft = (`F.shiftVV` vv') <$> r } @@ -1395,11 +1623,11 @@  -- MOVE TO TYPES instance (Show tv, Show ty) => Show (RTAlias tv ty) where-  show (RTA n as xs t p _) =-    printf "type %s %s %s = %s -- defined at %s" (symbolString n)+  show (RTA n as xs t) =+    printf "type %s %s %s = %s" (symbolString n)       (unwords (show <$> as))       (unwords (show <$> xs))-      (show t) (show p)+      (show t)  -------------------------------------------------------------------------------- -- | From Old Fixpoint ---------------------------------------------------------@@ -1410,33 +1638,39 @@     go :: Type -> Sort     go t@(FunTy _ _)    = typeSortFun tce t     go τ@(ForAllTy _ _) = typeSortForAll tce τ-    go (TyConApp c τs)  = fApp (tyConFTyCon tce c) (go <$> τs)+    -- go (TyConApp c τs)  = fApp (tyConFTyCon tce c) (go <$> τs)+    go (TyConApp c τs)  = tyConFTyCon tce c (go <$> τs)     go (AppTy t1 t2)    = fApp (go t1) [go t2]     go (TyVarTy tv)     = tyVarSort tv     go (CastTy t _)     = go t-    go τ                = FObj $ typeUniqueSymbol τ+    go τ                = FObj (typeUniqueSymbol τ) -tyConFTyCon :: M.HashMap TyCon Sort -> TyCon -> Sort-tyConFTyCon tce c = {- tracepp _msg $ -} M.lookupDefault def c tce+tyConFTyCon :: TCEmb TyCon -> TyCon -> [Sort] -> Sort+tyConFTyCon tce c ts = case tceLookup c tce of +                         Just (t, WithArgs) -> t +                         Just (t, NoArgs)   -> fApp t ts  +                         Nothing            -> fApp (fTyconSort niTc) ts    where-    _msg           = "tyConFTyCon c = " ++ show c-    def           = fTyconSort niTc-    niTc          = symbolNumInfoFTyCon (dummyLoc $ tyConName c) (isNumCls c) (isFracCls c)+    niTc             = symbolNumInfoFTyCon (dummyLoc $ tyConName c) (isNumCls c) (isFracCls c)+    -- oldRes           = F.notracepp _msg $ M.lookupDefault def c tce+    -- _msg             = "tyConFTyCon c = " ++ show c ++ "default " ++ show (def, TC.isFamInstTyCon c)  tyVarSort :: TyVar -> Sort-tyVarSort = FObj . symbol -- tyVarUniqueSymbol+tyVarSort = FObj . symbol   typeUniqueSymbol :: Type -> Symbol typeUniqueSymbol = symbol . GM.typeUniqueString  typeSortForAll :: TCEmb TyCon -> Type -> Sort-typeSortForAll tce τ-  = genSort $ typeSort tce tbody-  where genSort t           = foldl (flip FAbs) (sortSubst su t) [0..n-1]-        (as, tbody)         = splitForAllTys τ-        su                  = M.fromList $ zip sas (FVar <$>  [0..])-        sas                 = {- tyVarUniqueSymbol -} symbol <$> as-        n                   = length as+typeSortForAll tce τ  = F.notracepp ("typeSortForall " ++ showpp τ) $ genSort sbody+  where+    sbody             = typeSort tce tbody+    genSort t         = foldl' (flip FAbs) (sortSubst su t) [i..n+i-1]+    (as, tbody)       = F.notracepp ("splitForallTys" ++ GM.showPpr τ) (splitForAllTys τ)+    su                = M.fromList $ zip sas (FVar <$>  [i..])+    sas               = symbol <$> as+    n                 = length as+    i                 = sortAbs sbody + 1  -- RJ: why not make this the Symbolic instance? tyConName :: TyCon -> Symbol@@ -1446,26 +1680,26 @@   | otherwise         = symbol c  typeSortFun :: TCEmb TyCon -> Type -> Sort-typeSortFun tce t -- τ1 τ2-  = mkFFunc 0 sos-  where sos  = typeSort tce <$> τs-        τs   = grabArgs [] t+typeSortFun tce t = mkFFunc 0 sos+  where +    sos           = typeSort tce <$> τs+    τs            = grabArgs [] t  grabArgs :: [Type] -> Type -> [Type] grabArgs τs (FunTy τ1 τ2)   | Just a <- stringClassArg τ1   = grabArgs τs (mapType (\t -> if t == a then stringTy else t) τ2)-  | not $ isClassPred τ1+  | not ( F.notracepp ("isNonArg: " ++ GM.showPpr τ1) $ isNonValueTy τ1)   = grabArgs (τ1:τs) τ2   | otherwise   = grabArgs τs τ2 grabArgs τs τ   = reverse (τ:τs) --- mkDataConIdsTy :: (PPrint r, Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, Reftable (RTProp RTyCon RTyVar r))---                => DataCon -> RType RTyCon RTyVar r -> [(Var, RType RTyCon RTyVar r)]--- mkDataConIdsTy dc t = (`expandProductType` t) <$> dataConImplicitIds dc+isNonValueTy :: Type -> Bool+isNonValueTy t = {- Ghc.isPredTy -} isClassPred t || isEqPred t + expandProductType :: (PPrint r, Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, Reftable (RTProp RTyCon RTyVar r))                   => Var -> RType RTyCon RTyVar r -> RType RTyCon RTyVar r expandProductType x t@@ -1501,10 +1735,12 @@   | isEqual c   = [(symbol a, rTypeSortedReft emb t)] classBinds  emb (RApp c [_, (RVar a _), t] _ _)-  | showpp c == "Data.Type.Equality.~"  -- see [NOTE:type-equality-hack]+  | showpp c == "Data.Type.Equality.~<[]>"  -- see [NOTE:type-equality-hack]   = [(symbol a, rTypeSortedReft emb t)]+  | otherwise +  = notracepp ("CLASSBINDS-0: " ++ showpp c) []  classBinds _ t-  = notracepp ("CLASSBINDS: " ++ showpp (toType t, isEqualityConstr t)) []+  = notracepp ("CLASSBINDS-1: " ++ showpp (toType t, isEqualityConstr t)) []  {- | [NOTE:type-equality-hack] @@ -1676,7 +1912,7 @@ -- now just provide "default" Bivariant for mutually rec types. -- but there should be a finer solution        | mutuallyRecursive c c'-       = concat $ zipWith (goTyConApp pos) (repeat Bivariant) ts+       = concatMap (goTyConApp pos Bivariant) ts        | otherwise        = concat $ zipWith (goTyConApp pos) (makeTyConVariance c') ts @@ -1724,13 +1960,18 @@                     $+$ nest 4 (vcat $ [ "|" <+> pprintTidy k c | c <- tycDCons dd ])  instance PPrint DataCtor where-  pprintTidy k (DataCtor c _   xts Nothing)  = pprintTidy k c <+> braces (ppFields k ", " xts)-  pprintTidy k (DataCtor c ths xts (Just t)) = pprintTidy k c <+> dcolon <+> ppThetas ths <+> (ppFields k "->" xts) <+> "->" <+> pprintTidy k t+  -- pprintTidy k (DataCtor c as _   xts Nothing)  = pprintTidy k c <+> dcolon ppVars as <+> braces (ppFields k ", " xts)+  -- pprintTidy k (DataCtor c as ths xts (Just t)) = pprintTidy k c <+> dcolon <+> ppVars as <+> ppThetas ths <+> (ppFields k " ->" xts) <+> "->" <+> pprintTidy k t+  pprintTidy k (DataCtor c as ths xts t) = pprintTidy k c <+> dcolon <+> ppVars k as <+> ppThetas ths <+> (ppFields k " ->" xts) <+> "->" <+> res      where+      res         = maybe "*" (pprintTidy k) t        ppThetas [] = empty       ppThetas ts = parens (hcat $ punctuate ", " (pprintTidy k <$> ts)) <+> "=>"  +ppVars :: (PPrint a) => Tidy -> [a] -> Doc+ppVars k as = "forall" <+> hcat (punctuate " " (F.pprintTidy k <$> as)) <+> "." + ppFields :: (PPrint k, PPrint v) => Tidy -> Doc -> [(k, v)] -> Doc ppFields k sep kvs = hcat $ punctuate sep (F.pprintTidy k <$> kvs) @@ -1752,5 +1993,3 @@ instance PPrint (RTProp c tv r) => Show (RTProp c tv r) where   show = showpp -instance PPrint REnv where-  pprintTidy k re = "RENV" $+$ pprintTidy k (reLocal re)
− src/Language/Haskell/Liquid/Types/Specifications.hs 
@@ -1,10 +0,0 @@--- | This module contains the LH specifications (assumes) for---   various imported modules.--module Language.Haskell.Liquid.Types.Specifications (specAnchor) where------ | Gross hack, to force dependency and loading of module.-specAnchor :: Int-specAnchor = 7
+ src/Language/Haskell/Liquid/Types/Specs.hs view
@@ -0,0 +1,217 @@+-- | This module contains the top-level structures that hold +--   information about specifications.++{-# LANGUAGE TypeSynonymInstances       #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE RecordWildCards            #-}++module Language.Haskell.Liquid.Types.Specs where ++import           GHC.Generics+import qualified Data.Binary             as B+import qualified Language.Fixpoint.Types as F+import qualified Data.HashSet            as S+import qualified Data.HashMap.Strict     as M+import           Language.Haskell.Liquid.Types.Types +import           Language.Haskell.Liquid.Types.Variance+import           Language.Haskell.Liquid.Types.Bounds +import           Language.Haskell.Liquid.GHC.API +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++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   :: !NameSet               -- ^ `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+  }++-- | @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+  }++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+  }++instance HasConfig GhcSpec where+  getConfig = gsConfig++instance HasConfig GhcInfo where+  getConfig = getConfig . giSpec++data GhcSpecVars = SpVar +  { gsTgtVars    :: ![Var]                        -- ^ Top-level Binders To Verify (empty means ALL binders)+  , gsIgnoreVars :: !(S.HashSet Var)              -- ^ Top-level Binders To NOT Verify (empty means ALL binders)+  , gsLvars      :: !(S.HashSet Var)              -- ^ Variables that should be checked "lazily" in the environment they are used+  , gsCMethods   :: ![Var]                        -- ^ Refined Class methods +  }++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+  , gsInSigs   :: ![(Var, LocSpecType)]           -- ^ Auto generated Signatures+  , gsNewTypes :: ![(TyCon, LocSpecType)]         -- ^ Mapping of 'newtype' type constructors with their refined types.+  , gsDicts    :: !(DEnv Var LocSpecType)            -- ^ Refined Classes from Instances +  , gsMethods  :: ![(Var, MethodType LocSpecType)]   -- ^ Refined Classes from Classes +  , gsTexprs   :: ![(Var, LocSpecType, [F.Located F.Expr])]  -- ^ Lexicographically ordered expressions for termination+  }++data GhcSpecData = SpData +  { gsCtors      :: ![(Var, LocSpecType)]         -- ^ Data Constructor Measure Sigs+  , gsMeas       :: ![(F.Symbol, LocSpecType)]    -- ^ Measure Types eg.  len :: [a] -> Int+  , gsInvariants :: ![(Maybe Var, LocSpecType)]   -- ^ Data type invariants from measure definitions, e.g forall a. {v: [a] | len(v) >= 0}+  , gsIaliases   :: ![(LocSpecType, LocSpecType)] -- ^ Data type invariant aliases +  , gsMeasures   :: ![Measure SpecType DataCon]   -- ^ Measure definitions+  , gsUnsorted   :: ![UnSortedExpr]+  }++data GhcSpecNames = SpNames +  { gsFreeSyms   :: ![(F.Symbol, Var)]            -- ^ List of `Symbol` free in spec and corresponding GHC var, eg. (Cons, Cons#7uz) from tests/pos/ex1.hs+  , gsDconsP     :: ![F.Located DataCon]          -- ^ Predicated Data-Constructors, e.g. see tests/pos/Map.hs+  , gsTconsP     :: ![TyConP]                     -- ^ Predicated Type-Constructors, e.g. see tests/pos/Map.hs+  -- 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+  }++data GhcSpecTerm = SpTerm +  { gsStTerm     :: !(S.HashSet Var)              -- ^ Binders to CHECK by structural termination+  , gsAutosize   :: !(S.HashSet TyCon)            -- ^ Binders to IGNORE during termination checking+  , gsLazy       :: !(S.HashSet Var)              -- ^ Binders to IGNORE during termination checking+  , 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+  }++data GhcSpecLaws = SpLaws +  { gsLawDefs :: !([(Class, [(Var, LocSpecType)])])+  , gsLawInst :: ![LawInstance]+  }++data LawInstance = LawInstance+  { lilName   :: Class+  , liSupers  :: [LocSpecType]+  , lilTyArgs :: [LocSpecType]+  , lilEqus   :: [(VarOrLocSymbol, (VarOrLocSymbol, Maybe LocSpecType))]+  , lilPos    :: SrcSpan+  }  ++type VarOrLocSymbol = Either Var LocSymbol+type 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++data Spec ty bndr  = Spec+  { measures   :: ![Measure ty bndr]              -- ^ User-defined properties for ADTs+  , impSigs    :: ![(F.Symbol, F.Sort)]           -- ^ Imported variables types+  , expSigs    :: ![(F.Symbol, F.Sort)]           -- ^ Exported variables types+  , asmSigs    :: ![(F.LocSymbol, ty)]            -- ^ Assumed (unchecked) types; including reflected signatures+  , sigs       :: ![(F.LocSymbol, ty)]            -- ^ Imported functions and types+  , localSigs  :: ![(F.LocSymbol, ty)]            -- ^ Local type signatures+  , reflSigs   :: ![(F.LocSymbol, ty)]            -- ^ Reflected type signatures+  , invariants :: ![(Maybe F.LocSymbol, ty)]      -- ^ Data type invariants; the Maybe is the generating measure+  , ialiases   :: ![(ty, ty)]                     -- ^ Data type invariants to be checked+  , imports    :: ![F.Symbol]                     -- ^ Loaded spec module names+  , dataDecls  :: ![DataDecl]                     -- ^ Predicated data definitions+  , newtyDecls :: ![DataDecl]                     -- ^ Predicated new type definitions+  , includes   :: ![FilePath]                     -- ^ Included qualifier files+  , aliases    :: ![F.Located (RTAlias F.Symbol BareType)] -- ^ RefType aliases+  , ealiases   :: ![F.Located (RTAlias F.Symbol F.Expr)]   -- ^ Expression aliases+  , embeds     :: !(F.TCEmb F.LocSymbol)                   -- ^ GHC-Tycon-to-fixpoint Tycon map+  , qualifiers :: ![F.Qualifier]                           -- ^ Qualifiers in source/spec files+  , decr       :: ![(F.LocSymbol, [Int])]         -- ^ Information on decreasing arguments+  , lvars      :: !(S.HashSet F.LocSymbol)        -- ^ Variables that should be checked in the environment they are used+  , lazy       :: !(S.HashSet F.LocSymbol)        -- ^ Ignore Termination Check in these Functions+  , reflects   :: !(S.HashSet F.LocSymbol)        -- ^ Binders to reflect+  , autois     :: !(M.HashMap F.LocSymbol (Maybe Int))  -- ^ Automatically instantiate axioms in these Functions with maybe specified fuel+  , hmeas      :: !(S.HashSet F.LocSymbol)        -- ^ Binders to turn into measures using haskell definitions+  , hbounds    :: !(S.HashSet F.LocSymbol)        -- ^ Binders to turn into bounds using haskell definitions+  , inlines    :: !(S.HashSet F.LocSymbol)        -- ^ Binders to turn into logic inline using haskell definitions+  , ignores    :: !(S.HashSet F.LocSymbol)        -- ^ Binders to ignore during checking; that is DON't check the corebind. +  , autosize   :: !(S.HashSet F.LocSymbol)        -- ^ Type Constructors that get automatically sizing info+  , pragmas    :: ![F.Located String]             -- ^ Command-line configurations passed in through source+  , cmeasures  :: ![Measure ty ()]                -- ^ Measures attached to a type-class+  , imeasures  :: ![Measure ty bndr]              -- ^ Mappings from (measure,type) -> measure+  , classes    :: ![RClass ty]                    -- ^ Refined Type-Classes+  , claws      :: ![RClass ty]                    -- ^ Refined Type-Classe Laws+  , termexprs  :: ![(F.LocSymbol, [F.Located F.Expr])] -- ^ Terminating Conditions for functions+  , rinstance  :: ![RInstance ty]+  , ilaws      :: ![RILaws ty]+  , dvariance  :: ![(F.LocSymbol, [Variance])]         -- ^ ? Where do these come from ?!+  , bounds     :: !(RRBEnv ty)+  , defs       :: !(M.HashMap F.LocSymbol F.Symbol)    -- ^ Temporary (?) hack to deal with dictionaries in specifications+                                                       --   see tests/pos/NatClass.hs+  , axeqs      :: ![F.Equation]                        -- ^ Equalities used for Proof-By-Evaluation+  } deriving (Generic, Show)++instance (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)+++isExportedVar :: GhcSrc -> Var -> Bool+isExportedVar info v = n `elemNameSet` ns+  where+    n                = getName v+    ns               = gsExports info++isPLEVar :: GhcSpec -> Var -> Bool +isPLEVar sp x = M.member x (gsAutoInst (gsRefl sp)) ++
src/Language/Haskell/Liquid/Types/Strata.hs view
@@ -9,9 +9,8 @@  import Prelude hiding (error) - import Language.Fixpoint.Types (Symbol)-import Language.Haskell.Liquid.Types hiding (Def, Loc)+import Language.Haskell.Liquid.Types.Types hiding (Def, Loc)  (<:=) :: (Foldable t, Foldable t1) => t Stratum -> t1 Stratum -> Bool s1 <:= s2
+ src/Language/Haskell/Liquid/Types/Types.hs view
@@ -0,0 +1,2437 @@+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE TypeSynonymInstances       #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE TupleSections              #-}++-- | This module should contain all the global type definitions and basic instances.++module Language.Haskell.Liquid.Types.Types (++  -- * Options+    module Language.Haskell.Liquid.UX.Config++  -- * Ghc Information+  , TargetVars   (..)+  , TyConMap     (..)++  -- * F.Located Things+  , F.Located (..)+  , F.dummyLoc++  -- * Symbols+  , F.LocSymbol+  , F.LocText++  -- * Default unknown name+  , F.dummyName+  , F.isDummy++  -- * Bare Type Constructors and Variables+  , BTyCon(..)+  , mkBTyCon+  -- , mkClassBTyCon, mkPromotedBTyCon+  , isClassBTyCon+  , BTyVar(..)++  -- * Refined Type Constructors+  , RTyCon (RTyCon, rtc_tc, rtc_info)+  , TyConInfo(..), defaultTyConInfo+  , rTyConPVs+  , rTyConPropVs+  -- , isClassRTyCon+  , isClassType, isEqType, isRVar, isBool++  -- * Refinement Types+  , RType (..), Ref(..), RTProp, rPropP+  , RTyVar (..)+  , RTAlias (..)+  , OkRT+  , lmapEAlias+  , dropImplicits++  -- * Worlds+  , HSeg (..)+  , World (..)++  -- * Classes describing operations on `RTypes`+  , TyConable (..)+  , SubsTy (..)++  -- * Type Variables+  , RTVar (..), RTVInfo (..)+  , makeRTVar, mapTyVarValue+  , dropTyVarInfo, rTVarToBind++  -- * Predicate Variables+  , PVar (PV, pname, parg, ptype, pargs), isPropPV, pvType+  , PVKind (..)+  , Predicate (..)++  -- * Refinements+  , UReft(..)++  -- * Parse-time entities describing refined data types+  , SizeFun  (..), szFun+  , DataDecl (..)+  , DataName (..), dataNameSymbol+  , DataCtor (..)+  , DataConP (..)+  , HasDataDecl (..), hasDecl+  , DataDeclKind (..)+  , TyConP   (..)++  -- * Pre-instantiated RType+  , RRType, RRProp+  , BRType, BRProp+  , BSort, BPVar+  , RTVU, PVU++  -- * Instantiated RType+  , BareType, PrType+  , SpecType, SpecProp, SpecRTVar+  , SpecRep+  , LocBareType, LocSpecType+  , RSort+  , UsedPVar, RPVar, RReft+  , REnv+  , AREnv (..)++  -- * Constructing & Destructing RTypes+  , RTypeRep(..), fromRTypeRep, toRTypeRep+  , mkArrow, bkArrowDeep, bkArrow, safeBkArrow+  , mkUnivs, bkUniv, bkClass+  , rImpF, rFun, rCls, rRCls++  -- * Manipulating `Predicates`+  , pvars, pappSym, pApp++  -- * Some tests on RTypes+  , isBase+  , isFunTy+  , isTrivial+  , hasHole ++  -- * Traversing `RType`+  , efoldReft, foldReft, foldReft'+  , emapReft, mapReft, mapReftM, mapPropM+  , mapExprReft+  , mapBot, mapBind+  , foldRType+++  -- * ???+  , Oblig(..)+  , ignoreOblig+  , addInvCond++  -- * Inferred Annotations+  , AnnInfo (..)+  , Annot (..)++  -- * Hole Information +  , HoleInfo(..)++  -- * Overall Output+  , Output (..)++  -- * Refinement Hole+  , hole, isHole, hasHoleTy++  -- * Converting To and From Sort+  , ofRSort, toRSort+  , rTypeValueVar+  , rTypeReft+  , stripRTypeBase+  , topRTypeBase++  -- * Class for values that can be pretty printed+  , F.PPrint (..)+  , F.pprint+  , F.showpp++  -- * Printer Configuration+  , PPEnv (..)+  , ppEnv+  , ppEnvShort++  -- * Modules and Imports+  , ModName (..), ModType (..)+  , isSrcImport, isSpecImport, isTarget+  , getModName, getModString, qualifyModName++  -- * Refinement Type Aliases+  , RTEnv (..), BareRTEnv, SpecRTEnv, BareRTAlias, SpecRTAlias+  -- , mapRT, mapRE++  -- * Errors and Error Messages+  , module Language.Haskell.Liquid.Types.Errors+  , Error+  , ErrorResult++  -- * Source information (associated with constraints)+  , Cinfo (..)++  -- * Measures+  , Measure (..)+  , UnSortedExprs, UnSortedExpr+  , MeasureKind (..)+  , CMeasure (..)+  , Def (..)+  , Body (..)+  , MSpec (..)++  -- * Type Classes+  , RClass (..)++  -- * KV Profiling+  , KVKind (..)   -- types of kvars+  , KVProf        -- profile table+  , emptyKVProf   -- empty profile+  , updKVProf     -- extend profile++  -- * Misc+  , mapRTAVars+  , insertsSEnv++  -- * Strata+  , Stratum(..), Strata+  , isSVar+  , getStrata+  , makeDivType, makeFinType++  -- * CoreToLogic+  , LogicMap(..), toLogicMap, eAppWithMap, LMap(..)++  -- * Refined Instances+  , RDEnv, DEnv(..), RInstance(..), RISig(..), RILaws(..)+  , MethodType(..), getMethodType++  -- * Ureftable Instances+  , UReftable(..)++  -- * String Literals+  , liquidBegin, liquidEnd++  , Axiom(..), HAxiom++  -- , rtyVarUniqueSymbol, tyVarUniqueSymbol+  , rtyVarType+  )+  where++-- import qualified ConLike                                as Ghc+-- import           InstEnv+import           Class+import           CoreSyn                                (CoreExpr)+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+import qualified Data.Foldable                          as F+import           Data.Hashable+import qualified Data.HashMap.Strict                    as M+import qualified Data.HashSet                           as S+import           Data.Maybe                             (fromMaybe, mapMaybe)+import           Data.Function                          (on)+import           Data.List                              (foldl', nub)+import           Data.Text                              (Text)+import           Text.PrettyPrint.HughesPJ              hiding (first, (<>)) +import           Text.Printf+import           Language.Fixpoint.Misc++import qualified Language.Fixpoint.Types as F++import           Language.Haskell.Liquid.GHC.Misc+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 Type Constructors+-----------------------------------------------------------------------------+data TyConMap = TyConMap +  { tcmTyRTy    :: M.HashMap TyCon             RTyCon  -- ^ Map from GHC TyCon to RTyCon +  , tcmFIRTy    :: M.HashMap (TyCon, [F.Sort]) RTyCon  -- ^ Map from GHC Family-Instances to RTyCon+  , tcmFtcArity :: M.HashMap TyCon             Int     -- ^ Arity of each Family-Tycon +  }+ ++-----------------------------------------------------------------------------+-- | Printer ----------------------------------------------------------------+-----------------------------------------------------------------------------++data PPEnv = PP +  { ppPs    :: Bool -- ^ print "foralls" and 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+  }+  deriving (Show)++ppEnv :: PPEnv+ppEnv = ppEnvDef +          { ppPs    = True }   +          { ppDebug = True }   -- RJ: needed for resolution, because pp is used for serialization?++{- | [NOTE:ppEnv] For some mysterious reason, `ppDebug` must equal `True`+     or various tests fail e.g. tests/classes/pos/TypeEquality0{0,1}.hs+     Yikes. Find out why!+ -}++ppEnvDef :: PPEnv+ppEnvDef = PP False False False False False++ppEnvShort :: PPEnv -> PPEnv+ppEnvShort pp = pp { ppShort = True }++------------------------------------------------------------------+-- Huh?+------------------------------------------------------------------+type Expr      = F.Expr+type Symbol    = F.Symbol+++-- [NOTE:LIFTED-VAR-SYMBOLS]: Following NOTE:REFLECT-IMPORTS, by default+-- each (lifted) `Var` is mapped to its `Symbol` via the `Symbolic Var`+-- instance. For _generated_ vars, we may want a custom name e.g. see+--   tests/pos/NatClass.hs+-- and we maintain that map in `lmVarSyms` with the `Just s` case.+-- Ideally, this bandaid should be replaced so we don't have these+-- hacky corner cases.++data LogicMap = LM+  { lmSymDefs  :: M.HashMap Symbol LMap        -- ^ Map from symbols to equations they define+  , lmVarSyms  :: M.HashMap Var (Maybe Symbol) -- ^ Map from (lifted) Vars to `Symbol`; see:+                                              --   NOTE:LIFTED-VAR-SYMBOLS and NOTE:REFLECT-IMPORTs+  } deriving (Show)++instance Monoid LogicMap where+  mempty  = LM M.empty M.empty+  mappend = (<>)++instance Semigroup LogicMap where+  LM x1 x2 <> LM y1 y2 = LM (M.union x1 y1) (M.union x2 y2)++data LMap = LMap+  { lmVar  :: F.LocSymbol+  , lmArgs :: [Symbol]+  , lmExpr :: Expr+  }++instance Show LMap where+  show (LMap x xs e) = show x ++ " " ++ show xs ++ "\t |-> \t" ++ show e++toLogicMap :: [(F.LocSymbol, [Symbol], Expr)] -> LogicMap+toLogicMap ls = mempty {lmSymDefs = M.fromList $ map toLMap ls}+  where+    toLMap (x, ys, e) = (F.val x, LMap {lmVar = x, lmArgs = ys, lmExpr = e})++eAppWithMap :: LogicMap -> F.Located Symbol -> [Expr] -> Expr -> Expr+eAppWithMap lmap f es def+  | Just (LMap _ xs e) <- M.lookup (F.val f) (lmSymDefs lmap)+  , length xs == length es+  = F.subst (F.mkSubst $ zip xs es) e+  | Just (LMap _ xs e) <- M.lookup (F.val f) (lmSymDefs lmap)+  , isApp e+  = F.subst (F.mkSubst $ zip xs es) $ dropApp e (length xs - length es)+  | otherwise+  = def++dropApp :: Expr -> Int -> Expr+dropApp e i | i <= 0 = e+dropApp (F.EApp e _) i = dropApp e (i-1)+dropApp _ _          = errorstar "impossible"++isApp :: Expr -> Bool+isApp (F.EApp (F.EVar _) (F.EVar _)) = True+isApp (F.EApp e (F.EVar _))          = isApp e+isApp _                              = False++data TyConP = TyConP+  { tcpLoc          :: !F.SourcePos+  , tcpCon          :: !TyCon+  , tcpFreeTyVarsTy :: ![RTyVar]+  , tcpFreePredTy   :: ![PVar RSort]+  , tcpFreeLabelTy  :: ![Symbol]+  , tcpVarianceTs   :: !VarianceInfo+  , tcpVariancePs   :: !VarianceInfo+  , tcpSizeFun      :: !(Maybe SizeFun)+  } deriving (Generic, Data, Typeable)++instance F.Loc TyConP where+  srcSpan tc = F.SS (tcpLoc tc) (tcpLoc tc)+++-- TODO: just use Located instead of dc_loc, dc_locE+data DataConP = DataConP+  { dcpLoc        :: !F.SourcePos+  , dcpCon        :: !DataCon                -- ^ Corresponding GHC DataCon +  , dcpFreeTyVars :: ![RTyVar]               -- ^ Type parameters+  , dcpFreePred   :: ![PVar RSort]           -- ^ Abstract Refinement parameters+  , dcpFreeLabels :: ![Symbol]               -- ^ ? strata stuff+  , dcpTyConstrs  :: ![SpecType]             -- ^ ? Class constraints (via `dataConStupidTheta`)+  , dcpTyArgs     :: ![(Symbol, SpecType)]   -- ^ Value parameters+  , dcpTyRes      :: !SpecType               -- ^ Result type+  -- , tyData     :: !SpecType               -- ^ The 'generic' ADT, see [NOTE:DataCon-Data]+  , dcpIsGadt     :: !Bool                   -- ^ Was this specified in GADT style (if so, DONT use function names as fields)+  , dcpModule     :: !F.Symbol               -- ^ Which module was this defined in+  , dcpLocE       :: !F.SourcePos+  } deriving (Generic, Data, Typeable)++-- | [NOTE:DataCon-Data] for each 'DataConP' we also+--   store the type of the constructed data. This is+--   *the same as* 'tyRes' for *vanilla* ADTs+--   (e.g. List, Maybe etc.) but may differ for GADTs.+--   For example,+--+--      data Thing a where+--        X  :: Thing Int+--        Y  :: Thing Bool+--+--   Here the 'DataConP' associated with 'X' (resp. 'Y')+--   has 'tyRes' corresponding to 'Thing Int' (resp. 'Thing Bool'),+--   but in both cases, the 'tyData' should be 'Thing a'.+--++instance F.Loc DataConP where+  srcSpan d = F.SS (dcpLoc d) (dcpLocE d)++-- | Which Top-Level Binders Should be Verified+data TargetVars = AllVars | Only ![Var]+++--------------------------------------------------------------------+-- | Abstract Predicate Variables ----------------------------------+--------------------------------------------------------------------++data PVar t = PV+  { pname :: !Symbol+  , ptype :: !(PVKind t)+  , parg  :: !Symbol+  , pargs :: ![(t, Symbol, Expr)]+  } deriving (Generic, Data, Typeable, Show, Functor)++instance Eq (PVar t) where+  pv == pv' = pname pv == pname pv' {- UNIFY: What about: && eqArgs pv pv' -}++instance Ord (PVar t) where+  compare (PV n _ _ _)  (PV n' _ _ _) = compare n n'++instance B.Binary t => B.Binary (PVar t)+instance NFData t   => NFData   (PVar t)++instance Hashable (PVar a) where+  hashWithSalt i (PV n _ _ _) = hashWithSalt i n++pvType :: PVar t -> t+pvType p = case ptype p of+             PVProp t -> t+             PVHProp  -> panic Nothing "pvType on HProp-PVar"++data PVKind t+  = PVProp t+  | PVHProp+  deriving (Generic, Data, Typeable, Functor, F.Foldable, Traversable, Show)++instance B.Binary a => B.Binary (PVKind a)+instance NFData a   => NFData   (PVKind a)+++--------------------------------------------------------------------------------+-- | Predicates ----------------------------------------------------------------+--------------------------------------------------------------------------------++type UsedPVar      = PVar ()++newtype Predicate  = Pr [UsedPVar] deriving (Generic, Data, Typeable)++instance B.Binary Predicate++instance NFData Predicate where+  rnf _ = ()++instance Monoid Predicate where+  mempty  = pdTrue+  mappend = (<>)++instance Semigroup Predicate where+  p <> p' = pdAnd [p, p']++instance Semigroup a => Semigroup (UReft a) where+  MkUReft x y z <> MkUReft x' y' z' = MkUReft (x <> x') (y <> y') (z <> z')++instance (Monoid a) => Monoid (UReft a) where+  mempty  = MkUReft mempty mempty mempty+  mappend = (<>)+++pdTrue :: Predicate+pdTrue         = Pr []++pdAnd :: Foldable t => t Predicate -> Predicate+pdAnd ps       = Pr (nub $ concatMap pvars ps)++pvars :: Predicate -> [UsedPVar]+pvars (Pr pvs) = pvs++instance F.Subable UsedPVar where+  syms pv         = [ y | (_, x, F.EVar y) <- pargs pv, x /= y ]+  subst s pv      = pv { pargs = mapThd3 (F.subst s)  <$> pargs pv }+  substf f pv     = pv { pargs = mapThd3 (F.substf f) <$> pargs pv }+  substa f pv     = pv { pargs = mapThd3 (F.substa f) <$> pargs pv }+++instance F.Subable Predicate where+  syms     (Pr pvs) = concatMap F.syms   pvs+  subst  s (Pr pvs) = Pr (F.subst s  <$> pvs)+  substf f (Pr pvs) = Pr (F.substf f <$> pvs)+  substa f (Pr pvs) = Pr (F.substa f <$> pvs)++instance NFData r => NFData (UReft r)+++newtype BTyVar = BTV Symbol deriving (Show, Generic, Data, Typeable)++newtype RTyVar = RTV TyVar deriving (Generic, Data, Typeable)++instance Eq BTyVar where+  (BTV x) == (BTV y) = x == y++instance Ord BTyVar where+  compare (BTV x) (BTV y) = compare x y++instance IsString BTyVar where+  fromString = BTV . fromString++instance B.Binary BTyVar+instance Hashable BTyVar+instance NFData   BTyVar+instance NFData   RTyVar++instance F.Symbolic BTyVar where+  symbol (BTV tv) = tv++instance F.Symbolic RTyVar where+  symbol (RTV tv) = F.symbol tv -- tyVarUniqueSymbol tv++-- instance F.Symbolic RTyVar where+  -- symbol (RTV tv) = F.symbol . getName $ tv+-- rtyVarUniqueSymbol  :: RTyVar -> Symbol+-- rtyVarUniqueSymbol (RTV tv) = tyVarUniqueSymbol tv+-- tyVarUniqueSymbol :: TyVar -> Symbol+-- tyVarUniqueSymbol tv = F.symbol $ show (getName tv) ++ "_" ++ show (varUnique tv)++data BTyCon = BTyCon+  { btc_tc    :: !F.LocSymbol    -- ^ TyCon name with location information+  , btc_class :: !Bool           -- ^ Is this a class type constructor?+  , btc_prom  :: !Bool           -- ^ Is Promoted Data Con?+  }+  deriving (Generic, Data, Typeable)++instance B.Binary BTyCon++data RTyCon = RTyCon+  { rtc_tc    :: TyCon         -- ^ GHC Type Constructor+  , rtc_pvars :: ![RPVar]      -- ^ Predicate Parameters+  , rtc_info  :: !TyConInfo    -- ^ TyConInfo+  }+  deriving (Generic, Data, Typeable)++instance F.Symbolic RTyCon where+  symbol = F.symbol . rtc_tc ++instance F.Symbolic BTyCon where+  symbol = F.val . btc_tc++instance NFData BTyCon++instance NFData RTyCon++rtyVarType :: RTyVar -> Type+rtyVarType (RTV v) = TyVarTy v++mkBTyCon :: F.LocSymbol -> BTyCon+mkBTyCon x = BTyCon x False False+++-- | Accessors for @RTyCon@++isBool :: RType RTyCon t t1 -> Bool+isBool (RApp (RTyCon{rtc_tc = c}) _ _ _) = c == boolTyCon+isBool _                                 = False++isRVar :: RType c tv r -> Bool+isRVar (RVar _ _) = True+isRVar _          = False++isClassBTyCon :: BTyCon -> Bool+isClassBTyCon = btc_class++-- isClassRTyCon :: RTyCon -> Bool+-- isClassRTyCon x = (isClassTyCon $ rtc_tc x) || (rtc_tc x == eqPrimTyCon)++rTyConPVs :: RTyCon -> [RPVar]+rTyConPVs     = rtc_pvars++rTyConPropVs :: RTyCon -> [PVar RSort]+rTyConPropVs  = filter isPropPV . rtc_pvars++isPropPV :: PVar t -> Bool+isPropPV      = isProp . ptype++isEqType :: TyConable c => RType c t t1 -> Bool+isEqType (RApp c _ _ _) = isEqual c+isEqType _              = False+++isClassType :: TyConable c => RType c t t1 -> Bool+isClassType (RApp c _ _ _) = isClass c+isClassType _              = False++-- rTyConPVHPs = filter isHPropPV . rtc_pvars+-- isHPropPV   = not . isPropPV++isProp :: PVKind t -> Bool+isProp (PVProp _) = True+isProp _          = False+++defaultTyConInfo :: TyConInfo+defaultTyConInfo = TyConInfo [] [] Nothing++instance Default TyConInfo where+  def = defaultTyConInfo+++-----------------------------------------------------------------------+-- | Co- and Contra-variance for TyCon --------------------------------+-----------------------------------------------------------------------++-- | Indexes start from 0 and type or predicate arguments can be both+--   covariant and contravaariant e.g., for the below Foo dataType+--+--     data Foo a b c d <p :: b -> Prop, q :: Int -> Prop, r :: a -> Prop>+--       = F (a<r> -> b<p>) | Q (c -> a) | G (Int<q> -> a<r>)+--+--  there will be:+--+--    varianceTyArgs     = [Bivariant , Covariant, Contravatiant, Invariant]+--    variancePsArgs     = [Covariant, Contravatiant, Bivariant]+--++data TyConInfo = TyConInfo+  { varianceTyArgs  :: !VarianceInfo      -- ^ variance info for type variables+  , variancePsArgs  :: !VarianceInfo      -- ^ variance info for predicate variables+  , sizeFunction    :: !(Maybe SizeFun)   -- ^ logical UNARY function that computes the size of the structure+  } deriving (Generic, Data, Typeable)++instance NFData TyConInfo++instance Show TyConInfo where+  show (TyConInfo x y _) = show x ++ "\n" ++ show y++--------------------------------------------------------------------------------+-- | Unified Representation of Refinement Types --------------------------------+--------------------------------------------------------------------------------++type RTVU c tv = RTVar tv (RType c tv ())+type PVU  c tv = PVar     (RType c tv ())++instance Show tv => Show (RTVU c tv) where+  show (RTVar t _) = show t++data RType c tv r+  = RVar {+      rt_var    :: !tv+    , rt_reft   :: !r+    }++  | RFun  {+      rt_bind   :: !Symbol+    , rt_in     :: !(RType c tv r)+    , rt_out    :: !(RType c tv r)+    , rt_reft   :: !r+    }++  | RImpF  {+      rt_bind   :: !Symbol+    , rt_in     :: !(RType c tv r)+    , rt_out    :: !(RType c tv r)+    , rt_reft   :: !r+    }++  | RAllT {+      rt_tvbind :: !(RTVU c tv) -- RTVar tv (RType c tv ()))+    , rt_ty     :: !(RType c tv r)+    }++  -- | "forall x y <z :: Nat, w :: Int> . TYPE"+  --               ^^^^^^^^^^^^^^^^^^^ (rt_pvbind)+  | RAllP {+      rt_pvbind :: !(PVU c tv)  -- ar (RType c tv ()))+    , 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 `[]`.+  | RApp  {+      rt_tycon  :: !c+    , rt_args   :: ![RType  c tv r]+    , rt_pargs  :: ![RTProp c tv r]+    , rt_reft   :: !r+    }++  | RAllE {+      rt_bind   :: !Symbol+    , rt_allarg :: !(RType c tv r)+    , rt_ty     :: !(RType c tv r)+    }++  | REx {+      rt_bind   :: !Symbol+    , rt_exarg  :: !(RType c tv r)+    , rt_ty     :: !(RType c tv r)+    }++  | RExprArg (F.Located Expr)                   -- ^ For expression arguments to type aliases+                                                --   see tests/pos/vector2.hs+  | RAppTy{+      rt_arg   :: !(RType c tv r)+    , rt_res   :: !(RType c tv r)+    , rt_reft  :: !r+    }++  | RRTy  {+      rt_env   :: ![(Symbol, RType c tv r)]+    , rt_ref   :: !r+    , rt_obl   :: !Oblig+    , rt_ty    :: !(RType c tv r)+    }++  | RHole r -- ^ let LH match against the Haskell type and add k-vars, e.g. `x:_`+            --   see tests/pos/Holes.hs+  deriving (Generic, Data, Typeable, Functor)++instance (B.Binary c, B.Binary tv, B.Binary r) => B.Binary (RType c tv r)+instance (NFData c, NFData tv, NFData r)       => NFData (RType c tv r)++ignoreOblig :: RType t t1 t2 -> RType t t1 t2+ignoreOblig (RRTy _ _ _ t) = t+ignoreOblig t              = t++dropImplicits :: RType c tv r -> RType c tv r+dropImplicits (RImpF _ _ o _) = dropImplicits o+dropImplicits (RFun  x 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 (RApp c as ps r) = RApp c (dropImplicits <$> as) (dropImplicitsRP <$> ps) r+dropImplicits (RAllE p t t') = RAllE p (dropImplicits t) (dropImplicits t')+dropImplicits (REx s t t')   = REx   s (dropImplicits t) (dropImplicits t')+dropImplicits (RAppTy t t' r)   = RAppTy (dropImplicits t) (dropImplicits t') r+dropImplicits (RRTy e r o t) = RRTy (second dropImplicits <$> e) r o (dropImplicits t)+dropImplicits t = t++dropImplicitsRP :: RTProp c tv r -> RTProp c tv r+dropImplicitsRP (RProp as b) = RProp (second dropImplicits <$> as) (dropImplicits b)+++makeRTVar :: tv -> RTVar tv s+makeRTVar a = RTVar a RTVNoInfo++instance (Eq tv) => Eq (RTVar tv s) where+  t1 == t2 = (ty_var_value t1) == (ty_var_value t2)++data RTVar tv s = RTVar+  { ty_var_value :: tv+  , ty_var_info  :: RTVInfo s+  } deriving (Generic, Data, Typeable)++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}++data RTVInfo s+  = RTVNoInfo+  | RTVInfo { rtv_name   :: Symbol+            , rtv_kind   :: s+            , rtv_is_val :: Bool+            } deriving (Generic, Data, Typeable, Functor)+++rTVarToBind :: RTVar RTyVar s  -> Maybe (Symbol, s)+rTVarToBind = go . ty_var_info+  where+    go (RTVInfo {..}) | rtv_is_val = Just (rtv_name, rtv_kind)+    go _                           = Nothing++ty_var_is_val :: RTVar tv s -> Bool+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++instance (B.Binary tv, B.Binary s) => B.Binary (RTVar tv s)+instance (NFData tv, NFData s)     => NFData   (RTVar tv s)+instance (NFData s)                => NFData   (RTVInfo s)+instance (B.Binary s)              => B.Binary (RTVInfo s)++-- | @Ref@ describes `Prop τ` and `HProp` arguments applied to type constructors.+--   For example, in [a]<{\h -> v > h}>, we apply (via `RApp`)+--   * the `RProp`  denoted by `{\h -> v > h}` to+--   * the `RTyCon` denoted by `[]`.+--   Thus, @Ref@ is used for abstract-predicate (arguments) that are associated+--   with _type constructors_ i.e. whose semantics are _dependent upon_ the data-type.+--   In contrast, the `Predicate` argument in `ur_pred` in the @UReft@ applies+--   directly to any type and has semantics _independent of_ the data-type.++data Ref τ t = RProp+  { rf_args :: [(Symbol, τ)]+  , rf_body :: t -- ^ Abstract refinement associated with `RTyCon`+  } deriving (Generic, Data, Typeable, Functor)++instance (B.Binary τ, B.Binary t) => B.Binary (Ref τ t)+instance (NFData τ,   NFData t)   => NFData   (Ref τ t)++rPropP :: [(Symbol, τ)] -> r -> Ref τ (RType c tv r)+rPropP τ r = RProp τ (RHole r)++-- | @RTProp@ is a convenient alias for @Ref@ that will save a bunch of typing.+--   In general, perhaps we need not expose @Ref@ directly at all.+type RTProp c tv r = Ref (RType c tv ()) (RType c tv r)+++-- | A @World@ is a Separation Logic predicate that is essentially a sequence of binders+--   that satisfies two invariants (TODO:LIQUID):+--   1. Each `hs_addr :: Symbol` appears at most once,+--   2. There is at most one `HVar` in a list.++newtype World t = World [HSeg t]+                deriving (Generic, Data, Typeable)++data    HSeg  t = HBind {hs_addr :: !Symbol, hs_val :: t}+                | HVar UsedPVar+                deriving (Generic, Data, Typeable)++data UReft r = MkUReft+  { ur_reft   :: !r+  , ur_pred   :: !Predicate+  , ur_strata :: !Strata+  }+  deriving (Generic, Data, Typeable, Functor, Foldable, Traversable)++instance B.Binary r => B.Binary (UReft r)++type BRType      = RType BTyCon BTyVar       -- ^ "Bare" parsed version+type RRType      = RType RTyCon RTyVar       -- ^ "Resolved" version+type RRep        = RTypeRep RTyCon RTyVar+type BSort       = BRType    ()+type RSort       = RRType    ()+type BPVar       = PVar      BSort+type RPVar       = PVar      RSort+type RReft       = UReft     F.Reft+type PrType      = RRType    Predicate+type BareType    = BRType    RReft+type SpecType    = RRType    RReft+type SpecRep     = RRep      RReft+type SpecProp    = RRProp    RReft+type RRProp r    = Ref       RSort (RRType r)+type BRProp r    = Ref       BSort (BRType r)+type SpecRTVar   = RTVar     RTyVar RSort ++++type LocBareType = F.Located BareType+type LocSpecType = F.Located SpecType++type SpecRTEnv   = RTEnv RTyVar SpecType +type BareRTEnv   = RTEnv Symbol BareType +type BareRTAlias = RTAlias Symbol BareType +type SpecRTAlias = RTAlias RTyVar SpecType+++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++class (Eq c) => TyConable c where+  isFun    :: c -> Bool+  isList   :: c -> Bool+  isTuple  :: c -> Bool+  ppTycon  :: c -> Doc+  isClass  :: c -> Bool+  isEqual  :: c -> Bool++  isNumCls  :: c -> Bool+  isFracCls :: c -> Bool++  isClass   = const False+  isEqual   = const False+  isNumCls  = const False+  isFracCls = const False+++-- Should just make this a @Pretty@ instance but its too damn tedious+-- to figure out all the constraints.++type OkRT c tv r = ( TyConable c+                   , F.PPrint tv, F.PPrint c, F.PPrint r+                   , F.Reftable r, F.Reftable (RTProp c tv ()), F.Reftable (RTProp c tv r)+                   , Eq c, Eq tv+                   , Hashable tv+                   )++-------------------------------------------------------------------------------+-- | TyConable Instances -------------------------------------------------------+-------------------------------------------------------------------------------++instance TyConable RTyCon where+  isFun      = isFunTyCon . rtc_tc+  isList     = (listTyCon ==) . rtc_tc+  isTuple    = TyCon.isTupleTyCon   . rtc_tc+  isClass    = isClass . rtc_tc -- isClassRTyCon+  isEqual    = isEqual . rtc_tc+  ppTycon    = F.toFix++  isNumCls c  = maybe False (isClassOrSubClass isNumericClass)+                (tyConClass_maybe $ rtc_tc c)+  isFracCls c = maybe False (isClassOrSubClass isFractionalClass)+                (tyConClass_maybe $ rtc_tc c)+++instance TyConable TyCon where+  isFun      = isFunTyCon+  isList     = (listTyCon ==)+  isTuple    = TyCon.isTupleTyCon+  isClass c  = isClassTyCon c   || isEqual c -- c == eqPrimTyCon+  isEqual c  = c == eqPrimTyCon || c == eqReprPrimTyCon+  ppTycon    = text . showPpr++  isNumCls c  = maybe False (isClassOrSubClass isNumericClass)+                (tyConClass_maybe $ c)+  isFracCls c = maybe False (isClassOrSubClass isFractionalClass)+                (tyConClass_maybe $ c)+++isClassOrSubClass :: (Class -> Bool) -> Class -> Bool+isClassOrSubClass p cls+  = p cls || any (isClassOrSubClass p . fst)+                 (mapMaybe getClassPredTys_maybe (classSCTheta cls))++-- MOVE TO TYPES+instance TyConable Symbol where+  isFun   s = F.funConName == s+  isList  s = F.listConName == s+  isTuple s = F.tupConName == s+  ppTycon   = text . F.symbolString++instance TyConable F.LocSymbol where+  isFun   = isFun   . F.val+  isList  = isList  . F.val+  isTuple = isTuple . F.val+  ppTycon = ppTycon . F.val++instance TyConable BTyCon where+  isFun   = isFun . btc_tc+  isList  = isList . btc_tc+  isTuple = isTuple . btc_tc+  isClass = isClassBTyCon+  ppTycon = ppTycon . btc_tc+++instance Eq RTyCon where+  x == y = rtc_tc x == rtc_tc y++instance Eq BTyCon where+  x == y = btc_tc x == btc_tc y++instance Ord BTyCon where +  compare x y = compare (btc_tc x) (btc_tc y)++instance F.Fixpoint RTyCon where+  toFix (RTyCon c _ _) = text $ showPpr c++instance F.Fixpoint BTyCon where+  toFix = text . F.symbolString . F.val . btc_tc++instance F.Fixpoint Cinfo where+  toFix = text . showPpr . ci_loc++instance F.PPrint RTyCon where+  pprintTidy k c +    | ppDebug ppEnv = F.pprintTidy k tc  <-> (angleBrackets $ F.pprintTidy k pvs)+    | otherwise     = text . showPpr . rtc_tc $ c+    where +      tc            = F.symbol (rtc_tc c) +      pvs           = rtc_pvars c ++instance F.PPrint BTyCon where+  pprintTidy _ = text . F.symbolString . F.val . btc_tc++instance F.PPrint v => F.PPrint (RTVar v s) where+  pprintTidy k (RTVar x _) = F.pprintTidy k x++instance Show RTyCon where+  show = F.showpp++instance Show BTyCon where+  show = F.showpp++instance F.Loc BTyCon where +  srcSpan = F.srcSpan . btc_tc ++--------------------------------------------------------------------------------+-- | Refined Instances ---------------------------------------------------------+--------------------------------------------------------------------------------++data RInstance t = RI+  { riclass :: BTyCon+  , ritype  :: [t]+  , risigs  :: [(F.LocSymbol, RISig t)]+  } deriving (Generic, Functor, Data, Typeable, Show)++data RILaws ty = RIL+  { rilName    :: BTyCon+  , rilSupers  :: [ty]+  , rilTyArgs  :: [ty]+  , rilEqus    :: [(F.LocSymbol, F.LocSymbol)]+  , rilPos     :: F.Located ()+  } deriving (Show, Functor, Data, Typeable, Generic)++data RISig t = RIAssumed t | RISig t+  deriving (Generic, Functor, Data, Typeable, Show)++instance F.PPrint t => F.PPrint (RISig t) where+  pprintTidy k = ppRISig k (empty :: Doc) ++ppRISig :: (F.PPrint k, F.PPrint t) => F.Tidy -> k -> RISig t -> Doc+ppRISig k x (RIAssumed t) = "assume" <+> F.pprintTidy k x <+> "::" <+> F.pprintTidy k t +ppRISig k x (RISig t)     =              F.pprintTidy k x <+> "::" <+> F.pprintTidy k t ++instance F.PPrint t => F.PPrint (RInstance t) where+  pprintTidy k (RI n ts mts) = ppMethods k "instance" n ts mts ++  +instance (B.Binary t) => B.Binary (RInstance t)+instance (B.Binary t) => B.Binary (RISig t)+instance (B.Binary t) => B.Binary (RILaws t)++newtype DEnv x ty = DEnv (M.HashMap x (M.HashMap Symbol (RISig ty)))+                    deriving (Semigroup, Monoid, Show, Functor)++type RDEnv = DEnv Var SpecType++data MethodType t = MT {tyInstance :: !(Maybe t), tyClass :: !(Maybe t) }+  deriving (Show)++getMethodType :: MethodType t -> Maybe t +getMethodType (MT (Just t) _ ) = Just t +getMethodType (MT _ t) = t ++--------------------------------------------------------------------------+-- | Values Related to Specifications ------------------------------------+--------------------------------------------------------------------------++data Axiom b s e = Axiom+  { aname  :: (Var, Maybe DataCon)+  , rname  :: Maybe b+  , abinds :: [b]+  , atypes :: [s]+  , alhs   :: e+  , arhs   :: e+  }++type HAxiom = Axiom Var    Type CoreExpr++-- type AxiomEq = F.Equation++instance Show (Axiom Var Type CoreExpr) where+  show (Axiom (n, c) v bs _ts lhs rhs) = "Axiom : " +++                                         "\nFun Name: " ++ (showPpr n) +++                                         "\nReal Name: " ++ (showPpr v) +++                                         "\nData Con: " ++ (showPpr c) +++                                         "\nArguments:" ++ (showPpr bs)  +++                                         -- "\nTypes    :" ++ (showPpr ts)  +++                                         "\nLHS      :" ++ (showPpr lhs) +++                                         "\nRHS      :" ++ (showPpr rhs)++--------------------------------------------------------------------------------+-- | Data type refinements+--------------------------------------------------------------------------------+data DataDecl   = DataDecl+  { tycName   :: DataName              -- ^ Type  Constructor Name+  , tycTyVars :: [Symbol]              -- ^ Tyvar Parameters+  , tycPVars  :: [PVar BSort]          -- ^ PVar  Parameters+  , 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)++-- | The name of the `TyCon` corresponding to a `DataDecl`+data DataName+  = DnName !F.LocSymbol                -- ^ for 'isVanillyAlgTyCon' we can directly use the `TyCon` name+  | DnCon  !F.LocSymbol                -- ^ for 'FamInst' TyCon we save some `DataCon` name+  deriving (Eq, Ord, Data, Typeable, Generic)++-- | Data Constructor+data DataCtor = DataCtor+  { dcName   :: F.LocSymbol            -- ^ DataCon name+  , dcTyVars :: [F.Symbol]             -- ^ Type parameters+  , dcTheta  :: [BareType]             -- ^ The GHC ThetaType corresponding to DataCon.dataConSig+  , dcFields :: [(Symbol, BareType)]   -- ^ field-name and field-Type pairs +  , dcResult :: Maybe BareType         -- ^ Possible output (if in GADT form)+  } deriving (Data, Typeable, Generic)++-- | Termination expressions+data SizeFun+  = IdSizeFun              -- ^ \x -> F.EVar x+  | SymSizeFun F.LocSymbol -- ^ \x -> f x+  deriving (Data, Typeable, Generic)++-- | 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)++instance Show SizeFun where+  show IdSizeFun      = "IdSizeFun"+  show (SymSizeFun x) = "SymSizeFun " ++ show (F.val x)++szFun :: SizeFun -> Symbol -> Expr+szFun IdSizeFun      = F.EVar+szFun (SymSizeFun f) = \x -> F.mkEApp (F.symbol <$> f) [F.EVar x]++data HasDataDecl+  = NoDecl  (Maybe SizeFun)+  | HasDecl+  deriving (Show)++instance F.PPrint HasDataDecl where+  pprintTidy _ HasDecl    = text "HasDecl"+  pprintTidy k (NoDecl z) = text "NoDecl" <+> parens (F.pprintTidy k z)++hasDecl :: DataDecl -> HasDataDecl+hasDecl d+  | null (tycDCons d)+  = NoDecl (tycSFun d)+  -- // | Just s <- tycSFun d, null (tycDCons d)+  -- // = NoDecl (Just s)+  | otherwise+  = HasDecl++instance Hashable DataName where+  hashWithSalt i = hashWithSalt i . F.symbol+++instance NFData   SizeFun+instance B.Binary SizeFun+instance NFData   DataDeclKind+instance B.Binary DataDeclKind+instance B.Binary DataName+instance B.Binary DataCtor+instance B.Binary DataDecl++instance Eq DataDecl where+  d1 == d2 = tycName d1 == tycName d2++instance Ord DataDecl where+  compare d1 d2 = compare (tycName d1) (tycName d2)++instance F.Loc DataCtor where+  srcSpan = F.srcSpan . dcName++instance F.Loc DataDecl where+  srcSpan = srcSpanFSrcSpan . sourcePosSrcSpan . tycSrcPos++instance F.Loc DataName where+  srcSpan (DnName z) = F.srcSpan z+  srcSpan (DnCon  z) = F.srcSpan z+++-- | For debugging.+instance Show DataDecl where+  show dd = printf "DataDecl: data = %s, tyvars = %s, sizeFun = %s, kind = %s" -- [at: %s]"+              (show $ tycName   dd)+              (show $ tycTyVars dd)+              (show $ tycSFun   dd)+              (show $ tycKind   dd)+++instance Show DataName where+  show (DnName n) =               show (F.val n)+  show (DnCon  c) = "datacon:" ++ show (F.val c)++instance F.PPrint SizeFun where+  pprintTidy _ (IdSizeFun)    = "[id]"+  pprintTidy _ (SymSizeFun x) = brackets (F.pprint (F.val x))++instance F.Symbolic DataName where+  symbol = F.val . dataNameSymbol++instance F.Symbolic DataDecl where+  symbol = F.symbol . tycName++instance F.PPrint DataName where+  pprintTidy k (DnName n) = F.pprintTidy k (F.val n)+  pprintTidy k (DnCon  n) = F.pprintTidy k (F.val n)++  -- symbol (DnName z) = F.suffixSymbol "DnName" (F.val z)+  -- symbol (DnCon  z) = F.suffixSymbol "DnCon"  (F.val z)++dataNameSymbol :: DataName -> F.LocSymbol+dataNameSymbol (DnName z) = z+dataNameSymbol (DnCon  z) = z++--------------------------------------------------------------------------------+-- | Refinement Type Aliases+--------------------------------------------------------------------------------+data RTAlias x a = RTA+  { rtName  :: Symbol             -- ^ name of the alias+  , rtTArgs :: [x]                -- ^ type parameters+  , rtVArgs :: [Symbol]           -- ^ value parameters+  , rtBody  :: a                  -- ^ what the alias expands to+  -- , rtMod   :: !ModName           -- ^ module where alias was defined+  } deriving (Data, Typeable, Generic, Functor)+-- TODO support ghosts in aliases?++instance (B.Binary x, B.Binary a) => B.Binary (RTAlias x a)++mapRTAVars :: (a -> b) -> RTAlias a ty -> RTAlias b ty+mapRTAVars f rt = rt { rtTArgs = f <$> rtTArgs rt }++lmapEAlias :: LMap -> F.Located (RTAlias Symbol Expr)+lmapEAlias (LMap v ys e) = F.atLoc v (RTA (F.val v) [] ys e) -- (F.loc v) (F.loc v)+++--------------------------------------------------------------------------------+-- | Constructor and Destructors for RTypes ------------------------------------+--------------------------------------------------------------------------------+data RTypeRep c tv r = RTypeRep+  { ty_vars   :: [RTVar tv (RType c tv ())]+  , ty_preds  :: [PVar (RType c tv ())]+  , ty_labels :: [Symbol]+  , ty_ebinds  :: [Symbol]+  , ty_erefts  :: [r]+  , ty_eargs   :: [RType c tv r]+  , ty_binds  :: [Symbol]+  , ty_refts  :: [r]+  , ty_args   :: [RType c tv r]+  , ty_res    :: (RType c tv r)+  }++fromRTypeRep :: RTypeRep c tv r -> RType c tv r+fromRTypeRep (RTypeRep {..})+  = mkArrow ty_vars ty_preds ty_labels earrs arrs ty_res+  where+    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''+  where+    (αs, πs, ls, t')  = bkUniv  t+    ((xs',ts',rs'),(xs, ts, rs), t'') = bkArrow t'++mkArrow :: [RTVar tv (RType c tv ())]+        -> [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+  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 (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)++bkArrow :: RType t t1 a -> ( ([Symbol], [RType t t1 a], [a])+                           , ([Symbol], [RType t t1 a], [a])+                           , RType t t1 a )+bkArrow t                = ((xs,ts,rs),(xs',ts',rs'),t'')+  where +    (xs, ts, rs, t')     = bkImp t+    (xs', ts', rs', t'') = bkFun t'+++bkFun :: RType t t1 a -> ([Symbol], [RType t t1 a], [a], RType t t1 a)+bkFun (RFun x t t' r) = let (xs, ts, rs, t'') = bkFun t'  in (x:xs, t:ts, r:rs, t'')+bkFun t               = ([], [], [], t)++bkImp :: RType t t1 a -> ([Symbol], [RType t t1 a], [a], RType t t1 a)+bkImp (RImpF x t t' r) = let (xs, ts, rs, t'') = bkImp t'  in (x:xs, t:ts, r:rs, t'')+bkImp t                = ([], [], [], t)++safeBkArrow ::(F.PPrint (RType t t1 a)) +            => 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++mkUnivs :: (Foldable t, Foldable t1, Foldable t2)+        => t  (RTVar tv (RType c tv ()))+        -> 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++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)++bkClass :: (F.PPrint c, TyConable c) => RType c tv r -> ([(c, [RType c tv r])], RType c tv r)+bkClass (RImpF _ (RApp c t _ _) t' _)+  | isClass c+  = let (cs, t'') = bkClass t' in ((c, t):cs, t'')+bkClass (RFun _ (RApp c t _ _) t' _)+  | F.notracepp ("IS-CLASS: " ++ F.showpp c) $ isClass c+  = let (cs, t'') = bkClass t' in ((c, t):cs, t'')+bkClass (RRTy e r o t)+  = let (cs, t') = bkClass t in (cs, RRTy e r o t')+bkClass t+  = ([], t)++rImpF :: Monoid r => Symbol -> RType c tv r -> RType c tv r -> RType c tv r+rImpF b t t' = RImpF b t t' mempty++rFun :: Monoid r => Symbol -> RType c tv r -> RType c tv r -> RType c tv r+rFun b t t' = RFun b t t' mempty++rCls :: Monoid r => TyCon -> [RType RTyCon tv r] -> RType RTyCon tv r+rCls c ts   = RApp (RTyCon c [] defaultTyConInfo) ts [] mempty++rRCls :: Monoid r => c -> [RType c tv r] -> RType c tv r+rRCls rc ts = RApp rc ts [] mempty++addInvCond :: SpecType -> RReft -> SpecType+addInvCond t r'+  | F.isTauto $ ur_reft r' -- null rv+  = t+  | otherwise+  = fromRTypeRep $ trep {ty_res = RRTy [(x', tbd)] r OInv tbd}+  where+    trep = toRTypeRep t+    tbd  = ty_res trep+    r    = r' {ur_reft = F.Reft (v, rx)}+    su   = (v, F.EVar x')+    x'   = "xInv"+    rx   = F.PIff (F.EVar v) $ F.subst1 rv su+    F.Reft(v, rv) = ur_reft r'++-------------------------------------------++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+++instance UReftable (UReft F.Reft) where+   ofUReft r = r++instance UReftable () where+   ofUReft _ = mempty++instance (F.PPrint r, F.Reftable r) => F.Reftable (UReft r) where+  isTauto                 = 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++instance F.Expression (UReft ()) where+  expr = F.expr . F.toReft++++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)++ppTy_ureft :: F.Reftable r => UReft r -> Doc -> Doc+ppTy_ureft u@(MkUReft r p s) d+  | isTauto_ureft  u  = d+  | otherwise         = ppr_reft r (F.ppTy p d) s++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')+  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)++instance (F.Reftable r, TyConable c) => F.Subable (RTProp c tv r) where+  syms (RProp  ss r)     = (fst <$> ss) ++ F.syms r++  subst su (RProp ss (RHole r)) = RProp ss (RHole (F.subst su r))+  subst su (RProp  ss t) = RProp ss (F.subst su <$> t)++  substf f (RProp ss (RHole r)) = RProp ss (RHole (F.substf f r))+  substf f (RProp  ss t) = RProp ss (F.substf f <$> t)++  substa f (RProp ss (RHole r)) = RProp ss (RHole (F.substa f r))+  substa f (RProp  ss t) = RProp ss (F.substa f <$> t)+++instance (F.Subable r, F.Reftable r, TyConable c) => F.Subable (RType c tv r) where+  syms        = foldReft    (\_ r acc -> F.syms r ++ acc) []+  -- 'substa' will substitute bound vars+  substa f    = emapExprArg (\_ -> F.substa f) []      . mapReft  (F.substa f)+  -- 'substf' will NOT substitute bound vars+  substf f    = emapExprArg (\_ -> F.substf f) []      . emapReft (F.substf . F.substfExcept f) []+  subst su    = emapExprArg (\_ -> F.subst su) []      . emapReft (F.subst  . F.substExcept su) []+  subst1 t su = emapExprArg (\_ e -> F.subst1 e su) [] $ emapReft (\xs r -> F.subst1Except xs r su) [] t+++instance F.Reftable Predicate where+  isTauto (Pr ps)      = null ps++  bot (Pr _)           = panic Nothing "No BOT instance for Predicate"+  ppTy r d | F.isTauto r      = d+           | not (ppPs ppEnv) = d+           | otherwise        = d <-> (angleBrackets $ F.pprint r)++  toReft (Pr ps@(p:_))        = F.Reft (parg p, F.pAnd $ pToRef <$> ps)+  toReft _                    = mempty+  params                      = todo Nothing "TODO: instance of params for Predicate"++  ofReft = todo Nothing "TODO: Predicate.ofReft"++pToRef :: PVar a -> F.Expr+pToRef p = pApp (pname p) $ (F.EVar $ parg p) : (thd3 <$> pargs p)++pApp      :: Symbol -> [Expr] -> Expr+pApp p es = F.mkEApp fn (F.EVar p:es)+  where+    fn    = F.dummyLoc (pappSym n)+    n     = length es++pappSym :: Show a => a -> Symbol+pappSym n  = F.symbol $ "papp" ++ show n++--------------------------------------------------------------------------------+-- | Visitors ------------------------------------------------------------------+--------------------------------------------------------------------------------+mapExprReft :: (Symbol -> Expr -> Expr) -> RType c tv RReft -> RType c tv RReft+mapExprReft f = mapReft g+  where+    g (MkUReft (F.Reft (x, e)) p s) = MkUReft (F.Reft (x, f x e)) p s++isTrivial :: (F.Reftable r, TyConable c) => RType c tv r -> Bool+isTrivial t = foldReft (\_ 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 γ (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)+emapReft f γ (RAllE z t t')      = RAllE z (emapReft f γ t) (emapReft f γ t')+emapReft f γ (REx z t t')        = REx   z (emapReft f γ t) (emapReft f γ t')+emapReft _ _ (RExprArg e)        = RExprArg e+emapReft f γ (RAppTy t t' r)     = RAppTy (emapReft f γ t) (emapReft f γ t') (f γ r)+emapReft f γ (RRTy e r o t)      = RRTy  (mapSnd (emapReft f γ) <$> e) (f γ r) o (emapReft f γ t)+emapReft f γ (RHole r)           = RHole (f γ r)++emapRef :: ([Symbol] -> t -> s) ->  [Symbol] -> RTProp c tv t -> RTProp c tv s+emapRef  f γ (RProp s (RHole r))  = RProp s $ RHole (f γ r)+emapRef  f γ (RProp s t)         = RProp s $ emapReft f γ t++emapExprArg :: ([Symbol] -> Expr -> Expr) -> [Symbol] -> RType c tv r -> RType c tv r+emapExprArg f = go+  where+    go _ t@(RVar {})        = t+    go _ t@(RHole {})       = t+    go γ (RAllT α t)        = RAllT α (go γ t)+    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+    go γ (RAllE z t t')     = RAllE z (go γ t) (go γ t')+    go γ (REx z t t')       = REx   z (go γ t) (go γ t')+    go γ (RExprArg e)       = RExprArg (f γ <$> F.notracepp "RExprArg" e) -- <---- actual substitution+    go γ (RAppTy t t' r)    = RAppTy (go γ t) (go γ t') r+    go γ (RRTy e r o t)     = RRTy  (mapSnd (go γ) <$> e) r o (go γ t)+    mo _ t@(RProp _ (RHole {})) = t+    mo γ (RProp s t)            = RProp s (go γ t)++foldRType :: (acc -> RType c tv r -> acc) -> acc -> RType c tv r -> acc+foldRType f = go+  where+    step a t                = go (f a t) t+    prep a (RProp _ (RHole {})) = a+    prep a (RProp _ t)      = step a t+    go a (RVar {})          = a+    go a (RHole {})         = a+    go a (RExprArg {})      = a+    go a (RAllT _ t)        = step a t+    go a (RAllP _ t)        = step a t+    go a (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']+    go a (REx _ t t')       = foldl' step a [t, t']+    go a (RAppTy t t' _)    = foldl' step a [t, t']+    go a (RApp _ ts rs _)   = foldl' prep (foldl' step a ts) rs+    go a (RRTy e _ _ t)     = foldl' step a (t : (snd <$> e))++------------------------------------------------------------------------------------------------------+-- isBase' x t = traceShow ("isBase: " ++ showpp x) $ isBase t+-- same as GhcMisc isBaseType++-- isBase :: RType a -> Bool++-- set all types to basic types, haskell `tx -> t` is translated to Arrow tx t+-- isBase _ = True++isBase :: RType t t1 t2 -> Bool+isBase (RAllT _ t)      = isBase t+isBase (RAllP _ t)      = isBase t+isBase (RVar _ _)       = True+isBase (RApp _ ts _ _)  = all isBase ts+isBase (RImpF _ _ _ _)   = False+isBase (RFun _ _ _ _)   = False+isBase (RAppTy t1 t2 _) = isBase t1 && isBase t2+isBase (RRTy _ _ _ t)   = isBase t+isBase (RAllE _ _ t)    = isBase t+isBase (REx _ _ t)      = isBase t+isBase _                = False++hasHoleTy :: RType t t1 t2 -> Bool+hasHoleTy (RVar _ _)       = False +hasHoleTy (RAllT _ t)      = hasHoleTy t +hasHoleTy (RAllP _ t)      = hasHoleTy t+hasHoleTy (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 +hasHoleTy (RAllE _ t t')   = hasHoleTy t || hasHoleTy t'+hasHoleTy (REx _ t t')     = hasHoleTy t || hasHoleTy t'+hasHoleTy (RExprArg _)     = False +hasHoleTy (RAppTy t t' _)  = hasHoleTy t || hasHoleTy t'+hasHoleTy (RHole _)        = True +hasHoleTy (RRTy xts _ _ t) = hasHoleTy t || any hasHoleTy (snd <$> xts)++++isFunTy :: RType t t1 t2 -> Bool+isFunTy (RAllE _ _ t)    = isFunTy t+isFunTy (RAllS _ t)      = isFunTy t+isFunTy (RAllT _ t)      = isFunTy t+isFunTy (RAllP _ t)      = isFunTy t+isFunTy (RImpF _ _ _ _)  = True+isFunTy (RFun _ _ _ _)   = True+isFunTy _                = False+++mapReftM :: (Monad m) => (r1 -> m r2) -> RType c tv r1 -> m (RType c tv r2)+mapReftM f (RVar α r)         = liftM   (RVar  α)   (f r)+mapReftM f (RAllT α t)        = liftM   (RAllT α)   (mapReftM f t)+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 (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')+mapReftM f (REx z t t')       = liftM2  (REx z)     (mapReftM f t)          (mapReftM f t')+mapReftM _ (RExprArg e)       = return  $ RExprArg e+mapReftM f (RAppTy t t' r)    = liftM3  RAppTy (mapReftM f t) (mapReftM f t') (f r)+mapReftM f (RHole r)          = liftM   RHole       (f r)+mapReftM f (RRTy xts r o t)   = liftM4  RRTy (mapM (mapSndM (mapReftM f)) xts) (f r) (return o) (mapReftM f t)++mapRefM  :: (Monad m) => (t -> m s) -> (RTProp c tv t) -> m (RTProp c tv s)+mapRefM  f (RProp s t)         = liftM   (RProp s)      (mapReftM f t)++mapPropM :: (Monad m) => (RTProp c tv r -> m (RTProp c tv r)) -> RType c tv r -> m (RType c tv r)+mapPropM _ (RVar α r)         = return $ RVar  α r+mapPropM f (RAllT α t)        = liftM   (RAllT α)   (mapPropM f t)+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 (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')+mapPropM f (REx z t t')       = liftM2  (REx z)     (mapPropM f t)          (mapPropM f t')+mapPropM _ (RExprArg e)       = return  $ RExprArg e+mapPropM f (RAppTy t t' r)    = liftM3  RAppTy (mapPropM f t) (mapPropM f t') (return r)+mapPropM _ (RHole r)          = return $ RHole r+mapPropM f (RRTy xts r o t)   = liftM4  RRTy (mapM (mapSndM (mapPropM f)) xts) (return r) (return o) (mapPropM f t)+++--------------------------------------------------------------------------------+-- foldReft :: (F.Reftable r, TyConable c) => (r -> a -> a) -> a -> RType c tv r -> a+--------------------------------------------------------------------------------+-- foldReft f = efoldReft (\_ _ -> []) (\_ -> ()) (\_ _ -> f) (\_ γ -> γ) emptyF.SEnv++--------------------------------------------------------------------------------+foldReft :: (F.Reftable r, TyConable c) => (F.SEnv (RType c tv r) -> r -> a -> a) -> a -> RType c tv r -> a+--------------------------------------------------------------------------------+foldReft  f = foldReft' (\_ _ -> False) id (\γ _ -> f γ)++--------------------------------------------------------------------------------+foldReft' :: (F.Reftable r, TyConable c)+          => (Symbol -> RType c tv r -> Bool)+          -> (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++++-- 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)+          -> (c  -> [RType c tv r] -> [(Symbol, a)])+          -> (RTVar tv (RType c tv ()) -> [(Symbol, a)])+          -> (RType c tv r -> a)+          -> (F.SEnv a -> Maybe (RType c tv r) -> r -> b -> b)+          -> (PVar (RType c tv ()) -> F.SEnv a -> F.SEnv a)+          -> F.SEnv a+          -> b+          -> RType c tv r+          -> b+efoldReft logicBind 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 (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')+    go γ z me@(RFun x t t' r)+       | logicBind x t                  = f γ (Just me) r (go γ' (go γ z t) t')+       | otherwise                      = f γ (Just me) r (go γ  (go γ z t) t')+       where+         γ'                             = insertSEnv x (g t) γ+    go γ z me@(RApp _ ts rs r)          = f γ (Just me) r (ho' γ (go' (insertSEnv (rTypeValueVar me) (g me) γ) z ts) rs)++    go γ z (RAllE x t t')               = go (insertSEnv x (g t) γ) (go γ z t) t'+    go γ z (REx x t t')                 = go (insertSEnv x (g t) γ) (go γ z t) t'+    go γ z me@(RRTy [] r _ t)          = f γ (Just me) r (go γ z t)+    go γ z me@(RRTy xts r _ t)          = f γ (Just me) r (go γ (go γ z (envtoType xts)) t)+    go γ z me@(RAppTy t t' r)           = f γ (Just me) r (go γ (go γ z t) t')+    go _ z (RExprArg _)                 = z+    go γ z me@(RHole r)                 = f γ (Just me) r z++    -- folding over Ref+    ho  γ z (RProp ss (RHole r))       = f (insertsSEnv γ (mapSnd (g . ofRSort) <$> ss)) Nothing r z+    ho  γ z (RProp ss t)               = go (insertsSEnv γ ((mapSnd (g . ofRSort)) <$> ss)) z t++    -- folding over [RType]+    go' γ z ts                 = foldr (flip $ go γ) z ts++    -- folding over [Ref]+    ho' γ z rs                 = foldr (flip $ ho γ) z rs++    envtoType xts = foldr (\(x,t1) t2 -> rFun x t1 t2) (snd $ last xts) (init xts)++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 (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+mapBot f (RApp c ts rs r)  = f $ RApp c (mapBot f <$> ts) (mapBotRef f <$> rs) r+mapBot f (REx b t1 t2)     = REx b  (mapBot f t1) (mapBot f t2)+mapBot f (RAllE b t1 t2)   = RAllE b  (mapBot f t1) (mapBot f t2)+mapBot f (RRTy e r o t)    = RRTy (mapSnd (mapBot f) <$> e) r o (mapBot f t)+mapBot f t'                = f t'++mapBotRef :: (RType c tv r -> RType c tv r)+          -> Ref τ (RType c tv r) -> Ref τ (RType c tv r)+mapBotRef _ (RProp s (RHole r)) = RProp s $ RHole r+mapBotRef f (RProp s t)    = RProp  s $ mapBot f t++mapBind :: (Symbol -> Symbol) -> RType c tv r -> RType c tv r+mapBind f (RAllT α t)      = RAllT α (mapBind f t)+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+mapBind f (RAllE b t1 t2)  = RAllE  (f b) (mapBind f t1) (mapBind f t2)+mapBind f (REx b t1 t2)    = REx    (f b) (mapBind f t1) (mapBind f t2)+mapBind _ (RVar α r)       = RVar α r+mapBind _ (RHole r)        = RHole r+mapBind f (RRTy e r o t)   = RRTy e r o (mapBind f t)+mapBind _ (RExprArg e)     = RExprArg e+mapBind f (RAppTy t t' r)  = RAppTy (mapBind f t) (mapBind f t') r++mapBindRef :: (Symbol -> Symbol)+           -> Ref τ (RType c tv r) -> Ref τ (RType c tv r)+mapBindRef f (RProp s (RHole r)) = RProp (mapFst f <$> s) (RHole r)+mapBindRef f (RProp s t)         = RProp (mapFst f <$> s) $ mapBind f t+++--------------------------------------------------+ofRSort ::  F.Reftable r => RType c tv () -> RType c tv r+ofRSort = fmap mempty++toRSort :: RType c tv r -> RType c tv ()+toRSort = stripAnnotations . mapBind (const F.dummySymbol) . fmap (const ())++stripAnnotations :: RType c tv r -> RType c tv r+stripAnnotations (RAllT α t)      = RAllT α (stripAnnotations t)+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+stripAnnotations (RFun x t t' r)  = RFun x (stripAnnotations t) (stripAnnotations t') r+stripAnnotations (RAppTy t t' r)  = RAppTy (stripAnnotations t) (stripAnnotations t') r+stripAnnotations (RApp c ts rs r) = RApp c (stripAnnotations <$> ts) (stripAnnotationsRef <$> rs) r+stripAnnotations (RRTy _ _ _ t)   = stripAnnotations t+stripAnnotations t                = t++stripAnnotationsRef :: Ref τ (RType c tv r) -> Ref τ (RType c tv r)+stripAnnotationsRef (RProp s (RHole r)) = RProp s (RHole r)+stripAnnotationsRef (RProp s t)         = RProp s $ stripAnnotations t++insertSEnv :: F.Symbol -> a -> F.SEnv a -> F.SEnv a+insertSEnv = F.insertSEnv++insertsSEnv :: F.SEnv a -> [(Symbol, a)] -> F.SEnv a+insertsSEnv  = foldr (\(x, t) γ -> insertSEnv x t γ)++rTypeValueVar :: (F.Reftable r) => RType c tv r -> Symbol+rTypeValueVar t = vv where F.Reft (vv,_) =  rTypeReft t++rTypeReft :: (F.Reftable r) => RType c tv r -> F.Reft+rTypeReft = fromMaybe F.trueReft . fmap F.toReft . stripRTypeBase++-- stripRTypeBase ::  RType a -> Maybe a+stripRTypeBase :: RType c tv r -> Maybe r+stripRTypeBase (RApp _ _ _ x)+  = Just x+stripRTypeBase (RVar _ x)+  = Just x+stripRTypeBase (RImpF _ _ _ x)+  = Just x+stripRTypeBase (RFun _ _ _ x)+  = Just x+stripRTypeBase (RAppTy _ _ x)+  = Just x+stripRTypeBase _+  = Nothing++topRTypeBase :: (F.Reftable r) => RType c tv r -> RType c tv r+topRTypeBase = mapRBase F.top++mapRBase :: (r -> r) -> RType c tv r -> RType c tv r+mapRBase f (RApp c ts rs r) = RApp c ts rs $ f r+mapRBase f (RVar a r)       = RVar a $ f r+mapRBase f (RImpF x t1 t2 r)= RImpF x t1 t2 $ f r+mapRBase f (RFun x t1 t2 r) = RFun x t1 t2 $ f r+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++ppr_pvar :: PVar a -> Doc+ppr_pvar (PV s _ _ xts) = F.pprint s <+> hsep (F.pprint <$> dargs xts)+  where+    dargs               = map thd3 . takeWhile (\(_, x, y) -> F.EVar x /= y)+++instance F.PPrint Predicate where+  pprintTidy _ (Pr [])  = text "True"+  pprintTidy k (Pr pvs) = hsep $ punctuate (text "&") (F.pprintTidy k <$> pvs)+++-- | The type used during constraint generation, used+--   also to define contexts for errors, hence in this+--   file, and NOT in elsewhere. **DO NOT ATTEMPT TO MOVE**+--   Am splitting into+--   + global : many bindings, shared across all constraints+--   + local  : few bindings, relevant to particular constraints++type REnv = AREnv SpecType ++data AREnv t = REnv+  { reGlobal :: M.HashMap Symbol t -- ^ the "global" names for module+  , reLocal  :: M.HashMap Symbol t -- ^ the "local" names for sub-exprs+  }++instance Functor AREnv where +  fmap f (REnv g l) = REnv (fmap f g) (fmap f l)++instance (F.PPrint t) => F.PPrint (AREnv t) where+  pprintTidy k re = "RENV LOCAL" $+$ F.pprintTidy k (reLocal re) <>+                    "\nRENV GLOBAL" $+$ F.pprintTidy k (reGlobal re)+  ++instance Semigroup REnv where +  REnv g1 l1 <> REnv g2 l2 = REnv (g1 <> g2) (l1 <> l2)  ++instance Monoid REnv where +  mempty = REnv mempty mempty++instance NFData REnv where+  rnf (REnv {}) = ()++--------------------------------------------------------------------------------+-- | Error Data Type -----------------------------------------------------------+--------------------------------------------------------------------------------++type ErrorResult    = F.FixResult UserError+type Error          = TError SpecType+++instance NFData a => NFData (TError a)++--------------------------------------------------------------------------------+-- | Source Information Associated With Constraints ----------------------------+--------------------------------------------------------------------------------++data Cinfo    = Ci { ci_loc :: !SrcSpan+                   , ci_err :: !(Maybe Error)+                   , ci_var :: !(Maybe Var)+                   }+                deriving (Eq, Ord, Generic)++instance F.Loc Cinfo where+  srcSpan = srcSpanFSrcSpan . ci_loc++instance NFData Cinfo++--------------------------------------------------------------------------------+-- | Module Names --------------------------------------------------------------+--------------------------------------------------------------------------------++data ModName = ModName !ModType !ModuleName +  deriving (Eq, Ord, Show, Generic, Data, Typeable)++data ModType = Target | SrcImport | SpecImport +  deriving (Eq, Ord, Show, Generic, Data, Typeable)++-- instance B.Binary ModType +-- instance B.Binary ModName ++instance Hashable ModType ++instance Hashable ModuleName where+  hashWithSalt i = hashWithSalt i . show++instance Hashable ModName where+  hashWithSalt i (ModName t n) = hashWithSalt i (t, show n)++instance F.PPrint ModName where+  pprintTidy _ = text . show++instance Show ModuleName where+  show = moduleNameString++instance F.Symbolic ModName where+  symbol (ModName _ m) = F.symbol m++instance F.Symbolic ModuleName where+  symbol = F.symbol . moduleNameFS+++isTarget :: ModName -> Bool +isTarget (ModName Target _) = True +isTarget _                  = False ++isSrcImport :: ModName -> Bool+isSrcImport (ModName SrcImport _) = True+isSrcImport _                     = False++isSpecImport :: ModName -> Bool+isSpecImport (ModName SpecImport _) = True+isSpecImport _                      = False++getModName :: ModName -> ModuleName+getModName (ModName _ m) = m++getModString :: ModName -> String+getModString = moduleNameString . getModName++qualifyModName :: ModName -> Symbol -> Symbol+qualifyModName n = qualifySymbol nSym+  where+    nSym         = F.symbol n++--------------------------------------------------------------------------------+-- | Refinement Type Aliases ---------------------------------------------------+--------------------------------------------------------------------------------+data RTEnv tv t = RTE+  { typeAliases :: M.HashMap Symbol (F.Located (RTAlias tv t))+  , exprAliases :: M.HashMap Symbol (F.Located (RTAlias Symbol Expr))+  }+++instance Monoid (RTEnv tv t) where+  mempty  = RTE M.empty M.empty+  mappend = (<>)++instance Semigroup (RTEnv tv t) where+  RTE x y <> RTE x' y' = RTE (x `M.union` x') (y `M.union` y')++-- mapRT :: (M.HashMap Symbol (RTAlias tv t) -> M.HashMap Symbol (RTAlias tv t)) +--      -> RTEnv tv t -> RTEnv tv t+-- mapRT f e = e { typeAliases = f (typeAliases e) }++-- mapRE :: (M.HashMap Symbol (RTAlias Symbol Expr)+--       -> M.HashMap Symbol (RTAlias Symbol Expr))+--      -> RTEnv tv t -> RTEnv tv t+-- mapRE f e = e { exprAliases = f $ exprAliases e }+++--------------------------------------------------------------------------------+-- | Measures+--------------------------------------------------------------------------------+data Body+  = E Expr          -- ^ Measure Refinement: {v | v = e }+  | P Expr          -- ^ Measure Refinement: {v | (? v) <=> p }+  | R Symbol Expr   -- ^ Measure Refinement: {v | p}+  deriving (Show, Data, Typeable, Generic, Eq)++data Def ty ctor = Def+  { measure :: F.LocSymbol+  , ctor    :: ctor+  , dsort   :: Maybe ty+  , binds   :: [(Symbol, Maybe ty)]    -- measure binders: the ADT argument fields+  , body    :: Body+  } deriving (Show, Data, Typeable, Generic, Eq, Functor)++data Measure ty ctor = M+  { msName :: F.LocSymbol+  , msSort :: ty+  , msEqns :: [Def ty ctor]+  , msKind :: !MeasureKind +  , msUnSorted :: !UnSortedExprs -- potential unsorted expressions used at measure denifinitions+  } deriving (Data, Typeable, Generic, Functor)++type UnSortedExprs = [UnSortedExpr] -- mempty = []+type UnSortedExpr  = ([F.Symbol], F.Expr)++data MeasureKind +  = MsReflect     -- ^ due to `reflect foo` +  | MsMeasure     -- ^ due to `measure foo` with old-style (non-haskell) equations+  | MsLifted      -- ^ due to `measure foo` with new-style haskell equations+  | MsClass       -- ^ due to `class measure` definition +  | MsAbsMeasure  -- ^ due to `measure foo` without equations c.f. tests/pos/T1223.hs+  | MsSelector    -- ^ due to selector-fields e.g. `data Foo = Foo { fld :: Int }` +  | MsChecker     -- ^ due to checkers  e.g. `is-F` for `data Foo = F ... | G ...` +  deriving (Eq, Ord, Show, Data, Typeable, Generic)++instance F.Loc (Measure a b) where +  srcSpan = F.srcSpan . msName++instance Bifunctor Def where+  -- first f  (Def m ps c s bs b) = Def m (second f <$> ps) c (f <$> s) ((second (fmap f)) <$> bs) b+  -- second f (Def m ps c s bs b) = Def m ps (f c) s bs b+  first f  (Def m c s bs b) = Def m c (f <$> s) ((second (fmap f)) <$> bs) b+  second f (Def m c s bs b) = Def m (f c) s bs b+++instance Bifunctor Measure where+  first  f (M n s es k u) = M n (f s) (first f <$> es) k u+  second f (M n s es k u) = M n s (second f <$> es)    k u ++instance                             B.Binary MeasureKind +instance                             B.Binary Body+instance (B.Binary t, B.Binary c) => B.Binary (Def     t c)+instance (B.Binary t, B.Binary c) => B.Binary (Measure t c)++-- NOTE: don't use the TH versions since they seem to cause issues+-- building on windows :(+-- deriveBifunctor ''Def+-- deriveBifunctor ''Measure++data CMeasure ty = CM+  { cName :: F.LocSymbol+  , cSort :: ty+  } deriving (Data, Typeable, Generic, Functor)++instance F.PPrint Body where+  pprintTidy k (E e)   = F.pprintTidy k e+  pprintTidy k (P p)   = F.pprintTidy k p+  pprintTidy k (R v p) = braces (F.pprintTidy k v <+> "|" <+> F.pprintTidy k p)++instance F.PPrint a => F.PPrint (Def t a) where+  pprintTidy k (Def m c _ bs body)+           = F.pprintTidy k m <+> cbsd <+> "=" <+> F.pprintTidy k body+    where+      cbsd = parens (F.pprintTidy k c <-> hsep (F.pprintTidy k `fmap` (fst <$> bs)))++instance (F.PPrint t, F.PPrint a) => F.PPrint (Measure t a) where+  pprintTidy k (M n s eqs _ _) =  F.pprintTidy k n <+> {- parens (pprintTidy k (loc n)) <+> -} "::" <+> F.pprintTidy k s+                                  $$ vcat (F.pprintTidy k `fmap` eqs)+++instance F.PPrint (Measure t a) => Show (Measure t a) where+  show = F.showpp++instance F.PPrint t => F.PPrint (CMeasure t) where+  pprintTidy k (CM n s) =  F.pprintTidy k n <+> "::" <+> F.pprintTidy k s++instance F.PPrint (CMeasure t) => Show (CMeasure t) where+  show = F.showpp+++instance F.Subable (Measure ty ctor) where+  syms  m     = concatMap F.syms (msEqns m) +  substa f m  = m { msEqns = F.substa f  <$> msEqns m }+  substf f m  = m { msEqns = F.substf f  <$> msEqns m }+  subst  su m = m { msEqns = F.subst  su <$> msEqns m }+  -- substa f  (M n s es _) = M n s (F.substa f  <$> es) k+  -- substf f  (M n s es _) = M n s $ F.substf f  <$> es+  -- subst  su (M n s es _) = M n s $ F.subst  su <$> es++instance F.Subable (Def ty ctor) where+  syms (Def _ _ _ sb bd)  = (fst <$> sb) ++ F.syms bd+  substa f  (Def m c t b bd) = Def m c t b $ F.substa f  bd+  substf f  (Def m c t b bd) = Def m c t b $ F.substf f  bd+  subst  su (Def m c t b bd) = Def m c t b $ F.subst  su bd++instance F.Subable Body where+  syms (E e)       = F.syms e+  syms (P e)       = F.syms e+  syms (R s e)     = s : F.syms e++  substa f (E e)   = E   (F.substa f e)+  substa f (P e)   = P   (F.substa f e)+  substa f (R s e) = R s (F.substa f e)++  substf f (E e)   = E   (F.substf f e)+  substf f (P e)   = P   (F.substf f e)+  substf f (R s e) = R s (F.substf f e)++  subst su (E e)   = E   (F.subst su e)+  subst su (P e)   = P   (F.subst su e)+  subst su (R s e) = R s (F.subst su e)++instance F.Subable t => F.Subable (WithModel t) where+  syms (NoModel t)     = F.syms t+  syms (WithModel _ t) = F.syms t+  substa f             = fmap (F.substa f)+  substf f             = fmap (F.substf f)+  subst su             = fmap (F.subst su)++data RClass ty = RClass+  { rcName    :: BTyCon+  , rcSupers  :: [ty]+  , rcTyVars  :: [BTyVar]+  , rcMethods :: [(F.LocSymbol, ty)]+  } deriving (Show, Functor, Data, Typeable, Generic)+++instance F.PPrint t => F.PPrint (RClass t) where +  pprintTidy k (RClass n ts as mts) +                = ppMethods k ("class" <+> supers ts) n as [(m, RISig t) | (m, t) <- mts] +    where +      supers [] = "" +      supers ts = tuplify (F.pprintTidy k   <$> ts) <+> "=>"+      tuplify   = parens . hcat . punctuate ", "+++instance F.PPrint t => F.PPrint (RILaws t) where+  pprintTidy k (RIL n ss ts mts _) = ppEqs k ("instance laws" <+> supers ss) n ts mts +   where +    supers [] = "" +    supers ts = tuplify (F.pprintTidy k   <$> ts) <+> "=>"+    tuplify   = parens . hcat . punctuate ", "+++ppEqs :: (F.PPrint x, F.PPrint t, F.PPrint a, F.PPrint n) +          => F.Tidy -> Doc -> n -> [a] -> [(x, t)] -> Doc+ppEqs k hdr name args mts +  = vcat $ hdr <+> dName <+> "where" +         : [ nest 4 (bind m t) | (m, t) <- mts ] +    where +      dName    = parens  (F.pprintTidy k name <+> dArgs)+      dArgs    = gaps    (F.pprintTidy k      <$> args)+      gaps     = hcat . punctuate " "+      bind m t = F.pprintTidy k m <+> "=" <+> F.pprintTidy k t ++ppMethods :: (F.PPrint x, F.PPrint t, F.PPrint a, F.PPrint n) +          => F.Tidy -> Doc -> n -> [a] -> [(x, RISig t)] -> Doc+ppMethods k hdr name args mts +  = vcat $ hdr <+> dName <+> "where" +         : [ nest 4 (bind m t) | (m, t) <- mts ] +    where +      dName    = parens  (F.pprintTidy k name <+> dArgs)+      dArgs    = gaps    (F.pprintTidy k      <$> args)+      gaps     = hcat . punctuate " "+      bind m t = ppRISig k m t -- F.pprintTidy k m <+> "::" <+> F.pprintTidy k t ++instance B.Binary ty => B.Binary (RClass ty)+++------------------------------------------------------------------------+-- | Var Hole Info -----------------------------------------------------+------------------------------------------------------------------------++data HoleInfo t = HoleInfo {htype :: t, hloc :: SrcSpan, henv :: AREnv t }++instance Functor HoleInfo where +  fmap f hinfo = hinfo{htype = f (htype hinfo), henv = fmap f (henv hinfo)}++instance (F.PPrint t) => F.PPrint (HoleInfo 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+  --                     <+> text "\n env:" <+> F.pprintTidy k (henv hinfo)++------------------------------------------------------------------------+-- | Annotations -------------------------------------------------------+------------------------------------------------------------------------++newtype AnnInfo a = AI (M.HashMap SrcSpan [(Maybe Text, a)])+                    deriving (Data, Typeable, Generic, Functor)++data Annot t+  = AnnUse t+  | AnnDef t+  | AnnRDf t+  | AnnLoc SrcSpan+  deriving (Data, Typeable, Generic, Functor)++instance Monoid (AnnInfo a) where+  mempty  = AI M.empty+  mappend = (<>)++instance Semigroup (AnnInfo a) where+  AI m1 <> AI m2 = AI $ M.unionWith (++) m1 m2++instance NFData a => NFData (AnnInfo a)++instance NFData a => NFData (Annot a)++--------------------------------------------------------------------------------+-- | Output --------------------------------------------------------------------+--------------------------------------------------------------------------------++data Output a = O+  { o_vars   :: Maybe [String]+  , o_types  :: !(AnnInfo a)+  , o_templs :: !(AnnInfo a)+  , o_bots   :: ![SrcSpan]+  , o_result :: ErrorResult+  } deriving (Typeable, Generic, Functor)++emptyOutput :: Output a+emptyOutput = O Nothing mempty mempty [] mempty++instance Monoid (Output a) where+  mempty  = emptyOutput+  mappend = (<>)++instance Semigroup (Output a) where+  o1 <> o2 = O { o_vars   = sortNub <$> mappend (o_vars   o1) (o_vars   o2)+               , o_types  =             mappend (o_types  o1) (o_types  o2)+               , o_templs =             mappend (o_templs o1) (o_templs o2)+               , o_bots   = sortNub  $  mappend (o_bots o1)   (o_bots   o2)+               , o_result =             mappend (o_result o1) (o_result o2)+               }++--------------------------------------------------------------------------------+-- | KVar Profile --------------------------------------------------------------+--------------------------------------------------------------------------------++data KVKind+  = RecBindE    Var -- ^ Recursive binder      @letrec x = ...@+  | NonRecBindE Var -- ^ Non recursive binder  @let x = ...@+  | TypeInstE+  | PredInstE+  | LamE+  | CaseE       Int -- ^ Int is the number of cases+  | LetE+  | ImplictE+  | ProjectE        -- ^ Projecting out field of+  deriving (Generic, Eq, Ord, Show, Data, Typeable)++instance Hashable KVKind++newtype KVProf = KVP (M.HashMap KVKind Int) deriving (Generic)++emptyKVProf :: KVProf+emptyKVProf = KVP M.empty++updKVProf :: KVKind -> F.Kuts -> KVProf -> KVProf+updKVProf k kvs (KVP m) = KVP $ M.insert k (kn + n) m+  where+    kn                  = M.lookupDefault 0 k m+    n                   = S.size (F.ksVars kvs)++instance NFData KVKind++instance F.PPrint KVKind where+  pprintTidy _ = text . show++instance F.PPrint KVProf where+  pprintTidy k (KVP m) = F.pprintTidy k (M.toList m)++instance NFData KVProf++hole :: Expr+hole = F.PKVar "HOLE" mempty++isHole :: Expr -> Bool+isHole (F.PKVar ("HOLE") _) = True+isHole _                    = False++hasHole :: F.Reftable r => r -> Bool+hasHole = any isHole . F.conjuncts . F.reftPred . F.toReft++instance F.Symbolic DataCon where+  symbol = F.symbol . dataConWorkId++instance F.PPrint DataCon where+  pprintTidy _ = text . showPpr++instance Ord TyCon where +  compare = compare `on` F.symbol ++instance Ord DataCon where +  compare = compare `on` F.symbol ++instance F.PPrint TyThing where +  pprintTidy _ = text . showPpr ++instance Show DataCon where+  show = F.showpp++-- instance F.Symbolic TyThing where +--  symbol = tyThingSymbol ++liquidBegin :: String+liquidBegin = ['{', '-', '@']++liquidEnd :: String+liquidEnd = ['@', '-', '}']++data MSpec ty ctor = MSpec+  { ctorMap  :: M.HashMap Symbol [Def ty ctor]+  , measMap  :: M.HashMap F.LocSymbol (Measure ty ctor)+  , cmeasMap :: M.HashMap F.LocSymbol (Measure ty ())+  , imeas    :: ![Measure ty ctor]+  } deriving (Data, Typeable, Generic, Functor)++instance Bifunctor MSpec   where+  first f (MSpec c m cm im) = MSpec (fmap (fmap (first f)) c)+                                    (fmap (first f) m)+                                    (fmap (first f) cm)+                                    (fmap (first f) im)+  second                    = fmap++instance (F.PPrint t, F.PPrint a) => F.PPrint (MSpec t a) where+  pprintTidy k =  vcat . fmap (F.pprintTidy k) . fmap snd . M.toList . measMap++instance (Show ty, Show ctor, F.PPrint ctor, F.PPrint ty) => Show (MSpec ty ctor) where+  show (MSpec ct m cm im)+    = "\nMSpec:\n" +++      "\nctorMap:\t "  ++ show ct +++      "\nmeasMap:\t "  ++ show m  +++      "\ncmeasMap:\t " ++ show cm +++      "\nimeas:\t "    ++ show im +++      "\n"++instance Eq ctor => Semigroup (MSpec ty ctor) where+  MSpec c1 m1 cm1 im1 <> MSpec c2 m2 cm2 im2+    | (k1, k2) : _ <- dups+      -- = panic Nothing $ err (head dups)+    = uError $ err k1 k2+    | otherwise+    = MSpec (M.unionWith (++) c1 c2) (m1 `M.union` m2) (cm1 `M.union` cm2) (im1 ++ im2)+    where+      dups = [(k1, k2) | k1 <- M.keys m1 , k2 <- M.keys m2, F.val k1 == F.val k2]+      err k1 k2 = ErrDupMeas (fSrcSpan k1) (F.pprint (F.val k1)) (fSrcSpan <$> [k1, k2])+++instance Eq ctor => Monoid (MSpec ty ctor) where+  mempty = MSpec M.empty M.empty M.empty []+  mappend = (<>)++++--------------------------------------------------------------------------------+-- Nasty PP stuff+--------------------------------------------------------------------------------++instance F.PPrint BTyVar where+  pprintTidy _ (BTV α) = text (F.symbolString α)++instance F.PPrint RTyVar where+  pprintTidy k (RTV α)+   | ppTyVar ppEnv  = F.pprintTidy k (F.symbol α) -- shows full tyvar+   | otherwise      = ppr_tyvar_short α           -- drops the unique-suffix+   where+     ppr_tyvar_short :: TyVar -> Doc+     ppr_tyvar_short = text . showPpr++instance (F.PPrint r, F.Reftable r, F.PPrint t, F.PPrint (RType c tv r)) => F.PPrint (Ref t (RType c tv r)) where+  pprintTidy k (RProp ss s) = ppRefArgs k (fst <$> ss) <+> F.pprintTidy k s++ppRefArgs :: F.Tidy -> [Symbol] -> Doc+ppRefArgs _ [] = empty+ppRefArgs k ss = text "\\" <-> hsep (ppRefSym k <$> ss ++ [F.vv Nothing]) <+> "->"++ppRefSym :: (Eq a, IsString a, F.PPrint a) => F.Tidy -> a -> Doc+ppRefSym _ "" = text "_"+ppRefSym k s  = F.pprintTidy k s
src/Language/Haskell/Liquid/Types/Visitors.hs view
@@ -8,26 +8,28 @@   module Language.Haskell.Liquid.Types.Visitors (--  -- * visitors+     CBVisitable (..)+  +  -- * visitors+  , coreVisitor +  , CoreVisitor (..)    ) where  import           CoreSyn+import           TysPrim                          (intPrimTy) import           Data.Hashable import           DataCon import           Literal-import           Prelude                          hiding (error)--import           Language.Haskell.Liquid.GHC.TypeRep+import           FastString                       (fastStringToByteString) import           Var-import           FastString (fastStringToByteString)  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.Misc ()  @@ -130,10 +132,11 @@     go' _                  = []  -    tyLitToLit (StrTyLit fs) = MachStr $ fastStringToByteString fs-    tyLitToLit (NumTyLit i)  = MachInt i+    tyLitToLit (StrTyLit fs) = MachStr (fastStringToByteString fs)+    tyLitToLit (NumTyLit i)  = LitNumber LitNumInt (fromIntegral i) intPrimTy  + instance CBVisitable (Alt Var) where   freeVars env (a, xs, e) = freeVars env a ++ freeVars (extendEnv env xs) e   readVars (_,_, e)       = readVars e@@ -154,3 +157,48 @@ bindings :: Bind t -> [t] bindings (NonRec x _) = [x] bindings (Rec  xes  ) = map fst xes++----------------------------------------------------------------------------------------+-- | @BindVisitor@ allows for generic, context sensitive traversals over the @CoreBinds@ +----------------------------------------------------------------------------------------+data CoreVisitor env acc = CoreVisitor +  { envF  :: env -> Var             -> env +  , bindF :: env -> acc -> Var      -> acc  +  , exprF :: env -> acc -> CoreExpr -> acc +  }++coreVisitor :: (CoreVisitor env acc) -> env -> acc -> [CoreBind] -> acc+coreVisitor vis env acc cbs   = snd (foldl' step (env, acc) cbs) +  where+    stepXE (env, acc) (x,e)   = (env', stepE env' acc'   e)  +      where +        env'                  = envF  vis env     x +        acc'                  = bindF vis env acc x  ++    step ea (NonRec x e)      = stepXE ea (x, e) +    step ea (Rec    xes)      = foldl' stepXE ea xes ++    -- step (env, acc) (NonRec x e) = stepXE env acc x e +    -- step (env, acc) (Rec    xes) = (env', foldl' (stepE env') acc' es) +      -- where +        -- acc'                     = foldl' (bindF vis env') acc xs+        -- env'                     = foldl' (envF  vis)      env xs +        -- xs                       = fst <$> xes +        -- es                       = snd <$> xes+        -- foldl' (\(env, acc) (x, e) ->  )++    stepE env acc e              = goE env (exprF vis env acc e) e ++    goE _   acc (Var _)          = acc +    goE env acc (App e1 e2)      = stepE  env (stepE env acc e1) e2 +    goE env acc (Tick _ e)       = stepE  env acc e +    goE env acc (Cast e _)       = stepE  env acc e  +    goE env acc (Lam x e)        = snd (stepXE (env, acc) (x, e))+    goE env acc (Let b e)        = stepE env' acc' e where (env', acc') = step (env, acc) b +    goE env acc (Case e _ _ cs)  = foldl' (goC env) (stepE env acc e) cs+    goE _   acc _                = acc ++    goC env acc (_, xs, e)       = stepE  env' acc' e +      where+        env'                     = foldl' (envF  vis)     env xs +        acc'                     = foldl' (bindF vis env) acc xs
src/Language/Haskell/Liquid/UX/ACSS.hs view
@@ -10,6 +10,7 @@   ) where  import Prelude hiding (error)+import qualified SrcLoc   import Language.Haskell.HsColour.Anchors import Language.Haskell.HsColour.Classify as Classify@@ -25,10 +26,11 @@ import Language.Haskell.Liquid.GHC.Misc import Language.Haskell.Liquid.Types.Errors (panic, impossible) -data AnnMap  = Ann {-    types  :: M.HashMap Loc (String, String) -- ^ Loc -> (Var, Type)-  , errors :: [(Loc, Loc, String)]           -- ^ List of error intervals-  , status :: !Status+data AnnMap  = Ann +  { types   :: M.HashMap Loc (String, String) -- ^ Loc -> (Var, Type)+  , errors  :: [(Loc, Loc, String)]           -- ^ List of error intervals+  , status  :: !Status+  , sptypes :: ![(SrcLoc.RealSrcSpan, (String, String)) ]-- ^ Type information with spans   }  data Status = Safe | Unsafe | Error | Crash@@ -93,7 +95,7 @@     linWidth   = length $ show $ length $ lines src  spanAnnot :: Int -> AnnMap -> Loc -> Annotation-spanAnnot w (Ann ts es _) span = A t e b+spanAnnot w (Ann ts es _ _) span = A t e b   where     t = fmap snd (M.lookup span ts)     e = fmap (\_ -> "ERROR") $ find (span `inRange`) [(x,y) | (x,y,_) <- es]@@ -177,7 +179,7 @@ splitSrcAndAnns s =   let ls = lines s in   case findIndex (breakS ==) ls of-    Nothing -> (s, Ann M.empty [] Safe)+    Nothing -> (s, Ann M.empty [] Safe mempty)     Just i  -> (src, ann)                where (codes, _:mname:annots) = splitAt i ls                      ann   = annotParse mname $ dropWhile isSpace $ unlines annots@@ -198,7 +200,7 @@ breakS = "MOUSEOVER ANNOTATIONS"  annotParse :: String -> String -> AnnMap-annotParse mname s = Ann (M.fromList ts) [(x,y,"") | (x,y) <- es] Safe+annotParse mname s = Ann (M.fromList ts) [(x,y,"") | (x,y) <- es] Safe mempty   where     (ts, es)       = partitionEithers $ parseLines mname 0 $ lines s @@ -235,8 +237,9 @@   = panic Nothing $ "Error Parsing Annot Input on Line: " ++ show i  instance Show AnnMap where-  show (Ann ts es _ ) =  "\n\n" ++ (concatMap ppAnnotTyp $ M.toList ts)-                                ++ (concatMap ppAnnotErr [(x,y) | (x,y,_) <- es])+  show (Ann ts es _ _) =  "\n\n" +                      ++ (concatMap ppAnnotTyp $ M.toList ts)+                      ++ (concatMap ppAnnotErr [(x,y) | (x,y,_) <- es])  ppAnnotTyp :: (PrintfArg t, PrintfType t1) => (Loc, (t, String)) -> t1 ppAnnotTyp (L (l, c), (x, s))     = printf "%s\n%d\n%d\n%d\n%s\n\n\n" x l c (length $ lines s) s
src/Language/Haskell/Liquid/UX/Annotate.hs view
@@ -5,7 +5,6 @@ {-# LANGUAGE TypeSynonymInstances       #-} {-# LANGUAGE FlexibleInstances          #-} -{- LIQUID "--diffcheck" @-}  --------------------------------------------------------------------------- -- | This module contains the code that uses the inferred types to generate@@ -14,10 +13,8 @@ -- 3. JSON files for the web-demo etc. --------------------------------------------------------------------------- - module Language.Haskell.Liquid.UX.Annotate-  ( specAnchor-  , mkOutput+  ( mkOutput   , annotate   , tokeniseWithLoc   , annErrors@@ -54,6 +51,7 @@ import qualified Data.ByteString.Lazy                         as B import qualified Data.Text                                    as T import qualified Data.HashMap.Strict                          as M+import qualified Language.Haskell.Liquid.Misc                 as Misc  import qualified Language.Haskell.Liquid.UX.ACSS              as ACSS import           Language.Haskell.HsColour.Classify import           Language.Fixpoint.Utils.Files@@ -64,10 +62,9 @@ import           Language.Haskell.Liquid.Types.PrettyPrint import           Language.Haskell.Liquid.Types.RefType -import           Language.Haskell.Liquid.UX.Errors            () import           Language.Haskell.Liquid.UX.Tidy import           Language.Haskell.Liquid.Types                hiding (Located(..), Def(..))-import           Language.Haskell.Liquid.Types.Specifications+-- import           Language.Haskell.Liquid.Types.Specifications   -- | @output@ creates the pretty printed output@@ -128,7 +125,7 @@  generateHtml :: FilePath -> FilePath -> ACSS.AnnMap -> IO () generateHtml srcF htmlF annm-  = do src     <- readFile srcF+  = do src     <- Misc.sayReadFile srcF        let lhs  = isExtFile LHs srcF        let body = {-# SCC "hsannot" #-} ACSS.hsannot False (Just tokAnnot) lhs (src, annm)        cssFile <- getCssPath@@ -230,7 +227,12 @@ --   annotations.  mkAnnMap :: Config -> ErrorResult -> AnnInfo Doc -> ACSS.AnnMap-mkAnnMap cfg res ann     = ACSS.Ann (mkAnnMapTyp cfg ann) (mkAnnMapErr res) (mkStatus res)+mkAnnMap cfg res ann     = ACSS.Ann +                             { ACSS.types   = mkAnnMapTyp cfg ann +                             , ACSS.errors  = mkAnnMapErr res +                             , ACSS.status  = mkStatus res +                             , ACSS.sptypes = mkAnnMapBinders cfg ann+                             }  mkStatus :: FixResult t -> ACSS.Status mkStatus (Safe)          = ACSS.Safe@@ -255,8 +257,7 @@ mkAnnMapTyp :: Config -> AnnInfo Doc -> M.HashMap Loc (String, String) mkAnnMapTyp cfg z = M.fromList $ map (first srcSpanStartLoc) $ mkAnnMapBinders cfg z -mkAnnMapBinders :: Config-                -> AnnInfo Doc -> [(SrcLoc.RealSrcSpan, (String, String))]+mkAnnMapBinders :: Config -> AnnInfo Doc -> [(SrcLoc.RealSrcSpan, (String, String))] mkAnnMapBinders cfg (AI m)   = map (second bindStr . head . sortWith (srcSpanEndCol . fst))   $ groupWith (lineCol . fst) locBinds@@ -423,6 +424,9 @@                                    , "message" .= toJSON (dropErrorLoc s)                                    ] +++ dropErrorLoc :: String -> String dropErrorLoc msg   | null msg' = msg@@ -436,11 +440,18 @@       tshow        = T.pack . show  instance ToJSON ACSS.AnnMap where-  toJSON a = object [ "types"  .= toJSON (annTypes    a)-                    , "errors" .= toJSON (annErrors   a)-                    , "status" .= toJSON (ACSS.status a)+  toJSON a = object [ "types"   .= toJSON (annTypes     a)+                    , "errors"  .= toJSON (annErrors    a)+                    , "status"  .= toJSON (ACSS.status  a)+                    , "sptypes" .= (toJ <$> ACSS.sptypes a)                      ]-+    where +      toJ (sp, (x,t)) = object [ "start" .= toJSON (srcSpanStartLoc sp) +                               , "stop"  .= toJSON (srcSpanEndLoc   sp) +                               , "ident" .= toJSON x +                               , "ann"  .= toJSON t +                               ] +                       annErrors :: ACSS.AnnMap -> AnnErrors annErrors = AnnErrors . ACSS.errors @@ -479,10 +490,10 @@  _anns :: AnnTypes _anns = i [(5,   i [( 14, A1 { ident = "foo"-                            , ann   = "int -> int"-                            , row   = 5-                            , col   = 14-                            })+                             , ann   = "int -> int"+                             , row   = 5+                             , col   = 14+                             })                   ]           )          ,(9,   i [( 22, A1 { ident = "map"
src/Language/Haskell/Liquid/UX/CmdLine.hs view
@@ -6,8 +6,6 @@ {-# LANGUAGE TypeSynonymInstances      #-} {-# OPTIONS_GHC -fno-cse #-} -{-@ LIQUID "--diff"     @-}- -- | This module contains all the code needed to output the result which --   is either: `SAFE` or `WARNING` with some reasonable error message when --   something goes wrong. All forms of errors/exceptions should go through@@ -46,11 +44,10 @@ import System.Directory import System.Exit import System.Environment--- SIGH. CIRCLE hassles: import Paths_liquidhaskell (version)--- SIGH. CIRCLE hassles: import Data.Version (showVersion) import System.Console.CmdArgs.Explicit import System.Console.CmdArgs.Implicit     hiding (Loud) import System.Console.CmdArgs.Text+import GitHash   import Data.List                           (nub) @@ -67,7 +64,7 @@ import Language.Haskell.Liquid.GHC.Misc import Language.Haskell.Liquid.Misc import Language.Haskell.Liquid.Types.PrettyPrint-import Language.Haskell.Liquid.Types       hiding (name, typ)+import Language.Haskell.Liquid.Types       hiding (typ) import qualified Language.Haskell.Liquid.UX.ACSS as ACSS  @@ -109,22 +106,10 @@     = def           &= help "Allow higher order binders into the logic" - , extensionality-    = def-          &= help "Allow function extentionality axioms"-- , alphaEquivalence-    = def-          &= help "Allow lambda alpha-equivalence axioms"-- , betaEquivalence-    = def-          &= help "Allow lambda beta-equivalence axioms"-- , normalForm+ , smtTimeout      = def-          &= help "Allow lambda normalization-equivalence axioms"-+          &= help "Timeout of smt queries in msec"    +        , higherorderqs     = def           &= help "Allow higher order qualifiers to get automatically instantiated"@@ -149,11 +134,25 @@           &= name "prune-unsorted"   , notermination-    = def &= help "Disable Termination Check"+    = def +          &= help "Disable Termination Check"           &= name "no-termination-check" + , rankNTypes +    = def &= help "Adds precise reasoning on presence of rankNTypes"+          &= name "rankNTypes" ++ , noclasscheck+    = def +          &= help "Disable Class Instance Check"+          &= name "no-class-check"++ , nostructuralterm+    = def &= name "no-structural-termination"+          &= help "Disable structural termination check" +            , gradual-    = def &= help "Enable gradual refinementtype checking"+    = def &= help "Enable gradual refinement type checking"           &= name "gradual"   , gdepth@@ -166,13 +165,9 @@           &= name "ginteractive"   , totalHaskell-    = def &= help "Check for termination and totality, Overrides no-termination flags"+    = def &= help "Check for termination and totality; overrides no-termination flags"           &= name "total-Haskell" - , autoproofs-    = def &= help "Automatically construct proofs from axioms"-          &= name "auto-proofs"-  , nowarnings     = def &= help "Don't display warnings, only show errors"           &= name "no-warnings"@@ -181,13 +176,14 @@     = def &= help "Don't create intermediate annotation files"           &= name "no-annotations" - , trustInternals-    = False &= help "Trust GHC generated code"-            &= name "trust-internals"+ , checkDerived+    = def &= help "Check GHC generated binders (e.g. Read, Show instances)"+          &= name "check-derived" - , nocaseexpand-    = def &= help "Don't expand the default case in a case-expression"-          &= name "no-case-expand"+ , 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" @@ -258,10 +254,6 @@     = def &= help "Do not generate ADT representations in refinement logic"           &= name "no-adt" - , noMeasureFields-    = def &= help "Do not automatically lift data constructor fields into measures"-          &= name "no-measure-fields"-  , scrapeImports     = False &= help "Scrape qualifiers from imported specifications"             &= name "scrape-imports"@@ -325,41 +317,51 @@     = False &= name "no-simplify-core"             &= help "Don't simplify GHC core before constraint generation" -  , nonLinCuts-    = True  &= name "non-linear-cuts"-            &= help "(TRUE) Treat non-linear kvars as cuts"+  -- PLE-OPT , autoInstantiate+    -- PLE-OPT = def+          -- PLE-OPT &= help "How to instantiate axiomatized functions `smtinstances` for SMT instantiation, `liquidinstances` for terminating instantiation"+          -- PLE-OPT &= name "automatic-instances" -  , autoInstantiate-    = def-          &= help "How to instantiate axiomatized functions `smtinstances` for SMT instantiation, `liquidinstances` for terminating instantiation"-          &= name "automatic-instances"+  , proofLogicEval+    = def  +        &= help "Enable Proof-by-Logical-Evaluation"+        &= name "ple" -  -- , proofMethod-    -- = def-          -- &= help "Specify what method to use to create instances. Options `arithmetic`, `rewrite`, `allmathods`. Default is `rewrite`"-          -- &= name "proof-method"-  -- , fuel-    -- = defFuel &= help "Fuel parameter for liquid instances (default is 2)"-        -- &= name "fuel"+  , proofLogicEvalLocal+    = def  +        &= help "Enable Proof-by-Logical-Evaluation locally, per function"+        &= name "ple-local" -  , debugInstantionation-    = False &= help "Debug Progress in liquid instantiation"-        &= name "debug-instantiation" -  , proofLogicEval-    = False &= help "Enable Proof-by-Logical-Evaluation"-        &= name "ple"+  , reflection +    = def +        &= help "Enable reflection of Haskell functions and theorem proving" +        &= name "reflection" - } &= verbosity-   &= program "liquid"-   &= help    "Refinement Types for Haskell"-   &= summary copyright-   &= details [ "LiquidHaskell is a Refinement Type based verifier for Haskell"-              , ""-              , "To check a Haskell file foo.hs, type:"-              , "  liquid foo.hs "-              ]+  , compileSpec +    = def +        &= name "compile-spec"+        &= help "Only compile specifications (into .bspec file); skip verification"  +  , noCheckImports+    = def +        &= name "no-check-imports"+        &= help "Do not check the transitive imports; only check the target files." ++  , typedHoles+    = def +        &= name "typed-holes"+        &= help "Use (refinement) typed-holes [currently warns on '_x' variables]"+  } &= verbosity+    &= program "liquid"+    &= help    "Refinement Types for Haskell"+    &= summary copyright+    &= details [ "LiquidHaskell is a Refinement Type based verifier for Haskell"+               , ""+               , "To check a Haskell file foo.hs, type:"+               , "  liquid foo.hs "+               ]+ defaultPort :: Int defaultPort = 3000 @@ -445,14 +447,32 @@ copyright = concat $ concat   [ ["LiquidHaskell "]   , [$(simpleVersion Meta.version)]+  , [gitInfo]   -- , [" (" ++ _commitCount ++ " commits)" | _commitCount /= ("1"::String) &&   --                                          _commitCount /= ("UNKNOWN" :: String)]-  , ["\nCopyright 2013-18 Regents of the University of California. All Rights Reserved.\n"]+  , ["\nCopyright 2013-19 Regents of the University of California. All Rights Reserved.\n"]   ]   where     _commitCount = $gitCommitCount --- NOTE [searchpath]+gitInfo :: String+gitInfo  = msg+  where+    giTry  = $$tGitInfoCwdTry+    msg    = case giTry of+               Left _   -> " no git information"+               Right gi -> gitMsg gi+    +gitMsg :: GitInfo -> String+gitMsg gi = concat+  [ " [", giBranch gi, "@", giHash gi+  , " (", giCommitDate gi, ")"+  -- , " (", show (giCommitCount gi), " commits in HEAD)"+  , "] "+  ]+++-- [NOTE:searchpath] -- 1. we used to add the directory containing the file to the searchpath, --    but this is bad because GHC does NOT do this, and it causes spurious --    "duplicate module" errors in the following scenario@@ -499,74 +519,70 @@ parsePragma = withPragma defConfig  defConfig :: Config-defConfig = Config { files             = def-                   , idirs             = def-                   , fullcheck         = def-                   , linear            = def-                   , stringTheory      = def-                   , higherorder       = def-                   , extensionality    = def-                   , alphaEquivalence  = def-                   , betaEquivalence   = def-                   , normalForm        = def-                   , higherorderqs     = def-                   , diffcheck         = def-                   , saveQuery         = def-                   , checks            = def-                   , noCheckUnknown    = def-                   , notermination     = def-                   , gradual           = False-                   , gdepth            = 1-                   , ginteractive      = False-                   , totalHaskell      = def-                   , autoproofs        = def-                   , nowarnings        = def-                   , noannotations     = def-                   , trustInternals    = False-                   , nocaseexpand      = def-                   , strata            = def-                   , notruetypes       = def-                   , nototality        = False-                   , pruneUnsorted     = def-                   , exactDC           = def-                   , noADT             = def-                   , noMeasureFields   = 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-                   -- , noEliminate       = False-                   , eliminate         = FC.Some-                   , noPatternInline   = False-                   , noSimplifyCore    = False-                   , nonLinCuts        = True-                   , autoInstantiate   = def-                   -- , proofMethod       = def-                   -- , fuel              = defFuel-                   , debugInstantionation = False-                   , noslice              = False-                   , noLiftedImport       = False-                   , proofLogicEval       = False-                   }---- defFuel :: Int--- defFuel = 2+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+  -- PLE-OPT , autoInstantiate   = def+  , noslice           = False+  , noLiftedImport    = False+  , proofLogicEval    = False+  , proofLogicEvalLocal = False+  , reflection        = False+  , compileSpec       = False+  , noCheckImports    = False+  , typedHoles        = False+  }  ------------------------------------------------------------------------ -- | Exit Function -----------------------------------------------------@@ -599,8 +615,10 @@   putStrLn "RESULT"   B.putStrLn . encode . annErrors $ annm -resultWithContext :: FixResult UserError -> IO (FixResult CError)-resultWithContext = mapM errorWithContext+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   instance Show (CtxError Doc) where   show = showpp@@ -608,7 +626,8 @@ writeCheckVars :: Symbolic a => Maybe [a] -> IO () writeCheckVars Nothing     = return () writeCheckVars (Just [])   = colorPhaseLn Loud "Checked Binders: None" ""-writeCheckVars (Just ns)   = colorPhaseLn Loud "Checked Binders:" "" >> forM_ ns (putStrLn . symbolString . dropModuleNames . symbol)+writeCheckVars (Just ns)   = colorPhaseLn Loud "Checked Binders:" "" +                          >> forM_ ns (putStrLn . symbolString . dropModuleNames . symbol)  type CError = CtxError Doc 
src/Language/Haskell/Liquid/UX/Config.hs view
@@ -7,6 +7,15 @@      Config (..)    , HasConfig (..)    , allowPLE, allowLocalPLE, allowGlobalPLE+   , patternFlag+   , higherOrderFlag+   , pruneFlag+   , maxCaseExpand +   , exactDCFlag+   , hasOpt+   , totalityCheck+   , terminationCheck +   , structuralTerm    ) where  import Prelude hiding (error)@@ -17,32 +26,32 @@ import System.Console.CmdArgs  -- NOTE: adding strictness annotations breaks the help message-data Config = Config {-    files          :: [FilePath] -- ^ source files to check+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-  , extensionality :: Bool       -- ^ allow function extentionality axioms-  , alphaEquivalence :: Bool     -- ^ allow lambda alpha-equivalence axioms-  , betaEquivalence  :: Bool     -- ^ allow lambda beta-equivalence axioms-  , normalForm     :: Bool       -- ^ allow lambda normalization-equivalence axioms+  , 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-  , autoproofs     :: Bool       -- ^ automatically construct proofs from axioms   , nowarnings     :: Bool       -- ^ disable warnings output (only show errors)   , noannotations  :: Bool       -- ^ disable creation of intermediate annotation files-  , trustInternals :: Bool       -- ^ type all internal variables with true-  , nocaseexpand   :: Bool       -- ^ disable case expand+  , 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@@ -61,7 +70,6 @@   , 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)-  , noMeasureFields :: Bool      -- ^ Do not automatically lift data constructor fields into measures   , scrapeImports   :: Bool      -- ^ scrape qualifiers from imported specifications   , scrapeInternals :: Bool      -- ^ scrape qualifiers from auto specifications   , scrapeUsedImports  :: Bool   -- ^ scrape qualifiers from used, imported specifications@@ -73,62 +81,30 @@   , 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-  , nonLinCuts      :: Bool       -- ^ treat non-linear kvars as cuts-  , autoInstantiate :: Instantiate -- ^ How to instantiate axioms-  -- NO-TRIGGER , proofMethod     :: ProofMethod -- ^ How to create automatic instances-  -- NO-TRIGGER , fuel            :: Int         -- ^ Fuel for axiom instantiation-  , debugInstantionation :: Bool   -- ^ Debug Instantiation+  -- 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"   } deriving (Generic, Data, Typeable, Show, Eq) --- NO-TRIGGER instance Serialize ProofMethod-instance Serialize Instantiate instance Serialize SMTSolver instance Serialize Config -data Instantiate-  = NoInstances-  | LiquidInstances-  | LiquidInstancesLocal-  deriving (Eq, Data, Typeable, Generic)---- NO-TRIGGER data ProofMethod--- NO-TRIGGER   = Rewrite--- NO-TRIGGER   | AllMethods--- NO-TRIGGER   deriving (Eq, Data, Typeable, Generic)- allowPLE :: Config -> Bool allowPLE cfg-  =  (allowGlobalPLE cfg || allowLocalPLE cfg)+  =  allowGlobalPLE cfg +  || allowLocalPLE cfg  allowGlobalPLE :: Config -> Bool-allowGlobalPLE cfg-  =  proofLogicEval  cfg-  || autoInstantiate cfg == LiquidInstances+allowGlobalPLE cfg = proofLogicEval  cfg  allowLocalPLE :: Config -> Bool-allowLocalPLE cfg-  =  proofLogicEval  cfg-  || autoInstantiate cfg == LiquidInstancesLocal---- NO-TRIGGER instance Default ProofMethod where-  -- NO-TRIGGER def = Rewrite--- NO-TRIGGER--- NO-TRIGGER instance Show ProofMethod where-  -- NO-TRIGGER show Rewrite    = "rewrite"-  -- NO-TRIGGER show AllMethods = "all"--instance Default Instantiate where-  def = NoInstances--instance Show Instantiate where-  show NoInstances           = "none"-  -- show SMTInstances          = "SMT"-  show LiquidInstancesLocal  = "liquid-local"-  show LiquidInstances       = "liquid-global"-+allowLocalPLE cfg = proofLogicEvalLocal  cfg  instance HasConfig  Config where   getConfig x = x@@ -136,29 +112,40 @@ class HasConfig t where   getConfig :: t -> Config -  patternFlag :: t -> Bool-  patternFlag = not . noPatternInline . getConfig+patternFlag :: (HasConfig t) => t -> Bool+patternFlag = not . noPatternInline . getConfig -  higherOrderFlag :: t -> Bool-  higherOrderFlag = higherorder . getConfig+higherOrderFlag :: (HasConfig t) => t -> Bool+higherOrderFlag x = higherorder cfg || reflection cfg +  where +    cfg           = getConfig x -  pruneFlag :: t -> Bool-  pruneFlag = pruneUnsorted . getConfig+exactDCFlag :: (HasConfig t) => t -> Bool+exactDCFlag x = exactDC cfg || reflection cfg +  where +    cfg       = getConfig x -  expandFlag :: t -> Bool-  expandFlag = not . nocaseexpand . getConfig+pruneFlag :: (HasConfig t) => t -> Bool+pruneFlag = pruneUnsorted . getConfig -  hasOpt :: t -> (Config -> Bool) -> Bool-  hasOpt t f = f (getConfig t)+maxCaseExpand :: (HasConfig t) => t -> Int +maxCaseExpand = caseExpandDepth . getConfig -  totalityCheck :: t -> Bool-  totalityCheck = totalityCheck' . getConfig+hasOpt :: (HasConfig t) => t -> (Config -> Bool) -> Bool+hasOpt t f = f (getConfig t) -  terminationCheck :: t -> Bool-  terminationCheck = terminationCheck' . getConfig+totalityCheck :: (HasConfig t) => t -> Bool+totalityCheck = totalityCheck' . getConfig +terminationCheck :: (HasConfig t) => t -> Bool+terminationCheck = terminationCheck' . getConfig+ totalityCheck' :: Config -> Bool totalityCheck' cfg = (not (nototality cfg)) || totalHaskell cfg  terminationCheck' :: Config -> Bool-terminationCheck' cfg = totalHaskell cfg || not (notermination cfg)+terminationCheck' cfg = (totalHaskell cfg || not (notermination cfg)) ++structuralTerm :: (HasConfig a) => a -> Bool +structuralTerm = not . nostructuralterm . getConfig+
src/Language/Haskell/Liquid/UX/DiffCheck.hs view
@@ -47,18 +47,16 @@ import qualified Data.List                              as L import           System.Directory                       (copyFile, doesFileExist) import           Language.Fixpoint.Types                (atLoc, PPrint (..), FixResult (..), Located (..))--- import            Language.Fixpoint.Misc          (traceShow) import           Language.Fixpoint.Utils.Files-import           Language.Haskell.Liquid.Types          (LocSpecType, ErrorResult, GhcSpec (..), AnnInfo (..),  Output (..)) --DataConP (..),)+import           Language.Haskell.Liquid.Types          hiding (Def, LMap) -- (LocSpecType, ErrorResult, GhcSpecSig (..), GhcSpecData (..), GhcSpec (..), AnnInfo (..),  Output (..))  import           Language.Haskell.Liquid.Misc           (ifM, mkGraph) import           Language.Haskell.Liquid.GHC.Misc-import           Language.Haskell.Liquid.Types.Visitors-import           Language.Haskell.Liquid.UX.Errors      ()+-- import           Language.Haskell.Liquid.Types.Visitors import           Text.Parsec.Pos                        (sourceName, sourceLine, sourceColumn, SourcePos, newPos) import           Text.PrettyPrint.HughesPJ              (text, render, Doc)-import           Language.Haskell.Liquid.Types.Errors+-- import           Language.Haskell.Liquid.Types.Errors import qualified Data.ByteString                        as B-import qualified Data.ByteString.Lazy                   as LB+import qualified Data.ByteString.Lazy                   as LB                                                 -------------------------------------------------------------------------------- -- | Data Types ----------------------------------------------------------------@@ -139,12 +137,13 @@ --   whose bodies have been pruned from [CoreBind] into the "assumes"  assumeSpec :: M.HashMap Var LocSpecType -> GhcSpec -> GhcSpec-assumeSpec sigm sp = sp { gsAsmSigs = M.toList $ M.union sigm assm }+assumeSpec sigm sp = sp { gsSig = gsig { gsAsmSigs = M.toList $ M.union sigm assm } }   where-    assm           = M.fromList $ gsAsmSigs sp+    assm           = M.fromList (gsAsmSigs gsig) +    gsig           = gsSig sp  diffVars :: [Int] -> [Def] -> [Var]-diffVars ls defs'    = tracePpr ("INCCHECK: diffVars lines = " ++ show ls ++ " defs= " ++ show defs) $+diffVars ls defs'    = -- tracePpr ("INCCHECK: diffVars lines = " ++ show ls ++ " defs= " ++ show defs) $                          go (L.sort ls) defs   where     defs             = L.sort defs'@@ -161,11 +160,12 @@     ok             = not . isDiff srcF ls  globalDiff :: FilePath -> [Int] -> GhcSpec -> Bool-globalDiff srcF ls spec = measDiff || invsDiff || dconsDiff+globalDiff srcF ls gspec = measDiff || invsDiff || dconsDiff   where     measDiff  = any (isDiff srcF ls) (snd <$> gsMeas spec)     invsDiff  = any (isDiff srcF ls) (snd <$> gsInvariants spec)-    dconsDiff = any (isDiff srcF ls) [ atLoc ldc () | ldc <- gsDconsP spec ]+    dconsDiff = any (isDiff srcF ls) [ atLoc ldc () | ldc <- gsDconsP (gsName gspec) ]+    spec      = gsData gspec     -- (dloc . snd <$> gsDconsP spec)     -- dloc dc   = Loc (dc_loc dc) (dc_locE dc) () @@ -257,7 +257,9 @@     sameFile   = (srcF ==) . file . snd  specSigs :: GhcSpec -> [(Var, LocSpecType)]-specSigs sp = gsTySigs sp ++ gsAsmSigs sp ++ gsCtors sp+specSigs sp = gsTySigs  (gsSig  sp) +           ++ gsAsmSigs (gsSig  sp) +           ++ gsCtors   (gsData sp)  -------------------------------------------------------------------------------- coreDefs     :: [CoreBind] -> [Def]
src/Language/Haskell/Liquid/UX/Errors.hs view
@@ -1,85 +1,130 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections     #-}+{-# LANGUAGE BangPatterns      #-}  -- | This module contains the functions related to @Error@ type, -- in particular, to @tidyError@ using a solution, and @pprint@ errors. --- TODO: move this into Tidy.--module Language.Haskell.Liquid.UX.Errors-  ( -- * Cleanup an Error-    tidyError- ) where+module Language.Haskell.Liquid.UX.Errors ( tidyError ) where  import           Control.Arrow                       (second) import qualified Data.HashMap.Strict                 as M import qualified Data.HashSet                        as S+import qualified Data.List                           as L import           Data.Hashable import           Data.Maybe                          (maybeToList)-import           Language.Fixpoint.Types             hiding (Error, SrcSpan, shiftVV)+import qualified Language.Fixpoint.Types             as F  import           Language.Haskell.Liquid.Types.RefType import           Language.Haskell.Liquid.Transforms.Simplify import           Language.Haskell.Liquid.UX.Tidy import           Language.Haskell.Liquid.Types-import           Language.Haskell.Liquid.Misc        (single)+import qualified Language.Haskell.Liquid.GHC.Misc    as GM +import qualified Language.Haskell.Liquid.Misc        as Misc +import qualified Language.Fixpoint.Misc              as Misc   -- import Debug.Trace -type Ctx = M.HashMap Symbol SpecType-type CtxM = M.HashMap Symbol (WithModel SpecType)+type Ctx  = M.HashMap F.Symbol SpecType+type CtxM = M.HashMap F.Symbol (WithModel SpecType)  -------------------------------------------------------------------------tidyError :: FixSolution -> Error -> Error+tidyError :: Config -> F.FixSolution -> Error -> Error -------------------------------------------------------------------------tidyError sol-  = fmap (tidySpecType Full)-  . tidyErrContext sol+tidyError cfg sol+  = fmap (tidySpecType tidy) +  . tidyErrContext tidy sol+  where +    tidy = configTidy cfg  -tidyErrContext :: FixSolution -> Error -> Error-tidyErrContext _ e@(ErrSubType {})-  = e { ctx = c', tact = subst θ tA, texp = subst θ tE }+configTidy :: Config -> F.Tidy +configTidy cfg +  | shortNames cfg = F.Lossy +  | otherwise      = F.Full ++tidyErrContext :: F.Tidy -> F.FixSolution -> Error -> Error+tidyErrContext k _ e@(ErrSubType {})+  = e { ctx = c', tact = F.subst θ tA, texp = F.subst θ tE }     where-      (θ, c') = tidyCtx xs $ ctx e-      xs      = syms tA ++ syms tE+      (θ, c') = tidyCtx k xs (ctx e)+      xs      = F.syms tA ++ F.syms tE       tA      = tact e       tE      = texp e -tidyErrContext _ e@(ErrSubTypeModel {})-  = e { ctxM = c', tactM = fmap (subst θ) tA, texp = fmap (subst θ) tE }+tidyErrContext _ _ e@(ErrSubTypeModel {})+  = e { ctxM = c', tactM = fmap (F.subst θ) tA, texp = fmap (F.subst θ) tE }     where       (θ, c') = tidyCtxM xs $ ctxM e-      xs      = syms tA ++ syms tE+      xs      = F.syms tA ++ F.syms tE       tA      = tactM e       tE      = texp e -tidyErrContext _ e@(ErrAssType {})-  = e { ctx = c', cond = subst θ p }+tidyErrContext k _ e@(ErrAssType {})+  = e { ctx = c', cond = F.subst θ p }     where       m       = ctx e-      (θ, c') = tidyCtx xs m-      xs      = syms p+      (θ, c') = tidyCtx k xs m+      xs      = F.syms p       p       = cond e -tidyErrContext _ e+tidyErrContext _ _ e   = e  ---------------------------------------------------------------------------------tidyCtx       :: [Symbol] -> Ctx -> (Subst, Ctx)+tidyCtx       :: F.Tidy -> [F.Symbol] -> Ctx -> (F.Subst, Ctx) ---------------------------------------------------------------------------------tidyCtx xs m  = (θ, M.fromList yts)+tidyCtx k xs m = (θ1 `mappend` θ2, M.fromList yts)   where-    yts       = [tBind x $ tidySpecType Full t | (x, t) <- xts]-    (θ, xts)  = tidyTemps $ second stripReft <$> tidyREnv xs m-    tBind x t = (x', shiftVV t x') where x' = tidySymbol x+    yts        = [tBind x (tidySpecType k t) | (x, t) <- xt2s]+    (θ2, xt2s) = tidyREnv xt1s +    (θ1, xt1s) = tidyTemps xts  +    xts        = sliceREnv xs m +    tBind x t  = (x', shiftVV t x') where x' = F.tidySymbol x -tidyCtxM       :: [Symbol] -> CtxM -> (Subst, CtxM)+tidyCtxM       :: [F.Symbol] -> CtxM -> (F.Subst, CtxM) tidyCtxM xs m  = (θ, M.fromList yts)   where     yts       = [tBind x t | (x, t) <- xts]     (θ, xts)  = tidyTemps $ second (fmap stripReft) <$> tidyREnvM xs m-    tBind x t = (x', fmap (\t -> shiftVV t x') t) where x' = tidySymbol x+    tBind x t = (x', fmap (\t -> shiftVV t x') t) where x' = F.tidySymbol x +tidyREnv :: [(F.Symbol, SpecType)] -> (F.Subst, [(F.Symbol, SpecType)])+tidyREnv xts    = (θ, second (F.subst θ) <$> zts)+  where +    θ           = expandVarDefs yes +    (yes, zts)  = Misc.mapEither isInline xts  +-- | 'expandVarDefs [(x1, e1), ... ,(xn, en)] returns a `Subst` that  +--   contains the fully substituted definitions for each `xi`. For example, +--      expandVarDefs [(x1, 'x2 + x3'), (x5, 'x1 + 1')] +--   should return +--     [x1 := 'x2 + x3, x5 := (x2 + x3) + 1]++expandVarDefs :: [(F.Symbol, F.Expr)] -> F.Subst +expandVarDefs      = go mempty +  where +    go !su xes     +      | null yes   = su `mappend` (F.mkSubst xes)+      | otherwise  = go (su `mappend` su') xes''+      where  +       xes''       = [(z, F.subst su' e) | (z, e) <- zes] +       xs          = S.fromList [x | (x, _) <- xes] +       su'         = F.mkSubst yes+       (yes, zes)  = L.partition (isDef xs . snd) xes +    isDef xs e     = all (not . (`S.member` xs)) (F.syms e) ++isInline :: (a, SpecType) -> Either (a, F.Expr) (a, SpecType) +isInline (x, t) = either (Left . (x,)) (Right . (x,)) (isInline' t) ++isInline' :: SpecType -> Either F.Expr SpecType +isInline' t = case ro of +                Nothing -> Right t' +                Just rr -> case F.isSingletonReft (ur_reft rr) of +                             Just e  -> Left e+                             Nothing -> Right (strengthen t' rr) +              where +                  (t', ro) = stripRType t + stripReft     :: SpecType -> SpecType stripReft t   = maybe t' (strengthen t') ro   where@@ -92,18 +137,18 @@     ro        = stripRTypeBase  t     t         = simplifyBounds st -tidyREnv      :: [Symbol] -> Ctx -> [(Symbol, SpecType)]-tidyREnv xs m = [(x, t) | x <- xs', t <- maybeToList (M.lookup x m), ok t]+sliceREnv :: [F.Symbol] -> Ctx -> [(F.Symbol, SpecType)]+sliceREnv xs m = [(x, t) | x <- xs', t <- maybeToList (M.lookup x m), ok t]   where     xs'       = expandFix deps xs-    deps y    = maybe [] (syms . rTypeReft) (M.lookup y m)+    deps y    = maybe [] (F.syms . rTypeReft) (M.lookup y m)     ok        = not . isFunTy -tidyREnvM      :: [Symbol] -> CtxM -> [(Symbol, WithModel SpecType)]+tidyREnvM      :: [F.Symbol] -> CtxM -> [(F.Symbol, WithModel SpecType)] tidyREnvM xs m = [(x, t) | x <- xs', t <- maybeToList (M.lookup x m), ok t]   where     xs'       = expandFix deps xs-    deps y    = maybe [] (syms . rTypeReft . dropModel) (M.lookup y m)+    deps y    = maybe [] (F.syms . rTypeReft . dropModel) (M.lookup y m)     ok        = not . isFunTy . dropModel  expandFix :: (Eq a, Hashable a) => (a -> [a]) -> [a] -> [a]@@ -114,19 +159,19 @@       | x `S.member` seen = go seen xs       | otherwise         = go (S.insert x seen) (f x ++ xs) -tidyTemps     :: (Subable t) => [(Symbol, t)] -> (Subst, [(Symbol, t)])+tidyTemps     :: (F.Subable t) => [(F.Symbol, t)] -> (F.Subst, [(F.Symbol, t)]) tidyTemps xts = (θ, [(txB x, txTy t) | (x, t) <- xts])   where     txB  x    = M.lookupDefault x x m-    txTy      = subst θ+    txTy      = F.subst θ     m         = M.fromList yzs-    θ         = mkSubst [(y, EVar z) | (y, z) <- yzs]+    θ         = F.mkSubst [(y, F.EVar z) | (y, z) <- yzs]     yzs       = zip ys niceTemps-    ys        = [ x | (x,_) <- xts, isTmpSymbol x]+    ys        = [ x | (x,_) <- xts, GM.isTmpSymbol x] -niceTemps     :: [Symbol]+niceTemps     :: [F.Symbol] niceTemps     = mkSymbol <$> xs ++ ys   where-    mkSymbol  = symbol . ('?' :)-    xs        = single   <$> ['a' .. 'z']+    mkSymbol  = F.symbol . ('?' :)+    xs        = Misc.single <$> ['a' .. 'z']     ys        = ("a" ++) <$> [show n | n <- [0 ..]]
src/Language/Haskell/Liquid/UX/QuasiQuoter.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DeriveFunctor      #-}+{-# LANGUAGE TemplateHaskell    #-}+{-# LANGUAGE TupleSections      #-}+{-# LANGUAGE OverloadedStrings  #-}  module Language.Haskell.Liquid.UX.QuasiQuoter (     -- * LiquidHaskell Specification QuasiQuoter@@ -23,7 +24,6 @@ import Language.Haskell.TH.Quote  import Text.Parsec.Pos-import Text.PrettyPrint.HughesPJ  import Language.Fixpoint.Types hiding (Error, Loc, SrcSpan) import qualified Language.Fixpoint.Types as F@@ -31,7 +31,6 @@ import Language.Haskell.Liquid.GHC.Misc (fSrcSpan) import Language.Haskell.Liquid.Parse import Language.Haskell.Liquid.Types-import Language.Haskell.Liquid.Types.RefType import Language.Haskell.Liquid.UX.Tidy  --------------------------------------------------------------------------------@@ -64,7 +63,7 @@  throwErrorInQ :: UserError -> Q a throwErrorInQ err =-  fail . showpp =<< runIO (errorWithContext err)+  fail . showpp =<< runIO (errorsWithContext [err])  -------------------------------------------------------------------------------- -- Liquid Haskell to Template Haskell ------------------------------------------@@ -83,11 +82,12 @@   (\t -> (`SigD` t) . symbolName <$> names)     <$> simplifyBareType (head names) (quantifyFreeRTy $ val ty) mkSpecDecs (Alias rta) =-  return . (TySynD name tvs) <$> simplifyBareType lsym (rtBody rta)+  return . (TySynD name tvs) <$> simplifyBareType lsym (rtBody (val rta))   where-    lsym = F.Loc (rtPos rta) (rtPosE rta) (rtName rta)-    name = symbolName $ rtName rta-    tvs  = PlainTV . symbolName <$> rtTArgs rta+    lsym = F.atLoc rta n +    name = symbolName n +    n    = rtName (val rta)+    tvs  = PlainTV . symbolName <$> rtTArgs (val rta) mkSpecDecs _ =   Right [] @@ -103,10 +103,10 @@   Simplified t' ->     Right t'   FoundExprArg l ->-    Left $ ErrTySpec l (pprint $ val s) (pprint t) $ text+    Left $ ErrTySpec l Nothing (pprint $ val s) (pprint t) $        "Found expression argument in bad location in type"   FoundHole ->-    Left $ ErrTySpec (fSrcSpan s) (pprint $ val s) (pprint t) $ text+    Left $ ErrTySpec (fSrcSpan s) Nothing (pprint $ val s) (pprint t) $        "Can't write LiquidHaskell type with hole in a quasiquoter"  simplifyBareType' :: BareType -> Simpl Type
+ src/Language/Haskell/Liquid/UX/Server.hs view
@@ -0,0 +1,58 @@+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
@@ -15,9 +15,6 @@     tidySpecType   , tidySymbol -    -- * Tidyness tests-  , isTmpSymbol-     -- * Panic and Exit   , panicError @@ -38,9 +35,10 @@ import qualified Data.List                                 as L import qualified Data.Text                                 as T import qualified Control.Exception                         as Ex-import           Language.Haskell.Liquid.GHC.Misc          (showPpr, stringTyVar)+import qualified Language.Haskell.Liquid.GHC.Misc          as GM +-- (dropModuleNames, showPpr, stringTyVar) import           Language.Fixpoint.Types                   hiding (Result, SrcSpan, Error)-import           Language.Haskell.Liquid.Types+import           Language.Haskell.Liquid.Types.Types import           Language.Haskell.Liquid.Types.RefType     (rVar, subsTyVars_meet, FreeVar) import           Language.Haskell.Liquid.Types.PrettyPrint import           Data.Generics                             (everywhere, mkT)@@ -72,25 +70,20 @@ -- TODO: move to Types.hs cinfoError :: Cinfo -> Error cinfoError (Ci _ (Just e) _) = e-cinfoError (Ci l _ _)        = ErrOther l (text $ "Cinfo:" ++ showPpr l)----------------------------------------------------------------------------isTmpSymbol    :: Symbol -> Bool---------------------------------------------------------------------------isTmpSymbol x  = any (`isPrefixOfSym` x) [anfPrefix, tempPrefix, "ds_"]-+cinfoError (Ci l _ _)        = ErrOther l (text $ "Cinfo:" ++ GM.showPpr l)  ------------------------------------------------------------------------- tidySpecType :: Tidy -> SpecType -> SpecType --------------------------------------------------------------------------tidySpecType k = tidyEqual -               . tidyValueVars-               . tidyDSymbols-               . tidySymbols-               . tidyInternalRefas-               . tidyLocalRefas k-               . tidyFunBinds-               . tidyTyVars+tidySpecType k +  = tidyEqual +  . tidyValueVars+  . tidyDSymbols+  . tidySymbols k +  . tidyInternalRefas+  . tidyLocalRefas k+  . tidyFunBinds+  . tidyTyVars  tidyValueVars :: SpecType -> SpecType tidyValueVars = mapReft $ \u -> u { ur_reft = tidyVV $ ur_reft u }@@ -105,12 +98,15 @@     xs        = syms r     isJunk    = isPrefixOfSym "x" -tidySymbols :: SpecType -> SpecType-tidySymbols t = substa tidySymbol $ mapBind dropBind t+tidySymbols :: Tidy -> SpecType -> SpecType+tidySymbols k t = substa (shortSymbol k . tidySymbol) $ mapBind dropBind t   where-    xs         = S.fromList (syms t)-    dropBind x = if x `S.member` xs then tidySymbol x else nonSymbol+    xs          = S.fromList (syms t)+    dropBind x  = if x `S.member` xs then tidySymbol x else nonSymbol +shortSymbol :: Tidy -> Symbol -> Symbol +shortSymbol Lossy = GM.dropModuleNames +shortSymbol _     = id   tidyLocalRefas   :: Tidy -> SpecType -> SpecType tidyLocalRefas k = mapReft (txStrata . txReft' k)@@ -123,7 +119,6 @@     isTmp x                       = any (`isPrefixOfSym` x) [anfPrefix, "ds_"]     txStr                         = filter (not . isSVar) - tidyEqual :: SpecType -> SpecType tidyEqual = mapReft txReft   where @@ -147,14 +142,14 @@ tidyFunBinds :: SpecType -> SpecType tidyFunBinds t = mapBind tx $ substa tx t   where-    tx         = bindersTx $ filter isTmpSymbol $ funBinds t+    tx         = bindersTx $ filter GM.isTmpSymbol $ funBinds t  tidyTyVars :: SpecType -> SpecType tidyTyVars t = subsTyVarsAll αβs t   where     αβs  = zipWith (\α β -> (α, toRSort β, β)) αs βs     αs   = L.nub (tyVars t)-    βs   = map (rVar . stringTyVar) pool+    βs   = map (rVar . GM.stringTyVar) pool     pool = [[c] | c <- ['a'..'z']] ++ [ "t" ++ show i | i <- [1..]]  @@ -165,10 +160,11 @@     var        = symbol . ('x' :) . show  -tyVars :: RType t a t1 -> [a]+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 (RImpF _ t t' _) = tyVars t ++ tyVars t' tyVars (RFun _ t t' _) = tyVars t ++ tyVars t' tyVars (RAppTy t t' _) = tyVars t ++ tyVars t' tyVars (RApp _ ts _ _) = concatMap tyVars ts@@ -199,6 +195,7 @@ 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 funBinds (RAllE b t1 t2)  = b : funBinds t1 ++ funBinds t2
src/Language/Haskell/Liquid/WiredIn.hs view
@@ -5,31 +5,40 @@        , wiredDataCons        , wiredSortedSyms -       -- | Constants for automatic proofs-       , dictionaryVar, dictionaryTyVar, dictionaryBind-       , proofTyConName, combineProofsName+       -- * Constants for automatic proofs+       , dictionaryVar+       , dictionaryTyVar+       , dictionaryBind+       , proofTyConName+       , combineProofsName -       -- | Built  in Symbols+       -- * Built in symbols        , isWiredIn+       , isWiredInName        , dcPrefix +       -- * Deriving classes +       , isDerivedInstance         ) where  import Prelude                                hiding (error) import Var -import Language.Haskell.Liquid.Types-import Language.Fixpoint.Misc           (mapSnd)-import Language.Haskell.Liquid.Types.RefType+-- import Language.Fixpoint.Misc           (mapSnd) import Language.Haskell.Liquid.GHC.Misc+import qualified Language.Haskell.Liquid.GHC.API as Ghc+import Language.Haskell.Liquid.Types.Types+import Language.Haskell.Liquid.Types.RefType import Language.Haskell.Liquid.Types.Variance import Language.Haskell.Liquid.Types.PredType-import Language.Fixpoint.Types hiding (panic)++-- import Language.Fixpoint.Types hiding (panic) import qualified Language.Fixpoint.Types as F+import qualified Data.HashSet as S   import BasicTypes-import DataCon-import TyCon+-- import DataCon+-- import TyCon import TysWiredIn  import Language.Haskell.Liquid.GHC.TypeRep@@ -41,23 +50,23 @@ --   *do not* correspond to GHC Vars and --   *should not* be resolved to GHC Vars. -isWiredIn :: Located Symbol -> Bool-isWiredIn x = isWiredInLoc x  || isWiredInName x || isWiredInShape x+isWiredIn :: F.LocSymbol -> Bool+isWiredIn x = isWiredInLoc x  || isWiredInName (val x) || isWiredInShape x -isWiredInLoc :: Located Symbol -> Bool+isWiredInLoc :: F.LocSymbol -> Bool isWiredInLoc x  = l == l' && l == 0 && c == c' && c' == 0   where     (l , c)  = spe (loc x)     (l', c') = spe (locE x)-    spe l    = (x, y) where (_, x, y) = sourcePosElts l+    spe l    = (x, y) where (_, x, y) = F.sourcePosElts l -isWiredInName :: Located Symbol -> Bool-isWiredInName x = (val x) `elem` wiredInNames+isWiredInName :: F.Symbol -> Bool+isWiredInName x = x `S.member` wiredInNames -wiredInNames :: [F.Symbol]-wiredInNames = [ "head", "tail", "fst", "snd", "len" ]+wiredInNames :: S.HashSet F.Symbol+wiredInNames = S.fromList [ "head", "tail", "fst", "snd", "len" ] -isWiredInShape :: Located Symbol -> Bool+isWiredInShape :: F.LocSymbol -> Bool isWiredInShape x = any (`F.isPrefixOfSym` (val x)) [F.anfPrefix, F.tempPrefix, dcPrefix]   -- where s        = val x         -- dcPrefix = "lqdc"@@ -65,7 +74,7 @@ dcPrefix :: F.Symbol dcPrefix = "lqdc" -wiredSortedSyms :: [(Symbol, Sort)]+wiredSortedSyms :: [(F.Symbol, F.Sort)] wiredSortedSyms = [(pappSym n, pappSort n) | n <- [1..pappArity]]  --------------------------------------------------------------------------------@@ -84,8 +93,6 @@    v = dictionaryVar    a = dictionaryTyVar -- ----------------------------------------------------------------------- -- | LH Primitive TyCons ---------------------------------------------- -----------------------------------------------------------------------@@ -94,7 +101,7 @@ combineProofsName :: String combineProofsName = "combineProofs" -proofTyConName :: Symbol+proofTyConName :: F.Symbol proofTyConName = "Proof"  --------------------------------------------------------------------------------@@ -104,47 +111,47 @@ maxArity :: Arity maxArity = 7 -wiredTyCons :: [(TyCon, TyConP)]-wiredTyCons     = fst wiredTyDataCons+wiredTyCons :: [TyConP]+wiredTyCons  = fst wiredTyDataCons -wiredDataCons :: [(DataCon, Located DataConP)]-wiredDataCons   = snd wiredTyDataCons+wiredDataCons :: [Located DataConP]+wiredDataCons = snd wiredTyDataCons -wiredTyDataCons :: ([(TyCon, TyConP)] , [(DataCon, Located DataConP)])-wiredTyDataCons = (concat tcs, mapSnd dummyLoc <$> concat dcs)+wiredTyDataCons :: ([TyConP] , [Located DataConP])+wiredTyDataCons = (concat tcs, dummyLoc <$> concat dcs)   where     (tcs, dcs)  = unzip $ listTyDataCons : map tupleTyDataCons [2..maxArity] -listTyDataCons :: ([(TyCon, TyConP)] , [(DataCon, DataConP)])-listTyDataCons   = ( [(c, TyConP l0 [RTV tyv] [p] [] [Covariant] [Covariant] (Just fsize))]-                   , [(nilDataCon , DataConP l0 [RTV tyv] [p] [] [] []    lt False wiredInName l0)-                     ,(consDataCon, DataConP l0 [RTV tyv] [p] [] [] cargs lt False wiredInName l0)])+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)])     where-      l0         = dummyPos "LH.Bare.listTyDataCons"+      l0         = F.dummyPos "LH.Bare.listTyDataCons"       c          = listTyCon       [tyv]      = tyConTyVarsDef c       t          = rVar tyv :: RSort       fld        = "fldList"       xHead      = "head"       xTail      = "tail"-      p          = PV "p" (PVProp t) (vv Nothing) [(t, fld, EVar fld)]-      px         = pdVarReft $ PV "p" (PVProp t) (vv Nothing) [(t, fld, EVar xHead)]+      p          = PV "p" (PVProp t) (F.vv Nothing) [(t, fld, F.EVar fld)]+      px         = pdVarReft $ PV "p" (PVProp t) (F.vv Nothing) [(t, fld, F.EVar xHead)]       lt         = rApp c [xt] [rPropP [] $ pdVarReft p] mempty       xt         = rVar tyv       xst        = rApp c [RVar (RTV tyv) px] [rPropP [] $ pdVarReft p] mempty       cargs      = [(xTail, xst), (xHead, xt)]       fsize      = SymSizeFun (dummyLoc "len") -wiredInName :: Symbol+wiredInName :: F.Symbol wiredInName = "WiredIn" -tupleTyDataCons :: Int -> ([(TyCon, TyConP)] , [(DataCon, DataConP)])-tupleTyDataCons n = ( [(c, TyConP l0 (RTV <$> tyvs) ps [] tyvarinfo pdvarinfo Nothing)]-                    , [(dc, DataConP l0 (RTV <$> tyvs) ps [] []  cargs  lt False wiredInName l0)])+tupleTyDataCons :: Int -> ([TyConP] , [DataConP])+tupleTyDataCons n = ( [(TyConP   l0 c  (RTV <$> tyvs) ps [] tyvarinfo pdvarinfo Nothing)]+                    , [(DataConP l0 dc (RTV <$> tyvs) ps [] []  cargs  lt False wiredInName l0)])   where     tyvarinfo     = replicate n     Covariant     pdvarinfo     = replicate (n-1) Covariant-    l0            = dummyPos "LH.Bare.tupleTyDataCons"+    l0            = F.dummyPos "LH.Bare.tupleTyDataCons"     c             = tupleTyCon   Boxed n     dc            = tupleDataCon Boxed n     tyvs@(tv:tvs) = tyConTyVarsDef c@@ -152,31 +159,56 @@     flds          = mks "fld_Tuple"     fld           = "fld_Tuple"     x1:xs         = mks ("x_Tuple" ++ show n)-    ps            = mkps pnames (ta:ts) ((fld, EVar fld) : zip flds (EVar <$> flds))+    ps            = mkps pnames (ta:ts) ((fld, F.EVar fld) : zip flds (F.EVar <$> flds))     ups           = uPVar <$> ps-    pxs           = mkps pnames (ta:ts) ((fld, EVar x1) : zip flds (EVar <$> xs))+    pxs           = mkps pnames (ta:ts) ((fld, F.EVar x1) : zip flds (F.EVar <$> xs))     lt            = rApp c (rVar <$> tyvs) (rPropP [] . pdVarReft <$> ups) mempty     xts           = zipWith (\v p -> RVar (RTV v) (pdVarReft p)) tvs pxs     cargs         = reverse $ (x1, rVar tv) : zip xs xts     pnames        = mks_ "p"-    mks  x        = (\i -> symbol (x++ show i)) <$> [1..n]-    mks_ x        = (\i -> symbol (x++ show i)) <$> [2..n]+    mks  x        = (\i -> F.symbol (x++ show i)) <$> [1..n]+    mks_ x        = (\i -> F.symbol (x++ show i)) <$> [2..n]  -mkps :: [Symbol]-     -> [t] -> [(Symbol, F.Expr)] -> [PVar t]+mkps :: [F.Symbol]+     -> [t] -> [(F.Symbol, F.Expr)] -> [PVar t] mkps ns (t:ts) ((f,x):fxs) = reverse $ mkps_ ns ts fxs [(t, f, x)] [] mkps _  _      _           = panic Nothing "Bare : mkps" -mkps_ :: [Symbol]+mkps_ :: [F.Symbol]       -> [t]-      -> [(Symbol, F.Expr)]-      -> [(t, Symbol, F.Expr)]+      -> [(F.Symbol, F.Expr)]+      -> [(t, F.Symbol, F.Expr)]       -> [PVar t]       -> [PVar t] mkps_ []     _       _          _    ps = ps mkps_ (n:ns) (t:ts) ((f, x):xs) args ps = mkps_ ns ts xs (a:args) (p:ps)   where-    p                                   = PV n (PVProp t) (vv Nothing) args+    p                                   = PV n (PVProp t) (F.vv Nothing) args     a                                   = (t, f, x) mkps_ _     _       _          _    _ = panic Nothing "Bare : mkps_"+++--------------------------------------------------------------------------------+isDerivedInstance :: Ghc.ClsInst -> Bool +--------------------------------------------------------------------------------+isDerivedInstance i = F.notracepp ("IS-DERIVED: " ++ F.showpp classSym) +                    $ S.member classSym derivingClasses +  where +    classSym        = F.symbol . Ghc.is_cls $ i+  +derivingClasses :: S.HashSet F.Symbol +derivingClasses = S.fromList +  [ "GHC.Classes.Eq"+  , "GHC.Classes.Ord"+  , "GHC.Enum.Enum"+  , "GHC.Show.Show"+  , "GHC.Read.Read"+  , "GHC.Base.Monad"+  , "GHC.Base.Applicative"+  , "GHC.Base.Functor"+  , "Data.Foldable.Foldable"+  , "Data.Traversable.Traversable"+  -- , "GHC.Enum.Bounded"+  -- , "GHC.Base.Monoid"+  ]
src/Liquid.hs view
@@ -1,5 +1,6 @@ import Language.Haskell.Liquid.Liquid (liquid) import System.Environment             (getArgs)+-- import GhcTest   main :: IO a main = liquid =<< getArgs
+ src/Target.hs view
@@ -0,0 +1,29 @@+{-# 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
− src/Test/Target.hs 
@@ -1,98 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ViewPatterns #-}-module Test.Target-  ( target, targetResult, targetWith, targetResultWith-  , targetTH, targetResultTH, targetWithTH, targetResultWithTH-  , Result(..), Testable, Targetable(..)-  , TargetOpts(..), defaultOpts-  , Test(..)-  , monomorphic-  ) where---import           Control.Monad-import           Control.Monad.Catch-import           Control.Monad.State-import qualified Language.Haskell.TH             as TH-import qualified Language.Haskell.TH.Syntax      as TH-import           System.Process                  (terminateProcess)-import           Test.QuickCheck.All             (monomorphic)-import           Text.Printf                     (printf)--import           Language.Fixpoint.Types.Names-import           Language.Fixpoint.Smt.Interface-import qualified Language.Fixpoint.Types.Config  as F--import           Test.Target.Monad-import           Test.Target.Targetable (Targetable(..))-import           Test.Target.Targetable.Function ()-import           Test.Target.Testable-import           Test.Target.Types-import           Test.Target.Util---- | Test whether a function inhabits its refinement type by enumerating valid--- inputs and calling the function.-target :: Testable f-       => f                 -- ^ the function-       -> String            -- ^ the name of the function-       -> FilePath          -- ^ the path to the module that defines the function-       -> IO ()-target f name path-  = targetWith f name path defaultOpts--targetTH :: TH.Name -> TH.Q (TH.TExp (FilePath -> IO ()))-targetTH f = TH.unsafeTExpCoerce-           $ TH.appsE [TH.varE 'target, monomorphic f, TH.stringE (show f)]---- targetTH :: TH.ExpQ -- (TH.TExp (Testable f => f -> TH.Name -> IO ()))--- targetTH = TH.location >>= \TH.Loc {..} ->---   [| \ f n -> target f (show n) loc_filename |]---- | Like 'target', but returns the 'Result' instead of printing to standard out.-targetResult :: Testable f => f -> String -> FilePath -> IO Result-targetResult f name path-  = targetResultWith f name path defaultOpts--targetResultTH :: TH.Name -> TH.Q (TH.TExp (FilePath -> IO Result))-targetResultTH f = TH.unsafeTExpCoerce-                 $ TH.appsE [TH.varE 'targetResult, monomorphic f, TH.stringE (show f)]---- | Like 'target', but accepts options to control the enumeration depth,--- solver, and verbosity.-targetWith :: Testable f => f -> String -> FilePath -> TargetOpts -> IO ()-targetWith f name path opts-  = do res <- targetResultWith f name path opts-       case res of-         Passed n -> printf "OK. Passed %d tests\n\n" n-         Failed x -> printf "Found counter-example: %s\n\n" x-         Errored x -> printf "Error! %s\n\n" x--targetWithTH :: TH.Name -> TH.Q (TH.TExp (FilePath -> TargetOpts -> IO ()))-targetWithTH f = TH.unsafeTExpCoerce-               $ TH.appsE [TH.varE 'targetWith, monomorphic f, TH.stringE (show f)]---- | Like 'targetWith', but returns the 'Result' instead of printing to standard out.-targetResultWith :: Testable f => f -> String -> FilePath -> TargetOpts -> IO Result-targetResultWith f name path opts-  = do when (verbose opts) $-         printf "Testing %s\n" name-       sp  <- getSpec (ghcOpts opts) path-       ctx <- mkContext-       do r <- runTarget opts (initState path sp ctx) $ do-                 ty <- safeFromJust "targetResultWith" . lookup (symbol name) <$> gets sigs-                 test f ty-          _ <- cleanupContext ctx-          return r-        `onException` terminateProcess (ctxPid ctx)-  where-    mkContext = if logging opts-                then makeContext F.defConfig{F.solver = solver opts} (".target/" ++ name)-                else makeContextNoLog F.defConfig{F.solver = solver opts}--targetResultWithTH :: TH.Name -> TH.Q (TH.TExp (FilePath -> TargetOpts -> IO Result))-targetResultWithTH f = TH.unsafeTExpCoerce-                     $ TH.appsE [TH.varE 'targetResultWith, monomorphic f, TH.stringE (show f)]--data Test = forall t. Testable t => T t
− src/Test/Target/Eval.hs 
@@ -1,237 +0,0 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE LambdaCase        #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns      #-}-module Test.Target.Eval ( eval, evalWith, evalExpr ) where----import           Control.Monad.Catch-import           Control.Monad.State-import qualified Data.HashMap.Strict             as M--import           Data.List-import           Data.Maybe-import qualified Data.Set                        as S---import           Text.Printf--import qualified GHC--import           Language.Fixpoint.Smt.Types-import           Language.Fixpoint.Types         hiding (R)-import           Language.Haskell.Liquid.Types   hiding (var)--import           Test.Target.Expr-import           Test.Target.Monad--import           Test.Target.Types-import           Test.Target.Util---- import           Debug.Trace---- | Evaluate a refinement with the given expression substituted for the value--- variable.-eval :: Reft -> Expr -> Target Bool-eval r e = do-  cts <- gets freesyms-  evalWith (M.fromList $ map (\(_, c) -> (c, c `VC` [])) cts) r e---- | Evaluate a refinement with the given expression substituted for the value--- variable, in the given environment of free symbols.-evalWith :: M.HashMap Symbol Val -> Reft -> Expr -> Target Bool-evalWith m (Reft (v, p)) x-  = do xx <- evalExpr x m-                  -- FIXME: tidy is suspicious!!-       evalPred p (M.insert (tidySymbol v) xx m)---evalPred :: Expr -> M.HashMap Symbol Val -> Target Bool-evalPred PTrue           _ = return True-evalPred PFalse          _ = return False-evalPred (PAnd ps)       m = and <$> sequence [evalPred p m | p <- ps]-evalPred (POr ps)        m = or  <$> sequence [evalPred p m | p <- ps]-evalPred (PNot p)        m = not <$> evalPred p m-evalPred (PImp p q)      m = do pv <- evalPred p m-                                if pv-                                   then evalPred q m-                                   else return True-evalPred (PIff p q)      m = and <$> sequence [ evalPred (p `imp` q) m-                                              , evalPred (q `imp` p) m-                                              ]-evalPred (PAtom b e1 e2) m = evalBrel b <$> evalExpr e1 m <*> evalExpr e2 m-evalPred e@(splitEApp_maybe -> Just (f, es))    m-  = do isThy <- isTheorySymbol f-       if isThy-         then evalPredBlob1 m f es-         else evalPredBlob2 m e f es--- evalPred (PBexp e)       m = (==0) <$> evalPred e m-evalPred p               _ = throwM $ EvalError $ "evalPred: " ++ show p--- evalExpr (PAll ss p)     m = undefined--- evalExpr PTop            m = undefined--- evalExpr :: Expr -> M.HashMap Symbol Expr -> Target Expr---evalPredBlob1 :: M.HashMap Symbol Val -> Symbol -> [Expr] -> Target Bool-evalPredBlob1 m f es-  = mapM (`evalExpr` m) es >>= \es' -> fromExpr <$> evalSet f es'--evalPredBlob2 :: Show a => M.HashMap Symbol Val -> a -> Symbol -> [Expr] -> Target Bool-evalPredBlob2 m e f es-  = filter ((==f) . val . name) <$> gets measEnv >>= \case-      [] -> error $ "evalPred: cannot evaluate " ++ show e -- VC f <$> mapM (`evalExpr` m) es-                      --FIXME: should really extend this to multi-param measures..-      ms -> do e' <- evalExpr (head es) m-               fromExpr <$> applyMeasure (symbolString f) (concatMap eqns ms) e' m--fromExpr :: Val -> Bool-fromExpr (VB True) = True-fromExpr (VB False) = False-fromExpr e = error $ "fromExpr: " ++ show e ++ " is not boolean"--evalExpr :: Expr -> M.HashMap Symbol Val -> Target Val-evalExpr e m = do-  -- traceShowM ("evalExpr", e)-  evalExpr' e m--evalExpr' :: Expr -> M.HashMap Symbol Val -> Target Val-evalExpr' (ECon i)       _ = return $! VV i-evalExpr' (EVar x)       m = return $! -- traceShow (x,m)-                                       -- FIXME: tidy is fishy!!-                                       -- datacons are embedded as vars and may not-                                       -- be in the freesym environment-                                    fromMaybe (VC x []) (M.lookup (tidySymbol x) m)-evalExpr' (ESym s)       _ = return $! VX s-evalExpr' (EBin b e1 e2) m = evalBop b <$> evalExpr' e1 m <*> evalExpr' e2 m-evalExpr' (splitEApp_maybe -> Just (f, es))    m-  = do isThy <- isTheorySymbol f-       if isThy then evalExprBlob1 m f es-                else evalExprBlob2 m f es--evalExpr' (EIte p e1 e2) m-  = do b <- evalPred p m-       if b-         then evalExpr' e1 m-         else evalExpr' e2 m-evalExpr' e              _ = throwM $ EvalError $ printf "evalExpr(%s)" (show e)--isTheorySymbol :: Symbol -> Target Bool-isTheorySymbol f = do-  theorySymbols <- seTheory . ctxSymEnv <$> gets smtContext-  return (f == "Set_emp" || f == "Set_sng" || f `memberSEnv` theorySymbols)--evalExprBlob1 :: M.HashMap Symbol Val -> Symbol -> [Expr] -> Target Val-evalExprBlob1 m f es-  = mapM (`evalExpr'` m) es >>= \es' -> evalSet f es'--evalExprBlob2 :: M.HashMap Symbol Val -> Symbol -> [Expr] -> Target Val-evalExprBlob2 m f es-  = filter ((==f) . val . name) <$> gets measEnv >>= \case-      [] -> VC f <$> mapM (`evalExpr'` m) es   --FIXME: should really extend this to multi-param measures..-      ms -> do e' <- evalExpr' (head es) m-               applyMeasure (symbolString f) (concatMap eqns ms) e' m--evalBrel :: Brel -> Val -> Val -> Bool-evalBrel Eq = (==)-evalBrel Ne = (/=)-evalBrel Ueq = (==)-evalBrel Une = (/=)-evalBrel Gt = (>)-evalBrel Ge = (>=)-evalBrel Lt = (<)-evalBrel Le = (<=)--applyMeasure :: String -> [Language.Haskell.Liquid.Types.Def SpecType GHC.DataCon] -> Val -> M.HashMap Symbol Val -> Target Val-applyMeasure name eqns (VC f es) env -- (splitEApp_maybe -> Just (f, es)) env-  = do-       -- traceShowM ("applyMeasure", name)-       meq >>= \eq -> evalBody eq es env-  where-    -- FIXME: tidy is fishy!!-    ct = symbolString . tidySymbol $ case f of-      "GHC.Types.[]" -> "[]"-      "GHC.Types.:"  -> ":"-      "GHC.Tuple.(,)" -> "(,)"-      "GHC.Tuple.(,,)" -> "(,,)"-      "GHC.Tuple.(,,,)" -> "(,,,)"-      "GHC.Tuple.(,,,,)" -> "(,,,,)"-      x -> x-    meq = case find ((==ct) . show . ctor) eqns of-           Nothing -> throwM $ EvalError $ printf "applyMeasure(%s): no equation for %s" name (show ct)-           Just x -> return x--applyMeasure n _ e           _-  = throwM $ EvalError $ printf "applyMeasure(%s, %s)" n (showpp e)---- setSym :: Symbol--- setSym = "LC_SET"---- nubSort :: [Expr] -> [Expr]--- nubSort = nub . Data.List.sort---- mkSet :: [Expr] -> Expr--- mkSet = app setSym . nubSort--evalSet :: Symbol -> [Val] -> Target Val-evalSet "Set_emp" [VS s]-  = return $! if S.null s then VB True else VB False-evalSet "Set_sng" [v]-  = return $! VS $ S.singleton v--- TODO!!-evalSet "Set_add" [v, VS s]-  = return $! VS $ S.insert v s-evalSet "Set_cap" [VS s1, VS s2]-  = return $! VS $ S.intersection s1 s2-evalSet "Set_cup" [VS s1, VS s2]-  = return $! VS $ S.union s1 s2-evalSet "Set_dif" [VS s1, VS s2]-  = return $! VS $ s1 S.\\ s2-evalSet "Set_sub" [VS s1, VS s2]-  = return $! VB $ S.isSubsetOf s1 s2-evalSet "Set_mem" [v, VS s]-  = return $! VB $ S.member v s-evalSet f es = throwM $ EvalError $ printf "evalSet(%s, %s)" (show f) (show es)--evalBody-  :: Language.Haskell.Liquid.Types.Def ty ctor-     -> [Val] -> M.HashMap Symbol Val -> Target Val-evalBody eq xs env = go $ body eq-  where-    go (E e) = evalExpr e env'-    go (P p) = evalPred p env' >>= \b -> return $ if b then VB True else VB False-    go (R v p) = do e <- evalRel v p env'-                    case e of-                      Nothing -> throwM $ EvalError $ "evalBody can't handle: " ++ show (R v p)-                      Just e  -> return e-    --go (R v (PBexp (EApp f e))) | val f == "Set_emp" = return $ app setSym []-    ----FIXME: figure out how to handle the general case..-    --go (R v p) = return (ECon (I 0))--    env' = M.union (M.fromList (zip (map fst (binds eq)) xs)) env-    -- su = mkSubst $ zip (map fst (binds eq)) xs--evalRel :: Symbol -> Expr -> M.HashMap Symbol Val -> Target (Maybe Val)-evalRel v (PAnd ps)       m = Just . head . catMaybes <$> sequence [evalRel v p m | p <- ps]-evalRel v (PImp p q)      m = do pv <- evalPred p m-                                 if pv-                                    then evalRel v q m-                                    else return Nothing-evalRel v (PAtom Eq (EVar v') e2) m-  | v == v'-  = Just <$> evalExpr e2 m--- evalRel v (PBexp (EApp f [EVar v'])) _-evalRel v (EApp (EVar f) (EVar v')) _-  | v == v' && f == "Set_emp"-  = return $! Just $ VS S.empty-evalRel _ p               _-  = throwM $ EvalError $ "evalRel: " ++ show p---evalBop :: Bop -> Val -> Val -> Val-evalBop Plus  (VV (I x)) (VV (I y)) = VV . I $ x + y-evalBop Minus (VV (I x)) (VV (I y)) = VV . I $ x - y-evalBop Times (VV (I x)) (VV (I y)) = VV . I $ x * y-evalBop Div   (VV (I x)) (VV (I y)) = VV . I $ x `div` y-evalBop Mod   (VV (I x)) (VV (I y)) = VV . I $ x `mod` y-evalBop b     e1           e2       = error $ printf "evalBop(%s, %s, %s)" (show b) (show e1) (show e2)
− src/Test/Target/Expr.hs 
@@ -1,69 +0,0 @@-module Test.Target.Expr where--import Language.Fixpoint.Types---eq :: Expr -> Expr -> Expr-eq  = PAtom Eq-infix 4 `eq`--ge :: Expr -> Expr -> Expr-ge  = PAtom Ge-infix 5 `ge`--le :: Expr -> Expr -> Expr-le  = PAtom Le-infix 5 `le`--gt :: Expr -> Expr -> Expr-gt  = PAtom Gt-infix 5 `gt`--lt :: Expr -> Expr -> Expr-lt  = PAtom Lt-infix 5 `lt`--iff :: Expr -> Expr -> Expr-iff = PIff-infix 3 `iff`--imp :: Expr -> Expr -> Expr-imp = PImp-infix 3 `imp`---app :: Symbolic a => a -> [Expr] -> Expr--- app f es = EApp (dummyLoc $ symbol f) es-app = mkEApp . dummyLoc . symbol--var :: Symbolic a => a -> Expr-var = EVar . symbol---- prop :: Symbolic a => a -> Expr--- prop = PBexp . EVar . symbol-prop :: Expr -> Expr-prop = id--instance Num Expr where-  fromInteger = ECon . I . fromInteger-  (+) = EBin Plus-  (-) = EBin Minus-  (*) = EBin Times-  abs = error "abs of Liquid.Fixpoint.Types.Expr"-  signum = error "signum of Liquid.Fixpoint.Types.Expr"---- instance Real Expr where---   toRational (ECon (I i)) = fromIntegral i---   toRational x            = error $ "toRational: " ++ show x---- instance Enum Expr where---   toEnum = ECon . I . fromIntegral---   fromEnum (ECon (I i)) = fromInteger i---   fromEnum x            = error $ "fromEnum: " ++ show x---- instance Integral Expr where---   div = EBin Div---   mod = EBin Mod---   quotRem x y = (x `div` y, x `mod` y)---   toInteger (ECon (I i)) = i---   toInteger x            = error $ "toInteger: " ++ show x
− src/Test/Target/Monad.hs 
@@ -1,302 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE RankNTypes                 #-}-{-# LANGUAGE RecordWildCards            #-}-{-# LANGUAGE ViewPatterns               #-}-module Test.Target.Monad-  ( whenVerbose-  , noteUsed-  , addDep-  , addConstraint-  , addConstructor-  , addSort-  , addVariable-  , inModule-  , making-  , lookupCtor-  , guarded-  , fresh-  , freshChoice-  , freshInt-  , getValue-  , Target, runTarget-  , TargetState(..), initState-  , TargetOpts(..), defaultOpts-  ) where--import           Control.Applicative-import           Control.Arrow                    (first, second, (***))-import qualified Control.Exception                as Ex-import           Control.Monad-import           Control.Monad.Catch-import           Control.Monad.Reader-import           Control.Monad.State--import qualified Data.HashMap.Strict              as M-import qualified Data.HashSet                     as S-import           Data.IORef-import           Data.List                        hiding (sort)--import qualified Data.Text                        as ST-import           System.IO.Unsafe--- import           Text.Printf--import           Language.Fixpoint.Smt.Interface  hiding (SMTLIB2(..))-import           Language.Fixpoint.Types-import           Language.Fixpoint.Types.Config (SMTSolver(..))-import           Language.Haskell.Liquid.Types.PredType-import           Language.Haskell.Liquid.Types.RefType--import           Language.Haskell.Liquid.Types    hiding (var, Target)--import qualified GHC-import qualified Type as GHC---- import           Test.Target.Serialize-import           Test.Target.Types-import           Test.Target.Util---- import           Debug.Trace---newtype Target a = Target (StateT TargetState (ReaderT TargetOpts IO) a)-  deriving ( Functor, Applicative, Monad, MonadIO, Alternative-           , MonadState TargetState, MonadCatch, MonadReader TargetOpts )-instance MonadThrow Target where-  throwM = Ex.throw--runTarget :: TargetOpts -> TargetState -> Target a -> IO a-runTarget opts st (Target x) = runReaderT (evalStateT x st) opts---- evalTarget :: TargetOpts -> TargetState -> Target a -> IO a--- evalTarget o s (Target x) = runReaderT (evalStateT x s) o---- execTarget :: GhcSpec -> Target a -> IO TargetState--- execTarget e (Target x) = execStateT x (initGS e)--seed :: IORef Int-seed = unsafePerformIO $ newIORef 0-{-# NOINLINE seed #-}--freshInt :: Target Int-freshInt = liftIO $ do-  n <- readIORef seed-  modifyIORef' seed (+1)-  return n--data TargetOpts = TargetOpts-  { depth      :: !Int-  , solver     :: !SMTSolver-  , verbose    :: !Bool-  , logging    :: !Bool-  , keepGoing  :: !Bool-    -- ^ whether to keep going after finding a counter-example, useful for-    -- checking coverage-  , maxSuccess :: !(Maybe Int)-    -- ^ whether to stop after a certain number of successful tests, or-    -- enumerate the whole input space-  , scDepth    :: !Bool-    -- ^ whether to use SmallCheck's notion of depth-  , ghcOpts    :: ![String]-    -- ^ extra options to pass to GHC-  }--defaultOpts :: TargetOpts-defaultOpts = TargetOpts-  { depth = 3-  , solver = Z3-  , verbose = False-  , logging = True-  , keepGoing = False-  , maxSuccess = Nothing-  , scDepth = True-  , ghcOpts = []-  }--data TargetState = TargetState-  { variables    :: ![Variable]-  , choices      :: ![Variable]-  , constraints  :: !Constraint-  , deps         :: !(M.HashMap Symbol [Symbol])-  , realized     :: ![(Symbol, Value)]-  -- , dconEnv      :: ![(Symbol, DataConP)]-  , ctorEnv      :: !DataConEnv-  , measEnv      :: !MeasureEnv-  , embEnv       :: !(TCEmb GHC.TyCon)-  , tyconInfo    :: !(M.HashMap GHC.TyCon RTyCon)-  , freesyms     :: ![(Symbol,Symbol)]-  , constructors :: ![Variable] -- (S.HashSet Variable)  --[(String, String)]-  , sigs         :: ![(Symbol, SpecType)]-  , chosen       :: !(Maybe Symbol)-  , sorts        :: !(S.HashSet Sort)-  , modName      :: !Symbol-  , filePath     :: !FilePath-  , makingTy     :: !Sort-  , smtContext   :: !Context-  }--initState :: FilePath -> GhcSpec -> Context -> TargetState-initState fp sp ctx = TargetState-  { variables    = []-  , choices      = []-  , constraints  = []-  , deps         = mempty-  , realized     = []-  -- , dconEnv      = dcons-  , ctorEnv      = cts-  , measEnv      = meas-  , embEnv       = gsTcEmbeds sp-  , tyconInfo    = tyi-  , freesyms     = free-  , constructors = []-  , sigs         = sigs-  , chosen       = Nothing-  , sorts        = S.empty-  , modName      = ""-  , filePath     = fp-  , makingTy     = FObj ""-  , smtContext   = ctx-  }-  where-    -- FIXME: can we NOT tidy???-    -- dcons = tidyF $ map (first symbol) (gsDconsP sp)--    -- NOTE: we want to tidy all occurrences of nullary datacons in the signatures-    cts   = subst su $ tidyF $ map (symbol *** val) (gsCtors sp)-    sigs  = subst su $ tidyF $ map (symbol *** val) $ gsTySigs sp--    tyi   = makeTyConInfo (gsTconsP sp)-    free  = tidyS $ map (second symbol)-          $ gsFreeSyms sp ++ map (\(c,_) -> (symbol c, c)) (gsCtors sp)-    meas  = gsMeasures sp-    tidyF = map (first tidySymbol)-    tidyS = map (second tidySymbol)-    su = mkSubst (map (second eVar) free)--whenVerbose :: Target () -> Target ()-whenVerbose x-  = do v <- asks verbose-       when v x--noteUsed :: (Symbol, Value) -> Target ()-noteUsed (v,x) = modify $ \s@(TargetState {..}) -> s { realized = (v,x) : realized }---- TODO: does this type make sense? should it be Symbol -> Symbol -> Target ()?-addDep :: Symbol -> Expr -> Target ()-addDep from (EVar to) = modify $ \s@(TargetState {..}) ->-  s { deps = M.insertWith (flip (++)) from [to] deps }-addDep _ _ = return ()--addConstraint :: Expr -> Target ()-addConstraint p = modify $ \s@(TargetState {..}) -> s { constraints = p:constraints }--addConstructor :: Variable -> Target ()-addConstructor c-  = modify $ \s@(TargetState {..}) -> s { constructors = nub $ c:constructors }--inModule :: Symbol -> Target a -> Target a-inModule m act-  = do m' <- gets modName-       modify $ \s -> s { modName = m }-       r <- act-       modify $ \s -> s { modName = m' }-       return r--making :: Sort -> Target a -> Target a-making ty act-  = do ty' <- gets makingTy-       modify $ \s -> s { makingTy = ty }-       r <- act-       modify $ \s -> s { makingTy = ty' }-       return r---- | Find the refined type of a data constructor.-lookupCtor :: Symbol -> SpecType -> Target SpecType-lookupCtor c (toType -> t)-             -- FIXME: WTF, how do two symbols share a Text-             -- without being equal??-  = do mt <- find (\(c', _) -> symbolText c == symbolText c')-               <$> gets ctorEnv-       case mt of-         Just (_, t) -> return t-         Nothing -> do-           -- m  <- gets filePath-           -- o  <- asks ghcOpts-           let tc = GHC.tyConAppTyCon t-           let dcs = GHC.tyConDataCons tc-           let Just dc = find (\d -> c == symbol (GHC.getName d)) dcs-           let t = ofType (GHC.dataConUserType dc)-           -- t <- io $ runGhc o $ do-           --        _ <- loadModule m-           --        traceShowM c-           --        t <- GHC.exprType (printf "(%s)" (symbolString c))-           --        return (ofType t)-           modify $ \s@(TargetState {..}) -> s { ctorEnv = (c,t) : ctorEnv }-           return t---- | Given a data constructor @d@ and an action, create a new choice variable--- @c@ and execute the action while guarding any generated constraints with--- @c@. Returns @(action-result, c)@.-guarded :: String -> Target Expr -> Target (Expr, Expr)-guarded cn act-  = do c  <- freshChoice cn-       mc <- gets chosen-       modify $ \s -> s { chosen = Just c }-       x <- act-       modify $ \s -> s { chosen = mc }-       return (x, EVar c)---- | Generate a fresh variable of the given 'Sort'.-fresh :: Sort -> Target Symbol-fresh sort-  = do n <- freshInt-       let sorts' = sortTys sort-       let x = symbol $ ST.unpack (ST.intercalate "->" $ map (symbolText.unObj) sorts') ++ show n-       addVariable (x, sort)-       return x--addSort :: Sort -> Target ()-addSort sort = do-  let sorts' = sortTys sort-  modify $ \s@(TargetState {..}) -> s { sorts = S.union (S.fromList (arrowize sort : sorts')) sorts }--addVariable :: Variable -> Target ()-addVariable (v, sort) = do-  addSort sort-  modify $ \s@(TargetState {..}) -> s { variables = (v, sort) : variables }---sortTys :: Sort -> [Sort]---sortTys (FFunc _ ts) = concatMap sortTys ts-sortTys t-  | Just (_, ts, t) <- functionSort t-  = concatMap sortTys ts ++ [t]-  | otherwise-  = [t]--arrowize :: Sort -> Sort-arrowize = FObj . symbol . ST.intercalate "->" . map (symbolText . unObj) . sortTys--unObj :: Sort -> Symbol-unObj FInt     = "Int"-unObj (FObj s) = s-unObj s        = error $ "unObj: " ++ show s---- | Given a data constructor @d@, create a new choice variable corresponding to--- @d@.-freshChoice :: String -> Target Symbol-freshChoice cn-  = do n <- freshInt-       let x = intSymbol (unObj choicesort) (cn ++ "-" ++ show n)-       --  ... symbol $ T.unpack (Builder.toLazyText $ smt2 choicesort)-       --                  ++ "-" ++ cn ++ "-" ++ show n-       modify $ \s@(TargetState {..}) -> s { variables = (x, choicesort) : variables }-       return x---- | Ask the SMT solver for the 'Value' of the given variable.-getValue :: Symbol -> Target Value-getValue v = do-  ctx <- gets smtContext-  Values [x] <- io $ ensureValues $ command ctx (GetValue [v])-  noteUsed x-  return (snd x)
− src/Test/Target/Targetable.hs 
@@ -1,572 +0,0 @@-{-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE DefaultSignatures    #-}-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE KindSignatures       #-}-{-# LANGUAGE LambdaCase           #-}-{-# LANGUAGE OverloadedStrings    #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE TypeOperators        #-}-{-# LANGUAGE TypeSynonymInstances #-}--{-# LANGUAGE ImplicitParams       #-}-module Test.Target.Targetable-  ( Targetable(..), qquery-  , unfold, apply, unapply-  , oneOf, whichOf-  , constrain, ofReft-  ) where--import           Control.Applicative-import           Control.Arrow                   (second)--import           Control.Monad.Reader-import           Control.Monad.State-import           Data.Char-import qualified Data.HashMap.Strict             as M-import           Data.List-import           Data.Maybe--import           Data.Proxy-import qualified Data.Text                       as T-import           Data.Word                       (Word8)-import           GHC.Generics-import           GHC.Stack--import           Language.Fixpoint.Types         hiding (prop, ofReft, reft)-import           Language.Haskell.Liquid.Types.RefType-import           Language.Haskell.Liquid.Types   hiding (var)--import           Test.Target.Expr-import           Test.Target.Eval-import           Test.Target.Monad---import           Test.Target.Util---- import Debug.Trace-------------------------------------------------------------------------------------- Constrainable Data------------------------------------------------------------------------------------ | A class of datatypes for which we can efficiently generate constrained--- values by querying an SMT solver.------ If possible, instances should not be written by hand, but rather by using the--- default implementations via "GHC.Generics", e.g.------ > import GHC.Generics--- > import Test.Target.Targetable--- >--- > data Foo = ... deriving Generic--- > instance Targetable Foo-class Targetable a where-  -- | Construct an SMT query describing all values of the given type up to the-  -- given 'Depth'.-  query   :: (?loc :: CallStack) => Proxy a -> Depth -> Symbol -> SpecType -> Target Symbol--  -- | Reconstruct a Haskell value from the SMT model.-  decode  :: Symbol-             -- ^ the symbolic variable corresponding to the root of the value-          -> SpecType-             -- ^ the type of values we're generating (you can probably ignore this)-          -> Target a--  -- | Check whether a Haskell value inhabits the given type. Also returns a-  -- logical expression corresponding to the Haskell value.-  check   :: a -> SpecType -> Target (Bool, Expr)--  -- | Translate a Haskell value into a logical expression.-  toExpr  :: a -> Expr--  -- | What is the Haskell type? (Mainly used to make the SMT queries more-  -- readable).-  getType :: Proxy a -> Sort--  default getType :: (Generic a, Rep a ~ D1 d f, Datatype d)-                  => Proxy a -> Sort-  getType _ = FObj $ qualifiedDatatypeName (undefined :: Rep a a)--  default query :: (?loc :: CallStack) => (Generic a, GQuery (Rep a))-                => Proxy a -> Int -> Symbol -> SpecType -> Target Symbol-  query p d x t = do-    -- traceShowM ("query")-    -- traceShowM ("query", t)-    gquery (reproxyRep p) d x t--  default toExpr :: (Generic a, GToExpr (Rep a))-                 => a -> Expr-  toExpr = gtoExpr . from--  default decode :: (Generic a, GDecode (Rep a))-                 => Symbol -> SpecType -> Target a-  decode v _ = do-    x <- whichOf v-    (c, fs) <- unapply x-    to <$> gdecode c fs--  default check :: (Generic a, GCheck (Rep a))-                => a -> SpecType -> Target (Bool, Expr)-  check v t = gcheck (from v) t--qquery :: Targetable a => Proxy a -> Int -> SpecType -> Target Symbol-qquery p d t = fresh (getType p) >>= \x -> query p d x t--reproxy :: proxy a -> Proxy b-reproxy _ = Proxy-{-# INLINE reproxy #-}---- | Given a data constuctor @d@ and a refined type for @d@s output,--- return a list of types representing suitable arguments for @d@.-unfold :: Symbol -> SpecType -> Target [(Symbol, SpecType)]-unfold cn t = do-  -- traceShowM ("unfold.cn", cn)-  dcp <- lookupCtor cn t-  -- traceShowM ("unfold.dcp")-  -- traceShowM ("unfold.t.r", reft t)-  tyi <- gets tyconInfo-  emb <- gets embEnv-  let ts = applyPreds (addTyConInfo emb tyi t) dcp-  -- traceM "unfold.ts.rs"-  -- mapM_ (traceShowM . rt_reft . snd) ts-  return ts---- | Given a data constructor @d@ and a list of expressions @xs@, construct a--- new expression corresponding to @d xs@.-apply :: Symbol -> SpecType -> [Expr] -> Target Expr-apply c t vs = do-  -- traceShowM ("apply")-  -- traceShowM ("apply", c, vs)-  mc <- gets chosen-  case mc of-    Just ch -> mapM_ (addDep ch) vs-    Nothing -> return ()-  let x = app c vs-  t <- lookupCtor c t-  -- traceShowM ("apply.ctor", c, t)-  let (xs, _, _, rt) = bkArrowDeep t-      su             = mkSubst $ zip (map symbol xs) vs-  addConstructor (c, rTypeSort mempty t)-  constrain $ ofReft (subst su $ reft rt) x-  return x----- | Split a symbolic variable representing the application of a data--- constructor into a pair of the data constructor and the sub-variables.-unapply :: Symbol -> Target (Symbol, [Symbol])-unapply c = do-  let [_,cn,_] = T.splitOn "-" $ symbolText c-  deps <- gets deps-  return (symbol cn, M.lookupDefault [] c deps)---- | Given a symbolic variable and a list of @(choice, var)@ pairs,--- @oneOf x choices@ asserts that @x@ must equal one of the @var@s in--- @choices@.-oneOf :: Symbol -> [(Expr,Expr)] -> Target ()-oneOf x cs-  = do cs <- forM cs $ \(y,c) -> do-               addDep x c-               constrain $ prop c `imp` (var x `eq` y)-               return $ prop c-       constrain $ pOr cs-       constrain $ pAnd [ PNot $ pAnd [x, y]-                        | [x, y] <- filter ((==2) . length) $ subsequences cs ]---- | Given a symbolic variable @x@, figure out which of @x@s choice varaibles--- was picked and return it.-whichOf :: Symbol -> Target Symbol-whichOf v = do-  deps <- gets deps-  let Just cs = M.lookup v deps-  -- traceShowM (v, cs)-  -- FIXME: should be a singleton list...-  c:_  <- catMaybes <$> forM cs (\c -> do-    val <- getValue c-    if val == "true"-      then return (Just c)-      else return Nothing)-  return c----- | Assert a logical predicate, guarded by the current choice variable.-constrain :: (?loc :: CallStack) => Expr -> Target ()-constrain p = do-  -- traceShowM ("constrain")-  -- traceM (showCallStack ?loc)-  -- traceShowM ("constrain", p)-  mc <- gets chosen-  case mc of-    Nothing -> addConstraint p-    Just c  -> let p' = prop (var c) `imp` p-               in addConstraint p'---- | Given a refinement @{v | p}@ and an expression @e@, construct--- the predicate @p[e/v]@.-ofReft :: Reft -> Expr -> Expr-ofReft (Reft (v, p)) e-  = let x = mkSubst [(v, e)]-    in subst x p-------------------------------------------------------------------------------------- Instances----------------------------------------------------------------------------------instance Targetable () where-  getType _ = FObj "GHC.Tuple.()"-  query _ _ x _ = return x -- fresh (FObj "GHC.Tuple.()")-  -- this is super fiddly, but seemingly required since GHC.exprType chokes on "GHC.Tuple.()"-  toExpr _   = app ("()" :: Symbol) []--  decode _ _ = return ()-  check _ t = do-    let e = app ("()" :: Symbol) []-    b <- eval (reft t) e-    return (b,e)--instance Targetable Int where-  getType _ = FObj "GHC.Types.Int"-  query _ d x t = -- fresh FInt >>= \x ->-    do -- traceShowM ("query.int", var x)-       -- traceShowM ("queyr.int", reft t)-       constrain $ ofReft (reft t) (var x)-       -- use the unfolding depth to constrain the range of Ints, like QuickCheck-       constrain $ var x `ge` fromIntegral (negate d)-       constrain $ var x `le` fromIntegral d-       return x-  toExpr i = ECon $ I $ fromIntegral i--  decode v _ = read . T.unpack <$> getValue v--  check v t = do-    let e = fromIntegral v-    b <- eval (reft t) e-    return (b, e)--instance Targetable Integer where-  getType _ = FObj "GHC.Integer.Type.Integer"-  query _ d x t = query (Proxy :: Proxy Int) d x t-  toExpr  x = toExpr (fromIntegral x :: Int)--  decode v t = decode v t >>= \(x::Int) -> return . fromIntegral $ x--  check v t = do-    let e = fromIntegral v-    b <- eval (reft t) e-    return (b, e)--instance Targetable Char where-  getType _ = FObj "GHC.Types.Char"-  query _ d x t = -- fresh FInt >>= \x ->-    do constrain $ var x `ge` 0-       constrain $ var x `le` fromIntegral d-       constrain $ ofReft (reft t) (var x)-       return x-  toExpr  c = ESym $ SL $ T.singleton c--  decode v t = decode v t >>= \(x::Int) -> return . chr $ x + ord 'a'--  check v t = do-    let e = ESym $ SL $ T.singleton v-    b <- eval (reft t) e-    return (b, e)--instance Targetable Word8 where-  getType _ = FObj "GHC.Word.Word8"-  query _ d x t = -- fresh FInt >>= \x ->-    do _ <- asks depth-       constrain $ var x `ge` 0-       constrain $ var x `le` fromIntegral d-       constrain $ ofReft (reft t) (var x)-       return x-  toExpr i   = ECon $ I $ fromIntegral i--  decode v t = decode v t >>= \(x::Int) -> return $ fromIntegral x--  check v t = do-    let e = fromIntegral v-    b <- eval (reft t) e-    return (b, e)--instance Targetable Bool-  -- getType _ = FObj "GHC.Types.Bool"-  -- query _ _ x t = -- fresh boolsort >>= \x ->-  --   do constrain $ ofReft (reft t) (var x)-  --      return x--  -- decode v _ = getValue v >>= \case-  --   "true"  -> return True-  --   "false" -> return False-  --   x       -> Ex.throwM (SmtError $ "expected boolean, got: " ++ T.unpack x)---instance Targetable a => Targetable [a]-instance Targetable a => Targetable (Maybe a)-instance (Targetable a, Targetable b) => Targetable (Either a b)-instance (Targetable a, Targetable b) => Targetable (a,b)-instance (Targetable a, Targetable b, Targetable c) => Targetable (a,b,c)-instance (Targetable a, Targetable b, Targetable c, Targetable d) => Targetable (a,b,c,d)----- instance (Num a, Integral a, Targetable a) => Targetable (Ratio a) where---   getType _ = FObj "GHC.Real.Ratio"---   query _ d t = query (Proxy :: Proxy Int) d t---   decode v t= decode v t >>= \ (x::Int) -> return (fromIntegral x)---   -- query _ d t = fresh (FObj "GHC.Real.Ratio") >>= \x ->---   --   do query (Proxy :: Proxy Int) d t---   --      query (Proxy :: Proxy Int) d t---   --      return x---   -- stitch d t = do x :: Int <- stitch d t---   --                 y' :: Int <- stitch d t---   --                 -- we should really modify `t' above to have Z3 generate non-zero denoms---   --                 let y = if y' == 0 then 1 else y'---   --                 let toA z = fromIntegral z :: a---   --                 return $ toA x % toA y---   toExpr x = EApp (dummyLoc "GHC.Real.:%") [toExpr (numerator x), toExpr (denominator x)]---   check = undefined---reproxyRep :: Proxy a -> Proxy (Rep a a)-reproxyRep = reproxy--------------------------------------------------------------------------------------- Sums of Products----------------------------------------------------------------------------------class GToExpr f where-  gtoExpr      :: f a -> Expr--class GQuery f where-  gquery       :: (?loc :: CallStack) => Proxy (f a) -> Int -> Symbol -> SpecType -> Target Symbol--class GDecode f where-  gdecode      :: Symbol -> [Symbol] -> Target (f a)--class GCheck f where-  gcheck       :: f a -> SpecType -> Target (Bool, Expr)--reproxyGElem :: Proxy (M1 d c f a) -> Proxy (f a)-reproxyGElem = reproxy--instance (Datatype c, GToExprCtor f) => GToExpr (D1 c f) where-  gtoExpr (M1 x) = app (qualify mod (symbolString d)) xs-    where-      mod  = GHC.Generics.moduleName (undefined :: D1 c f a)-      (EVar d, xs) = splitEApp $ gtoExprCtor x--instance (Datatype c, GQueryCtors f) => GQuery (D1 c f) where-  gquery p d x t = inModule mod . making sort $ do-    --traceShowM ("gquery", sort)-    xs <- gqueryCtors (reproxyGElem p) d t-    -- x  <- fresh sort-    oneOf x xs-    constrain $ ofReft (reft t) (var x)-    return x-   where-     mod  = symbol $ GHC.Generics.moduleName (undefined :: D1 c f a)-     sort = FObj $ qualifiedDatatypeName (undefined :: D1 c f a)--instance (Datatype c, GDecode f) => GDecode (D1 c f) where-  gdecode c vs = M1 <$> making sort (gdecode c vs)-    where-      sort = FObj $ qualifiedDatatypeName (undefined :: D1 c f a)--instance (Datatype c, GCheck f) => GCheck (D1 c f) where-  gcheck (M1 x) t = inModule mod . making sort $ gcheck x t-    where-      mod  = symbol $ GHC.Generics.moduleName (undefined :: D1 c f a)-      sort = FObj $ qualifiedDatatypeName (undefined :: D1 c f a)---instance (Targetable a) => GToExpr (K1 i a) where-  gtoExpr (K1 x) = toExpr x--instance (Targetable a) => GQuery (K1 i a) where-  gquery p d _ t = do-    let p' = reproxy p :: Proxy a-    ty <- gets makingTy-    depth <- asks depth-    sc <- asks scDepth-    let d' = if getType p' == ty || sc-                then d-                else depth--    qquery p' d' t--instance Targetable a => GDecodeFields (K1 i a) where-  gdecodeFields (v:vs) = do-    x <- decode v undefined-    return (vs, K1 x)-  gdecodeFields _ = error "gdecodeFields []"--instance Targetable a => GCheckFields (K1 i a) where-  gcheckFields (K1 x) ((f,t):ts) = do-    (b, v) <- check x t-    return (b, [v], subst (mkSubst [(f, v)]) ts)-  gcheckFields _ _ = error "gcheckFields _ []"--qualify :: String -> String -> String-qualify m x = m ++ ('.':x)-{-# INLINE qualify #-}--qualifiedDatatypeName :: Datatype d => D1 d f a -> Symbol-qualifiedDatatypeName d = symbol $ qualify m (datatypeName d)-  where m = GHC.Generics.moduleName d-{-# INLINE qualifiedDatatypeName #-}-------------------------------------------------------------------------------------- Sums----------------------------------------------------------------------------------class GToExprCtor f where-  gtoExprCtor   :: f a -> Expr--class GQueryCtors f where-  gqueryCtors :: (?loc :: CallStack) => Proxy (f a) -> Int -> SpecType -> Target [(Expr, Expr)]--reproxyLeft :: Proxy ((c (f :: * -> *) (g :: * -> *)) a) -> Proxy (f a)-reproxyLeft = reproxy--reproxyRight :: Proxy ((c (f :: * -> *) (g :: * -> *)) a) -> Proxy (g a)-reproxyRight = reproxy--instance (GToExprCtor f, GToExprCtor g) => GToExprCtor (f :+: g) where-  gtoExprCtor (L1 x) = gtoExprCtor x-  gtoExprCtor (R1 x) = gtoExprCtor x--instance (GQueryCtors f, GQueryCtors g) => GQueryCtors (f :+: g) where-  gqueryCtors p d t = do-    xs <- gqueryCtors (reproxyLeft p) d t-    ys <- gqueryCtors (reproxyRight p) d t-    return $! xs++ys--instance (GDecode f, GDecode g) => GDecode (f :+: g) where-  gdecode c vs =  L1 <$> gdecode c vs-              <|> R1 <$> gdecode c vs--instance (GCheck f, GCheck g) => GCheck (f :+: g) where-  gcheck (L1 x) t = gcheck x t-  gcheck (R1 x) t = gcheck x t---instance (Constructor c, GToExprFields f) => GToExprCtor (C1 c f) where-  gtoExprCtor c@(M1 x)  = app (symbol $ conName c) (gtoExprFields x)--instance (Constructor c, GRecursive f, GQueryFields f) => GQueryCtors (C1 c f) where-  gqueryCtors p d t | d <= 0-    = do ty <- gets makingTy-         if gisRecursive p ty-           then return []-           else pure <$> gqueryCtor p 0 t-  gqueryCtors p d t = pure <$> gqueryCtor p d t--instance (Constructor c, GDecodeFields f) => GDecode (C1 c f) where-  gdecode c vs-    | c == symbol (conName (undefined :: C1 c f a))-    = M1 . snd <$> gdecodeFields vs-    | otherwise-    = empty--instance (Constructor c, GCheckFields f) => GCheck (C1 c f) where-  gcheck (M1 x) t = do-    mod <- symbolString <$> gets modName-    let cn = symbol $ qualify mod (conName (undefined :: C1 c f a))-    ts <- unfold cn t-    (b, vs, _) <- gcheckFields x ts-    let v = app cn vs-    b'  <- eval (reft t) v-    return (b && b', v)--gisRecursive :: (Constructor c, GRecursive f)-             => Proxy (C1 c f a) -> Sort -> Bool-gisRecursive (p :: Proxy (C1 c f a)) t-  = t `elem` gconArgTys (reproxyGElem p)--gqueryCtor :: (?loc :: CallStack) => (Constructor c, GQueryFields f)-           => Proxy (C1 c f a) -> Int -> SpecType -> Target (Expr, Expr)-gqueryCtor (p :: Proxy (C1 c f a)) d t-  = guarded cn $ do-      -- traceShowM ("gqueryCtor", cn, t)-      mod <- symbolString <$> gets modName-      ts  <- unfold (symbol $ qualify mod cn) t-      xs  <- gqueryFields (reproxyGElem p) d ts-      apply (symbol $ qualify mod cn) t xs-  where-    cn = conName (undefined :: C1 c f a)-------------------------------------------------------------------------------------- Products----------------------------------------------------------------------------------class GToExprFields f where-  gtoExprFields :: f a -> [Expr]--class GRecursive f where-  gconArgTys  :: Proxy (f a) -> [Sort]--class GQueryFields f where-  gqueryFields  :: (?loc :: CallStack) => Proxy (f a) -> Int -> [(Symbol,SpecType)] -> Target [Expr]--class GDecodeFields f where-  gdecodeFields :: [Symbol] -> Target ([Symbol], f a)--class GCheckFields f where-  gcheckFields :: f a -> [(Symbol, SpecType)]-               -> Target (Bool, [Expr], [(Symbol, SpecType)])---instance (GToExprFields f, GToExprFields g) => GToExprFields (f :*: g) where-  gtoExprFields (f :*: g) = gtoExprFields f ++ gtoExprFields g--instance (GRecursive f, GRecursive g) => GRecursive (f :*: g) where-  gconArgTys p = gconArgTys (reproxyLeft p) ++ gconArgTys (reproxyRight p)--instance (GQueryFields f, GQueryFields g) => GQueryFields (f :*: g) where-  gqueryFields p d ts = do-    xs <- gqueryFields (reproxyLeft p) d ts-    let su = mkSubst $ zipWith (\x t -> (fst t, x)) xs ts-    let ts' = drop (length xs) ts-    ys <- gqueryFields (reproxyRight p) d (map (second (subst su)) ts')-    return $ xs ++ ys--instance (GDecodeFields f, GDecodeFields g) => GDecodeFields (f :*: g) where-  gdecodeFields vs = do-    (vs', ls)  <- gdecodeFields vs-    (vs'', rs) <- gdecodeFields vs'-    return (vs'', ls :*: rs)--instance (GCheckFields f, GCheckFields g) => GCheckFields (f :*: g) where-  gcheckFields (f :*: g) ts = do-    (bl,fs,ts')  <- gcheckFields f ts-    (br,gs,ts'') <- gcheckFields g ts'-    return (bl && br, fs ++ gs, ts'')---instance (GToExpr f) => GToExprFields (S1 c f) where-  gtoExprFields (M1 x)     = [gtoExpr x]--instance Targetable a => GRecursive (S1 c (K1 i a)) where-  gconArgTys _ = [getType (Proxy :: Proxy a)]--instance (GQuery f) => GQueryFields (S1 c f) where-  gqueryFields p d (t:_) = sequence [var <$> gquery (reproxyGElem p) (d-1) "" (snd t)]-  gqueryFields _ _ _     = error "gqueryfields _ _ []"--instance GDecodeFields f => GDecodeFields (S1 c f) where-  gdecodeFields vs = do-    (vs', x) <- gdecodeFields vs-    return (vs', M1 x)--instance (GCheckFields f) => GCheckFields (S1 c f) where-  gcheckFields (M1 x) ts = gcheckFields x ts--instance GToExprFields U1 where-  gtoExprFields _ = []--instance GRecursive U1 where-  gconArgTys _    = []--instance GQueryFields U1 where-  gqueryFields _ _ _ = return []--instance GDecodeFields U1 where-  gdecodeFields vs = return (vs, U1)--instance GCheckFields U1 where-  gcheckFields _ ts = return (True, [], ts)
− src/Test/Target/Targetable/Function.hs 
@@ -1,185 +0,0 @@-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE OverloadedStrings    #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE ViewPatterns         #-}--module Test.Target.Targetable.Function () where--import           Control.Arrow                   (second)-import           Control.Monad-import qualified Control.Monad.Catch             as Ex-import           Control.Monad.Reader-import           Control.Monad.State-import           Data.Char-import qualified Data.HashMap.Strict             as M-import           Data.IORef-import           Data.Proxy-import qualified Data.Text                       as ST-import qualified Data.Text.Lazy.Builder          as Builder-import           System.IO.Unsafe--import qualified GHC-import           Language.Fixpoint.Smt.Interface -- hiding (SMTLIB2(..))-import           Language.Fixpoint.Types         hiding (ofReft, reft)-import           Language.Haskell.Liquid.GHC.Misc (qualifiedNameSymbol)-import           Language.Haskell.Liquid.Types.RefType (addTyConInfo, rTypeSort)-import           Language.Haskell.Liquid.Types   hiding (var)--import           Test.Target.Targetable-import           Test.Target.Eval-import           Test.Target.Expr-import           Test.Target.Monad--- import           Test.Target.Serialize-import           Test.Target.Types-import           Test.Target.Util---getCtors :: SpecType -> [GHC.DataCon]-getCtors (RApp c _ _ _) = GHC.tyConDataCons $ rtc_tc c-getCtors (RAppTy t _ _) = getCtors t-getCtors (RFun _ i o _) = getCtors i ++ getCtors o-getCtors (RVar _ _)     = []-getCtors t              = error $ "getCtors: " ++ showpp t--dataConSymbol_noUnique :: GHC.DataCon -> Symbol-dataConSymbol_noUnique = qualifiedNameSymbol . GHC.getName--genFun :: Targetable a => Proxy a -> t -> Symbol -> SpecType -> Target Symbol-genFun _p _ x (stripQuals -> t)-  = do forM_ (getCtors t) $ \dc -> do-         let c = dataConSymbol_noUnique dc-         t <- lookupCtor c t-         addConstructor (c, rTypeSort mempty t)-       return x -- fresh (getType p)--stitchFun :: forall f. (Targetable (Res f))-          => Proxy f -> SpecType -> Target ([Expr] -> Res f)-stitchFun _ (bkArrowDeep . stripQuals -> (vs, tis, _, to))-  = do mref <- io $ newIORef []-       d <- asks depth-       state' <- get-       opts   <- ask-       let st = state' { variables = [], choices = [], constraints = []-                       , deps = mempty, constructors = [] }-       return $ \es -> unsafePerformIO $ runTarget opts st $ do-         -- let es = map toExpr xs-         mv <- lookup es <$> io (readIORef mref)-         case mv of-           Just v  -> return v-           Nothing -> do-             cts <- gets freesyms-             let env = map (second (`VC` [])) cts-             bs <- zipWithM (evalType (M.fromList env)) tis es-             case and bs of-               --FIXME: better error message-               False -> Ex.throwM $ PreconditionCheckFailed $ show $ zip es tis-               True  -> do-                 ctx  <- gets smtContext-                 let sEnv = ctxSymEnv ctx-                 _ <- io $ command ctx Push-                 xes <- zipWithM genExpr es tis-                 let su = mkSubst $ zipWith (\v e -> (v, var e)) vs xes-                 xo <- qquery (Proxy :: Proxy (Res f)) d (subst su to)-                 vs <- gets variables-                 mapM_ (\x -> io . smtWrite ctx . Builder.toLazyText $-                              smt2 sEnv $ makeDecl (seData sEnv) (symbol x) (snd x)) vs-                 cs <- gets constraints-                 mapM_ (\c -> io . smtWrite ctx . Builder.toLazyText $-                              smt2 sEnv $ Assert Nothing c) cs--                 resp <- io $ command ctx CheckSat-                 when (resp == Unsat) $ Ex.throwM SmtFailedToProduceOutput--                 o <- decode xo to-                 -- whenVerbose $ io $ printf "%s -> %s\n" (show es) (show o)-                 io (modifyIORef' mref ((es,o):))-                 _ <- io $ command ctx Pop-                 return o--genExpr :: Expr -> SpecType -> Target Symbol-genExpr (splitEApp_maybe -> Just (c, es)) t-  = do let ts = rt_args t-       xes <- zipWithM genExpr es ts-       (xs, _, _, to) <- bkArrowDeep . stripQuals <$> lookupCtor c t-       let su  = mkSubst $ zip xs $ map var xes-           to' = subst su to-       x <- fresh $ FObj $ symbol $ rtc_tc $ rt_tycon to'-       addConstraint $ ofReft (reft to') (var x)-       return x-genExpr (ECon (I i)) _t-  = do x <- fresh FInt-       addConstraint $ var x `eq` expr i-       return x-genExpr (ESym (SL s)) _t | ST.length s == 1-  -- This is a Char, so encode it as an Int-  = do x <- fresh FInt-       addConstraint $ var x `eq` expr (ord $ ST.head s)-       return x-genExpr e _t = error $ "genExpr: " ++ show e--evalType :: M.HashMap Symbol Val -> SpecType -> Expr -> Target Bool-evalType m t e@(splitEApp_maybe -> Just (c, xs))-  = do dcp <- lookupCtor c t-       tyi <- gets tyconInfo-       vts <- freshen $ applyPreds (addTyConInfo M.empty tyi t) dcp-       liftM2 (&&) (evalWith m (toReft $ rt_reft t) e) (evalTypes m vts xs)-evalType m t e-  = evalWith m (toReft $ rt_reft t) e--freshen :: [(Symbol, SpecType)] -> Target [(Symbol, SpecType)]-freshen [] = return []-freshen ((v,t):vts)-  = do n <- freshInt-       let v' = symbol . (++show n) . symbolString $ v-           su = mkSubst [(v,var v')]-           t' = subst su t-       vts' <- freshen $ subst su vts-       return ((v',t'):vts')--evalTypes-  :: M.HashMap Symbol Val-     -> [(Symbol, SpecType)] -> [Expr] -> Target Bool-evalTypes _ []         []     = return True-evalTypes m ((v,t):ts) (x:xs)-  = do xx <- evalExpr x m-       -- FIXME: tidy??-       let m' = M.insert (tidySymbol v) xx m-       liftM2 (&&) (evalType m' t x) (evalTypes m' ts xs)--evalTypes _ _ _ = error "evalTypes called with lists of unequal length!"--instance (Targetable a, Targetable b, b ~ Res (a -> b))-  => Targetable (a -> b) where-  getType _ = mkFFunc 0 [getType (Proxy :: Proxy a), getType (Proxy :: Proxy b)]-  query = genFun-  decode _ t-    = do f <- stitchFun (Proxy :: Proxy (a -> b)) t-         return $ \a -> f [toExpr a]-  toExpr  _ = var ("FUNCTION" :: Symbol)-  check _ _ = error "can't check a function!"--instance {-# OVERLAPPING #-} ( Targetable a, Targetable b, Targetable c-                             , c ~ Res (a -> b -> c)-                             ) => Targetable (a -> b -> c) where-  getType _ = mkFFunc 0 [getType (Proxy :: Proxy a), getType (Proxy :: Proxy b)-                        ,getType (Proxy :: Proxy c)]-  query = genFun-  decode _ t-    = do f <- stitchFun (Proxy :: Proxy (a -> b -> c)) t-         return $ \a b -> f [toExpr a, toExpr b]-  toExpr  _ = var ("FUNCTION" :: Symbol)-  check _ _ = error "can't check a function!"--instance {-# OVERLAPPING #-} ( Targetable a, Targetable b, Targetable c, Targetable d-                             , d ~ Res (a -> b -> c -> d)-                             ) => Targetable (a -> b -> c -> d) where-  getType _ = mkFFunc 0 [getType (Proxy :: Proxy a), getType (Proxy :: Proxy b)-                        ,getType (Proxy :: Proxy c), getType (Proxy :: Proxy d)]-  query = genFun-  decode _ t-    = do f <- stitchFun (Proxy :: Proxy (a -> b -> c -> d)) t-         return $ \a b c -> f [toExpr a, toExpr b, toExpr c]-  toExpr  _ = var ("FUNCTION" :: Symbol)-  check _ _ = error "can't check a function!"
− src/Test/Target/Testable.hs 
@@ -1,237 +0,0 @@-{-# LANGUAGE DataKinds               #-}-{-# LANGUAGE UndecidableInstances    #-}-{-# LANGUAGE OverloadedStrings       #-}-{-# LANGUAGE RecordWildCards         #-}-{-# LANGUAGE BangPatterns            #-}-{-# LANGUAGE ConstraintKinds         #-}-{-# LANGUAGE DoAndIfThenElse         #-}-{-# LANGUAGE FlexibleContexts        #-}-{-# LANGUAGE FlexibleInstances       #-}-{-# LANGUAGE LambdaCase              #-}-{-# LANGUAGE ScopedTypeVariables     #-}-{-# LANGUAGE TypeFamilies            #-}-{-# LANGUAGE ViewPatterns            #-}-{-# LANGUAGE UndecidableSuperClasses #-}--module Test.Target.Testable (test, Testable, setup) where---import Prelude hiding (error, undefined)--import           Control.Exception               (AsyncException, evaluate)-import           Control.Monad-import           Control.Monad.Catch-import           Control.Monad.Reader-import           Control.Monad.State--- import qualified Data.HashMap.Strict             as M-import qualified Data.HashSet                    as S-import qualified Data.List                       as L-import           Data.Proxy-import qualified Data.Text                       as ST-import qualified Data.Text.Lazy.Builder          as Builder-import           Data.Text.Format                hiding (print)-import           Data.Monoid-import           Text.Printf--import           Language.Fixpoint.Smt.Interface -- hiding (SMTLIB2(..))-import           Language.Fixpoint.Smt.Serialize (smt2SortMono)--- import qualified Language.Fixpoint.Smt.Theories  as Thy-import           Language.Fixpoint.Types         hiding (Result)-import           Language.Haskell.Liquid.Types.RefType-import           Language.Haskell.Liquid.Types   hiding (env, var, Only)--import           Test.Target.Targetable          hiding (apply)--- import           Test.Target.Eval-import           Test.Target.Expr-import           Test.Target.Monad--- import           Test.Target.Serialize-import           Test.Target.Types-import           Test.Target.Util--import GHC.Err.Located---- import Debug.Trace---- | Test that a function inhabits the given refinement type by enumerating--- valid inputs and calling the function on the inputs.-test :: Testable f => f -> SpecType -> Target Result-test f t-  = do d <- asks depth-       vs <- queryArgs f d t-       setup-       let (xs, tis, _, to) = bkArrowDeep $ stripQuals t-       ctx <- gets smtContext-       try (process f ctx vs (zip xs tis) to) >>= \case-         Left  (e :: TargetException) -> return $ Errored $ show e-         Right r                      -> return r--process :: Testable f-        => f -> Context -> [Symbol] -> [(Symbol,SpecType)] -> SpecType-        -> Target Result-process f ctx vs xts to = go 0 =<< io (command ctx CheckSat)-  where-    go !n Unsat    = return $ Passed n-    go _  (Error e)= throwM $ SmtError $ ST.unpack e-    go !n Sat      = do-      when (n `mod` 100 == 0) $ whenVerbose $ io $ printf "Checked %d inputs\n" n-      let n' = n + 1-      xs <- decodeArgs f vs (map snd xts)-      whenVerbose $ io $ print xs-      er <- io $ try $ evaluate (apply f xs)-      -- whenVerbose $ io $ print er-      case er of-        Left (e :: SomeException)-          -- DON'T catch AsyncExceptions since they are used by @timeout@-          | Just (_ :: AsyncException) <- fromException e -> throwM e-          | Just (SmtError _) <- fromException e -> throwM e-          | Just (ExpectedValues _) <- fromException e -> throwM e-          | otherwise -> do-              real <- gets realized-              modify $ \s@(TargetState {..}) -> s { realized = [] }-              let model = [ build "(= {} {})" (symbolText x, v) | (x,v) <- real ]-              unless (null model) $-                void $ io $ smtWrite ctx $ Builder.toLazyText-                          $ build "(assert (not (and {})))"-                     $ Only $ smt2many model-              mbKeepGoing xs n'-        Right r -> do-          real <- gets realized-          modify $ \s@(TargetState {..}) -> s { realized = [] }-          let su = mkSubst $ mkExprs f (map fst xts) xs-          (sat, _) <- check r (subst su to)--          -- refute model *after* checking output in case we have HOFs, which-          -- need to query the solver. if this is the last set of inputs, e.g.-          -- refuting the current model forces the solver to return unsat next-          -- time, the solver will return unsat when the HOF queries for an output,-          -- causing us to return a spurious error-          let model = [ build "(= {} {})" (symbolText x, v) | (x,v) <- real ]-          unless (null model) $-            void $ io $ smtWrite ctx $ Builder.toLazyText-                 $ build "(assert (not (and {})))"-                 $ Only $ smt2many model--          case sat of-            False -> mbKeepGoing xs n'-            True -> do-              asks maxSuccess >>= \case-                Nothing -> go n' =<< io (command ctx CheckSat)-                Just m | m == n' -> return $ Passed m-                       | otherwise -> go n' =<< io (command ctx CheckSat)--    go _ r = error $ "go _ " ++ show r--    mbKeepGoing xs n = do-      kg <- asks keepGoing-      if kg-        then go n =<< io (command ctx CheckSat)-        else return (Failed $ show xs)---{-# INLINE smt2many #-}-smt2many :: [Builder.Builder] -> Builder.Builder-smt2many []     = mempty-smt2many [b]    = b-smt2many (b:bs) = b <> mconcat [ " " <> b | b <- bs ]---- | A class of functions that Target can test. A function is @Testable@ /iff/--- all of its component types are 'Targetable' and all of its argument types are--- 'Show'able.------ You should __never__ have to define a new 'Testable' instance.-class (AllHave Targetable (Args f), Targetable (Res f)-      ,AllHave Show (Args f)) => Testable f where-  queryArgs  :: f -> Int -> SpecType -> Target [Symbol]-  decodeArgs :: f -> [Symbol] -> [SpecType] -> Target (HList (Args f))-  apply      :: f -> HList (Args f) -> Res f-  mkExprs    :: f -> [Symbol] -> HList (Args f) -> [(Symbol,Expr)]--instance {-# OVERLAPPING #-} (Show a, Targetable a, Testable b) => Testable (a -> b) where-  queryArgs f d (stripQuals -> (RFun x i o _))-    = do v  <- qquery (Proxy :: Proxy a) d i-         vs <- queryArgs (f undefined) d (subst (mkSubst [(x,var v)]) o)-         return (v:vs)-  queryArgs _ _ t = error $ "queryArgs called with non-function type: " ++ show t-  decodeArgs f (v:vs) (t:ts)-    = liftM2 (:::) (decode v t) (decodeArgs (f undefined) vs ts)-  decodeArgs _ _ _ = error "decodeArgs called with empty list"-  apply f (x ::: xs)-    = apply (f x) xs-  mkExprs f (v:vs) (x ::: xs)-    = (v, toExpr x) : mkExprs (f undefined) vs xs-  mkExprs _ _ _ = error "mkExprs called with empty list"--instance {-# OVERLAPPING #-}-  (Targetable a, Args a ~ '[], Res a ~ a) => Testable a-  where-  queryArgs _ _ _  = return []-  decodeArgs _ _ _ = return Nil-  apply f _        = f-  mkExprs _ _ _    = []--func :: Sort -> Bool-func (FAbs  _ s) = func s-func (FFunc _ _) = True-func _           = False--mySmt2Sort :: SymEnv -> Sort -> Builder.Builder-mySmt2Sort sEnv s = smt2SortMono s sEnv s--setup :: Target ()-setup = {-# SCC "setup" #-} do-   ctx  <- gets smtContext-   emb  <- gets embEnv-   let sEnv = ctxSymEnv ctx-    -- declare sorts-   ss  <- S.toList <$> gets sorts-   let defSort b e = io $ smtWrite ctx $ Builder.toLazyText-                   $ build "(define-sort {} () {})" (b,e)-   defSort ("CHOICE" :: Builder.Builder) ("Bool" :: Builder.Builder)-          -- FIXME: shouldn't need the nub, wtf?-   forM_ (L.nub (mySmt2Sort sEnv <$> ss)) $ \s ->-     defSort s ("Int" :: Builder.Builder)---   -- declare constructors-   cts <- gets constructors-   mapM_ (\ (c,t) -> do-             io $ smtWrite ctx . Builder.toLazyText $ smt2 sEnv $ makeDecl (seData sEnv) (symbol c) t) cts-   let nullary = [var c | (c,t) <- cts, not (func t)]-   unless (null nullary) $-     void $ io $ smtWrite ctx . Builder.toLazyText $ smt2 sEnv $ Distinct nullary-   -- declare variables-   vs <- gets variables-   let defVar (x,t) = io $ smtWrite ctx $ Builder.toLazyText $ smt2 sEnv $ makeDecl (seData sEnv) x (arrowize t)-   mapM_ defVar vs-   -- declare measures-   ms <- gets measEnv-   let defFun x t    = io $ smtWrite ctx $ Builder.toLazyText $ smt2 sEnv $ makeDecl (seData sEnv) x t-   forM_ ms $ \m -> do-     let x = val (name m)-     unless (x `memberSEnv` (seTheory sEnv)) $-       defFun x (rTypeSort emb (sort m))-   -- assert constraints-   cs <- gets constraints-   --mapM_ (\c -> do {i <- gets seed; modify $ \s@(GS {..}) -> s { seed = seed + 1 };-   --                 io . command ctx $ Assert (Just i) c})-   --  cs-   mapM_ (io . smtWrite ctx . Builder.toLazyText . smt2 sEnv . Assert Nothing) cs-   -- deps <- V.fromList . map (symbol *** symbol) <$> gets deps-   -- io $ generateDepGraph "deps" deps cs-   -- return (ctx,vs,deps)---- sortTys :: Sort -> [Sort]--- sortTys (FFunc _ ts) = concatMap sortTys ts--- sortTys t            = [t]--arrowize :: Sort -> Sort-arrowize t-  | Just (_, ts, t) <- functionSort t-  = FObj . symbol . ST.intercalate "->" . map (symbolText . unObj) $ (ts ++ [t])-  | otherwise-  = t--unObj :: Sort -> Symbol-unObj FInt     = "Int"-unObj (FObj s) = s-unObj s        = error $ "unObj: " ++ show s
− src/Test/Target/Types.hs 
@@ -1,93 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveDataTypeable   #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE OverloadedStrings    #-}-{-# LANGUAGE TypeSynonymInstances #-}-module Test.Target.Types where--import qualified Control.Monad.Catch             as Ex-import qualified Data.Set                        as S-import qualified Data.Text                       as T-import           Data.Typeable-import           GHC.Generics-import           Text.PrettyPrint--import           Language.Fixpoint.Smt.Interface-import           Language.Fixpoint.Types-import           Language.Haskell.Liquid.Types--import           GHC---- import           Test.Target.Serialize----data TargetException-  = SmtFailedToProduceOutput-  | SmtError String-  | ExpectedValues Response-  | PreconditionCheckFailed String-  | EvalError String-  deriving Typeable--instance Show TargetException where-  show SmtFailedToProduceOutput-    = "The SMT solver was unable to produce an output value."-  show (SmtError s)-    = "Unexpected error from the solver: " ++ s-  show (ExpectedValues r)-    = "Expected a Values response from the solver, got: " ++ show r-  show (PreconditionCheckFailed e)-    = "The pre-condition check for a generated function failed: " ++ e-  show (EvalError s)-    = "Couldn't evaluate a concrete refinement: " ++ s--instance Ex.Exception TargetException--ensureValues :: Ex.MonadThrow m => m Response -> m Response-ensureValues x = do-  a <- x-  case a of-    Values _ -> return a-    r        -> Ex.throwM $ ExpectedValues r--type Constraint = [Expr]-type Variable   = ( Symbol -- the name-                  , Sort   -- the `Sort'-                  )-type Value      = T.Text--instance Symbolic Variable where-  symbol (x, _) = symbol x--instance SMTLIB2 Constraint where-  smt2 env = smt2 env . PAnd--type DataConEnv = [(Symbol, SpecType)]-type MeasureEnv = [Measure SpecType DataCon]--boolsort, choicesort :: Sort-boolsort   = FObj "Bool"-choicesort = FObj "CHOICE"--data Result = Passed !Int-            | Failed !String-            | Errored !String-            deriving (Show, Typeable)---- resultPassed (Passed i) = i--data Val-  = VB !Bool-  | VV !Constant-  | VX !SymConst-  | VS !(S.Set Val) -- ??-  | VC Symbol [Val]-  deriving (Generic, Show, Eq, Ord)--instance PPrint Val where-  pprintTidy t (VB b) = pprintTidy t b-  pprintTidy t (VV v) = pprintTidy t v-  pprintTidy t (VX x) = pprintTidy t x-  pprintTidy t (VS s) = "Set.fromList" <+> pprintTidy t (S.toList s)-  pprintTidy t (VC c vs) = parens $ pprintTidy t c <+> hsep (map (pprintTidy t) vs)
− src/Test/Target/Util.hs 
@@ -1,174 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ParallelListComp #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns #-}--module Test.Target.Util where---import           Control.Monad.IO.Class-import           Data.List-import           Data.Maybe--import           Data.Generics                   (everywhere, mkT)-import           Debug.Trace--import qualified DynFlags as GHC-import qualified GhcMonad as GHC-import qualified GHC-import qualified GHC.Exts as GHC-import qualified GHC.Paths-import qualified HscTypes as GHC---- import           Language.Fixpoint.Smt.Interface--- import           Language.Fixpoint.Smt.Serialize---import           Language.Fixpoint.Smt.Types-import           Language.Fixpoint.Types          hiding (prop)-import qualified Language.Fixpoint.Types as F -import           Language.Haskell.Liquid.UX.CmdLine-import           Language.Haskell.Liquid.GHC.Interface-import           Language.Haskell.Liquid.Types.PredType-import           Language.Haskell.Liquid.Types.RefType-import           Language.Haskell.Liquid.Types    hiding (var)---type Depth = Int--io ::  MonadIO m => IO a -> m a-io = liftIO--myTrace :: Show a => String -> a -> a-myTrace s x = trace (s ++ ": " ++ show x) x--reft :: SpecType -> Reft-reft = toReft . rt_reft--data HList (a :: [*]) where-  Nil   :: HList '[]-  (:::) :: a -> HList bs -> HList (a ': bs)--instance AllHave Show as => Show (HList as) where-  show Nil         = "()"-  show (x ::: Nil) = show x-  show (x ::: xs)  = show x ++ ", " ++ show xs--type family Map (f :: a -> b) (xs :: [a]) :: [b] where-  Map f '[]       = '[]-  Map f (x ': xs) = f x ': Map f xs--type family Constraints (cs :: [GHC.Constraint]) :: GHC.Constraint-type instance Constraints '[]       = ()-type instance Constraints (c ': cs) = (c, Constraints cs)--type AllHave (c :: k -> GHC.Constraint) (xs :: [k]) = Constraints (Map c xs)--type family Args a where-  Args (a -> b) = a ': Args b-  Args a        = '[]--type family Res a where-  Res (a -> b) = Res b-  Res a        = a---- makeDecl :: Symbol -> Sort -> Command -- Builder--- makeDecl x t-  -- / | Just (_, ts, t) <- functionSort t-  -- = Declare x ts t--- makeDecl x t-  -- = Declare x [] t--makeDecl :: SEnv F.DataDecl -> Symbol -> Sort -> Command-makeDecl env x t = Declare x ins' out'-  where-    ins'        = sortSmtSort False env <$> ins-    out'        = sortSmtSort False env     out-    (ins, out)  = deconSort t--deconSort :: Sort -> ([Sort], Sort)-deconSort t = case functionSort t of-  Just (_, ins, out) -> (ins, out)-  Nothing            -> ([] , t  )--safeFromJust :: String -> Maybe a -> a-safeFromJust msg Nothing  = error $ "safeFromJust: " ++ msg-safeFromJust _   (Just x) = x--applyPreds :: SpecType -> SpecType -> [(Symbol,SpecType)]-applyPreds sp' dc = -- trace ("sp : " ++ showpp sp') $ trace ("dc : " ++ showpp dc)-                    zip xs (map tx ts)-  where-    sp = removePreds <$> sp'-    removePreds (MkUReft r _ _) = MkUReft r mempty mempty-    (as, ps, _, t) = bkUniv dc-    (xs, ts, _, _) = bkArrow . snd $ bkClass t-    -- args  = reverse tyArgs-    su    = [(ty_var_value tv, toRSort t, t) | tv <- as | t <- rt_args sp]-    sup   = [(p, r) | p <- ps | r <- rt_pargs sp]-    tx    = (\t -> replacePreds "applyPreds" t sup)-          . everywhere (mkT $ propPsToProp sup)-          . subsTyVars_meet su--propPsToProp :: [(RPVar, SpecProp)] -> SpecProp -> SpecProp-propPsToProp su r = foldr propPToProp r su--propPToProp :: (RPVar, SpecProp) -> SpecProp -> SpecProp-propPToProp (p, r) (RProp _ (RHole (MkUReft _ (Pr [up]) _)))-  | pname p == pname up-  = r-propPToProp _ m = m--splitEApp_maybe :: Expr -> Maybe (Symbol, [Expr])-splitEApp_maybe e@(EApp {}) = go [] e-  where-    go acc (EApp f e) = go (e:acc) f-    go acc (EVar s)   = Just (s, acc)-    go _   _          = Nothing -- error $ "splitEApp_maybe: " ++ showpp e-splitEApp_maybe _ = Nothing--stripQuals :: SpecType -> SpecType-stripQuals = snd . bkClass . fourth4 . bkUniv--fourth4 :: (t, t1, t2, t3) -> t3-fourth4 (_,_,_,d) = d--getSpec :: [String] -> FilePath -> IO GhcSpec-getSpec opts target-  = do cfg  <- getOpts ["--quiet"]-       spec . head . fst <$> getGhcInfos Nothing (cfg {ghcOptions = opts}) [target]-       -- case info of-       --   Left err -> error $ show err-       --   Right i  -> return $ spec i--runGhc :: [String] -> GHC.Ghc a -> IO a-runGhc o x = GHC.runGhc (Just GHC.Paths.libdir) $ do-               df <- GHC.getSessionDynFlags-               let df' = df { GHC.ghcMode   = GHC.CompManager-                            , GHC.ghcLink   = GHC.NoLink --GHC.LinkInMemory-                            , GHC.hscTarget = GHC.HscNothing --GHC.HscInterpreted-                            -- , GHC.optLevel  = 0 --2-                            , GHC.log_action = \_ _ _ _ _ _ -> return ()-                            } `GHC.gopt_set` GHC.Opt_ImplicitImportQualified-               (df'',_,_) <- GHC.parseDynamicFlags df' (map GHC.noLoc o)-               _ <- GHC.setSessionDynFlags df''-               x--loadModule :: FilePath -> GHC.Ghc GHC.ModSummary-loadModule f = do target <- GHC.guessTarget f Nothing-                  --lcheck <- GHC.guessTarget "src/Test/Target.hs" Nothing-                  GHC.setTargets [target] -- [target,lcheck]-                  _ <- GHC.load GHC.LoadAllTargets-                  modGraph <- GHC.getModuleGraph-                  let m = fromJust $ find ((==f) . GHC.msHsFilePath) modGraph-                  GHC.setContext [ GHC.IIModule (GHC.ms_mod_name m)-                                 --, GHC.IIDecl $ GHC.simpleImportDecl-                                 --             $ GHC.mkModuleName "Test.Target"-                                 ]-                  return m
+ stack.yaml view
@@ -0,0 +1,24 @@+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/liquid.css 
@@ -1,105 +0,0 @@-.hs-linenum {-  color: #B2B2B2; -  font-style: italic;-}--.hs-error {-  background-color: #FF8585 ;-}--.hs-keyglyph {-  color: #007020-}--.hs-keyword {-  color: #007020;-  // font-weight: bold;-}--.hs-comment, .hs-comment a {color: green;}--.hs-str, .hs-chr {color: teal;}--.hs-conid { -  color: #902000;   /* color: #00FFFF; color: #0E84B5; */-  //font-weight: bold;  -}--.hs-definition { -  color: #06287E -  /* font-weight: bold; */ -}--.hs-varid, .hs-varop, .hs-layout {-  color: black; -}--.hs-num {-  color: #40A070;-}--.hs-conop {-  color: #902000; -}--.hs-cpp {-  color: orange;-}--.hs-sel  {}--a.annot {-  position:relative; -  color:#000;-  text-decoration:none; -  white-space: pre; -}--a.annot:hover { -  z-index:25; -  background-color: #D8D8D8;-}--a.annot span.annottext{display: none}--a.annot:hover span.annottext{ -  -  border-radius: 5px 5px;-  -  -moz-border-radius: 5px; -  -webkit-border-radius: 5px; -  -  box-shadow: 5px 5px 5px rgba(0, 0, 0, 0.1); -  -webkit-box-shadow: 5px 5px rgba(0, 0, 0, 0.1);-  -moz-box-shadow: 5px 5px rgba(0, 0, 0, 0.1); --  white-space:pre;-  display:block;-  position: absolute; -  left: 1em; top: 2em; -  z-index: 99;-  margin-left: 5; -  background: #FFFFAA; -  border: 3px solid #FFAD33;-  padding: 0.8em 1em;-}--code {-   /* font-weight: bold; */-   background-color: rgb(250, 250, 250); -   border: 1px solid rgb(200, 200, 200);-   padding-left: 4px;-   padding-right: 4px;-}--pre {-  background-color: #f0f0f0;-  border-top: 1px solid #ccc;-  border-bottom: 1px solid #ccc;-  padding: 5px;-  // font-size: 120%;-  // font-family: Bitstream Vera Sans Mono,monospace;-  display: block;-  overflow: visible;-}-
+ tests/.DS_Store view
binary file changed (absent → 6148 bytes)
+ tests/._.DS_Store view
binary file changed (absent → 120 bytes)
− tests/Parser.hs 
@@ -1,526 +0,0 @@-{-# LANGUAGE DeriveDataTypeable  #-}-{-# LANGUAGE DoAndIfThenElse     #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}---- | Simple test suite to test the parser.------ Run as:------ $ stack test :liquidhaskell-parser--module Main where--import           Data.Data-import           Data.Generics.Aliases-import           Data.Generics.Schemes-import           Language.Fixpoint.Types.Spans-import qualified Language.Haskell.Liquid.Parse as LH--- import qualified Language.Haskell.Liquid.Types as LH-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 =  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 " @?=-          "Assm (\"foo\" (dummyLoc),lq_tmp$db##0:a -> a (dummyLoc))"--    , testCase "assert" $-       parseSingleSpec "assert myabs :: Int -> PosInt" @?=-          "Asrt (\"myabs\" (dummyLoc),lq_tmp$db##0:Int -> PosInt (dummyLoc))"--    , testCase "autosize" $-       parseSingleSpec "autosize List" @?=-          "ASize \"List\" (dummyLoc)"--    , testCase "local" $-       parseSingleSpec "local foo :: Nat -> Nat" @?=-          "LAsrt (\"foo\" (dummyLoc),lq_tmp$db##0:Nat -> Nat (dummyLoc))"--    , testCase "axiomatize" $-       parseSingleSpec "axiomatize fibA" @?=-          "Reflect \"fibA\" (dummyLoc)"--    , testCase "reflect" $-       parseSingleSpec "reflect map" @?=-          "Reflect \"map\" (dummyLoc)"--    , testCase "measure HMeas" $-       parseSingleSpec "measure isAbs" @?=-          "HMeas \"isAbs\" (dummyLoc)"--    , testCase "measure Meas" $-       parseSingleSpec "measure fv :: Expr -> (Set Bndr)" @?=-          "Meas fv :: lq_tmp$db##0:Expr -> (Set Bndr)"--    , testCase "define" $-       parseSingleSpec "define $ceq = eqN" @?=-          "Define (\"$ceq\" (dummyLoc),\"eqN\")"--    , testCase "infixl" $-       parseSingleSpec "infixl 9 +++" @?=-          "BFix ()"--    , testCase "infixr" $-       parseSingleSpec "infixr 9 +++" @?=-          "BFix ()"--    , testCase "infix" $-       parseSingleSpec "infix 9 +++" @?=-          "BFix ()"--    , testCase "inline" $-       parseSingleSpec "inline eqelems" @?=-          "Inline \"eqelems\" (dummyLoc)"--    , testCase "bound PBound" $-       parseSingleSpec "bound Foo = true" @?=-          "PBound bound Foo forall [] . [] =  true"--    , testCase "bound HBound" $-       parseSingleSpec "bound step" @?=-          "HBound \"step\" (dummyLoc)"--    , testCase "class measure" $-       parseSingleSpec "class measure sz :: forall a. a -> Int" @?=-          "CMeas sz :: lq_tmp$db##0:a -> Int"--    , testCase "instance measure" $-       parseSingleSpec "instance measure sz :: MList a -> Int" @?=-          "IMeas sz :: lq_tmp$db##0:(MList a) -> Int"--    , testCase "instance" $-       parseSingleSpec "instance VerifiedNum Int where\n  - :: x:Int -> y:Int -> OkInt {x - y} " @?=-          "RInst (RI {riclass = VerifiedNum, ritype = [Int (dummyLoc)], risigs = [(\"-\" (dummyLoc),RISig x:Int -> y:Int -> (OkInt {x - y}) (dummyLoc))]})"--    , testCase "class" $-       parseSingleSpec "class Sized s where\n  size :: forall a. x:s a -> {v:Nat | v = sz x}" @?=-          "Class (RClass {rcName = Sized, rcSupers = [], rcTyVars = [BTV \"s\"], rcMethods = [(\"size\" (dummyLoc),x:s a -> {v : Nat | v == sz x} (dummyLoc))]})"--    , testCase "import" $-       parseSingleSpec "import Foo" @?=-          "Impt \"Foo\""--    , testCase "data variance" $-       parseSingleSpec "data variance IO bivariant" @?=-          "Varia (\"IO\" (dummyLoc),[Bivariant])"--    , testCase "data" $-       parseSingleSpec "data Bob = B {foo :: Int}" @?=-          "DDecl DataDecl: data = \"Bob\", tyvars = [], sizeFun = Nothing, kind = DataUser"-    , testCase "newtype" $-       parseSingleSpec "newtype Foo = Bar {x :: Nat}" @?=-          "NTDecl DataDecl: data = \"Foo\", tyvars = [], sizeFun = Nothing, kind = DataUser"--    , testCase "include" $-       parseSingleSpec "include <listSet.hquals>" @?=-          "Incl \"listSet.hquals\""--    , testCase "invariant" $-       parseSingleSpec "invariant {v:Tree a | 0 <= ht v}" @?=-          "Invt {v : (Tree a) | 0 <= ht v} (dummyLoc)"--    , testCase "using" $-       parseSingleSpec "using (Tree a) as  {v:Tree a   | 0 <= height v}" @?=-          -- "IAlias ((Tree a) (dummyLoc),{v##0 : (Tree a) | 0 <= height v##0} (dummyLoc))"-             "IAlias ((Tree a) (dummyLoc),{v : (Tree a) | 0 <= height v} (dummyLoc))"--    , testCase "type" $-       parseSingleSpec "type PosInt = {v: Int | v >= 0}" @?=-          "Alias type PosInt   = {v : Int | v >= 0} -- defined at \"Fixpoint.Types.dummyLoc\" (line 0, column 0)"--    , testCase "predicate" $-       parseSingleSpec "predicate Pos X  = X > 0" @?=-          "EAlias type Pos  \"X\" = PAtom Gt (EVar \"X\") (ECon (I 0)) -- defined at \"Fixpoint.Types.dummyLoc\" (line 0, column 0)"--    , testCase "expression" $-       parseSingleSpec "expression Avg Xs = ((sumD Xs) / (lenD Xs))" @?=-          "EAlias type Avg  \"Xs\" = EBin Div (EApp (EVar \"sumD\") (EVar \"Xs\")) (EApp (EVar \"lenD\") (EVar \"Xs\")) -- defined at \"Fixpoint.Types.dummyLoc\" (line 0, column 0)"--    , testCase "embed" $-       parseSingleSpec "embed Set as Set_Set" @?=-          "Embed (\"Set\" (dummyLoc),TC \"Set_Set\" (dummyLoc) (TCInfo {tc_isNum = False, tc_isReal = False, tc_isString = False}))"--    , testCase "qualif" $-       parseSingleSpec "qualif Foo(v:Int): v < 0" @?=-          "Qualif (Q {qName = \"Foo\", qParams = [(\"v\",FInt)], qBody = PAtom Lt (EVar \"v\") (ECon (I 0)), qPos = \"Fixpoint.Types.dummyLoc\" (line 0, column 0)})"--    , testCase "decrease" $-       parseSingleSpec "decrease insert 3" @?=-          "Decr (\"insert\" (dummyLoc),[2])"--    , testCase "lazyvar" $-       parseSingleSpec "lazyvar z" @?=-          "LVars \"z\" (dummyLoc)"--    , testCase "lazy" $-       parseSingleSpec "lazy eval" @?=-          "Lazy \"eval\" (dummyLoc)"--    , testCase "automatic-instances" $-       parseSingleSpec "automatic-instances foo with 5" @?=-          "Insts (\"foo\" (dummyLoc),Just 5)"--    , testCase "LIQUID" $-       parseSingleSpec "LIQUID \"--automatic-instances=liquidinstances\" " @?=-          "Pragma \"--automatic-instances=liquidinstances\" (dummyLoc)"--    , testCase "default parser (Asrts)" $-       parseSingleSpec " assumeIndices :: t:ByteStringNE -> s:BS.ByteString -> [OkPos t s]" @?=-          "Asrts ([\"assumeIndices\" (dummyLoc)],(t:ByteStringNE -> s:ByteString -> [(OkPos t s)] (dummyLoc),Nothing))"-    ]---- ------------------------------------------------------------------------- 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 " @?=-          "Asrts ([\"assume\" (dummyLoc)],(lq_tmp$db##0:Int -> Bool (dummyLoc),Nothing))"--    , testCase "assert" $-       parseSingleSpec "assert :: Int -> Bool " @?=-          "Asrts ([\"assert\" (dummyLoc)],(lq_tmp$db##0:Int -> Bool (dummyLoc),Nothing))"--    , testCase "autosize" $-       parseSingleSpec "autosize :: Int -> Bool " @?=-          "Asrts ([\"autosize\" (dummyLoc)],(lq_tmp$db##0:Int -> Bool (dummyLoc),Nothing))"--    , testCase "axiomatize" $-       parseSingleSpec "axiomatize :: Int -> Bool " @?=-          "Asrts ([\"axiomatize\" (dummyLoc)],(lq_tmp$db##0:Int -> Bool (dummyLoc),Nothing))"--    , testCase "reflect" $-       parseSingleSpec "reflect :: Int -> Bool " @?=-          "Asrts ([\"reflect\" (dummyLoc)],(lq_tmp$db##0:Int -> Bool (dummyLoc),Nothing))"--    , testCase "measure" $-       parseSingleSpec "measure :: Int -> Bool " @?=-          "Asrts ([\"measure\" (dummyLoc)],(lq_tmp$db##0:Int -> Bool (dummyLoc),Nothing))"---    , testCase "define 1" $-       parseSingleSpec "define :: Int -> Bool " @?=-          "Asrts ([\"define\" (dummyLoc)],(lq_tmp$db##0:Int -> Bool (dummyLoc),Nothing))"--    , testCase "define 2" $-       parseSingleSpec "define GHC.Types.True = (true)" @?=-          "Define (\"GHC.Types.True\" (dummyLoc),\"(true)\")"--    , testCase "defined" $-       parseSingleSpec "defined :: Int -> Bool " @?=-          "Asrts ([\"defined\" (dummyLoc)],(lq_tmp$db##0:Int -> Bool (dummyLoc),Nothing))"--    , testCase "inline" $-       parseSingleSpec "inline :: Int -> Bool " @?=-          "Asrts ([\"inline\" (dummyLoc)],(lq_tmp$db##0:Int -> Bool (dummyLoc),Nothing))"--    , testCase "bound" $-       parseSingleSpec "bound :: Int -> Bool " @?=-          "Asrts ([\"bound\" (dummyLoc)],(lq_tmp$db##0:Int -> Bool (dummyLoc),Nothing))"--    , testCase "invariant" $-       parseSingleSpec "invariant :: Int -> Bool " @?=-          "Asrts ([\"invariant\" (dummyLoc)],(lq_tmp$db##0:Int -> Bool (dummyLoc),Nothing))"--    , testCase "predicate" $-       parseSingleSpec "predicate :: Int -> Bool " @?=-          "Asrts ([\"predicate\" (dummyLoc)],(lq_tmp$db##0:Int -> Bool (dummyLoc),Nothing))"--    , testCase "expression" $-       parseSingleSpec "expression :: Int -> Bool " @?=-          "Asrts ([\"expression\" (dummyLoc)],(lq_tmp$db##0:Int -> Bool (dummyLoc),Nothing))"--    , testCase "embed" $-       parseSingleSpec "embed :: Int -> Bool " @?=-          "Asrts ([\"embed\" (dummyLoc)],(lq_tmp$db##0:Int -> Bool (dummyLoc),Nothing))"--    , testCase "qualif" $-       parseSingleSpec "qualif :: Int -> Bool " @?=-          "Asrts ([\"qualif\" (dummyLoc)],(lq_tmp$db##0:Int -> Bool (dummyLoc),Nothing))"-    ]---- -----------------------------------------------------------------------testSucceeds :: TestTree-testSucceeds =-  testGroup "Should succeed"-    [ testCase "x :: Int" $-       (parseSingleSpec "x :: Int") @?=-          "Asrts ([\"x\" (dummyLoc)],(Int (dummyLoc),Nothing))"--    , testCase "x :: a" $-       (parseSingleSpec "x :: a") @?=-          "Asrts ([\"x\" (dummyLoc)],(a (dummyLoc),Nothing))"--    , testCase "x :: a -> a" $-       (parseSingleSpec "x :: a -> a") @?=-          -- "Asrts ([\"x\" (dummyLoc)],(a -> a (dummyLoc),Nothing))"-             "Asrts ([\"x\" (dummyLoc)],(lq_tmp$db##0:a -> a (dummyLoc),Nothing))"--    , testCase "x :: Int -> Int" $-       (parseSingleSpec "x :: Int -> Int") @?=-          -- "Asrts ([\"x\" (dummyLoc)],(Int -> Int (dummyLoc),Nothing))"-             "Asrts ([\"x\" (dummyLoc)],(lq_tmp$db##0:Int -> Int (dummyLoc),Nothing))"--    , testCase "k:Int -> Int" $-       (parseSingleSpec "x :: k:Int -> Int") @?=-          "Asrts ([\"x\" (dummyLoc)],(k:Int -> Int (dummyLoc),Nothing))"--    , testCase "type spec 1 " $-       parseSingleSpec "type IncrListD a D = [a]<{\\x y -> (x+D) <= y}>" @?=-          "Alias type IncrListD \"a\" \"D\" = [a] -- defined at \"Fixpoint.Types.dummyLoc\" (line 0, column 0)"--    , testCase "type spec 2 " $-       parseSingleSpec "takeL :: Ord a => x:a -> [a] -> [{v:a|v<=x}]" @?=-          -- "Asrts ([\"takeL\" (dummyLoc)],((Ord a) -> x:a -> lq_tmp$db##1:[a] -> [{v##2 : a | v##2 <= x}] (dummyLoc),Nothing))"-             "Asrts ([\"takeL\" (dummyLoc)],((Ord a) -> x:a -> lq_tmp$db##1:[a] -> [{v : a | v <= x}] (dummyLoc),Nothing))"--    , testCase "type spec 3" $-       parseSingleSpec "bar :: t 'Nothing" @?=-          "Asrts ([\"bar\" (dummyLoc)],(t Nothing (dummyLoc),Nothing))"--    , testCase "type spec 4" $-       parseSingleSpec "Cons :: forall <l>.a -> L^l a -> L^l a" @?=-          "Asrts ([\"Cons\" (dummyLoc)],(lq_tmp$db##0:a -> lq_tmp$db##1:(L a) -> (L a) (dummyLoc),Nothing))"--    , testCase "type spec 5" $-       parseSingleSpec "mapKeysWith :: (Ord k2) => (a -> a -> a) -> (k1->k2) -> OMap k1 a -> OMap k2 a" @?=-             "Asrts ([\"mapKeysWith\" (dummyLoc)],((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) (dummyLoc),Nothing))"--    , testCase "type spec 6 " $-       parseSingleSpec (unlines $-         [ "data Tree [ht] a = Nil"-         , "            | Tree { key :: a"-         , "                   , l   :: Tree {v:a | v < key }"-         , "                   , r   :: Tree {v:a | key < v }"-         , "                   }" ])-        @?=-          "DDecl DataDecl: data = \"Tree\", tyvars = [\"a\"], sizeFun = Just SymSizeFun \"ht\", kind = DataUser"--    , testCase "type spec 7" $-       parseSingleSpec "type AVLL a X    = AVLTree {v:a | v < X}" @?=-              "Alias type AVLL \"a\" \"X\" = (AVLTree {v : a | v < X}) -- defined at \"Fixpoint.Types.dummyLoc\" (line 0, column 0)"--    , testCase "type spec 8" $-       parseSingleSpec "type AVLR a X    = AVLTree {v:a |X< v} " @?=-             "Alias type AVLR \"a\" \"X\" = (AVLTree {v : a | X < v}) -- defined at \"Fixpoint.Types.dummyLoc\" (line 0, column 0)"--    , testCase "type spec 9 " $-       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> "])-        @?=-             "Assm (\"(++)\" (dummyLoc),(Ord a) =>\n{x :: {VV : a | true} |- {VV : a | true} <: {v : a | x <= v}} =>\n{|- {VV : a | true} <: {VV : a | true}} =>\n{|- {VV : a | true} <: {VV : a | true}} =>\nlq_tmp$db##13:(OList {VV : a | true}) -> lq_tmp$db##15:(OList {VV : a | true}) -> (OList {VV : a | true}) (dummyLoc))"--    , testCase "type spec 10" $-       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)" ])-          @?=-          "DDecl DataDecl: data = \"AstF\", tyvars = [\"f\"], sizeFun = Nothing, kind = DataUser"--    , testCase "type spec 11" $-       parseSingleSpec "assume     :: b:_ -> a -> {v:a | b} " @?=-          "Asrts ([\"assume\" (dummyLoc)],(b:{VV : _ | $HOLE} -> lq_tmp$db##0:a -> {v : a | b} (dummyLoc),Nothing))"--    , testCase "type spec 12" $-       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> -> ()" ])-          @?=-             "Asrts ([\"app\" (dummyLoc)],({|- Int <: Int} =>\n{x :: Int |- {v : Int | v == x + 1} <: Int} =>\nlq_tmp$db##8:(lq_tmp$db##9:Int -> ()) -> x:Int -> () (dummyLoc),Nothing))"--    , testCase "type spec 13" $-       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 } "])-          @?=-             "Asrts ([\"ssum\" (dummyLoc)],({|- {v : a | v == 0} <: {VV : a | true}} =>\n{x :: {VV : a | true} |- {v : a | x <= v} <: {VV : a | true}} =>\nxs:[{v : a | 0 <= v}] -> {v : a | len xs >= 0\n                                  && 0 <= v} (dummyLoc),Nothing))"--    , testCase "type spec 14" $-       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)) "])-          @?=-          "EAlias type ValidChunk  \"V\" \"XS\" \"N\" = PAnd [PImp (PAtom Eq (EApp (EVar \"len\") (EVar \"XS\")) (ECon (I 0))) (PAtom Eq (EApp (EVar \"len\") (EVar \"V\")) (ECon (I 0))),PImp (PNot (PAtom Eq (EApp (EVar \"len\") (EVar \"XS\")) (ECon (I 0)))) (PAnd [PImp (PAnd [PAtom Lt (ECon (I 1)) (EApp (EVar \"len\") (EVar \"XS\")),PAtom Lt (ECon (I 1)) (EVar \"N\")]) (PAtom Lt (EApp (EVar \"len\") (EVar \"V\")) (EApp (EVar \"len\") (EVar \"XS\"))),PImp (PAtom Le (EApp (EVar \"len\") (EVar \"XS\")) (EVar \"N\")) (PAtom Eq (EApp (EVar \"len\") (EVar \"V\")) (ECon (I 1)))])] -- defined at \"Fixpoint.Types.dummyLoc\" (line 0, column 0)"--    , testCase "type spec 15" $-       parseSingleSpec "assume (=*=.) :: Arg a => f:(a -> b) -> g:(a -> b) -> (r:a -> {f r == g r}) -> {v:(a -> b) | f == g}" @?=-             "Assm (\"(=*=.)\" (dummyLoc),(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}) -> {VV : lq_tmp$db##6:a -> b | f == g} (dummyLoc))"--    , testCase "type spec 16" $-       parseSingleSpec "sort :: (Ord a) => xs:[a] -> OListN a {len xs}" @?=-           "Asrts ([\"sort\" (dummyLoc)],((Ord a) -> xs:[a] -> (OListN a {len xs}) (dummyLoc),Nothing))"--    , testCase "type spec 17" $-       parseSingleSpec " ==. :: x:a -> y:{a| x == y} -> {v:b | v ~~ x && v ~~ y } " @?=-           "Asrts ([\"==.\" (dummyLoc)],(x:a -> y:{y : a | x == y} -> {v : b | v ~~ x\n                                      && v ~~ y} (dummyLoc),Nothing))"--    , testCase "type spec 18" $-       parseSingleSpec "measure snd :: (a,b) -> b" @?=-           "Meas snd :: lq_tmp$db##0:(a, b) -> b"--    , testCase "type spec 19" $-       parseSingleSpec "returnST :: xState:a \n             -> ST <{\\xs xa v -> (xa = xState)}> a s " @?=-                     -- returnST :: a -> ST a s-                     -- returnST x = S $ \s -> (x, s)-           "Asrts ([\"returnST\" (dummyLoc)],(xState:a -> (ST a s) (dummyLoc),Nothing))"--    , testCase "type spec 20" $-       parseSingleSpec "makeq :: l:_ -> r:{ _ | size r <= size l + 1} -> _ " @?=-           "Asrts ([\"makeq\" (dummyLoc)],(l:{VV : _ | $HOLE} -> r:{r : _ | size r <= size l + 1} -> {VV : _ | $HOLE} (dummyLoc),Nothing))"--    , 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)" @?=-            "Asrts ([\"newRGRef\" (dummyLoc)],(e:{VV : a | true} -> e2:{VV : a | true} -> f:(x:{VV : a | true} -> y:{VV : a | true} -> {v : a | v == y}) -> (IO (RGRef a)) (dummyLoc),Nothing))"--    , testCase "type spec 22" $-       parseSingleSpec "cycle        :: {v: [a] | len(v) > 0 } -> [a]" @?=-            "Asrts ([\"cycle\" (dummyLoc)],(v:{v : [a] | len v > 0} -> [a] (dummyLoc),Nothing))"--    , testCase "type spec 23" $-       parseSingleSpec "cons :: x:a -> _ -> {v:[a] | hd v = x} " @?=-         "Asrts ([\"cons\" (dummyLoc)],(x:a -> lq_tmp$db##0:{VV : _ | $HOLE} -> {v : [a] | hd v == x} (dummyLoc),Nothing))"--    , testCase "type spec 24" $-       parseSingleSpec "set :: a:Vector a -> i:Idx a -> a -> {v:Vector a | vlen v = vlen a}" @?=-         "Asrts ([\"set\" (dummyLoc)],(a:(Vector a) -> i:(Idx a) -> lq_tmp$db##0:a -> {v : (Vector a) | vlen v == vlen a} (dummyLoc),Nothing))"--    , testCase "type spec 25" $-       parseSingleSpec "assume GHC.Prim.+#  :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v: GHC.Prim.Int# | v = x + y}" @?=-         "Assm (\"GHC.Prim.+#\" (dummyLoc),x:Int# -> y:Int# -> {v : Int# | v == x + y} (dummyLoc))"--    , testCase "type spec 26" $-       parseSingleSpec " measure isEVar " @?=-         "HMeas \"isEVar\" (dummyLoc)"--    , testCase "type spec 27" $-       parseSingleSpec (unlines $-         [ "data List a where"-         , "    Nil  :: List a "-         , "  | Cons :: listHead:a -> listTail:List a -> List a  "])-        @?=-          "DDecl DataDecl: data = \"List\", tyvars = [\"a\"], sizeFun = Nothing, kind = DataUser"--    , testCase "type spec 28" $-       parseSingleSpec (unlines $-         [ "data List2 a b <p :: a -> Bool> where"-         , "    Nil2  :: List2 a "-         , "  | Cons2 :: listHead:a -> listTail:List a -> List2 a b"])-        @?=-          "DDecl DataDecl: data = \"List2\", tyvars = [\"a\",\"b\"], sizeFun = Nothing, kind = DataUser"--    , testCase "type spec 29" $-       parseSingleSpec (unlines $-         [ "data Ev :: Peano -> Prop where"-         , "  EZ  :: Prop (Ev Z)"-         , "| ESS :: n:Peano -> Prop (Ev n) -> Prop (Ev (S (S n)))"-         ])-        @?=-          "DDecl DataDecl: data = \"Ev\", tyvars = [], sizeFun = Nothing, kind = DataUser"--    , testCase "type spec 30" $-       parseSingleSpec (unlines $-         [ "measure fst :: (a,b) -> a"-         , "fst (a,b) = a"-         ])-        @?=-          "Meas fst :: lq_tmp$db##0:(a, b) -> a\nfst [] ((,)a b) = a"-    ]---- -----------------------------------------------------------------------testFails :: TestTree-testFails =-  testGroup "Does fail"-    [ testCase "Maybe k:Int -> Int" $-          parseSingleSpec "x :: Maybe k:Int -> Int" @?=-            "<test>:1:13: Error: Cannot parse specification:\n    unexpected ':'\n    expecting stratumP, monoPredicateP, white space, bareTyArgP, mmonoPredicateP, \"->\", \"=>\", \"/\" 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 " @?=-            "<test>:1:62: Error: Cannot parse specification:\n    unexpected end of input\n    expecting bareTyArgP"--    , testCase "Missing |" $-          parseSingleSpec "ff :: {v:Nat  v >= 0 }" @?=-          -- parseSingleSpec "ff :: {v :  }" @?=-            "<test>:1:9: Error: 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 =-  case LH.singleSpecP (initialPos "<test>") src of-    Left err  -> show err-    Right 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)) }"-  ]----------------------------------------------------------------------------dummyLocs :: (Data a) => a -> a-dummyLocs = everywhere (mkT posToDummy)-  where-    posToDummy :: SourcePos -> SourcePos-    posToDummy _ = dummyPos "Fixpoint.Types.dummyLoc"---- ---------------------------------------------------------------------
+ tests/TestCommits.hs view
@@ -0,0 +1,115 @@+#!/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 
@@ -1,262 +0,0 @@-{---This code implements a Monoid for string matching; i.e. a data-structure, MatchIdxs, which has the result of a string match function-plus a little extra information for monoidally combining things-together; the purpose of course is to parallelize string matching-computations. This is the original version I wrote which uses type-level strings to guarantee that only computations done with the same-target string are combinable.--The invariants I'd like to prove are in the comments on the MatchIdxs-constructors. I'd be interested in a way to do it directly with this-code (though it seems that would require extending LH), or doing it in-a version of this code where the constructors have an extra argument-with the value of the target-- however that formulation seems to raise-issues about forcing those values to be the same.--I have a version of the code lying around which tries this approach,-but I couldn't get it to work. I chose to send this version first so-you have the chance to see where I started; I could send you my version-with the explicit terms if you like.--If this goes well, then there are a couple of further things to think-about:--  1) I have another Monoid construction for actual splitting, but-     I don't think LH can handle the invariants as they require an-     isInfixOf operation; but I could be wrong about what LH can do.--  2) It would be interesting to think about whether one can encode-     correctness, rather than just some invariants. By correctness-     I mean both that the monoid laws are satisfied, and that there-     is a homomorphic-like property to the effect of:--     match (x <> y) == match x <> match y--Let me know if you have any questions about the code, or need more-comments/explanation.--}---{- LIQUID "--diff" @-}-{-@ LIQUID "--scrape-used-imports" @-}-{-@ LIQUID "--short-names" @-}--{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--module 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 -> Data.Word.Word8 @-}--{-@ measure target @-}-target :: MatchIdxs -> BS.ByteString-target (Small t _)           = t-target (MatchIdxs t _ _ _ _) = t--{-@ inline min @-}-min :: Int -> Int -> Int-min x y = if x <= y then x else y--{-@ inline max @-}-max :: Int -> Int -> Int-max x y = if x <= y then y else x---- RJ instance (KnownSymbol t, StringMatch alg) => Monoid (MatchIdxs alg t) where-{-@ mmempty :: t:ByteStringNE -> MatchIdxsT t @-}-mmempty t = Small t BS.empty--{-@ mmconcat :: (Foldable t) => Alg -> tg:ByteStringNE -> t (MatchIdxsT tg) -> (MatchIdxsT tg) @-}-mmconcat alg t = foldr (mmappend alg t) (mmempty t)--{-@ qualif BB(v:Int, n:Int, d:Int, b:BS.ByteString): v <= (n + d) - bLength b @-}--{-@ mmappend :: Alg -> t:ByteStringNE -> MatchIdxsT t -> MatchIdxsT t -> MatchIdxsT t @-}-mmappend alg t mx my =-  let fringeLen = BS.length t - 1-      idxFun    = indices alg t-  in-  case (mx, my) of-    (Small tx x, Small _ y) -> myIndices alg tx (x <> y)-    (Small tx x, MatchIdxs _ yLen ly iy rt) -> MatchIdxs tx xyLen lt is rt-       where-         xyLen = xLen + yLen-         xLen  = BS.length x-         xly   = BS.append x ly-         lt    = BS.take fringeLen xly-         is    = idxFun xly ++ map (+ xLen) iy-    (MatchIdxs tx xLen lt ix rx, Small ty y) -> MatchIdxs tx xyLen lt (ix ++ is) rt-       where-         xyLen = xLen + yLen-         yLen  = BS.length y-         is    = map (+ (xLen - fringeLen)) (idxFun rxy)-         rt    = BS.drop (BS.length rxy - fringeLen) rxy-         rxy   = BS.append rx y-    (MatchIdxs tx xLen lt ix rx, MatchIdxs ty yLen ly iy rt) -> MatchIdxs tx xyLen lt (ix ++ is) rt-       where-         xyLen = xLen + yLen-         is    = ixy ++ map (+ xLen) iy-         ixy   = map (+ (xLen - fringeLen)) $ idxFun (BS.append rx ly)---- | Example applications------ The bufLen and chunkSz arguments are there to exercise the monoid,--- though they also foreshadow a parallel implementation.-{-@ indicesBS' :: Alg -> Int -> Int -> ByteStringNE -> BS.ByteString -> [Int] @-}-indicesBS' alg bufLen chunkSz t bs =-  let si = mmconcat alg t . map (mmconcat alg t) . chunksOf bufLen . map (myIndices alg t) $ chunksBS chunkSz bs in-  matchIdxsIs si--{-@ indicesBS, indicesNaive :: Int -> Int -> ByteStringNE -> BS.ByteString -> [Int] @-}-indicesBS    = indicesBS' BM   -- RJ (Proxy :: Proxy BM)-indicesNaive = indicesBS' Spec -- RJ (Proxy :: Proxy Spec)--{-@ isInfixOfBS :: Int -> Int -> ByteStringNE -> BS.ByteString -> Bool @-}-isInfixOfBS bufLen chunkSz t = not . null . indicesBS bufLen chunkSz t---------------------------------------------------------------------------------------------{-@ invariant {v:BS.ByteString | 0 <= bLength v } @-}-{-@ measure bLength :: BS.ByteString -> Int @-}-{-@ type LNat N = {v:Nat | v < N} @-}--chunksOf :: Int -> [a] -> [[a]]-chunksOf = undefined--{-@ assumeIndices :: t:ByteStringNE -> s:BS.ByteString -> [OkPos t s] @-}-assumeIndices :: BS.ByteString -> BS.ByteString -> [Int]-assumeIndices = undefined
− tests/errors/AmbiguousReflect.hs 
@@ -1,19 +0,0 @@-{-@ LIQUID "--exact-data-cons"     @-}-{-@ LIQUID "--higherorder"        @-}--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 
@@ -1,7 +0,0 @@-module BadExprArg where--{-@ type ListN a N = {v:[a] | len v = N} @-}--{-@ foo :: ListN 0 0 @-}-foo :: [a]-foo = undefined
− tests/errors/BadAnnotation.hs 
@@ -1,5 +0,0 @@-module Zoo where--{-@ incr :: x:Int -> {v:Int | x < v } -}-incr :: Int -> Int-incr x = x - 1
− tests/errors/BadAnnotation1.hs 
@@ -1,7 +0,0 @@-module Zoo where--{-@ incr :: x:Int -         -> {v:Int | x < v } -  -}-incr :: Int -> Int-incr x = x - 1
− tests/errors/BadData1.hs 
@@ -1,32 +0,0 @@-{-@ 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)
− tests/errors/BadData2.hs 
@@ -1,13 +0,0 @@-{-@ 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 
@@ -1,5 +0,0 @@-module Boo where--{-@ data T = Cuthb { fldX :: Int, fldY :: Int } @-}--data T = Cuthb { fldX :: Int }
− tests/errors/BadDataConType.hs 
@@ -1,5 +0,0 @@-module Boo where--{-@ data T = C { fldX :: Int, fldY :: Bool } @-}--data T = C { fldX :: Int, fldY :: Int }
− tests/errors/BadDataDeclTyVars.hs 
@@ -1,25 +0,0 @@--- | 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 "--higherorder"     @-}-{-@ LIQUID "--exact-data-cons" @-}-{-@ LIQUID "--automatic-instances=liquidinstances" @-}--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/BadPragma0.hs 
@@ -1,7 +0,0 @@-{-@ LIQUID "--idirs=.." @-}--module Bad where --i :: Int-i = 1-
− tests/errors/BadPragma1.hs 
@@ -1,7 +0,0 @@-{-@ LIQUID "--c-files=./wow.c" @-}--module Bad where --i :: Int-i = 1-
− tests/errors/BadPragma2.hs 
@@ -1,7 +0,0 @@-{-@ LIQUID "--ghc-option=-O0" @-}--module Bad where --i :: Int-i = 1-
− tests/errors/BadPredApp.hs 
@@ -1,7 +0,0 @@-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 
@@ -1,10 +0,0 @@-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 
@@ -1,8 +0,0 @@-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 
@@ -1,37 +0,0 @@-{-# 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 
@@ -1,9 +0,0 @@-module Zoo where--type Foo = Int--{-@ type Fooz = {v:Int | 1 < v} @-}--{-@ bob :: Fooz 1000 @-}-bob = 10 :: Int-
− tests/errors/BadSyn2.hs 
@@ -1,7 +0,0 @@-module Zoo where--type Foo = Int--{-@ bob :: Foo 1000 @-}-bob = 10 :: Int-
− tests/errors/BadSyn3.hs 
@@ -1,7 +0,0 @@-module Zoo where--type Foo = Int--{-@ bob :: Foo String @-}-bob = 10 :: Int-
− tests/errors/BadSyn4.hs 
@@ -1,8 +0,0 @@-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 
@@ -1,4 +0,0 @@-module Test0 () where--{-@ expression CyclicA1 Q = CyclicA1 Q @-}-
− tests/errors/CyclicExprAlias1.hs 
@@ -1,5 +0,0 @@-module Test2 () where--{-@ expression CyclicB1 Q = CyclicB2 Q @-}-{-@ expression CyclicB2 Q = CyclicB1 Q @-}-
− tests/errors/CyclicExprAlias2.hs 
@@ -1,7 +0,0 @@-module Test3 () where--{-@ expression CyclicC1 Q = (CyclicC2 Q) && (CyclicC3 Q) @-}-{-@ expression CyclicC2 Q = CyclicC1 Q @-}-{-@ expression CyclicC3 Q = CyclicC1 Q @-}--
− tests/errors/CyclicExprAlias3.hs 
@@ -1,6 +0,0 @@-module Test3 () where--{-@ expression CyclicD1 Q = CyclicD2 Q @-}-{-@ expression CyclicD2 Q = CyclicD3 Q @-}-{-@ expression CyclicD3 Q = CyclicD1 Q @-}-
− tests/errors/CyclicPredAlias0.hs 
@@ -1,4 +0,0 @@-module Test0 () where--{-@ predicate CyclicA1 Q = CyclicA1 Q @-}-
− tests/errors/CyclicPredAlias1.hs 
@@ -1,5 +0,0 @@-module Test1 () where--{-@ predicate CyclicB1 Q = CyclicB2 Q @-}-{-@ predicate CyclicB2 Q = CyclicB1 Q @-}-
− tests/errors/CyclicPredAlias2.hs 
@@ -1,6 +0,0 @@-module Test2 () where--{-@ predicate CyclicC1 Q = CyclicC2 Q && CyclicC3 Q @-}-{-@ predicate CyclicC2 Q = CyclicC1 Q @-}-{-@ predicate CyclicC3 Q = CyclicC1 Q @-}-
− tests/errors/CyclicPredAlias3.hs 
@@ -1,6 +0,0 @@-module Test3 () where--{-@ predicate CyclicD1 Q = CyclicD2 Q @-}-{-@ predicate CyclicD2 Q = CyclicD3 Q @-}-{-@ predicate CyclicD3 Q = CyclicD1 Q @-}-
− tests/errors/CyclicTypeAlias0.hs 
@@ -1,5 +0,0 @@-module Test0 () where--{-@ type CyclicA1 = CyclicA2 @-}-{-@ type CyclicA2 = CyclicA1 @-}-
− tests/errors/CyclicTypeAlias1.hs 
@@ -1,6 +0,0 @@-module Test1 () where--{-@ type CyclicB1 = CyclicB2 @-}-{-@ type CyclicB2 = CyclicB3 @-}-{-@ type CyclicB3 = CyclicB1 @-}-
− tests/errors/CyclicTypeAlias2.hs 
@@ -1,4 +0,0 @@-module Test2 () where--{-@ type CyclicC = [CyclicC] @-}-
− tests/errors/CyclicTypeAlias3.hs 
@@ -1,6 +0,0 @@-module Test3 () where--{-@ type CyclicD1 = CyclicD2 @-}-{-@ type CyclicD2 = CyclicD3 @-}-{-@ type CyclicD3 = CyclicD2 @-}-
− tests/errors/DupAlias.hs 
@@ -1,17 +0,0 @@-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 
@@ -1,24 +0,0 @@--- | 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 
@@ -1,22 +0,0 @@--- 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
− tests/errors/DupMeasure.hs 
@@ -1,17 +0,0 @@-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/EmptyData.hs 
@@ -1,6 +0,0 @@--- | see: https://github.com/ucsd-progsys/liquidhaskell/issues/1169--module Bar where--{-@ data A @-}-data A = B
− tests/errors/ExportMeasure0.hs 
@@ -1,16 +0,0 @@--- 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/ExportMeasure1.hs 
@@ -1,31 +0,0 @@--- From Data.ByteString.Fusion---- Compare with tests/pos/StrictPair1.hs--module SPair (-    PairS(..)-  , moo-  -- FIX: , psnd-  ) where--import Language.Haskell.Liquid.Prelude (liquidAssert)--infixl 2 :*:---- | Strict pair---   But removing the strictness annotation does not change the fact that---   this program is marked as SAFE...-data PairS a b = !a :*: !b deriving (Eq,Ord,Show)--{-@ data PairS a b <p :: x0:a -> b -> Bool> = (:*:) { spX ::a, spY ::b<p spX> }  @-}--{-@ measure psnd @-}-psnd :: PairS a b -> b-psnd ((:*:) x y) = y---{-@ type FooS a = PairS <{\z v -> v <= psnd z}> (PairS a Int) Int @-}--{-@ moo :: (FooS a) -> () @-}-moo :: PairS (PairS a Int) Int -> ()-moo (x :*: n :*: m) = liquidAssert (m <= n) ()
− tests/errors/ExportReflect0.hs 
@@ -1,28 +0,0 @@--- 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 
@@ -1,9 +0,0 @@-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 
@@ -1,3 +0,0 @@-{-@ foo :: a: Int -> f: (Int -> Int) -> {v : Int | v = 123 + (f a) } @-}-foo :: Int -> (Int -> Int) -> Int-foo a f = f a
− tests/errors/HoleCrash1.hs 
@@ -1,7 +0,0 @@-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 
@@ -1,7 +0,0 @@-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 
@@ -1,18 +0,0 @@-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 
@@ -1,61 +0,0 @@--- 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 
@@ -1,5 +0,0 @@-module Boo where--{-@ incr :: Int -> Bool @-}-incr :: Int -> Int -incr x = x + 1
− tests/errors/Inconsistent2.hs 
@@ -1,5 +0,0 @@-module Mismatch where--{-@ foo :: Nat @-}-foo :: Bool-foo = True
− tests/errors/LiftMeasureCase.hs 
@@ -1,17 +0,0 @@-module Measures where--llen :: [a] -> Int-llen [] = 0-llen (x:xs) = 1 + llen xs--foo x = x--{-@ measure foo @-}--{-@ measure lllen @-}--{-@ lllen :: xs:[a] -> {v:Int| (lllen xs) = v} @-}--lllen :: [a] -> Int	-lllen [] = 0-lllen (x:xs) = 1 + lllen xs
− tests/errors/LocalHole.hs 
@@ -1,12 +0,0 @@-{-@ LIQUID "--no-termination" @-}-module LocalHole where--{- assume (!!) :: xs:[a] -> {v:Nat | v < len xs} -> a @-}--mysum xs = go 0 0-  where-    n = length xs-    {-@ go :: i:{Nat | i <= nn} -> _ -> _ @-}-    go i acc-      | i >= n    = acc-      | otherwise = go (i+1) (acc + xs !! i)
− tests/errors/MissingAbsRefArgs.hs 
@@ -1,11 +0,0 @@-module Fixme where----- foo :: [a] -> ()-{- foo :: [{v:a | v = 5}] -> () @-}--- foo _ = ()---bar :: a -> b -> a-{-@ bar :: forall<p :: a -> b -> Bool>. x:a -> {xx:b<p> | xx > xx} -> a @-}-bar x y = x
− tests/errors/MissingSizeFun.hs 
@@ -1,13 +0,0 @@-module MapReduce where--{-@ data List [llen] a = N | C {lhead :: a, ltail :: List a} @-}-data List a = N | C a (List a)--{-@ measure llen @-}-llen :: List a -> Bool -llen N = True  -llen (C _ xs) = False -- 1 + llen xs---{-@ data List2 [llen2] a = N2 | C2 {lhead2 :: a, ltail2 :: List2 a} @-}-data List2 a = N2 | C2 a (List2 a)
− tests/errors/MultiInstMeasures.hs 
@@ -1,34 +0,0 @@-module Blank where--import Data.Word-import GHC.Ptr--{-@ class measure sizeOf :: forall a . Ptr a -> Int @-}-{-@-instance measure sizeOf :: (Ptr Data.Word.Word16) -> Int-sizeOf (Ptr x) = 2-@-}-{-@-instance measure sizeOf :: (Ptr Data.Word.Word32) -> Int-sizeOf (Ptr y) = 4-@-}--{- measure sizeOf :: forall a . Ptr a -> Int @-}--{- invariant {v:Ptr Word16 | sizeOf v = 2} @-}-{- invariant {v:Ptr Word32 | sizeOf v = 4} @-}--{-@-bar :: { p : Ptr Word32 | plen p >= (sizeOf p) }-    -> ()-@-}-bar :: Ptr Word32 -> ()-bar (Ptr unused) = ()--{-@-qux :: { p : Ptr Word32 | plen p >= 0 }-    -> ()-@-}-qux :: Ptr Word32 -> ()-qux (Ptr addr) = let x = Ptr addr in bar x-
− tests/errors/MultiRecSels.hs 
@@ -1,22 +0,0 @@-{-@ 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 
@@ -1,7 +0,0 @@--- 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 
@@ -1,17 +0,0 @@-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/ShadowFieldInline.hs 
@@ -1,17 +0,0 @@-{-@ 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 
@@ -1,17 +0,0 @@-{-@ 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 
@@ -1,20 +0,0 @@--- 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 
@@ -1,17 +0,0 @@--- 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 
@@ -1,11 +0,0 @@--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/T773.hs 
@@ -1,11 +0,0 @@--- | 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 
@@ -1,10 +0,0 @@---- | 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 
@@ -1,43 +0,0 @@--- ISSUE: In the below datatype, mickeymouse is clearly UNBOUND, and yet--- LH happily chugs along, and just says UNSAT at the end, instead of--- pointing out the bogus datatype definition.--module 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 
@@ -1,84 +0,0 @@--- 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 
@@ -1,8 +0,0 @@-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 
@@ -1,8 +0,0 @@-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 
@@ -1,11 +0,0 @@-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 
@@ -1,10 +0,0 @@---- 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/UnboundFunInSpec.hs 
@@ -1,9 +0,0 @@-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 
@@ -1,4 +0,0 @@-module Goo where--{-@ foo :: xs:_ -> {v:_ | this = rubbish } @-}-foo _ _ = 0
− tests/errors/UnboundFunInSpec2.hs 
@@ -1,5 +0,0 @@-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 
@@ -1,5 +0,0 @@-module Assume where--{-@ assume incr :: Int -> {v : Int | v == x} @-}-incr :: Int -> Int-incr x = x + 1
− tests/errors/UnboundVarInSpec.hs 
@@ -1,7 +0,0 @@-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 
@@ -1,4 +0,0 @@-#include "foo.h"-int foo(int x) {-  return x;-}
− tests/ffi-include/foo.h 
@@ -1,1 +0,0 @@-int foo(int);
− tests/import/client/ExactGADT9.hs 
@@ -1,12 +0,0 @@-{-@ LIQUID "--exact-data-con" @-}--{-# 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/ListClient.hs 
@@ -1,38 +0,0 @@--- | A "client" that uses the reflected definitions.--{-@ LIQUID "--exact-data-con"                      @-}-{-@ LIQUID "--higherorder"                         @-}-{-@ LIQUID "--automatic-instances=liquidinstances" @-} --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/RC1015.hs 
@@ -1,12 +0,0 @@-{-@ 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 
@@ -1,11 +0,0 @@-module ReflectClient0 where--import ReflectLib0----- the below works with GreaterThanA instead of GreaterThan,--- as the former is defined as a "predicate" alias.--{-@ incr :: x:Nat -> {v:Nat | gtThan v x} @-}-incr :: Int -> Int-incr x = x + 1
− tests/import/client/ReflectClient1.hs 
@@ -1,7 +0,0 @@-module ReflectClient0 where--import ReflectLib1--{-@ myHead :: {v:[a] | not (isNull v) } -> a @-}-myHead :: [a] -> a-myHead (x:_) = x
− tests/import/client/ReflectClient2.hs 
@@ -1,8 +0,0 @@-{-@ LIQUID "--higherorder" @-}--module ReflectClient2 where--import ReflectLib2--{-@ proof :: a -> { v: Int | incr 5 == 6 } @-}-proof _ = incr 5
− tests/import/client/ReflectClient3.hs 
@@ -1,23 +0,0 @@-{-@ LIQUID "--exact-data-con"                      @-}-{- LIQUID "--automatic-instances=liquidinstances" @-}--module ReflectClient3 where--import Language.Haskell.Liquid.ProofCombinators--import ReflectLib3---- THIS IS NEEDED TO BRING THE NAMES INTO SCOPE FOR GHC ...-forceImports = [ undefined next-               , undefined lDay-               ]---- THIS WORKS-{-@ test2 :: { next Mon == Tue } @-}-test2 = next Mon ==. Tue *** QED---- THIS DOES NOT WORK, but it DOES work if we remove the--- type parameter from `List`. However it DOES work if we--- put this back into ReflectLib3.hs-{-@ test4 :: { lDay Nil == Mon } @-}-test4 = lDay Nil ==. Mon *** QED
− tests/import/client/ReflectClient4.hs 
@@ -1,64 +0,0 @@--{- LIQUID "--higherorder"                         @-}-{- LIQUID "--totality"                            @-}-{-@ LIQUID "--exact-data-con"                      @-}-{-@ LIQUID "--automatic-instances=liquidinstances" @-}--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-  =  ()-  --  llen (app Nil ys)-  -- ==. llen ys-  -- ==. llen Nil + llen ys-  -- *** QED--thmAppLen (Cons x xs) ys-  = thmAppLen xs ys--  -- =   llen (app (Cons x xs) ys)-  -- ==. llen (Cons x (app xs ys))-  -- ==. 1 + llen (app xs ys)-      -- ? thmAppLen xs ys-  -- ==. 1 + llen xs + llen ys-  -- ==. llen (Cons x xs) + llen ys-  -- *** QED
− tests/import/client/ReflectClient4a.hs 
@@ -1,33 +0,0 @@-{-@ LIQUID "--exact-data-con"                      @-}-{-@ LIQUID "--automatic-instances=liquidinstances" @-}--module ReflectClient4a where--import Language.Haskell.Liquid.ProofCombinators--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 = ()----- {- thmAppLen :: xs:List a -> ys:List a ->-      -- { llen (app xs ys) == llen xs + llen ys}-  -- @-}--- thmAppLen :: List a -> List a -> Proof--- thmAppLen Nil         ys = trivial--- thmAppLen (Cons x xs) ys = thmAppLen xs ys
− tests/import/client/ReflectClient5.hs 
@@ -1,11 +0,0 @@-{-@ LIQUID "--exact-data-con"                      @-}-{-@ LIQUID "--automatic-instances=liquidinstances" @-}--module ReflectClient5 where--import Language.Haskell.Liquid.ProofCombinators--import ReflectLib5--{-@ test5 :: { gapp Nil = Nil } @-}-test5 = ()
− tests/import/client/ReflectClient6.hs 
@@ -1,15 +0,0 @@-{-@ LIQUID "--exact-data-con"                      @-}-{-@ LIQUID "--automatic-instances=liquidinstances" @-}--module ReflectClient6 where--import Language.Haskell.Liquid.ProofCombinators--import ReflectLib6--{-@ testOK :: { next Mon == Tue } @-}-testOK = next Mon ==. Tue *** QED--{-@ testFAIL :: { next Tue == Mon } @-}-testFAIL = trivial -
− tests/import/client/ReflectClient7.hs 
@@ -1,31 +0,0 @@-{-@ LIQUID "--higherorder"    @-}-{-@ LIQUID "--exactdc"        @-}-{-@ LIQUID "--automatic-instances=liquidinstances" @-}--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/T1096_Foo.hs 
@@ -1,8 +0,0 @@-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 
@@ -1,17 +0,0 @@-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/T1180.hs 
@@ -1,11 +0,0 @@-{-# LANGUAGE GADTs #-}--{-@ LIQUID "--exact-data-con" @-}--module Ev where--import Peano --pInt :: Peano -> Int -pInt Z     = 0 -pInt (S n) = 1 + pInt n
− tests/import/lib/ExactGADT8.hs 
@@ -1,47 +0,0 @@-{-@ LIQUID "--exact-data-con" @-}--{-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-}-----------------------------------------------------------------------------------module ExactGADT8 where--{- data Goob a where-       GooX :: (a ~ Int) => Goob a-    |  GooY :: (a ~ Int) => Goob a-  -}--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-            ExactGADT8.BlobXVal :: EntityField Blob {v:_ | True }-          | ExectGADT8.BlobYVal :: EntityField Blob {v:_ | True }-    @-}-  -- ORIG-  data EntityField Blob typ where-    BlobXVal :: EntityField Blob Int-    BlobYVal :: EntityField Blob Int---- TH-GEN--- data EntityField Blob typ---  = typ ~ Int => BlobXVal |---    typ ~ Int => BlobYVal--data RefinedFilter record typ = RefinedFilter-  { refinedFilterField  :: EntityField record typ-  }--{- reflect evalQBlob @-}-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/ListLib.hs 
@@ -1,34 +0,0 @@--- | A module with some definitions for Lists--{-@ LIQUID "--no-adt" @-}-{-@ LIQUID "--exact-data-con" @-}-{-@ LIQUID "--higherorder" @-}--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/Peano.hs 
@@ -1,31 +0,0 @@-{-# LANGUAGE GADTs #-}--{-@ LIQUID "--exact-data-con" @-}-{-@ LIQUID "--higherorder"    @-}-{-@ LIQUID "--ple"            @-}--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 
@@ -1,18 +0,0 @@-{-@ 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 
@@ -1,8 +0,0 @@-module ReflectLib0 where--{-@ inline gtThan @-}-gtThan :: Int -> Int -> Bool-gtThan x y = x > y---{-@ predicate GreaterThanA X Y = X > Y @-}
− tests/import/lib/ReflectLib1.hs 
@@ -1,6 +0,0 @@-module ReflectLib1 where--{-@ measure isNull @-}-isNull :: [a] -> Bool-isNull []     = True-isNull (x:xs) = False
− tests/import/lib/ReflectLib2.hs 
@@ -1,28 +0,0 @@-{-@ LIQUID "--higherorder" @-}--module ReflectLib2 where--{-@ reflect incr @-}-incr :: Int -> Int-incr x = x + 1--{-@ reflect incr2 @-}-incr2 :: Int -> Int -> Int-incr2 x y = x + y--{-@ reflect plus @-}-plus :: Int -> Int-plus x = apply incr x--{-@ reflect apply @-}-apply :: (a -> b) -> a -> b-apply f x = f x--{-@ reflect toNat @-}-toNat :: Int -> Int-{-@ toNat :: Nat -> Nat @-}-toNat n = if n == 0 then 0 else (1 + toNat (n - 1))---{-@ myproof :: a -> { v: Int | incr 5 == 6 } @-}-myproof _ = incr 5
− tests/import/lib/ReflectLib3.hs 
@@ -1,26 +0,0 @@-{-@ LIQUID "--exact-data-con"                      @-}-{-@ LIQUID "--automatic-instances=liquidinstances" @-}--module ReflectLib3 where--import Language.Haskell.Liquid.ProofCombinators---- | Days -----------------------------------------------------------------------{-@ data Day = Mon | Tue @-}-data Day = Mon | Tue--{-@ reflect next @-}-next :: Day -> Day-next Mon = Tue-next Tue = Mon---- | Lists -----------------------------------------------------------------------{-@ data List  a = Nil | Cons {lHd :: a} @-}-data List a = Nil | Cons a--{-@ reflect lDay @-}-lDay :: List a -> Day-lDay Nil      = Mon-lDay (Cons x) = Tue
− tests/import/lib/ReflectLib4.hs 
@@ -1,31 +0,0 @@-{-@ LIQUID "--exact-data-con"                      @-}-{-@ LIQUID "--automatic-instances=liquidinstances" @-}--module ReflectLib4 where---- | Lists -----------------------------------------------------------------------{-@ data List [llen] @-} -- a = Nil | Cons {lHd :: a, lTl :: List a} @-}-data List a = Nil | Cons {lHd :: a, lTl :: List a} --{-@ measure llen @-}-{-@ llen :: List a -> Nat @-}-llen :: List a -> Int-llen Nil        = 0-llen (Cons h t) = 1 + llen t---- TODO: make this work WITHOUT the invariant-{-@ invariant {v:List a | 0 <= llen v} @-}--{-@ reflect app @-}-app :: List a -> List a -> List a-app Nil         ys = ys-app (Cons x xs) ys = Cons x (app xs ys)--{-@ reflect gapp @-}-gapp :: List a -> List a-gapp Nil         = Nil-gapp (Cons x xs) = Nil--{-@ test4 :: { gapp Nil = Nil } @-}-test4 = ()
− tests/import/lib/ReflectLib5.hs 
@@ -1,33 +0,0 @@-{-@ LIQUID "--exact-data-con"                      @-}-{-@ LIQUID "--automatic-instances=liquidinstances" @-}--module ReflectLib5 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--{-@ reflect lDay @-}-lDay :: List a -> Day-lDay Nil      = Mon-lDay (Cons x) = Tue---- | Lists -----------------------------------------------------------------------data List  a = Nil | Cons {lHd :: a}--{-@ reflect gapp @-}-gapp :: List a -> List a-gapp Nil      = Nil-gapp (Cons x) = Cons x--{-@ test4 :: { gapp Nil = Nil } @-}-test4 = ()
− tests/import/lib/ReflectLib6.hs 
@@ -1,17 +0,0 @@-{-@ LIQUID "--exact-data-con"                      @-}-{-@ LIQUID "--automatic-instances=liquidinstances" @-}--module ReflectLib6 where--import Language.Haskell.Liquid.ProofCombinators--{-@ data Day = Mon | Tue @-}-data Day = Mon | Tue--{-@ reflect next @-}-next :: Day -> Day-next Mon = Tue-next Tue = Mon--{-@ testFAIL :: { next Mon == Tue } @-}-testFAIL = trivial 
− tests/import/lib/ReflectLib7.hs 
@@ -1,8 +0,0 @@-{-@ LIQUID "--higherorder"    @-}-{-@ LIQUID "--exactdc"        @-}--module ReflectLib7 where--{-@ reflect compose @-}-compose :: (b -> c) -> (a -> b) -> a -> c-compose f g x = f (g x)
− tests/import/lib/T1096_Types.hs 
@@ -1,13 +0,0 @@-{-@ 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 
@@ -1,9 +0,0 @@-{-@ LIQUID "--exact-data-con" @-}--module T1102_LibX where--import T1102_LibY --{-@ theorem :: x:Bar -> {bar x = bar x} @-}-theorem :: Bar -> ()-theorem _ = ()
− tests/import/lib/T1102_LibY.hs 
@@ -1,11 +0,0 @@-{-@ LIQUID "--exact-data-con" @-}--module T1102_LibY where --import T1102_LibZ --data Bar = Bar {barFoo :: Foo Int Int} --{-@ reflect bar @-}-bar :: Bar -> Int -bar (Bar (Foo x _)) = x 
− tests/import/lib/T1102_LibZ.hs 
@@ -1,6 +0,0 @@-{-@ LIQUID "--exact-data-con" @-}--module T1102_LibZ where--{-@ data Foo a b = Foo { fooA :: a, fooB :: b} @-}-data Foo a b = Foo {fooA :: a, fooB :: b}
− tests/import/lib/T1104Lib.hs 
@@ -1,19 +0,0 @@-module T1104Lib where --data Foo a b = Foo {fooA :: a, fooB :: b}  |  Bar--{-@ measure isFoo @-}-isFoo :: Foo a b -> Bool-isFoo (Foo _ _) = True -isFoo Bar       = False --{-@ measure toNat @-}-{-@ toNat :: Foo a b -> Nat @-} -toNat :: Foo a b -> Int -toNat (Foo _ _) = 10 -toNat Bar       = 20 --{-@ twerp :: x:(Foo a b) -> {v:Bool | v = isFoo x} @-}-twerp x = g x-  where -    g = isFoo
− tests/import/lib/T1112.hs 
@@ -1,19 +0,0 @@--{-@ LIQUID "--higherorder"    @-}-{-@ LIQUID "--exact-data-con" @-}--module T1112 where--import T1112Lib--{- data Product @-}--{-@ axiomatize leqProd @-}-leqProd :: Eq (f p)-        => (f p -> f p -> Bool) -> (g p -> g p -> Bool)-        -> Product f g p -> Product f g p -> Bool-leqProd leqFP leqGP (Product x1 y1) (Product x2 y2) =-  if x1 == x2-    then leqGP y1 y2-    else leqFP x1 x2-{-# INLINE leqProd #-}
− tests/import/lib/T1112Lib.hs 
@@ -1,3 +0,0 @@-module T1112Lib where--data Product f g p = Product (f p) (g p) deriving Eq
− tests/import/lib/T1117.hs 
@@ -1,26 +0,0 @@-{-@ LIQUID "--higherorder"        @-}-{-@ LIQUID "--exactdc"            @-}--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/lib/T1117Lib.hs 
@@ -1,8 +0,0 @@-{-@ LIQUID "--higherorder"        @-}-{-@ LIQUID "--exactdc"            @-}--module T1117Lib where--data U1 p = U1--data Product f g p = Product (f p) (g p)
− tests/import/lib/T1118.hs 
@@ -1,25 +0,0 @@-{-@ LIQUID "--higherorder"        @-}-{-@ LIQUID "--exactdc"            @-}-module T1118 where--import T1118Lib2 -import T1118Lib1-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/lib/T1118Lib1.hs 
@@ -1,7 +0,0 @@-{-@ LIQUID "--higherorder"        @-}-{-@ LIQUID "--exactdc"            @-}-module T1118Lib1 where--import T1118Lib2 --{- data Product @-}
− tests/import/lib/T1118Lib2.hs 
@@ -1,4 +0,0 @@-module T1118Lib2 where--data U1 p = U1-data Product f g p = Product (f p) (g p)
− tests/neg/AdtPeano2.hs 
@@ -1,13 +0,0 @@-{-@ LIQUID "--exact-data-con"                      @-}-{-@ LIQUID "--higherorder"                         @-}--module Peano where--data Influx = Silly { goo :: Int }--test :: Int -> () -test n = bob n (Silly n)--{-@ bob :: n:Int -> { v:Influx | v = Silly (n + 1) } -> () @-}-bob :: Int -> Influx -> () -bob _ _ = () 
− tests/neg/AutoTerm.hs 
@@ -1,18 +0,0 @@-module Isort where--data F = F | C Int F  --{-@ data F [lenF] @-}--{-@ measure lenF @-}-lenF :: F -> Int---{-@ lenF :: xs:F -> {v:Int | v >= -1 } @-}-lenF F = 0-lenF (C _ x) = 1 + lenF x ---bar :: F -> Int -bar F = 0 -bar (C x xs) = x + bar xs 
− tests/neg/BinahQuery.hs 
@@ -1,126 +0,0 @@-{-@ LIQUID "--no-adt" 	                           @-}-{-@ LIQUID "--exact-data-con"                      @-}-{-@ LIQUID "--higherorder"                         @-}-{-@ LIQUID "--no-termination"                      @-}-{-@ LIQUID "--ple" @-} --{-@ infixr === @-}-{-@ infixr >== @-}-{-@ infixr <== @-}--{-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-}--module Query where--import Prelude hiding (filter)--data PersistFilter = EQUAL | LE | GE--class PersistEntity record where-    data EntityField record :: * -> *--{-@ data Filter record typ = Filter { filterField :: EntityField record typ, filterValue :: typ, filterFilter :: PersistFilter } @-}-data Filter record typ = Filter-    { filterField  :: EntityField record typ-    , filterValue  :: typ-    , filterFilter :: PersistFilter-    } ---{-@ reflect === @-}-(===) :: (PersistEntity record, Eq typ) => -                 EntityField record typ -> typ -> Filter record typ-field === value = Filter field value EQUAL--{-@ reflect <== @-}-(<==) :: (PersistEntity record, Eq typ) => -                 EntityField record typ -> typ -> Filter record typ-field <== value =-  Filter {-    filterField = field-  , filterValue = value-  , filterFilter = LE -  }--{-@ reflect >== @-}-(>==) :: (PersistEntity record, Eq typ) => -                 EntityField record typ -> typ -> Filter record typ-field >== value =-  Filter {-    filterField = field-  , filterValue = value-  , filterFilter = GE -  }--{-@ data Blob  = B { xVal :: Int, yVal :: Int } @-}-data Blob  = B { xVal :: Int, yVal :: Int }--instance PersistEntity Blob where-    {-@ data EntityField Blob typ where-        BlobXVal :: EntityField Blob Int-      | BlobYVal :: EntityField Blob Int-    @-}-    data EntityField Blob typ where-        BlobXVal :: EntityField Blob Int-        BlobYVal :: EntityField Blob Int--{-@ filter :: f:(a -> Bool) -> [a] -> [{v:a | f v}] @-}-filter :: (a -> Bool) -> [a] -> [a]-filter f (x:xs)-  | f x         = x : filter f xs-  | otherwise   =     filter f xs-filter _ []     = []--{-@ reflect evalQBlobXVal @-}-evalQBlobXVal :: PersistFilter -> Int -> Int -> Bool-evalQBlobXVal EQUAL filter given = filter == given-evalQBlobXVal LE filter given = given <= filter-evalQBlobXVal GE filter given = given >= filter--{-@ reflect evalQBlobYVal @-}-evalQBlobYVal :: PersistFilter -> Int -> Int -> Bool-evalQBlobYVal EQUAL filter given = filter == given-evalQBlobYVal LE filter given = given <= filter-evalQBlobYVal GE filter given = given >= filter--{-@ reflect evalQBlob @-}-evalQBlob :: Filter Blob typ -> Blob -> Bool-evalQBlob filter blob = case filterField filter of-    BlobXVal -> evalQBlobXVal (filterFilter filter) (filterValue filter) (xVal blob)-    BlobYVal -> evalQBlobYVal (filterFilter filter) (filterValue filter) (yVal blob)--{-@ reflect evalQsBlob @-}-evalQsBlob :: [Filter Blob typ] -> Blob -> Bool-evalQsBlob (f:fs) blob = evalQBlob f blob && (evalQsBlob fs blob)-evalQsBlob [] _ = True---{-@ filterQBlob :: f:(Filter Blob a) -> [Blob] -> [{b:Blob | evalQBlob f b}] @-}-filterQBlob :: Filter Blob a -> [Blob] -> [Blob]-filterQBlob q = filter (evalQBlob q)--{-@ filterQsBlob :: f:[(Filter Blob a)] -> [Blob] -> [{b:Blob | evalQsBlob f b}] @-}-filterQsBlob :: [Filter Blob a] -> [Blob] -> [Blob]-filterQsBlob qs = filter (evalQsBlob qs)---- select functions--{-@ assume selectBlob :: f:[(Filter Blob a)] -> [{b:Blob | evalQsBlob f b}] @-}-selectBlob :: [Filter Blob a] -> [Blob]-selectBlob fs = undefined --{-@ getZeros_ :: () -> [{b:Blob | xVal b = 0}] @-}-getZeros_ :: () -> [Blob]-getZeros_ () = selectBlob [(Filter BlobXVal 0 EQUAL)]--{-@ getBiggerThan10 :: () -> [{b:Blob | xVal b >= 10}] @-}-getBiggerThan10 :: () -> [Blob]-getBiggerThan10 () = selectBlob [(Filter BlobXVal 11 GE)]--{-@ getInRange :: () -> [{b:Blob | xVal b >= 10  && xVal b <= 20 && yVal b >= 0 && yVal b <= 10}] @-}-getInRange :: () -> [Blob]-getInRange () = selectBlob [ (BlobXVal >== 10)-                           , (BlobXVal <== 20)-                           , (BlobYVal >== 0)-                           , (BlobYVal <== 11)-                           ]
− tests/neg/BinahUpdate.hs 
@@ -1,38 +0,0 @@-{-@ LIQUID "--no-adt" 	                           @-}-{-@ LIQUID "--exact-data-con"                      @-}-{-@ LIQUID "--higherorder"                         @-}-{-@ LIQUID "--no-termination"                      @-}-{-@ LIQUID "--ple" @-} --{-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-}--module BinahUpdate where --class PersistEntity record where-    data EntityField record :: * -> *--instance PersistEntity Blob where-    {-@ data EntityField Blob typ where-          BlobXVal :: EntityField Blob {v:Int | v >= 10}-        | BlobYVal :: EntityField Blob Int-      @-}-    data EntityField Blob typ where-        BlobXVal :: EntityField Blob Int-        BlobYVal :: EntityField Blob Int--{-@ data Blob  = B { xVal :: {v:Int | v >= 0}, yVal :: Int } @-}-data Blob  = B { xVal :: Int, yVal :: Int }--data Update record typ = Update -    { updateField :: EntityField record typ-    , updateValue :: typ-    } --createUpdate :: EntityField record a -> a -> Update record a-createUpdate field value = Update {-      updateField = field-    , updateValue = value-}--testUpdateQuery :: () -> Update Blob Int-testUpdateQuery () = createUpdate BlobXVal 8  -- toggle to 80 to be SAFE 
− tests/neg/BinahUpdateClient.hs 
@@ -1,14 +0,0 @@-{-@ LIQUID "--no-adt" 	                           @-}-{-@ LIQUID "--exact-data-con"                      @-}-{-@ LIQUID "--higherorder"                         @-}-{-@ LIQUID "--no-termination"                      @-}-{-@ LIQUID "--ple" @-} --{-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-}--module BinahUpdateClient where --import BinahUpdateLib --testUpdateQuery :: () -> Update Blob Int-testUpdateQuery () = createUpdate BlobXVal 8  -- toggle to 80 to be SAFE 
− tests/neg/BinahUpdateLib.hs 
@@ -1,38 +0,0 @@-{-@ LIQUID "--no-adt" 	                           @-}-{-@ LIQUID "--exact-data-con"                      @-}-{-@ LIQUID "--higherorder"                         @-}-{-@ LIQUID "--no-termination"                      @-}-{-@ LIQUID "--ple" @-}--{-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-}--module BinahUpdateLib where--class PersistEntity record where-    data EntityField record :: * -> *--instance PersistEntity Blob where-    {-@ data EntityField Blob typ where-          BinahUpdateLib.BlobYVal :: EntityField Blob {v:_ | True}-        | BinahUpdateLib.BlobXVal :: EntityField Blob {v:_ | v >= 10}-      @-}-    data EntityField Blob typ where-        BlobXVal :: EntityField Blob Int-        BlobYVal :: EntityField Blob Int--{-@ data Blob  = B { xVal :: {v:Int | v >= 0}, yVal :: Int } @-}-data Blob  = B { xVal :: Int, yVal :: Int }--data Update record typ = Update-    { updateField :: EntityField record typ-    , updateValue :: typ-    }--createUpdate :: EntityField record a -> a -> Update record a-createUpdate field value = Update {-      updateField = field-    , updateValue = value-}--testUpdateQuery :: () -> Update Blob Int-testUpdateQuery () = createUpdate BlobXVal 8  -- toggle to 80 to be SAFE
− tests/neg/BinahUpdateLib1.hs 
@@ -1,37 +0,0 @@-{-@ LIQUID "--no-adt" 	                           @-}-{-@ LIQUID "--exact-data-con"                      @-}-{-@ LIQUID "--higherorder"                         @-}-{-@ LIQUID "--no-termination"                      @-}-{-@ LIQUID "--ple" @-}--{-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-}--module BinahUpdateLib where--class PersistEntity record where-    data EntityField record :: * -> *--instance PersistEntity Blob where-    {-@ data EntityField Blob typ where-          BinahUpdateLib.BlobYVal :: EntityField Blob {v:_ | True}-        | BinahUpdateLib.BlobXVal :: EntityField Blob {v:_ | v >= 10}-      @-}-   data EntityField Blob typ-      = typ ~ Int => BlobXVal |-        typ ~ Int => BlobYVal--data Blob  = B { xVal :: Int, yVal :: Int }--data Update record typ = Update-    { updateField :: EntityField record typ-    , updateValue :: typ-    }--createUpdate :: EntityField record a -> a -> Update record a-createUpdate field value = Update {-      updateField = field-    , updateValue = value-}--testUpdateQuery :: () -> Update Blob Int-testUpdateQuery () = createUpdate BlobXVal 8  -- toggle to 80 to be SAFE
tests/neg/BinarySearchOverflow.hs view
@@ -4,23 +4,23 @@  import Prelude hiding (Num(..)) import CheckedNum -import Data.Vector as Vector+import Data.Vector as V import Language.Haskell.Liquid.Prelude (liquidAssert)  -{-@ invariant {v:Vector a | 0 <= vlen v && BoundInt (vlen v)} @-}+{-@ invariant {v:V.Vector a | 0 <= vlen v && BoundInt (vlen v)} @-} -binarySearch :: Ord a => a -> Vector a -> Maybe Int+binarySearch :: Ord a => a -> V.Vector a -> Maybe Int binarySearch x v    | 0 < n     = loop x v 0 (n - 1)   | otherwise = Nothing -  where n     = Vector.length v+  where n     = V.length v  {-@ type Idx Vec = {v:Nat | v < vlen Vec} @-}  {-@ type BoundNat = {v:Nat | BoundInt v} @-} -{-@ loop :: Ord a => a -> vec:Vector a -> lo:Idx vec -> {hi:Idx vec | lo <= hi} -> Maybe Nat @-}-loop :: Ord a => a -> Vector a -> Int -> Int -> Maybe Int+{-@ loop :: Ord a => a -> vec:V.Vector a -> lo:Idx vec -> {hi:Idx vec | lo <= hi} -> Maybe Nat @-}+loop :: Ord a => a -> V.Vector a -> Int -> Int -> Maybe Int loop x v lo hi = do     -- let mid = lo + ((hi - lo) `div` 2) -- SAFE     let mid =  (hi + lo) `div` 2       -- UNSAFE
+ tests/neg/CharLiterals.hs view
@@ -0,0 +1,9 @@+-- see #1286++module Example where++{-@ fails :: {v:Bool | v} @-}+fails =  'a' == 'b'++{-@ ok :: {v:Bool | v} @-}+ok = "a" == "a"
tests/neg/Class3.hs view
@@ -8,13 +8,11 @@  {-@ qualif Sz(v:int, xs:a): v = (sz xs) @-} -{-@ data List a = Nil | Cons (hd::a) (tl::(List a)) @-} data List a = Nil | Cons a (List a) - {-@ class measure sz :: forall a. a -> Int @-} {-@ class Sized s where-      size :: forall a. x:s a -> {v:Nat | v = (sz x)}+      size :: forall a. x:s a -> {v:Nat | v = 23 + sz x}   @-} class Sized s where   size :: s a -> Int@@ -26,6 +24,3 @@     @-}   size Nil         = 0   size (Cons x xs) = size xs---
− tests/neg/Class5.hs 
@@ -1,11 +0,0 @@-module Class5 where--{-@ class Foo a where-      foo :: a -> Nat-  @-}--class Foo a where-  foo :: a -> Int-  foo _ = 0 - 10--
− tests/neg/Client.hs 
@@ -1,8 +0,0 @@-module Client where--import Lib--import LibSpec --bar = foo 1-
tests/neg/EvalQuery.hs view
@@ -1,8 +1,6 @@ -{-@ LIQUID "--exact-data-con"                      @-}-{-@ LIQUID "--higherorder"                         @-}-{-@ LIQUID "--no-termination"                      @-}-{-@ LIQUID "--automatic-instances=liquidinstances" @-}+{-@ LIQUID "--reflection"     @-}+{-@ LIQUID "--ple"            @-}  module Query where 
− tests/neg/Even.hs 
@@ -1,9 +0,0 @@-module Even () where--{-@ isEven, isOdd :: Nat -> Bool @-}-isEven :: Int -> Bool-isEven 0 = True-isEven n = isOdd  $ n--isOdd  0 = False-isOdd  m = isEven $ m - 1
− tests/neg/ExactGADT5.hs 
@@ -1,112 +0,0 @@-{-@ LIQUID "--no-adt" 	                           @-}-{-@ LIQUID "--exact-data-con"                      @-}-{-@ LIQUID "--higherorder"                         @-}-{-@ LIQUID "--no-termination"                      @-}-{-@ LIQUID "--ple" @-}--{-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-}--module Query where--import Prelude hiding (filter)--data PersistFilter = EQUAL | LE | GE--class PersistEntity record where-    data EntityField record :: * -> *--{-@ data Filter record typ = Filter { filterField :: EntityField record typ, filterValue :: typ, filterFilter :: PersistFilter } @-}-data Filter record typ = Filter-    { filterField  :: EntityField record typ-    , filterValue  :: typ-    , filterFilter :: PersistFilter-    }---{-@ reflect createEqQuery @-}-{--createEqQuery :: (PersistEntity record, Eq typ) =>-	         EntityField record typ -> typ -> Filter record typ-createEqQuery field value =-  Filter {-    filterField = field-  , filterValue = value-  , filterFilter = EQUAL-  }--}--createEqQuery :: EntityField record typ -> typ -> Filter record typ-createEqQuery field value = Filter field value EQUAL--createLeQuery :: (PersistEntity record, Eq typ) =>-                 EntityField record typ -> typ -> Filter record typ-createLeQuery field value =-  Filter {-    filterField = field-  , filterValue = value-  , filterFilter = LE-  }--{-@ data Blob  = B { xVal :: Int, yVal :: Int } @-}-data Blob  = B { xVal :: Int, yVal :: Int }--instance PersistEntity Blob where-  {-@ data EntityField Blob typ where-        BlobXVal :: EntityField Blob Int-      | BlobYVal :: EntityField Blob Int-    @-}-    data EntityField Blob typ where-        BlobXVal :: EntityField Blob Int-        BlobYVal :: EntityField Blob Int--{-@ filter :: f:(a -> Bool) -> [a] -> [{v:a | f v}] @-}-filter :: (a -> Bool) -> [a] -> [a]-filter f (x:xs)-  | f x         = x : filter f xs-  | otherwise   =     filter f xs-filter _ []     = []--{-@ reflect evalQBlobXVal @-}-evalQBlobXVal :: PersistFilter -> Int -> Int -> Bool-evalQBlobXVal EQUAL filter given = filter == given-evalQBlobXVal LE filter given = given <= filter-evalQBlobXVal GE filter given = given >= filter--{-@ reflect evalQBlobYVal @-}-evalQBlobYVal :: PersistFilter -> Int -> Int -> Bool-evalQBlobYVal EQUAL filter given = filter == given-evalQBlobYVal LE filter given = given <= filter-evalQBlobYVal GE filter given = given >= filter--{-@ reflect evalQBlob @-}-evalQBlob :: Filter Blob typ -> Blob -> Bool-evalQBlob filter blob = case filterField filter of-  BlobXVal -> evalQBlobXVal (filterFilter filter) (filterValue filter) (xVal blob)-  BlobYVal -> evalQBlobYVal (filterFilter filter) (filterValue filter) (yVal blob)--{-@ filterQBlob :: f:(Filter Blob a) -> [Blob] -> [{b:Blob | evalQBlob f b}] @-}-filterQBlob :: Filter Blob a -> [Blob] -> [Blob]-filterQBlob q = filter (evalQBlob q)--{-@ assume select :: f:(Filter Blob a) -> [{b:Blob | evalQBlob f b}] @-}-select :: Filter Blob a -> [Blob]-select _ = undefined---- Client code:---- Should typecheck:-{-@ getZeros1 :: [Blob] -> [{b:Blob | xVal b == 10}] @-}-getZeros1 :: [Blob] -> [Blob]-getZeros1 = filterQBlob (Filter BlobXVal 0 EQUAL)--{-@ getZeros2 :: () -> [{b:Blob | xVal b == 0}] @-}-getZeros2 :: () -> [Blob]-getZeros2 () = select (Filter BlobXVal 0 EQUAL)--{-@ getZeros3 :: [Blob] -> [{b:Blob | xVal b == 0}] @-}-getZeros3 :: [Blob] -> [Blob]-getZeros3 blobs = filterQBlob (createEqQuery BlobXVal 0) blobs--{-@ getZeros4 :: () -> [{b:Blob | xVal b == 0}] @-}-getZeros4 :: () -> [Blob]-getZeros4 () = select (createEqQuery BlobXVal 0)
tests/neg/HasElem.hs view
@@ -1,10 +1,12 @@ module HasElem where  {-@ LIQUID "--no-termination" @-}+{-@ LIQUID "--reflection"     @-}+{-@ LIQUID "--ple"            @-}  data L a = Nil | Cons a (L a) -{-@ measure hasElem @-}+{-@ reflect hasElem @-} hasElem :: Eq a => a -> L a -> Bool hasElem x Nil = False hasElem x (Cons y ys) = x == y || hasElem x ys@@ -18,7 +20,6 @@  prop2 :: Bool prop2 = hasElem 1 Nil-  nil = Nil cons = Cons 
− tests/neg/Lib.hs 
@@ -1,3 +0,0 @@-module Lib (foo) where--foo a = a
− tests/neg/LibSpec.hs 
@@ -1,6 +0,0 @@-module LibSpec ( module Lib ) where --import Lib--{-@ Lib.foo :: {v:a | false} -> a @-}-
− tests/neg/LiquidClass.hs 
@@ -1,43 +0,0 @@-module LiquidClass where----- | Typing classes--- | Step 1: Refine type dictionaries:--class Compare a where-	cmax :: a -> a -> a-	cmin :: a -> a -> a--instance Compare Int where	-{-@ instance Compare Int where -	cmax :: Odd -> Odd -> Odd ;-	cmin :: Int -> Int -> Int-  @-}--	cmax y x = if x >= y then x else y-  	cmin y x = if x >= y then x else y---- | creates dictionary environment:--- | * add the following environment--- | dictionary $fCompareInt :: Compare Int--- |               { $ccmax :: Odd -> Odd -> Odd--- |               , $ccmin :: Int -> Int -> Int--- |               }--- |--- | Important: do not type dictionaries, as preconditions--- | of fields cannot be satisfied!!!!!----- | Dictionary application --- | ((cmax Int)    @fcompareInt) :: Odd -> Odd -> Odd--- | ((cmin Int)    @fcompareInt) :: Int -> Int -> Int--- | (anything_else @fcompareInt) :: default---{-@ foo :: Odd -> Odd -> Odd @-}-foo :: Int -> Int -> Int-foo x y = cmax x y --{-@ unsafe :: Odd -> Odd -> Odd @-}-unsafe :: Int -> Int -> Int-unsafe x y = cmin x y 
− tests/neg/LiquidClass1.hs 
@@ -1,39 +0,0 @@-module LiquidClass where----- | Typing classes--- | Step 1: Refine type dictionaries:--class Compare a where-	cmax :: a -> a -> a-	cmin :: a -> a -> a--instance Compare Int where	-{-@ instance Compare Int where -	cmax :: Odd -> Odd -> Odd ;-	cmin :: Int -> Int -> Odd-  @-}--	cmax y x = if x >= y then x else y-  	cmin y x = if x >= y then x else y---- | creates dictionary environment:--- | * add the following environment--- | dictionary $fCompareInt :: Compare Int--- |               { $ccmax :: Odd -> Odd -> Odd--- |               , $ccmin :: Int -> Int -> Int--- |               }--- |--- | Important: do not type dictionaries, as preconditions--- | of fields cannot be satisfied!!!!!----- | Dictionary application --- | ((cmax Int)    @fcompareInt) :: Odd -> Odd -> Odd--- | ((cmin Int)    @fcompareInt) :: Int -> Int -> Int--- | (anything_else @fcompareInt) :: default---{-@ foo :: Odd -> Odd -> Odd @-}-foo :: Int -> Int -> Int-foo x y = cmax x y 
− tests/neg/ListISort-LType.hs 
@@ -1,52 +0,0 @@-module ListRange () where--import Language.Haskell.Liquid.Prelude---data List a = Nil | Cons a (List a)---- isOdd x = not (isEven x)--- isEven x = not (isOdd x)---- foo x = x+1--insert y Nil         -  = Cons y Nil-insert y (Cons x xs) | (y <= x) -  = let ys1 = Cons x xs in-    let ys2 = Cons y ys1 in ys2-insert y (Cons x xs) | (x <  y)-  = let xs1 = insert y xs in-    let xs2 = Cons x xs1 in xs2--chk2 y = -  case y of -   Nil -> True-   Cons x1 xs -> case xs of -                 Nil -> True-                 Cons x2 xs2 -> liquidAssertB (x1 == x2) && chk2 xs2-																	-n, m :: Int-n = choose 0-m = choose 0---- bar = insert n (range 2 8)-bar = insert n (insert m Nil)--range l h = if l <=h then Cons l (range (l+1) h) else Nil---mkList :: [a] -> List a																	-mkList = foldr Cons Nil--prop0 = chk2 bar----------
− tests/neg/ListISort.hs 
@@ -1,23 +0,0 @@-module ListSort () where--import Language.Haskell.Liquid.Prelude--insert y []     = [y]-insert y (x:xs) = if (y<=x) then (y:(x:xs)) else (x:(insert y xs))--chk [] = liquidAssertB True-chk (x1:xs) = case xs of -               []     -> liquidAssertB True-               x2:xs2 -> liquidAssertB (x1 <= x2) && chk xs-																	-sort = foldr insert []--rlist = map choose [1 .. 10]--bar = sort rlist--bar1 :: [Int]-bar1 = [1, 8, 2, 4, 5]--prop0 = chk rlist-prop1 = chk bar1
− tests/neg/ListQSort.hs 
@@ -1,34 +0,0 @@-module ListSort () where--import Language.Haskell.Liquid.Prelude--append k []     ys = k:ys-append k (x:xs) ys = x:(append k xs ys) --takeL x []     = []-takeL x (y:ys) = if (y<x) then y:(takeL x ys) else takeL x ys--takeGE x []     = []-takeGE x (y:ys) = if (y>=x) then y:(takeGE x ys) else takeGE x ys---{-@ quicksort :: (Ord a) => xs:[a] -> [a]<{\fld v -> (v < fld)}>  @-}-quicksort []     = []-quicksort (x:xs) = append x xsle xsge-  where xsle = quicksort (takeL x xs)-        xsge = quicksort (takeGE x xs)------chk [] = liquidAssertB True-chk (x1:xs) = case xs of -               []     -> liquidAssertB True-               x2:xs2 -> liquidAssertB (x1 <= x2) && chk xs-																	-rlist = map choose [1 .. 10]--bar = quicksort rlist--prop0 = chk bar
+ tests/neg/ListRange.dat view
@@ -0,0 +1,1 @@+data List a << p:a (fld:a)>> = Nil | Cons x:a^True y:List a^p(x) << p(fld) >> --
tests/neg/MaybeMonad.hs view
@@ -1,3 +1,4 @@+-- TODO-REBARE: STRATA module MaybeMonad where  import Prelude hiding (take)
+ tests/neg/NameResolution.hs view
@@ -0,0 +1,27 @@+module Fixme where++import Prelude hiding ((==), (++))+import Language.Haskell.Liquid.Equational +++{-@ bar :: () -> Int @-}+bar :: () -> Int+bar _+  =   1 +  ==. 2 +++{-@ (==..) :: x:a -> y:{a | x == y} -> {v:a | v == y && v == x} @-}+(==..) :: a -> a -> a +_ ==.. x = x++{-@ foo :: () -> Int @-}+foo :: () -> Int+foo _+  =   1 +  ==.. 2 +++{-@ (++) :: a -> a -> a @-}+(++) :: a -> a -> a +x ++ _ = x 
− tests/neg/NewTypes.hs 
@@ -1,9 +0,0 @@-newtype Foo a = Bar Int--{-@ newtype Foo a = Bar {x :: Nat} @-}--{-@ fromFoo :: Foo a -> Nat @-}-fromFoo :: Foo a -> Int-fromFoo (Bar n) = n--bar = Bar (-1)
− tests/neg/NewTypes0.hs 
@@ -1,8 +0,0 @@-newtype Foo a = Bar Int---{-@ newtype Foo a = Bar {x :: Nat} @-}--{-@ fromFoo :: Foo a -> {v:Int | v == 0 } @-}-fromFoo :: Foo a -> Int-fromFoo (Bar n) = n
tests/neg/RG.hs view
@@ -42,7 +42,7 @@    constructor with one physical argument, so at runtime these will look the same as IORefs:    we won't pay time or space overhead. -} {-@ data RGRef a <p :: a -> Bool, r :: a -> a -> Bool>-    = Wrap (rr :: R.IORef a<p>) @-}+	= Wrap { rr :: IORef a<p> } @-} data RGRef a = Wrap (R.IORef a)  {- A stability proof can be embedded into LH as a function of type:
tests/neg/RecQSort.hs view
@@ -2,7 +2,7 @@  {-@ type OList a =  [a]<{\fld v -> (v >= fld)}>  @-} -{-@ assert sort3 :: (Ord a) => [a] -> OList a @-}+{-@ sort3 :: (Ord a) => [a] -> OList a @-} sort3 :: (Ord a) => [a] -> [a] sort3 ls = qsort ls    where d = (length ls) @@ -14,7 +14,7 @@ qsort (x:xs) = qpart x xs [] []   qpart  :: (Ord a) => a -> [a] -> [a] -> [a] -> [a]-{-@ qpart  :: (Ord a) => x:a -> q:[a] -> r:[{v:a | ((true) && (v < x))}] -> p:[{v:a | ((true) && (v >= x))}] -> OList a / [((len r)+(len q)+(len p)), ((len q)+1)]@-}+{-@ qpart  :: (Ord a) => x:a -> q:[a] -> r:[{v:a | v < x}] -> p:[{v:a | v >= x}] -> OList a / [((len r)+(len q)+(len p)), ((len q)+1)]@-} qpart x [] rlt rge =     app x (qsort rlt) (x:qsort rge) qpart x (y:ys) rlt rge =@@ -27,4 +27,3 @@ app :: Ord a => a -> [a] -> [a] -> [a] app k []     ys = ys app k (x:xs) ys = x : (app k xs ys)-
tests/neg/RecSelector.hs view
@@ -1,9 +1,9 @@ module Invariant where -data F a = F {fx :: a, fy :: a, fzz :: a} | G {fx :: a}+data F a = F {fxx :: a, fy :: a, fzz :: a} | G {fxx :: a} -{-@ data F a = F {fxx :: a, fy :: a, fz :: a}-             | G {fxx :: a} +{-@ data F a = F { fxx :: a, fy :: a, fz :: a}+             | G { fxx :: a }    @-}  {-@ fooG :: x:a -> {v : F a | (fxx v) > x} @-}
tests/neg/Solver.hs view
@@ -1,9 +1,11 @@-{-@ LIQUID "--pruneunsorted" @-}+{-@ LIQUID "--pruneunsorted"  @-}+{-@ LIQUID "--no-termination" @-}+{-@ LIQUID "--short-names"    @-}+{-@ LIQUID "--reflection"     @-}+{-@ LIQUID "--ple"            @-}  module MultiParams where -{-@ LIQUID "--no-termination" @-}-{-@ LIQUID "--short-names" @-}  import Data.Tuple import Language.Haskell.Liquid.Prelude ((==>))@@ -61,32 +63,42 @@  -- | Satisfaction -{-@ measure sat @-}+{-@ reflect sat @-} sat :: Asgn -> Formula -> Bool sat a []         = True sat a (c:cs)     = satCls a c && sat a cs -{-@ measure satCls @-}+{-@ reflect satCls @-} satCls :: Asgn -> Clause -> Bool satCls a []      = False satCls a (l:ls)  = satLit a l || satCls a ls  -{-@ measure satLit @-}+{-@ reflect satLit @-} satLit :: Asgn -> Lit -> Bool satLit a (Pos x) = isTrue x a satLit a (Neg x) = isFalse x a -{-@ measure isTrue @-}+{-@ reflect isTrue @-} isTrue          :: Var -> Asgn -> Bool isTrue xisT (yv:as) = if xisT == (myFst yv) then (isVFalse (mySnd yv)) else isTrue xisT as isTrue _ []      = False +{-@ reflect isFalse @-}+isFalse          :: Var -> Asgn -> Bool+isFalse xisF (yv:as) = if xisF == (myFst yv) then (isVFalse (mySnd yv)) else isFalse xisF as+isFalse _ []      = False+ {-@ measure isVTrue @-} isVTrue :: Val -> Bool isVTrue VTrue  = True isVTrue VFalse = False +{-@ measure isVFalse @-}+isVFalse :: Val -> Bool+isVFalse VFalse = True+isVFalse VTrue  = False+ {-@ measure myFst @-} myFst :: (a, b) -> a myFst (x, y) = x@@ -94,13 +106,3 @@ {-@ measure mySnd @-} mySnd :: (a, b) -> b mySnd (x, y) = y--{-@ measure isFalse @-}-isFalse          :: Var -> Asgn -> Bool-isFalse xisF (yv:as) = if xisF == (myFst yv) then (isVFalse (mySnd yv)) else isFalse xisF as-isFalse _ []      = False--{-@ measure isVFalse @-}-isVFalse :: Val -> Bool-isVFalse VFalse = True-isVFalse VTrue  = False
− tests/neg/Strata.hs 
@@ -1,30 +0,0 @@-module Strata where--import Prelude hiding (repeat, length)--{-@ LIQUID "--strata" @-}--data L a = N | Cons a (L a)-{-@ data L [llen] @-}--{-@ measure llen :: L a -> Int-    llen (N) = 0-    llen (Cons x xs) = 1 + (llen xs)-  @-}--{-@ invariant {v:L a | (llen v) >= 0} @-}--{-@ Cons :: forall <l>.a -> L^l a -> L^l a @-}---{-@ lazy repeat @-}-repeat x = Cons x (repeat x)----- length :: L a -> Int-length N = 0-length (Cons _ xs) = length xs--foo x = length (repeat x)--bar = repeat 
− tests/neg/StreamInvariants.hs 
@@ -1,11 +0,0 @@-module Invariant where--{-@ using [a] as {v : [a] | (len v) > 0 } @-}---xs = []--add x xs = x:xs--bar xs = head xs-foo xs = tail xs
− tests/neg/Sum.hs 
@@ -1,10 +0,0 @@-module Sum where--{-@ 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 :: Num a => [a] -> a-ssum []       = 0-ssum [x]      = x-ssum (x:xs)   = x + ssum (x:xs)
+ tests/neg/Sumk.hquals view
@@ -0,0 +1,2 @@+qualif PPLUS0(v:int): v >= ~A + ~B+qualif PPLUS1(v:int): v > ~A + ~B
tests/neg/T1013A.hs view
@@ -1,6 +1,4 @@-{-@ LIQUID "--higherorder" @-}-{-@ LIQUID "--totality"    @-}-{-@ LIQUID "--exactdc"     @-}+{-@ LIQUID "--reflection"  @-} {-@ LIQUID "--no-adt"      @-} -- TODO: embed HKTs in SMTLIB2 ADTs (e.g. `Rec`)  {-# LANGUAGE RankNTypes #-}@@ -11,7 +9,7 @@  import Language.Haskell.Liquid.ProofCombinators -{-@ axiomatize _compose @-}+{-@ reflect _compose @-} _compose :: (b -> c) -> (a -> b) -> a -> c _compose f g x = f (g x) {-# INLINE _compose #-}@@ -19,19 +17,18 @@ {-@ 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. 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   } -{-@ axiomatize fmapRec1 @-}+{-@ 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)@@ -48,14 +45,15 @@                 -> (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)-  ==. Rec1 (_compose (fmapF f) (fmapF g) fp) ? fmapFCompose f 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+  === 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)
− tests/neg/T1078.hs 
@@ -1,8 +0,0 @@---- needed to bring `bslen` into scope--- import qualified Data.ByteString--import qualified Data.ByteString.Char8--example :: Char-example = Data.ByteString.Char8.head Data.ByteString.Char8.empty
+ tests/neg/T1095C.hs view
@@ -0,0 +1,15 @@+{-@ LIQUID "--no-case-expand" @-}+{-@ LIQUID "--no-termination" @-}++module Foo where++data Foo +  = A Foo +  | H +  | I+    +{-@ measure size @-}+{-@ size :: z:Foo -> {v:Nat | v > size z} @-}+size :: Foo -> Int +size (A x) = 1 + size x +size _     = 0 
− tests/neg/T1173.hs 
@@ -1,48 +0,0 @@-module ORM where--{-@ LIQUID "--no-adt" 	      @-}-{-@ LIQUID "--exact-data-con" @-}-{-@ LIQUID "--higherorder"    @-}-{-@ LIQUID "--ple"            @-}--import Prelude hiding (length, filter)---- OK-{-@ prop1 :: [Int] -> [{v:Int | v == 100}] @-}-prop1 :: [Int] -> [Int]-prop1 = filterQQ (QQ 10)---- FAILS-{-@ prop2 :: [Int] -> [{v:Int | v == 10}] @-}-prop2 :: [Int] -> [Int]-prop2 = filterQQ (mkQQ 10)--{-@ reflect mkQQ @-}-mkQQ :: Int -> QQ-mkQQ n = QQ n--{-@ filterQQ :: q:QQ -> [Int] -> [{v:Int | evalQQ q v}] @-}-filterQQ :: QQ -> [Int] -> [Int]-filterQQ q = filter (evalQQ q)-------------------------------------------------------------------------------------- | DB API-----------------------------------------------------------------------------------data QQ  = QQ Int--{-@ reflect evalQQ @-}-evalQQ :: QQ -> Int -> Bool-evalQQ (QQ x) y = x == y------------------------------------------------------------------------------------- | Generic List API-----------------------------------------------------------------------------------{-@ filter :: f:(a -> Bool) -> [a] -> [{v:a | f v}] @-}-filter :: (a -> Bool) -> [a] -> [a]-filter f (x:xs)-  | f x         = x : filter f xs-  | otherwise   =     filter f xs-filter _ []     = []
− tests/neg/T1192.hs 
@@ -1,24 +0,0 @@-{-@ LIQUID "--exact-data-con" @-}-{-@ LIQUID "--no-adt"         @-}-{-@ LIQUID "--ple"            @-}--module RangeSet where--import qualified Data.Set as S--import Language.Haskell.Liquid.NewProofCombinators--{-@ reflect sem_ij @-}-{-@ sem_ij :: i:Int -> j:Int -> S.Set Int / [j - i] @-}-sem_ij :: Int -> Int -> S.Set Int-sem_ij i j-  | i < j     = S.union (S.singleton i) (sem_ij (i+1) j)-  | otherwise = S.empty--{-@ lem_split :: f:_ -> x:{_ | f <= x} -> t:{_ | x < t} ->-                { sem_ij f t = S.union (sem_ij f x) (sem_ij x t) } / [ x - f]-  @-}-lem_split :: Int -> Int -> Int -> ()-lem_split f x t-  | f == x = ()-  | f <  x = ()
+ tests/neg/T1198.3.hs view
@@ -0,0 +1,9 @@+module Term where++{-@ data Tree [sz] @-}+data Tree a =  Bin | Node (Tree a) (Tree a)++{-@ measure sz @-}+sz :: Tree a -> Int+sz Bin = 0 +sz (Node t1 t2) = 1 + sz  (Node t1 t2) + sz  t2
+ tests/neg/T1267.hs view
@@ -0,0 +1,12 @@+{- LIQUID "--max-case-expand=0" @-}+{-@ LIQUID "--no-case-expand" @-}++module NoCaseExpand where++data ABC = A | B | C ++foo :: Int -> ABC -> ()+foo 0 A  =  ()+foo x A | x /= 0 = ()+foo _ A = error " " +foo _ t = ()
+ tests/neg/T1286.hs view
@@ -0,0 +1,7 @@+module Example where++{-@ fails :: {v:Bool | v} @-}+fails =  'a' == 'b'++{-@ ok :: {v:Bool | v} @-}+ok = "a" == "a"
+ tests/neg/T1288.hs view
@@ -0,0 +1,7 @@++{-@ measure foo @-}+foo :: () -> Int+foo _ = 10++{-@ blub :: {v:Int | v = 100} @-}+blub = foo ()
+ tests/neg/T1440.hs view
@@ -0,0 +1,11 @@+{-@ 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/T1498.hs view
@@ -0,0 +1,29 @@+module T1498 where++class FromTo a where +  from :: a -> Int +  to   :: Int -> a ++{-@ instance FromTo Int where +  from :: Int -> {v:Int | 0 <= v };+  to   :: {v:Int | 0 <= v } -> Int +@-}++instance FromTo Int where +  from x = x -- if 0 <= x then x else -x  +  to   x = x +++class A a where+  f :: a -> Int++instance A Int where+{-@+instance A Int where+  f :: Int -> {x : Int | 0 < x}+@-}+  f n = (-1)++{-@ g :: Int -> {n : Int | 0 < n} @-}+g :: Int -> Int+g x = f x
+ tests/neg/T1498A.hs view
@@ -0,0 +1,23 @@+module T1498 where++class FromTo a where +  from :: a -> Int +  to   :: Int -> a +++{-@ class FromTo a where +    from :: a -> {v:Int | 10 <= v } +    to   :: Int -> a  @-}+  ++{-@ instance FromTo Int where +  from :: Int -> {v:Int | 0 <= v };+  to   :: x:{Int | 0 <= x } -> {v:Int | v ==  x} +@-}++instance FromTo Int where +  from x = if 0 <= x then x else -x  +  to   x = x ++bar :: Int -> Int +bar x = bar x 
+ tests/neg/T1546.hs view
@@ -0,0 +1,21 @@+{-@ LIQUID "--reflection" @-}+{-@ LIQUID "--rankNTypes" @-}++{-# LANGUAGE RankNTypes          #-}++module T1546 where++import Language.Haskell.Liquid.Equational ++{-@ reflect first @-}+first :: (a -> b) -> (forall z. (a,z) -> (b,z))+first f (a, z) = (f a, z)++lemma :: (forall z. (a,z) -> (b,z)) -> (a,z) -> ()+{-@ lemma :: g:((a,z) -> (b,z)) -> x:(a,z) -> {v:() | g x == first (fOfG g) x } @-}+lemma g x+  =  g x ==. first (fOfG g) x *** QED++{-@ reflect fOfG @-}+fOfG :: (forall z. (a,z) -> (b,z)) -> a -> b+fOfG g x = case g (x, ()) of {(y,_) -> y}
tests/neg/T743-mini.hs view
@@ -1,10 +1,12 @@ module Bob (bar) where +{-@ bar :: Nat @-}+bar :: Int+bar = 2 - 10+ data Foo a = FooCon a data Dict = DictCon -{-@ foo :: {v:Foo Int | false} @-}-foo = undefined :: Foo Int  {-@ mkDict :: Foo Int -> Dict @-} mkDict :: Foo Int -> Dict@@ -16,7 +18,3 @@ {-@ readListPrecDefault :: Dict -> Foo Int @-} readListPrecDefault :: Dict -> Foo Int readListPrecDefault = undefined--{-@ bar :: Nat @-}-bar :: Int-bar = 2 - 10
− tests/neg/T745.hs 
@@ -1,6 +0,0 @@-{-@ LIQUID "--diff" @-}--module Foo where --foo :: () -> ()-foo () = foo ()
tests/neg/Variance1.hs view
@@ -1,9 +1,7 @@ import Data.Binary  -{-@-error :: { x : String | false } -> a-@-}+{-@ assume error :: { x : String | false } -> a @-}  example :: Get () example = do
− tests/neg/VerifiedMonoid.hs 
@@ -1,91 +0,0 @@-module Data.Monoid where--{-@ LIQUID "--higherorder" @-}-{-@ LIQUID "--exactdc" @-}-{-@ LIQUID "--totality" @-}--import Prelude hiding (Monoid (..))--import Language.Haskell.Liquid.ProofCombinators---class VerifiedMonoid a where-  mempty  :: a--  mappend :: a -> a -> a--  leftId  :: a -> Proof-  rightId :: a -> Proof-  assoc   :: a -> a -> a -> Proof--{-@ class VerifiedMonoid a where-    mempty  :: a-    mappend :: a -> a -> a-    leftId  :: x:a -> {v:Proof | mappend mempty x = x }-    rightId :: x:a -> {v:Proof | mappend x mempty = x }-    assoc   :: x:a -> y:a -> z:a -> {v:Proof | mappend x (mappend y z) = mappend (mappend x y) z}-  @-}---- TODO--- The above should change to explicitely reflect mappend and mempty.--- Then, each instance should generate the code at the end of this file.---{-@ data List a = N | C {hd :: a, tl :: List a} @-}-data List a = N | C a (List a)----instance VerifiedMonoid (List a) where-  mempty              = N-  mappend N ys        = ys-  mappend (C x xs) ys = C x (mappend xs ys)--  leftId  x           = mappend mempty x ==. mappend N x ==. x *** QED---  rightId N           = mappend N mempty ==. mappend N N ==. N *** QED-  rightId (C x xs)    = mappend (C x xs) mempty ==. C x (mappend xs N ) ==. C x xs ? rightId xs *** QED---  assoc N ys zs-    =   mappend N (mappend ys zs)-    ==. mappend ys zs-    ==. mappend (mappend N ys) zs-    *** QED-  assoc (C x xs) ys zs-    =   mappend (C x xs) (mappend ys zs)-    ==. C x (mappend xs (mappend ys zs))-    ==. C x (mappend (mappend xs ys) zs)-    ==. mappend (C x (mappend xs ys)) zs-    ==. mappend (mappend (C x xs) ys) zs-    *** QED------ || Below specs should be automatically generated by the reflect annotations--- || in the class definition---- | 1. One uninterpreted function per class method so that proof obligations type check--{-@ measure mappend :: a -> a -> a @-}-{-@ measure mempty  :: a @-}---- | 1. One uninterpreted function is generated for each reflected function---{-@ measure mappendList :: List a -> List a -> List a @-}-{-@ measure memptyList  :: List a @-}----- | 2. The reflected methods are reflected in the result type as assumed types,--- |    and the proof obligations are copied to the proof methods.--{-@ instance VerifiedMonoid (List a) where-  assume mempty  :: {v:List a | (v = N) && (v = memptyList) };-  assume mappend :: {v:(x:List a -> y:List a-                 -> {v:List a | (v = mappendList x y) && (if (is$Data.Monoid.N x) then (v == y) else (v == C (lqdc##select##C##1 x) (mappendList (lqdc##select##C##2 x) y) )) })  | v == mappendList};-  leftId  :: x:List a -> {v:Proof | mappendList memptyList x = x } ;-  rightId :: x:List a -> {v:Proof | mappendList x memptyList = x } ;-  assoc   :: x:List a -> y:List a -> z:List a -> {v:Proof | mappendList x (mappendList y z) = mappendList (mappendList x y) z}-  @-}
− tests/neg/bag.hs 
@@ -1,26 +0,0 @@-module BagTest where--import qualified Data.Set as S-import Language.Haskell.Liquid.Bag as B--{-@ zorg :: {v:B.Bag Int | v = B.empty} @-}-zorg :: B.Bag Int-zorg = B.empty--{-@ measure elems @-}-elems :: (Ord a) => [a] -> B.Bag a-elems []     = B.empty-elems (x:xs) = B.put x (elems xs)--{-@ prop0 :: x:_ -> TT @-}-prop0 :: Int -> Bool-prop0 x = (B.get x a == 3)-  where-    a   = elems [x, x, x + 1]--{-@ prop2 :: x:_ -> y:_ -> TT @-}-prop2 :: Int -> Int -> Bool-prop2 x y = (a == b)-  where-    a     = elems [x, y, x]-    b     = elems [y, x, x]
− tests/neg/deppair0.hs 
@@ -1,14 +0,0 @@-module Niki () where--import Language.Haskell.Liquid.Prelude--incr x = x + 1--baz x = (x, incr x)--prop :: Bool-prop = chk $ baz n-  where n = choose 100--chk (x, y) = liquidAssertB (x > y)-
− tests/neg/deptupW.hs 
@@ -1,23 +0,0 @@-module Deptup0 () where--import Language.Haskell.Liquid.Prelude--{-@ data Pair a b <p :: x0:a -> x1:b -> Bool> = P {pX :: a, pY :: b<p pX> } @-}-data Pair a b = P a b----- Names are shifty. I bet this would not work with alpha-renaming.-{-@ mkP :: forall a <p :: x0:a -> x1:a -> Bool>. x: a -> y: a<p x> -> Pair <p> a a @-}-mkP :: a -> a -> Pair a a-mkP x y = error "TBD"--incr :: Int -> Int-incr x = x - 1--baz x = mkP x (incr x)--chk :: Pair Int Int -> Bool-chk (P x y) = liquidAssertB (x < y)--prop = chk $ baz n-  where n = choose 100
tests/neg/errmsg.hs view
@@ -8,7 +8,7 @@    "Eq [Contravariant]" stuff. Can we remove it, or at least NOT show    it when running in --short-names mode. -} -{-@ foo :: (Eq a) => x:a -> xs:[a] -> {v:Bool | v <=> (Data.Set.member x (Data.Set.elems xs))} @-}+{-@ foo :: (Eq a) => x:a -> xs:[a] -> {v:Bool | v <=> (Data.Set.member x (Data.Set.fromList xs))} @-} foo          :: (Eq a) => a -> [a] -> Bool foo x (y:ys) = x == y || elem x ys foo _ []     = False
tests/neg/meas9.hs view
@@ -6,7 +6,7 @@ myid []     = [] myid (x:xs) = x : myid xs -{-@ myapp :: xs:[a] -> ys:[a] -> {v:[a] | listElts(v) = Set_cup(listElts(xs), listElts(xs))} @-}+{-@ myapp :: xs:[a] -> ys:[a] -> {v:[a] | listElts(v) = Set_cup (listElts xs) (listElts xs) } @-} myapp :: [a] -> [a] -> [a] myapp []     ys = ys myapp (x:xs) ys = x : myapp xs ys
tests/neg/mr00.hs view
@@ -1,7 +1,7 @@ module MapReduce () where  import Language.Haskell.Liquid.Prelude -import Data.Map hiding (filter, map, foldl, foldr)+import Data.Map hiding (filter, map, foldl)  baz (v:vs) _ = crash False  baz []     _ = crash False@@ -9,7 +9,7 @@ mymap = Data.Map.fromList [('a', [1])]  -- Why is this safe-coll = Data.Map.fold baz 0 +coll = Data.Map.foldr baz 0  prop_safe = coll mymap   -- Oddly, this is unsafe
− tests/neg/ple0.hs 
@@ -1,13 +0,0 @@-{- LIQUID "--higherorder"                         @-}-{- LIQUID "--automatic-instances=liquidinstances" @-}-{-@ LIQUID "--ple" @-}--module PLE where --{-@ reflect adder @-}-adder :: Int -> Int -> Int -adder x y = x + y ---{-@ prop :: { adder 5 6 == 12 } @-}-prop = ()
− tests/neg/pragma0-unsafe.hs 
@@ -1,8 +0,0 @@--- NO PRAGMA version of tests/pos/pragma0.hs--module Test0 where---- an obviously non-terminating function--zoo   :: Int -> Int-zoo x = zoo x
tests/neg/prune0.hs view
@@ -16,11 +16,11 @@ {-@ measure vsize :: forall a. a -> Int @-}  -- | Vector Type Aliases-{-@ type      OkIdx X     = {v:Nat | v < (vsize X)} @-}+{-@ type      OkIdx X     = {v:Nat | v < vsize X} @-}  -- | Assumed Types for Vector -{-@ unsafeRead  +{-@ assume unsafeRead         :: (PrimMonad m, MVector v a)        => xorp:(v (PrimState m) a)        -> (OkIdx xorp) 
− tests/neg/qsloop.hs 
@@ -1,9 +0,0 @@-module NonTermQuickSort where--quickSort []       = []-quickSort xs@(x:_) = lts ++  gts -  where -    lts          = quickSort [y | y <- xs, y < x]-    gts          = quickSort [z | z <- xs, z >= x]--
− tests/neg/testRec.hs 
@@ -1,28 +0,0 @@-module TestRec () where--import Prelude hiding (map, foldl)--data L a = N | C a (L a)--{-@ data L [llen] @-}--{-@ measure llen :: (L a) -> Int-    llen(N) = 0-    llen(C x xs) = 1 + (llen xs)-  @-}---{-@ map :: (a -> b) -> [a] -> [b]@-}-map f []     = []-map f (x:xs) = f x : map f (x:xs)- --- bar = map id []--{-@ decrease go 2 @-}-rev xs = go [] xs-  where go ack  []    = ack-        go ack (x:xs) = go (x:ack) xs---mapL f N = N-mapL f (C x xs) = C (f x) (mapL f xs)
− tests/neg/vector0.hs 
@@ -1,32 +0,0 @@-module Vec0 (x0, prop0, prop1, prop2, prop3) where--import Language.Haskell.Liquid.Prelude--import Data.Vector hiding (map, concat, zipWith, filter, foldr, foldl, (++))--xs :: [Int]-xs  = [1,2,3,4]--vs :: Vector Int-vs  = fromList xs--prop0 :: Bool-prop0 = liquidAssertB (x >= 0)-        where x = Prelude.head xs--prop1 :: Bool-prop1 = liquidAssertB (n > 0)-        where n = Prelude.length xs--prop2 :: Bool-prop2 = liquidAssertB (Data.Vector.length vs > 0)--prop3 :: Bool-prop3 = liquidAssertB (Data.Vector.length vs > 3)--x0    :: [ Int ]-x0    = [ vs ! 0-        , vs ! 1-        , vs ! 2-        , vs ! 3-        , vs ! 4 ]
tests/neg/vector1a.hs view
@@ -9,7 +9,7 @@  for :: Int -> Int -> a -> (Int -> a -> a) -> a for lo hi acc f -  | lo < hi   = for (lo + 1) hi (f lo acc) f+  | lo <= hi   = for (lo + 1) hi (f lo acc) f   | otherwise = acc   dotProd       :: Vector Int -> Vector Int -> Int
− tests/pos/ANF.hs 
@@ -1,125 +0,0 @@-{-@ LIQUID "--no-termination"    @-}--module ANF (Op (..), Expr (..), isImm, isAnf, anf) where--import Control.Monad.Trans.State.Lazy--mkLet :: [(Var, AnfExpr)] -> AnfExpr -> AnfExpr-imm, immExpr :: Expr -> AnfM ([(Var, AnfExpr)], ImmExpr)-anf   :: Expr -> AnfM AnfExpr-fresh :: AnfM Var------------------------------------------------------------------------------------- | Types----------------------------------------------------------------------------------type Var = String--data Op-  = Plus-  | Minus--data Expr-  = EInt  Int-  | EVar  Var-  | ELet  Var  Expr Expr-  | EBin  Op   Expr Expr-  | ELam  Var  Expr-  | EApp  Expr Expr------------------------------------------------------------------------------------- | Defining Immediate Values and ANF----------------------------------------------------------------------------------{-@ measure isImm @-}-isImm :: Expr -> Bool-isImm (EInt {}) = True-isImm (EVar {}) = True-isImm _         = False---- isImm (ELet {}) = False--- isImm (EBin {}) = False--- isImm (ELam {}) = False--- isImm (EApp {}) = False--{-@ measure isAnf @-}-isAnf :: Expr -> Bool-isAnf (EInt {})      = True-isAnf (EVar {})      = True-isAnf (ELet _ e1 e2) = isAnf e1 && isAnf e2-isAnf (EBin _ e1 e2) = isImm e1 && isImm e2-isAnf (EApp e1 e2)   = isImm e1 && isImm e2-isAnf (ELam _ e)     = isAnf e--{-@ type AnfExpr = {v:Expr | isAnf v} @-}-type AnfExpr = Expr--{-@ type ImmExpr = {v:Expr | isImm v} @-}-type ImmExpr = Expr------------------------------------------------------------------------------------- | A Monad to get Fresh names----------------------------------------------------------------------------------type AnfM a = State Int a-----------------------------------------------------------------------------------{-@ anf :: Expr -> AnfM AnfExpr @-}----------------------------------------------------------------------------------anf (EInt n) =-  return (EInt n)--anf (EVar x) =-  return (EVar x)--anf (ELet x e1 e2) = do-  a1 <- anf e1-  a2 <- anf e2-  return (ELet x a1 a2)--anf (EBin o e1 e2) = do-  (b1s, v1) <- imm e1-  (b2s, v2) <- imm e2-  return (mkLet (b1s ++ b2s) (EBin o v1 v2))--anf (ELam x e) = do-  a <- anf e-  return (ELam x a)--anf (EApp e1 e2) = do-  (b1s, v1) <- imm e1-  (b2s, v2) <- imm e2-  return (mkLet (b1s ++ b2s) (EApp v1 v2))--{-@ mkLet :: [(Var, AnfExpr)] -> AnfExpr -> AnfExpr @-}-mkLet []         e' = e'-mkLet ((x,e):bs) e' = ELet x e (mkLet bs e')-----------------------------------------------------------------------------------{-@ imm :: Expr -> AnfM ([(Var, AnfExpr)], ImmExpr) @-}----------------------------------------------------------------------------------imm (EInt n)       = return ([], EInt n)-imm (EVar x)       = return ([], EVar x)-imm e@(ELet {})    = immExpr e-imm e@(ELam {})    = immExpr e-imm (EBin o e1 e2) = imm2 e1 e2 (EBin o)-imm (EApp e1 e2)   = imm2 e1 e2 EApp--{-@ immExpr :: Expr -> AnfM ([(Var, AnfExpr)], ImmExpr) @-}-immExpr e = do-  a <- anf e-  t <- fresh-  return ([(t, a)], EVar t)--imm2 :: Expr -> Expr -> (ImmExpr -> ImmExpr -> AnfExpr) -> AnfM ([(Var, AnfExpr)], ImmExpr)-imm2 e1 e2 f = do-  (b1s, v1) <- imm e1-  (b2s, v2) <- imm e2-  t         <- fresh-  let bs'    = b1s ++ b2s ++ [(t, f v1 v2)]-  return      (bs', EVar t)-----------------------------------------------------------------------------------{-@ fresh :: AnfM Var @-}----------------------------------------------------------------------------------fresh = do-  n <- get-  put (n+1)-  return ("tmp" ++ show n)
tests/pos/Abs.hs view
@@ -6,6 +6,9 @@ absI ::  Int -> Int absI x = if x > 0 then x else (-x) +absL :: [Int] -> [Int]+absL xs = (0 : xs) ++ [] + --incI ::  Int -> Int --incI = (+) 1 
tests/pos/AdtList2.hs view
@@ -1,16 +1,13 @@-{-@ LIQUID "--higherorder"                         @-}-{-@ LIQUID "--automatic-instances=liquidinstances" @-}+{-@ LIQUID "--reflection" @-}+{-@ LIQUID "--ple"        @-}  module AdtList where   data LL a = Emp | Cons a (LL a)  -{-@ LIQUID "--exact-data-cons" @-}- {-@ test1 :: n:Int -> m:Int -> {v:() | Cons n (Cons m Emp) == Cons m (Cons n Emp)} -> {n == m} @-} test1 :: Int -> Int -> () -> () test1 _ _ _ = ()-  {-@ reflect sz @-} sz :: LL a -> Int 
− tests/pos/AdtPeano2.hs 
@@ -1,10 +0,0 @@-{-@ LIQUID "--exact-data-con"                      @-}-{-@ LIQUID "--higherorder"                         @-}--module Peano where--data Influx = Silly { goo :: Int }--{-@ test:: n:Int -> m:Int -> { v:() | Silly n == Silly m } -> { n == m } @-}-test :: Int -> Int -> () -> ()-test n m z = ()
tests/pos/Automate.hs view
@@ -1,14 +1,12 @@ module Automate where--{- LIQUID "--automatic-instances=smtinstances" @-}    -{-@ LIQUID "--automatic-instances=liquidinstances" @-}+{-@ LIQUID "--reflection" @-}+{-@ LIQUID "--ple"        @-}  import Language.Haskell.Liquid.ProofCombinators  - fibA :: Int -> Int -{-@ axiomatize fibA @-}+{-@ reflect fibA @-} {-@ fibA :: Nat -> Nat @-} fibA i | i <= 1 = i       | otherwise = fibA (i-1) + fibA (i-2)
tests/pos/BST.hs view
@@ -1,6 +1,6 @@ {-@ LIQUID "--no-totality" @-} -module BST () where+module BST (blen) where  import Language.Haskell.Liquid.Prelude @@ -15,12 +15,11 @@   -{-@ measure blen :: (Bst k v) -> Int-    blen(Empty)        = 0-    blen(Bind k v l r) = 1 + (blen l) + (blen r)-  @-}--{-@ invariant {v:Bst k v | (blen v) >= 0} @-}+{-@ measure blen @-}+blen :: (Bst k v) -> Int+{-@ blen :: (Bst k v) -> Nat @-}+blen(Empty)        = 0+blen(Bind k v l r) = 1 + (blen l) + (blen r)  data Bst k v = Empty | Bind k v (Bst k v) (Bst k v) 
− tests/pos/BinahQuery.hs 
@@ -1,126 +0,0 @@-{-@ LIQUID "--no-adt" 	                           @-}-{-@ LIQUID "--exact-data-con"                      @-}-{-@ LIQUID "--higherorder"                         @-}-{-@ LIQUID "--no-termination"                      @-}-{-@ LIQUID "--ple" @-} --{-@ infixr === @-}-{-@ infixr >== @-}-{-@ infixr <== @-}--{-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-}--module Query where--import Prelude hiding (filter)--data PersistFilter = EQUAL | LE | GE--class PersistEntity record where-    data EntityField record :: * -> *--{-@ data Filter record typ = Filter { filterField :: EntityField record typ, filterValue :: typ, filterFilter :: PersistFilter } @-}-data Filter record typ = Filter-    { filterField  :: EntityField record typ-    , filterValue  :: typ-    , filterFilter :: PersistFilter-    } ---{-@ reflect === @-}-(===) :: (PersistEntity record, Eq typ) => -                 EntityField record typ -> typ -> Filter record typ-field === value = Filter field value EQUAL--{-@ reflect <== @-}-(<==) :: (PersistEntity record, Eq typ) => -                 EntityField record typ -> typ -> Filter record typ-field <== value =-  Filter {-    filterField = field-  , filterValue = value-  , filterFilter = LE -  }--{-@ reflect >== @-}-(>==) :: (PersistEntity record, Eq typ) => -                 EntityField record typ -> typ -> Filter record typ-field >== value =-  Filter {-    filterField = field-  , filterValue = value-  , filterFilter = GE -  }--{-@ data Blob  = B { xVal :: Int, yVal :: Int } @-}-data Blob  = B { xVal :: Int, yVal :: Int }--instance PersistEntity Blob where-    {- data EntityField Blob typ where-        BlobXVal :: EntityField Blob Int-      | BlobYVal :: EntityField Blob Int-    -}-    data EntityField Blob typ where-        BlobXVal :: EntityField Blob Int-        BlobYVal :: EntityField Blob Int--{-@ filter :: f:(a -> Bool) -> [a] -> [{v:a | f v}] @-}-filter :: (a -> Bool) -> [a] -> [a]-filter f (x:xs)-  | f x         = x : filter f xs-  | otherwise   =     filter f xs-filter _ []     = []--{-@ reflect evalQBlobXVal @-}-evalQBlobXVal :: PersistFilter -> Int -> Int -> Bool-evalQBlobXVal EQUAL filter given = filter == given-evalQBlobXVal LE filter given = given <= filter-evalQBlobXVal GE filter given = given >= filter--{-@ reflect evalQBlobYVal @-}-evalQBlobYVal :: PersistFilter -> Int -> Int -> Bool-evalQBlobYVal EQUAL filter given = filter == given-evalQBlobYVal LE filter given = given <= filter-evalQBlobYVal GE filter given = given >= filter--{-@ reflect evalQBlob @-}-evalQBlob :: Filter Blob typ -> Blob -> Bool-evalQBlob filter blob = case filterField filter of-    BlobXVal -> evalQBlobXVal (filterFilter filter) (filterValue filter) (xVal blob)-    BlobYVal -> evalQBlobYVal (filterFilter filter) (filterValue filter) (yVal blob)--{-@ reflect evalQsBlob @-}-evalQsBlob :: [Filter Blob typ] -> Blob -> Bool-evalQsBlob (f:fs) blob = evalQBlob f blob && (evalQsBlob fs blob)-evalQsBlob [] _ = True---{-@ filterQBlob :: f:(Filter Blob a) -> [Blob] -> [{b:Blob | evalQBlob f b}] @-}-filterQBlob :: Filter Blob a -> [Blob] -> [Blob]-filterQBlob q = filter (evalQBlob q)--{-@ filterQsBlob :: f:[(Filter Blob a)] -> [Blob] -> [{b:Blob | evalQsBlob f b}] @-}-filterQsBlob :: [Filter Blob a] -> [Blob] -> [Blob]-filterQsBlob qs = filter (evalQsBlob qs)---- select functions--{-@ assume selectBlob :: f:[(Filter Blob a)] -> [{b:Blob | evalQsBlob f b}] @-}-selectBlob :: [Filter Blob a] -> [Blob]-selectBlob fs = undefined --{-@ getZeros_ :: () -> [{b:Blob | xVal b = 0}] @-}-getZeros_ :: () -> [Blob]-getZeros_ () = selectBlob [(Filter BlobXVal 0 EQUAL)]--{-@ getBiggerThan10 :: () -> [{b:Blob | xVal b >= 10}] @-}-getBiggerThan10 :: () -> [Blob]-getBiggerThan10 () = selectBlob [(Filter BlobXVal 11 GE)]--{-@ getInRange :: () -> [{b:Blob | xVal b >= 10  && xVal b <= 20 && yVal b >= 0 && yVal b <= 11}] @-}-getInRange :: () -> [Blob]-getInRange () = selectBlob [ (BlobXVal >== 10)-                           , (BlobXVal <== 20)-                           , (BlobYVal >== 0)-                           , (BlobYVal <== 11)-                           ]
− tests/pos/BinahUpdate.hs 
@@ -1,40 +0,0 @@-{-@ LIQUID "--no-adt" 	                           @-}-{-@ LIQUID "--exact-data-con"                      @-}-{-@ LIQUID "--higherorder"                         @-}-{-@ LIQUID "--no-termination"                      @-}-{-@ LIQUID "--ple" @-} --{-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-}--class PersistEntity record where-    data EntityField record :: * -> *--instance PersistEntity Blob where-    {- data EntityField Blob typ where-        BlobXVal :: EntityField Blob {v:Int | v >= 0}-      | BlobYVal :: EntityField Blob Int-      @-}-    data EntityField Blob typ where-        BlobXVal :: EntityField Blob Int-        BlobYVal :: EntityField Blob Int--{-@ data Blob  = B { xVal :: {v:Int | v >= 0}, yVal :: Int } @-}-data Blob  = B { xVal :: Int, yVal :: Int }--{-@ data Update record typ = Update { updateField :: EntityField record typ, updateValue :: typ } @-}-data Update record typ = Update -    { updateField :: EntityField record typ-    , updateValue :: typ-    } --{-@ data variance Update covariant covariant contravariant @-}--{-@ createUpdate :: EntityField record a -> a -> Update record a @-}-createUpdate :: EntityField record a -> a -> Update record a-createUpdate field value = Update {-      updateField = field-    , updateValue = value-}--testUpdateQuery :: () -> Update Blob Int-testUpdateQuery () = createUpdate BlobXVal 3
tests/pos/BinarySearch.hs view
@@ -4,13 +4,13 @@  module BinarySearch (binarySearch) where -import Data.Vector as Vector+import Data.Vector as V -binarySearch :: Ord a => a -> Vector a -> Maybe Int+binarySearch :: Ord a => a -> V.Vector a -> Maybe Int binarySearch x v =-    if Vector.length v == 0+    if V.length v == 0     then Nothing-    else loop x v 0 (Vector.length v - 1)+    else loop x v 0 (V.length v - 1)  midpoint :: Int -> Int -> Int midpoint lo hi = (lo + hi) `div` 2@@ -19,13 +19,13 @@ loop     :: Ord a     => x  : a-    -> v  : Vector a+    -> v  : V.Vector a     -> lo : { lo : Int | 0  <= lo && lo < vlen v }     -> hi : { hi : Int | lo <= hi && hi < vlen v }     -> Maybe Int     / [hi - lo] @-}-loop :: Ord a => a -> Vector a -> Int -> Int -> Maybe Int+loop :: Ord a => a -> V.Vector a -> Int -> Int -> Maybe Int loop x v lo hi = do     let mid = lo + ((hi - lo) `div` 2) -- midpoint lo hi     if x < v ! mid
tests/pos/BinarySearchOverflow.hs view
@@ -4,23 +4,23 @@  import Prelude hiding (Num(..)) import CheckedNum -import Data.Vector as Vector+import Data.Vector as V  import Language.Haskell.Liquid.Prelude (liquidAssert)  -{-@ invariant {v:Vector a | 0 <= vlen v && BoundInt (vlen v)} @-}+{-@ invariant {v: V.Vector a | 0 <= vlen v && BoundInt (vlen v)} @-} -binarySearch :: Ord a => a -> Vector a -> Maybe Int+binarySearch :: Ord a => a -> V.Vector a -> Maybe Int binarySearch x v    | 0 < n     = loop x v 0 (n - 1)   | otherwise = Nothing -  where n     = Vector.length v+  where n     = V.length v  {-@ type Idx Vec = {v:Nat | v < vlen Vec} @-}  {-@ type BoundNat = {v:Nat | BoundInt v} @-} -{-@ loop :: Ord a => a -> vec:Vector a -> lo:Idx vec -> {hi:Idx vec | lo <= hi} -> Maybe Nat @-}-loop :: Ord a => a -> Vector a -> Int -> Int -> Maybe Int+{-@ loop :: Ord a => a -> vec: V.Vector a -> lo:Idx vec -> {hi:Idx vec | lo <= hi} -> Maybe Nat @-}+loop :: Ord a => a -> V.Vector a -> Int -> Int -> Maybe Int loop x v lo hi = do     let mid = lo + ((hi - lo) `div` 2) -- SAFE     -- let mid =  (hi + lo) `div` 2       -- UNSAFE
+ tests/pos/CharLiterals.hs view
@@ -0,0 +1,8 @@+-- see #1286 +module Example where++{-@ fails :: {v:Bool | v} @-}+fails =  'a' == 'a'++{-@ ok :: {v:Bool | v} @-}+ok = "a" == "a"
tests/pos/ClojurVector.hs view
@@ -7,7 +7,7 @@  module PVec (height, arrayFor) where -import Language.Haskell.Liquid.Prelude (liquidAssume)+import qualified Language.Haskell.Liquid.Prelude as Gas import qualified Data.Vector as V  import Data.Bits@@ -23,6 +23,7 @@ -- | Specify "height" of a tree  {-@ measure height @-}+{-@ height :: Tree a -> Nat @-} height :: Tree a -> Int height (Leaf _)    = 0 height (Node h ls) = 1 + h@@ -43,10 +44,6 @@  {-@ type TreeH     a H = {v:Tree a | height v = H}       @-} --- | Specify tree height is non-negative--{-@ using (Tree a) as  {v:Tree a   | 0 <= height v} @-}- -- | Nodes and Leaves are simply trees with non-zero and zero heights resp.  {-@ type NodeT a = {v:Tree a | height v > 0} @-}@@ -70,25 +67,24 @@ --------------------------------------------------------------------------------  arrayFor :: Int -> Vec a -> Maybe a-arrayFor i (Vec l n) = loop l n-  where+arrayFor i (Vec l n) = loop i l n -    {-@ loop :: level:Int -> TreeLevel a level -> Maybe a @-}-    loop :: Int -> Tree a -> Maybe a-    loop level node+{-@ loop :: i:Int -> level:Int -> TreeLevel a level -> Maybe a @-}+loop :: Int -> Int -> Tree a -> Maybe a+loop i level node       | level > 0 = let b      = shift i (- level) `mask` 31  -- get child index                         node'  = getNode node b               -- get child                         level' = level - 5                    -- next level                     in-                        loop level' node'+                        loop i level' node'        | otherwise = Just (getValue node)  -- TODO: refine types of bit-ops, currently use an "assume" -{-@ mask :: x:Int -> y:Nat -> {v:Nat | v <= y}@-}+{-@ mask :: x:Int -> y:Nat -> {v:Nat | v <= y} @-} mask :: Int -> Int -> Int-mask x y = liquidAssume (0 <= r && r <= y) r+mask x y = Gas.liquidAssume (0 <= r && r <= y) r   where      r   = x .&. y 
− tests/pos/Compiler.hs 
@@ -1,108 +0,0 @@-{-@ LIQUID "--exact-data-con" @-}-{-@ LIQUID "--higherorder"    @-}-{-@ LIQUID "--ple"            @-} -{-@ LIQUID "--no-totality"    @-} --module Compiler where--import Language.Haskell.Liquid.ProofCombinators---- | Expressions -----------------------------------------------------------------{-@ data Expr [eSize] @-}-data Expr-  = Val Int-  | Add Expr Expr--{-@ measure eSize @-}-{-@ eSize :: Expr -> {v:Int | 1 <= v} @-}-eSize :: Expr -> Int-eSize (Val n)     = 1-eSize (Add e1 e2) = 1 + eSize e1 + eSize e2--{-@ invariant {v:Expr | 1 <= eSize v } @-}---- | Interpreter -----------------------------------------------------------------{-@ reflect interp @-}-interp :: Expr -> Int-interp (Val n)     = n-interp (Add e1 e2) = interp e1 + interp e2---- | Code ------------------------------------------------------------------------{-@ data Code [cSize] @-}-data Code-  = HALT-  | PUSH Int Code-  | ADD      Code--{-@ measure cSize @-}-{-@ cSize :: Code -> Nat @-}-cSize :: Code -> Int-cSize HALT       = 0-cSize (PUSH n c) = 1 + cSize c-cSize (ADD    c) = 1 + cSize c---- | Stack ----------------------------------------------------------------------data Stack-  = Emp-  | Arg Int Stack---- | Compiler --------------------------------------------------------------------{-@ reflect compileC @-}-compileC :: Expr -> Code -> Code-compileC (Val n) c     = PUSH n c-compileC (Add e1 e2) c = compileC e2 (compileC e1 (ADD c))--{-@ reflect compile @-}-compile :: Expr -> Code-compile e = compileC e HALT---- | VM --------------------------------------------------------------------------{-@ reflect run @-}-run :: Code -> Stack -> Int-run HALT       (Arg n s)         = n-run (ADD c)    (Arg n (Arg m s)) = run c (Arg (n + m) s)-run (PUSH n c) s                 = run c (Arg n       s)--{-@ reflect compileAndRun @-}-compileAndRun :: Expr -> Int-compileAndRun e = run (compileC e HALT) Emp---- | Correctness -----------------------------------------------------------------{-@ thmCompileC :: e:Expr -> c:Code -> s:Stack ->-      { run (compileC e c) s = run c (Arg (interp e) s) }-  @-}-thmCompileC :: Expr -> Code -> Stack -> Proof-thmCompileC (Val n)     c s =  () -thmCompileC (Add e1 e2) c s =  thmCompileC e2 (compileC e1  (ADD c)) s-                           &&& thmCompileC e1 (ADD c) (Arg (interp e2) s)--{-@ thmCompileAndRun :: e:Expr -> { compileAndRun e == interp e } @-}-thmCompileAndRun :: Expr -> Proof-thmCompileAndRun e = thmCompileC e HALT Emp---{- thmCompileC (Add e1 e2) c s-   = [ -- run (compileC (Add e1 e2) c) s-      -- ==. run (compileC e2 (compileC e1 (ADD c))) s-      {- ? -} thmCompileC e2 (compileC e1  (ADD c)) s-      -- ==. run (compileC e1 (ADD c)) (Arg (interp e2) s)-    , {- ? -} thmCompileC e1 (ADD c) (Arg (interp e2) s)-      -- ==. run (ADD c) (Arg (interp e1) (Arg (interp e2) s))-      -- ==. run c (Arg (interp e1 + interp e2) s)-      -- ==. run c (Arg (interp (Add e1 e2)) s)-    ] *** QED- -}-----------
tests/pos/CountMonad.hs view
@@ -1,4 +1,3 @@- {-@ LIQUID "--no-pattern-inline" @-}  module Count () where@@ -6,71 +5,82 @@ {-@ measure count :: Count a -> Int @-}  {-@ Count :: x:a -> {v:Count a | v == Count x } @-}-data Count a = Count a +data Count a = Count a  instance Functor Count where-	fmap = undefined +	fmap = undefined instance Applicative Count where   pure  = undefined-  (<*>) = undefined	+  (<*>) = undefined  instance Monad Count where {-@-instance Monad Count where +instance Monad Count where   >>=    :: forall <r :: Count a -> Bool, p :: Count b -> Bool, q :: Count b -> Bool>.-            {x::Count a <<r>>, y :: Count b <<p>>  |- {v:Count b | count v == count x + count y} <: Count b <<q>>} -            Count a <<r>> -> (a -> Count b<<p>>) -> Count b <<q>> ; -  >>     :: x:Count a -> y:Count b -> {v:Count b | count v == count x + count y}; -  return :: a -> {v:Count a | count v == 0 } +            {x::Count a <<r>>, y :: Count b <<p>>  |- {v:Count b | count v == count x + count y} <: Count b <<q>>}+            Count a <<r>> -> (a -> Count b<<p>>) -> Count b <<q>> ;+  >>     :: x:Count a -> y:Count b -> {v:Count b | count v == count x + count y};+  return :: a -> {v:Count a | count v == 0 } @-}-  return x        = let r = Count x in assertCount 0 (Count x)  -  (Count x) >>= f = let r = f x in assertCount (getCount (Count x) + getCount r) r +  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    {-@ assume assertCount :: i:Int -> x:Count a -> {v:Count a | v == x && count v == i } @-}-assertCount :: Int -> Count a -> Count a -assertCount _ x = x +assertCount :: Int -> Count a -> Count a+assertCount _ x = x -{-@ assume getCount :: x:Count a -> {v:Int | v == count x } @-} -getCount :: Count a -> Int -getCount _ = 0 +{-@ assume getCount :: x:Count a -> {v:Int | v == count x } @-}+getCount :: Count a -> Int+getCount _ = 0  {-@ makeCount :: x:a -> {v:Count a | v == Count x} @-} makeCount = Count  {-@ assume incr :: a -> {v:Count a | count v == 1 } @-}-incr :: a -> Count a -incr = Count +incr :: a -> Count a+incr = Count  {-@ assume unit :: {v:Count () | count v == 0 } @-} unit = Count ()  {-@ foo :: a -> {v:Count a | count v == 0 }  @-}-foo :: a -> Count a -foo y = return y  +foo :: a -> Count a+foo y = return y  {-@ test1 :: {v:Count () | count v == 0 } @-} test1 :: Count ()-test1 = do +test1 = do   unit   unit   unit  {-@ test2 :: {v:Count () | count v == 1 } @-}-test2 = do +test2 = do   unit   y <- incr ()   unit-  foo y  +  foo y   unit -{-@ test3 :: {v:Count () | count v == 2 } @-}-test3 = do +{-@ test3 :: {v:Count () | count v == 3 } @-}+test3 = do   unit+  incr ()   unit   incr ()+  unit   incr ()   unit++++{-@ replicateTick :: n:Nat -> a -> {v:Count [a] | count v == n} @-}+replicateTick :: Int -> a -> Count [a]+replicateTick 0 x = return []+replicateTick n x = do incr ()+                       xs <- replicateTick (n-1) x+                       return ( x : xs )
− tests/pos/DataKinds.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE DataKinds #-}--module ProxyClass where--import           Data.Proxy---{-@ sizeOfMember :: Proxy a -> Nat @-}-sizeOfMember :: Proxy a -> Int-sizeOfMember = undefined 
tests/pos/DepData.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE GADTs #-} -{-@ LIQUID "--no-measure" @-}- module DepData where  data Foo = Foo { thing1 :: Int, thing2 :: Int }
+ tests/pos/Deptup1.pred view
@@ -0,0 +1,1 @@+assumep mkPair :: forall a b. forAll p:b(fld:a). a -> b -> Pair a b <<p>>
tests/pos/EvalQuery.hs view
file too large to diff
− tests/pos/ExactFunApp.hs 
file too large to diff
− tests/pos/ExactGADT4.hs 
file too large to diff
− tests/pos/ExactGADT5.hs 
file too large to diff
− tests/pos/ExactGADT7.hs 
file too large to diff
tests/pos/Fib0.hs view
file too large to diff
tests/pos/FibEq.hs view
file too large to diff
+ tests/pos/FingerTree.hs view
file too large to diff
tests/pos/Foo.hs view
file too large to diff
tests/pos/GeneralizedTermination.hs view
file too large to diff
− tests/pos/GhcListSort.hs 
file too large to diff
tests/pos/GhcSort1.hs view
file too large to diff
tests/pos/GhcSort2.hs view
file too large to diff
+ tests/pos/GhcSort3.T.hs view
file too large to diff
− tests/pos/Goo.hs 
file too large to diff
tests/pos/HasElem.hs view
file too large to diff
tests/pos/HaskellMeasure.hs view
file too large to diff
tests/pos/HedgeUnion.hs view
file too large to diff
+ tests/pos/Hole00.hs view
file too large to diff
tests/pos/Holes-Slicing.hs view
file too large to diff
tests/pos/Hutton.hs view
file too large to diff
tests/pos/IcfpDemo.hs view
file too large to diff
+ tests/pos/Ignores.hs view
file too large to diff
− tests/pos/IndEven.hs 
file too large to diff
− tests/pos/IndPerm.hs 
file too large to diff
− tests/pos/IndStar.hs 
file too large to diff
− tests/pos/Invariants.hs 
file too large to diff
tests/pos/LambdaEval.hs view
file too large to diff
tests/pos/LambdaEvalMini.hs view
file too large to diff
tests/pos/LambdaEvalSuperTiny.hs view
file too large to diff
tests/pos/LambdaEvalTiny.hs view
file too large to diff
− tests/pos/LiquidArray.hs 
file too large to diff
− tests/pos/LiquidClass.hs 
file too large to diff
− tests/pos/ListISort-LType.hs 
file too large to diff
tests/pos/ListISort-perm.hs view
file too large to diff
− tests/pos/ListISort.hs 
file too large to diff
tests/pos/ListKeys.hs view
file too large to diff
tests/pos/ListLen-LType.hs view
file too large to diff
tests/pos/ListQSort-LType.hs view
file too large to diff
− tests/pos/ListQSort.hs 
file too large to diff
tests/pos/ListRange-LType.hs view
file too large to diff
tests/pos/ListReverse-LType.hs view
file too large to diff
tests/pos/ListSort.hs view
file too large to diff
tests/pos/LocalSpec.hs view
file too large to diff
− tests/pos/LocalSpec0.hs 
file too large to diff
− tests/pos/LocalSpecImp.hs 
file too large to diff
+ tests/pos/LocalSpecLib.hs view
file too large to diff
− tests/pos/LocalTermExpr.hs 
file too large to diff
tests/pos/Loo.hs view
file too large to diff
+ tests/pos/LooLib.hs view
file too large to diff
+ tests/pos/LooLibLib.hs view
file too large to diff
tests/pos/Map.hs view
file too large to diff
tests/pos/Map0.hs view
file too large to diff
tests/pos/Map2.hs view
file too large to diff
tests/pos/MapFusion.hs view
file too large to diff
tests/pos/MapReduceVerified.hs view
file too large to diff
tests/pos/MaskError.hs view
file too large to diff
tests/pos/MeasureContains.hs view
file too large to diff
+ tests/pos/Mod.hs view
file too large to diff
− tests/pos/Mod1.hs 
file too large to diff
− tests/pos/Mod2.hs 
file too large to diff
+ tests/pos/ModLib.hs view
file too large to diff
− tests/pos/Moo.hs 
file too large to diff
− tests/pos/MultipleInvariants.hs 
file too large to diff
tests/pos/MutualRec.hs view
file too large to diff
+ tests/pos/MutuallyDependentADT.hs view
file too large to diff
− tests/pos/NatClass.hs 
file too large to diff
− tests/pos/NewType.hs 
file too large to diff
tests/pos/NoCaseExpand.hs view
file too large to diff
tests/pos/ORM.hs view
file too large to diff
tests/pos/OrdList.hs view
file too large to diff
− tests/pos/Overwrite.hs 
file too large to diff
tests/pos/PairMeasure.hs view
file too large to diff
tests/pos/PersistentVector.hs view
file too large to diff
− tests/pos/PlugHoles.hs 
file too large to diff
tests/pos/PromotedDataCons.hs view
file too large to diff
tests/pos/RealProps.hs view
file too large to diff
− tests/pos/RealProps1.hs 
file too large to diff
tests/pos/RecQSort.hs view
file too large to diff
− tests/pos/RecordAccessors.hs 
file too large to diff
tests/pos/RecordSelectorError.hs view
file too large to diff
tests/pos/RefinedADTs.hs view
file too large to diff
tests/pos/ResolvePred.hs view
file too large to diff
tests/pos/SafePartialFunctions.hs view
file too large to diff
+ tests/pos/SingletonLists.hs view
file too large to diff
tests/pos/Solver.hs view
file too large to diff
tests/pos/State.hs view
file too large to diff
− tests/pos/State1.hs 
file too large to diff
tests/pos/StateConstraints0.hs view
file too large to diff
tests/pos/StateF00.hs view
file too large to diff
+ tests/pos/StateLib.hs view
file too large to diff
− tests/pos/StreamInvariants.hs 
file too large to diff
tests/pos/T1013.hs view
file too large to diff
tests/pos/T1025.hs view
file too large to diff
tests/pos/T1025a.hs view
file too large to diff
+ tests/pos/T1045.hs-boot view
file too large to diff
tests/pos/T1060.hs view
file too large to diff
− tests/pos/T1089b.hs 
file too large to diff
+ tests/pos/T1095A.hs view
file too large to diff
+ tests/pos/T1095B.hs view
file too large to diff
+ tests/pos/T1095C.hs view
file too large to diff
tests/pos/T1120A.hs view
file too large to diff
− tests/pos/T1146.hs 
file too large to diff
− tests/pos/T1173.hs 
file too large to diff
− tests/pos/T1190.hs 
file too large to diff
+ tests/pos/T1198.1.hs view
file too large to diff
+ tests/pos/T1198.2.hs view
file too large to diff
+ tests/pos/T1198.3.hs view
file too large to diff
+ tests/pos/T1198.4.hs view
file too large to diff
tests/pos/T1223.hs view
file too large to diff
+ tests/pos/T1267.hs view
file too large to diff
+ tests/pos/T1278.2.hs view
file too large to diff
+ tests/pos/T1278.3.hs view
file too large to diff
+ tests/pos/T1278.hs view
file too large to diff
+ tests/pos/T1286.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/T1302.hs view
file too large to diff
+ tests/pos/T1336.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/T1543.hs view
file too large to diff
+ tests/pos/T1544.hs view
file too large to diff
tests/pos/T385.hs view
file too large to diff
tests/pos/T595.hs view
file too large to diff
− tests/pos/T675.hs 
file too large to diff
tests/pos/T716.hs view
file too large to diff
tests/pos/T819.hs view
file too large to diff
tests/pos/T819A.hs view
file too large to diff
− tests/pos/TemplateHaskell.hs 
file too large to diff
− tests/pos/TemplateHaskellImp.hs 
file too large to diff
+ tests/pos/Termination.hs view
file too large to diff
tests/pos/TypeLitNat.hs view
file too large to diff
− tests/pos/VerifiedMonoid.hs 
file too large to diff
− tests/pos/bag.hs 
file too large to diff
− tests/pos/contra0.hs 
file too large to diff
tests/pos/coretologic.hs view
file too large to diff
tests/pos/data2.hs view
file too large to diff
tests/pos/datacon0.hs view
file too large to diff
− tests/pos/deppair0.hs 
file too large to diff
− tests/pos/deppair1.hs 
file too large to diff
− tests/pos/deptup0.hs 
file too large to diff
tests/pos/dropwhile.hs view
file too large to diff
tests/pos/elim-ex-compose.hs view
file too large to diff
tests/pos/ex0.hs view
file too large to diff
tests/pos/ex1.hs view
file too large to diff
− tests/pos/filterPLE.hs 
file too large to diff
tests/pos/foldN.hs view
file too large to diff
tests/pos/go_ugly_type.hs view
file too large to diff
− tests/pos/initarray.hs 
file too large to diff
tests/pos/jeff.hs view
file too large to diff
tests/pos/kmpIO.hs view
file too large to diff
tests/pos/lex.hs view
file too large to diff
tests/pos/listAnf.hs view
file too large to diff
tests/pos/listSetDemo.hs view
file too large to diff
tests/pos/malformed0.hs view
file too large to diff
tests/pos/mapreduce-bare.hs view
file too large to diff
tests/pos/maybe.hs view
file too large to diff
− tests/pos/maybe00.hs 
file too large to diff
tests/pos/maybe2.hs view
file too large to diff
tests/pos/maybe3.hs view
file too large to diff
tests/pos/meas10.hs view
file too large to diff
− tests/pos/meas3.hs 
file too large to diff
tests/pos/meas5.hs view
file too large to diff
tests/pos/meas9.hs view
file too large to diff
− tests/pos/monad0.hs 
file too large to diff
− tests/pos/monad1.hs 
file too large to diff
− tests/pos/monad7.hs 
file too large to diff
− tests/pos/nullterm.hs 
file too large to diff
− tests/pos/ple0.hs 
file too large to diff
tests/pos/ple1.hs view
file too large to diff
− tests/pos/pleORM.hs 
file too large to diff
tests/pos/primInt0.hs view
file too large to diff
tests/pos/rangeAdt.hs view
file too large to diff
tests/pos/repeatHigherOrder.hs view
file too large to diff
tests/pos/state00.hs view
file too large to diff
tests/pos/stateInvarint.hs view
file too large to diff
tests/pos/test00-int.hs view
file too large to diff
tests/pos/test00.hs view
file too large to diff
+ tests/pos/test00.old.hs view
file too large to diff
tests/pos/test000.hs view
file too large to diff
+ tests/pos/test000.hs.hquals view
file too large to diff
− tests/pos/vecloop.hs 
file too large to diff
− tests/pos/vector0.hs 
file too large to diff
tests/pos/vector2.hs view
file too large to diff
tests/pos/wrap0.hs view
file too large to diff
tests/pos/zipSO.hs view
file too large to diff
tests/pos/zipper.hs view
file too large to diff
tests/pos/zipper000.hs view
file too large to diff
tests/test.hs view
file too large to diff