packages feed

liquidhaskell 0.8.10.7.1 → 0.9.0.2.1

raw patch · 1224 files changed

+19181/−18520 lines, 1224 filesdep −optparse-simpledep −stmdep −string-convdep ~basedep ~containersdep ~directory

Dependencies removed: optparse-simple, stm, string-conv, tagged, tasty-golden, tasty-rerun

Dependency ranges changed: base, containers, directory, filepath, ghc, hashable, liquid-fixpoint, optparse-applicative, process, recursion-schemes, tasty, tasty-hunit, 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

README.md view
@@ -1,7 +1,6 @@ ![LiquidHaskell](/resources/logo.png)  - [![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) @@ -35,13 +34,13 @@ * Please be sure to include test cases that illustrate the effect of the PR     - e.g. show new features that that are supported or how it fixes some previous issue * If you're making user-visible changes, please also add documentation-    - e.g. [options.md](options.md), [specifications.md](specifications.md), the [main tutorial](https:///github.com/ucsd-progsys/intro-refinement-types) (as relevant)+    - e.g. [options.md](docs/mkDocs/docs/options.md), [specifications.md](docs/mkDocs/docs/specifications.md), the [main tutorial](https:///github.com/ucsd-progsys/intro-refinement-types) (as relevant)  Pull requests don't just have to be about code: documentation can often be improved too!  ## Ask for Help -If you have further questions or you just need help, you can always reach out on our [slack channel](https://join.slack.com/t/liquidhaskell/shared_invite/enQtMjY4MTk3NDkwODE3LTFmZGFkNGEzYWRkNDJmZDQ0ZGU1MzBiZWZiZDhhNmY3YTJiMjUzYTRlNjMyZDk1NDU3ZGIxYzhlOTIzN2UxNWE), [google groups mailing list](https://groups.google.com/forum/#!forum/liquidhaskell), [GitHub issue tracker](https://github.com/ucsd-progsys/liquidhaskell/issues), or by emailing one of our star developers: [Ranjit Jhala](https://github.com/ranjitjhala), [Niki Vazou](https://github.com/nikivazou).+If you have further questions or you just need help, you can always reach out on our [slack channel](https://join.slack.com/t/liquidhaskell/shared_invite/enQtMjY4MTk3NDkwODE3LTFmZGFkNGEzYWRkNDJmZDQ0ZGU1MzBiZWZiZDhhNmY3YTJiMjUzYTRlNjMyZDk1NDU3ZGIxYzhlOTIzN2UxNWE), [google groups mailing list](https://groups.google.com/forum/#!forum/liquidhaskell), [GitHub issue tracker](https://github.com/ucsd-progsys/liquidhaskell/issues), or by emailing [Ranjit Jhala](https://github.com/ranjitjhala), [Niki Vazou](https://github.com/nikivazou).  # General Development Guide @@ -78,9 +77,18 @@ #### Stack  ```-env LIQUID_DEV_MODE=true stack build+LIQUID_DEV_MODE=true stack build ``` +If on NixOS++```+LIQUID_DEV_MODE=true stack --no-nix-pure build+```++With the above, `stack` will unregister and re-register the libraries,+but hopefully it won't rebuild any modules.+ #### Cabal  ```@@ -96,43 +104,75 @@  ## How To Run Regression Tests +For documentation on the `test-driver` executable itself, please refer to the+`README.md` in `tests/` or run `cabal run tests:test-driver -- --help` or `stack+run test-driver -- --help`+ _For a way of running the test suite for multiple GHC versions, consult the General Development FAQs. below_  There are particular scripts for running LH in the different modes, e.g. for different -compiler versions and in plugin mode or as standalone. These scripts are in:+compiler versions. These scripts are in:      $ ./scripts/test  So you can run *all* the tests for say the ghc-8.10 version by -    $ ./scripts/test/test_810.sh+    $ ./scripts/test/test_810_plugin.sh -You can run a particular test instead by+You can run a bunch of particular test-groups instead by -    $ LIQUID_DEV_MODE=true ./scripts/test/test_810.sh BadDataDeclTyVars.hs+    $ LIQUID_DEV_MODE=true ./scripts/test/test_810_plugin.sh <test-group-name1> <test-group-name2> ... -Note that the script uses the `BadDataDeclTyVars.hs` as a pattern so will run *all* tests that match.-So, for example,+and you can list all the possible test options with  -    $ LIQUID_DEV_MODE=true ./scripts/test/test_810.sh Error-Messages+    $ LIQUID_DEV_MODE=true ./scripts/test/test_810_plugin.sh --help -will run all the tests in the `Error-Messages` group.+or get a list of just the test groups, one per line, with -To pass in specific parameters and run a subset of the tests  **FIXME**+    $ LIQUID_DEV_MODE=true ./scripts/test/test_810_plugin.sh --show-all -    $ stack test liquidhaskell --fast  --test-arguments "--liquid-opts --no-termination -p Unit+To pass in specific parameters and run a subset of the tests, you can invoke cabal directly with +    $ LIQUID_DEV_MODE=true cabal build tests:<test-group-name> --ghc-options=-fplugin-opt=LiquidHaskell:--no-termination MySpecificTest++For example:++    $ LIQUID_DEV_MODE=true cabal build tests:unit-neg --ghc-options=--fplugin-opt=LiquidHaskell:--no-termination AbsApp+ Or your favorite number of threads, depending on cores etc. -You can directly extend and run the tests by modifying+You can directly extend and run the tests by modifying the files in -    tests/test.hs+    tests/harness/ +### Parallelism in Tests++Most tests run in parallel, with a few module dependencies built sequentially in+advance. Benchmarks are run sequentially after all other tests have finished.+For details on adding tests, see note [Parallel_Tests] in `tests/test.hs`.+ ## How to create performance comparison charts -Everytime `liquidhaskell` tests are run, a report of the time taken by-each test is written to a file `tests/logs/<host>-<time>/summary.csv`.+When `liquidhaskell` tests run, we can collect timing information with +    $ ./scripts/test/test_810_plugin.sh --measure-timings++Measures will be collected in `.dump-timings` files. These can be converted to json+data with++```bash+cabal v2-build ghc-timings+cabal v2-exec ghc-timings dist-newstyle+```++which will produce `tmp/*.json` files.++Then a csv report can be generated from this json files with+```+cabal v2-run benchmark-timings -- tmp/*.json --phase LiquidHaskell -o summary.csv+```+On each line, the report will contain the time taken by each test.+ There is a script `scripts/plot-performance/chart_perf.sh` that can be used to generate comparison charts in `svg` and `png` formats. It requires [gnuplot](http://www.gnuplot.info/) to run. The following@@ -141,10 +181,17 @@      $ scripts/plot-performance/chart_perf.sh path_to_before_summary.csv path_to_after_summary.csv -The current formatting is optmized for comparing the outputs of running+The current formatting is optimized for comparing the outputs of running the benchmarks alone. -    $ scripts/test/test_810.sh Benchmarks+    $ scripts/test/test_810_plugin.sh \+        benchmark-stitch-lh \+        benchmark-bytestring \+        benchmark-vector-algorithms \+        benchmark-cse230 \+        benchmark-esop2013 \+        benchmark-icfp15-pos \+        benchmark-icfp15-neg  ## How to Profile @@ -253,10 +300,22 @@ to upload by scanning the `$PWD` for packages named appropriately. It will ask the user for confirmation before proceeding, and `stack upload` will be used under the hood. +## GHC support policy++LH supports only one version of GHC at any given time. This is because LH depends heavily on the `ghc` library+and there is currently no distinction between public API's and API's internal to GHC. There are currently no+release notes for the `ghc` library and breaking changes happen without notice and without deprecation+periods. Supporting only one GHC version saves developer time because it obviates the need for `#ifdef`'s+throughout the codebase, or for an compatibility layer that becomes increasingly difficult to write as we+attempt to support more GHC versions. Porting to newer GHC versions takes less time, the code is easier to+read and there is less code duplication.++Users of older versions of GHC can still use older versions of LH.+ ## The GHC.API module -In order to allow LH to work with multiple GHC versions, we need a way to abstract over all the breaking-changes of the `ghc` library, which might change substantially with every major GHC release. This is+In order to minimize the effort in porting LH to new releases of GHC, we need a way to abstract over breaking+changes in the `ghc` library, which might change substantially with every major GHC release. This is accomplished by the [GHC.API][] module. The idea is that **rather than importing multiple `ghc` modules, LH developers must import this single module in order to write future-proof code**. This is especially important for versions of the compiler greater than 9, where the module hierarchy changed substantially,
devel/Paths_liquidhaskell.hs view
@@ -8,10 +8,10 @@ import Data.Version (Version, makeVersion)  getDataFileName :: FilePath -> IO FilePath-getDataFileName f = do-  let loc = $(do { loc <- location; f <- runIO (canonicalizePath (loc_filename loc)); litE (stringL f); })-  let root = takeDirectory (takeDirectory loc)-  return (root </> f)+getDataFileName fp = do+  let loc' = $(do { loc <- location; f <- runIO (canonicalizePath (loc_filename loc)); litE (stringL f); })+  let root = takeDirectory (takeDirectory loc')+  return (root </> fp)  -- | dummy version (devel only) version :: Version
include/CoreToLogic.lg view
@@ -23,6 +23,7 @@ define GHC.Types.True                 = (true) define GHC.Real.div x y               = (x / y) define GHC.Real.mod x y               = (x mod y)+define GHC.Classes.not x              = (~ x) define GHC.Base.$ f x                 = (f x)  define Language.Haskell.Liquid.Bag.get k m   = (Map_select m k)@@ -38,6 +39,7 @@ define String.stringEmp  = (stringEmp) define Main.mempty       = (mempty) define Language.Haskell.Liquid.ProofCombinators.cast x y = (y)+define Language.Haskell.Liquid.ProofCombinators.withProof x y = (x) define ProofCombinators.cast x y = (y) define Liquid.ProofCombinators.cast x y = (y) define Control.Parallel.Strategies.withStrategy s x = (x)
include/GHC/Num.spec view
@@ -1,8 +1,8 @@ module spec GHC.Num where -embed GHC.Integer.Type.Integer as int +// 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.fromInteger :: (GHC.Num.Num a) => x:_ -> {v:a | v = x }  GHC.Num.negate :: (GHC.Num.Num a)                => x:a
− include/Language/Haskell/Liquid/RTick/Combinators.hs 
@@ -1,366 +0,0 @@------- Liquidate your assets: reasoning about resource usage in Liquid Haskell.-----{-@ LIQUID "--reflection" @-}--module Language.Haskell.Liquid.RTick.Combinators-  (--  -- 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 Language.Haskell.Liquid.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 (==<?) #-}
liquidhaskell.cabal view
@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               liquidhaskell-version:            0.8.10.7.1+version:            0.9.0.2.1 synopsis:           Liquid Types for Haskell description:        Liquid Types for Haskell. license:            BSD-3-Clause@@ -11,7 +11,7 @@ category:           Language homepage:           https://github.com/ucsd-progsys/liquidhaskell build-type:         Simple-tested-with:        GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.1,  GHC == 8.10.7, GHC == 9.0.1+tested-with:        GHC == 9.0.2 extra-source-files: CHANGES.md                     README.md                     devel/Paths_liquidhaskell.hs@@ -65,6 +65,12 @@   type:     git   location: https://github.com/ucsd-progsys/liquidhaskell/ +flag devel+  default:     False+  manual:      True+  description: Enable more warnings and fail compilation when warnings occur.+               Turn this flag on in CI.+ flag include   default:     False   description: use in-tree include directory@@ -113,17 +119,20 @@                       Language.Haskell.Liquid.Constraint.Split                       Language.Haskell.Liquid.Constraint.ToFixpoint                       Language.Haskell.Liquid.Constraint.Types-                      Language.Haskell.Liquid.GHC.API-                      Language.Haskell.Liquid.GHC.API.StableModule-                      Language.Haskell.Liquid.GHC.GhcMonadLike-                      Language.Haskell.Liquid.GHC.Interface-                      Language.Haskell.Liquid.GHC.Logging-                      Language.Haskell.Liquid.GHC.Misc-                      Language.Haskell.Liquid.GHC.Play-                      Language.Haskell.Liquid.GHC.Resugar-                      Language.Haskell.Liquid.GHC.SpanStack-                      Language.Haskell.Liquid.GHC.Types-                      Language.Haskell.Liquid.GHC.TypeRep+                      Language.Haskell.Liquid.Constraint.Relational+                      Liquid.GHC.API+                      Liquid.GHC.API.StableModule+                      Liquid.GHC.GhcMonadLike+                      Liquid.GHC.Interface+                      Liquid.GHC.Logging+                      Liquid.GHC.Misc+                      Liquid.GHC.Play+                      Liquid.GHC.Resugar+                      Liquid.GHC.SpanStack+                      Liquid.GHC.Types+                      Liquid.GHC.TypeRep+                      Language.Haskell.Liquid.GHC.Plugin+                      Language.Haskell.Liquid.GHC.Plugin.Tutorial                       Language.Haskell.Liquid.Interactive.Handler                       Language.Haskell.Liquid.Interactive.Types                       Language.Haskell.Liquid.LawInstances@@ -172,36 +181,15 @@                       Language.Haskell.Liquid.UX.DiffCheck                       Language.Haskell.Liquid.UX.Errors                       Language.Haskell.Liquid.UX.QuasiQuoter+                      Language.Haskell.Liquid.UX.SimpleVersion                       Language.Haskell.Liquid.UX.Tidy                       Language.Haskell.Liquid.WiredIn                       LiquidHaskell                       Paths_liquidhaskell--  -- FIXME: Temporary measure to ensure that if the source plugin is available, then:-  --   1. we compile it;-  --   2. We don't rely on the \"liquid-prelude\" Haskell files previously shipped as part of LH itself.-  -- Once the source plugin is out, we should also removed the duplicate \"liquid-prelude\" files from-  -- the \"include\" directory.--  if impl(ghc >= 8.10)-      exposed-modules:    Language.Haskell.Liquid.GHC.Plugin-                          Language.Haskell.Liquid.GHC.Plugin.Tutorial-      other-modules:      Language.Haskell.Liquid.GHC.Plugin.SpecFinder-                          Language.Haskell.Liquid.GHC.Plugin.Types-                          Language.Haskell.Liquid.GHC.Plugin.Util-      hs-source-dirs:     src-  else-      hs-source-dirs:     src include-      exposed-modules:    Language.Haskell.Liquid.RTick-                          Language.Haskell.Liquid.Prelude-                          Language.Haskell.Liquid.Foreign-                          Language.Haskell.Liquid.RTick.Combinators-                          Language.Haskell.Liquid.String-                          Language.Haskell.Liquid.List-                          Language.Haskell.Liquid.Equational-                          Language.Haskell.Liquid.Bag-                          Language.Haskell.Liquid.ProofCombinators-                          KMeansHelper+  other-modules:      Language.Haskell.Liquid.GHC.Plugin.SpecFinder+                      Language.Haskell.Liquid.GHC.Plugin.Types+                      Language.Haskell.Liquid.GHC.Plugin.Util+  hs-source-dirs:     src src-ghc    build-depends:      base                 >= 4.11.1.0 && < 5                     , Diff                 >= 0.3 && < 0.5@@ -218,19 +206,17 @@                     , filepath             >= 1.3                     , fingertree           >= 0.1                     , exceptions           < 0.11-                    , ghc+                    , ghc                  ^>= 9                     , ghc-boot                     , ghc-paths            >= 0.1                     , ghc-prim                     , gitrev-                    , hashable             >= 1.3 && < 1.3.4+                    , hashable             >= 1.3 && < 1.4                     , hscolour             >= 1.22                     , liquid-fixpoint      >= 0.8.10.2.1 && < 0.9                     , mtl                  >= 2.1                     , optics               >= 0.2-                    , optparse-applicative < 0.16.0.0-                    , optparse-simple-                    , optparse-applicative < 0.16.0.0+                    , optparse-applicative < 0.17                     , githash                     , megaparsec           >= 8                     , pretty               >= 1.1@@ -241,25 +227,27 @@                     , temporary            >= 1.2                     , text                 >= 1.2                     , time                 >= 1.4-                    , time                     , transformers         >= 0.3                     , unordered-containers >= 0.2.11                     , vector               >= 0.10                     , free-                    , recursion-schemes    <= 5.2.2+                    , recursion-schemes    < 5.3                     , data-fix-                    , extra +                    , extra   default-language:   Haskell98   default-extensions: PatternGuards, RecordWildCards, DoAndIfThenElse   ghc-options:        -W -fwarn-missing-signatures +  if flag(devel)+    ghc-options:      -Wall -Werror+   if flag(include)     hs-source-dirs: devel    if flag(deterministic-profiling)     cpp-options: -DDETERMINISTIC_PROFILING -  if impl(ghc < 8.10) || flag(no-plugin)+  if flag(no-plugin)     cpp-options: -DLIQUID_NO_PLUGIN  -- This is the (legacy) 'liquid' executable which uses the old GHC Interface.@@ -268,35 +256,10 @@   build-depends:      base >= 4.9.1.0 && < 5, liquidhaskell   default-language:   Haskell98   default-extensions: PatternGuards-  ghc-options:        -W -threaded -fdefer-typed-holes-+  ghc-options:        -W -threaded -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-                  , string-conv          >= 0.1-                  , tagged               >= 0.7.3-                  , tasty                >= 1.4.2 && < 1.5-                  , tasty-ant-xml-                  , tasty-golden         >= 2.0.0-                  , tasty-hunit          >= 0.9-                  , tasty-rerun          >= 1.1-                  , text-                  , transformers         >= 0.3-  default-language: Haskell98-  ghc-options:      -W -threaded-  if !flag(no-plugin)-    cpp-options: -DUSE_NEW_EXECUTABLE+  if flag(devel)+    ghc-options:      -Wall -Wno-name-shadowing -Werror  test-suite liquidhaskell-parser   type:             exitcode-stdio-1.0@@ -316,6 +279,9 @@   default-language: Haskell2010   ghc-options:      -W +  if flag(devel)+    ghc-options:    -Wall -Wno-name-shadowing -Werror+ test-suite synthesis   type:             exitcode-stdio-1.0   main-is:          Synthesis.hs@@ -335,6 +301,8 @@   default-language: Haskell2010   ghc-options:      -W +  if flag(devel)+    ghc-options:    -Wall -Wno-name-shadowing -Werror  -- This executable can be used to generate modules for mirror-packages. executable mirror-modules@@ -351,7 +319,7 @@                  , filepath < 1.5                  , containers < 0.7                  , mustache < 2.4-                 , optparse-applicative < 0.16.1.0+                 , optparse-applicative < 0.17     buildable: True   else     buildable: False@@ -363,3 +331,7 @@     MultiWayIf     LambdaCase   ghc-options:        -W -threaded++  if flag(devel)+    ghc-options:      -Wall -Wno-name-shadowing -Werror+
+ src-ghc/Liquid/GHC/API.hs view
@@ -0,0 +1,179 @@+{-| This module re-exports a bunch of the GHC API.++The intended use of this module is to shelter LiquidHaskell from changes to the GHC API, so this is the+/only/ module LiquidHaskell should import when trying to access any ghc-specific functionality.++--}++{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE BangPatterns #-}++module Liquid.GHC.API (+    module Ghc+  , module StableModule+  , tyConRealArity+  , dataConExTyVars+  , fsToUnitId+  , moduleUnitId+  , thisPackage+  , renderWithStyle+  , mkUserStyle+  , pattern LitNumber+  , dataConSig+  , getDependenciesModuleNames+  , gcatch+  ) where++import           Liquid.GHC.API.StableModule      as StableModule+import           GHC                                               as Ghc hiding ( Warning+                                                                                 , SrcSpan(RealSrcSpan, UnhelpfulSpan)+                                                                                 , exprType+                                                                                 )++import Optics+import qualified Control.Monad.Catch as Ex++import Data.Foldable                  (asum)+import GHC.Builtin.Names              as Ghc+import GHC.Builtin.Types              as Ghc+import GHC.Builtin.Types.Prim         as Ghc+import GHC.Builtin.Utils              as Ghc+import GHC.Core                       as Ghc hiding (AnnExpr, AnnExpr' (..), AnnRec, AnnCase)+import GHC.Core.Class                 as Ghc+import GHC.Core.Coercion              as Ghc+import GHC.Core.Coercion.Axiom        as Ghc+import GHC.Core.ConLike               as Ghc+import GHC.Core.DataCon               as Ghc+import GHC.Core.FamInstEnv            as Ghc hiding (pprFamInst)+import GHC.Core.InstEnv               as Ghc+import GHC.Core.Lint                  as Ghc hiding (dumpIfSet)+import GHC.Core.Make                  as Ghc+import GHC.Core.Opt.Monad             as Ghc (CoreToDo(..))+import GHC.Core.Opt.WorkWrap.Utils    as Ghc+import GHC.Core.Predicate             as Ghc (getClassPredTys_maybe, getClassPredTys, isEvVarType, isEqPrimPred, isEqPred, isClassPred, isDictId, mkClassPred)+import GHC.Core.Subst                 as Ghc (deShadowBinds, emptySubst, extendCvSubst)+import GHC.Core.TyCo.Rep              as Ghc+import GHC.Core.TyCon                 as Ghc+import GHC.Core.Type                  as Ghc hiding (typeKind , isPredTy, extendCvSubst, linear)+import GHC.Core.Unify                 as Ghc+import GHC.Core.Utils                 as Ghc (exprType)+import GHC.Data.Bag                   as Ghc+import GHC.Data.FastString            as Ghc+import GHC.Data.Graph.Directed        as Ghc+import GHC.Data.Pair                  as Ghc+import GHC.Driver.Finder              as Ghc+import GHC.Driver.Main                as Ghc+import GHC.Driver.Phases              as Ghc (Phase(StopLn))+import GHC.Driver.Pipeline            as Ghc (compileFile)+import GHC.Driver.Session             as Ghc hiding (isHomeModule)+import GHC.Driver.Types               as Ghc+import GHC.Driver.Monad               as Ghc (withSession)+import GHC.HsToCore.Monad             as Ghc+import GHC.Iface.Syntax               as Ghc+import GHC.Plugins                    as Ghc ( deserializeWithData+                                             , fromSerialized+                                             , toSerialized+                                             , defaultPlugin+                                             , Plugin(..)+                                             , CommandLineOption+                                             , purePlugin+                                             , extendIdSubst+                                             , substExpr+                                             )+import GHC.Tc.Instance.Family         as Ghc+import GHC.Tc.Module                  as Ghc+import GHC.Tc.Types                   as Ghc+import GHC.Tc.Utils.Monad             as Ghc hiding (getGHCiMonad)+import GHC.Tc.Utils.TcType            as Ghc (tcSplitDFunTy, tcSplitMethodTy)+import GHC.Types.Annotations          as Ghc+import GHC.Types.Avail                as Ghc+import GHC.Types.Basic                as Ghc+import GHC.Types.CostCentre           as Ghc+import GHC.Types.Id                   as Ghc hiding (lazySetIdInfo, setIdExported, setIdNotExported)+import GHC.Types.Id.Info              as Ghc+import GHC.Types.Literal              as Ghc hiding (LitNumber)+import GHC.Types.Name                 as Ghc hiding (varName, isWiredIn)+import GHC.Types.Name.Reader          as Ghc+import GHC.Types.Name.Set             as Ghc+import GHC.Types.SrcLoc               as Ghc+import GHC.Types.Unique               as Ghc+import GHC.Types.Unique.DFM           as Ghc+import GHC.Types.Unique.FM            as Ghc+import GHC.Types.Unique.Set           as Ghc+import GHC.Types.Unique.Supply        as Ghc+import GHC.Types.Var                  as Ghc+import GHC.Types.Var.Env              as Ghc+import GHC.Types.Var.Set              as Ghc+import GHC.Unit.Module                as Ghc+import GHC.Utils.Error                as Ghc+import GHC.Utils.Outputable           as Ghc hiding ((<>), integer, renderWithStyle, mkUserStyle)+import GHC.Utils.Panic                as Ghc+import qualified GHC.Types.Literal    as Ghc+import qualified GHC.Utils.Outputable as Ghc+import GHC.Tc.Types.Origin            as Ghc (lexprCtOrigin)+import GHC.Rename.Expr                as Ghc (rnLExpr)+import GHC.Tc.Gen.Expr                as Ghc (tcInferSigma, tcInferRho)+import GHC.Tc.Gen.Bind                as Ghc (tcValBinds)+import GHC.Tc.Solver                  as Ghc+import GHC.Tc.Utils.Zonk              as Ghc+import GHC.Core.FVs                   as Ghc (exprFreeVarsList)+import GHC.Tc.Types.Evidence          as Ghc+import GHC.HsToCore.Expr              as Ghc+import GHC.Core.Opt.OccurAnal         as Ghc++-- 'fsToUnitId' is gone in GHC 9, but we can bring code it in terms of 'fsToUnit' and 'toUnitId'.+fsToUnitId :: FastString -> UnitId+fsToUnitId = toUnitId . fsToUnit++moduleUnitId :: Module -> UnitId+moduleUnitId = toUnitId . moduleUnit++thisPackage :: DynFlags -> UnitId+thisPackage = toUnitId . homeUnit++-- See NOTE [tyConRealArity].+tyConRealArity :: TyCon -> Int+tyConRealArity tc = go 0 (tyConKind tc)+  where+    go :: Int -> Kind -> Int+    go !acc k =+      case asum [fmap (view _3) (splitFunTy_maybe k), fmap snd (splitForAllTy_maybe k)] of+        Nothing -> acc+        Just ks -> go (acc + 1) ks++dataConExTyVars :: DataCon -> [TyVar]+dataConExTyVars = dataConExTyCoVars++getDependenciesModuleNames :: Dependencies -> [ModuleNameWithIsBoot]+getDependenciesModuleNames = dep_mods++renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String+renderWithStyle dynflags sdoc style = Ghc.renderWithStyle (Ghc.initSDocContext dynflags style) sdoc++mkUserStyle :: DynFlags -> PrintUnqualified -> Depth -> PprStyle+mkUserStyle _ = Ghc.mkUserStyle++--+-- Literal+--++-- In GHC 9 'LitNumber' doesn't have the extra 3rd argument, so we simply ignore it in the construction.++pattern LitNumber :: Ghc.LitNumType -> Integer -> Ghc.Type -> Ghc.Literal+pattern LitNumber numType integer ty <- ((intPrimTy,) -> (ty, Ghc.LitNumber numType integer))+  where+    LitNumber numType integer _ = Ghc.LitNumber numType integer++-- This function is gone in GHC 9.+dataConSig :: DataCon -> ([TyCoVar], ThetaType, [Type], Type)+dataConSig dc+  = (dataConUnivAndExTyCoVars dc, dataConTheta dc, map irrelevantMult $ dataConOrigArgTys dc, dataConOrigResTy dc)++gcatch :: (Ex.MonadCatch m, Exception e) => m a -> (e -> m a) -> m a+gcatch = Ex.catch
+ src-ghc/Liquid/GHC/API/StableModule.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE DeriveGeneric #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Liquid.GHC.API.StableModule (+    StableModule+  -- * Constructing a 'StableModule'+  , mkStableModule+  -- * Converting a 'StableModule' into a standard 'Module'+  , unStableModule+  -- * Utility functions+  , toStableModule+  , renderModule+  ) where++import qualified GHC+import qualified GHC.Unit.Types as GHC+import qualified GHC.Unit.Module as GHC+import           Data.Hashable+import           GHC.Generics            hiding (to, moduleName)+import           Data.Binary++-- | A newtype wrapper around a 'Module' which:+--+-- * Allows a 'Module' to be serialised (i.e. it has a 'Binary' instance)+-- * It tries to use stable comparison and equality under the hood.+--+newtype StableModule =+  StableModule { unStableModule :: GHC.Module }+  deriving Generic++-- | Converts a 'Module' into a 'StableModule'.+toStableModule :: GHC.Module -> StableModule+toStableModule = StableModule++moduleUnitId :: GHC.Module -> GHC.UnitId+moduleUnitId = GHC.toUnitId . GHC.moduleUnit++renderModule :: GHC.Module -> String+renderModule m =    "Module { unitId = " <> (GHC.unitIdString . moduleUnitId $ m)+                 <> ", name = " <> show (GHC.moduleName m)+                 <> " }"++-- These two orphans originally lived inside module 'Language.Haskell.Liquid.Types.Types'.+instance Hashable GHC.ModuleName where+  hashWithSalt i = hashWithSalt i . show++instance Show GHC.ModuleName where+  show = GHC.moduleNameString++instance Hashable StableModule where+  hashWithSalt s (StableModule mdl) = hashWithSalt s (GHC.moduleStableString mdl)++instance Ord StableModule where+  (StableModule m1) `compare` (StableModule m2) = GHC.stableModuleCmp m1 m2++instance Eq StableModule where+  (StableModule m1) == (StableModule m2) = (m1 `GHC.stableModuleCmp` m2) == EQ++instance Show StableModule where+    show (StableModule mdl) = "Stable" ++ renderModule mdl++instance Binary StableModule where++    put (StableModule mdl) = do+      put (GHC.unitIdString . moduleUnitId $ mdl)+      put (GHC.moduleNameString . GHC.moduleName $ mdl)++    get = do+      uidStr <- get+      mkStableModule (GHC.stringToUnitId uidStr) . GHC.mkModuleName <$> get++--+-- Compat shim layer+--++-- | Creates a new 'StableModule' out of a 'ModuleName' and a 'UnitId'.+mkStableModule :: GHC.UnitId -> GHC.ModuleName -> StableModule+mkStableModule uid modName =+  let realUnit = GHC.RealUnit $ GHC.Definite uid+  in StableModule (GHC.Module realUnit modName)
+ src-ghc/Liquid/GHC/GhcMonadLike.hs view
@@ -0,0 +1,307 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+-- | This module introduces a \"lighter\" "GhcMonad" typeclass which doesn't require an instance of+-- 'ExceptionMonad', and can therefore be used for both 'CoreM' and 'Ghc'.+--++module Liquid.GHC.GhcMonadLike (+  -- * Types and type classes+    HasHscEnv+  , GhcMonadLike+  , ModuleInfo+  , TypecheckedModule(..)++  -- * Functions and typeclass methods++  , askHscEnv+  , getModuleGraph+  , getModSummary+  , lookupModSummary+  , lookupGlobalName+  , lookupName+  , modInfoLookupName+  , moduleInfoTc+  , parseModule+  , typecheckModule+  , desugarModule+  , findModule+  , lookupModule+  , isBootInterface+  , apiComments+  ) where++import Control.Monad.IO.Class+import Control.Exception (throwIO)++import Data.IORef (readIORef)++import qualified Liquid.GHC.API   as Ghc+import           Liquid.GHC.API   hiding ( ModuleInfo+                                                          , findModule+                                                          , desugarModule+                                                          , typecheckModule+                                                          , parseModule+                                                          , lookupName+                                                          , lookupGlobalName+                                                          , getModSummary+                                                          , getModuleGraph+                                                          , modInfoLookupName+                                                          , lookupModule+                                                          , TypecheckedModule+                                                          , tm_parsed_module+                                                          , tm_renamed_source+                                                          )++import GHC.Data.Maybe+import GHC.Driver.Make+import GHC.Utils.Exception (ExceptionMonad)+import qualified GHC.Core.Opt.Monad as CoreMonad+import qualified GHC.Data.EnumSet as EnumSet++import qualified Data.Map.Strict as M+import Optics++class HasHscEnv m where+  askHscEnv :: m HscEnv++instance HasHscEnv CoreMonad.CoreM where+  askHscEnv = CoreMonad.getHscEnv++instance HasHscEnv Ghc where+  askHscEnv = getSession++instance HasHscEnv (IfM lcl) where+  askHscEnv = getTopEnv++instance HasHscEnv TcM where+  askHscEnv = env_top <$> getEnv++instance HasHscEnv Hsc where+  askHscEnv = Hsc $ curry pure++instance (ExceptionMonad m, HasHscEnv m) => HasHscEnv (GhcT m) where+  askHscEnv = getSession++-- | A typeclass which is /very/ similar to the existing 'GhcMonad', but it doesn't impose a+-- 'ExceptionMonad' constraint.+class (Functor m, MonadIO m, HasHscEnv m, HasDynFlags m) => GhcMonadLike m++instance GhcMonadLike CoreMonad.CoreM+instance GhcMonadLike Ghc+instance GhcMonadLike (IfM lcl)+instance GhcMonadLike TcM+instance GhcMonadLike Hsc+instance (ExceptionMonad m, GhcMonadLike m) => GhcMonadLike (GhcT m)++-- NOTE(adn) Taken from the GHC API, adapted to work for a 'GhcMonadLike' monad.+getModuleGraph :: GhcMonadLike m => m ModuleGraph+getModuleGraph = fmap hsc_mod_graph askHscEnv++-- NOTE(adn) Taken from the GHC API, adapted to work for a 'GhcMonadLike' monad.+getModSummary :: GhcMonadLike m => ModuleName -> m ModSummary+getModSummary mdl = do+   mg <- fmap hsc_mod_graph askHscEnv+   let mods_by_name = [ ms | ms <- mgModSummaries mg+                      , ms_mod_name ms == mdl+                      , not (isBootInterface . isBootSummary $ ms) ]+   case mods_by_name of+     [] -> do dflags <- getDynFlags+              liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph")+     [ms] -> return ms+     multiple -> do dflags <- getDynFlags+                    liftIO $ throwIO $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple)+++-- Converts a 'IsBootInterface' into a 'Bool'.+isBootInterface :: IsBootInterface -> Bool+isBootInterface IsBoot  = True+isBootInterface NotBoot = False++lookupModSummary :: GhcMonadLike m => ModuleName -> m (Maybe ModSummary)+lookupModSummary mdl = do+   mg <- fmap hsc_mod_graph askHscEnv+   let mods_by_name = [ ms | ms <- mgModSummaries mg+                      , ms_mod_name ms == mdl+                      , not (isBootInterface . isBootSummary $ ms) ]+   case mods_by_name of+     [ms] -> pure (Just ms)+     _    -> pure Nothing++-- NOTE(adn) Taken from the GHC API, adapted to work for a 'GhcMonadLike' monad.+lookupGlobalName :: GhcMonadLike m => Name -> m (Maybe TyThing)+lookupGlobalName name = do+  hsc_env <- askHscEnv+  liftIO $ lookupTypeHscEnv hsc_env name++-- NOTE(adn) Taken from the GHC API, adapted to work for a 'GhcMonadLike' monad.+lookupName :: GhcMonadLike m => Name -> m (Maybe TyThing)+lookupName name = do+  hsc_env <- askHscEnv+  liftIO $ hscTcRcLookupName hsc_env name++-- | Our own simplified version of 'ModuleInfo' to overcome the fact we cannot construct the \"original\"+-- one as the constructor is not exported, and 'getHomeModuleInfo' and 'getPackageModuleInfo' are not+-- exported either, so we had to backport them as well.+newtype ModuleInfo = ModuleInfo { minf_type_env :: UniqFM Name TyThing }++modInfoLookupName :: GhcMonadLike m+                  => ModuleInfo+                  -> Name+                  -> m (Maybe TyThing)+modInfoLookupName minf name = do+  hsc_env <- askHscEnv+  case lookupTypeEnv (minf_type_env minf) name of+    Just tyThing -> return (Just tyThing)+    Nothing      -> do+      eps   <- liftIO $ readIORef (hsc_EPS hsc_env)+      return $! lookupType (hsc_dflags hsc_env) (hsc_HPT hsc_env) (eps_PTE eps) name++moduleInfoTc :: GhcMonadLike m => ModSummary -> TcGblEnv -> m ModuleInfo+moduleInfoTc ms tcGblEnv = do+  hsc_env <- askHscEnv+  let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }+  details <- md_types <$> liftIO (makeSimpleDetails hsc_env_tmp tcGblEnv)+  pure ModuleInfo { minf_type_env = details }++--+-- Parsing, typechecking and desugaring a module+--+parseModule :: GhcMonadLike m => ModSummary -> m ParsedModule+parseModule ms = do+  hsc_env <- askHscEnv+  let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }+  hpm <- liftIO $ hscParse hsc_env_tmp ms+  return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm)+                           (hpm_annotations hpm))++-- | Our own simplified version of 'TypecheckedModule'.+data TypecheckedModule = TypecheckedModule { +    tm_parsed_module  :: ParsedModule+  , tm_renamed_source :: Maybe RenamedSource+  , tm_mod_summary    :: ModSummary+  , tm_gbl_env        :: TcGblEnv+  }++typecheckModule :: GhcMonadLike m => ParsedModule -> m TypecheckedModule+typecheckModule pmod = do+  -- Suppress all the warnings, so that they won't be printed (which would result in them being+  -- printed twice, one by GHC and once here).+  let ms = pm_mod_summary pmod+  hsc_env <- askHscEnv+  let dynFlags' = ms_hspp_opts ms+  let hsc_env_tmp = hsc_env { hsc_dflags = dynFlags' { warningFlags = EnumSet.empty } }+  (tc_gbl_env, rn_info)+        <- liftIO $ hscTypecheckRename hsc_env_tmp ms $+                       HsParsedModule { hpm_module = parsedSource pmod,+                                        hpm_src_files = pm_extra_src_files pmod,+                                        hpm_annotations = pm_annotations pmod }+  return TypecheckedModule {+      tm_parsed_module  = pmod+    , tm_renamed_source = rn_info+    , tm_mod_summary    = ms+    , tm_gbl_env        = tc_gbl_env+    }++{- | [NOTE:ghc810]+Something changed in the GHC bowels such that the 'hscTarget' that the 'ModSummary' was inheriting+was /not/ the one we were setting in 'configureDynFlags'. This is important, because if the 'hscTarget'+is not 'HscInterpreted' or 'HscNothing', the call to 'targetRetainsAllBindings' will yield 'False'. This+function is used internally by GHC to do dead-code-elimination and to mark functions as "exported" or not.+Therefore, the 'CoreBind's passed to LiquidHaskell would be different between GHC 8.6.5 and GHC 8.10.+-}++class IsTypecheckedModule t where+  tmParsedModule :: Lens'  t ParsedModule+  tmModSummary   :: Lens'  t ModSummary+  tmGblEnv       :: Getter t TcGblEnv++instance IsTypecheckedModule TypecheckedModule where+  tmParsedModule = lens tm_parsed_module (\s x -> s { tm_parsed_module = x })+  tmModSummary   = lens tm_mod_summary   (\s x -> s { tm_mod_summary = x })+  tmGblEnv       = to tm_gbl_env++instance IsTypecheckedModule Ghc.TypecheckedModule where+  tmParsedModule = lens Ghc.tm_parsed_module (\s x -> s { Ghc.tm_parsed_module = x })+  tmModSummary   = lens (pm_mod_summary . Ghc.tm_parsed_module)+                        (\s x -> over tmParsedModule (\pm -> pm { Ghc.pm_mod_summary = x }) s )+  tmGblEnv       = to (fst . Ghc.tm_internals_)++-- | Desugar a typechecked module.+desugarModule :: (GhcMonadLike m, IsTypecheckedModule t) => ModSummary -> t -> m ModGuts+desugarModule originalModSum typechecked = do+  -- See [NOTE:ghc810] on why we override the dynFlags here before calling 'desugarModule'.+  dynFlags          <- getDynFlags+  let modSum         = originalModSum { ms_hspp_opts = dynFlags }+  let parsedMod'     = (view tmParsedModule typechecked) { pm_mod_summary = modSum }+  let typechecked'   = set tmParsedModule parsedMod' typechecked++  hsc_env <- askHscEnv+  let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts (view tmModSummary typechecked') }+  liftIO $ hscDesugar hsc_env_tmp (view tmModSummary typechecked') (view tmGblEnv typechecked')++-- | Takes a 'ModuleName' and possibly a 'UnitId', and consults the+-- filesystem and package database to find the corresponding 'Module',+-- using the algorithm that is used for an @import@ declaration.+findModule :: GhcMonadLike m => ModuleName -> Maybe FastString -> m Module+findModule mod_name maybe_pkg = do+  hsc_env <- askHscEnv+  let+    dflags   = hsc_dflags hsc_env+    this_pkg = thisPackage dflags+  --+  case maybe_pkg of+    Just pkg | fsToUnitId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do+      res <- findImportedModule hsc_env mod_name maybe_pkg+      case res of+        Found _ m -> return m+        err       -> throwOneError $ noModError dflags noSrcSpan mod_name err+    _otherwise -> do+      home <- lookupLoadedHomeModule mod_name+      case home of+        Just m  -> return m+        Nothing -> liftIO $ do+           res <- findImportedModule hsc_env mod_name maybe_pkg+           case res of+             Found loc m | moduleUnitId m /= this_pkg -> return m+                         | otherwise -> modNotLoadedError dflags m loc+             err -> throwOneError $ noModError dflags noSrcSpan mod_name err+++lookupLoadedHomeModule :: GhcMonadLike m => ModuleName -> m (Maybe Module)+lookupLoadedHomeModule mod_name = do+  hsc_env <- askHscEnv+  case lookupHpt (hsc_HPT hsc_env) mod_name of+    Just mod_info      -> return (Just (mi_module (hm_iface mod_info)))+    _not_a_home_module -> return Nothing+++modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a+modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $+   text "module is not loaded:" <+>+   quotes (ppr (moduleName m)) <+>+   parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))+++lookupModule :: GhcMonadLike m => ModuleName -> Maybe FastString -> m Module+lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg)+lookupModule mod_name Nothing = do+  hsc_env <- askHscEnv+  home <- lookupLoadedHomeModule mod_name+  case home of+    Just m  -> return m+    Nothing -> liftIO $ do+      res <- findExposedPackageModule hsc_env mod_name Nothing+      case res of+        Found _ m -> return m+        err       -> throwOneError $ noModError (hsc_dflags hsc_env) noSrcSpan mod_name err++-- Compatibility shim to extract the comments out of an 'ApiAnns', as modern GHCs now puts the+-- comments (i.e. Haskell comments) in a different field ('apiAnnRogueComments').+apiComments :: ApiAnns -> [Ghc.Located AnnotationComment]+apiComments apiAnns =+  let comments = concat . M.elems . apiAnnComments $ apiAnns+  in+     map toRealSrc $ mappend comments (apiAnnRogueComments apiAnns)+  where+    toRealSrc (L x e) = L (RealSrcSpan x Nothing) e
+ src-ghc/Liquid/GHC/Interface.hs view
@@ -0,0 +1,1048 @@+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE TypeSynonymInstances       #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE PartialTypeSignatures      #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE ViewPatterns               #-}++{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wwarn=deprecations #-}++module Liquid.GHC.Interface (++  -- * Determine the build-order for target files+   realTargets++  , getInterfaceDynFlags++  -- * Extract all information needed for verification+  , getTargetInfos+  , runLiquidGhc++  -- * Printer+  , pprintCBs++  -- * predicates+  -- , isExportedVar+  -- , exportedVars++  -- * Internal exports (provisional)+  , extractSpecComments+  , extractSpecQuotes'+  , makeLogicMap+  , classCons+  , derivedVars+  , importVars+  , makeGhcSrc+  , allImports+  , qualifiedImports+  , modSummaryHsFile+  , makeFamInstEnv+  , findAndParseSpecFiles+  , parseSpecFile+  , noTerm+  , clearSpec+  , checkFilePragmas+  , keepRawTokenStream+  , ignoreInline+  , lookupTyThings+  , availableTyCons+  , availableVars+  , updLiftedSpec+  , loadDependenciesOf+  ) where++import Prelude hiding (error)++import GHC.Paths (libdir)++import           Liquid.GHC.API as Ghc hiding ( text+                                                               , (<+>)+                                                               , panic+                                                               , vcat+                                                               , showPpr+                                                               , mkStableModule+                                                               , Target+                                                               , Located+                                                               )+import qualified Liquid.GHC.API as Ghc+import qualified Liquid.GHC.API as O+import GHC.LanguageExtensions++import Control.Exception+import Control.Monad++import Data.Bifunctor+import Data.Data+import Data.List hiding (intersperse)+import Data.Maybe++import Data.Generics.Aliases (mkT)+import Data.Generics.Schemes (everywhere)++import qualified Data.HashSet        as S+import qualified Data.HashMap.Strict as HM++import System.Console.CmdArgs.Verbosity hiding (Loud)+import System.Directory+import System.FilePath+import System.IO+import System.IO.Temp+import Text.Megaparsec.Error+import Text.PrettyPrint.HughesPJ        hiding (first, (<>))+import Language.Fixpoint.Types          hiding (err, panic, Error, Result, Expr)+import qualified Language.Fixpoint.Misc as Misc+import Language.Haskell.Liquid.Bare+import Liquid.GHC.Misc+import Liquid.GHC.Types (MGIModGuts(..), miModGuts)+import Liquid.GHC.Play+import qualified Liquid.GHC.GhcMonadLike as GhcMonadLike+import Liquid.GHC.GhcMonadLike (GhcMonadLike, isBootInterface, askHscEnv)+import Language.Haskell.Liquid.WiredIn (isDerivedInstance)+import qualified Language.Haskell.Liquid.Measure  as Ms+import qualified Language.Haskell.Liquid.Misc     as Misc+import Language.Haskell.Liquid.Parse+import Language.Haskell.Liquid.Transforms.ANF+import Language.Haskell.Liquid.Types hiding (Spec)+-- import Language.Haskell.Liquid.Types.PrettyPrint+-- import Language.Haskell.Liquid.Types.Visitors+import Language.Haskell.Liquid.UX.CmdLine+import Language.Haskell.Liquid.UX.QuasiQuoter+import Language.Haskell.Liquid.UX.Tidy+import Language.Fixpoint.Utils.Files++import Optics hiding (ix)++import qualified Debug.Trace as Debug+++--------------------------------------------------------------------------------+{- | @realTargets mE cfg targets@ uses `Interface.configureGhcTargets` to+     return a list of files++       [i1, i2, ... ] ++ [f1, f2, ...]++     1. Where each file only (transitively imports) PRECEDIING ones;+     2. `f1..` are a permutation of the original `targets`;+     3. `i1..` either don't have "fresh" .bspec files.++ -}+--------------------------------------------------------------------------------+realTargets :: Maybe HscEnv -> Config -> [FilePath] -> IO [FilePath]+realTargets  mbEnv cfg tgtFs+  | noCheckImports cfg = return tgtFs+  | otherwise          = do+    incDir   <- Misc.getIncludeDir+    allFs    <- orderTargets mbEnv cfg tgtFs+    let srcFs = filter (not . Misc.isIncludeFile incDir) allFs+    realFs   <- filterM check srcFs+    dir      <- getCurrentDirectory+    return      (makeRelative dir <$> realFs)+  where+    check f    = not <$> skipTarget tgts f+    tgts       = S.fromList tgtFs++getInterfaceDynFlags :: Maybe HscEnv -> Config -> IO DynFlags+getInterfaceDynFlags mbEnv cfg = runLiquidGhc mbEnv cfg getSessionDynFlags++orderTargets :: Maybe HscEnv -> Config -> [FilePath] -> IO [FilePath]+orderTargets mbEnv cfg tgtFiles = runLiquidGhc mbEnv cfg $ do+  homeModules <- configureGhcTargets tgtFiles+  return         (modSummaryHsFile <$> mgModSummaries homeModules)+++skipTarget :: S.HashSet FilePath -> FilePath -> IO Bool+skipTarget tgts f+  | S.member f tgts = return False          -- Always check target file+  | otherwise       = hasFreshBinSpec f     -- But skip an import with fresh .bspec++hasFreshBinSpec :: FilePath -> IO Bool+hasFreshBinSpec srcF = do+  let specF = extFileName BinSpec srcF+  srcMb    <- Misc.lastModified srcF+  specMb   <- Misc.lastModified specF+  case (srcMb, specMb) of+    (Just srcT, Just specT) -> return (srcT < specT)+    _                       -> return False++++--------------------------------------------------------------------------------+-- | GHC Interface Pipeline ----------------------------------------------------+--------------------------------------------------------------------------------++getTargetInfos :: Maybe HscEnv -> Config -> [FilePath] -> IO ([TargetInfo], HscEnv)+getTargetInfos hscEnv cfg tgtFiles' = do+  tgtFiles <- mapM canonicalizePath tgtFiles'+  mapM_ checkFilePresent tgtFiles+  mapM_ createTempDirectoryIfMissing tgtFiles+  logicMap <- liftIO makeLogicMap+  runLiquidGhc hscEnv cfg (getTargetInfos' cfg logicMap tgtFiles)++checkFilePresent :: FilePath -> IO ()+checkFilePresent f = do+  b <- doesFileExist f+  unless b $ panic Nothing ("Cannot find file: " ++ f)++getTargetInfos' :: Config -> LogicMap -> [FilePath] -> Ghc ([TargetInfo], HscEnv)+getTargetInfos' cfg logicMap tgtFiles = do+  _           <- compileCFiles cfg+  homeModules <- configureGhcTargets tgtFiles+  depGraph    <- buildDepGraph homeModules+  ghcInfos    <- processModules cfg logicMap tgtFiles depGraph homeModules+  hscEnv      <- getSession+  return (ghcInfos, hscEnv)++createTempDirectoryIfMissing :: FilePath -> IO ()+createTempDirectoryIfMissing tgtFile = Misc.tryIgnore "create temp directory" $+  createDirectoryIfMissing False $ tempDirectory tgtFile++--------------------------------------------------------------------------------+-- | GHC Configuration & Setup -------------------------------------------------+--------------------------------------------------------------------------------+runLiquidGhc :: Maybe HscEnv -> Config -> Ghc a -> IO a+runLiquidGhc hscEnv cfg act =+  withSystemTempDirectory "liquid" $ \tmp ->+    runGhc (Just libdir) $ do+      maybe (return ()) setSession hscEnv+      df <- configureDynFlags cfg tmp+      prettyPrintGhcErrors df act++updateIncludePaths :: DynFlags -> [FilePath] -> IncludeSpecs+updateIncludePaths df ps = addGlobalInclude (includePaths df) ps++configureDynFlags :: Config -> FilePath -> Ghc DynFlags+configureDynFlags cfg tmp = do+  df <- getSessionDynFlags+  (df',_,_) <- parseDynamicFlags df $ map noLoc $ ghcOptions cfg+  loud <- liftIO isLoud+  let df'' = df' { importPaths  = nub $ idirs cfg ++ importPaths df'+                 , libraryPaths = nub $ idirs cfg ++ libraryPaths df'+                 , includePaths = updateIncludePaths df' (idirs cfg) -- addGlobalInclude (includePaths df') (idirs cfg)+                 , packageFlags = ExposePackage ""+                                                (PackageArg "ghc-prim")+                                                (ModRenaming True [])+                                : packageFlags df'++                 , debugLevel   = 1               -- insert SourceNotes+                 -- , profAuto     = ProfAutoCalls+                 , ghcLink      = LinkInMemory+                 , hscTarget    = HscInterpreted+                 , ghcMode      = CompManager+                 -- prevent GHC from printing anything, unless in Loud mode+                 , log_action   = if loud+                                    then defaultLogAction+                                    else \_ _ _ _ _   -> return ()+                 -- redirect .hi/.o/etc files to temp directory+                 , objectDir    = Just tmp+                 , hiDir        = Just tmp+                 , stubDir      = Just tmp+                 } `gopt_set` Opt_ImplicitImportQualified+                   `gopt_set` Opt_PIC+                   `gopt_set` Opt_DeferTypedHoles+                   `xopt_set` MagicHash+                   `xopt_set` DeriveGeneric+                   `xopt_set` StandaloneDeriving+  _ <- setSessionDynFlags df''+  return df''++configureGhcTargets :: [FilePath] -> Ghc ModuleGraph+configureGhcTargets tgtFiles = do+  targets         <- mapM (`guessTarget` Nothing) tgtFiles+  _               <- setTargets targets+  moduleGraph     <- depanal [] False -- see [NOTE:DROP-BOOT-FILES]++  let homeModules  = filter (not . isBootInterface . isBootSummary) $+                     flattenSCCs $ topSortModuleGraph False moduleGraph Nothing+  let homeNames    = moduleName . ms_mod <$> homeModules+  _               <- setTargetModules homeNames+  liftIO $ whenLoud $ print ("Module Dependencies" :: String, homeNames)+  return $ mkModuleGraph homeModules++setTargetModules :: [ModuleName] -> Ghc ()+setTargetModules modNames = setTargets $ mkTarget <$> modNames+  where+    mkTarget modName = Ghc.Target (TargetModule modName) True Nothing++compileCFiles :: Config -> Ghc ()+compileCFiles cfg = do+  df  <- getSessionDynFlags+  _   <- setSessionDynFlags $+           df { includePaths = updateIncludePaths df (idirs cfg)+              , importPaths  = nub $ idirs cfg ++ importPaths df+              , libraryPaths = nub $ idirs cfg ++ libraryPaths df }+  hsc <- getSession+  os  <- mapM (\x -> liftIO $ compileFile hsc StopLn (x,Nothing)) (nub $ cFiles cfg)+  df'  <- getSessionDynFlags+  void $ setSessionDynFlags $ df' { ldInputs = nub $ map (FileOption "") os ++ ldInputs df' }++{- | [NOTE:DROP-BOOT-FILES] Drop hs-boot files from the graph.+      We do it manually rather than using the flag to topSortModuleGraph+      because otherwise the order of mutually recursive modules depends+      on the modulename, e.g. given++      Bar.hs --> Foo.hs --> Bar.hs-boot++      we'll get++      [Bar.hs, Foo.hs]++      which is backwards..+ -}+--------------------------------------------------------------------------------+-- Home Module Dependency Graph ------------------------------------------------+--------------------------------------------------------------------------------++type DepGraph = Graph DepGraphNode+type DepGraphNode = Node Module ()++reachableModules :: DepGraph -> Module -> [Module]+reachableModules depGraph mod' =+  node_key <$> tail (reachableG depGraph (DigraphNode () mod' []))++buildDepGraph :: ModuleGraph -> Ghc DepGraph+buildDepGraph homeModules =+  graphFromEdgedVerticesOrd <$> mapM mkDepGraphNode (mgModSummaries homeModules)++mkDepGraphNode :: ModSummary -> Ghc DepGraphNode+mkDepGraphNode modSummary =+  DigraphNode () (ms_mod modSummary) <$> (filterM isHomeModule =<< modSummaryImports modSummary)++isHomeModule :: GhcMonadLike m => Module -> m Bool+isHomeModule mod' = do+  homePkg <- thisPackage <$> getDynFlags+  return   $ moduleUnitId mod' == homePkg++modSummaryImports :: GhcMonadLike m => ModSummary -> m [Module]+modSummaryImports modSummary =+  mapM (importDeclModule (ms_mod modSummary))+       (ms_textual_imps modSummary)++importDeclModule :: GhcMonadLike m => Module -> (Maybe FastString,  Ghc.Located ModuleName) -> m Module+importDeclModule fromMod (mpkgQual, locModName) = do+  hscEnv <- askHscEnv+  let modName = unLoc locModName+  res <- liftIO $ findImportedModule hscEnv modName mpkgQual+  case res of+    Ghc.Found _ mod' -> return mod'+    _ -> do+      dflags <- getDynFlags+      liftIO $ throwGhcExceptionIO $ ProgramError $+        O.showPpr dflags (moduleName fromMod) ++ ": " +++        O.showSDoc dflags (cannotFindModule dflags modName res)++--------------------------------------------------------------------------------+-- | Extract Ids ---------------------------------------------------------------+--------------------------------------------------------------------------------++classCons :: Maybe [ClsInst] -> [Id]+classCons Nothing   = []+classCons (Just cs) = concatMap (dataConImplicitIds . head . tyConDataCons . classTyCon . is_cls) cs++derivedVars :: Config -> MGIModGuts -> [Var]+derivedVars cfg mg  = concatMap (dFunIdVars cbs . is_dfun) derInsts+  where+    derInsts+      | checkDer    = insts+      | otherwise   = filter isDerivedInstance insts+    insts           = mgClsInstances mg+    checkDer        = checkDerived cfg+    cbs             = mgi_binds mg+++mgClsInstances :: MGIModGuts -> [ClsInst]+mgClsInstances = fromMaybe [] . mgi_cls_inst++dFunIdVars :: CoreProgram -> DFunId -> [Id]+dFunIdVars cbs fd  = notracepp msg $ concatMap bindersOf cbs' ++ deps+  where+    msg            = "DERIVED-VARS-OF: " ++ showpp fd+    cbs'           = filter f cbs+    f (NonRec x _) = eqFd x+    f (Rec xes)    = any eqFd (fst <$> xes)+    eqFd x         = varName x == varName fd+    deps           = concatMap unfoldDep unfolds+    unfolds        = unfoldingInfo . idInfo <$> concatMap bindersOf cbs'++unfoldDep :: Unfolding -> [Id]+unfoldDep (DFunUnfolding _ _ e)       = concatMap exprDep e+unfoldDep CoreUnfolding {uf_tmpl = e} = exprDep e+unfoldDep _                           = []++exprDep :: CoreExpr -> [Id]+exprDep = freeVars S.empty++importVars :: CoreProgram -> [Id]+importVars = freeVars S.empty++_definedVars :: CoreProgram -> [Id]+_definedVars = concatMap defs+  where+    defs (NonRec x _) = [x]+    defs (Rec xes)    = map fst xes++--------------------------------------------------------------------------------+-- | Per-Module Pipeline -------------------------------------------------------+--------------------------------------------------------------------------------++type SpecEnv = ModuleEnv (ModName, Ms.BareSpec)++processModules :: Config -> LogicMap -> [FilePath] -> DepGraph -> ModuleGraph -> Ghc [TargetInfo]+processModules cfg logicMap tgtFiles depGraph homeModules = do+  -- DO NOT DELETE: liftIO $ putStrLn $ "Process Modules: TargetFiles = " ++ show tgtFiles+  catMaybes . snd <$> Misc.mapAccumM go emptyModuleEnv (mgModSummaries homeModules)+  where+    go = processModule cfg logicMap (S.fromList tgtFiles) depGraph++processModule :: Config -> LogicMap -> S.HashSet FilePath -> DepGraph -> SpecEnv -> ModSummary+              -> Ghc (SpecEnv, Maybe TargetInfo)+processModule cfg logicMap tgtFiles depGraph specEnv modSummary = do+  let mod'             = ms_mod modSummary+  -- DO-NOT-DELETE _                <- liftIO $ whenLoud $ putStrLn $ "Process Module: " ++ showPpr (moduleName mod)+  file                <- liftIO $ canonicalizePath $ modSummaryHsFile modSummary+  let isTarget'        = file `S.member` tgtFiles+  _                   <- loadDependenciesOf $ moduleName mod'+  parsed              <- parseModule $ keepRawTokenStream modSummary+  let specComments     = extractSpecComments (pm_annotations parsed)+  typechecked         <- typecheckModule $ ignoreInline parsed+  let specQuotes       = extractSpecQuotes typechecked+  _                   <- loadModule' typechecked+  (modName, commSpec) <- either throw return $ hsSpecificationP (moduleName mod') specComments specQuotes++  liftedSpec          <- liftIO $ if isTarget' || null specComments then return Nothing else loadLiftedSpec cfg file+  let bareSpec         = updLiftedSpec commSpec liftedSpec+  _                   <- checkFilePragmas $ Ms.pragmas bareSpec+  let specEnv'         = extendModuleEnv specEnv mod' (modName, noTerm bareSpec)+  (specEnv', ) <$> if isTarget'+                     then Just <$> processTargetModule cfg logicMap depGraph specEnv file typechecked bareSpec+                     else return Nothing++updLiftedSpec :: Ms.BareSpec -> Maybe Ms.BareSpec -> Ms.BareSpec+updLiftedSpec s1 Nothing   = s1+updLiftedSpec s1 (Just s2) = clearSpec s1 `mappend` s2++clearSpec :: Ms.BareSpec -> Ms.BareSpec+clearSpec s = s { sigs = [], asmSigs = [], aliases = [], ealiases = [], qualifiers = [], dataDecls = [] }++keepRawTokenStream :: ModSummary -> ModSummary+keepRawTokenStream modSummary = modSummary+  { ms_hspp_opts = ms_hspp_opts modSummary `gopt_set` Opt_KeepRawTokenStream }++loadDependenciesOf :: GhcMonad m => ModuleName -> m ()+loadDependenciesOf modName = do+  loadResult <- load $ LoadDependenciesOf modName+  when (failed loadResult) $ liftIO $ throwGhcExceptionIO $ ProgramError $+   "Failed to load dependencies of module " ++ showPpr modName++loadModule' :: TypecheckedModule -> Ghc TypecheckedModule+loadModule' tm = loadModule tm'+  where+    pm   = tm_parsed_module tm+    ms   = pm_mod_summary pm+    df   = ms_hspp_opts ms+    df'  = df { hscTarget = HscNothing, ghcLink = NoLink }+    ms'  = ms { ms_hspp_opts = df' }+    pm'  = pm { pm_mod_summary = ms' }+    tm'  = tm { tm_parsed_module = pm' }+++++      -- -- we should be able to setContext regardless of whether+      -- -- we use the ghc api. However, ghc will complain+      -- -- if the filename does not match the module name+      -- when (typeclass cfg) $ do+      --   Ghc.setContext [iimport |(modName, _) <- allSpecs legacyBareSpec,+      --                   let iimport = if isTarget modName+      --                                 then Ghc.IIModule (getModName modName)+      --                                 else Ghc.IIDecl (Ghc.simpleImportDecl (getModName modName))]+      --   void $ Ghc.execStmt+      --     "let {infixr 1 ==>; True ==> False = False; _ ==> _ = True}"+      --     Ghc.execOptions+      --   void $ Ghc.execStmt+      --     "let {infixr 1 <=>; True <=> False = False; _ <=> _ = True}"+      --     Ghc.execOptions+      --   void $ Ghc.execStmt+      --     "let {infix 4 ==; (==) :: a -> a -> Bool; _ == _ = undefined}"+      --     Ghc.execOptions+      --   void $ Ghc.execStmt+      --     "let {infix 4 /=; (/=) :: a -> a -> Bool; _ /= _ = undefined}"+      --     Ghc.execOptions+      --   void $ Ghc.execStmt+      --     "let {infixl 7 /; (/) :: Num a => a -> a -> a; _ / _ = undefined}"+      --     Ghc.execOptions+      --   void $ Ghc.execStmt+      --     "let {len :: [a] -> Int; len _ = undefined}"+      --     Ghc.execOptions+processTargetModule :: Config -> LogicMap -> DepGraph -> SpecEnv -> FilePath -> TypecheckedModule -> Ms.BareSpec+                    -> Ghc TargetInfo+processTargetModule cfg0 logicMap depGraph specEnv file typechecked bareSpec = do+  withPragmas cfg0 file (Ms.pragmas bareSpec) $ \cfg -> do+    let modSum    = pm_mod_summary (tm_parsed_module typechecked)+    ghcSrc       <- makeGhcSrc    cfg file     typechecked modSum+    dependencies <- makeDependencies cfg depGraph specEnv modSum bareSpec++    let targetSrc = view targetSrcIso ghcSrc+    dynFlags <- getDynFlags+  -- set up the interactive context+    when (typeclass cfg) $+      loadContext (view bareSpecIso bareSpec) dependencies targetSrc+    (msgs, specM) <- Ghc.withSession $ \hsc_env -> liftIO $ runTcInteractive hsc_env+      (makeTargetSpec cfg logicMap targetSrc (view bareSpecIso bareSpec) dependencies)+    case specM of+      Nothing -> panic Nothing  $ O.showSDoc dynFlags $ O.sep (Ghc.pprErrMsgBagWithLoc (snd msgs))+      Just spec ->+        case spec of+          Left diagnostics -> do+            mapM_ (liftIO . printWarning dynFlags) (allWarnings diagnostics)+            throw (allErrors diagnostics)+          Right (warns, targetSpec, liftedSpec) -> do+            mapM_ (liftIO . printWarning dynFlags) warns+            -- The call below is temporary, we should really load & save directly 'LiftedSpec's.+            _          <- liftIO $ saveLiftedSpec (_giTarget ghcSrc) (unsafeFromLiftedSpec liftedSpec)+            return      $ TargetInfo targetSrc targetSpec++  -- cfg          <- liftIO $ withPragmas cfg0 file (Ms.pragmas bareSpec)+  -- let modSum    = pm_mod_summary (tm_parsed_module typechecked)+  -- ghcSrc       <- makeGhcSrc    cfg file     typechecked modSum+  -- dependencies <- makeDependencies cfg depGraph specEnv modSum bareSpec++  -- let targetSrc = view targetSrcIso ghcSrc+  -- dynFlags <- getDynFlags+  -- -- set up the interactive context+  -- when (typeclass cfg) $+  --   loadContext (view bareSpecIso bareSpec) dependencies targetSrc+  -- (msgs, specM) <- Ghc.withSession $ \hsc_env -> liftIO $ runTcInteractive hsc_env+  --   (makeTargetSpec cfg logicMap targetSrc (view bareSpecIso bareSpec) dependencies)+  -- case specM of+  --   Nothing -> panic Nothing  $ O.showSDoc dynFlags $ O.sep (Ghc.pprErrMsgBagWithLoc (snd msgs))+  --   Just spec ->+  --     case spec of+  --       Left diagnostics -> do+  --         mapM_ (liftIO . printWarning dynFlags) (allWarnings diagnostics)+  --         throw (allErrors diagnostics)+  --       Right (warns, targetSpec, liftedSpec) -> do+  --         mapM_ (liftIO . printWarning dynFlags) warns++  --     -- makeTargetSpec cfg logicMap targetSrc (view bareSpecIso bareSpec) dependencies >>= \case+  --     --   Left  validationErrors -> Bare.checkThrow (Left validationErrors)+  --     --   Right (targetSpec, liftedSpec) -> do++  --     -- The call below is temporary, we should really load & save directly 'LiftedSpec's.+  --         _          <- liftIO $ saveLiftedSpec (_giTarget ghcSrc) (unsafeFromLiftedSpec liftedSpec)+  --         return      $ TargetInfo targetSrc targetSpec+++loadContext :: BareSpec -> TargetDependencies -> TargetSrc -> Ghc ()+loadContext bareSpec dependencies targetSrc = do+  Ghc.setContext $ [Ghc.IIModule (getModName modName) |(modName, _) <- allSpecs legacyBareSpec,+                    isTarget modName]++  where+    toLegacyDep :: (StableModule, LiftedSpec) -> (ModName, Ms.BareSpec)+    toLegacyDep (sm, ls) = (ModName SrcImport (Ghc.moduleName . unStableModule $ sm), unsafeFromLiftedSpec ls)++    toLegacyTarget :: Ms.BareSpec -> (ModName, Ms.BareSpec)+    toLegacyTarget validatedSpec = (giTargetMod targetSrc, validatedSpec)++    legacyDependencies :: [(ModName, Ms.BareSpec)]+    legacyDependencies = map toLegacyDep . HM.toList . getDependencies $ dependencies++    allSpecs :: Ms.BareSpec -> [(ModName, Ms.BareSpec)]+    allSpecs validSpec = toLegacyTarget validSpec : legacyDependencies++    -- legacyBareSpec :: Spec LocBareType F.LocSymbol+    legacyBareSpec = review bareSpecIso bareSpec++---------------------------------------------------------------------------------------+-- | @makeGhcSrc@ builds all the source-related information needed for consgen+---------------------------------------------------------------------------------------++makeGhcSrc :: Config -> FilePath -> TypecheckedModule -> ModSummary -> Ghc GhcSrc+makeGhcSrc cfg file typechecked modSum = do+  modGuts'          <- GhcMonadLike.desugarModule modSum typechecked++  let modGuts        = makeMGIModGuts modGuts'+  hscEnv            <- getSession+  coreBinds         <- liftIO $ anormalize cfg hscEnv modGuts'+  _                 <- liftIO $ whenNormal $ Misc.donePhase Misc.Loud "A-Normalization"+  let dataCons       = concatMap (map dataConWorkId . tyConDataCons) (mgi_tcs modGuts)+  (fiTcs, fiDcs)    <- makeFamInstEnv <$> liftIO (getFamInstances hscEnv)+  things            <- lookupTyThings hscEnv modSum (fst $ tm_internals_ typechecked)++  availableTcs      <- availableTyCons hscEnv modSum (fst $ tm_internals_ typechecked) (mg_exports modGuts')++  let impVars        = importVars coreBinds ++ classCons (mgi_cls_inst modGuts)+  incDir            <- liftIO Misc.getIncludeDir++  --liftIO $ do+  --  print $ "_gsTcs   => " ++ show (nub $ (mgi_tcs      modGuts) ++ availableTcs)+  --  print $ "_gsFiTcs => " ++ show fiTcs+  --  print $ "_gsFiDcs => " ++ show fiDcs+  --  print $ "dataCons => " ++ show dataCons+  --  print $ "defVars  => " ++ show (dataCons ++ (letVars coreBinds))++  return $ Src+    { _giIncDir    = incDir+    , _giTarget    = file+    , _giTargetMod = ModName Target (moduleName (ms_mod modSum))+    , _giCbs       = coreBinds+    , _giImpVars   = impVars+    , _giDefVars   = dataCons ++ letVars coreBinds+    , _giUseVars   = readVars coreBinds+    , _giDerVars   = S.fromList (derivedVars cfg modGuts)+    , _gsExports   = mgi_exports  modGuts+    , _gsTcs       = nub $ mgi_tcs modGuts ++ availableTcs+    , _gsCls       = mgi_cls_inst modGuts+    , _gsFiTcs     = fiTcs+    , _gsFiDcs     = fiDcs+    , _gsPrimTcs   = Ghc.primTyCons+    , _gsQualImps  = qualifiedImports (maybe mempty (view _2) (tm_renamed_source typechecked))+    , _gsAllImps   = allImports       (maybe mempty (view _2) (tm_renamed_source typechecked))+    , _gsTyThings  = [ t | (_, Just t) <- things ]+    }++_impThings :: [Var] -> [TyThing] -> [TyThing]+_impThings vars  = filter ok+  where+    vs          = S.fromList vars+    ok (AnId x) = S.member x vs+    ok _        = True++allImports :: [LImportDecl GhcRn] -> S.HashSet Symbol+allImports = \case+  []-> Debug.trace "WARNING: Missing RenamedSource" mempty+  imps -> S.fromList (symbol . unLoc . ideclName . unLoc <$> imps)++qualifiedImports :: [LImportDecl GhcRn] -> QImports+qualifiedImports = \case+  []   -> Debug.trace "WARNING: Missing RenamedSource" (qImports mempty)+  imps -> qImports [ (qn, n) | i         <- imps+                                          , let decl   = unLoc i+                                          , let m      = unLoc (ideclName decl)+                                          , qm        <- maybeToList (unLoc <$> ideclAs decl)+                                          , let [n,qn] = symbol <$> [m, qm]+                                          ]++qImports :: [(Symbol, Symbol)] -> QImports+qImports qns  = QImports+  { qiNames   = Misc.group qns+  , qiModules = S.fromList (snd <$> qns)+  }+++---------------------------------------------------------------------------------------+-- | @lookupTyThings@ grabs all the @Name@s and associated @TyThing@ known to GHC+--   for this module; we will use this to create our name-resolution environment+--   (see `Bare.Resolve`)+---------------------------------------------------------------------------------------+lookupTyThings :: GhcMonadLike m => HscEnv -> ModSummary -> TcGblEnv -> m [(Name, Maybe TyThing)]+lookupTyThings hscEnv modSum tcGblEnv = forM names (lookupTyThing hscEnv modSum tcGblEnv)+  where+    names :: [Ghc.Name]+    names  = liftM2 (++)+             (fmap Ghc.gre_name . Ghc.globalRdrEnvElts . tcg_rdr_env)+             (fmap is_dfun_name . tcg_insts) tcGblEnv+-- | Lookup a single 'Name' in the GHC environment, yielding back the 'Name' alongside the 'TyThing',+-- if one is found.+lookupTyThing :: GhcMonadLike m => HscEnv -> ModSummary -> TcGblEnv -> Name -> m (Name, Maybe TyThing)+lookupTyThing hscEnv modSum tcGblEnv n = do+  mi  <- GhcMonadLike.moduleInfoTc modSum tcGblEnv+  tt1 <-          GhcMonadLike.lookupName      n+  tt2 <- liftIO $ Ghc.hscTcRcLookupName hscEnv n+  tt3 <-          GhcMonadLike.modInfoLookupName mi n+  tt4 <-          GhcMonadLike.lookupGlobalName n+  return (n, Misc.firstMaybes [tt1, tt2, tt3, tt4])++availableTyThings :: GhcMonadLike m => HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> m [TyThing]+availableTyThings hscEnv modSum tcGblEnv avails = fmap (catMaybes . mconcat) $ forM avails $ \a -> do+  results <- case a of+    Avail n        -> pure <$> lookupTyThing hscEnv modSum tcGblEnv n+    AvailTC n ns _ -> forM (n : ns) $ lookupTyThing hscEnv modSum tcGblEnv+  pure . map snd $ results++-- | Returns all the available (i.e. exported) 'TyCon's (type constructors) for the input 'Module'.+availableTyCons :: GhcMonadLike m => HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> m [Ghc.TyCon]+availableTyCons hscEnv modSum tcGblEnv avails =+  fmap (\things -> [tyCon | (ATyCon tyCon) <- things]) (availableTyThings hscEnv modSum tcGblEnv avails)++-- | Returns all the available (i.e. exported) 'Var's for the input 'Module'.+availableVars :: GhcMonadLike m => HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> m [Ghc.Var]+availableVars hscEnv modSum tcGblEnv avails =+  fmap (\things -> [var | (AnId var) <- things]) (availableTyThings hscEnv modSum tcGblEnv avails)++-- lookupTyThings :: HscEnv -> TypecheckedModule -> MGIModGuts -> Ghc [(Name, Maybe TyThing)]+-- lookupTyThings hscEnv tcm mg =+--   forM (mgNames mg ++ instNames mg) $ \n -> do+--     tt1 <-          lookupName                   n+--     tt2 <- liftIO $ Ghc.hscTcRcLookupName hscEnv n+--     tt3 <-          modInfoLookupName mi         n+--     tt4 <-          lookupGlobalName             n+--     return (n, Misc.firstMaybes [tt1, tt2, tt3, tt4])+--     where+--       mi = tm_checked_module_info tcm+++-- lookupName        :: GhcMonad m => Name -> m (Maybe TyThing)+-- hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)+-- modInfoLookupName :: GhcMonad m => ModuleInfo -> Name -> m (Maybe TyThing)+-- lookupGlobalName  :: GhcMonad m => Name -> m (Maybe TyThing)++_dumpTypeEnv :: TypecheckedModule -> IO ()+_dumpTypeEnv tm = do+  print ("DUMP-TYPE-ENV" :: String)+  print (showpp <$> tcmTyThings tm)++tcmTyThings :: TypecheckedModule -> Maybe [Name]+tcmTyThings+  =+  -- typeEnvElts+  -- . tcg_type_env . fst+  -- . md_types . snd+  -- . tm_internals_+  modInfoTopLevelScope+  . tm_checked_module_info+++_dumpRdrEnv :: HscEnv -> MGIModGuts -> IO ()+_dumpRdrEnv _hscEnv modGuts = do+  print ("DUMP-RDR-ENV" :: String)+  print (mgNames modGuts)+  -- print (hscNames hscEnv)+  -- print (mgDeps modGuts)+  where+    _mgDeps   = Ghc.dep_mods . mgi_deps+    _hscNames = fmap showPpr . Ghc.ic_tythings . Ghc.hsc_IC++mgNames :: MGIModGuts -> [Ghc.Name]+mgNames  = fmap Ghc.gre_name . Ghc.globalRdrEnvElts .  mgi_rdr_env++---------------------------------------------------------------------------------------+-- | @makeDependencies@ loads BareSpec for target and imported modules+-- /IMPORTANT(adn)/: We \"cheat\" a bit by creating a 'Module' out the 'ModuleName' we+-- parse from the spec, and convert the former into a 'StableModule' for the purpose+-- of dependency tracking. This means, in practice, that all the \"wired-in-prelude\"+-- specs will share the same `UnitId`, which for the sake of the executable is an+-- acceptable compromise, as long as we don't create duplicates.+---------------------------------------------------------------------------------------+makeDependencies :: Config -> DepGraph -> SpecEnv -> ModSummary -> Ms.BareSpec+                 -> Ghc TargetDependencies+makeDependencies cfg depGraph specEnv modSum _ = do+  let paths     = S.fromList $ idirs cfg ++ importPaths (ms_hspp_opts modSum)+  _            <- liftIO $ whenLoud $ putStrLn $ "paths = " ++ show paths+  let reachable = reachableModules depGraph (ms_mod modSum)+  specSpecs    <- findAndParseSpecFiles cfg paths modSum reachable+  let homeSpecs = cachedBareSpecs specEnv reachable++  -- NOTE:(adn) Unfortunately for the executable we might have 3 different 'Prelude' specs+  -- (one for the Prelude functions, one for the Real/NonReal and one for the PatErr, so we+  -- cannot really assume all the module names will be disjointed. As a result we have to+  -- hack our way around this by replacing the 'UnitId' with some unique enumeration, at+  -- least unique in this local scope.++  let combine' ix (mn, sp) = ((mn, ix), sp)+  let impSpecs  = map (bimap mkStableModule (view liftedSpecGetter)) (zipWith combine' [0..] (specSpecs ++ homeSpecs))++  return        $ TargetDependencies $ HM.fromList impSpecs+  where+    mkStableModule :: (ModName, Int) -> StableModule+    mkStableModule (modName, ix) =+      Ghc.mkStableModule (fakeUnitId (moduleUnitId targetModule) ix) (getModName modName)++    fakeUnitId :: UnitId -> Int -> UnitId+    fakeUnitId uid ix = stringToUnitId $ unitIdString uid ++ show ix++    targetModule :: Module+    targetModule = ms_mod modSum++modSummaryHsFile :: ModSummary -> FilePath+modSummaryHsFile modSummary =+  fromMaybe+    (panic Nothing $+      "modSummaryHsFile: missing .hs file for " +++      showPpr (ms_mod modSummary))+    (ml_hs_file $ ms_location modSummary)++cachedBareSpecs :: SpecEnv -> [Module] -> [(ModName, Ms.BareSpec)]+cachedBareSpecs specEnv mods = lookupBareSpec <$> mods+  where+    lookupBareSpec m         = fromMaybe (err m) (lookupModuleEnv specEnv m)+    err m                    = impossible Nothing ("lookupBareSpec: missing module " ++ showPpr m)++checkFilePragmas :: GhcMonadLike m => [Located String] -> m ()+checkFilePragmas = Misc.applyNonNull (return ()) throw . mapMaybe err+  where+    err pragma+      | check (val pragma) = Just (ErrFilePragma $ fSrcSpan pragma :: Error)+      | otherwise          = Nothing+    check pragma           = any (`isPrefixOf` pragma) bad+    bad =+      [ "-i", "--idirs"+      , "-g", "--ghc-option"+      , "--c-files", "--cfiles"+      ]++--------------------------------------------------------------------------------+-- | Family instance information+--------------------------------------------------------------------------------+makeFamInstEnv :: [FamInst] -> ([Ghc.TyCon], [(Symbol, DataCon)])+makeFamInstEnv famInsts =+  let fiTcs = [ tc            | FamInst { fi_flavor = DataFamilyInst tc } <- famInsts ]+      fiDcs = [ (symbol d, d) | tc <- fiTcs, d <- tyConDataCons tc ]+  in (fiTcs, fiDcs)++getFamInstances :: HscEnv -> IO [FamInst]+getFamInstances env = do+  (_, Just (pkg_fie, home_fie)) <- runTcInteractive env tcGetFamInstEnvs+  return $ famInstEnvElts home_fie ++ famInstEnvElts pkg_fie++--------------------------------------------------------------------------------+-- | Extract Specifications from GHC -------------------------------------------+--------------------------------------------------------------------------------+extractSpecComments :: ApiAnns -> [(SourcePos, String)]+extractSpecComments = mapMaybe extractSpecComment . GhcMonadLike.apiComments++-- | 'extractSpecComment' pulls out the specification part from a full comment+--   string, i.e. if the string is of the form:+--   1. '{-@ S @-}' then it returns the substring 'S',+--   2. '{-@ ... -}' then it throws a malformed SPECIFICATION ERROR, and+--   3. Otherwise it is just treated as a plain comment so we return Nothing.++extractSpecComment :: Ghc.Located AnnotationComment -> Maybe (SourcePos, String)+extractSpecComment (Ghc.L sp (AnnBlockComment txt))+  | isPrefixOf "{-@" txt && isSuffixOf "@-}" txt          -- valid   specification+  = Just (offsetPos, take (length txt - 6) $ drop 3 txt)+  | isPrefixOf "{-@" txt                                   -- invalid specification+  = uError $ ErrParseAnn sp "A valid specification must have a closing '@-}'."+  where+    offsetPos = case srcSpanSourcePos sp of+      SourcePos file line col -> safeSourcePos file (unPos line) (unPos col + 3)+extractSpecComment _ = Nothing++extractSpecQuotes :: TypecheckedModule -> [BPspec]+extractSpecQuotes =+  extractSpecQuotes' (ms_mod . pm_mod_summary . tm_parsed_module)+                     (tcg_anns . fst . tm_internals_)++extractSpecQuotes' :: (a -> Module) -> (a -> [Annotation]) -> a -> [BPspec]+extractSpecQuotes' thisModule getAnns a = mapMaybe extractSpecQuote anns+  where+    anns = map ann_value $+           filter (isOurModTarget . ann_target) $+           getAnns a++    isOurModTarget (ModuleTarget mod1) = mod1 == thisModule a+    isOurModTarget _ = False++extractSpecQuote :: AnnPayload -> Maybe BPspec+extractSpecQuote payload =+  case Ghc.fromSerialized Ghc.deserializeWithData payload of+    Nothing -> Nothing+    Just qt -> Just $ refreshSymbols $ liquidQuoteSpec qt++refreshSymbols :: Data a => a -> a+refreshSymbols = everywhere (mkT refreshSymbol)++refreshSymbol :: Symbol -> Symbol+refreshSymbol = symbol . symbolText++--------------------------------------------------------------------------------+-- | Finding & Parsing Files ---------------------------------------------------+--------------------------------------------------------------------------------++-- | Handle Spec Files ---------------------------------------------------------++findAndParseSpecFiles :: GhcMonadLike m+                      => Config+                      -> S.HashSet FilePath+                      -> ModSummary+                      -> [Module]+                      -> m [(ModName, Ms.BareSpec)]+findAndParseSpecFiles cfg paths modSummary reachable = do+  modGraph <- GhcMonadLike.getModuleGraph+  impSumms <- mapM GhcMonadLike.getModSummary (moduleName <$> reachable)+  imps''   <- nub . concat <$> mapM modSummaryImports (modSummary : impSumms)+  imps'    <- filterM ((not <$>) . isHomeModule) imps''+  let imps  = m2s <$> imps'+  fs'      <- liftIO $ moduleFiles modGraph Spec paths imps+  -- liftIO  $ whenLoud  $ print ("moduleFiles-imps'': "  ++ show (m2s <$> imps''))+  -- liftIO  $ whenLoud  $ print ("moduleFiles-imps' : "  ++ show (m2s <$> imps'))+  -- liftIO  $ whenLoud  $ print ("moduleFiles-imps  : "  ++ show imps)+  -- liftIO  $ whenLoud  $ print ("moduleFiles-Paths : "  ++ show paths)+  -- liftIO  $ whenLoud  $ print ("moduleFiles-Specs : "  ++ show fs')+  patSpec  <- liftIO $ getPatSpec  modGraph paths $ totalityCheck cfg+  rlSpec   <- liftIO $ getRealSpec modGraph paths $ not (linear cfg)+  let fs    = patSpec ++ rlSpec ++ fs'+  liftIO $ transParseSpecs modGraph paths mempty mempty fs+  where+    m2s = moduleNameString . moduleName++getPatSpec :: ModuleGraph -> S.HashSet FilePath -> Bool -> IO [FilePath]+getPatSpec modGraph paths totalitycheck+ | totalitycheck = moduleFiles modGraph Spec paths [patErrorName]+ | otherwise     = return []+ where+  patErrorName   = "PatErr"++getRealSpec :: ModuleGraph -> S.HashSet FilePath -> Bool -> IO [FilePath]+getRealSpec modGraph paths freal+  | freal     = moduleFiles modGraph Spec paths [realSpecName]+  | otherwise = moduleFiles modGraph Spec paths [notRealSpecName]+  where+    realSpecName    = "Real"+    notRealSpecName = "NotReal"++transParseSpecs :: ModuleGraph+                -> S.HashSet FilePath+                -> S.HashSet FilePath+                -> [(ModName, Ms.BareSpec)]+                -> [FilePath]+                -> IO [(ModName, Ms.BareSpec)]+transParseSpecs _ _ _ specs [] = return specs+transParseSpecs modGraph paths seenFiles specs newFiles = do+  -- liftIO $ print ("TRANS-PARSE-SPECS", seenFiles, newFiles)+  newSpecs      <- liftIO $ mapM parseSpecFile newFiles+  impFiles      <- moduleFiles modGraph Spec paths $ specsImports newSpecs+  let seenFiles' = seenFiles `S.union` S.fromList newFiles+  let specs'     = specs ++ map (second noTerm) newSpecs+  let newFiles'  = filter (not . (`S.member` seenFiles')) impFiles+  transParseSpecs modGraph paths seenFiles' specs' newFiles'+  where+    specsImports ss = nub $ concatMap (map symbolString . Ms.imports . snd) ss++noTerm :: Ms.BareSpec -> Ms.BareSpec+noTerm spec = spec { Ms.decr = mempty, Ms.lazy = mempty, Ms.termexprs = mempty }++-- | Parse a spec file by path.+--+-- On a parse error, we fail.+--+-- TODO, Andres: It would be better to fail more systematically, but currently we+-- seem to have an option between throwing an error which will be reported badly,+-- or printing the error ourselves.+--+parseSpecFile :: FilePath -> IO (ModName, Ms.BareSpec)+parseSpecFile file = do+  contents <- Misc.sayReadFile file+  case specSpecificationP file contents of+    Left peb -> do+      hPutStrLn stderr (errorBundlePretty peb)+      panic Nothing "parsing spec file failed"+    Right x  -> pure x++-- Find Hquals Files -----------------------------------------------------------++-- _moduleHquals :: MGIModGuts+--              -> [FilePath]+--              -> FilePath+--              -> [String]+--              -> [FilePath]+--              -> Ghc [FilePath]+-- _moduleHquals mgi paths target imps incs = do+--   hqs   <- specIncludes Hquals paths incs+--   hqs'  <- moduleFiles Hquals paths (mgi_namestring mgi : imps)+--   hqs'' <- liftIO $ filterM doesFileExist [extFileName Hquals target]+--   return $ Misc.sortNub $ hqs'' ++ hqs ++ hqs'++-- Find Files for Modules ------------------------------------------------------++moduleFiles :: ModuleGraph -> Ext -> S.HashSet FilePath -> [String] -> IO [FilePath]+moduleFiles modGraph ext paths names = catMaybes <$> mapM (moduleFile modGraph ext paths) names++moduleFile :: ModuleGraph -> Ext -> S.HashSet FilePath -> String -> IO (Maybe FilePath)+moduleFile modGraph ext (S.toList -> paths) name+  | ext `elem` [Hs, LHs] = do+    let graph = mgModSummaries modGraph+    case find (\m -> not (isBootInterface . isBootSummary $ m) &&+                     name == moduleNameString (ms_mod_name m)) graph of+      Nothing -> getFileInDirs (extModuleName name ext) paths+      Just ms -> return $ normalise <$> ml_hs_file (ms_location ms)+  | otherwise = getFileInDirs (extModuleName name ext) paths+++--------------------------------------------------------------------------------+-- Assemble Information for Spec Extraction ------------------------------------+--------------------------------------------------------------------------------++makeMGIModGuts :: ModGuts -> MGIModGuts+makeMGIModGuts modGuts = miModGuts deriv modGuts+  where+    deriv   = Just $ instEnvElts $ mg_inst_env modGuts++makeLogicMap :: IO LogicMap+makeLogicMap = do+  lg    <- Misc.getCoreToLogicPath+  lspec <- Misc.sayReadFile lg+  case parseSymbolToLogic lg lspec of+    Left peb -> do+      hPutStrLn stderr (errorBundlePretty peb)+      panic Nothing "makeLogicMap failed"+    Right lm -> return (lm <> listLMap)++listLMap :: LogicMap -- TODO-REBARE: move to wiredIn+listLMap  = toLogicMap [ (dummyLoc nilName , []     , hNil)+                       , (dummyLoc consName, [x, xs], hCons (EVar <$> [x, xs])) ]+  where+    x     = "x"+    xs    = "xs"+    hNil  = mkEApp (dcSym Ghc.nilDataCon ) []+    hCons = mkEApp (dcSym Ghc.consDataCon)+    dcSym = dummyLoc . dropModuleUnique . symbol++++--------------------------------------------------------------------------------+-- | Pretty Printing -----------------------------------------------------------+--------------------------------------------------------------------------------++instance PPrint TargetSpec where+  pprintTidy k spec = vcat+    [ "******* Target Variables ********************"+    , pprintTidy k $ gsTgtVars (gsVars spec)+    , "******* Type Signatures *********************"+    , pprintLongList k (gsTySigs (gsSig spec))+    , "******* Assumed Type Signatures *************"+    , pprintLongList k (gsAsmSigs (gsSig spec))+    , "******* DataCon Specifications (Measure) ****"+    , pprintLongList k (gsCtors (gsData spec))+    , "******* Measure Specifications **************"+    , pprintLongList k (gsMeas (gsData spec))       ]++instance PPrint TargetInfo where+  pprintTidy k info = vcat+    [ -- "*************** Imports *********************"+      -- , intersperse comma $ text <$> imports info+      -- , "*************** Includes ********************"+      -- , intersperse comma $ text <$> includes info+      "*************** Imported Variables **********"+    , pprDoc $ _giImpVars (review targetSrcIso $ giSrc info)+    , "*************** Defined Variables ***********"+    , pprDoc $ _giDefVars (review targetSrcIso $ giSrc info)+    , "*************** Specification ***************"+    , pprintTidy k $ giSpec info+    , "*************** Core Bindings ***************"+    , pprintCBs $ _giCbs (review targetSrcIso $ giSrc info) ]++pprintCBs :: [CoreBind] -> Doc+pprintCBs = pprDoc . tidyCBs+    -- To print verbosely+    --    = text . O.showSDocDebug unsafeGlobalDynFlags . O.ppr . tidyCBs++instance Show TargetInfo where+  show = showpp++instance PPrint TargetVars where+  pprintTidy _ AllVars   = text "All Variables"+  pprintTidy k (Only vs) = text "Only Variables: " <+> pprintTidy k vs++------------------------------------------------------------------------+-- Dealing with Errors ---------------------------------------------------+------------------------------------------------------------------------++instance Result SourceError where+  result e = Crash ((, Nothing) <$> sourceErrors "" e) "Invalid Source"
+ src-ghc/Liquid/GHC/Logging.hs view
@@ -0,0 +1,52 @@+{- | This module exposes variations over the standard GHC's logging functions to work with the 'Doc'+     type from the \"pretty\" package. We would like LiquidHaskell to emit diagnostic messages using the very+     same GHC machinery, so that IDE-like programs (e.g. \"ghcid\", \"ghcide\" etc) would be able to+     correctly show errors and warnings to the users, in ther editors.++     Unfortunately, this is not possible to do out of the box because LiquidHaskell uses the 'Doc' type from+     the \"pretty\" package but GHC uses (for historical reasons) its own version. Due to the fact none of+     the constructors are exported, we simply cannot convert between the two types effortlessly, but we have+     to pay the price of a pretty-printing \"roundtrip\".+-}++module Liquid.GHC.Logging (+    fromPJDoc+  , putWarnMsg+  , putErrMsg+  , mkLongErrAt+  ) where++import qualified Liquid.GHC.API as GHC+import qualified Text.PrettyPrint.HughesPJ as PJ++-- Unfortunately we need the import below to bring in scope 'PPrint' instances.+import Language.Haskell.Liquid.Types.Errors ()++fromPJDoc :: PJ.Doc -> GHC.SDoc+fromPJDoc = GHC.text . PJ.render++-- | Like the original 'putLogMsg', but internally converts the input 'Doc' (from the \"pretty\" library)+-- into GHC's internal 'SDoc'.+putLogMsg :: GHC.DynFlags+          -> GHC.WarnReason+          -> GHC.Severity+          -> GHC.SrcSpan+          -> Maybe GHC.PprStyle+          -> PJ.Doc+          -> IO ()+putLogMsg dynFlags reason sev srcSpan _mbStyle =+  GHC.putLogMsg dynFlags reason sev srcSpan . GHC.text . PJ.render++defaultErrStyle :: GHC.DynFlags -> GHC.PprStyle+defaultErrStyle _dynFlags = GHC.defaultErrStyle++putWarnMsg :: GHC.DynFlags -> GHC.SrcSpan -> PJ.Doc -> IO ()+putWarnMsg dynFlags srcSpan doc =+  putLogMsg dynFlags GHC.NoReason GHC.SevWarning srcSpan (Just $ defaultErrStyle dynFlags) doc++putErrMsg :: GHC.DynFlags -> GHC.SrcSpan -> PJ.Doc -> IO ()+putErrMsg dynFlags srcSpan doc = putLogMsg dynFlags GHC.NoReason GHC.SevError srcSpan Nothing doc++-- | Like GHC's 'mkLongErrAt', but it builds the final 'ErrMsg' out of two \"HughesPJ\"'s 'Doc's.+mkLongErrAt :: GHC.SrcSpan -> PJ.Doc -> PJ.Doc -> GHC.TcRn GHC.ErrMsg+mkLongErrAt srcSpan msg extra = GHC.mkLongErrAt srcSpan (fromPJDoc msg) (fromPJDoc extra)
+ src-ghc/Liquid/GHC/Misc.hs view
@@ -0,0 +1,1097 @@+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE TupleSections             #-}+{-# LANGUAGE TypeSynonymInstances      #-}+{-# LANGUAGE UndecidableInstances      #-}+{-# LANGUAGE ViewPatterns              #-}+{-# LANGUAGE PatternSynonyms           #-}++{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- TODO(#1918): Only needed for GHC <9.0.1.+{-# OPTIONS_GHC -Wno-orphans #-}++-- | This module contains a wrappers and utility functions for+-- accessing GHC module information. It should NEVER depend on+-- ANY module inside the Language.Haskell.Liquid.* tree.++module Liquid.GHC.Misc where++import           Data.String+import qualified Data.List as L+import           Debug.Trace++import           Prelude                                    hiding (error)+import           Liquid.GHC.API            as Ghc hiding ( L+                                                                          , sourceName+                                                                          , showPpr+                                                                          , showSDocDump+                                                                          , panic+                                                                          , showSDoc+                                                                          )+import qualified Liquid.GHC.API            as Ghc (GenLocated (L), showSDoc, panic, showSDocDump)+++import           Data.Char                                  (isLower, isSpace, isUpper)+import           Data.Maybe                                 (isJust, fromMaybe, fromJust, maybeToList)+import           Data.Hashable+import qualified Data.HashSet                               as S+import qualified Data.Map.Strict                            as OM+import           Control.Monad.State                        (evalState, get, modify)++import qualified Data.Text.Encoding.Error                   as TE+import qualified Data.Text.Encoding                         as T+import qualified Data.Text                                  as T+import           Control.Arrow                              (second)+import           Control.Monad                              ((>=>), foldM)+import qualified Text.PrettyPrint.HughesPJ                  as PJ+import           Language.Fixpoint.Types                    hiding (L, panic, Loc (..), SrcSpan, Constant, SESearch (..))+import qualified Language.Fixpoint.Types                    as F+import           Language.Fixpoint.Misc                     (safeHead, safeLast, errorstar) -- , safeLast, safeInit)+import           Language.Haskell.Liquid.Misc               (keyDiff)+import           Control.DeepSeq+import           Language.Haskell.Liquid.Types.Errors+++isAnonBinder :: Ghc.TyConBinder -> Bool+isAnonBinder (Bndr _ (AnonTCB _)) = True+isAnonBinder (Bndr _ _)           = False++mkAlive :: Var -> Id+mkAlive x+  | isId x && isDeadOcc (idOccInfo x)+  = setIdInfo x (setOccInfo (idInfo x) noOccInfo)+  | otherwise+  = x+++--------------------------------------------------------------------------------+-- | Encoding and Decoding Location --------------------------------------------+--------------------------------------------------------------------------------+srcSpanTick :: Module -> SrcSpan -> Tickish a+srcSpanTick m sp = ProfNote (AllCafsCC m sp) False True++tickSrcSpan ::  Outputable a => Tickish a -> SrcSpan+tickSrcSpan (ProfNote cc _ _) = cc_loc cc+tickSrcSpan (SourceNote ss _) = RealSrcSpan ss Nothing+tickSrcSpan _                 = noSrcSpan++--------------------------------------------------------------------------------+-- | Generic Helpers for Accessing GHC Innards ---------------------------------+--------------------------------------------------------------------------------++-- FIXME: reusing uniques like this is really dangerous+stringTyVar :: String -> TyVar+stringTyVar s = mkTyVar name liftedTypeKind+  where+    name      = mkInternalName (mkUnique 'x' 24)  occ noSrcSpan+    occ       = mkTyVarOcc s++-- FIXME: reusing uniques like this is really dangerous+stringVar :: String -> Type -> Var+stringVar s t = mkLocalVar VanillaId name Many t vanillaIdInfo+   where+      name = mkInternalName (mkUnique 'x' 25) occ noSrcSpan+      occ  = mkVarOcc s++-- FIXME: plugging in dummy type like this is really dangerous+maybeAuxVar :: Symbol -> Maybe Var+maybeAuxVar s+  | isMethod sym = Just sv+  | otherwise = Nothing+  where (_, uid) = splitModuleUnique s+        sym = dropModuleNames s+        sv = mkExportedLocalId VanillaId name anyTy+        -- 'x' is chosen for no particular reason..+        name = mkInternalName (mkUnique 'x' uid) occ noSrcSpan+        occ = mkVarOcc (T.unpack (symbolText sym))++stringTyCon :: Char -> Int -> String -> TyCon+stringTyCon = stringTyConWithKind anyTy++-- FIXME: reusing uniques like this is really dangerous+stringTyConWithKind :: Kind -> Char -> Int -> String -> TyCon+stringTyConWithKind k c n s = Ghc.mkKindTyCon name [] k [] name+  where+    name          = mkInternalName (mkUnique c n) occ noSrcSpan+    occ           = mkTcOcc s++hasBaseTypeVar :: Var -> Bool+hasBaseTypeVar = isBaseType . varType++-- same as Constraint isBase+isBaseType :: Type -> Bool+isBaseType (ForAllTy _ _)  = False+isBaseType (FunTy { ft_arg = t1, ft_res = t2}) = isBaseType t1 && isBaseType t2+isBaseType (TyVarTy _)     = True+isBaseType (TyConApp _ ts) = all isBaseType ts+isBaseType (AppTy t1 t2)   = isBaseType t1 && isBaseType t2+isBaseType _               = False++isTmpVar :: Var -> Bool+isTmpVar = isTmpSymbol . dropModuleNamesAndUnique . symbol++isTmpSymbol    :: Symbol -> Bool+isTmpSymbol x  = any (`isPrefixOfSym` x) [anfPrefix, tempPrefix, "ds_"]++validTyVar :: String -> Bool+validTyVar s@(c:_) = isLower c && not (any isSpace s)+validTyVar _       = False++tvId :: TyVar -> String+tvId α = {- traceShow ("tvId: α = " ++ show α) $ -} showPpr α ++ show (varUnique α)++tidyCBs :: [CoreBind] -> [CoreBind]+tidyCBs = map unTick++unTick :: CoreBind -> CoreBind+unTick (NonRec b e) = NonRec b (unTickExpr e)+unTick (Rec bs)     = Rec $ map (second unTickExpr) bs++unTickExpr :: CoreExpr -> CoreExpr+unTickExpr (App e a)          = App (unTickExpr e) (unTickExpr a)+unTickExpr (Lam b e)          = Lam b (unTickExpr e)+unTickExpr (Let b e)          = Let (unTick b) (unTickExpr e)+unTickExpr (Case e b t as)    = Case (unTickExpr e) b t (map unTickAlt as)+    where unTickAlt (a, b', e') = (a, b', unTickExpr e')+unTickExpr (Cast e c)         = Cast (unTickExpr e) c+unTickExpr (Tick _ e)         = unTickExpr e+unTickExpr x                  = x++isFractionalClass :: Class -> Bool+isFractionalClass clas = classKey clas `elem` fractionalClassKeys++isOrdClass :: Class -> Bool+isOrdClass clas = classKey clas == ordClassKey++--------------------------------------------------------------------------------+-- | Pretty Printers -----------------------------------------------------------+--------------------------------------------------------------------------------+notracePpr :: Outputable a => String -> a -> a+notracePpr _ x = x++tracePpr :: Outputable a => String -> a -> a+tracePpr s x = trace ("\nTrace: [" ++ s ++ "] : " ++ showPpr x) x++pprShow :: Show a => a -> Ghc.SDoc+pprShow = text . show+++toFixSDoc :: Fixpoint a => a -> PJ.Doc+toFixSDoc = PJ.text . PJ.render . toFix++sDocDoc :: Ghc.SDoc -> PJ.Doc+sDocDoc   = PJ.text . showSDoc++pprDoc :: Outputable a => a -> PJ.Doc+pprDoc    = sDocDoc . ppr++-- Overriding Outputable functions because they now require DynFlags!+showPpr :: Outputable a => a -> String+showPpr       = showSDoc . ppr++-- FIXME: somewhere we depend on this printing out all GHC entities with+-- fully-qualified names...+showSDoc :: Ghc.SDoc -> String+showSDoc sdoc = Ghc.renderWithStyle unsafeGlobalDynFlags sdoc (Ghc.mkUserStyle unsafeGlobalDynFlags myQualify {- Ghc.alwaysQualify -} Ghc.AllTheWay)++myQualify :: Ghc.PrintUnqualified+myQualify = Ghc.neverQualify { Ghc.queryQualifyName = Ghc.alwaysQualifyNames }+-- { Ghc.queryQualifyName = \_ _ -> Ghc.NameNotInScope1 }++showSDocDump :: Ghc.SDoc -> String+showSDocDump  = Ghc.showSDocDump unsafeGlobalDynFlags++instance Outputable a => Outputable (S.HashSet a) where+  ppr = ppr . S.toList++typeUniqueString :: Outputable a => a -> String+typeUniqueString = {- ("sort_" ++) . -} showSDocDump . ppr+++--------------------------------------------------------------------------------+-- | Manipulating Source Spans -------------------------------------------------+--------------------------------------------------------------------------------++newtype Loc    = L (Int, Int) deriving (Eq, Ord, Show)++instance Hashable Loc where+  hashWithSalt i (L z) = hashWithSalt i z++--instance (Uniquable a) => Hashable a where++instance Hashable SrcSpan where+  hashWithSalt i (UnhelpfulSpan reason) = case reason of+    UnhelpfulNoLocationInfo -> hashWithSalt i (uniq $ fsLit "UnhelpfulNoLocationInfo")+    UnhelpfulWiredIn        -> hashWithSalt i (uniq $ fsLit "UnhelpfulWiredIn")+    UnhelpfulInteractive    -> hashWithSalt i (uniq $ fsLit "UnhelpfulInteractive")+    UnhelpfulGenerated      -> hashWithSalt i (uniq $ fsLit "UnhelpfulGenerated")+    UnhelpfulOther fs       -> hashWithSalt i (uniq fs)+  hashWithSalt i (RealSrcSpan s _)      = hashWithSalt i (srcSpanStartLine s, srcSpanStartCol s, srcSpanEndCol s)++fSrcSpan :: (F.Loc a) => a -> SrcSpan+fSrcSpan = fSrcSpanSrcSpan . F.srcSpan++fSourcePos :: (F.Loc a) => a -> F.SourcePos+fSourcePos = F.sp_start . F.srcSpan++fSrcSpanSrcSpan :: F.SrcSpan -> SrcSpan+fSrcSpanSrcSpan (F.SS p p') = sourcePos2SrcSpan p p'++srcSpanFSrcSpan :: SrcSpan -> F.SrcSpan+srcSpanFSrcSpan sp = F.SS p p'+  where+    p              = srcSpanSourcePos sp+    p'             = srcSpanSourcePosE sp++sourcePos2SrcSpan :: SourcePos -> SourcePos -> SrcSpan+sourcePos2SrcSpan p p' = RealSrcSpan (realSrcSpan f (unPos l) (unPos c) (unPos l') (unPos c')) Nothing+  where+    (f, l,  c)         = F.sourcePosElts p+    (_, l', c')        = F.sourcePosElts p'++sourcePosSrcSpan   :: SourcePos -> SrcSpan+sourcePosSrcSpan p@(SourcePos file line col) = sourcePos2SrcSpan p (SourcePos file line (succPos col))++sourcePosSrcLoc    :: SourcePos -> SrcLoc+sourcePosSrcLoc (SourcePos file line col) = mkSrcLoc (fsLit file) (unPos line) (unPos col)++srcSpanSourcePos :: SrcSpan -> SourcePos+srcSpanSourcePos (UnhelpfulSpan _) = dummyPos "<no source information>"+srcSpanSourcePos (RealSrcSpan s _) = realSrcSpanSourcePos s++srcSpanSourcePosE :: SrcSpan -> SourcePos+srcSpanSourcePosE (UnhelpfulSpan _) = dummyPos "<no source information>"+srcSpanSourcePosE (RealSrcSpan s _) = realSrcSpanSourcePosE s++srcSpanFilename :: SrcSpan -> String+srcSpanFilename    = maybe "" unpackFS . srcSpanFileName_maybe++srcSpanStartLoc :: RealSrcSpan -> Loc+srcSpanStartLoc l  = L (srcSpanStartLine l, srcSpanStartCol l)++srcSpanEndLoc :: RealSrcSpan -> Loc+srcSpanEndLoc l    = L (srcSpanEndLine l, srcSpanEndCol l)+++oneLine :: RealSrcSpan -> Bool+oneLine l          = srcSpanStartLine l == srcSpanEndLine l++lineCol :: RealSrcSpan -> (Int, Int)+lineCol l          = (srcSpanStartLine l, srcSpanStartCol l)++realSrcSpanSourcePos :: RealSrcSpan -> SourcePos+realSrcSpanSourcePos s = safeSourcePos file line col+  where+    file               = unpackFS $ srcSpanFile s+    line               = srcSpanStartLine       s+    col                = srcSpanStartCol        s+++realSrcSpanSourcePosE :: RealSrcSpan -> SourcePos+realSrcSpanSourcePosE s = safeSourcePos file line col+  where+    file                = unpackFS $ srcSpanFile s+    line                = srcSpanEndLine       s+    col                 = srcSpanEndCol        s++getSourcePos :: NamedThing a => a -> SourcePos+getSourcePos = srcSpanSourcePos  . getSrcSpan++getSourcePosE :: NamedThing a => a -> SourcePos+getSourcePosE = srcSpanSourcePosE . getSrcSpan++locNamedThing :: NamedThing a => a -> F.Located a+locNamedThing x = F.Loc l lE x+  where+    l          = getSourcePos  x+    lE         = getSourcePosE x++instance F.Loc Var where+  srcSpan v = SS (getSourcePos v) (getSourcePosE v)++namedLocSymbol :: (F.Symbolic a, NamedThing a) => a -> F.Located F.Symbol+namedLocSymbol d = F.symbol <$> locNamedThing d++varLocInfo :: (Type -> a) -> Var -> F.Located a+varLocInfo f x = f . varType <$> locNamedThing x++namedPanic :: (NamedThing a) => a -> String -> b+namedPanic x msg = panic (Just (getSrcSpan x)) msg++--------------------------------------------------------------------------------+-- | Manipulating CoreExpr -----------------------------------------------------+--------------------------------------------------------------------------------++collectArguments :: Int -> CoreExpr -> [Var]+collectArguments n e = if length xs > n then take n xs else xs+  where+    (vs', e')        = collectValBinders' $ snd $ collectTyBinders e+    vs               = fst $ collectBinders $ ignoreLetBinds e'+    xs               = vs' ++ vs++{-+collectTyBinders :: CoreExpr -> ([Var], CoreExpr)+collectTyBinders expr+  = go [] expr+  where+    go tvs (Lam b e) | isTyVar b = go (b:tvs) e+    go tvs e                     = (reverse tvs, e)+-}++collectValBinders' :: Ghc.Expr Var -> ([Var], Ghc.Expr Var)+collectValBinders' = go []+  where+    go tvs (Lam b e) | isTyVar b = go tvs     e+    go tvs (Lam b e) | isId    b = go (b:tvs) e+    go tvs (Tick _ e)            = go tvs e+    go tvs e                     = (reverse tvs, e)++ignoreLetBinds :: Ghc.Expr t -> Ghc.Expr t+ignoreLetBinds (Let (NonRec _ _) e')+  = ignoreLetBinds e'+ignoreLetBinds e+  = e++--------------------------------------------------------------------------------+-- | Predicates on CoreExpr and DataCons ---------------------------------------+--------------------------------------------------------------------------------++isExternalId :: Id -> Bool+isExternalId = isExternalName . getName++isTupleId :: Id -> Bool+isTupleId = maybe False Ghc.isTupleDataCon . idDataConM++idDataConM :: Id -> Maybe DataCon+idDataConM x = case idDetails x of+  DataConWorkId d -> Just d+  DataConWrapId d -> Just d+  _               -> Nothing++isDataConId :: Id -> Bool+isDataConId = isJust . idDataConM++getDataConVarUnique :: Var -> Unique+getDataConVarUnique v+  | isId v && isDataConId v = getUnique (idDataCon v)+  | otherwise               = getUnique v++isDictionaryExpression :: Ghc.Expr Id -> Maybe Id+isDictionaryExpression (Tick _ e) = isDictionaryExpression e+isDictionaryExpression (Var x)    | isDictionary x = Just x+isDictionaryExpression _          = Nothing++realTcArity :: TyCon -> Arity+realTcArity = tyConArity++{-+  tracePpr ("realTcArity of " ++ showPpr c+     ++ "\n tyConKind = " ++ showPpr (tyConKind c)+     ++ "\n kindArity = " ++ show (kindArity (tyConKind c))+     ++ "\n kindArity' = " ++ show (kindArity' (tyConKind c)) -- this works for TypeAlias+     ) $ kindArity' (tyConKind c)+-}++kindTCArity :: TyCon -> Arity+kindTCArity = go . tyConKind+  where+    go (FunTy { ft_res = res}) = 1 + go res+    go _               = 0+++kindArity :: Kind -> Arity+kindArity (ForAllTy _ res)+  = 1 + kindArity res+kindArity _+  = 0++uniqueHash :: Uniquable a => Int -> a -> Int+uniqueHash i = hashWithSalt i . getKey . getUnique++-- slightly modified version of DynamicLoading.lookupRdrNameInModule+lookupRdrName :: HscEnv -> ModuleName -> RdrName -> IO (Maybe Name)+lookupRdrName hsc_env mod_name rdr_name = do+    -- First find the package the module resides in by searching exposed packages and home modules+    found_module <- findImportedModule hsc_env mod_name Nothing+    case found_module of+        Found _ mod' -> do+            -- Find the exports of the module+            (_, mb_iface) <- getModuleInterface hsc_env mod'+            case mb_iface of+                Just iface -> do+                    -- Try and find the required name in the exports+                    let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name+                                                , is_qual = False, is_dloc = noSrcSpan }+                        provenance = Just $ ImpSpec decl_spec ImpAll+                        env = case mi_globals iface of+                                Nothing -> mkGlobalRdrEnv (gresFromAvails provenance (mi_exports iface))+                                Just e -> e+                    case lookupGRE_RdrName rdr_name env of+                        [gre] -> return (Just (gre_name gre))+                        []    -> return Nothing+                        _     -> Ghc.panic "lookupRdrNameInModule"+                Nothing -> throwCmdLineErrorS dflags $ Ghc.hsep [Ghc.ptext (sLit "Could not determine the exports of the module"), ppr mod_name]+        err' -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err'+  where dflags = hsc_dflags hsc_env+        throwCmdLineErrorS dflags' = throwCmdLineError . Ghc.showSDoc dflags'+        throwCmdLineError = throwGhcException . CmdLineError++-- qualImportDecl :: ModuleName -> ImportDecl name+-- qualImportDecl mn = (simpleImportDecl mn) { ideclQualified = True }++ignoreInline :: ParsedModule -> ParsedModule+ignoreInline x = x {pm_parsed_source = go <$> pm_parsed_source x}+  where+    go  y      = y {hsmodDecls = filter go' (hsmodDecls y) }+    go' :: LHsDecl GhcPs -> Bool+    go' z+      | SigD _ (InlineSig {}) <-  unLoc z = False+      | otherwise                         = True++--------------------------------------------------------------------------------+-- | Symbol Conversions --------------------------------------------------------+--------------------------------------------------------------------------------++symbolTyConWithKind :: Kind -> Char -> Int -> Symbol -> TyCon+symbolTyConWithKind k x i n = stringTyConWithKind k x i (symbolString n)++symbolTyCon :: Char -> Int -> Symbol -> TyCon+symbolTyCon x i n = stringTyCon x i (symbolString n)++symbolTyVar :: Symbol -> TyVar+symbolTyVar = stringTyVar . symbolString++localVarSymbol ::  Var -> Symbol+localVarSymbol v+  | us `isSuffixOfSym` vs = vs+  | otherwise             = suffixSymbol vs us+  where+    us                    = symbol $ showPpr $ getDataConVarUnique v+    vs                    = exportedVarSymbol v++exportedVarSymbol :: Var -> Symbol+exportedVarSymbol x = notracepp msg . symbol . getName $ x+  where+    msg = "exportedVarSymbol: " ++ showPpr x++qualifiedNameSymbol :: Name -> Symbol+qualifiedNameSymbol n = symbol $ concatFS [modFS, occFS, uniqFS]+  where+  _msg   = showSDoc (ppr n) -- getOccString n+  modFS = case nameModule_maybe n of+            Nothing -> fsLit ""+            Just m  -> concatFS [moduleNameFS (moduleName m), fsLit "."]++  occFS = occNameFS (getOccName n)+  uniqFS+    | isSystemName n+    = concatFS [fsLit "_",  fsLit (showPpr (getUnique n))]+    | otherwise+    = fsLit ""++instance Symbolic FastString where+  symbol = symbol . fastStringText++fastStringText :: FastString -> T.Text+fastStringText = T.decodeUtf8With TE.lenientDecode . bytesFS++tyConTyVarsDef :: TyCon -> [TyVar]+tyConTyVarsDef c+  | noTyVars c = []+  | otherwise  = Ghc.tyConTyVars c+  --where+  --  none         = tracepp ("tyConTyVarsDef: " ++ show c) (noTyVars c)++noTyVars :: TyCon -> Bool+noTyVars c =  Ghc.isPrimTyCon c || isFunTyCon c || Ghc.isPromotedDataCon c++--------------------------------------------------------------------------------+-- | Symbol Instances+--------------------------------------------------------------------------------++instance Symbolic TyCon where+  symbol = symbol . getName++instance Symbolic Class where+  symbol = symbol . getName++instance Symbolic Name where+  symbol = symbol . qualifiedNameSymbol++-- | [NOTE:REFLECT-IMPORTS] we **eschew** the `unique` suffix for exported vars,+-- to make it possible to lookup names from symbols _across_ modules;+-- anyways exported names are top-level and you shouldn't have local binders+-- that shadow them. However, we **keep** the `unique` suffix for local variables,+-- as otherwise there are spurious, but extremely problematic, name collisions+-- in the fixpoint environment.++instance Symbolic Var where   -- TODO:reflect-datacons varSymbol+  symbol v+    | isExternalId v = exportedVarSymbol v+    | otherwise      = localVarSymbol    v+++instance Hashable Var where+  hashWithSalt = uniqueHash++instance Hashable TyCon where+  hashWithSalt = uniqueHash++instance Hashable Class where+  hashWithSalt = uniqueHash++instance Hashable DataCon where+  hashWithSalt = uniqueHash++instance Fixpoint Var where+  toFix = pprDoc++instance Fixpoint Name where+  toFix = pprDoc++instance Fixpoint Type where+  toFix = pprDoc++instance Show Name where+  show = symbolString . symbol++instance Show Var where+  show = show . getName++instance Show Class where+  show = show . getName++instance Show TyCon where+  show = show . getName++instance NFData Class where+  rnf t = seq t ()++instance NFData TyCon where+  rnf t = seq t ()++instance NFData Type where+  rnf t = seq t ()++instance NFData Var where+  rnf t = seq t ()++--------------------------------------------------------------------------------+-- | Manipulating Symbols ------------------------------------------------------+--------------------------------------------------------------------------------++takeModuleUnique :: Symbol -> Symbol+takeModuleUnique = mungeNames tailName sepUnique   "takeModuleUnique: "+  where+    tailName msg = symbol . safeLast msg++splitModuleUnique :: Symbol -> (Symbol, Int)+splitModuleUnique x = (dropModuleNamesAndUnique x, base62ToI (takeModuleUnique x))++base62ToI :: Symbol -> Int+base62ToI s =  fromMaybe (errorstar "base62ToI Out Of Range") $ go (F.symbolText s)+  where+    digitToI :: OM.Map Char Int+    digitToI = OM.fromList $ zip (['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z']) [0..]+    f acc (flip OM.lookup digitToI -> x) = (acc * 62 +) <$> x+    go = foldM f 0 . T.unpack+++splitModuleName :: Symbol -> (Symbol, Symbol)+splitModuleName x = (takeModuleNames x, dropModuleNamesAndUnique x)++dropModuleNamesAndUnique :: Symbol -> Symbol+dropModuleNamesAndUnique = dropModuleUnique . dropModuleNames++dropModuleNames  :: Symbol -> Symbol+dropModuleNames = dropModuleNamesCorrect+{- +dropModuleNames = mungeNames lastName sepModNames "dropModuleNames: "+ where+   lastName msg = symbol . safeLast msg+-}++dropModuleNamesCorrect  :: Symbol -> Symbol+dropModuleNamesCorrect = F.symbol . go . F.symbolText+  where+    go s = case T.uncons s of+             Just (c,tl) -> if isUpper c  && T.any (== '.') tl+                              then go $ snd $ fromJust $ T.uncons $ T.dropWhile (/= '.') s+                              else s+             Nothing -> s++takeModuleNames  :: Symbol -> Symbol+takeModuleNames  = F.symbol . go [] . F.symbolText+  where+    go acc s = case T.uncons s of+                Just (c,tl) -> if isUpper c && T.any (== '.') tl+                                 then go (getModule' s:acc) $ snd $ fromJust $ T.uncons $ T.dropWhile (/= '.') s+                                 else T.intercalate "." (reverse acc)+                Nothing -> T.intercalate "." (reverse acc)+    getModule' = T.takeWhile (/= '.')++{- +takeModuleNamesOld  = mungeNames initName sepModNames "takeModuleNames: "+  where+    initName msg = symbol . T.intercalate "." . safeInit msg+-}+dropModuleUnique :: Symbol -> Symbol+dropModuleUnique = mungeNames headName sepUnique   "dropModuleUnique: "+  where+    headName msg = symbol . safeHead msg++cmpSymbol :: Symbol -> Symbol -> Bool+cmpSymbol coreSym logicSym+  =  (dropModuleUnique coreSym == dropModuleNamesAndUnique logicSym)+  || (dropModuleUnique coreSym == dropModuleUnique         logicSym)++sepModNames :: T.Text+sepModNames = "."++sepUnique :: T.Text+sepUnique = "#"++mungeNames :: (String -> [T.Text] -> Symbol) -> T.Text -> String -> Symbol -> Symbol+mungeNames _ _ _ ""  = ""+mungeNames f d msg s'@(symbolText -> s)+  | s' == tupConName = tupConName+  | otherwise        = f (msg ++ T.unpack s) $ T.splitOn d $ stripParens s++qualifySymbol :: Symbol -> Symbol -> Symbol+qualifySymbol (symbolText -> m) x'@(symbolText -> x)+  | isQualified x  = x'+  | isParened x    = symbol (wrapParens (m `mappend` "." `mappend` stripParens x))+  | otherwise      = symbol (m `mappend` "." `mappend` x)++isQualifiedSym :: Symbol -> Bool+isQualifiedSym (symbolText -> x) = isQualified x++isQualified :: T.Text -> Bool+isQualified y = "." `T.isInfixOf` y++wrapParens :: (IsString a, Monoid a) => a -> a+wrapParens x  = "(" `mappend` x `mappend` ")"++isParened :: T.Text -> Bool+isParened xs  = xs /= stripParens xs++isDictionary :: Symbolic a => a -> Bool+isDictionary = isPrefixOfSym "$f" . dropModuleNames . symbol++isMethod :: Symbolic a => a -> Bool+isMethod = isPrefixOfSym "$c" . dropModuleNames . symbol++isInternal :: Symbolic a => a -> Bool+isInternal   = isPrefixOfSym "$"  . dropModuleNames . symbol++isWorker :: Symbolic a => a -> Bool+isWorker s = notracepp ("isWorkerSym: s = " ++ ss) $ "$W" `L.isInfixOf` ss+  where+    ss     = symbolString (symbol s)++isSCSel :: Symbolic a => a -> Bool+isSCSel  = isPrefixOfSym "$p" . dropModuleNames . symbol++stripParens :: T.Text -> T.Text+stripParens t = fromMaybe t (strip t)+  where+    strip = T.stripPrefix "(" >=> T.stripSuffix ")"++stripParensSym :: Symbol -> Symbol+stripParensSym (symbolText -> t) = symbol (stripParens t)++desugarModule :: TypecheckedModule -> Ghc DesugaredModule+desugarModule tcm = do+  let ms = pm_mod_summary $ tm_parsed_module tcm+  -- let ms = modSummary tcm+  let (tcg, _) = tm_internals_ tcm+  hsc_env <- getSession+  let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }+  guts <- liftIO $ hscDesugar{- WithLoc -} hsc_env_tmp ms tcg+  return DesugaredModule { dm_typechecked_module = tcm, dm_core_module = guts }++--------------------------------------------------------------------------------+-- | GHC Compatibility Layer ---------------------------------------------------+--------------------------------------------------------------------------------++gHC_VERSION :: String+gHC_VERSION = show (__GLASGOW_HASKELL__ :: Int)++symbolFastString :: Symbol -> FastString+symbolFastString = mkFastStringByteString . T.encodeUtf8 . symbolText++lintCoreBindings :: [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc)+lintCoreBindings = Ghc.lintCoreBindings (defaultDynFlags undefined (undefined ("LlvmTargets" :: String))) CoreDoNothing++synTyConRhs_maybe :: TyCon -> Maybe Type+synTyConRhs_maybe = Ghc.synTyConRhs_maybe++tcRnLookupRdrName :: HscEnv -> Ghc.Located RdrName -> IO (Messages, Maybe [Name])+tcRnLookupRdrName = Ghc.tcRnLookupRdrName++showCBs :: Bool -> [CoreBind] -> String+showCBs untidy+  | untidy    = Ghc.showSDocDebug unsafeGlobalDynFlags . ppr . tidyCBs+  | otherwise = showPpr+++ignoreCoreBinds :: S.HashSet Var -> [CoreBind] -> [CoreBind]+ignoreCoreBinds vs cbs+  | S.null vs         = cbs+  | otherwise         = concatMap go cbs+  where+    go :: CoreBind -> [CoreBind]+    go b@(NonRec x _)+      | S.member x vs = []+      | otherwise     = [b]+    go (Rec xes)      = [Rec (filter ((`notElem` vs) . fst) xes)]+++findVarDef :: Symbol -> [CoreBind] -> Maybe (Var, CoreExpr)+findVarDef sym cbs = case xCbs of+                     (NonRec v def   : _ ) -> Just (v, def)+                     (Rec [(v, def)] : _ ) -> Just (v, def)+                     _                     -> Nothing+  where+    xCbs            = [ cb | cb <- concatMap unRec cbs, sym `elem` coreBindSymbols cb ]+    unRec (Rec xes) = [NonRec x es | (x,es) <- xes]+    unRec nonRec    = [nonRec]+++findVarDefMethod :: Symbol -> [CoreBind] -> Maybe (Var, CoreExpr)+findVarDefMethod sym cbs =+  case rcbs  of+                     (NonRec v def   : _ ) -> Just (v, def)+                     (Rec [(v, def)] : _ ) -> Just (v, def)+                     _                     -> Nothing+  where+    rcbs | isMethod sym = mCbs+         | isDictionary (dropModuleNames sym) = dCbs+         | otherwise  = xCbs+    xCbs            = [ cb | cb <- concatMap unRec cbs, sym `elem` coreBindSymbols cb+                           ]+    mCbs            = [ cb | cb <- concatMap unRec cbs, sym `elem` methodSymbols cb]+    dCbs            = [ cb | cb <- concatMap unRec cbs, sym `elem` dictionarySymbols cb]+    unRec (Rec xes) = [NonRec x es | (x,es) <- xes]+    unRec nonRec    = [nonRec]++dictionarySymbols :: CoreBind -> [Symbol]+dictionarySymbols = filter isDictionary . map (dropModuleNames . symbol) . binders+++methodSymbols :: CoreBind -> [Symbol]+methodSymbols = filter isMethod . map (dropModuleNames . symbol) . binders++++coreBindSymbols :: CoreBind -> [Symbol]+coreBindSymbols = map (dropModuleNames . simplesymbol) . binders++simplesymbol :: (NamedThing t) => t -> Symbol+simplesymbol = symbol . getName++binders :: Bind a -> [a]+binders (NonRec z _) = [z]+binders (Rec xes)    = fst <$> xes++expandVarType :: Var -> Type+expandVarType = expandTypeSynonyms . varType++--------------------------------------------------------------------------------+-- | The following functions test if a `CoreExpr` or `CoreVar` can be+--   embedded in logic. With type-class support, we can no longer erase+--   such expressions arbitrarily.+--------------------------------------------------------------------------------+isEmbeddedDictExpr :: CoreExpr -> Bool+isEmbeddedDictExpr = isEmbeddedDictType . exprType++isEmbeddedDictVar :: Var -> Bool+isEmbeddedDictVar v = F.notracepp msg . isEmbeddedDictType . varType $ v+  where+    msg     =  "isGoodCaseBind v = " ++ show v++isEmbeddedDictType :: Type -> Bool+isEmbeddedDictType = anyF [isOrdPred, isNumericPred, isEqPred, isPrelEqPred]++-- unlike isNumCls, isFracCls, these two don't check if the argument's+-- superclass is Ord or Num. I believe this is the more predictable behavior++isPrelEqPred :: Type -> Bool+isPrelEqPred ty = case tyConAppTyCon_maybe ty of+  Just tyCon -> isPrelEqTyCon tyCon+  _          -> False+++isPrelEqTyCon :: TyCon -> Bool+isPrelEqTyCon tc = tc `hasKey` eqClassKey++isOrdPred :: Type -> Bool+isOrdPred ty = case tyConAppTyCon_maybe ty of+  Just tyCon -> tyCon `hasKey` ordClassKey+  _          -> False++-- Not just Num, but Fractional, Integral as well+isNumericPred :: Type -> Bool+isNumericPred ty = case tyConAppTyCon_maybe ty of+  Just tyCon -> getUnique tyCon `elem` numericClassKeys+  _          -> False++++--------------------------------------------------------------------------------+-- | The following functions test if a `CoreExpr` or `CoreVar` are just types+--   in disguise, e.g. have `PredType` (in the GHC sense of the word), and so+--   shouldn't appear in refinements.+--------------------------------------------------------------------------------+isPredExpr :: CoreExpr -> Bool+isPredExpr = isPredType . Ghc.exprType++isPredVar :: Var -> Bool+isPredVar v = F.notracepp msg . isPredType . varType $ v+  where+    msg     =  "isGoodCaseBind v = " ++ show v++isPredType :: Type -> Bool+isPredType = anyF [ isClassPred, isEqPred, isEqPrimPred ]++anyF :: [a -> Bool] -> a -> Bool+anyF ps x = or [ p x | p <- ps ]+++-- | 'defaultDataCons t ds' returns the list of '(dc, types)' pairs,+--   corresponding to the _missing_ cases, i.e. _other_ than those in 'ds',+--   that are being handled by DEFAULT.+defaultDataCons :: Type -> [AltCon] -> Maybe [(DataCon, [TyVar], [Type])]+defaultDataCons (TyConApp tc argτs) ds = do+  allDs     <- Ghc.tyConDataCons_maybe tc+  let seenDs = [d | DataAlt d <- ds ]+  let defDs  = keyDiff showPpr allDs seenDs+  return [ (d, Ghc.dataConExTyVars d, map irrelevantMult $ Ghc.dataConInstArgTys d argτs) | d <- defDs ]++defaultDataCons _ _ =+  Nothing++++isEvVar :: Id -> Bool+isEvVar x = isPredVar x || isTyVar x || isCoVar x+++--------------------------------------------------------------------------------+-- | Elaboration+--------------------------------------------------------------------------------++-- FIXME: the handling of exceptions seems to be broken++-- partially stolen from GHC'sa exprType++-- elaborateHsExprInst+--   :: GhcMonad m => LHsExpr GhcPs -> m (Messages, Maybe CoreExpr)+-- elaborateHsExprInst expr = elaborateHsExpr TM_Inst expr+++-- elaborateHsExpr+--   :: GhcMonad m => TcRnExprMode -> LHsExpr GhcPs -> m (Messages, Maybe CoreExpr)+-- elaborateHsExpr mode expr =+--   withSession $ \hsc_env -> liftIO $ hscElabHsExpr hsc_env mode expr++-- hscElabHsExpr :: HscEnv -> TcRnExprMode -> LHsExpr GhcPs -> IO (Messages, Maybe CoreExpr)+-- hscElabHsExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do+--   hsc_env <- Ghc.getHscEnv+--   liftIO $ elabRnExpr hsc_env mode expr++elabRnExpr+  :: TcRnExprMode -> LHsExpr GhcPs -> TcRn CoreExpr+elabRnExpr mode rdr_expr = do+    (rn_expr, _fvs) <- rnLExpr rdr_expr+    failIfErrsM++        -- Now typecheck the expression, and generalise its type+        -- it might have a rank-2 type (e.g. :t runST)+    uniq <- newUnique ;+    let fresh_it  = itName uniq (getLoc rdr_expr) +    ((tclvl, (tc_expr, res_ty)), lie)+          <- captureTopConstraints $+             pushTcLevelM          $+             tc_infer rn_expr++    -- Generalise+    (_qtvs, _dicts, evbs, residual, _)+         <- simplifyInfer tclvl infer_mode+                          []    {- No sig vars -}+                          [(fresh_it, res_ty)]+                          lie++    -- Ignore the dictionary bindings+    evbs' <- perhaps_disable_default_warnings $+         simplifyInteractive residual+    full_expr <- zonkTopLExpr (mkHsDictLet (EvBinds evbs') (mkHsDictLet evbs tc_expr))+    initDsTc $ dsLExpr full_expr+  where+    tc_infer expr' | inst      = tcInferRho expr'+                   | otherwise = tcInferSigma expr'+                  -- tcInferSigma: see Note [Implementing :type]++    -- See Note [TcRnExprMode]+    (inst, infer_mode, perhaps_disable_default_warnings) = case mode of+      TM_Inst    -> (True,  NoRestrictions, id)+      TM_NoInst  -> (False, NoRestrictions, id)+      TM_Default -> (True,  EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults)++newtype HashableType = HashableType {getHType :: Type}++instance Eq HashableType where+  x == y = eqType (getHType x) (getHType y)++instance Ord HashableType where+  compare x y = nonDetCmpType (getHType x) (getHType y)++instance Outputable HashableType where+  ppr = ppr . getHType+++--------------------------------------------------------------------------------+-- | Superclass coherence+--------------------------------------------------------------------------------++canonSelectorChains :: PredType -> OM.Map HashableType [Id]+canonSelectorChains t = foldr (OM.unionWith const) mempty (zs : xs)+ where+  (cls, ts) = Ghc.getClassPredTys t+  scIdTys   = classSCSelIds cls+  ys        = fmap (\d -> (d, piResultTys (idType d) (ts ++ [t]))) scIdTys+  zs        = OM.fromList $ fmap (\(x, y) -> (HashableType y, [x])) ys+  xs        = fmap (\(d, t') -> fmap (d :) (canonSelectorChains t')) ys++buildCoherenceOblig :: Class -> [[([Id], [Id])]]+buildCoherenceOblig cls = evalState (mapM f xs) OM.empty+ where+  (ts, _, selIds, _) = classBigSig cls+  tts                = mkTyVarTy <$> ts+  t                  = mkClassPred cls tts+  ys = fmap (\d -> (d, piResultTys (idType d) (tts ++ [t]))) selIds+  xs                 = fmap (\(d, t') -> fmap (d:) (canonSelectorChains t')) ys+  f tid = do+    ctid' <- get+    modify (flip (OM.unionWith const) tid)+    pure . OM.elems $ OM.intersectionWith (,) ctid' (fmap tail tid)+++-- to be zipped onto the super class selectors+coherenceObligToRef :: (F.Symbolic s) => s -> [Id] -> [Id] -> F.Reft+coherenceObligToRef d = coherenceObligToRefE (F.eVar $ F.symbol d)++coherenceObligToRefE :: F.Expr -> [Id] -> [Id] -> F.Reft+coherenceObligToRefE e rps0 rps1 = F.Reft (F.vv_, F.PAtom F.Eq lhs rhs)+  where lhs = L.foldr EApp e ps0+        rhs = L.foldr EApp (F.eVar F.vv_) ps1+        ps0 = F.eVar . F.symbol <$> L.reverse rps0+        ps1 = F.eVar . F.symbol <$> L.reverse rps1++data TcWiredIn = TcWiredIn {+    tcWiredInName :: Name+  , tcWiredInFixity :: Maybe (Int, FixityDirection)+  , tcWiredInType :: LHsType GhcRn+  }++-- | Run a computation in GHC's typechecking monad with wired in values locally bound in the typechecking environment.+withWiredIn :: TcM a -> TcM a+withWiredIn m = discardConstraints $ do+  -- undef <- lookupUndef+  wiredIns <- mkWiredIns+  -- snd <$> tcValBinds Ghc.NotTopLevel (binds undef wiredIns) (sigs wiredIns) m+  snd <$> tcValBinds Ghc.NotTopLevel [] (sigs wiredIns) m++ where+  -- lookupUndef = do+  --   lookupOrig gHC_ERR (Ghc.mkVarOcc "undefined")+  --   -- tcLookupGlobal undefName++  -- binds :: Name -> [TcWiredIn] -> [(Ghc.RecFlag, LHsBinds GhcRn)]+  -- binds undef wiredIns = map (\w -> +  --     let ext = Ghc.unitNameSet undef in -- $ varName $ tyThingId undef in+  --     let co_fn = idHsWrapper in+  --     let matches = +  --           let ctxt = LambdaExpr in+  --           let grhss = GRHSs Ghc.noExtField [Ghc.L locSpan (GRHS Ghc.noExtField [] (Ghc.L locSpan (HsVar Ghc.noExtField (Ghc.L locSpan undef))))] (Ghc.L locSpan emptyLocalBinds) in+  --           MG Ghc.noExtField (Ghc.L locSpan [Ghc.L locSpan (Match Ghc.noExtField ctxt [] grhss)]) Ghc.Generated +  --     in+  --     let b = FunBind ext (Ghc.L locSpan $ tcWiredInName w) matches co_fn [] in+  --     (Ghc.NonRecursive, unitBag (Ghc.L locSpan b))+  --   ) wiredIns++  sigsExt ext wiredIns = concatMap (\w ->+      let inf = maybeToList $ (\(fPrec, fDir) -> Ghc.L locSpan $ FixSig Ghc.noExtField $ FixitySig Ghc.noExtField [Ghc.L locSpan (tcWiredInName w)] $ Ghc.Fixity Ghc.NoSourceText fPrec fDir) <$> tcWiredInFixity w in+      let t =+            let ext' = [] in+            [Ghc.L locSpan $ TypeSig Ghc.noExtField [Ghc.L locSpan (tcWiredInName w)] $ HsWC ext' $ HsIB ext $ tcWiredInType w]+      in+      inf <> t+    ) wiredIns++  sigs = sigsExt cppExt++  cppExt = []++  locSpan = UnhelpfulSpan (UnhelpfulOther "Liquid.GHC.Misc: WiredIn")++  mkHsFunTy :: LHsType GhcRn -> LHsType GhcRn -> LHsType GhcRn+  mkHsFunTy a b = nlHsFunTy a b++  mkWiredIns = sequence [impl, dimpl, eq, len]++  toName s = do+    u <- getUniqueM+    return $ Ghc.mkInternalName u (Ghc.mkVarOcc s) locSpan++  toLoc = Ghc.L locSpan+  nameToTy = Ghc.L locSpan . HsTyVar Ghc.noExtField Ghc.NotPromoted++  boolTy' :: LHsType GhcRn+  boolTy' = nameToTy $ toLoc boolTyConName+    -- boolName <- lookupOrig (Module (stringToUnitId "Data.Bool") (mkModuleName "Data.Bool")) (Ghc.mkVarOcc "Bool")+    -- return $ Ghc.L locSpan $ HsTyVar Ghc.noExtField Ghc.NotPromoted $ Ghc.L locSpan boolName+  intTy' = nameToTy $ toLoc intTyConName+  listTy lt = toLoc $ HsAppTy Ghc.noExtField (nameToTy $ toLoc listTyConName) lt++  -- infixr 1 ==> :: Bool -> Bool -> Bool+  impl = do+    n <- toName "==>"+    let ty = mkHsFunTy boolTy' (mkHsFunTy boolTy' boolTy')+    return $ TcWiredIn n (Just (1, Ghc.InfixR)) ty++  -- infixr 1 <=> :: Bool -> Bool -> Bool+  dimpl = do+    n <- toName "<=>"+    let ty = mkHsFunTy boolTy' (mkHsFunTy boolTy' boolTy')+    return $ TcWiredIn n (Just (1, Ghc.InfixR)) ty++  -- infix 4 == :: forall a . a -> a -> Bool+  eq = do+    n <- toName "=="+    aName <- Ghc.L locSpan <$> toName "a"+    let aTy = nameToTy aName+    let ty = noLoc $ HsForAllTy Ghc.noExtField+             (mkHsForAllInvisTele [Ghc.L locSpan $ UserTyVar Ghc.noExtField SpecifiedSpec aName]) $ mkHsFunTy aTy (mkHsFunTy aTy boolTy')+    return $ TcWiredIn n (Just (4, Ghc.InfixN)) ty++  -- TODO: This is defined as a measure in liquid-base GHC.Base. We probably want to insert all measures to the environment.+  -- len :: forall a. [a] -> Int+  len = do+    n <- toName "len"+    aName <- Ghc.L locSpan <$> toName "a"+    let aTy = nameToTy aName+    let ty =+          noLoc $ HsForAllTy Ghc.noExtField+               (mkHsForAllInvisTele [Ghc.L locSpan $ UserTyVar Ghc.noExtField SpecifiedSpec aName]) $ mkHsFunTy (listTy aTy) intTy'+    return $ TcWiredIn n Nothing ty++prependGHCRealQual :: FastString -> RdrName+prependGHCRealQual = varQual_RDR gHC_REAL++isFromGHCReal :: NamedThing a => a -> Bool+isFromGHCReal x = Ghc.nameModule (Ghc.getName x) == gHC_REAL
+ src-ghc/Liquid/GHC/Play.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleInstances         #-}++{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- TODO(#1918): Only needed for GHC <9.0.1.++module Liquid.GHC.Play where++import Prelude hiding (error)++import           Control.Arrow       ((***))+import qualified Data.HashMap.Strict as M+import qualified Data.List           as L+import qualified Data.Maybe          as Mb++import Liquid.GHC.API as Ghc hiding (substTysWith, panic,showPpr)+import Liquid.GHC.Misc ()+import Language.Haskell.Liquid.Types.Errors+import Language.Haskell.Liquid.Types.Variance++-------------------------------------------------------------------------------+-- | Positivity Checker -------------------------------------------------------+-------------------------------------------------------------------------------++-- If the type constructor T is in the input list and its data constructors Di, Dj+-- use T in non strictly positive positions, +-- then (T,(Di, Dj)) will appear in the result list.  ++getNonPositivesTyCon :: [TyCon] -> [(TyCon, [DataCon])]+getNonPositivesTyCon tcs = Mb.mapMaybe go (M.toList $ makeOccurrences tcs)+  where+    go (tc,dcocs) = case filter (\(_,occ) -> elem tc (negOcc occ)) dcocs of+                      [] -> Nothing+                      xs -> Just (tc, fst <$> xs)+++-- OccurrenceMap maps type constructors to their TyConOccurrence. +-- for each of their data constructor. For example, for the below data definition+-- data T a = P (T a) | N (T a -> Int) | Both (T a -> T a) | None +-- the entry below should get generated+--  OccurrenceMap +-- = T |-> [(P, [+--          (P,    TyConOcc [T] [])+--          (N,    TyConOcc [Int] [T])+--          (Both, TyConOcc [T] [T])+--          (None, TyConOcc [] [])+--         ])] +-- For positivity check, ultimately we only care about self occurences, +-- but we keep track of all the TyCons for the mutually inductive data types. +-- We separate the occurences per data constructor only to provide better error messages. +type OccurrenceMap = M.HashMap TyCon [(DataCon, TyConOccurrence)]++data TyConOccurrence+    = TyConOcc { posOcc :: [TyCon] -- TyCons that occur in positive positions+               , negOcc :: [TyCon] -- TyCons that occur in negative positions+               }+  deriving Eq++instance Monoid TyConOccurrence where+  mempty = TyConOcc mempty mempty+instance Semigroup TyConOccurrence where+  TyConOcc p1 n1 <> TyConOcc p2 n2 = TyConOcc (L.nub (p1 <> p2)) (L.nub (n1 <> n2))+instance Outputable TyConOccurrence where+  ppr (TyConOcc pos neg) = text "pos" <+> ppr pos <+>  text "neg" <+> ppr neg+++instance Outputable OccurrenceMap where+  ppr m = ppr (M.toList m)+++makeOccurrences :: [TyCon] -> OccurrenceMap+makeOccurrences tycons+  = let m0 = M.fromList [(tc, map (\dc -> (dc, makeOccurrence tcInfo (dctypes dc))) (tyConDataCons tc))+                        | tc <- tycons']+    -- fixpoint to find occurrences of mutually recursive data definitons+    in fix (\m -> foldl merge m tycons') m0+  where+    fix f x = let x' = f x in if x == x' then x else fix f x'+    tcInfo = M.fromList $ zip tycons' (makeTyConVariance <$> tycons')+    merge m tc = M.update (mergeList m) tc m+    mergeList m xs = Just [(dc, mergeApp m am) | (dc,am) <- xs]+    mergeApp m (TyConOcc pos neg) =+        let TyConOcc pospos posneg = mconcat (findOccurrence m <$> pos)+            TyConOcc negpos negneg = mconcat (findOccurrence m <$> neg)+        -- Keep positive, flip negative +        in TyConOcc (L.nub (pos <> pospos <> negneg)) (L.nub (neg <> negpos <> posneg))+++    tycontypes tc = concatMap dctypes $ tyConDataCons tc+    dctypes    dc = irrelevantMult <$> dataConOrigArgTys dc++    -- Construct the map for all TyCons that appear in the definitions +    tycons' = L.nub (concatMap tcs (concatMap tycontypes tycons) ++ tycons)++    tcs (TyConApp tc' ts) = tc': concatMap tcs ts+    tcs (AppTy t1 t2)     = tcs t1 ++ tcs t2+    tcs (ForAllTy _ t)    = tcs t+    tcs (FunTy _ _ t1 t2) = tcs t1 ++ tcs t2+    tcs (TyVarTy _ )      = []+    tcs (LitTy _)         = []+    tcs (CastTy _ _)      = []+    tcs (CoercionTy _)    = []++makeOccurrence :: M.HashMap TyCon VarianceInfo -> [Type] -> TyConOccurrence+makeOccurrence tcInfo = foldl (go Covariant) mempty+  where+    go :: Variance -> TyConOccurrence -> Type -> TyConOccurrence+    go p m (TyConApp tc ts)  = addOccurrence p tc+                             $ foldl (\m' (t, v) -> go (v <> p) m' t) m+                                (zip ts (M.lookupDefault (repeat Bivariant) tc tcInfo))+    go _ m (TyVarTy _ )      = m+    go _ m (AppTy t1 t2)     = go Bivariant (go Bivariant m t1) t2+    go p m (ForAllTy _ t)    = go p m t+    go p m (FunTy _ _ t1 t2) = go p (go (flipVariance p) m t1) t2+    go _ m (LitTy _)         = m+    go _ m (CastTy _ _)      = m+    go _ m (CoercionTy _)    = m++    addOccurrence p tc (TyConOcc pos neg)+      = case p of+         Covariant     -> TyConOcc (L.nub (tc:pos)) neg+         Contravariant -> TyConOcc pos (L.nub (tc:neg))+         Bivariant     -> TyConOcc (L.nub (tc:pos)) (L.nub (tc:neg))+         Invariant     -> TyConOcc pos neg++findOccurrence :: OccurrenceMap -> TyCon -> TyConOccurrence+findOccurrence m tc = mconcat (snd <$> M.lookupDefault mempty tc m)+++++isRecursivenewTyCon :: TyCon -> Bool+isRecursivenewTyCon c+  | not (isNewTyCon c)+  = False+isRecursivenewTyCon c+  = go t+  where+    t = snd $ newTyConRhs c+    go (AppTy t1 t2)      = go t1 || go t2+    go (TyConApp c' ts)   = c == c' || any go ts+    go (ForAllTy _ t1)    = go t1+    go (FunTy _ _ t1 t2)  = go t1 || go t2+    go (CastTy t1 _)      = go t1+    go _                  = False+++isHoleVar :: Var -> Bool+isHoleVar x = L.isPrefixOf "_" (show x)++dataConImplicitIds :: DataCon -> [Id]+dataConImplicitIds dc = [ x | AnId x <- dataConImplicitTyThings dc]++class Subable a where+  sub   :: M.HashMap CoreBndr CoreExpr -> a -> a+  subTy :: M.HashMap TyVar Type -> a -> a++instance Subable CoreExpr where+  sub s (Var v)        = M.lookupDefault (Var v) v s+  sub _ (Lit l)        = Lit l+  sub s (App e1 e2)    = App (sub s e1) (sub s e2)+  sub s (Lam b e)      = Lam b (sub s e)+  sub s (Let b e)      = Let (sub s b) (sub s e)+  sub s (Case e b t a) = Case (sub s e) (sub s b) t (map (sub s) a)+  sub s (Cast e c)     = Cast (sub s e) c+  sub s (Tick t e)     = Tick t (sub s e)+  sub _ (Type t)       = Type t+  sub _ (Coercion c)   = Coercion c++  subTy s (Var v)      = Var (subTy s v)+  subTy _ (Lit l)      = Lit l+  subTy s (App e1 e2)  = App (subTy s e1) (subTy s e2)+  subTy s (Lam b e)    | isTyVar b = Lam v' (subTy s e)+   where v' = case M.lookup b s of+               Just (TyVarTy v) -> v+               _                -> b++  subTy s (Lam b e)      = Lam (subTy s b) (subTy s e)+  subTy s (Let b e)      = Let (subTy s b) (subTy s e)+  subTy s (Case e b t a) = Case (subTy s e) (subTy s b) (subTy s t) (map (subTy s) a)+  subTy s (Cast e c)     = Cast (subTy s e) (subTy s c)+  subTy s (Tick t e)     = Tick t (subTy s e)+  subTy s (Type t)       = Type (subTy s t)+  subTy s (Coercion c)   = Coercion (subTy s c)++instance Subable Coercion where+  sub _ c                = c+  subTy _ _              = panic Nothing "subTy Coercion"++instance Subable (Alt Var) where+ sub s (a, b, e)   = (a, map (sub s) b,   sub s e)+ subTy s (a, b, e) = (a, map (subTy s) b, subTy s e)++instance Subable Var where+ sub s v   | M.member v s = subVar $ s M.! v+           | otherwise    = v+ subTy s v = setVarType v (subTy s (varType v))++subVar :: Expr t -> Id+subVar (Var x) = x+subVar  _      = panic Nothing "sub Var"++instance Subable (Bind Var) where+ sub s (NonRec x e)   = NonRec (sub s x) (sub s e)+ sub s (Rec xes)      = Rec ((sub s *** sub s) <$> xes)++ subTy s (NonRec x e) = NonRec (subTy s x) (subTy s e)+ subTy s (Rec xes)    = Rec ((subTy s  *** subTy s) <$> xes)++instance Subable Type where+ sub _ e   = e+ subTy     = substTysWith++substTysWith :: M.HashMap Var Type -> Type -> Type+substTysWith s tv@(TyVarTy v)      = M.lookupDefault tv v s+substTysWith s (FunTy aaf m t1 t2) = FunTy aaf m (substTysWith s t1) (substTysWith s t2)+substTysWith s (ForAllTy v t)      = ForAllTy v (substTysWith (M.delete (binderVar v) s) t)+substTysWith s (TyConApp c ts)     = TyConApp c (map (substTysWith s) ts)+substTysWith s (AppTy t1 t2)       = AppTy (substTysWith s t1) (substTysWith s t2)+substTysWith _ (LitTy t)           = LitTy t+substTysWith s (CastTy t c)        = CastTy (substTysWith s t) c+substTysWith _ (CoercionTy c)      = CoercionTy c++substExpr :: M.HashMap Var Var -> CoreExpr -> CoreExpr+substExpr s = go+  where+    subsVar v                = M.lookupDefault v v s+    go (Var v)               = Var $ subsVar v+    go (Lit l)               = Lit l+    go (App e1 e2)           = App (go e1) (go e2)+    go (Lam x e)             = Lam (subsVar x) (go e)+    go (Let (NonRec x ex) e) = Let (NonRec (subsVar x) (go ex)) (go e)+    go (Let (Rec xes) e)     = Let (Rec [(subsVar x', go e') | (x',e') <- xes]) (go e)+    go (Case e b t alts)     = Case (go e) (subsVar b) t [(c, subsVar <$> xs, go e') | (c, xs, e') <- alts]+    go (Cast e c)            = Cast (go e) c+    go (Tick t e)            = Tick t (go e)+    go (Type t)              = Type t+    go (Coercion c)          = Coercion c++mapType :: (Type -> Type) -> Type -> Type+mapType f = go+  where+    go t@(TyVarTy _)        = f t+    go (AppTy t1 t2)        = f $ AppTy (go t1) (go t2)+    go (TyConApp c ts)      = f $ TyConApp c (go <$> ts)+    go (FunTy aaf m t1 t2)  = f $ FunTy aaf m (go t1) (go t2)+    go (ForAllTy v t)       = f $ ForAllTy v (go t)+    go t@(LitTy _)          = f t+    go (CastTy t c)         = CastTy (go t) c+    go (CoercionTy c)       = f $ CoercionTy c+++stringClassArg :: Type -> Maybe Type+stringClassArg t | isFunTy t+  = Nothing+stringClassArg t+  = case (tyConAppTyCon_maybe t, tyConAppArgs_maybe t) of+      (Just c, Just [t']) | isStringClassName == tyConName c+           -> Just t'+      _    -> Nothing
+ src-ghc/Liquid/GHC/Resugar.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE UndecidableInstances      #-}++-- | This module contains functions for "resugaring" low-level GHC `CoreExpr`+--   into high-level patterns, that can receive special case handling in+--   different phases (e.g. ANF, Constraint Generation, etc.)++module Liquid.GHC.Resugar (+  -- * High-level Source Patterns+    Pattern (..)++  -- * Lift a CoreExpr into a Pattern+  , lift++  -- * Lower a pattern back into a CoreExpr+  , lower+  ) where++import qualified Data.List as L+import           Liquid.GHC.API  as Ghc hiding (PatBind)+import qualified Liquid.GHC.Misc as GM+import qualified Language.Fixpoint.Types          as F +import qualified Text.PrettyPrint.HughesPJ        as PJ +-- import           Debug.Trace++--------------------------------------------------------------------------------+-- | Data type for high-level patterns -----------------------------------------+--------------------------------------------------------------------------------++data Pattern+  = PatBind+      { patE1  :: !CoreExpr+      , patX   :: !Var+      , patE2  :: !CoreExpr+      , patM   :: !Type+      , patDct :: !CoreExpr+      , patTyA :: !Type+      , patTyB :: !Type+      , patFF  :: !Var+      }                      -- ^ e1 >>= \x -> e2++  | PatReturn                -- return @ m @ t @ $dT @ e+     { patE    :: !CoreExpr  -- ^ e+     , patM    :: !Type      -- ^ m+     , patDct  :: !CoreExpr  -- ^ $dT+     , patTy   :: !Type      -- ^ t+     , patRet  :: !Var       -- ^ "return"+     }++  | PatProject               -- (case xe as x of C [x1,...,xn] -> xi) : ty+    { patXE    :: !Var       -- ^ xe+    , patX     :: !Var       -- ^ x+    , patTy    :: !Type      -- ^ ty+    , patCtor  :: !DataCon   -- ^ C+    , patBinds :: ![Var]     -- ^ [x1,...,xn]+    , patIdx   :: !Int       -- ^ i :: NatLT {len patBinds}+    }++  | PatSelfBind              -- let x = e in x+    { patX     :: !Var       -- ^ x+    , patE     :: !CoreExpr  -- ^ e+    }++  | PatSelfRecBind           -- letrec x = e in x+    { patX     :: !Var       -- ^ x+    , patE     :: !CoreExpr  -- ^ e+    }++instance F.PPrint Pattern where +  pprintTidy  = ppPat++ppPat :: F.Tidy -> Pattern -> PJ.Doc +ppPat k (PatReturn e m d t rv) = +  "PatReturn: " +  PJ.$+$ +  F.pprintKVs k+    [ ("rv" :: PJ.Doc, GM.pprDoc rv) +    , ("e " :: PJ.Doc, GM.pprDoc e) +    , ("m " :: PJ.Doc, GM.pprDoc m) +    , ("$d" :: PJ.Doc, GM.pprDoc d) +    , ("t " :: PJ.Doc, GM.pprDoc t) +    ] +ppPat _ _  = "TODO: PATTERN" +    ++_mbId :: CoreExpr -> Maybe Var+_mbId (Var x)    = Just x+_mbId (Tick _ e) = _mbId e+_mbId _          = Nothing++--------------------------------------------------------------------------------+-- | Lift expressions into High-level patterns ---------------------------------+--------------------------------------------------------------------------------+lift :: CoreExpr -> Maybe Pattern+--------------------------------------------------------------------------------+lift e = exprArgs e (collectArgs e)++exprArgs :: CoreExpr -> (CoreExpr, [CoreExpr]) -> Maybe Pattern+exprArgs _e (Var op, [Type m, d, Type a, Type b, e1, Lam x e2])+  | op `is` Ghc.bindMName+  = Just (PatBind e1 x e2 m d a b op)++exprArgs (Case (Var xe) x t [(DataAlt c, ys, Var y)]) _+  | Just i <- y `L.elemIndex` ys+  = Just (PatProject xe x t c ys i)+++{- TEMPORARILY DISABLED: TODO-REBARE; in reality it hasn't been working AT ALL +   since at least the GHC 8.2.1 port (?) because the TICKs get in the way +   of recognizing the pattern? Anyways, messes up ++     tests/pattern/pos/Return00.hs  ++   because we treat _all_ types of the form `m a` as "invariant" in the parameter `a`.+   Looks like the above tests only pass in earlier LH versions because this pattern +   was NOT getting tickled!++exprArgs _e (Var op, [Type m, d, Type t, e])+  | op `is` PN.returnMName+  = Just (PatReturn e m d t op)+-}++{- TEMPORARILY DISBLED++exprArgs (Let (NonRec x e) e') _+  | Just y <- _mbId e', x == y+  = Just (PatSelfBind x e)++exprArgs (Let (Rec [(x, e)]) e') _+  | Just y <- _mbId e', x == y+  = Just (PatSelfRecBind x e)++-}+exprArgs _ _+  = Nothing++is :: Var -> Name -> Bool+is v n = n == getName v++--------------------------------------------------------------------------------+-- | Lower patterns back into expressions --------------------------------------+--------------------------------------------------------------------------------+lower :: Pattern -> CoreExpr+--------------------------------------------------------------------------------+lower (PatBind e1 x e2 m d a b op)+  = Ghc.mkCoreApps (Var op) [Type m, d, Type a, Type b, e1, Lam x e2]++lower (PatReturn e m d t op)+  = Ghc.mkCoreApps (Var op) [Type m, d, Type t, e]++lower (PatProject xe x t c ys i)+  = Case (Var xe) x t [(DataAlt c, ys, Var yi)] where yi = ys !! i++lower (PatSelfBind x e)+  = Let (NonRec x e) (Var x)++lower (PatSelfRecBind x e)+  = Let (Rec [(x, e)]) (Var x)
+ src-ghc/Liquid/GHC/SpanStack.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE BangPatterns #-}++module Liquid.GHC.SpanStack+   ( -- * Stack of positions+     Span (..)+   , SpanStack++     -- * Creating Stacks+   , empty, push++     -- * Using Stacks+   , srcSpan++     -- * Creating general spans+   , showSpan+   ) where++import           Prelude                   hiding (error)+import           Data.Maybe                       (listToMaybe, fromMaybe)+import           Liquid.GHC.Misc (tickSrcSpan, showPpr)+import qualified Liquid.GHC.API  as Ghc+import           Liquid.GHC.API  ( SrcSpan+                                                  , fsLit+                                                  , getSrcSpan+                                                  , isGoodSrcSpan+                                                  , mkGeneralSrcSpan+                                                  )++-- | Opaque type for a stack of spans+newtype SpanStack = SpanStack { unStack :: [(Span, SrcSpan)] }++--------------------------------------------------------------------------------+empty :: SpanStack+--------------------------------------------------------------------------------+empty = SpanStack []++--------------------------------------------------------------------------------+push :: Span -> SpanStack -> SpanStack+--------------------------------------------------------------------------------+push !s stk -- @(SpanStack stk)+  | Just sp <- spanSrcSpan s = SpanStack ((s, sp) : unStack stk)+  | otherwise                = stk++-- | A single span+data Span+  = Var  !Ghc.Var               -- ^ binder for whom we are generating constraint+  | Tick !(Ghc.Tickish Ghc.Var) -- ^ nearest known Source Span+  | Span SrcSpan++instance Show Span where+  show (Var x)   = show x+  show (Tick tt) = showPpr tt+  show (Span s)  = show s ++--------------------------------------------------------------------------------+srcSpan :: SpanStack -> SrcSpan+--------------------------------------------------------------------------------+srcSpan s  = fromMaybe noSpan (mbSrcSpan s)+  where+    noSpan = showSpan "Yikes! No source information"++mbSrcSpan :: SpanStack -> Maybe SrcSpan+mbSrcSpan = fmap snd . listToMaybe  . unStack++spanSrcSpan :: Span -> Maybe SrcSpan+spanSrcSpan      = maybeSpan Nothing . go+  where+    go (Var x)   = getSrcSpan x+    go (Tick tt) = tickSrcSpan tt+    go (Span s)  = s ++maybeSpan :: Maybe SrcSpan -> SrcSpan -> Maybe SrcSpan+maybeSpan d sp+  | isGoodSrcSpan sp = Just sp+  | otherwise        = d++--------------------------------------------------------------------------------+showSpan :: (Show a) => a -> SrcSpan+--------------------------------------------------------------------------------+showSpan = mkGeneralSrcSpan . fsLit . show
+ src-ghc/Liquid/GHC/TypeRep.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE UndecidableInstances      #-}+{-# LANGUAGE StandaloneDeriving        #-}++{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- TODO(#1918): Only needed for GHC <9.0.1.+{-# OPTIONS_GHC -Wno-orphans #-}++module Liquid.GHC.TypeRep (+  mkTyArg, ++  showTy+  ) where++import           Liquid.GHC.Misc (showPpr)+import           Liquid.GHC.API as Ghc hiding (mkTyArg, showPpr, panic)+import           Language.Fixpoint.Types (symbol)++-- e368f3265b80aeb337fbac3f6a70ee54ab14edfd++mkTyArg :: TyVar -> TyVarBinder+mkTyArg v = Bndr v Required++instance Eq Type where+  t1 == t2 = eqType' t1 t2++eqType' :: Type -> Type -> Bool +eqType' (LitTy l1) (LitTy l2) +  = l1 == l2  +eqType' (CoercionTy c1) (CoercionTy c2) +  = c1 == c2  +eqType'(CastTy t1 c1) (CastTy t2 c2) +  = eqType' t1 t2 && c1 == c2 +eqType' (FunTy a1 m1 t11 t12) (FunTy a2 m2 t21 t22)+  = a1 == a2 && m1 == m2 && eqType' t11 t21 && eqType' t12 t22  +eqType' (ForAllTy (Bndr v1 _) t1) (ForAllTy (Bndr v2 _) t2) +  = eqType' t1 (subst v2 (TyVarTy v1) t2) +eqType' (TyVarTy v1) (TyVarTy v2) +  = v1 == v2 +eqType' (AppTy t11 t12) (AppTy t21 t22) +  = eqType' t11 t21 && eqType' t12 t22  +eqType' (TyConApp c1 ts1) (TyConApp c2 ts2) +  = c1 == c2 && and (zipWith eqType' ts1 ts2) +eqType' _ _ +  = False +++deriving instance (Eq tyvar, Eq argf) => Eq (VarBndr tyvar argf)++instance Eq Coercion where+  _ == _ = True +++showTy :: Type -> String +showTy (TyConApp c ts) = "(RApp   " ++ showPpr c ++ " " ++ sep' ", " (showTy <$> ts) ++ ")"+showTy (AppTy t1 t2)   = "(TAppTy " ++ (showTy t1 ++ " " ++ showTy t2) ++ ")" +showTy (TyVarTy v)   = "(RVar " ++ show (symbol v)  ++ ")" +showTy (ForAllTy (Bndr v _) t)  = "ForAllTy " ++ show (symbol v) ++ ". (" ++  showTy t ++ ")"+showTy (FunTy af _m1 t1 t2) = "FunTy " ++ showPpr af ++ " " ++ showTy t1 ++ ". (" ++  showTy t2 ++ ")"+showTy (CastTy _ _)    = "CastTy"+showTy (CoercionTy _)  = "CoercionTy"+showTy (LitTy _)       = "LitTy"++sep' :: String -> [String] -> String+sep' _ [x] = x+sep' _ []  = []+sep' s (x:xs) = x ++ s ++ sep' s xs ++++-------------------------------------------------------------------------------+-- | GHC Type Substitutions ---------------------------------------------------+-------------------------------------------------------------------------------++class SubstTy a where+  subst :: TyVar -> Type -> a -> a+  subst _ _ = id  ++instance SubstTy Type where+  subst = substType++substType :: TyVar -> Type -> Type -> Type+substType x tx (TyConApp c ts) +  = TyConApp c (subst x tx <$> ts)+substType x tx (AppTy t1 t2)   +  = AppTy (subst x tx t1) (subst x tx t2) +substType x tx (TyVarTy y)   +  | symbol x == symbol y+  = tx +  | otherwise+  = TyVarTy y +substType x tx (FunTy aaf m t1 t2)+  = FunTy aaf m (subst x tx t1) (subst x tx t2)+substType x tx f@(ForAllTy b@(Bndr y _) t)  +  | symbol x == symbol y +  = f+  | otherwise +  = ForAllTy b (subst x tx t)+substType x tx (CastTy t c)    +  = CastTy (subst x tx t) (subst x tx c)+substType x tx (CoercionTy c)  +  = CoercionTy $ subst x tx c +substType _ _  (LitTy l)+  = LitTy l  +++instance SubstTy Coercion where+  subst = substCoercion++substCoercion :: TyVar -> Type -> Coercion -> Coercion+substCoercion x tx (TyConAppCo r c cs)+  = TyConAppCo (subst x tx r) c (subst x tx <$> cs)+substCoercion x tx (AppCo c1 c2)+  = AppCo (subst x tx c1) (subst x tx c2)+substCoercion x tx (FunCo r cN c1 c2)+  = FunCo r cN (subst x tx c1) (subst x tx c2) -- TODO(adinapoli) Is this the correct substitution?+substCoercion x tx (ForAllCo y c1 c2)+  | symbol x == symbol y +  = ForAllCo y c1 c2+  | otherwise +  = ForAllCo y (subst x tx c1) (subst x tx c2)+substCoercion _ _ (CoVarCo y)+  = CoVarCo y +substCoercion x tx (AxiomInstCo co bi cs)+  = AxiomInstCo (subst x tx co) bi (subst x tx <$> cs)  +substCoercion x tx (UnivCo y r t1 t2)+  = UnivCo (subst x tx y) (subst x tx r) (subst x tx t1) (subst x tx t2)+substCoercion x tx (SymCo c)+  = SymCo (subst x tx c)+substCoercion x tx (TransCo c1 c2)+  = TransCo (subst x tx c1) (subst x tx c2)+substCoercion x tx (AxiomRuleCo ca cs)+  = AxiomRuleCo (subst x tx ca)  (subst x tx <$> cs)  +substCoercion x tx (NthCo r i c)+  = NthCo r i (subst x tx c)+substCoercion x tx (LRCo i c)+  = LRCo i (subst x tx c)+substCoercion x tx (InstCo c1 c2)+  = InstCo (subst x tx c1) (subst x tx c2)+substCoercion x tx (KindCo c)+  = KindCo (subst x tx c)+substCoercion x tx (SubCo c)+  = SubCo (subst x tx c)++instance SubstTy Role where+instance SubstTy (CoAxiom Branched) where++instance SubstTy UnivCoProvenance where+  subst x tx (PhantomProv c)+    = PhantomProv $ subst x tx c +  subst x tx (ProofIrrelProv c)+    = ProofIrrelProv $ subst x tx c +  subst _ _ ch +    = ch ++instance SubstTy CoAxiomRule where+  subst x tx (CoAxiomRule n rs r ps) +    = CoAxiomRule n (subst x tx <$> rs) (subst x tx r) (\eq -> subst x tx (ps (subst x tx eq)))++instance (SubstTy a, Functor m) => SubstTy (m a) where+  subst x tx xs = subst x tx <$> xs
+ src-ghc/Liquid/GHC/Types.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE DeriveGeneric #-}+module Liquid.GHC.Types where++import           Data.HashSet (HashSet, fromList)+import           Data.Hashable+import           GHC.Generics hiding (moduleName)+import           Liquid.GHC.API++-- | A 'StableName' is virtually isomorphic to a GHC's 'Name' but crucially we don't use+-- the 'Eq' instance defined on a 'Name' because it's 'Unique'-based. In particular, GHC+-- doesn't guarantee that if we load an interface multiple times we would get the same 'Unique' for the+-- same 'Name', and this is a problem when we rely on 'Name's to be the same when we call 'isExportedVar',+-- which used to use a 'NameSet' derived from the '[AvailInfo]'. As the name implies, a 'NameSet' uses a+-- 'Name's 'Unique' for duplicate detection and indexing, and this would lead to 'Var's being resolved to+-- a 'Name' which is basically the same, but it has a /different/ 'Unique', and that would cause the lookup+-- inside the 'NameSet' to fail.+newtype StableName =+  MkStableName { unStableName :: Name }+  deriving Generic++instance Show StableName where+  show (MkStableName n) = nameStableString n++instance Hashable StableName where+  hashWithSalt s (MkStableName n) = hashWithSalt s (nameStableString n)++instance Eq StableName where+  (MkStableName n1) == (MkStableName n2) = -- n1 `stableNameCmp` n2 == EQ+    let sameOccName = occNameString (nameOccName n1) == occNameString (nameOccName n2)+        sameModule  = nameModule  n1 == nameModule  n2+        sameSrcLoc  = nameSrcLoc  n1 == nameSrcLoc  n2+        sameSrcSpan = nameSrcSpan n1 == nameSrcSpan n2+    in sameOccName && sameModule && sameSrcLoc  && sameSrcSpan++-- | Creates a new 'StableName' out of a 'Name'.+mkStableName :: Name -> StableName+mkStableName = MkStableName++-- | Converts a list of 'AvailInfo' into a \"StableNameSet\", similarly to what 'availsToNameSet' would do.+availsToStableNameSet :: [AvailInfo] -> HashSet StableName+availsToStableNameSet avails = foldr add mempty avails+      where add av acc = acc <> fromList (map mkStableName (availNames av))++--------------------------------------------------------------------------------+-- | Datatype For Holding GHC ModGuts ------------------------------------------+--------------------------------------------------------------------------------+data MGIModGuts = MI+  { mgi_binds     :: !CoreProgram+  , mgi_module    :: !Module+  , mgi_deps      :: !Dependencies+  , mgi_dir_imps  :: ![ModuleName]+  , mgi_rdr_env   :: !GlobalRdrEnv+  , mgi_tcs       :: ![TyCon]+  , mgi_fam_insts :: ![FamInst]+  , mgi_exports   :: !(HashSet StableName)+  , mgi_cls_inst  :: !(Maybe [ClsInst])+  }++miModGuts :: Maybe [ClsInst] -> ModGuts -> MGIModGuts+miModGuts cls mg  = MI+  { mgi_binds     = mg_binds mg+  , mgi_module    = mg_module mg+  , mgi_deps      = mg_deps mg+  , mgi_dir_imps  = mgDirImps mg+  , mgi_rdr_env   = mg_rdr_env mg+  , mgi_tcs       = mg_tcs mg+  , mgi_fam_insts = mg_fam_insts mg+  , mgi_exports   = availsToStableNameSet $ mg_exports mg+  , mgi_cls_inst  = cls+  }++nameSetToStableNameSet :: NameSet -> HashSet StableName+nameSetToStableNameSet = fromList . map mkStableName . nameSetElemsStable++mgDirImps :: ModGuts -> [ModuleName]+mgDirImps = map gwib_mod . getDependenciesModuleNames . mg_deps++mgiNamestring :: MGIModGuts -> String+mgiNamestring = moduleNameString . moduleName . mgi_module
src/Language/Haskell/Liquid/Bare.hs view
@@ -2,8 +2,6 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables       #-} {-# LANGUAGE TupleSections             #-}-{-# LANGUAGE RecordWildCards           #-}-{-# LANGUAGE ViewPatterns              #-} {-# LANGUAGE PartialTypeSignatures     #-} {-# LANGUAGE OverloadedStrings         #-} @@ -25,7 +23,7 @@  import           Prelude                                    hiding (error) import           Optics-import           Control.Monad                              (unless, forM)+import           Control.Monad                              (forM) import           Control.Applicative                        ((<|>)) import qualified Control.Exception                          as Ex import qualified Data.Binary                                as B@@ -38,30 +36,30 @@ import           System.Directory                           (doesFileExist) import           System.Console.CmdArgs.Verbosity           (whenLoud) import           Language.Fixpoint.Utils.Files              as Files-import           Language.Fixpoint.Misc                     as Misc +import           Language.Fixpoint.Misc                     as Misc import           Language.Fixpoint.Types                    hiding (dcFields, DataDecl, Error, panic) import qualified Language.Fixpoint.Types                    as F import qualified Language.Haskell.Liquid.Misc               as Misc -- (nubHashOn)-import qualified Language.Haskell.Liquid.GHC.Misc           as GM-import qualified Language.Haskell.Liquid.GHC.API            as Ghc -import           Language.Haskell.Liquid.GHC.Types          (StableName)+import qualified Liquid.GHC.Misc           as GM+import qualified Liquid.GHC.API            as Ghc+import           Liquid.GHC.Types          (StableName) import           Language.Haskell.Liquid.Types import           Language.Haskell.Liquid.WiredIn import qualified Language.Haskell.Liquid.Measure            as Ms-import qualified Language.Haskell.Liquid.Bare.Types         as Bare -import qualified Language.Haskell.Liquid.Bare.Resolve       as Bare +import qualified Language.Haskell.Liquid.Bare.Types         as Bare+import qualified Language.Haskell.Liquid.Bare.Resolve       as Bare import qualified Language.Haskell.Liquid.Bare.DataType      as Bare import           Language.Haskell.Liquid.Bare.Elaborate-import qualified Language.Haskell.Liquid.Bare.Expand        as Bare -import qualified Language.Haskell.Liquid.Bare.Measure       as Bare -import qualified Language.Haskell.Liquid.Bare.Plugged       as Bare -import qualified Language.Haskell.Liquid.Bare.Axiom         as Bare -import qualified Language.Haskell.Liquid.Bare.ToBare        as Bare -import qualified Language.Haskell.Liquid.Bare.Class         as Bare -import qualified Language.Haskell.Liquid.Bare.Check         as Bare +import qualified Language.Haskell.Liquid.Bare.Expand        as Bare+import qualified Language.Haskell.Liquid.Bare.Measure       as Bare+import qualified Language.Haskell.Liquid.Bare.Plugged       as Bare+import qualified Language.Haskell.Liquid.Bare.Axiom         as Bare+import qualified Language.Haskell.Liquid.Bare.ToBare        as Bare+import qualified Language.Haskell.Liquid.Bare.Class         as Bare+import qualified Language.Haskell.Liquid.Bare.Check         as Bare import qualified Language.Haskell.Liquid.Bare.Laws          as Bare-import qualified Language.Haskell.Liquid.Bare.Typeclass     as Bare -import qualified Language.Haskell.Liquid.Transforms.CoreToLogic as CoreToLogic +import qualified Language.Haskell.Liquid.Bare.Typeclass     as Bare+import qualified Language.Haskell.Liquid.Transforms.CoreToLogic as CoreToLogic import           Control.Arrow                    (second) import Data.Hashable (Hashable) import qualified Language.Haskell.Liquid.Bare.Slice as Dg@@ -72,13 +70,13 @@  loadLiftedSpec :: Config -> FilePath -> IO (Maybe Ms.BareSpec) loadLiftedSpec cfg srcF-  | noLiftedImport cfg = putStrLn "No LIFTED Import" >> return Nothing +  | 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 +      lSp <- if ex+               then Just <$> B.decodeFile specF                else {- warnMissingLiftedSpec srcF specF >> -} return Nothing       Ex.evaluate lSp @@ -88,10 +86,7 @@ --   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 -> Ms.BareSpec -> IO () +saveLiftedSpec :: FilePath -> Ms.BareSpec -> IO () saveLiftedSpec srcF lspec = do   ensurePath specF   B.encodeFile specF lspec@@ -123,9 +118,10 @@                -> TargetDependencies                -> Ghc.TcRn (Either Diagnostics ([Warning], TargetSpec, LiftedSpec)) makeTargetSpec cfg lmap targetSrc bareSpec dependencies = do+  let targDiagnostics     = Bare.checkTargetSrc cfg targetSrc   let depsDiagnostics     = mapM (uncurry Bare.checkBareSpec) legacyDependencies   let bareSpecDiagnostics = Bare.checkBareSpec (giTargetMod targetSrc) legacyBareSpec-  case depsDiagnostics >> bareSpecDiagnostics of+  case targDiagnostics >> depsDiagnostics >> bareSpecDiagnostics of    Left d | noErrors d -> secondPhase (allWarnings d)    Left d              -> return $ Left d    Right ()            -> secondPhase mempty@@ -198,9 +194,9 @@                                          (ghcSpecEnv sp)                                          (_giCbs src)                                          (fst . view targetSpecGetter $ sp)-  pure $ if not (noErrors dg0) then Left dg0 else +  pure $ if not (noErrors dg0) then Left dg0 else            case diagnostics of-             Left dg1 +             Left dg1                | noErrors dg1 -> pure (allWarnings dg1, sp)                | otherwise    -> Left dg1              Right ()         -> pure (mempty, sp)@@ -210,7 +206,7 @@ ghcSpecEnv sp = F.notracepp "RENV" $ fromListSEnv binds   where     emb       = gsTcEmbeds (_gsName sp)-    binds     = F.notracepp "binds" $ concat +    binds     = F.notracepp "binds" $ concat                  [ [(x,        rSort t) | (x, Loc _ _ t)  <- gsMeas     (_gsData sp)]                  , [(symbol v, rSort t) | (v, Loc _ _ t)  <- gsCtors    (_gsData sp)]                  , [(symbol v, vSort v) | v               <- gsReflects (_gsRefl sp)]@@ -230,48 +226,48 @@ --   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)] -> +makeGhcSpec0 :: Config -> GhcSrc ->  LogicMap -> [(ModName, Ms.BareSpec)] ->                 Ghc.TcRn (Diagnostics, GhcSpec) makeGhcSpec0 cfg src lmap mspecsNoCls = do   -- build up environments-  tycEnv <- makeTycEnv1 cfg name env (tycEnv0, datacons) coreToLg simplifier-  let tyi      = Bare.tcTyConMap   tycEnv -  let sigEnv   = makeSigEnv  embs tyi (_gsExports src) rtEnv -  let lSpec1   = lSpec0 <> makeLiftedSpec1 cfg src tycEnv lmap mySpec1 -  let mySpec   = mySpec2 <> lSpec1 +  tycEnv <- makeTycEnv1 name env (tycEnv0, datacons) coreToLg simplifier+  let tyi      = Bare.tcTyConMap   tycEnv+  let sigEnv   = makeSigEnv  embs tyi (_gsExports src) rtEnv+  let lSpec1   = lSpec0 <> makeLiftedSpec1 cfg src tycEnv lmap mySpec1+  let mySpec   = mySpec2 <> lSpec1   let specs    = M.insert name mySpec iSpecs2-  let myRTE    = myRTEnv       src env sigEnv rtEnv  -  let (dg5, measEnv) = withDiagnostics $ makeMeasEnv      env tycEnv sigEnv       specs +  let myRTE    = myRTEnv       src env sigEnv rtEnv+  let (dg5, measEnv) = withDiagnostics $ makeMeasEnv      env tycEnv sigEnv       specs   let (dg4, sig) = withDiagnostics $ makeSpecSig cfg name specs env sigEnv   tycEnv measEnv (_giCbs src)   elaboratedSig <-     if allowTC then Bare.makeClassAuxTypes (elaborateSpecType coreToLg simplifier) datacons instMethods                               >>= elaborateSig sig                else pure sig-  let qual     = makeSpecQual cfg env tycEnv measEnv rtEnv specs -  let sData    = makeSpecData  src env sigEnv measEnv elaboratedSig specs +  let qual     = makeSpecQual cfg env tycEnv measEnv rtEnv specs+  let sData    = makeSpecData  src env sigEnv measEnv elaboratedSig specs   let (dg1, spcVars) = withDiagnostics $ makeSpecVars cfg src mySpec env measEnv-  let (dg2, spcTerm) = withDiagnostics $ makeSpecTerm cfg     mySpec env       name    -  let (dg3, refl)    = withDiagnostics $ makeSpecRefl cfg src measEnv specs env name elaboratedSig tycEnv -  let laws     = makeSpecLaws env sigEnv (gsTySigs elaboratedSig ++ gsAsmSigs elaboratedSig) measEnv specs +  let (dg2, spcTerm) = withDiagnostics $ makeSpecTerm cfg     mySpec env       name+  let (dg3, refl)    = withDiagnostics $ makeSpecRefl cfg src measEnv specs env name elaboratedSig tycEnv+  let laws     = makeSpecLaws env sigEnv (gsTySigs elaboratedSig ++ gsAsmSigs elaboratedSig) measEnv specs   let finalLiftedSpec = makeLiftedSpec name src env refl sData elaboratedSig qual myRTE lSpec1   let diags    = mconcat [dg0, dg1, dg2, dg3, dg4, dg5] -  pure (diags, SP -    { _gsConfig = cfg +  pure (diags, SP+    { _gsConfig = cfg     , _gsImps   = makeImports mspecs     , _gsSig    = addReflSigs env name rtEnv refl elaboratedSig-    , _gsRefl   = refl -    , _gsLaws   = laws -    , _gsData   = sData -    , _gsQual   = qual -    , _gsName   = makeSpecName env     tycEnv measEnv   name +    , _gsRefl   = refl+    , _gsLaws   = laws+    , _gsData   = sData+    , _gsQual   = qual+    , _gsName   = makeSpecName env     tycEnv measEnv   name     , _gsVars   = spcVars     , _gsTerm   = spcTerm      , _gsLSpec  = finalLiftedSpec                 { impSigs   = makeImports mspecs                 , expSigs   = [ (F.symbol v, F.sr_sort $ Bare.varSortedReft embs v) | v <- gsReflects refl ]-                , dataDecls = dataDecls mySpec2 +                , dataDecls = Bare.dataDeclSize mySpec $ dataDecls mySpec                 , measures  = Ms.measures mySpec                   -- We want to export measures in a 'LiftedSpec', especially if they are                   -- required to check termination of some 'liftedSigs' we export. Due to the fact@@ -286,20 +282,20 @@                   -- Preserve user-defined 'dvariance'.                 , rinstance = Ms.rinstance finalLiftedSpec ++ Ms.rinstance mySpec                   -- Preserve rinstances.-                } +                }     })   where     -- typeclass elaboration -    coreToLg e =+    coreToLg ce =       case CoreToLogic.runToLogic              embs              lmap              dm              (\x -> todo Nothing ("coreToLogic not working " ++ x))-             (CoreToLogic.coreToLogic allowTC e) of+             (CoreToLogic.coreToLogic allowTC ce) of         Left msg -> panic Nothing (F.showpp msg)-        Right e -> e    +        Right e -> e     elaborateSig si auxsig = do       tySigs <-         forM (gsTySigs si) $ \(x, t) ->@@ -321,30 +317,30 @@     allowTC  = typeclass cfg     mySpec2  = Bare.qualifyExpand env name rtEnv l [] mySpec1    where l = F.dummyPos "expand-mySpec2"     iSpecs2  = Bare.qualifyExpand env name rtEnv l [] iSpecs0    where l = F.dummyPos "expand-iSpecs2"-    rtEnv    = Bare.makeRTEnv env name mySpec1 iSpecs0 lmap  +    rtEnv    = Bare.makeRTEnv env name mySpec1 iSpecs0 lmap     mspecs   = if allowTC then M.toList $ M.insert name mySpec0 iSpecs0 else mspecsNoCls     (mySpec0, instMethods)  = if allowTC                               then Bare.compileClasses src env (name, mySpec0NoCls) (M.toList iSpecs0)                               else (mySpec0NoCls, [])-    mySpec1  = mySpec0 <> lSpec0    -    lSpec0   = makeLiftedSpec0 cfg src embs lmap mySpec0 +    mySpec1  = mySpec0 <> lSpec0+    lSpec0   = makeLiftedSpec0 cfg src embs lmap mySpec0     embs     = makeEmbeds          src env ((name, mySpec0) : M.toList iSpecs0)     dm       = Bare.tcDataConMap tycEnv0-    (dg0, datacons, tycEnv0) = makeTycEnv0   cfg name env embs mySpec2 iSpecs2 +    (dg0, datacons, tycEnv0) = makeTycEnv0   cfg name env embs mySpec2 iSpecs2     -- extract name and specs     env      = Bare.makeEnv cfg src lmap mspecsNoCls     (mySpec0NoCls, iSpecs0) = splitSpecs name src mspecsNoCls     -- check barespecs -    name     = F.notracepp ("ALL-SPECS" ++ zzz) $ _giTargetMod  src +    name     = F.notracepp ("ALL-SPECS" ++ zzz) $ _giTargetMod  src     zzz      = F.showpp (fst <$> mspecs) -splitSpecs :: ModName -> GhcSrc -> [(ModName, Ms.BareSpec)] -> (Ms.BareSpec, Bare.ModSpecs) -splitSpecs name src specs = (mySpec, iSpecm) -  where +splitSpecs :: ModName -> GhcSrc -> [(ModName, Ms.BareSpec)] -> (Ms.BareSpec, Bare.ModSpecs)+splitSpecs name src specs = (mySpec, iSpecm)+  where     iSpecm             = fmap mconcat . Misc.group $ iSpecs     iSpecs             = Dg.sliceSpecs src mySpec iSpecs'     mySpec             = mconcat (snd <$> mySpecs)-    (mySpecs, iSpecs') = L.partition ((name ==) . fst) specs +    (mySpecs, iSpecs') = L.partition ((name ==) . fst) specs   makeImports :: [(ModName, Ms.BareSpec)] -> [(F.Symbol, F.Sort)]@@ -352,17 +348,17 @@   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 +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) +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" +      symTc = Mb.maybeToList . Bare.maybeResolveSym env name "embed-tycon"  -------------------------------------------------------------------------------- -- | [NOTE]: REFLECT-IMPORTS@@ -375,7 +371,7 @@ --   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 +makeLiftedSpec1 :: Config -> GhcSrc -> Bare.TycEnv -> LogicMap -> Ms.BareSpec                 -> Ms.BareSpec makeLiftedSpec1 config src tycEnv lmap mySpec = mempty   { Ms.measures  = Bare.makeHaskellMeasures (typeclass config) src tycEnv lmap mySpec }@@ -392,12 +388,12 @@ -- 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 +makeLiftedSpec0 :: Config -> GhcSrc -> F.TCEmb Ghc.TyCon -> LogicMap -> Ms.BareSpec                 -> Ms.BareSpec makeLiftedSpec0 cfg src embs lmap mySpec = mempty-  { Ms.ealiases  = lmapEAlias . snd <$> Bare.makeHaskellInlines (typeclass cfg) src embs lmap mySpec -  , Ms.reflects  = Ms.reflects mySpec <> (if reflection cfg then Ms.hmeas mySpec else mempty)-  , Ms.dataDecls = Bare.makeHaskellDataDecls cfg name mySpec tcs  +  { Ms.ealiases  = lmapEAlias . snd <$> Bare.makeHaskellInlines (typeclass cfg) src embs lmap mySpec+  , Ms.reflects  = Ms.reflects mySpec+  , Ms.dataDecls = Bare.makeHaskellDataDecls cfg name mySpec tcs   , Ms.embeds    = Ms.embeds mySpec   -- We do want 'embeds' to survive and to be present into the final 'LiftedSpec'. The   -- caveat is to decide which format is more appropriate. We obviously cannot store@@ -407,7 +403,7 @@   -- We do want 'cmeasures' to survive and to be present into the final 'LiftedSpec'. The   -- caveat is to decide which format is more appropriate. This needs more thinking.   }-  where +  where     tcs          = uniqNub (_gsTcs src ++ refTcs)     refTcs       = reflectedTyCons cfg embs cbs  mySpec     cbs          = _giCbs       src@@ -426,7 +422,7 @@ reflectedTyCons cfg embs cbs spec   | exactDCFlag cfg = filter (not . isEmbedded embs)                     $ concatMap varTyCons-                    $ reflectedVars cfg spec cbs+                    $ reflectedVars spec cbs ++ measureVars spec cbs   | otherwise       = []  -- | We cannot reflect embedded tycons (e.g. Bool) as that gives you a sort@@ -444,66 +440,72 @@     tc acc t@RApp {} = rtc_tc (rt_tycon t) : acc     tc acc _         = acc -reflectedVars :: Config -> Ms.BareSpec -> [Ghc.CoreBind] -> [Ghc.Var]-reflectedVars cfg spec cbs = fst <$> xDefs+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 <> if reflection cfg then Ms.hmeas spec else mempty)+    reflSyms           = val <$> S.toList (Ms.reflects spec) +measureVars :: Ms.BareSpec -> [Ghc.CoreBind] -> [Ghc.Var]+measureVars spec cbs = fst <$> xDefs+  where+    xDefs              = Mb.mapMaybe (`GM.findVarDef` cbs) measureSyms+    measureSyms        = val <$> S.toList (Ms.hmeas spec)+ -------------------------------------------------------------------------------------------makeSpecVars :: Config -> GhcSrc -> Ms.BareSpec -> Bare.Env -> Bare.MeasEnv +makeSpecVars :: Config -> GhcSrc -> Ms.BareSpec -> Bare.Env -> Bare.MeasEnv              -> Bare.Lookup GhcSpecVars -------------------------------------------------------------------------------------------makeSpecVars cfg src mySpec env measEnv = do -  tgtVars     <-   mapM (resolveStringVar  env name)              (checks     cfg) -  igVars      <-  sMapM (Bare.lookupGhcVar env name "gs-ignores") (Ms.ignores mySpec) +makeSpecVars cfg src mySpec env measEnv = do+  tgtVars     <-   mapM (resolveStringVar  env name)              (checks     cfg)+  igVars      <-  sMapM (Bare.lookupGhcVar env name "gs-ignores") (Ms.ignores mySpec)   lVars       <-  sMapM (Bare.lookupGhcVar env name "gs-lvars"  ) (Ms.lvars   mySpec)   return (SpVar tgtVars igVars lVars cMethods)-  where -    name       = _giTargetMod src -    cMethods   = snd3 <$> Bare.meMethods measEnv +  where+    name       = _giTargetMod src+    cMethods   = snd3 <$> Bare.meMethods measEnv  sMapM :: (Monad m, Eq b, Hashable b) => (a -> m b) -> S.HashSet a -> m (S.HashSet b)-sMapM f xSet = do - ys <- mapM f (S.toList xSet) +sMapM f xSet = do+ ys <- mapM f (S.toList xSet)  return (S.fromList ys)  sForM :: (Monad m, Eq b, Hashable b) =>S.HashSet a -> (a -> m b) -> m (S.HashSet b) sForM xs f = sMapM f xs -qualifySymbolic :: (F.Symbolic a) => ModName -> a -> F.Symbol +qualifySymbolic :: (F.Symbolic a) => ModName -> a -> F.Symbol qualifySymbolic name s = GM.qualifySymbol (F.symbol name) (F.symbol s)  resolveStringVar :: Bare.Env -> ModName -> String -> Bare.Lookup Ghc.Var resolveStringVar env name s = Bare.lookupGhcVar env name "resolve-string-var" lx-  where +  where     lx                      = dummyLoc (qualifySymbolic name s)    -------------------------------------------------------------------------------------------makeSpecQual :: Config -> Bare.Env -> Bare.TycEnv -> Bare.MeasEnv -> BareRTEnv -> Bare.ModSpecs -             -> GhcSpecQual +makeSpecQual :: Config -> Bare.Env -> Bare.TycEnv -> Bare.MeasEnv -> BareRTEnv -> Bare.ModSpecs+             -> GhcSpecQual -------------------------------------------------------------------------------------------makeSpecQual _cfg env tycEnv measEnv _rtEnv specs = SpQual -  { gsQualifiers = filter okQual quals +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) +  }+  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) +    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) +    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 +makeQualifiers env tycEnv (modn, spec)+  = fmap        (Bare.qualifyTopDummy env        modn)+  . Mb.mapMaybe (resolveQParams       env tycEnv modn)+  $ Ms.qualifiers spec   -- | @resolveQualParams@ converts the sorts of parameters from, e.g. @@ -512,85 +514,102 @@ --   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   +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 +    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 +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 +    embs                = Bare.tcEmbs tycEnv -tyConSort :: F.TCEmb Ghc.TyCon -> F.Located Ghc.TyCon -> F.Sort +tyConSort :: F.TCEmb Ghc.TyCon -> F.Located Ghc.TyCon -> F.Sort tyConSort embs lc = Mb.maybe s0 fst (F.tceLookup c embs)-  where +  where     c             = F.val lc     s0            = tyConSortRaw lc -tyConSortRaw :: F.Located Ghc.TyCon -> F.Sort -tyConSortRaw = FTC . F.symbolFTycon . fmap F.symbol +tyConSortRaw :: F.Located Ghc.TyCon -> F.Sort+tyConSortRaw = FTC . F.symbolFTycon . fmap F.symbol  -------------------------------------------------------------------------------------------makeSpecTerm :: Config -> Ms.BareSpec -> Bare.Env -> ModName -> -                Bare.Lookup GhcSpecTerm +makeSpecTerm :: Config -> Ms.BareSpec -> Bare.Env -> ModName ->+                Bare.Lookup GhcSpecTerm -------------------------------------------------------------------------------------------makeSpecTerm cfg mySpec env name = do +makeSpecTerm cfg mySpec env name = do   sizes  <- if structuralTerm cfg then pure mempty else makeSize env name mySpec   lazies <- makeLazy     env name mySpec   autos  <- makeAutoSize env name mySpec   decr   <- makeDecrs env name mySpec-  fail   <- makeFail env name mySpec -  return  $ SpTerm +  gfail  <- makeFail env name mySpec+  return  $ SpTerm     { gsLazy       = S.insert dictionaryVar (lazies `mappend` sizes)-    , gsFail       = fail+    , gsFail       = gfail     , gsStTerm     = sizes-    , gsAutosize   = autos -    , gsDecr       = decr -    , gsNonStTerm  = mempty +    , gsAutosize   = autos+    , gsDecr       = decr+    , gsNonStTerm  = mempty     }  -- formerly, makeHints-makeDecrs :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup [(Ghc.Var, [Int])] +makeDecrs :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup [(Ghc.Var, [Int])] makeDecrs env name mySpec =-  forM (Ms.decr mySpec) $ \(lx, z) -> do +  forM (Ms.decr mySpec) $ \(lx, z) -> do     v <- Bare.lookupGhcVar env name "decreasing" lx     return (v, z) +makeRelation :: Bare.Env -> ModName -> Bare.SigEnv ->+  [(LocSymbol, LocSymbol, LocBareType, LocBareType, RelExpr, RelExpr)] -> Bare.Lookup [(Ghc.Var, Ghc.Var, LocSpecType, LocSpecType, RelExpr, RelExpr)]+makeRelation env name sigEnv = mapM go+ where+  go (x, y, tx, ty, a, e) = do+    vx <- Bare.lookupGhcVar env name "Var" x+    vy <- Bare.lookupGhcVar env name "Var" y+    return  +        ( vx+        , vy+        , Bare.cookSpecType env sigEnv name (Bare.HsTV vx) tx+        , Bare.cookSpecType env sigEnv name (Bare.HsTV vy) ty+        , a+        , e+        )++ makeLazy :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup (S.HashSet Ghc.Var) makeLazy env name spec =   sMapM (Bare.lookupGhcVar env name "Var") (Ms.lazy spec)  makeFail :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup (S.HashSet (Located Ghc.Var))-makeFail env name spec = -  sForM (Ms.fails spec) $ \x -> do -    vx <- Bare.lookupGhcVar env name "Var" x +makeFail env name spec =+  sForM (Ms.fails spec) $ \x -> do+    vx <- Bare.lookupGhcVar env name "Var" x     return x { val = vx }  makeRewrite :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup (S.HashSet (Located Ghc.Var))-makeRewrite env name spec = +makeRewrite env name spec =   sForM (Ms.rewrites spec) $ \x -> do-    vx <-  Bare.lookupGhcVar env name "Var" x +    vx <-  Bare.lookupGhcVar env name "Var" x     return x { val = vx }  makeRewriteWith :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup (M.HashMap Ghc.Var [Ghc.Var]) makeRewriteWith env name spec = M.fromList <$> makeRewriteWith' env name spec  makeRewriteWith' :: Bare.Env -> ModName -> Spec ty bndr -> Bare.Lookup [(Ghc.Var, [Ghc.Var])]-makeRewriteWith' env name spec = +makeRewriteWith' env name spec =   forM (M.toList $ Ms.rewriteWith spec) $ \(x, xs) -> do     xv  <- Bare.lookupGhcVar env name "Var1" x     xvs <- mapM (Bare.lookupGhcVar env name "Var2") xs@@ -598,17 +617,17 @@  makeAutoSize :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup (S.HashSet Ghc.TyCon) makeAutoSize env name-  = fmap S.fromList -  . mapM (Bare.lookupGhcTyCon env name "TyCon") -  . S.toList -  . Ms.autosize +  = fmap S.fromList+  . mapM (Bare.lookupGhcTyCon env name "TyCon")+  . S.toList+  . Ms.autosize  makeSize :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup (S.HashSet Ghc.Var) makeSize env name   = fmap S.fromList-  . mapM (Bare.lookupGhcVar env name "Var") +  . mapM (Bare.lookupGhcVar env name "Var")   . Mb.mapMaybe getSizeFuns-  . Ms.dataDecls +  . Ms.dataDecls  getSizeFuns :: DataDecl -> Maybe LocSymbol getSizeFuns decl@@ -620,46 +639,54 @@   -------------------------------------------------------------------------------------------makeSpecLaws :: Bare.Env -> Bare.SigEnv -> [(Ghc.Var,LocSpecType)] -> Bare.MeasEnv -> Bare.ModSpecs -             -> GhcSpecLaws +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  +makeSpecLaws env sigEnv sigs menv specs = SpLaws+  { gsLawDefs = second (map (\(_,x,y) -> (x,y))) <$> Bare.meCLaws menv   , gsLawInst = Bare.makeInstanceLaws env sigEnv sigs specs   }  -------------------------------------------------------------------------------------------makeSpecRefl :: Config -> GhcSrc -> Bare.MeasEnv -> Bare.ModSpecs -> Bare.Env -> ModName -> GhcSpecSig -> Bare.TycEnv -             -> Bare.Lookup GhcSpecRefl +makeSpecRefl :: Config -> GhcSrc -> Bare.MeasEnv -> Bare.ModSpecs -> Bare.Env -> ModName -> GhcSpecSig -> Bare.TycEnv+             -> Bare.Lookup GhcSpecRefl -------------------------------------------------------------------------------------------makeSpecRefl cfg src menv specs env name sig tycEnv = do -  autoInst <- makeAutoInst env name mySpec +makeSpecRefl cfg src menv specs env name sig tycEnv = do+  autoInst <- makeAutoInst env name mySpec   rwr      <- makeRewrite env name mySpec   rwrWith  <- makeRewriteWith env name mySpec   wRefls   <- Bare.wiredReflects cfg env name sig   xtes     <- Bare.makeHaskellAxioms cfg src env tycEnv name lmap sig mySpec-  let myAxioms = [ Bare.qualifyTop env name (F.loc lt) (e {eqName = symbol x}) | (x, lt, e) <- xtes]  +  let myAxioms =+        [ Bare.qualifyTop+            env+            name+            (F.loc lt)+            e {eqName = s, eqRec = S.member s (exprSymbolsSet (eqBody e))}+        | (x, lt, e) <- xtes+        , let s = symbol x+        ]   let sigVars  = F.notracepp "SIGVARS" $ (fst3 <$> xtes)            -- reflects                                       ++ (fst  <$> gsAsmSigs sig)   -- assumes                                       ++ (fst  <$> gsRefSigs sig)-  return SpRefl -    { gsLogicMap   = lmap -    , gsAutoInst   = autoInst +  return SpRefl+    { gsLogicMap   = lmap+    , gsAutoInst   = autoInst     , gsImpAxioms  = concatMap (Ms.axeqs . snd) (M.toList specs)-    , gsMyAxioms   = F.notracepp "gsMyAxioms" myAxioms +    , gsMyAxioms   = F.notracepp "gsMyAxioms" myAxioms     , gsReflects   = F.notracepp "gsReflects" (lawMethods ++ filter (isReflectVar rflSyms) sigVars ++ wRefls)-    , gsHAxioms    = F.notracepp "gsHAxioms" xtes +    , gsHAxioms    = F.notracepp "gsHAxioms" xtes     , gsWiredReft  = wRefls     , gsRewrites   = rwr     , gsRewritesWith = rwrWith     }   where-    lawMethods   = F.notracepp "Law Methods" $ concatMap Ghc.classMethods (fst <$> Bare.meCLaws menv) -    mySpec       = M.lookupDefault mempty name specs +    lawMethods   = F.notracepp "Law Methods" $ concatMap Ghc.classMethods (fst <$> Bare.meCLaws menv)+    mySpec       = M.lookupDefault mempty name specs     rflSyms      = S.fromList (getReflects specs)     lmap         = Bare.reLMap env -isReflectVar :: S.HashSet F.Symbol -> Ghc.Var -> Bool +isReflectVar :: S.HashSet F.Symbol -> Ghc.Var -> Bool isReflectVar reflSyms v = S.member vx reflSyms   where     vx                  = GM.dropModuleNames (symbol v)@@ -668,7 +695,7 @@ 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. @@ -677,7 +704,7 @@ ------------------------------------------------------------------------------------------ addReflSigs env name rtEnv refl sig =   sig { gsRefSigs = F.notracepp ("gsRefSigs for " ++ F.showpp name) $ map expandReflectedSignature reflSigs-      , gsAsmSigs = F.notracepp ("gsAsmSigs for " ++ F.showpp name) $ (wreflSigs ++ filter notReflected (gsAsmSigs sig))+      , gsAsmSigs = F.notracepp ("gsAsmSigs for " ++ F.showpp name) (wreflSigs ++ filter notReflected (gsAsmSigs sig))       }   where @@ -690,162 +717,166 @@     expandReflectedSignature :: (Ghc.Var, LocSpecType) -> (Ghc.Var, LocSpecType)     expandReflectedSignature = fmap (Bare.qualifyExpand env name rtEnv (F.dummyPos "expand-refSigs") []) -    (wreflSigs, reflSigs)   = L.partition ((`elem` gsWiredReft refl) . fst) -                                 [ (x, t) | (x, t, _) <- gsHAxioms refl ]   +    (wreflSigs, reflSigs)   = L.partition ((`elem` gsWiredReft refl) . fst)+                                 [ (x, t) | (x, t, _) <- gsHAxioms refl ]     reflected       = fst <$> (wreflSigs ++ reflSigs)     notReflected xt = fst xt `notElem` reflected -makeAutoInst :: Bare.Env -> ModName -> Ms.BareSpec -> +makeAutoInst :: Bare.Env -> ModName -> Ms.BareSpec ->                 Bare.Lookup (M.HashMap Ghc.Var (Maybe Int)) makeAutoInst env name spec = M.fromList <$> kvs-  where -    kvs = forM (M.toList (Ms.autois spec)) $ \(k, val) -> do +  where+    kvs = forM (M.toList (Ms.autois spec)) $ \(k, val) -> do             vk <- Bare.lookupGhcVar env name "Var" k             return (vk, val)   ---------------------------------------------------------------------------------------- makeSpecSig :: Config -> ModName -> Bare.ModSpecs -> Bare.Env -> Bare.SigEnv -> Bare.TycEnv -> Bare.MeasEnv -> [Ghc.CoreBind]-            -> Bare.Lookup GhcSpecSig +            -> Bare.Lookup GhcSpecSig -----------------------------------------------------------------------------------------makeSpecSig cfg name specs env sigEnv tycEnv measEnv cbs = do +makeSpecSig cfg name specs env sigEnv tycEnv measEnv cbs = do   mySigs     <- makeTySigs  env sigEnv name mySpec-  aSigs      <- F.notracepp ("makeSpecSig aSigs " ++ F.showpp name) $ makeAsmSigs env sigEnv name specs -  let asmSigs =  Bare.tcSelVars tycEnv +  aSigs      <- F.notracepp ("makeSpecSig aSigs " ++ F.showpp name) $ makeAsmSigs env sigEnv name specs+  let asmSigs =  Bare.tcSelVars tycEnv               ++ aSigs               ++ [ (x,t) | (_, x, t) <- concatMap snd (Bare.meCLaws measEnv) ]-  let tySigs  = strengthenSigs . concat $ +  let tySigs  = strengthenSigs . concat $                   [ [(v, (0, t)) | (v, t,_) <- mySigs                         ]   -- NOTE: these weights are to priortize                    , [(v, (1, t)) | (v, t  ) <- makeMthSigs measEnv            ]   -- user defined sigs OVER auto-generated                    , [(v, (2, t)) | (v, t  ) <- makeInlSigs env rtEnv allSpecs ]   -- during the strengthening, i.e. to KEEP                    , [(v, (3, t)) | (v, t  ) <- makeMsrSigs env rtEnv allSpecs ]   -- the binders used in USER-defined sigs                    ]                                                               -- as they appear in termination metrics-  newTys     <-  makeNewTypes env sigEnv allSpecs -  return SpSig -    { gsTySigs   = tySigs +  newTys     <-  makeNewTypes env sigEnv allSpecs+  relation   <-  makeRelation env name sigEnv (Ms.relational mySpec)+  asmRel     <-  makeRelation env name sigEnv (Ms.asmRel mySpec)+  return SpSig+    { gsTySigs   = tySigs     , gsAsmSigs  = asmSigs-    , gsRefSigs  = [] -    , gsDicts    = dicts +    , gsRefSigs  = []+    , gsDicts    = dicts     -- , gsMethods  = if noclasscheck cfg then [] else Bare.makeMethodTypes dicts (Bare.meClasses  measEnv) cbs -    , gsMethods  = if noclasscheck cfg then [] else Bare.makeMethodTypes (typeclass cfg) dicts (Bare.meClasses  measEnv) cbs +    , gsMethods  = if noclasscheck cfg then [] else Bare.makeMethodTypes (typeclass cfg) dicts (Bare.meClasses  measEnv) cbs     , gsInSigs   = mempty-    , gsNewTypes = newTys -    , gsTexprs   = [ (v, t, es) | (v, t, Just es) <- mySigs ] -    }-  where -    dicts      = Bare.makeSpecDictionaries env sigEnv specs  +    , gsNewTypes = newTys+    , gsTexprs   = [ (v, t, es) | (v, t, Just es) <- mySigs ]+    , gsRelation = relation+    , gsAsmRel   = asmRel+  }+  where+    dicts      = Bare.makeSpecDictionaries env sigEnv specs     mySpec     = M.lookupDefault mempty name specs-    allSpecs   = M.toList specs -    rtEnv      = Bare.sigRTEnv sigEnv +    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 +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 +    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 +makeInlSigs :: Bare.Env -> BareRTEnv -> [(ModName, Ms.BareSpec)] -> [(Ghc.Var, LocSpecType)]+makeInlSigs env rtEnv   = makeLiftedSigs rtEnv (CoreToLogic.inlineSpecType (typeclass (getConfig env)))-  . makeFromSet "hinlines" Ms.inlines env +  . makeFromSet "hinlines" Ms.inlines env -makeMsrSigs :: Bare.Env -> BareRTEnv -> [(ModName, Ms.BareSpec)] -> [(Ghc.Var, LocSpecType)] -makeMsrSigs env rtEnv +makeMsrSigs :: Bare.Env -> BareRTEnv -> [(ModName, Ms.BareSpec)] -> [(Ghc.Var, LocSpecType)]+makeMsrSigs env rtEnv   = makeLiftedSigs rtEnv (CoreToLogic.inlineSpecType (typeclass (getConfig env)))-  . makeFromSet "hmeas" Ms.hmeas env +  . makeFromSet "hmeas" Ms.hmeas env  makeLiftedSigs :: BareRTEnv -> (Ghc.Var -> SpecType) -> [Ghc.Var] -> [(Ghc.Var, LocSpecType)]-makeLiftedSigs rtEnv f xs +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 +    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) +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 +makeTySigs :: Bare.Env -> Bare.SigEnv -> ModName -> Ms.BareSpec            -> Bare.Lookup [(Ghc.Var, LocSpecType, Maybe [Located F.Expr])] makeTySigs env sigEnv name spec = do-  bareSigs   <- bareTySigs env name                spec -  expSigs    <- makeTExpr  env name bareSigs rtEnv spec -  let rawSigs = Bare.resolveLocalBinds env expSigs +  bareSigs   <- bareTySigs env name                spec+  expSigs    <- makeTExpr  env name bareSigs rtEnv spec+  let rawSigs = Bare.resolveLocalBinds env expSigs   return [ (x, cook x bt, z) | (x, bt, z) <- rawSigs ]-  where -    rtEnv     = Bare.sigRTEnv sigEnv -    cook x bt = Bare.cookSpecType env sigEnv name (Bare.HsTV x) bt +  where+    rtEnv     = Bare.sigRTEnv sigEnv+    cook x bt = Bare.cookSpecType env sigEnv name (Bare.HsTV x) bt  bareTySigs :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup [(Ghc.Var, LocBareType)]-bareTySigs env name spec = checkDuplicateSigs <$> vts -  where -    vts = forM ( Ms.sigs spec ++ Ms.localSigs spec ) $ \ (x, t) -> do +bareTySigs env name spec = checkDuplicateSigs <$> vts+  where+    vts = forM ( Ms.sigs spec ++ Ms.localSigs spec ) $ \ (x, t) -> do             v <- F.notracepp "LOOKUP-GHC-VAR" $ Bare.lookupGhcVar env name "rawTySigs" x-            return (v, t) +            return (v, t)  -- checkDuplicateSigs :: [(Ghc.Var, LocSpecType)] -> [(Ghc.Var, LocSpecType)]  checkDuplicateSigs :: (Symbolic x) => [(x, F.Located t)] -> [(x, F.Located t)] checkDuplicateSigs xts = case Misc.uniqueByKey symXs  of   Left (k, ls) -> uError (errDupSpecs (pprint k) (GM.sourcePosSrcSpan <$> ls))-  Right _      -> xts +  Right _      -> xts   where     symXs = [ (F.symbol x, F.loc t) | (x, t) <- xts ]   makeAsmSigs :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.ModSpecs -> Bare.Lookup [(Ghc.Var, LocSpecType)]-makeAsmSigs env sigEnv myName specs = do +makeAsmSigs env sigEnv myName specs = do   raSigs <- rawAsmSigs env myName specs-  return [ (x, t) | (name, x, bt) <- raSigs, let t = Bare.cookSpecType env sigEnv name (Bare.LqTV x) bt ] +  return [ (x, t) | (name, x, bt) <- raSigs, let t = Bare.cookSpecType env sigEnv name (Bare.LqTV x) bt ]  rawAsmSigs :: Bare.Env -> ModName -> Bare.ModSpecs -> Bare.Lookup [(ModName, Ghc.Var, LocBareType)]-rawAsmSigs env myName specs = do -  aSigs <- allAsmSigs env myName specs -  return [ (m, v, t) | (v, sigs) <- aSigs, let (m, t) = myAsmSig v sigs ] -    +rawAsmSigs env myName specs = do+  aSigs <- allAsmSigs env myName specs+  return [ (m, v, t) | (v, sigs) <- aSigs, let (m, t) = myAsmSig v sigs ]+ myAsmSig :: Ghc.Var -> [(Bool, ModName, LocBareType)] -> (ModName, LocBareType)-myAsmSig v sigs = Mb.fromMaybe errImp (Misc.firstMaybes [mbHome, mbImp]) -  where -    mbHome      = takeUnique err                  sigsHome -    mbImp       = takeUnique err (Misc.firstGroup sigsImp) -- see [NOTE:Prioritize-Home-Spec] +myAsmSig v sigs = Mb.fromMaybe errImp (Misc.firstMaybes [mbHome, mbImp])+  where+    mbHome      = takeUnique mkErr                  sigsHome+    mbImp       = takeUnique mkErr (Misc.firstGroup sigsImp) -- see [NOTE:Prioritize-Home-Spec]      sigsHome    = [(m, t)      | (True,  m, t) <- sigs ]     sigsImp     = F.notracepp ("SIGS-IMP: " ++ F.showpp v)                   [(d, (m, t)) | (False, m, t) <- sigs, let d = nameDistance vName m]-    err ts      = ErrDupSpecs (Ghc.getSrcSpan v) (F.pprint v) (GM.sourcePosSrcSpan . F.loc . snd <$> ts) :: UserError+    mkErr ts    = ErrDupSpecs (Ghc.getSrcSpan v) (F.pprint v) (GM.sourcePosSrcSpan . F.loc . snd <$> ts) :: UserError     errImp      = impossible Nothing "myAsmSig: cannot happen as sigs is non-null"     vName       = GM.takeModuleNames (F.symbol v) -makeTExpr :: Bare.Env -> ModName -> [(Ghc.Var, LocBareType)] -> BareRTEnv -> Ms.BareSpec +makeTExpr :: Bare.Env -> ModName -> [(Ghc.Var, LocBareType)] -> BareRTEnv -> Ms.BareSpec           -> Bare.Lookup [(Ghc.Var, LocBareType, Maybe [Located F.Expr])]-makeTExpr env name tySigs rtEnv spec = do +makeTExpr env name tySigs rtEnv spec = do   vExprs       <- M.fromList <$> makeVarTExprs env name spec-  let vSigExprs = Misc.hashMapMapWithKey (\v t -> (t, M.lookup v vExprs)) vSigs -  return [ (v, t, qual t <$> es) | (v, (t, es)) <- M.toList vSigExprs ] -  where +  let vSigExprs = Misc.hashMapMapWithKey (\v t -> (t, M.lookup v vExprs)) vSigs+  return [ (v, t, qual t <$> es) | (v, (t, es)) <- M.toList vSigExprs ]+  where     qual t es   = qualifyTermExpr env name rtEnv t <$> es-    vSigs       = M.fromList tySigs -                    -qualifyTermExpr :: Bare.Env -> ModName -> BareRTEnv -> LocBareType -> Located F.Expr -                -> Located F.Expr -qualifyTermExpr env name rtEnv t le +    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 +  where+    l   = F.loc le+    e   = F.val le+    bs  = ty_binds . toRTypeRep . val $ t  makeVarTExprs :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.Lookup [(Ghc.Var, [Located F.Expr])]-makeVarTExprs env name spec = -  forM (Ms.termexprs spec) $ \(x, es) -> do +makeVarTExprs env name spec =+  forM (Ms.termexprs spec) $ \(x, es) -> do     vx <- Bare.lookupGhcVar env name "Var" x     return (vx, es) @@ -865,20 +896,20 @@ -- 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 +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) +takeUnique _ []  = Nothing+takeUnique _ [x] = Just x+takeUnique f xs  = Ex.throw (f xs) -allAsmSigs :: Bare.Env -> ModName -> Bare.ModSpecs -> +allAsmSigs :: Bare.Env -> ModName -> Bare.ModSpecs ->               Bare.Lookup [(Ghc.Var, [(Bool, ModName, LocBareType)])]-allAsmSigs env myName specs = do +allAsmSigs env myName specs = do   let aSigs = [ (name, must, x, t) | (name, spec) <- M.toList specs                                    , (must, x, t) <- getAsmSigs myName name spec ]   vSigs    <- forM aSigs $ \(name, must, x, t) -> do@@ -891,14 +922,14 @@ resolveAsmVar env name False lx = return $  Bare.maybeResolveSym     env name "resolveAsmVar-False" lx  <|> GM.maybeAuxVar (F.val lx)  -getAsmSigs :: ModName -> ModName -> Ms.BareSpec -> [(Bool, LocSymbol, LocBareType)]  -getAsmSigs myName name spec +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 +  | 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) +  where+    qSym           = fmap (GM.qualifySymbol ns)     ns             = F.symbol name  -- TODO-REBARE: grepClassAssumes@@ -909,52 +940,51 @@     goOne (x, RIAssumed t) = Just (fmap (F.symbol . (".$c" ++ ) . F.symbolString) x, t)     goOne (_, RISig _)     = Nothing -makeSigEnv :: F.TCEmb Ghc.TyCon -> Bare.TyConMap -> S.HashSet StableName -> BareRTEnv -> Bare.SigEnv +makeSigEnv :: F.TCEmb Ghc.TyCon -> Bare.TyConMap -> S.HashSet StableName -> BareRTEnv -> Bare.SigEnv makeSigEnv embs tyi exports rtEnv = Bare.SigEnv-  { sigEmbs     = embs -  , sigTyRTyMap = tyi -  , sigExports  = exports +  { sigEmbs     = embs+  , sigTyRTyMap = tyi+  , sigExports  = exports   , sigRTEnv    = rtEnv-  } +  } -makeNewTypes :: Bare.Env -> Bare.SigEnv -> [(ModName, Ms.BareSpec)] -> +makeNewTypes :: Bare.Env -> Bare.SigEnv -> [(ModName, Ms.BareSpec)] ->                 Bare.Lookup [(Ghc.TyCon, LocSpecType)]-makeNewTypes env sigEnv specs = do -  fmap concat $ -    forM nameDecls $ \(name, d) -> -      makeNewType env sigEnv name d+makeNewTypes env sigEnv specs = do+  fmap concat $+    forM nameDecls $ uncurry (makeNewType env sigEnv)   where-    nameDecls = [(name, d) | (name, spec) <- specs, d <- Ms.newtyDecls spec] +    nameDecls = [(name, d) | (name, spec) <- specs, d <- Ms.newtyDecls spec] -makeNewType :: Bare.Env -> Bare.SigEnv -> ModName -> DataDecl -> +makeNewType :: Bare.Env -> Bare.SigEnv -> ModName -> DataDecl ->                Bare.Lookup [(Ghc.TyCon, LocSpecType)]-makeNewType env sigEnv name d = do +makeNewType env sigEnv name d = do   tcMb <- Bare.lookupGhcDnTyCon env name "makeNewType" tcName   case tcMb of-    Just tc -> return [(tc, t)] +    Just tc -> return [(tc, lst)]     _       -> return []-  where +  where     tcName                    = tycName d-    t                         = Bare.cookSpecType env sigEnv name Bare.GenTV bt+    lst                       = Bare.cookSpecType env sigEnv name Bare.GenTV bt     bt                        = getTy tcName (tycSrcPos d) (Mb.fromMaybe [] (tycDCons d))     getTy _ l [c]       | [(_, t)] <- dcFields c = Loc l l t-    getTy n l _                = Ex.throw (err n l) -    err n l                    = ErrOther (GM.sourcePosSrcSpan l) ("Bad new type declaration:" <+> F.pprint n) :: UserError+    getTy n l _                = Ex.throw (mkErr n l)+    mkErr n l                  = ErrOther (GM.sourcePosSrcSpan l) ("Bad new type declaration:" <+> F.pprint n) :: UserError  ------------------------------------------------------------------------------------------ makeSpecData :: GhcSrc -> Bare.Env -> Bare.SigEnv -> Bare.MeasEnv -> GhcSpecSig -> Bare.ModSpecs              -> GhcSpecData -------------------------------------------------------------------------------------------makeSpecData src env sigEnv measEnv sig specs = SpData -  { gsCtors      = F.notracepp "GS-CTORS" -                   [ (x, if allowTC then t else tt) +makeSpecData src env sigEnv measEnv sig specs = SpData+  { gsCtors      = F.notracepp "GS-CTORS"+                   [ (x, if allowTC then t else tt)                        | (x, t) <- Bare.meDataCons measEnv-                       , let tt  = Bare.plugHoles (typeclass $ getConfig env) sigEnv name (Bare.LqTV x) t +                       , let tt  = Bare.plugHoles (typeclass $ getConfig env) sigEnv name (Bare.LqTV x) t                    ]-  , gsMeas       = [ (F.symbol x, uRType <$> t) | (x, t) <- measVars ] +  , gsMeas       = [ (F.symbol x, uRType <$> t) | (x, t) <- measVars ]   , gsMeasures   = Bare.qualifyTopDummy env name <$> (ms1 ++ ms2)-  , gsInvariants = Misc.nubHashOn (F.loc . snd) invs +  , gsInvariants = Misc.nubHashOn (F.loc . snd) invs   , gsIaliases   = concatMap (makeIAliases env sigEnv) (M.toList specs)   , gsUnsorted   = usI ++ concatMap msUnSorted (concatMap measures specs)   }@@ -963,39 +993,52 @@     measVars     = Bare.meSyms      measEnv -- ms'                 ++ Bare.meClassSyms measEnv -- cms'                  ++ Bare.varMeasures env-    measuresSp   = Bare.meMeasureSpec measEnv  +    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)+    invs         = minvs ++ concatMap (makeInvariants env sigEnv) (M.toList specs)  makeIAliases :: Bare.Env -> Bare.SigEnv -> (ModName, Ms.BareSpec) -> [(LocSpecType, LocSpecType)] makeIAliases env sigEnv (name, spec)   = [ z | Right z <- mkIA <$> Ms.ialiases spec ]-  where +  where     -- mkIA :: (LocBareType, LocBareType) -> Either _ (LocSpecType, LocSpecType)-    mkIA (t1, t2) = (,) <$> mkI t1 <*> mkI t2-    mkI           = Bare.cookSpecTypeE env sigEnv name Bare.GenTV +    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 +makeInvariants env sigEnv (name, spec) =+  [ (Nothing, t)+    | (_, bt) <- Ms.invariants spec     , Bare.knownGhcType env name bt     , let t = Bare.cookSpecType env sigEnv name Bare.GenTV bt+  ] +++  concat [ (Nothing,) . makeSizeInv l <$>  ts+    | (bts, l) <- Ms.dsize spec+    , all (Bare.knownGhcType env name) bts+    , let ts = Bare.cookSpecType env sigEnv name Bare.GenTV <$> bts   ] -makeMeasureInvariants :: Bare.Env -> ModName -> GhcSpecSig -> Ms.BareSpec +makeSizeInv :: F.LocSymbol -> Located SpecType -> Located SpecType+makeSizeInv s lst = lst{val = go (val lst)}+  where go (RApp c ts rs r) = RApp c ts rs (r `meet` nat)+        go (RAllT a t r)    = RAllT a (go t) r+        go t = t+        nat  = MkUReft (Reft (vv_, PAtom Le (ECon $ I 0) (EApp (EVar $ val s) (eVar vv_))))+                       mempty++makeMeasureInvariants :: Bare.Env -> ModName -> GhcSpecSig -> Ms.BareSpec                       -> ([(Maybe Ghc.Var, LocSpecType)], [UnSortedExpr])-makeMeasureInvariants env name sig mySpec -  = mapSnd Mb.catMaybes $ +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) +  where+    sigs = gsTySigs sig+    xs   = S.toList (Ms.hmeas  mySpec)  isSymbolOfVar :: Symbol -> Ghc.Var -> Bool isSymbolOfVar x v = x == symbol' v@@ -1004,88 +1047,88 @@     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)+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+    rts  = 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)+    tz   = last rts+    usorted = if isSimpleADT tz then Nothing else mapFst (:[]) <$> mkReft (dummyLoc $ F.symbol v) z tz res     mtype-      | null ts +      | null rts       = uError $ ErrHMeas (GM.sourcePosSrcSpan $ loc t) (pprint x) "Measure has no arguments!"-      | otherwise -      = mkInvariant x z tz res -    isSimpleADT (RApp _ ts _ _) = all isRVar ts -    isSimpleADT _               = False +      | 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)+mkInvariant x z t tr = strengthen (top <$> t) (MkUReft reft' mempty)       where-        reft  = Mb.maybe mempty Reft mreft-        mreft = mkReft x z t tr +        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 +mkReft x z _t tr   | Just q <- stripRTypeBase tr   = let Reft (v, p) = toReft q         su          = mkSubst [(v, mkEApp x [EVar v]), (z,EVar v)]         -- p'          = pAnd $ filter (\e -> z `notElem` syms e) $ conjuncts p     in  Just (v, subst su p)-mkReft _ _ _ _  -  = Nothing +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                +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  +  , gsTcEmbeds = Bare.tcEmbs     tycEnv+  , gsADTs     = Bare.tcAdts     tycEnv+  , gsTyconEnv = Bare.tcTyConMap tycEnv   }-  where +  where     datacons, cls :: [DataConP]-    datacons   = Bare.tcDataCons tycEnv -    cls        = F.notracepp "meClasses" $ Bare.meClasses measEnv -    tycons     = Bare.tcTyCons   tycEnv +    datacons   = Bare.tcDataCons tycEnv+    cls        = F.notracepp "meClasses" $ Bare.meClasses measEnv+    tycons     = Bare.tcTyCons   tycEnv   -- REBARE: formerly, makeGhcCHOP1 -- split into two to break circular dependency. we need dataconmap for core2logic --------------------------------------------------------------------------------------------makeTycEnv0 :: Config -> ModName -> Bare.Env -> TCEmb Ghc.TyCon -> Ms.BareSpec -> Bare.ModSpecs +makeTycEnv0 :: Config -> ModName -> Bare.Env -> TCEmb Ghc.TyCon -> Ms.BareSpec -> Bare.ModSpecs            -> (Diagnostics,  [Located DataConP], Bare.TycEnv) --------------------------------------------------------------------------------------------makeTycEnv0 cfg myName env embs mySpec iSpecs = (diag0 <> diag1, datacons, Bare.TycEnv -  { tcTyCons      = tycons                  +makeTycEnv0 cfg myName env embs mySpec iSpecs = (diag0 <> diag1, datacons, Bare.TycEnv+  { tcTyCons      = tycons   , tcDataCons    = mempty -- val <$> datacons -  , tcSelMeasures = dcSelectors             +  , tcSelMeasures = dcSelectors   , tcSelVars     = mempty -- recSelectors            -  , tcTyConMap    = tyi                     -  , tcAdts        = adts                    +  , tcTyConMap    = tyi+  , tcAdts        = adts   , tcDataConMap  = dm   , tcEmbs        = embs   , tcName        = myName   })   where     (tcDds, dcs)   = conTys-    (diag0, conTys) = withDiagnostics $ Bare.makeConTypes myName env specs +    (diag0, conTys) = withDiagnostics $ Bare.makeConTypes myName env specs     specs         = (myName, mySpec) : M.toList iSpecs-    tcs           = Misc.snd3 <$> tcDds +    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 +    tycons        = tcs ++ knownWiredTyCons env myName     datacons      = Bare.makePluggedDataCon (typeclass cfg) embs tyi <$> (concat dcs ++ knownWiredDataCons env myName)     tds           = [(name, tcpCon tcp, dd) | (name, tcp, Just dd) <- tcDds]     (diag1, adts) = Bare.makeDataDecls cfg embs myName tds       datacons@@ -1096,14 +1139,13 @@   makeTycEnv1 ::-     Config -  -> ModName+     ModName   -> Bare.Env   -> (Bare.TycEnv, [Located DataConP])   -> (Ghc.CoreExpr -> F.Expr)   -> (Ghc.CoreExpr -> Ghc.TcRn Ghc.CoreExpr)   -> Ghc.TcRn Bare.TycEnv-makeTycEnv1 cfg myName env (tycEnv, datacons) coreToLg simplifier = do+makeTycEnv1 myName env (tycEnv, datacons) coreToLg simplifier = do   -- fst for selector generation, snd for dataconsig generation   lclassdcs <- forM classdcs $ traverse (Bare.elaborateClassDcp coreToLg simplifier)   let recSelectors = Bare.makeRecordSelectorSigs env myName (dcs ++ (fmap . fmap) snd lclassdcs)@@ -1114,27 +1156,27 @@       L.partition         (Ghc.isClassTyCon . Ghc.dataConTyCon . dcpCon . F.val) datacons -    -knownWiredDataCons :: Bare.Env -> ModName -> [Located DataConP] -knownWiredDataCons env name = filter isKnown wiredDataCons -  where ++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 +knownWiredTyCons :: Bare.Env -> ModName -> [TyConP]+knownWiredTyCons env name = filter isKnown wiredTyCons+  where+    isKnown               = Bare.knownGhcTyCon env name . GM.namedLocSymbol . tcpCon   -- REBARE: formerly, makeGhcCHOP2 --------------------------------------------------------------------------------------------makeMeasEnv :: Bare.Env -> Bare.TycEnv -> Bare.SigEnv -> Bare.ModSpecs -> -               Bare.Lookup Bare.MeasEnv +makeMeasEnv :: Bare.Env -> Bare.TycEnv -> Bare.SigEnv -> Bare.ModSpecs ->+               Bare.Lookup Bare.MeasEnv --------------------------------------------------------------------------------------------makeMeasEnv env tycEnv sigEnv specs = do +makeMeasEnv env tycEnv sigEnv specs = do   laws        <- Bare.makeCLaws env sigEnv name specs   (cls, mts)  <- Bare.makeClasses        env sigEnv name specs-  let dms      = Bare.makeDefaultMethods env mts  +  let dms      = Bare.makeDefaultMethods env mts   measures0   <- mapM (Bare.makeMeasureSpec env sigEnv name) (M.toList specs)   let measures = mconcat (Ms.mkMSpec' dcSelectors : measures0)   let (cs, ms) = Bare.makeMeasureSpec'  (typeclass $ getConfig env)   measures@@ -1143,21 +1185,21 @@   let ms'      = [ (F.val lx, F.atLoc lx t) | (lx, t) <- ms                                             , Mb.isNothing (lookup (val lx) cms') ]   let cs'      = [ (v, txRefs v t) | (v, t) <- Bare.meetDataConSpec (typeclass (getConfig env)) embs cs (datacons ++ cls)]-  return Bare.MeasEnv -    { meMeasureSpec = measures -    , meClassSyms   = cms' -    , meSyms        = ms' -    , meDataCons    = cs' +  return Bare.MeasEnv+    { meMeasureSpec = measures+    , meClassSyms   = cms'+    , meSyms        = ms'+    , meDataCons    = cs'     , meClasses     = cls-    , meMethods     = mts ++ dms +    , meMethods     = mts ++ dms     , meCLaws       = laws     }-  where -    txRefs v t    = Bare.txRefSort tyi embs (t <$ GM.locNamedThing v) -    tyi           = Bare.tcTyConMap    tycEnv -    dcSelectors   = Bare.tcSelMeasures tycEnv -    datacons      = Bare.tcDataCons    tycEnv -    embs          = Bare.tcEmbs        tycEnv +  where+    txRefs v t    = Bare.txRefSort tyi embs (t <$ GM.locNamedThing v)+    tyi           = Bare.tcTyConMap    tycEnv+    dcSelectors   = Bare.tcSelMeasures tycEnv+    datacons      = Bare.tcDataCons    tycEnv+    embs          = Bare.tcEmbs        tycEnv     name          = Bare.tcName        tycEnv  -----------------------------------------------------------------------------------------@@ -1165,42 +1207,42 @@ --   so that downstream files that import this target can access the lifted definitions,  --   e.g. for measures, reflected functions etc. ------------------------------------------------------------------------------------------makeLiftedSpec :: ModName -> GhcSrc -> Bare.Env -               -> GhcSpecRefl -> GhcSpecData -> GhcSpecSig -> GhcSpecQual -> BareRTEnv -               -> Ms.BareSpec -> Ms.BareSpec +makeLiftedSpec :: ModName -> GhcSrc -> Bare.Env+               -> GhcSpecRefl -> GhcSpecData -> GhcSpecSig -> GhcSpecQual -> BareRTEnv+               -> Ms.BareSpec -> Ms.BareSpec ------------------------------------------------------------------------------------------makeLiftedSpec name src _env refl sData sig qual myRTE lSpec0 = lSpec0 -  { Ms.asmSigs    = F.notracepp   ("makeLiftedSpec : ASSUMED-SIGS " ++ F.showpp name ) $ (xbs ++ myDCs) +makeLiftedSpec name src _env refl sData sig qual myRTE lSpec0 = lSpec0+  { Ms.asmSigs    = F.notracepp   ("makeLiftedSpec : ASSUMED-SIGS " ++ F.showpp name ) (xbs ++ myDCs)   , Ms.reflSigs   = F.notracepp "REFL-SIGS"         xbs-  , Ms.sigs       = F.notracepp   ("makeLiftedSpec : LIFTED-SIGS " ++ F.showpp name )  $ mkSigs (gsTySigs sig)  -  , Ms.invariants = [ ((varLocSym <$> x), Bare.specToBare <$> t) -                       | (x, t) <- gsInvariants sData +  , Ms.sigs       = F.notracepp   ("makeLiftedSpec : LIFTED-SIGS " ++ F.showpp name )  $ mkSigs (gsTySigs sig)+  , Ms.invariants = [ (varLocSym <$> x, Bare.specToBare <$> t)+                       | (x, t) <- gsInvariants sData                        , isLocInFile srcF t                     ]-  , Ms.axeqs      = gsMyAxioms refl +  , Ms.axeqs      = gsMyAxioms refl   , Ms.aliases    = F.notracepp "MY-ALIASES" $ M.elems . typeAliases $ myRTE-  , Ms.ealiases   = M.elems . exprAliases $ myRTE +  , Ms.ealiases   = M.elems . exprAliases $ myRTE   , Ms.qualifiers = filter (isLocInFile srcF) (gsQualifiers qual)   }   where     myDCs         = [(x,t) | (x,t) <- mkSigs (gsCtors sData)                            , F.symbol name == fst (GM.splitModuleName $ val x)]     mkSigs xts    = [ toBare (x, t) | (x, t) <- xts-                    ,  S.member x sigVars && (isExportedVar (view targetSrcIso src) x) -                    ] +                    ,  S.member x sigVars && isExportedVar (view targetSrcIso src) x+                    ]     toBare (x, t) = (varLocSym x, Bare.specToBare <$> t)-    xbs           = toBare <$> reflTySigs +    xbs           = toBare <$> reflTySigs     sigVars       = S.difference defVars reflVars     defVars       = S.fromList (_giDefVars src)     reflTySigs    = [(x, t) | (x,t,_) <- gsHAxioms refl, x `notElem` gsWiredReft refl]     reflVars      = S.fromList (fst <$> reflTySigs)     -- myAliases fld = M.elems . fld $ myRTE -    srcF          = _giTarget src +    srcF          = _giTarget src  -- | Returns 'True' if the input determines a location within the input file. Due to the fact we might have -- Haskell sources which have \"companion\" specs defined alongside them, we also need to account for this -- case, by stripping out the extensions and check that the LHS is a Haskell source and the RHS a spec file.-isLocInFile :: (F.Loc a) => FilePath -> a ->  Bool +isLocInFile :: (F.Loc a) => FilePath -> a ->  Bool isLocInFile f lx = f == lifted || isCompanion   where     lifted :: FilePath@@ -1212,7 +1254,7 @@        &&  isExtFile Hs f        &&  isExtFile Files.Spec lifted -locFile :: (F.Loc a) => a -> FilePath +locFile :: (F.Loc a) => a -> FilePath locFile = Misc.fst3 . F.sourcePosElts . F.sp_start . F.srcSpan  varLocSym :: Ghc.Var -> LocSymbol@@ -1227,37 +1269,37 @@ --   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 +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 +    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 +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 +  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 +    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
@@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings    #-} {-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances    #-}  -- | This module contains the code that DOES reflection; i.e. converts Haskell@@ -16,36 +15,36 @@ -- 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 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 qualified Language.Haskell.Liquid.GHC.Misc as GM +import qualified Liquid.GHC.API as Ghc+import qualified Liquid.GHC.Misc as GM import           Language.Haskell.Liquid.Types.RefType import           Language.Haskell.Liquid.Transforms.CoreToLogic-import           Language.Haskell.Liquid.GHC.Misc+import           Liquid.GHC.Misc import           Language.Haskell.Liquid.Types  import           Language.Haskell.Liquid.Bare.Resolve as Bare import           Language.Haskell.Liquid.Bare.Types   as Bare  ------------------------------------------------------------------------------------------------makeHaskellAxioms :: Config -> GhcSrc -> Bare.Env -> Bare.TycEnv -> ModName -> LogicMap -> GhcSpecSig -> Ms.BareSpec +makeHaskellAxioms :: Config -> GhcSrc -> Bare.Env -> Bare.TycEnv -> ModName -> LogicMap -> GhcSpecSig -> Ms.BareSpec                   -> Bare.Lookup [(Ghc.Var, LocSpecType, F.Equation)] ------------------------------------------------------------------------------------------------makeHaskellAxioms cfg src env tycEnv name lmap spSig spec = do +makeHaskellAxioms cfg src env tycEnv name lmap spSig spec = do   wiDefs     <- wiredDefs cfg env name spSig   let refDefs = getReflectDefs src spSig spec   return (makeAxiom env tycEnv name lmap <$> (wiDefs ++ refDefs)) -getReflectDefs :: GhcSrc -> GhcSpecSig -> Ms.BareSpec +getReflectDefs :: GhcSrc -> GhcSpecSig -> Ms.BareSpec                -> [(LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr)] getReflectDefs src sig spec = findVarDefType cbs sigs <$> xs   where-    sigs                    = gsTySigs sig +    sigs                    = gsTySigs sig     xs                      = S.toList (Ms.reflects spec)     cbs                     = _giCbs src @@ -54,22 +53,22 @@ findVarDefType cbs sigs x = case findVarDefMethod (val x) cbs of   -- YL: probably ok even without checking typeclass flag since user cannot   -- manually reflect internal names-  Just (v, e) -> if Ghc.isExportedId v || isMethod (F.symbol x) || isDictionary (F.symbol x)+  Just (v, e) -> if GM.isExternalId v || isMethod (F.symbol x) || isDictionary (F.symbol x)                    then (x, val <$> lookup v sigs, v, e)                    else Ex.throw $ mkError x ("Lifted functions must be exported; please export " ++ show v)   Nothing     -> Ex.throw $ mkError x "Cannot lift haskell function"  ---------------------------------------------------------------------------------makeAxiom :: Bare.Env -> Bare.TycEnv -> ModName -> LogicMap +makeAxiom :: Bare.Env -> Bare.TycEnv -> ModName -> LogicMap           -> (LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr)           -> (Ghc.Var, LocSpecType, F.Equation) ---------------------------------------------------------------------------------makeAxiom env tycEnv name lmap (x, mbT, v, def) +makeAxiom env tycEnv name lmap (x, mbT, v, def)             = (v, t, e)-  where -    t       = Bare.qualifyTop env name (F.loc t0) t0 +  where+    t       = Bare.qualifyTop env name (F.loc t0) t0     (t0, e) = makeAssumeType allowTC embs lmap dm x mbT v def-    embs    = Bare.tcEmbs       tycEnv +    embs    = Bare.tcEmbs       tycEnv     dm      = Bare.tcDataConMap tycEnv     allowTC = typeclass (getConfig env) @@ -81,23 +80,23 @@   -> F.TCEmb Ghc.TyCon -> LogicMap -> DataConMap -> LocSymbol -> Maybe SpecType   -> Ghc.Var -> Ghc.CoreExpr   -> (LocSpecType, F.Equation)-makeAssumeType allowTC tce lmap dm x mbT v def-  = (x {val = aty at `strengthenRes` F.subst su ref},  F.mkEquation (val x) xts (F.subst su le) out)+makeAssumeType allowTC tce lmap dm sym mbT v def+  = (sym {val = aty at `strengthenRes` F.subst su ref},  F.mkEquation (val sym) xts (F.subst su le) out)   where-    t     = fromRTypeRep .+    rt    = fromRTypeRep .             (\trep@RTypeRep{..} ->                 trep{ty_info = fmap (\rinfo -> rinfo{permitTC = Just allowTC}) ty_info}) .-            toRTypeRep $ Mb.fromMaybe (ofType $ τ) mbT+            toRTypeRep $ Mb.fromMaybe (ofType τ) mbT     τ     = Ghc.varType v-    at    = axiomType allowTC x t-    out   = rTypeSort tce $ ares at -    xArgs = (F.EVar . fst) <$> aargs at-    _msg  = unwords [showpp x, showpp mbT]+    at    = axiomType allowTC sym rt+    out   = rTypeSort tce $ ares at+    xArgs = F.EVar . fst <$> aargs at+    _msg  = unwords [showpp sym, showpp mbT]     le    = case runToLogicWithBoolBinds bbs tce lmap dm mkErr (coreToLogic allowTC def') of               Right e -> e               Left  e -> panic Nothing (show e)     ref        = F.Reft (F.vv_, F.PAtom F.Eq (F.EVar F.vv_) le)-    mkErr s    = ErrHMeas (sourcePosSrcSpan $ loc x) (pprint $ val x) (PJ.text s)+    mkErr s    = ErrHMeas (sourcePosSrcSpan $ loc sym) (pprint $ val sym) (PJ.text s)     bbs        = filter isBoolBind xs     (xs, def') = GM.notracePpr "grabBody" $ grabBody allowTC (Ghc.expandTypeSynonyms τ) $ normalize allowTC def     su         = F.mkSubst  $ zip (F.symbol     <$> xs) xArgs@@ -109,48 +108,48 @@  grabBody :: Bool -- ^ typeclass enabled          -> Ghc.Type -> Ghc.CoreExpr -> ([Ghc.Var], Ghc.CoreExpr)-grabBody allowTC (Ghc.ForAllTy _ t) e -  = grabBody allowTC t e -grabBody allowTC@False (Ghc.FunTy { Ghc.ft_arg = tx, Ghc.ft_res = t}) e | Ghc.isClassPred tx -  = grabBody allowTC t e -grabBody allowTC@True (Ghc.FunTy { Ghc.ft_arg = tx, Ghc.ft_res = t}) e | isEmbeddedDictType tx -  = grabBody allowTC t e -grabBody allowTC torig@Ghc.FunTy {} (Ghc.Let (Ghc.NonRec x e) body) +grabBody allowTC (Ghc.ForAllTy _ ty) e+  = grabBody allowTC ty e+grabBody allowTC@False Ghc.FunTy{ Ghc.ft_arg = tx, Ghc.ft_res = t} e | Ghc.isClassPred tx+  = grabBody allowTC t e+grabBody allowTC@True Ghc.FunTy{ Ghc.ft_arg = tx, Ghc.ft_res = t} e | isEmbeddedDictType tx+  = grabBody allowTC t e+grabBody allowTC torig@Ghc.FunTy {} (Ghc.Let (Ghc.NonRec x e) body)   = grabBody allowTC torig (subst (x,e) body)-grabBody allowTC (Ghc.FunTy { Ghc.ft_res = t}) (Ghc.Lam x e) +grabBody allowTC Ghc.FunTy{ Ghc.ft_res = t} (Ghc.Lam x e)   = (x:xs, e') where (xs, e') = grabBody allowTC t e-grabBody allowTC t (Ghc.Tick _ e) +grabBody allowTC t (Ghc.Tick _ e)   = grabBody allowTC t e-grabBody allowTC t@(Ghc.FunTy {}) e               -  = (txs++xs, e') -   where (ts,tr)  = splitFun t +grabBody allowTC ty@Ghc.FunTy{} e+  = (txs++xs, e')+   where (ts,tr)  = splitFun ty          (xs, e') = grabBody allowTC tr (foldl Ghc.App e (Ghc.Var <$> txs))-         txs      = [ stringVar ("ls" ++ show i) t |  (t,i) <- zip ts [1..]]+         txs      = [ stringVar ("ls" ++ show i) t |  (t,i) <- zip ts [(1::Int)..]] grabBody _ _ e   = ([], e)  splitFun :: Ghc.Type -> ([Ghc.Type], Ghc.Type)-splitFun = go [] -  where go acc (Ghc.FunTy { Ghc.ft_arg = tx, Ghc.ft_res = t}) = go (tx:acc) t -        go acc t                                              = (reverse acc, t)+splitFun = go []+  where go acc Ghc.FunTy{ Ghc.ft_arg = tx, Ghc.ft_res = t} = go (tx:acc) t+        go acc t                                           = (reverse acc, t)   isBoolBind :: Ghc.Var -> Bool isBoolBind v = isBool (ty_res $ toRTypeRep ((ofType $ Ghc.varType v) :: RRType ()))  strengthenRes :: SpecType -> F.Reft -> SpecType-strengthenRes t r = go t -  where -    go (RAllT a t r)   = RAllT a (go t) r  +strengthenRes st rf = go st+  where+    go (RAllT a t r)   = RAllT a (go t) r     go (RAllP p t)     = RAllP p $ go t-    go (RFun x i tx t r) = RFun x i tx (go t) r -    go t               =  t `strengthen` F.ofReft r +    go (RFun x i tx t r) = RFun x i tx (go t) r+    go t               =  t `strengthen` F.ofReft rf  class Subable a where   subst :: (Ghc.Var, Ghc.CoreExpr) -> a -> a  instance Subable Ghc.Var where-  subst (x, ex) z +  subst (x, ex) z     | x == z, Ghc.Var y <- ex = y     | otherwise           = z @@ -172,8 +171,8 @@     = Ghc.Cast (subst su e) t   subst su (Ghc.Tick t e)     = Ghc.Tick t (subst su e)-  subst _ e -    = e +  subst _ e+    = e  instance Subable Ghc.CoreAlt where   subst su (c, xs, e) = (c, xs, subst su e)@@ -182,24 +181,24 @@  -- | Specification for Haskell function axiomType :: Bool -> LocSymbol -> SpecType -> AxiomType-axiomType allowTC s t = AT to (reverse xts) res  +axiomType allowTC s st = AT to (reverse xts) res   where-    (to, (_,xts, Just res)) = runState (go t) (1,[], Nothing)-    go (RAllT a t r) = RAllT a <$> go t <*> return r -    go (RAllP p t) = RAllP p <$> go t +    (to, (_,xts, Just res)) = runState (go st) (1,[], Nothing)+    go (RAllT a t r) = RAllT a <$> go t <*> return r+    go (RAllP p t) = RAllP p <$> go t     go (RFun x i tx t r) | isErasable tx = (\t' -> RFun x i tx t' r) <$> go t-    go (RFun x ii tx t r) = do -      (i,bs,res) <- get -      let x' = unDummy x i -      put (i+1, (x', tx):bs,res)-      t' <- go t -      return $ RFun x' ii tx t' r -    go t = do -      (i,bs,_) <- get +    go (RFun x ii tx t r) = do+      (i,bs,mres) <- get+      let x' = unDummy x i+      put (i+1, (x', tx):bs,mres)+      t' <- go t+      return $ RFun x' ii tx t' r+    go t = do+      (i,bs,_) <- get       let ys = reverse $ map fst bs       let t' = strengthen t (singletonApp s ys)       put (i, bs, Just t')-      return t' +      return t'     isErasable = if allowTC then isEmbeddedClass else isClassType unDummy :: F.Symbol -> Int -> F.Symbol unDummy x i@@ -216,20 +215,20 @@ -- | Hardcode imported reflected functions ------------------------------------ ------------------------------------------------------------------------------- -wiredReflects :: Config -> Bare.Env -> ModName -> GhcSpecSig -> +wiredReflects :: Config -> Bare.Env -> ModName -> GhcSpecSig ->                  Bare.Lookup [Ghc.Var]-wiredReflects cfg env name sigs = do +wiredReflects cfg env name sigs = do   vs <- wiredDefs cfg env name sigs   return [v | (_, _, v, _) <- vs] -wiredDefs :: Config -> Bare.Env -> ModName -> GhcSpecSig +wiredDefs :: Config -> Bare.Env -> ModName -> GhcSpecSig           -> Bare.Lookup [(LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr)] wiredDefs cfg env name spSig   | reflection cfg = do     let x = F.dummyLoc functionComposisionSymbol     v    <- Bare.lookupGhcVar env name "wiredAxioms" x     return [ (x, F.val <$> lookup v (gsTySigs spSig), v, makeCompositionExpression v) ]-  | otherwise = +  | otherwise =     return []  -------------------------------------------------------------------------------@@ -238,28 +237,28 @@ -------------------------------------------------------------------------------  -makeCompositionExpression :: Ghc.Id -> Ghc.CoreExpr -makeCompositionExpression x +makeCompositionExpression :: Ghc.Id -> Ghc.CoreExpr+makeCompositionExpression gid   =  go $ Ghc.varType $ F.notracepp ( -- tracing to find  the body of . from the inline spec,                                        -- replace F.notrace with F.trace to print -      "\nv = " ++ GM.showPpr x ++ -      "\n realIdUnfolding = " ++ GM.showPpr (Ghc.realIdUnfolding x) ++ -      "\n maybeUnfoldingTemplate . realIdUnfolding = " ++ GM.showPpr (Ghc.maybeUnfoldingTemplate $ Ghc.realIdUnfolding x ) ++ -      "\n inl_src . inlinePragInfo . Ghc.idInfo = "    ++ GM.showPpr (Ghc.inl_src $ Ghc.inlinePragInfo $ Ghc.idInfo x) ++ -      "\n inl_inline . inlinePragInfo . Ghc.idInfo = " ++ GM.showPpr (Ghc.inl_inline $ Ghc.inlinePragInfo $ Ghc.idInfo x) ++ -      "\n inl_sat . inlinePragInfo . Ghc.idInfo = "    ++ GM.showPpr (Ghc.inl_sat $ Ghc.inlinePragInfo $ Ghc.idInfo x) ++ -      "\n inl_act . inlinePragInfo . Ghc.idInfo = "    ++ GM.showPpr (Ghc.inl_act $ Ghc.inlinePragInfo $ Ghc.idInfo x) ++ -      "\n inl_rule . inlinePragInfo . Ghc.idInfo = "   ++ GM.showPpr (Ghc.inl_rule $ Ghc.inlinePragInfo $ Ghc.idInfo x) ++ -      "\n inl_rule rule = " ++ GM.showPpr (Ghc.inl_rule $ Ghc.inlinePragInfo $ Ghc.idInfo x) ++ -      "\n inline spec = " ++ GM.showPpr (Ghc.inl_inline $ Ghc.inlinePragInfo $ Ghc.idInfo x)  -     ) x -   where  -    go (Ghc.ForAllTy a (Ghc.ForAllTy b (Ghc.ForAllTy c (Ghc.FunTy { Ghc.ft_arg = tf, Ghc.ft_res = Ghc.FunTy { Ghc.ft_arg = tg, Ghc.ft_res = tx}}))))-      = let f = stringVar "f" tf +      "\nv = " ++ GM.showPpr gid +++      "\n realIdUnfolding = " ++ GM.showPpr (Ghc.realIdUnfolding gid) +++      "\n maybeUnfoldingTemplate . realIdUnfolding = " ++ GM.showPpr (Ghc.maybeUnfoldingTemplate $ Ghc.realIdUnfolding gid ) +++      "\n inl_src . inlinePragInfo . Ghc.idInfo = "    ++ GM.showPpr (Ghc.inl_src $ Ghc.inlinePragInfo $ Ghc.idInfo gid) +++      "\n inl_inline . inlinePragInfo . Ghc.idInfo = " ++ GM.showPpr (Ghc.inl_inline $ Ghc.inlinePragInfo $ Ghc.idInfo gid) +++      "\n inl_sat . inlinePragInfo . Ghc.idInfo = "    ++ GM.showPpr (Ghc.inl_sat $ Ghc.inlinePragInfo $ Ghc.idInfo gid) +++      "\n inl_act . inlinePragInfo . Ghc.idInfo = "    ++ GM.showPpr (Ghc.inl_act $ Ghc.inlinePragInfo $ Ghc.idInfo gid) +++      "\n inl_rule . inlinePragInfo . Ghc.idInfo = "   ++ GM.showPpr (Ghc.inl_rule $ Ghc.inlinePragInfo $ Ghc.idInfo gid) +++      "\n inl_rule rule = " ++ GM.showPpr (Ghc.inl_rule $ Ghc.inlinePragInfo $ Ghc.idInfo gid) +++      "\n inline spec = " ++ GM.showPpr (Ghc.inl_inline $ Ghc.inlinePragInfo $ Ghc.idInfo gid)+     ) gid+   where+    go (Ghc.ForAllTy a (Ghc.ForAllTy b (Ghc.ForAllTy c Ghc.FunTy{ Ghc.ft_arg = tf, Ghc.ft_res = Ghc.FunTy { Ghc.ft_arg = tg, Ghc.ft_res = tx}})))+      = let f = stringVar "f" tf             g = stringVar "g" tg-            x = stringVar "x" tx -        in Ghc.Lam (Ghc.binderVar a) $ -           Ghc.Lam (Ghc.binderVar b) $ -           Ghc.Lam (Ghc.binderVar c) $ +            x = stringVar "x" tx+        in Ghc.Lam (Ghc.binderVar a) $+           Ghc.Lam (Ghc.binderVar b) $+           Ghc.Lam (Ghc.binderVar c) $            Ghc.Lam f $ Ghc.Lam g $ Ghc.Lam x $ Ghc.App (Ghc.Var f) (Ghc.App (Ghc.Var g) (Ghc.Var x))     go _ = error "Axioms.go"
src/Language/Haskell/Liquid/Bare/Check.hs view
@@ -1,19 +1,19 @@-{-# LANGUAGE ParallelListComp    #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE TupleSections       #-} {-# LANGUAGE RecordWildCards     #-} {-# LANGUAGE OverloadedStrings   #-} -module Language.Haskell.Liquid.Bare.Check +module Language.Haskell.Liquid.Bare.Check   ( checkTargetSpec   , checkBareSpec+  , checkTargetSrc   ) where   import           Language.Haskell.Liquid.Constraint.ToFixpoint -import           Language.Haskell.Liquid.GHC.API                   as Ghc hiding ( Located+import           Liquid.GHC.API                   as Ghc hiding ( Located                                                                                  , text                                                                                  , (<+>)                                                                                  , panic@@ -29,21 +29,42 @@ import qualified Data.HashMap.Strict                       as M import qualified Data.HashSet                              as S import           Data.Hashable-import qualified Language.Fixpoint.Misc                    as Misc  +import qualified Language.Fixpoint.Misc                    as Misc import           Language.Fixpoint.SortCheck               (checkSorted, checkSortedReftFull, checkSortFull)-import qualified Language.Fixpoint.Types                   as F -import qualified Language.Haskell.Liquid.GHC.Misc          as GM +import qualified Language.Fixpoint.Types                   as F+import qualified Liquid.GHC.Misc          as GM+import           Liquid.GHC.Play          (getNonPositivesTyCon) import           Language.Haskell.Liquid.Misc              (condNull, thd5) import           Language.Haskell.Liquid.Types import           Language.Haskell.Liquid.WiredIn import           Language.Haskell.Liquid.LawInstances      (checkLawInstances)  import qualified Language.Haskell.Liquid.Measure           as Ms-import qualified Language.Haskell.Liquid.Bare.Types        as Bare -import qualified Language.Haskell.Liquid.Bare.Resolve      as Bare +import qualified Language.Haskell.Liquid.Bare.Types        as Bare+import qualified Language.Haskell.Liquid.Bare.Resolve      as Bare   ----------------------------------------------------------------------------------------------+-- | Checking TargetSrc ------------------------------------------------------------------------+----------------------------------------------------------------------------------------------+checkTargetSrc :: Config -> TargetSrc -> Either Diagnostics ()+checkTargetSrc cfg spec+  |  nopositivity cfg+  || nopositives == emptyDiagnostics+  = Right ()+  | otherwise+  = Left nopositives+  where nopositives = checkPositives (gsTcs spec)+++checkPositives :: [TyCon] -> Diagnostics+checkPositives tys = mkDiagnostics [] $ mkNonPosError (getNonPositivesTyCon tys)++mkNonPosError :: [(TyCon, [DataCon])]  -> [Error]+mkNonPosError tcs = [ ErrPosTyCon (getSrcSpan tc) (pprint tc) (pprint dc <+> ":" <+> pprint (dataConRepType dc))+                    | (tc, dc:_) <- tcs]++---------------------------------------------------------------------------------------------- -- | Checking BareSpec ------------------------------------------------------------------------ ---------------------------------------------------------------------------------------------- checkBareSpec :: ModName -> Ms.BareSpec -> Either Diagnostics ()@@ -67,28 +88,28 @@     fields    = concatMap dataDeclFields (Ms.dataDecls sp)  dataDeclFields :: DataDecl -> [F.LocSymbol]-dataDeclFields = filter (not . GM.isTmpSymbol . F.val) -               . Misc.hashNubWith val -               . concatMap dataCtorFields +dataDeclFields = filter (not . GM.isTmpSymbol . F.val)+               . Misc.hashNubWith val+               . concatMap dataCtorFields                . fromMaybe []                . tycDCons  dataCtorFields :: DataCtor -> [F.LocSymbol]-dataCtorFields c -  | isGadt c  = [] +dataCtorFields c+  | isGadt c  = []   | otherwise = F.atLoc c <$> [ f | (f,_) <- dcFields c ] -isGadt :: DataCtor -> Bool -isGadt = isJust . dcResult +isGadt :: DataCtor -> Bool+isGadt = isJust . dcResult  checkUnique :: String -> [F.LocSymbol] -> Diagnostics-checkUnique _ = mkDiagnostics mempty . checkUnique' F.val GM.fSrcSpan +checkUnique _ = mkDiagnostics mempty . checkUnique' F.val GM.fSrcSpan -checkUnique' :: (PPrint a, Eq a, Hashable a) +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] +checkUnique' nameF locF ts = [ErrDupSpecs l (pprint n) ls | (n, ls@(l:_)) <- dups]   where-    dups                   = [ z      | z@(_, _:_:_) <- Misc.groupList nts       ] +    dups                   = [ z      | z@(_, _:_:_) <- Misc.groupList nts       ]     nts                    = [ (n, l) | t <- ts, let n = nameF t, let l = locF t ]  checkDisjoints :: [S.HashSet F.LocSymbol] -> Diagnostics@@ -109,56 +130,56 @@                 -> [CoreBind]                 -> TargetSpec                 -> Either Diagnostics ()-checkTargetSpec specs src env cbs sp+checkTargetSpec specs src env cbs tsp   | diagnostics == emptyDiagnostics = Right ()   | otherwise                       = Left diagnostics   where     diagnostics      :: Diagnostics-    diagnostics      =  foldMap (checkBind allowHO bsc "measure"      emb tcEnv env) (gsMeas       (gsData sp))+    diagnostics      =  foldMap (checkBind allowHO bsc "measure"      emb tcEnv env) (gsMeas       (gsData tsp))                      <> condNull noPrune-                        (foldMap (checkBind allowHO bsc "constructor"  emb tcEnv env) (txCtors $ gsCtors      (gsData sp)))-                     <> foldMap (checkBind allowHO bsc "assume"       emb tcEnv env) (gsAsmSigs    (gsSig sp))-                     <> foldMap (checkBind allowHO bsc "reflect"      emb tcEnv env) (fmap (\sig@(_,s) -> F.notracepp (show (ty_info (toRTypeRep (F.val s)))) sig) $ gsRefSigs    (gsSig sp))-                     <> checkTySigs allowHO bsc cbs            emb tcEnv env                (gsSig sp)+                        (foldMap (checkBind allowHO bsc "constructor"  emb tcEnv env) (txCtors $ gsCtors      (gsData tsp)))+                     <> foldMap (checkBind allowHO bsc "assume"       emb tcEnv env) (gsAsmSigs    (gsSig tsp))+                     <> foldMap (checkBind allowHO bsc "reflect"      emb tcEnv env . (\sig@(_,s) -> F.notracepp (show (ty_info (toRTypeRep (F.val s)))) sig)) (gsRefSigs (gsSig tsp))+                     <> checkTySigs allowHO bsc cbs            emb tcEnv env                (gsSig tsp)                      -- ++ mapMaybe (checkTerminationExpr             emb       env) (gsTexprs     (gsSig  sp))-                     <> foldMap (checkBind allowHO bsc "class method" emb tcEnv env) (clsSigs      (gsSig sp))-                     <> foldMap (checkInv allowHO bsc emb tcEnv env)                 (gsInvariants (gsData sp))-                     <> checkIAl allowHO bsc emb tcEnv env                            (gsIaliases   (gsData sp))+                     <> foldMap (checkBind allowHO bsc "class method" emb tcEnv env) (clsSigs      (gsSig tsp))+                     <> foldMap (checkInv allowHO bsc emb tcEnv env)                 (gsInvariants (gsData tsp))+                     <> checkIAl allowHO bsc emb tcEnv env                            (gsIaliases   (gsData tsp))                      <> checkMeasures emb env ms-                     <> checkClassMeasures                                        (gsMeasures (gsData sp))-                     <> checkClassMethods (gsCls src) (gsCMethods (gsVars sp)) (gsTySigs     (gsSig sp))+                     <> checkClassMeasures                                        (gsMeasures (gsData tsp))+                     <> checkClassMethods (gsCls src) (gsCMethods (gsVars tsp)) (gsTySigs     (gsSig tsp))                      -- <> foldMap checkMismatch sigs                      <> foldMap checkMismatch (L.filter (\(v,_) -> not (GM.isSCSel v || GM.isMethod v)) sigs)-                     <> checkDuplicate                                            (gsTySigs     (gsSig sp))+                     <> checkDuplicate                                            (gsTySigs     (gsSig tsp))                      -- TODO-REBARE ++ checkQualifiers env                                       (gsQualifiers (gsQual sp))-                     <> checkDuplicate                                            (gsAsmSigs    (gsSig sp))-                     <> checkDupIntersect                                         (gsTySigs (gsSig sp)) (gsAsmSigs (gsSig sp))+                     <> checkDuplicate                                            (gsAsmSigs    (gsSig tsp))+                     <> checkDupIntersect                                         (gsTySigs (gsSig tsp)) (gsAsmSigs (gsSig tsp))                      <> checkRTAliases "Type Alias" env            tAliases                      <> checkRTAliases "Pred Alias" env            eAliases                      -- ++ _checkDuplicateFieldNames                   (gsDconsP sp)                      -- NV TODO: allow instances of refined classes to be refined                      -- but make sure that all the specs are checked.                      -- ++ checkRefinedClasses                        rClasses rInsts-                     <> checkSizeFun emb env                                      (gsTconsP (gsName sp))-                     <> checkPlugged (catMaybes [ fmap (F.dropSym 2 $ GM.simplesymbol x,) (getMethodType t) | (x, t) <- gsMethods (gsSig sp) ])-                     <> checkLawInstances (gsLaws sp)-                     <> checkRewrites sp+                     <> checkSizeFun emb env                                      (gsTconsP (gsName tsp))+                     <> checkPlugged (catMaybes [ fmap (F.dropSym 2 $ GM.simplesymbol x,) (getMethodType t) | (x, t) <- gsMethods (gsSig tsp) ])+                     <> checkLawInstances (gsLaws tsp)+                     <> checkRewrites tsp -    _rClasses         = concatMap (Ms.classes  ) specs-    _rInsts           = concatMap (Ms.rinstance) specs+    _rClasses         = concatMap Ms.classes specs+    _rInsts           = concatMap Ms.rinstance specs     tAliases          = concat [Ms.aliases sp  | sp <- specs]     eAliases          = concat [Ms.ealiases sp | sp <- specs]-    emb              = gsTcEmbeds (gsName sp)-    tcEnv            = gsTyconEnv (gsName sp)-    ms               = gsMeasures (gsData sp)+    emb              = gsTcEmbeds (gsName tsp)+    tcEnv            = gsTyconEnv (gsName tsp)+    ms               = gsMeasures (gsData tsp)     clsSigs sp       = [ (v, t) | (v, t) <- gsTySigs sp, isJust (isClassOpId_maybe v) ]-    sigs             = gsTySigs (gsSig sp) ++ gsAsmSigs (gsSig sp) ++ gsCtors (gsData sp)+    sigs             = gsTySigs (gsSig tsp) ++ gsAsmSigs (gsSig tsp) ++ gsCtors (gsData tsp)     -- allowTC          = typeclass (getConfig sp)-    allowHO          = higherOrderFlag sp-    bsc              = bscope (getConfig sp)-    noPrune          = not (pruneFlag sp)+    allowHO          = higherOrderFlag tsp+    bsc              = bscope (getConfig tsp)+    noPrune          = not (pruneFlag tsp)     txCtors ts       = [(v, fmap (fmap (fmap (F.filterUnMatched temps))) t) | (v, t) <- ts]-    temps            = F.makeTemplates $ gsUnsorted $ gsData sp+    temps            = F.makeTemplates $ gsUnsorted $ gsData tsp     -- env'             = L.foldl' (\e (x, s) -> insertSEnv x (RR s mempty) e) env wiredSortedSyms  @@ -182,14 +203,14 @@             -> GhcSpecSig             -> Diagnostics ---------------------------------------------------------------------------------checkTySigs allowHO bsc cbs emb tcEnv env sig-                   = mconcat (map (check env) topTs)+checkTySigs allowHO bsc cbs emb tcEnv senv sig+                   = mconcat (map (check senv) topTs)                    -- = concatMap (check env) topTs                    -- (mapMaybe   (checkT env) [ (x, t)     | (x, (t, _)) <- topTs])                    -- ++ (mapMaybe   (checkE env) [ (x, t, es) | (x, (t, Just es)) <- topTs]) -                  <> coreVisitor checkVisitor env emptyDiagnostics cbs+                  <> coreVisitor checkVisitor senv emptyDiagnostics cbs                    -- ++ coreVisitor checkVisitor env [] cbs -  where +  where     check env      = checkSigTExpr allowHO bsc emb tcEnv env     locTm          = M.fromList locTs     (locTs, topTs) = Bare.partitionLocalBinds vtes@@ -203,17 +224,17 @@                        , exprF = \_   acc _ -> acc                        }     vSort            = Bare.varSortedReft emb-    errs env v       = case M.lookup v locTm of +    errs env v       = case M.lookup v locTm of                          Nothing -> emptyDiagnostics-                         Just t  -> check env (v, t) +                         Just t  -> check env (v, t) -checkSigTExpr :: Bool -> BScope -> F.TCEmb TyCon -> Bare.TyConMap -> F.SEnv F.SortedReft -              -> (Var, (LocSpecType, Maybe [Located F.Expr])) +checkSigTExpr :: Bool -> BScope -> F.TCEmb TyCon -> Bare.TyConMap -> F.SEnv F.SortedReft+              -> (Var, (LocSpecType, Maybe [Located F.Expr]))               -> Diagnostics-checkSigTExpr allowHO bsc emb tcEnv env (x, (t, es)) +checkSigTExpr allowHO bsc emb tcEnv env (x, (t, es))            = mbErr1 <> mbErr2-   where -    mbErr1 = checkBind allowHO bsc empty emb tcEnv env (x, t) +   where+    mbErr1 = checkBind allowHO bsc empty emb tcEnv env (x, t)     mbErr2 = maybe emptyDiagnostics (checkTerminationExpr emb env . (x, t,)) es     -- mbErr2 = checkTerminationExpr emb env . (x, t,) =<< es  @@ -222,7 +243,7 @@  checkQualifier       :: F.SEnv F.SortedReft -> F.Qualifier -> Maybe Error checkQualifier env q =  mkE <$> checkSortFull (F.srcSpan q) γ F.boolSort  (F.qBody q)-  where +  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) @@ -256,7 +277,7 @@   = mkError <$> duplicates   where     duplicates-      = mapMaybe checkCls (rcName <$> definitions)+      = mapMaybe (checkCls . rcName) definitions     checkCls cls       = case findConflicts cls of           []        -> Nothing@@ -351,14 +372,14 @@                      -> F.SEnv F.SortedReft                      -> (v, LocSpecType, [F.Located F.Expr])                      -> Diagnostics-checkTerminationExpr emb env (v, Loc l _ t, les)-            = (mkErr "ill-sorted" $ go les) <> (mkErr "non-numeric" $ go' les)+checkTerminationExpr emb env (v, Loc l _ st, les)+            = mkErr "ill-sorted" (go les) <> mkErr "non-numeric" (go' les)   where     -- es      = val <$> les     mkErr :: Doc -> Maybe (F.Expr, Doc) -> Diagnostics     mkErr _ Nothing = emptyDiagnostics-    mkErr k (Just e) =-      mkDiagnostics mempty [uncurry (\ e d -> ErrTermSpec (GM.sourcePosSrcSpan l) (pprint v) k e t d) e]+    mkErr k (Just expr') =+      mkDiagnostics mempty [(\ (e, d) -> ErrTermSpec (GM.sourcePosSrcSpan l) (pprint v) k e st d) expr']     -- mkErr   = uncurry (\ e d -> ErrTermSpec (GM.sourcePosSrcSpan l) (pprint v) (text "ill-sorted" ) e t d)     -- mkErr'  = uncurry (\ e d -> ErrTermSpec (GM.sourcePosSrcSpan l) (pprint v) (text "non-numeric") e t d) @@ -369,11 +390,11 @@     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+    xts     = concatMap mkClss $ zip (ty_binds trep) (ty_args trep)+    trep    = toRTypeRep st -    mkClass (_, RApp c ts _ _) | isClass c = classBinds emb (rRCls c ts)-    mkClass (x, t)                         = [(x, rSort t)]+    mkClss (_, RApp c ts _ _) | isClass c = classBinds emb (rRCls c ts)+    mkClss (x, t)                         = [(x, rSort t)]      rSort   = rTypeSortedReft emb     cmpZero e = F.PAtom F.Le (F.expr (0 :: Int)) (val e)@@ -456,13 +477,13 @@ ------------------------------------------------------------------------------------------------ checkRType :: Bool -> BScope -> F.TCEmb TyCon -> F.SEnv F.SortedReft -> LocSpecType -> Maybe Doc -------------------------------------------------------------------------------------------------checkRType allowHO bsc emb env lt-  =   checkAppTys t-  <|> checkAbstractRefs t-  <|> efoldReft farg bsc cb (tyToBind emb) (rTypeSortedReft emb) f insertPEnv env Nothing t+checkRType allowHO bsc emb senv lt+  =   checkAppTys st+  <|> checkAbstractRefs st+  <|> efoldReft farg bsc cb (tyToBind emb) (rTypeSortedReft emb) f insertPEnv senv Nothing st   where     -- isErasable         = if allowTC then isEmbeddedDict else isClass-    t                  = val lt+    st                 = val lt     cb c ts            = classBinds emb (rRCls c ts)     farg _ t           = allowHO || isBase t  -- NOTE: this check should be the same as the one in addCGEnv     f env me r err     = err <|> checkReft (F.srcSpan lt) env emb me r@@ -472,8 +493,8 @@ tyToBind :: F.TCEmb TyCon -> RTVar RTyVar RSort  -> [(F.Symbol, F.SortedReft)] tyToBind emb = go . ty_var_info   where-    go (RTVInfo {..})   = [(rtv_name, rTypeSortedReft emb rtv_kind)]-    go (RTVNoInfo {..}) = []+    go RTVInfo{..} = [(rtv_name, rTypeSortedReft emb rtv_kind)]+    go RTVNoInfo{} = []  checkAppTys :: RType RTyCon t t1 -> Maybe Doc checkAppTys = go@@ -494,7 +515,7 @@     go (RHole _)        = Nothing  checkTcArity :: RTyCon -> Arity -> Maybe Doc-checkTcArity (RTyCon { rtc_tc = tc }) givenArity+checkTcArity RTyCon{ rtc_tc = tc } givenArity   | expectedArity < givenArity     = Just $ text "Type constructor" <+> pprint tc         <+> text "expects a maximum" <+> pprint expectedArity@@ -509,9 +530,9 @@ checkAbstractRefs   :: (PPrint t, F.Reftable t, SubsTy RTyVar RSort t, F.Reftable (RTProp RTyCon RTyVar (UReft t))) =>      RType RTyCon RTyVar (UReft t) -> Maybe Doc-checkAbstractRefs t = go t+checkAbstractRefs rt = go rt   where-    penv = mkPEnv t+    penv = mkPEnv rt      go t@(RAllT _ t1 r)   = check (toRSort t :: RSort) r <|>  go t1     go (RAllP _ t)        = go t@@ -563,7 +584,7 @@     mkPEnv (RAllT _ t _) = mkPEnv t     mkPEnv (RAllP p t)   = p:mkPEnv t     mkPEnv _             = []-    pvType' p          = Misc.safeHead (showpp p ++ " not in env of " ++ showpp t) [pvType q | q <- penv, pname p == pname q]+    pvType' p          = Misc.safeHead (showpp p ++ " not in env of " ++ showpp rt) [pvType q | q <- penv, pname p == pname q]   checkReft                    :: (PPrint r, F.Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, F.Reftable (RTProp RTyCon RTyVar (UReft r)))@@ -605,11 +626,11 @@            -> SpecType            -> Def (RRType r) DataCon            -> Maybe Doc-checkMBody γ emb _ sort (Def m c _ bs body) = checkMBody' emb sort γ' sp body+checkMBody senv emb _ sort (Def m c _ bs body) = checkMBody' emb sort γ' sp body   where     sp    = F.srcSpan m-    γ'    = L.foldl' (\γ (x, t) -> F.insertSEnv x t γ) γ xts-    xts   = zip (fst <$> bs) $ rTypeSortedReft emb . subsTyVars_meet su  <$> +    γ'    = L.foldl' (\γ (x, t) -> F.insertSEnv x t γ) senv xts+    xts   = zip (fst <$> bs) $ rTypeSortedReft emb . subsTyVarsMeet su  <$>             filter keep (ty_args trep)     keep | allowTC = not . isEmbeddedClass          | otherwise = not . isClassType@@ -622,17 +643,17 @@  checkMBodyUnify   :: RType t t2 t1 -> RType c tv r -> [(t2,RType c tv (),RType c tv r)]-checkMBodyUnify                 = go+checkMBodyUnify = go   where-    go (RVar tv _) t            = [(tv, toRSort t, t)]-    go t@(RApp {}) t'@(RApp {}) = concat $ zipWith go (rt_args t) (rt_args t')-    go _ _                      = []+    go (RVar tv _) t      = [(tv, toRSort t, t)]+    go t@RApp{} t'@RApp{} = concat $ zipWith go (rt_args t) (rt_args t')+    go _ _                = []  checkMBody' :: (PPrint r, F.Reftable r,SubsTy RTyVar RSort r, F.Reftable (RTProp RTyCon RTyVar r))             => F.TCEmb TyCon             -> RType RTyCon RTyVar r             -> F.SEnv F.SortedReft-            -> F.SrcSpan +            -> F.SrcSpan             -> Body             -> Maybe Doc checkMBody' emb sort γ sp body = case body of@@ -661,12 +682,12 @@                 ++ show rw                 ++ " as a rewrite because it does not prove an equality, or the equality it proves is trivial." ]   | otherwise-  = refErrs ++ if cannotInstantiate then-        [ErrRewrite (GM.fSrcSpan t) $+  = refErrs +++      [ ErrRewrite (GM.fSrcSpan t) $         text $ "Could not generate any rewrites from equality. Likely causes: "         ++ "\n - There are free (uninstantiatable) variables on both sides of the "-        ++ "equality\n - The rewrite would diverge"]-        else []+        ++ "equality\n - The rewrite would diverge"+      | cannotInstantiate]     where         refErrs = map getInnerRefErr (filter (hasInnerRefinement . fst) (zip tyArgs syms))         allowedRWs = [ (lhs, rhs) | (lhs , rhs) <- refinementEQs t@@ -724,9 +745,9 @@   checkClassMeasures :: [Measure SpecType DataCon] -> Diagnostics-checkClassMeasures ms = mkDiagnostics mempty (mapMaybe checkOne byTyCon)+checkClassMeasures measures = mkDiagnostics mempty (mapMaybe checkOne byTyCon)   where-  byName = L.groupBy ((==) `on` (val . msName)) ms+  byName = L.groupBy ((==) `on` (val . msName)) measures    byTyCon = concatMap (L.groupBy ((==) `on` (dataConTyCon . ctor . head . msEqns)))                       byName
src/Language/Haskell/Liquid/Bare/Class.hs view
@@ -2,18 +2,17 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ParallelListComp  #-} {-# LANGUAGE TupleSections     #-}-{-# LANGUAGE BangPatterns      #-} -module Language.Haskell.Liquid.Bare.Class +module Language.Haskell.Liquid.Bare.Class   ( makeClasses   , makeCLaws   , makeSpecDictionaries   , makeDefaultMethods   , makeMethodTypes-  ) +  )   where -import           Data.Bifunctor +import           Data.Bifunctor import qualified Data.Maybe                                 as Mb import qualified Data.List                                  as L import qualified Data.HashMap.Strict                        as M@@ -23,14 +22,14 @@ import qualified Language.Fixpoint.Types.Visitor            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 qualified Liquid.GHC.Misc           as GM+import qualified Liquid.GHC.API            as Ghc import           Language.Haskell.Liquid.Misc import           Language.Haskell.Liquid.Types.RefType import           Language.Haskell.Liquid.Types              hiding (freeTyVars)  import qualified Language.Haskell.Liquid.Measure            as Ms-import           Language.Haskell.Liquid.Bare.Types         as Bare +import           Language.Haskell.Liquid.Bare.Types         as Bare import           Language.Haskell.Liquid.Bare.Resolve       as Bare import           Language.Haskell.Liquid.Bare.Expand        as Bare import           Language.Haskell.Liquid.Bare.Misc         as Bare@@ -44,19 +43,19 @@ ------------------------------------------------------------------------------- makeMethodTypes :: Bool -> DEnv Ghc.Var LocSpecType -> [DataConP] -> [Ghc.CoreBind] -> [(Ghc.Var, MethodType LocSpecType)] --------------------------------------------------------------------------------makeMethodTypes allowTC (DEnv m) cls cbs -  = [(x, MT (addCC allowTC x . fromRISig <$> methodType d x m) (addCC allowTC x <$> classType (splitDictionary e) x)) | (d,e) <- ds, x <- grepMethods e]-    where +makeMethodTypes allowTC (DEnv hm) cls cbs+  = [(x, MT (addCC allowTC x . fromRISig <$> methodType d x hm) (addCC allowTC x <$> classType (splitDictionary e) x)) | (d,e) <- ds, x <- grepMethods e]+    where       grepMethods = filter GM.isMethod . freeVars mempty       ds = filter (GM.isDictionary . fst) (concatMap unRec cbs)       unRec (Ghc.Rec xes) = xes       unRec (Ghc.NonRec x e) = [(x,e)]        classType Nothing _ = Nothing-      classType (Just (d, ts, _)) x = -        case filter ((==d) . Ghc.dataConWorkId . dcpCon) cls of -          (di:_) -> fmap ((dcpLoc di `F.atLoc`) . subst (zip (dcpFreeTyVars di) ts)) $ L.lookup (mkSymbol x) (dcpTyArgs di)-          _      -> Nothing +      classType (Just (d, ts, _)) x =+        case filter ((==d) . Ghc.dataConWorkId . dcpCon) cls of+          (di:_) -> (dcpLoc di `F.atLoc`) . subst (zip (dcpFreeTyVars di) ts) <$> L.lookup (mkSymbol x) (dcpTyArgs di)+          _      -> Nothing        methodType d x m = ihastype (M.lookup d m) x @@ -65,216 +64,215 @@        mkSymbol x = F.dropSym 2 $ GM.simplesymbol x -      subst [] t = t -      subst ((a,ta):su) t = subsTyVar_meet' (a,ofType ta) (subst su t)+      subst [] t = t+      subst ((a,ta):su) t = subsTyVarMeet' (a,ofType ta) (subst su t)  addCC :: Bool -> Ghc.Var -> LocSpecType -> LocSpecType-addCC allowTC x zz@(Loc l l' st0) -  = Loc l l' -  . addForall hst  -  . mkArrow [] ps' [] [] -  . makeCls cs' -  . mapExprReft (\_ -> F.applyCoSub coSub) -  . subts su -  $ st  +addCC allowTC var zz@(Loc l l' st0)+  = Loc l l'+  . addForall hst+  . mkArrow [] ps' [] []+  . makeCls cs'+  . mapExprReft (\_ -> F.applyCoSub coSub)+  . subts su+  $ st   where     hst           = ofType (Ghc.expandTypeSynonyms t0) :: SpecType-    t0            = Ghc.varType x +    t0            = Ghc.varType var     tyvsmap       = case Bare.runMapTyVars allowTC t0 st err of-                          Left e  -> Ex.throw e +                          Left e  -> Ex.throw e                           Right s -> Bare.vmap s     su            = [(y, rTyVar x)           | (x, y) <- tyvsmap]     su'           = [(y, RVar (rTyVar x) ()) | (x, y) <- tyvsmap] :: [(RTyVar, RSort)]     coSub         = M.fromList [(F.symbol y, F.FObj (F.symbol x)) | (y, x) <- su]     ps'           = fmap (subts su') <$> ps-    cs'           = [(F.dummySymbol, RApp c ts [] mempty) | (c, ts) <- cs ] +    cs'           = [(F.dummySymbol, RApp c ts [] mempty) | (c, ts) <- cs ]     (_,_,cs,_)    = bkUnivClass (F.notracepp "hs-spec" $ ofType (Ghc.expandTypeSynonyms t0) :: SpecType)     (_,ps,_ ,st)  = bkUnivClass (F.notracepp "lq-spec" st0) -    makeCls cs t  = foldr (uncurry rFun) t cs-    err hsT lqT   = ErrMismatch (GM.fSrcSpan zz) (pprint x) +    makeCls c t  = foldr (uncurry rFun) t c+    err hsT lqT   = ErrMismatch (GM.fSrcSpan zz) (pprint var)       (text "makeMethodTypes")       (pprint $ Ghc.expandTypeSynonyms t0)       (pprint $ toRSort st0)       (Just (hsT, lqT))-      (Ghc.getSrcSpan x) +      (Ghc.getSrcSpan var)      addForall (RAllT v t r) tt@(RAllT v' _ _)       | v == v'       = tt-      | otherwise +      | otherwise       = RAllT (updateRTVar v) (addForall t tt) r-    addForall (RAllT v t r) t' -      = RAllT (updateRTVar v) (addForall t t') r -    addForall (RAllP _ t) t' +    addForall (RAllT v t r) t'+      = RAllT (updateRTVar v) (addForall t t') r+    addForall (RAllP _ t) t'       = addForall t t'     addForall _ (RAllP p t')-      = RAllP (fmap (subts su') p) t' +      = RAllP (fmap (subts su') p) t'     addForall (RFun _ _ t1 t2 _) (RFun x i t1' t2' r)-      = RFun x i (addForall t1 t1') (addForall t2 t2') r  -    addForall _ t -      = t +      = RFun x i (addForall t1 t1') (addForall t2 t2') r+    addForall _ t+      = t   splitDictionary :: Ghc.CoreExpr -> Maybe (Ghc.Var, [Ghc.Type], [Ghc.Var])-splitDictionary = go [] [] -  where +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.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 +makeCLaws :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.ModSpecs           -> Bare.Lookup [(Ghc.Class, [(ModName, Ghc.Var, LocSpecType)])] --------------------------------------------------------------------------------makeCLaws env sigEnv myName specs = do -  zMbs <- forM classTcs $ \(name, cls, tc) -> do -            clsMb <- mkClass env sigEnv myName name cls tc-            case clsMb of -              Nothing -> -                return $ Nothing -              Just cls -> do -                gcls <- Mb.maybe (err tc) Right (Ghc.tyConClass_maybe tc) +makeCLaws env sigEnv myName specs = do+  zMbs <- forM classTcs $ \(name, clss, tc) -> do+            clsMb <- mkClass env sigEnv myName name clss tc+            case clsMb of+              Nothing ->+                return Nothing+              Just cls -> do+                gcls <- Mb.maybe (err tc) Right (Ghc.tyConClass_maybe tc)                 return $ Just (gcls, snd cls)   return (Mb.catMaybes zMbs)   where     err tc   = error ("Not a type class: " ++ F.showpp tc)-    classTc  = Bare.maybeResolveSym env myName "makeClass" . btc_tc . rcName +    classTc  = Bare.maybeResolveSym env myName "makeClass" . btc_tc . rcName     classTcs = [ (name, cls, tc) | (name, spec) <- M.toList specs                                  , cls          <- Ms.claws spec-                                 , tc           <- Mb.maybeToList (classTc cls) +                                 , tc           <- Mb.maybeToList (classTc cls)                ]  --------------------------------------------------------------------------------makeClasses :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.ModSpecs +makeClasses :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.ModSpecs             -> Bare.Lookup ([DataConP], [(ModName, Ghc.Var, LocSpecType)]) --------------------------------------------------------------------------------makeClasses env sigEnv myName specs = do -  mbZs <- forM classTcs $ \(name, cls, tc) -> -            mkClass env sigEnv myName name cls tc -  return . second mconcat . unzip . Mb.catMaybes $ mbZs +makeClasses env sigEnv myName specs = do+  mbZs <- forM classTcs $ \(name, cls, tc) ->+            mkClass env sigEnv myName name cls tc+  return . second mconcat . unzip . Mb.catMaybes $ mbZs   where     classTcs = [ (name, cls, tc) | (name, spec) <- M.toList specs                                  , cls          <- Ms.classes spec                                  , tc           <- Mb.maybeToList (classTc cls) ]-    classTc = Bare.maybeResolveSym env myName "makeClass" . btc_tc . rcName +    classTc = Bare.maybeResolveSym env myName "makeClass" . btc_tc . rcName -mkClass :: Bare.Env -> Bare.SigEnv -> ModName -> ModName -> RClass LocBareType -> Ghc.TyCon +mkClass :: Bare.Env -> Bare.SigEnv -> ModName -> ModName -> RClass LocBareType -> Ghc.TyCon         -> Bare.Lookup (Maybe (DataConP, [(ModName, Ghc.Var, LocSpecType)]))-mkClass env sigEnv _myName name (RClass cc ss as ms) -  = Bare.failMaybe env name -  . mkClassE env sigEnv _myName name (RClass cc ss as ms) +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 +mkClassE :: Bare.Env -> Bare.SigEnv -> ModName -> ModName -> RClass LocBareType -> Ghc.TyCon          -> Bare.Lookup (DataConP, [(ModName, Ghc.Var, LocSpecType)])-mkClassE env sigEnv _myName name (RClass cc ss as ms) tc = do -    ss'    <- mapM (mkConstr   env sigEnv name) ss +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'+    let dcp = DataConP l dc αs [] (val <$> ss') (reverse sts) rt False (F.symbol name) l'     return  $ F.notracepp msg (dcp, vts)   where     c      = btc_tc cc     l      = loc  c     l'     = locE c-    msg    = "MKCLASS: " ++ F.showpp (cc, as, αs) +    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'+    rt     = rCls tc as' -mkConstr :: Bare.Env -> Bare.SigEnv -> ModName -> LocBareType -> Bare.Lookup LocSpecType     -mkConstr env sigEnv name = fmap (fmap dropUniv) . Bare.cookSpecTypeE env sigEnv name Bare.GenTV -  where +mkConstr :: Bare.Env -> Bare.SigEnv -> ModName -> LocBareType -> Bare.Lookup LocSpecType+mkConstr env sigEnv name = fmap (fmap dropUniv) . Bare.cookSpecTypeE env sigEnv name Bare.GenTV+  where     dropUniv t           = t' where (_, _, t') = bkUniv t     --FIXME: cleanup this code-unClass :: SpecType -> SpecType +unClass :: SpecType -> SpecType unClass = snd . bkClass . thrd3 . bkUniv -makeMethod :: Bare.Env -> Bare.SigEnv -> ModName -> (LocSymbol, LocBareType) +makeMethod :: Bare.Env -> Bare.SigEnv -> ModName -> (LocSymbol, LocBareType)            -> Bare.Lookup (ModName, PlugTV Ghc.Var, LocSpecType) makeMethod env sigEnv name (lx, bt) = (name, mbV,) <$> Bare.cookSpecTypeE env sigEnv name mbV bt-  where -    mbV = maybe Bare.GenTV Bare.LqTV (Bare.maybeResolveSym env name "makeMethod" lx) +  where+    mbV = maybe Bare.GenTV Bare.LqTV (Bare.maybeResolveSym env name "makeMethod" lx)  --------------------------------------------------------------------------------makeSpecDictionaries :: Bare.Env -> Bare.SigEnv -> ModSpecs -> DEnv Ghc.Var LocSpecType +makeSpecDictionaries :: Bare.Env -> Bare.SigEnv -> ModSpecs -> DEnv Ghc.Var LocSpecType ------------------------------------------------------------------------------- makeSpecDictionaries env sigEnv specs-  = dfromList -  . concatMap (makeSpecDictionary env sigEnv) +  = dfromList+  . concatMap (makeSpecDictionary env sigEnv)   $ M.toList specs  makeSpecDictionary :: Bare.Env -> Bare.SigEnv -> (ModName, Ms.BareSpec)                    -> [(Ghc.Var, M.HashMap F.Symbol (RISig LocSpecType))] makeSpecDictionary env sigEnv (name, spec)-  = Mb.catMaybes -  . resolveDictionaries env name -  . fmap (makeSpecDictionaryOne env sigEnv name) -  . Ms.rinstance +  = Mb.catMaybes+  . resolveDictionaries env name+  . fmap (makeSpecDictionaryOne env sigEnv name)+  . Ms.rinstance   $ spec -makeSpecDictionaryOne :: Bare.Env -> Bare.SigEnv -> ModName -                      -> RInstance LocBareType +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 $ F.notracepp "RI" $ RI x ts [(x, mkLSpecIType t) | (x, t) <- xts ] +makeSpecDictionaryOne env sigEnv name (RI bt lbt xts)+         = makeDictionary $ F.notracepp "RI" $ RI bt ts [(x, mkLSpecIType t) | (x, t) <- xts ]   where-    ts      = mkTy' <$> t-    as      = concatMap (univs . val) ts-    univs t = (\(RTVar tv _, _) -> tv) <$> as where (as, _, _) = bkUniv t +    ts      = mkTy' <$> lbt+    rts     = concatMap (univs . val) ts+    univs t = (\(RTVar tv _, _) -> tv) <$> as where (as, _, _) = bkUniv t      mkTy' :: LocBareType -> LocSpecType     mkTy' = Bare.cookSpecType env sigEnv name Bare.GenTV     mkTy :: LocBareType -> LocSpecType-    mkTy = fmap (mapUnis tidy) . Bare.cookSpecType env sigEnv name +    mkTy = fmap (mapUnis tidy) . Bare.cookSpecType env sigEnv name                Bare.GenTV -- (Bare.HsTV (Bare.lookupGhcVar env name "rawDictionaries" x))     mapUnis f t = mkUnivs (f as) ps t0 where (as, ps, t0) = bkUniv t -    tidy vs = l ++ r -      where (l,r) = L.partition (\(RTVar tv _,_) -> tv `elem` as) vs +    tidy vs = l ++ r+      where (l,r) = L.partition (\(RTVar tv _,_) -> tv `elem` rts) vs      mkLSpecIType :: RISig LocBareType -> RISig LocSpecType     mkLSpecIType t = fmap mkTy t -resolveDictionaries :: Bare.Env -> ModName -> [(F.Symbol, M.HashMap F.Symbol (RISig LocSpecType))] +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 +resolveDictionaries env name = fmap lookupVar+                             . concatMap addInstIndex+                             . Misc.groupList   where     lookupVar (x, inst)      = (, inst) <$> Bare.maybeResolveSym env name "resolveDict" (F.dummyLoc x)  -- formerly, addIndex -- GHC internal postfixed same name dictionaries with ints addInstIndex            :: (F.Symbol, [a]) -> [(F.Symbol, a)]-addInstIndex (x, is) = go 0 (reverse is)-  where +addInstIndex (x, ks) = go (0::Int) (reverse ks)+  where     go _ []          = []     go _ [i]         = [(x, i)]     go j (i:is)      = (F.symbol (F.symbolString x ++ show j),i) : go (j+1) is  -----------------------------------------------------------------------------------makeDefaultMethods :: Bare.Env -> [(ModName, Ghc.Var, LocSpecType)] +makeDefaultMethods :: Bare.Env -> [(ModName, Ghc.Var, LocSpecType)]                    -> [(ModName, Ghc.Var, LocSpecType)] -----------------------------------------------------------------------------------makeDefaultMethods env mts = [ (mname, dm, t) +makeDefaultMethods env mts = [ (mname, dm, t)                                  | (mname, m, t) <- mts-                                 , dm            <- lookupDefaultVar env mname m ]  +                                 , 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" +lookupDefaultVar :: Bare.Env -> ModName -> Ghc.Var -> [Ghc.Var]+lookupDefaultVar env name v = Mb.maybeToList+                            . Bare.maybeResolveSym env name "default-method"                             $ dmSym-  where +  where     dmSym                   = F.atLoc v (GM.qualifySymbol mSym dnSym)     dnSym                   = F.mappendSym "$dm" nSym-    (mSym, nSym)            = GM.splitModuleName (F.symbol v) +    (mSym, nSym)            = GM.splitModuleName (F.symbol v)
src/Language/Haskell/Liquid/Bare/DataType.hs view
@@ -7,7 +7,7 @@    -- * Names for accessing Data Constuctors    , makeDataConChecker-  , makeDataConSelector +  , makeDataConSelector   , addClassEmbeds    -- * Constructors@@ -17,6 +17,7 @@   , meetDataConSpec   -- , makeTyConEmbeds +  , dataDeclSize   ) where  import           Prelude                                hiding (error)@@ -26,11 +27,11 @@ 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 Data.Maybe                             as Mb  import qualified Language.Fixpoint.Types                as F-import qualified Language.Haskell.Liquid.GHC.Misc       as GM -import qualified Language.Haskell.Liquid.GHC.API        as Ghc +import qualified Liquid.GHC.Misc       as GM+import qualified Liquid.GHC.API        as Ghc import           Language.Haskell.Liquid.Types.PredType (dataConPSpecType) import qualified Language.Haskell.Liquid.Types.RefType  as RT import           Language.Haskell.Liquid.Types.Types@@ -39,10 +40,12 @@ import qualified Language.Haskell.Liquid.Misc           as Misc import           Language.Haskell.Liquid.Types.Variance import           Language.Haskell.Liquid.WiredIn+import           Language.Haskell.Liquid.Types.Names (selfSymbol)  import qualified Language.Haskell.Liquid.Measure        as Ms-import qualified Language.Haskell.Liquid.Bare.Types     as Bare  -import qualified Language.Haskell.Liquid.Bare.Resolve   as Bare ++import qualified Language.Haskell.Liquid.Bare.Types     as Bare+import qualified Language.Haskell.Liquid.Bare.Resolve   as Bare import           Text.Printf                     (printf) import Text.PrettyPrint ((<+>)) @@ -64,7 +67,7 @@ -------------------------------------------------------------------------------- makeDataConChecker :: Ghc.DataCon -> F.Symbol ---------------------------------------------------------------------------------makeDataConChecker = F.testSymbol . F.symbol +makeDataConChecker = F.testSymbol . F.symbol  -------------------------------------------------------------------------------- -- | 'makeDataConSelector d' creates the selector `select$d$i`@@ -74,11 +77,11 @@ -------------------------------------------------------------------------------- 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 +  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)@@ -89,13 +92,13 @@ 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+    rest          = maybe [] (Misc.single . F.symbol . show) iMb   -------------------------------------------------------------------------------- -- | makeClassEmbeds: sort-embeddings for numeric, and family-instance tycons ---------------------------------------------------------------------------------addClassEmbeds :: Maybe [Ghc.ClsInst] -> [Ghc.TyCon] -> F.TCEmb Ghc.TyCon +addClassEmbeds :: Maybe [Ghc.ClsInst] -> [Ghc.TyCon] -> F.TCEmb Ghc.TyCon                -> F.TCEmb Ghc.TyCon addClassEmbeds instenv fiTcs = makeFamInstEmbeds fiTcs . makeNumEmbeds instenv @@ -106,10 +109,10 @@ --   with the actual family instance  types that have numeric instances as int [Check!] -------------------------------------------------------------------------------- makeFamInstEmbeds :: [Ghc.TyCon] -> F.TCEmb Ghc.TyCon -> F.TCEmb Ghc.TyCon-makeFamInstEmbeds cs0 embs = L.foldl' embed embs famInstSorts+makeFamInstEmbeds cs0 embeds = L.foldl' embed embeds famInstSorts   where     famInstSorts          = F.notracepp "famInstTcs"-                            [ (c, RT.typeSort embs ty)+                            [ (c, RT.typeSort embeds ty)                                 | c   <- cs                                 , ty  <- Mb.maybeToList (RT.famInstTyConType c) ]     embed embs (c, t)     = F.tceInsert c t F.NoArgs embs@@ -209,27 +212,27 @@               -> [Located DataConP]               -> (Diagnostics, [F.DataDecl]) makeDataDecls cfg tce name tds ds-  | makeDecls        = (mkDiagnostics warns [], okDecs)  +  | makeDecls        = (mkDiagnostics warns [], okDecs)   | otherwise        = (mempty, [])   where     makeDecls        = exactDCFlag cfg && not (noADT cfg)     warns            = (mkWarnDecl . fst . fst . snd <$> badTcs) ++ (mkWarnDecl <$> badDecs)     tds'             = resolveTyCons name tds-    tcDds            = filter ((/= Ghc.listTyCon) . fst) +    tcDds            = filter ((/= Ghc.listTyCon) . fst)                      $ groupDataCons tds' ds     (okTcs, badTcs)  = L.partition isVanillaTc tcDds-    decs             = [ makeFDataDecls tce tc dd ctors | (tc, (dd, ctors)) <- okTcs] +    decs             = [ makeFDataDecls tce tc dd ctors | (tc, (dd, ctors)) <- okTcs]     (okDecs,badDecs) = checkRegularData decs  isVanillaTc :: (a, (b, [(Ghc.DataCon, c)])) -> Bool-isVanillaTc (_, (_, ctors)) = all (Ghc.isVanillaDataCon . fst) ctors +isVanillaTc (_, (_, ctors)) = all (Ghc.isVanillaDataCon . fst) ctors  checkRegularData :: [F.DataDecl] -> ([F.DataDecl], [F.DataDecl]) checkRegularData ds = (oks, badDs)   where     badDs           = F.checkRegular ds     badSyms         = {- F.notracepp "BAD-Data" . -} S.fromList . fmap F.symbol $ badDs-    oks             = [ d |  d <- ds, not (S.member (F.symbol d) badSyms) ] +    oks             = [ d |  d <- ds, not (S.member (F.symbol d) badSyms) ]  mkWarnDecl :: (F.Loc a, F.Symbolic a) => a -> Warning mkWarnDecl d = mkWarning (GM.fSrcSpan d) ("Non-regular data declaration" <+> pprint (F.symbol d))@@ -265,8 +268,8 @@ -} resolveTyCons :: ModName -> [(ModName, Ghc.TyCon, DataPropDecl)]               -> [(Ghc.TyCon, (ModName, DataPropDecl))]-resolveTyCons m mtds = [(tc, (m, d)) | (tc, mds) <- M.toList tcDecls-                                     , (m, d)    <- Mb.maybeToList $ resolveDecls m tc mds ]+resolveTyCons mn mtds = [(tc, (m, d)) | (tc, mds) <- M.toList tcDecls+                                      , (m, d)    <- Mb.maybeToList $ resolveDecls mn tc mds ]   where     tcDecls          = Misc.group [ (tc, (m, d)) | (m, tc, d) <- mtds ] @@ -339,7 +342,7 @@ makeDataFields tce _c as xts = [ F.DField x (fSort t) | (x, t) <- xts]   where     su    = zip (F.symbol <$> as) [0..]-    fSort = F.substVars su . F.mapFVar (+ (length as)) . RT.rTypeSort tce+    fSort = F.substVars su . F.mapFVar (+ length as) . RT.rTypeSort tce  {-  muSort :: F.FTycon -> Int -> F.Sort -> F.Sort@@ -351,45 +354,82 @@ -}  ---------------------------------------------------------------------------------meetDataConSpec :: Bool -> F.TCEmb Ghc.TyCon -> [(Ghc.Var, SpecType)] -> [DataConP] +meetDataConSpec :: Bool -> F.TCEmb Ghc.TyCon -> [(Ghc.Var, SpecType)] -> [DataConP]                 -> [(Ghc.Var, SpecType)] -------------------------------------------------------------------------------- meetDataConSpec allowTC emb xts dcs  = M.toList $ snd <$> L.foldl' upd dcm0 xts   where-    dcm0                     = M.fromList (dataConSpec' allowTC dcs)+    dcm0                     = M.fromListWith meetM (dataConSpec' allowTC dcs)     upd dcm (x, t)           = M.insert x (Ghc.getSrcSpan x, tx') dcm                                 where                                   tx' = maybe t (meetX x t) (M.lookup x dcm)-    meetX x t (sp', t')      = F.notracepp (_msg x t t') $ meetVarTypes emb (pprint x) (Ghc.getSrcSpan x, t) (sp', t') +    meetM (l,t) (_,t')       = (l, t `F.meet` t')+    meetX x t (sp', t')      = F.notracepp (_msg x t t') $ meetVarTypes emb (pprint x) (Ghc.getSrcSpan x, t) (sp', t')     _msg x t t'              = "MEET-VAR-TYPES: " ++ showpp (x, t, t')  dataConSpec' :: Bool -> [DataConP] -> [(Ghc.Var, (Ghc.SrcSpan, SpecType))]-dataConSpec' allowTC = concatMap tx +dataConSpec' allowTC = concatMap tx   where     tx dcp   =  [ (x, res) | (x, t0) <- dataConPSpecType allowTC dcp-                          , let t    = RT.expandProductType x t0  +                          , let t    = RT.expandProductType x t0                           , let res  = (GM.fSrcSpan dcp, t)                 ] -------------------------------------------------------------------------------- -- | Bare Predicate: DataCon Definitions --------------------------------------- ---------------------------------------------------------------------------------makeConTypes :: ModName -> Bare.Env -> [(ModName, Ms.BareSpec)] +makeConTypes :: ModName -> Bare.Env -> [(ModName, Ms.BareSpec)]              -> Bare.Lookup ([(ModName, TyConP, Maybe DataPropDecl)], [[Located DataConP]]) makeConTypes myName env specs =-  Misc.concatUnzip <$> mapM (makeConTypes' myName env) specs +  Misc.concatUnzip <$> mapM (makeConTypes' myName env) specs -  -makeConTypes' :: ModName -> Bare.Env -> (ModName, Ms.BareSpec) ++makeConTypes' :: ModName -> Bare.Env -> (ModName, Ms.BareSpec)              -> Bare.Lookup ([(ModName, TyConP, Maybe DataPropDecl)], [[Located DataConP]]) makeConTypes' _myName env (name, spec) = do   dcs'   <- canonizeDecls env name dcs-  let gvs = groupVariances dcs' vdcs+  let dcs'' = dataDeclSize spec dcs'+  let gvs = groupVariances dcs'' vdcs   zong <- catLookups . map (uncurry (ofBDataDecl env name)) $ gvs   return (unzip zong)   where-    dcs  = Ms.dataDecls spec -    vdcs = Ms.dvariance spec +    dcs  = Ms.dataDecls spec+    vdcs = Ms.dvariance spec ++type DSizeMap = M.HashMap F.Symbol (F.Symbol, [F.Symbol])+normalizeDSize :: [([LocBareType], F.LocSymbol)] -> DSizeMap+normalizeDSize ds = M.fromList (concatMap go ds)+  where go (ts,x) = let xs = Mb.mapMaybe (getTc . val) ts+                    in [(tc, (val x, xs)) | tc <- xs]+        getTc (RAllT _ t _)  = getTc t+        getTc (RApp c _ _ _) = Just (val $ btc_tc c)+        getTc _ = Nothing++dataDeclSize :: Ms.BareSpec -> [DataDecl] -> [DataDecl]+dataDeclSize spec dcs = makeSize smap <$> dcs+  where smap = normalizeDSize $ Ms.dsize spec+++makeSize :: DSizeMap -> DataDecl -> DataDecl+makeSize smap d+  | Just p <- M.lookup (F.symbol $ tycName d) smap+  = d {tycDCons = fmap (fmap (makeSizeCtor p)) (tycDCons d) }+  | otherwise+   = d++makeSizeCtor :: (F.Symbol, [F.Symbol]) -> DataCtor -> DataCtor+makeSizeCtor (s,xs) d = d {dcFields = Misc.mapSnd (mapBot go) <$> dcFields d}+  where+    go (RApp c ts rs r) | F.symbol c `elem` xs+                        = RApp c ts rs (r `F.meet` rsz)+    go t                = t+    rsz  = MkUReft (F.Reft (F.vv_, F.PAtom F.Lt+                                      (F.EApp (F.EVar s) (F.EVar F.vv_))+                                      (F.EApp (F.EVar s) (F.EVar selfSymbol))+                                      ))+                   mempty++ catLookups :: [Bare.Lookup a] -> Bare.Lookup [a] catLookups = sequence . Mb.mapMaybe skipResolve @@ -401,7 +441,7 @@ isErrResolve ErrResolve {} = True isErrResolve _             =  False -left' :: [e] -> Maybe (Either [e] a)  +left' :: [e] -> Maybe (Either [e] a) left' [] = Nothing left' es = Just (Left es) @@ -412,9 +452,9 @@ --   instead of the unlifted versions.  canonizeDecls :: Bare.Env -> ModName -> [DataDecl] -> Bare.Lookup [DataDecl]-canonizeDecls env name ds = do-  kds <- forM ds $ \d -> do-           k <- dataDeclKey env name d +canonizeDecls env name dataDecls = do+  kds <- forM dataDecls $ \d -> do+           k <- dataDeclKey env name d            return (fmap (, d) k)   case Misc.uniqueByKey' selectDD (Mb.catMaybes kds) of     Left  decls  -> Left [err decls]@@ -428,13 +468,13 @@     err ds@(d:_) = {- uError $ -} errDupSpecs (pprint (tycName d)) (GM.fSrcSpan <$> ds)     err _        = impossible Nothing "canonizeDecls" -dataDeclKey :: Bare.Env -> ModName -> DataDecl -> Bare.Lookup (Maybe F.Symbol) +dataDeclKey :: Bare.Env -> ModName -> DataDecl -> Bare.Lookup (Maybe F.Symbol) dataDeclKey env name d = do   tcMb  <- Bare.lookupGhcDnTyCon env name "canonizeDecls" (tycName d)   case tcMb of-    Nothing -> +    Nothing ->       return Nothing-    Just tc -> do +    Just tc -> do       _ <- checkDataCtors env name tc d (tycDCons d)       return $ Just (F.symbol tc) @@ -460,19 +500,18 @@   -- The data constructors in the spec (which we have to qualify for them to match the GHC data constructors)   mbDcs <- mapM (Bare.failMaybe env name . Bare.lookupGhcDataCon env name "checkDataCtors" . dcName) cons   let rdcs = S.fromList . fmap F.symbol . Mb.catMaybes $ mbDcs-   if dcs == rdcs     then mapM checkDataCtorDupField cons     else Left [errDataConMismatch (dataNameSymbol (tycName dd)) dcs rdcs]  -- | Checks whether the given data constructor has duplicate fields. ---checkDataCtorDupField :: DataCtor -> Bare.Lookup DataCtor -checkDataCtorDupField d -  | x : _ <- dups = Left [err lc x]-  | otherwise     = return d +checkDataCtorDupField :: DataCtor -> Bare.Lookup DataCtor+checkDataCtorDupField d+  | x : _ <- dups = Left [err sym x]+  | otherwise     = return d     where-      lc          = dcName   d +      sym         = dcName   d       xts         = dcFields d       dups        = [ x | (x, ts) <- Misc.groupList xts, 2 <= length ts ]       err lc x    = ErrDupField (GM.sourcePosSrcSpan $ loc lc) (pprint $ val lc) (pprint x)@@ -511,7 +550,7 @@     isGADT        = Ghc.isGadtSyntaxTyCon c  getDnTyCon :: Bare.Env -> ModName -> DataName -> Bare.Lookup Ghc.TyCon-getDnTyCon env name dn = do +getDnTyCon env name dn = do   tcMb <- Bare.lookupGhcDnTyCon env name "ofBDataDecl-1" dn   case tcMb of     Just tc -> return tc@@ -522,7 +561,7 @@ -- FIXME: ES: why the maybes? ofBDataDecl :: Bare.Env -> ModName -> Maybe DataDecl -> Maybe (LocSymbol, [Variance])             -> Bare.Lookup ( (ModName, TyConP, Maybe DataPropDecl), [Located DataConP] )-ofBDataDecl env name (Just dd@(DataDecl tc as ps cts pos sfun pt _)) maybe_invariance_info = do +ofBDataDecl env name (Just dd@(DataDecl tc as ps cts pos sfun pt _)) maybe_invariance_info = do   let Loc lc lc' _ = dataNameSymbol tc   let πs           = Bare.ofBPVar env name pos <$> ps   let αs           = RTV . GM.symbolTyVar <$> as@@ -530,21 +569,21 @@   let initmap      = zip (RT.uPVar <$> πs) [0..]   tc'             <- getDnTyCon env name tc   cts'            <- mapM (ofBDataCtor env name lc lc' tc' αs ps πs) (Mb.fromMaybe [] cts)-  unless (checkDataDecl tc' dd) (Left [err])  -  let pd           = Bare.ofBareType env name lc (Just []) <$> (F.tracepp "ofBDataDecl-prop" pt)+  unless (checkDataDecl tc' dd) (Left [err])+  let pd           = Bare.ofBareType env name lc (Just []) <$> F.tracepp "ofBDataDecl-prop" pt   let tys          = [t | dcp <- cts', (_, t) <- dcpTyArgs dcp]   let varInfo      = L.nub $  concatMap (getPsSig initmap True) tys   let defPs        = varSignToVariance varInfo <$> [0 .. (length πs - 1)]   let (tvi, pvi)   = case maybe_invariance_info of                        Nothing     -> ([], defPs)-                       Just (_,is) -> let is_n = drop n is in +                       Just (_,is) -> let is_n = drop n is in                                       (take n is, if null is_n then defPs else is_n)   let tcp          = TyConP lc tc' αs πs tvi pvi sfun   return ((name, tcp, Just (dd { tycDCons = cts }, pd)), Loc lc lc' <$> cts')   where-    err            = ErrBadData (GM.fSrcSpan tc) (pprint tc) "Mismatch in number of type variables" +    err            = ErrBadData (GM.fSrcSpan tc) (pprint tc) "Mismatch in number of type variables" -ofBDataDecl env name Nothing (Just (tc, is)) =  +ofBDataDecl env name Nothing (Just (tc, is)) =   case Bare.lookupGhcTyCon env name "ofBDataDecl-2" tc of     Left e    -> Left e     Right tc' -> Right ((name, TyConP srcpos tc' [] [] tcov tcontr Nothing, Nothing), [])@@ -556,7 +595,7 @@   = panic Nothing "Bare.DataType.ofBDataDecl called on invalid inputs"  -- TODO:EFFECTS:ofBDataCon-ofBDataCtor :: Bare.Env +ofBDataCtor :: Bare.Env             -> ModName             -> F.SourcePos             -> F.SourcePos@@ -568,29 +607,29 @@             -> Bare.Lookup DataConP ofBDataCtor env name l l' tc αs ps πs dc = do   c' <- Bare.lookupGhcDataCon env name "ofBDataCtor" (dcName dc)-  return (ofBDataCtorTc env name l l' tc αs ps πs dc c') +  return (ofBDataCtorTc env name l l' tc αs ps πs dc c') -ofBDataCtorTc :: Bare.Env -> ModName -> F.SourcePos -> F.SourcePos -> -                 Ghc.TyCon -> [RTyVar] -> [PVar BSort] -> [PVar RSort] -> DataCtor -> Ghc.DataCon -> +ofBDataCtorTc :: Bare.Env -> ModName -> F.SourcePos -> F.SourcePos ->+                 Ghc.TyCon -> [RTyVar] -> [PVar BSort] -> [PVar RSort] -> DataCtor -> Ghc.DataCon ->                  DataConP-ofBDataCtorTc env name l l' tc αs ps πs _ctor@(DataCtor _c as _ xts res) c' = -  DataConP -    { dcpLoc        = l                -    , dcpCon        = c'                -    , dcpFreeTyVars = RT.symbolRTyVar <$> as -    , dcpFreePred   = πs                 -    , dcpTyConstrs  = cs                -    , dcpTyArgs     = zts                 -    , dcpTyRes      = ot                -    , dcpIsGadt     = isGadt                -    , dcpModule     = F.symbol name          +ofBDataCtorTc env name l l' tc αs ps πs _ctor@(DataCtor _c as _ xts res) c' =+  DataConP+    { dcpLoc        = l+    , dcpCon        = c'+    , dcpFreeTyVars = RT.symbolRTyVar <$> as+    , dcpFreePred   = πs+    , dcpTyConstrs  = cs+    , dcpTyArgs     = zts+    , dcpTyRes      = ot+    , dcpIsGadt     = isGadt+    , dcpModule     = F.symbol name     , dcpLocE       = l'-    } +    }   where     ts'           = Bare.ofBareType env name l (Just ps) <$> ts     res'          = Bare.ofBareType env name l (Just ps) <$> res     t0'           = dataConResultTy c' αs t0 res'-    _cfg          = getConfig env +    _cfg          = getConfig env     (yts, ot)     = qualifyDataCtor (not isGadt) name dLoc (zip xs ts', t0')     zts           = zipWith (normalizeField c') [1..] (reverse yts)     usedTvs       = S.fromList (ty_var_value <$> concatMap RT.freeTyVars (t0':ts'))@@ -636,8 +675,8 @@ getPsSigPs m pos (RProp _ t) = getPsSig m pos t  addps :: [(UsedPVar, a)] -> b -> UReft t -> [(a, b)]-addps m pos (MkUReft _ ps) = (flip (,)) pos . f  <$> pvars ps-  where +addps m pos (MkUReft _ ps) = (, pos) . f  <$> pvars ps+  where     f = Mb.fromMaybe (panic Nothing "Bare.addPs: notfound") . (`L.lookup` m) . RT.uPVar  keepPredType :: S.HashSet RTyVar -> SpecType -> Bool@@ -656,7 +695,7 @@                 -> SpecType dataConResultTy c _ _ (Just t) = F.notracepp ("dataConResultTy-3 : vanilla = " ++ show (Ghc.isVanillaDataCon c) ++ " : ") t dataConResultTy c _ t _-  | Ghc.isVanillaDataCon c     = F.notracepp ("dataConResultTy-1 : " ++ F.showpp c) $ t+  | Ghc.isVanillaDataCon c     = F.notracepp ("dataConResultTy-1 : " ++ F.showpp c) t   | otherwise                  = F.notracepp ("dataConResultTy-2 : " ++ F.showpp c) $ RT.ofType ct   where     (_,_,_,_,_,ct)             = Ghc.dataConFullSig c@@ -679,18 +718,18 @@ type CtorType = ([(F.Symbol, SpecType)], SpecType)  qualifyDataCtor :: Bool -> ModName -> F.Located a -> CtorType -> CtorType-qualifyDataCtor qualFlag name l ct@(xts, t)+qualifyDataCtor qualFlag name l ct@(xts, st)  | qualFlag  = (xts', t')  | otherwise = ct  where-   t'        = F.subst su <$> t+   t'        = F.subst su <$> st    xts'      = [ (qx, F.subst su t)       | (qx, t, _) <- fields ]    su        = F.mkSubst [ (x, F.eVar qx) | (qx, _, Just x) <- fields ]    fields    = [ (qx, t, mbX) | (x, t) <- xts, let (mbX, qx) = qualifyField name (F.atLoc l x) ]  qualifyField :: ModName -> LocSymbol -> (Maybe F.Symbol, F.Symbol) qualifyField name lx- | needsQual = (Just x, F.notracepp msg $ qualifyModName name x) + | needsQual = (Just x, F.notracepp msg $ qualifyModName name x)  | otherwise = (Nothing, x)  where    msg       = "QUALIFY-NAME: " ++ show x ++ " in module " ++ show (F.symbol name)@@ -698,18 +737,18 @@    needsQual = not (isWiredIn lx)  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 +checkRecordSelectorSigs vts = [ (v, take1 v lspecTys) | (v, lspecTys) <- Misc.groupList vts ]+  where+    take1 v lsts            = case Misc.nubHashOn (showpp . val) lsts of+                                [t]    -> t                                 (t:ts) -> Ex.throw (ErrDupSpecs (GM.fSrcSpan t) (pprint v) (GM.fSrcSpan <$> ts) :: Error)                                 _      -> impossible Nothing "checkRecordSelectorSigs"   strengthenClassSel :: Ghc.Var -> LocSpecType -> LocSpecType-strengthenClassSel v lt = lt { val = t }+strengthenClassSel v lt = lt { val = st }  where-  t = runReader (go (F.val lt)) (1, [])+  st = runReader (go (F.val lt)) (1, [])   s = GM.namedLocSymbol v   extend :: F.Symbol -> (Int, [F.Symbol]) -> (Int, [F.Symbol])   extend x (i, xs) = (i + 1, x : xs)@@ -717,7 +756,7 @@   go (RAllT a t r) = RAllT a <$> go t <*> pure r   go (RAllP p t  ) = RAllP p <$> go t   go (RFun x i tx t r) | isEmbeddedClass tx =-    RFun <$> pure x <*> return i <*> pure tx <*> go t <*> pure r+    RFun x i tx <$> go t <*> pure r   go (RFun x i tx t r) = do     x' <- unDummy x <$> reader fst     r' <- singletonApp s <$> (L.reverse <$> reader snd)@@ -745,13 +784,13 @@     || 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 ] +    | otherwise+    = [ (v, t) | (Just v, t) <- zip fs ts ]     where       maybe_cls = Ghc.tyConClass_maybe (Ghc.dataConTyCon dc)       dc  = dcpCon dcp       fls = Ghc.dataConFieldLabels dc-      fs  = Bare.lookupGhcNamedVar env name . Ghc.flSelector <$> fls +      fs  = Bare.lookupGhcNamedVar env name . Ghc.flSelector <$> fls       ts :: [ LocSpecType ]       ts = [ Loc l l' (mkArrow (zip (makeRTVar <$> dcpFreeTyVars dcp) (repeat mempty)) []                                  [] [(z, classRFInfo True, res, mempty)]@@ -761,12 +800,12 @@                -- the measure singleton refinement, eg `v = getBar foo`              , let mt = RT.uReft (vv, F.PAtom F.Eq (F.EVar vv) (F.EApp (F.EVar x) (F.EVar z)))              ]-  +       su   = F.mkSubst [ (x, F.EApp (F.EVar x) (F.EVar z)) | x <- fst <$> args ]       args = dcpTyArgs dcp       z    = "lq$recSel"       res  = dropPreds (dcpTyRes dcp)-  +       -- FIXME: this is clearly imprecise, but the preds in the DataConP seem       -- to be malformed. If we leave them in, tests/pos/kmp.hs fails with       -- a malformed predicate application. Niki, help!!
src/Language/Haskell/Liquid/Bare/Elaborate.hs view
@@ -6,6 +6,12 @@ {-# LANGUAGE LambdaCase                #-} {-# LANGUAGE OverloadedStrings         #-} {-# LANGUAGE CPP                       #-}++{-# OPTIONS_GHC -Wno-orphans #-}++{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- TODO(#1913): Fix import of Data.Functor.Foldable.Fix+{-# OPTIONS_GHC -Wno-unused-top-binds #-} -- TODO(#1914): Is RTypeF even used?+ -- | This module uses GHC API to elaborate the resolves expressions  -- TODO: Genearlize to BareType and replace the existing resolution mechanisms@@ -19,8 +25,8 @@  import qualified Language.Fixpoint.Types       as F -- import           Control.Arrow-import           Language.Haskell.Liquid.GHC.API hiding (panic, varName)-import qualified Language.Haskell.Liquid.GHC.Misc+import           Liquid.GHC.API hiding (panic, varName)+import qualified Liquid.GHC.Misc                                                as GM import           Language.Haskell.Liquid.Types.Types import           Language.Haskell.Liquid.Types.RefType@@ -36,34 +42,13 @@ import           Data.Functor.Foldable #endif --- import           TcRnMonad (TcRn) import           Data.Char                      ( isUpper )-#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) import           GHC.Types.Name.Occurrence-#else-import           OccName-#endif--- import           GHC--- import           GhcPlugins                     ( isDFunId---                                                 )---- import           FastString--- import           CoreSyn--- import           PrelNames-import qualified Language.Haskell.Liquid.GHC.API as Ghc+import qualified Liquid.GHC.API as Ghc                                                 (noExtField)---- import qualified Outputable                    as O--- import           TysWiredIn                     ( boolTyCon---                                                 , true_RDR---                                                 )--- import           RdrName--- import           BasicTypes import           Data.Default                   ( def ) import qualified Data.Maybe                    as Mb--- import qualified CoreUtils                     as Utils - -- TODO: make elaboration monadic so typeclass names are unified to something -- that is generated in advance. This can greatly simplify the implementation -- of elaboration@@ -282,22 +267,22 @@ -- | returns (lambda binders, forall binders) collectSpecTypeBinders :: SpecType -> ([F.Symbol], [F.Symbol]) collectSpecTypeBinders = para $ \case-  RFunF bind _ (tin, _) (_, (bs, abs)) _ | isClassType tin -> (bs, abs)-                                       | otherwise       -> (bind : bs, abs)-  RImpFF bind _ (tin, _) (_, (bs, abs)) _ | isClassType tin -> (bs, abs)-                                        | otherwise       -> (bind : bs, abs)-  RAllEF b _ (_, (bs, abs))  -> (b : bs, abs)-  RAllTF (RTVar (RTV ab) _) (_, (bs, abs)) _ -> (bs, F.symbol ab : abs)-  RExF b _ (_, (bs, abs))    -> (b : bs, abs)-  RAppTyF _ (_, (bs, abs)) _ -> (bs, abs)-  RRTyF _ _ _ (_, (bs, abs)) -> (bs, abs)+  RFunF bind _ (tin, _) (_, (bs, abs')) _ | isClassType tin -> (bs, abs')+                                       | otherwise       -> (bind : bs, abs')+  RImpFF bind _ (tin, _) (_, (bs, abs')) _ | isClassType tin -> (bs, abs')+                                        | otherwise       -> (bind : bs, abs')+  RAllEF b _ (_, (bs, abs'))  -> (b : bs, abs')+  RAllTF (RTVar (RTV ab) _) (_, (bs, abs')) _ -> (bs, F.symbol ab : abs')+  RExF b _ (_, (bs, abs'))    -> (b : bs, abs')+  RAppTyF _ (_, (bs, abs')) _ -> (bs, abs')+  RRTyF _ _ _ (_, (bs, abs')) -> (bs, abs')   _                          -> ([], [])  -- really should be fused with collectBinders. However, we need the binders -- to correctly convert fixpoint expressions to ghc expressions because of -- namespace related issues (whether the symbol denotes a varName or a datacon) buildHsExpr :: LHsExpr GhcPs -> SpecType -> LHsExpr GhcPs-buildHsExpr res = para $ \case+buildHsExpr result = para $ \case   RFunF bind _ (tin, _) (_, res) _     | isClassType tin -> res     | otherwise       -> mkHsLam [nlVarPat (varSymbolToRdrName bind)] res@@ -309,7 +294,7 @@   RExF    _ _        (_, res) -> res   RAppTyF _ (_, res) _        -> res   RRTyF _ _ _ (_, res)        -> res-  _                           -> res+  _                           -> result   @@ -504,8 +489,7 @@     -- in the future     RExprArg _ -> impossible Nothing "RExprArg should not appear here"     RHole    _ -> impossible Nothing "RHole should not appear here"-    RRTy _ _ _ _ ->-      todo Nothing ("Not sure how to elaborate RRTy" ++ F.showpp t)+    RRTy{}     -> todo Nothing ("Not sure how to elaborate RRTy" ++ F.showpp t)  where   boolType = RApp (RTyCon boolTyCon [] def) [] [] mempty :: SpecType   elaborateReft@@ -515,7 +499,7 @@     -> ([F.Symbol] -> F.Expr -> TcRn a)     -> TcRn a   elaborateReft (reft@(F.Reft (vv, e)), vvTy) trivial nonTrivialCont =-    if isTrivial reft+    if isTrivial' reft       then trivial       else do         let@@ -531,16 +515,9 @@             buildHsExpr (fixExprToHsExpr (S.fromList origBinders) e)                         querySpecType :: LHsExpr GhcPs           exprWithTySigs = noLoc $ ExprWithTySig-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) && !MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)        -            (mkLHsSigWcType (specTypeToLHsType querySpecType))-            hsExpr-#else             Ghc.noExtField             hsExpr             (mkLHsSigWcType (specTypeToLHsType querySpecType))-#endif-#endif         eeWithLamsCore <- GM.elabRnExpr TM_Inst exprWithTySigs         eeWithLamsCore' <- simplify eeWithLamsCore         let@@ -549,7 +526,7 @@               . ofType               . exprType               $ eeWithLamsCore'-          substTy = zip tyBinders origTyBinders+          substTy' = zip tyBinders origTyBinders           eeWithLams =             coreToLogic (GM.notracePpr "eeWithLamsCore" eeWithLamsCore')           (bs', ee) = F.notracepp "grabLams" $ grabLams ([], eeWithLams)@@ -563,11 +540,11 @@               "Oops, Ghc gave back more/less binders than I expected"         ret <- nonTrivialCont           dictbs-          ( renameBinderCoerc (\x -> Mb.fromMaybe x (L.lookup x substTy))+          ( renameBinderCoerc (\x -> Mb.fromMaybe x (L.lookup x substTy'))           . F.substa (\x -> Mb.fromMaybe x (L.lookup x subst))           $ F.notracepp               (  "elaborated: subst "-              ++ F.showpp substTy+              ++ F.showpp substTy'               ++ "  "               ++ F.showpp                    (ofType $ exprType eeWithLamsCore' :: SpecType)@@ -576,9 +553,9 @@           )  -- (GM.dropModuleUnique <$> bs')         pure (F.notracepp "result" ret)                            -- (F.substa )-  isTrivial :: F.Reft -> Bool-  isTrivial (F.Reft (_, F.PTrue)) = True-  isTrivial _                     = False+  isTrivial' :: F.Reft -> Bool+  isTrivial' (F.Reft (_, F.PTrue)) = True+  isTrivial' _                     = False    grabLams :: ([F.Symbol], F.Expr) -> ([F.Symbol], F.Expr)   grabLams (bs, F.ELam (b, _) e) = grabLams (b : bs, e)@@ -607,7 +584,7 @@   rename (   F.PIff e0 e1      ) = F.PIff (rename e0) (rename e1)   rename (   F.PAtom brel e0 e1) = F.PAtom brel (rename e0) (rename e1)   rename (F.ECoerc _ _ e') = rename e'-    +   rename e = panic     Nothing     ("renameBinderCoerc: Not sure how to handle the expression " ++ F.showpp e)@@ -630,11 +607,7 @@   mkHsTyConApp ::  IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p)-#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)-mkHsTyConApp = nlHsTyConApp -#else mkHsTyConApp tyconId tyargs = nlHsTyConApp Prefix tyconId (map HsValArg tyargs)-#endif  -- | Embed fixpoint expressions into parsed haskell expressions. --   It allows us to bypass the GHC parser and use arbitrary symbols@@ -755,21 +728,14 @@   flip (ghylo (distPara @SpecType) distAna) (fmap pure . project) $ \case     RVarF (RTV tv) _ -> nlHsTyVar       -- (GM.notracePpr ("varRdr" ++ F.showpp (F.symbol tv)) $ getRdrName tv)-      (symbolToRdrNameNs tvName (F.symbol tv)) +      (symbolToRdrNameNs tvName (F.symbol tv))     RFunF _ _ (tin, tin') (_, tout) _       | isClassType tin -> noLoc $ HsQualTy Ghc.noExtField (noLoc [tin']) tout       | otherwise       -> nlHsFunTy tin' tout     RImpFF _ _ (_, tin) (_, tout) _              -> nlHsFunTy tin tout     RAllTF (ty_var_value -> (RTV tv)) (_, t) _ -> noLoc $ HsForAllTy       Ghc.noExtField-#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)-#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)-      ForallInvis-#endif-      [noLoc $ UserTyVar Ghc.noExtField (noLoc $ symbolToRdrNameNs tvName (F.symbol tv))]-#else       (mkHsForAllInvisTele [noLoc $ UserTyVar Ghc.noExtField SpecifiedSpec (noLoc $ symbolToRdrNameNs tvName (F.symbol tv))])-#endif       t     RAllPF _ (_, ty)                    -> ty     RAppF RTyCon { rtc_tc = tc } ts _ _ -> mkHsTyConApp@@ -789,68 +755,3 @@     RHoleF _                 -> noLoc $ HsWildCardTy Ghc.noExtField     RExprArgF _ ->       todo Nothing "Oops, specTypeToLHsType doesn't know how to handle RExprArg"---bareTypeToLHsType :: BareType -> LHsType GhcPs--- surprised that the type application is necessary-bareTypeToLHsType =-  flip (ghylo (distPara @BareType) distAna) (fmap pure . project) $ \case-    RVarF (BTV tv) _ -> nlHsTyVar-      -- (GM.notracePpr ("varRdr" ++ F.showpp (F.symbol tv)) $ getRdrName tv)-      (symbolToRdrNameNs tvName (F.symbol tv)) -    RFunF _ _ (tin, tin') (_, tout) _-      | isClassType tin -> noLoc $ HsQualTy Ghc.noExtField (noLoc [tin']) tout-      | otherwise       -> nlHsFunTy tin' tout-    RImpFF _ _ (_, tin) (_, tout) _              -> nlHsFunTy tin tout-    RAllTF (ty_var_value -> (BTV tv)) (_, t) _ -> noLoc $ HsForAllTy-      Ghc.noExtField-#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)-#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)-      ForallInvis-#endif-      [noLoc $ UserTyVar Ghc.noExtField (noLoc $ symbolToRdrNameNs tvName (F.symbol tv))]-#else-      (mkHsForAllInvisTele [noLoc $ UserTyVar Ghc.noExtField SpecifiedSpec (noLoc $ symbolToRdrNameNs tvName (F.symbol tv))])-#endif-      t-    RAllPF _ (_, ty)                    -> ty-    RAppF BTyCon { btc_tc = tc } ts _ _ -> mkHsTyConApp-      (symbolToRdrNameNs tcName (F.val tc))-      [ hst | (t, hst) <- ts, notExprArg t ]-     where-      notExprArg (RExprArg _) = False-      notExprArg _            = True-    RAllEF _ (_, tin) (_, tout) -> nlHsFunTy tin tout-    RExF   _ (_, tin) (_, tout) -> nlHsFunTy tin tout-    -- impossible-    RAppTyF _ (RExprArg _, _) _ ->-      impossible Nothing "RExprArg should not appear here"-    RAppTyF (_, t) (_, t') _ -> nlHsAppTy t t'-    -- YL: todo..-    RRTyF _ _ _ (_, t)       -> t-    RHoleF _                 -> noLoc $ HsWildCardTy Ghc.noExtField-    RExprArgF _ ->-      todo Nothing "Oops, specTypeToLHsType doesn't know how to handle RExprArg"----- the core expression returned by ghc might be eta-expanded--- we need to do elimination so Pred doesn't contain lambda terms-eliminateEta :: F.Expr -> F.Expr-eliminateEta (F.EApp e0 e1) = F.EApp (eliminateEta e0) (eliminateEta e1)-eliminateEta (F.ENeg e    ) = F.ENeg (eliminateEta e)-eliminateEta (F.EBin bop e0 e1) =-  F.EBin bop (eliminateEta e0) (eliminateEta e1)-eliminateEta (F.EIte e0 e1 e2) =-  F.EIte (eliminateEta e0) (eliminateEta e1) (eliminateEta e2)-eliminateEta (F.ECst e0 s) = F.ECst (eliminateEta e0) s-eliminateEta (F.ELam (x, t) body)-  | F.EApp e0 (F.EVar x') <- ebody, x == x' && notElem x (F.syms e0) = e0-  | otherwise = F.ELam (x, t) ebody-  where ebody = eliminateEta body-eliminateEta (F.PAnd es   ) = F.PAnd (eliminateEta <$> es)-eliminateEta (F.POr  es   ) = F.POr (eliminateEta <$> es)-eliminateEta (F.PNot e    ) = F.PNot (eliminateEta e)-eliminateEta (F.PImp e0 e1) = F.PImp (eliminateEta e0) (eliminateEta e1)-eliminateEta (F.PAtom brel e0 e1) =-  F.PAtom brel (eliminateEta e0) (eliminateEta e1)-eliminateEta e = e
src/Language/Haskell/Liquid/Bare/Expand.hs view
@@ -2,19 +2,16 @@ --   and the pipeline for "cooking" a @BareType@ into a @SpecType@.  --   TODO: _only_ export `makeRTEnv`, `cookSpecType` and maybe `qualifyExpand`... -{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE TypeSynonymInstances  #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE OverloadedStrings     #-} --module Language.Haskell.Liquid.Bare.Expand +module Language.Haskell.Liquid.Bare.Expand   ( -- * Create alias expansion environment-    makeRTEnv +    makeRTEnv      -- * Expand and Qualify -  , qualifyExpand +  , qualifyExpand      -- * Converting BareType to SpecType   , cookSpecType@@ -30,23 +27,23 @@ import Data.Maybe  import           Control.Monad.State+import           Data.Functor ((<&>)) import qualified Control.Exception         as Ex import qualified Data.HashMap.Strict       as M-import qualified Data.HashSet              as S import qualified Data.Char                 as Char import qualified Data.List                 as L-import qualified Text.Printf               as Printf +import qualified Text.Printf               as Printf import qualified Text.PrettyPrint.HughesPJ as PJ -import qualified Language.Fixpoint.Types               as F +import qualified Language.Fixpoint.Types               as F -- import qualified Language.Fixpoint.Types.Visitor       as F -import qualified Language.Fixpoint.Misc                as Misc +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 qualified Liquid.GHC.Misc      as GM+import qualified Liquid.GHC.API       as Ghc+import qualified Language.Haskell.Liquid.Types.RefType as RT import           Language.Haskell.Liquid.Types         hiding (fresh)-import qualified Language.Haskell.Liquid.Misc          as Misc +import qualified Language.Haskell.Liquid.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@@ -56,10 +53,10 @@ -- | `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 :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.ModSpecs -> LogicMap+          -> BareRTEnv ---------------------------------------------------------------------------------makeRTEnv env m mySpec iSpecs lmap +makeRTEnv env modName mySpec iSpecs lmap           = renameRTArgs $ makeRTAliases tAs $ makeREAliases eAs   where     tAs   = [ t                   | (_, s)  <- specs, t <- Ms.aliases  s ]@@ -69,60 +66,60 @@                                               -- this clearly breaks things if a signature                                               -- contains lmap functions but never gets                                               -- elaborated-              else [ specREAlias env m e | (_, xl) <- M.toList (lmSymDefs lmap)+              else [ specREAlias env modName e | (_, xl) <- M.toList (lmSymDefs lmap)                                   , let e    = lmapEAlias xl             ]-    specs = (m, mySpec) : M.toList iSpecs+    specs = (modName, mySpec) : M.toList iSpecs  -- | We apply @renameRTArgs@ *after* expanding each alias-definition, to  --   ensure that the substitutions work properly (i.e. don't miss expressions  --   hidden inside @RExprArg@ or as strange type parameters. -renameRTArgs :: BareRTEnv -> BareRTEnv -renameRTArgs rte = RTE -  { typeAliases = M.map (fmap ( renameTys . renameVV . renameRTVArgs)) (typeAliases rte) -  , exprAliases = M.map (fmap (                        renameRTVArgs)) (exprAliases rte) -  } +renameRTArgs :: BareRTEnv -> BareRTEnv+renameRTArgs rte = RTE+  { typeAliases = M.map (fmap (renameTys . renameVV . renameRTVArgs)) (typeAliases rte)+  , exprAliases = M.map (fmap                         renameRTVArgs) (exprAliases rte)+  } -makeREAliases :: [Located (RTAlias F.Symbol F.Expr)] -> BareRTEnv -makeREAliases = graphExpand buildExprEdges f mempty +makeREAliases :: [Located (RTAlias F.Symbol F.Expr)] -> BareRTEnv+makeREAliases = graphExpand buildExprEdges f mempty   where     f rtEnv xt = setREAlias rtEnv (expandLoc rtEnv xt)   -- | @renameTys@ ensures that @RTAlias@ type parameters have distinct names  --   to avoid variable capture e.g. as in T1556.hs-renameTys :: RTAlias F.Symbol BareType -> RTAlias F.Symbol BareType -renameTys rt = rt { rtTArgs = ys, rtBody = subts (rtBody rt) (zip xs ys) }-  where -    xs    = rtTArgs rt +renameTys :: RTAlias F.Symbol BareType -> RTAlias F.Symbol BareType+renameTys rt = rt { rtTArgs = ys, rtBody = sbts (rtBody rt) (zip xs ys) }+  where+    xs    = rtTArgs rt     ys    = (`F.suffixSymbol` rtName rt) <$> xs-    subts = foldl (flip subt)+    sbts  = foldl (flip subt)  -renameVV :: RTAlias F.Symbol BareType -> RTAlias F.Symbol BareType +renameVV :: RTAlias F.Symbol BareType -> RTAlias F.Symbol BareType renameVV rt = rt { rtBody = RT.shiftVV (rtBody rt) (F.vv (Just 0)) }  -- | @renameRTVArgs@ ensures that @RTAlias@ value parameters have distinct names  --   to avoid variable capture e.g. as in tests-names-pos-Capture01.hs-renameRTVArgs :: (F.PPrint a, F.Subable a) => RTAlias x a -> RTAlias x a +renameRTVArgs :: (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 +                      , 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..]+    su           = F.mkSubst (zip oldArgs (F.eVar <$> newArgs))+    newArgs      = zipWith rtArg (rtVArgs rt) [(0::Int)..]     oldArgs      = rtVArgs rt-    rtArg x i    = F.suffixSymbol x (F.intSymbol "rta" i) +    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 +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 +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  -------------------------------------------------------------------------------------------------------------- @@ -132,22 +129,22 @@             -> thing                                     -- ^ initial             -> [Located (RTAlias x t)]                   -- ^ vertices             -> thing                                     -- ^ final -graphExpand buildEdges expBody env lxts +graphExpand buildEdges expBody env lxts            = L.foldl' expBody env (genExpandOrder table' graph)-  where +  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)  +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 +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)  @@ -167,20 +164,20 @@ type Graph t = [Node t] type Node  t = (t, t, [t]) -buildAliasGraph :: (PPrint t) => (t -> [F.Symbol]) -> [Located (RTAlias x 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) +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 +  where+    a               = val la -checkCyclicAliases :: AliasTable x t -> Graph F.Symbol -> AliasTable x t +checkCyclicAliases :: AliasTable x t -> Graph F.Symbol -> AliasTable x t checkCyclicAliases table graph   = case mapMaybe go (stronglyConnComp graph) of-      []   -> table +      []   -> table       sccs -> Ex.throw (cycleAliasErr table <$> sccs)     where       go (CyclicSCC vs) = Just vs@@ -188,8 +185,8 @@  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 }+cycleAliasErr t symList@(rta:_) = ErrAliasCycle { pos    = fst (locate rta)+                                                , acycle = map locate symList }   where     locate sym = ( GM.fSrcSpan $ fromAliasSymbol t sym                  , pprint sym )@@ -261,8 +258,8 @@ ---------------------------------------------------------------------------------- -- | Using the `BareRTEnv` to do alias-expansion  -----------------------------------------------------------------------------------class Expand a where -  expand :: BareRTEnv -> F.SourcePos -> a -> a +class Expand a where+  expand :: BareRTEnv -> F.SourcePos -> a -> a  ---------------------------------------------------------------------------------- -- | @qualifyExpand@ first qualifies names so that we can successfully resolve them during expansion.@@ -284,11 +281,11 @@     qualifiedRTEnv = rtEnv { typeAliases = M.map (Bare.qualify env name l bs) (typeAliases rtEnv) }  -----------------------------------------------------------------------------------expandLoc :: (Expand a) => BareRTEnv -> Located a -> Located a -expandLoc rtEnv lx = expand rtEnv (F.loc lx) <$> lx +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 Expr where+  expand = expandExpr  instance Expand F.Reft where   expand rtEnv l (F.Reft (v, ra)) = F.Reft (v, expand rtEnv l ra)@@ -296,7 +293,7 @@ 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 :: (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) @@ -308,68 +305,68 @@ --   3. stuff from @LogicMap@  instance Expand SpecType where-  expand = expandReft +  expand = expandReft  -- | @expand@ on a BareType actually applies the type- and expression- aliases.-instance Expand BareType where +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 (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 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) +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 +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 ] +    { 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 ++instance Expand DataDecl where+  expand rtEnv l d = d     { tycDCons  = expand rtEnv l (tycDCons  d)-    , tycPropTy = expand rtEnv l (tycPropTy d) -    } +    , tycPropTy = expand rtEnv l (tycPropTy d)+    } -instance Expand BareMeasure where -  expand rtEnv l m = m -    { msSort = expand rtEnv l (msSort m) +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 BareDef where+  expand rtEnv l d = d+    { dsort = expand rtEnv l (dsort d)+    , binds = [ (x, expand rtEnv l t) | (x, t) <- binds d]+    , body  = expand rtEnv l (body  d)+    }  instance Expand Ms.BareSpec where   expand = expandBareSpec -instance Expand a => Expand (F.Located a) where -  expand rtEnv _ = expandLoc rtEnv +instance Expand a => Expand (F.Located a) where+  expand rtEnv _ = expandLoc rtEnv -instance Expand a => Expand (F.LocSymbol, a) where +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 (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 [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) +instance Expand a => Expand (M.HashMap k a) where+  expand rtEnv l = fmap (expand rtEnv l)  -- | Expands a 'BareSpec'. expandBareSpec :: BareRTEnv -> F.SourcePos -> Ms.BareSpec -> Ms.BareSpec@@ -385,32 +382,32 @@   }   where f      = expand rtEnv l -expandBareType :: BareRTEnv -> F.SourcePos -> BareType -> BareType -expandBareType rtEnv _ = go +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 (RApp c ts rs r)  = case lookupRTEnv c rtEnv of+                             Just rta -> expandRTAliasApp (GM.fSourcePos c) rta (go <$> ts) r+                             Nothing  -> RApp c (go <$> ts) (goRef <$> rs) r     go (RAppTy t1 t2 r)  = RAppTy (go t1) (go t2) r-    go (RImpF x i t1 t2 r) = RImpF x i (go t1) (go t2) r -    go (RFun  x i t1 t2 r) = RFun  x i (go t1) (go t2) r +    go (RImpF x i t1 t2 r) = RImpF x i (go t1) (go t2) r+    go (RFun  x i t1 t2 r) = RFun  x i (go t1) (go t2) r     go (RAllT a t r)     = RAllT a (go t) r-    go (RAllP a t)       = RAllP a (go t) +    go (RAllP a t)       = RAllP a (go t)     go (RAllE x t1 t2)   = RAllE x (go t1) (go t2)     go (REx x t1 t2)     = REx   x (go t1) (go t2)     go (RRTy e r o t)    = RRTy  e r o     (go t)-    go t@(RHole {})      = t -    go t@(RVar {})       = t -    go t@(RExprArg {})   = t +    go t@RHole{}         = t+    go t@RVar{}          = t+    go t@RExprArg{}      = t     goRef (RProp ss t)   = RProp ss (go t)  lookupRTEnv :: BTyCon -> BareRTEnv -> Maybe (Located BareRTAlias) lookupRTEnv c rtEnv = M.lookup (F.symbol c) (typeAliases rtEnv) -expandRTAliasApp :: F.SourcePos -> Located BareRTAlias -> [BareType] -> RReft -> BareType -expandRTAliasApp l (Loc la _ rta) args r = case isOK of +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+  Nothing    -> F.subst esu . (`RT.strengthen` r) . RT.subsTyVarsMeet tsu $ rtBody rta   where     tsu       = zipWith (\α t -> (α, toRSort t, t)) αs ts     esu       = F.mkSubst $ zip (F.symbol <$> εs) es@@ -423,32 +420,32 @@     -- ERROR Checking Code     msg       = "EXPAND-RTALIAS-APP: " ++ F.showpp (rtName rta)     nαs       = length αs-    nεs       = length εs -    nargs     = length args +    nεs       = length εs+    nargs     = length args     ntargs    = length targs     neargs    = length eargs-    err       = errRTAliasApp l la rta +    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]+      = 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 +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 +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 +    sp'             = GM.sourcePosSrcSpan la   @@ -464,8 +461,8 @@ --   `exprArg` converts that `BareType` into an `Expr`. -------------------------------------------------------------------------------- exprArg :: F.SourcePos -> String -> BareType -> Expr-exprArg l msg = F.notracepp ("exprArg: " ++ msg) . go -  where +exprArg l msg = F.notracepp ("exprArg: " ++ msg) . go+  where     go :: BareType -> Expr     go (RExprArg e)     = val e     go (RVar x _)       = EVar (F.symbol x)@@ -481,36 +478,33 @@ --   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 :: 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 +  where     _msg = "cookSpecType: " ++ GM.showPpr (z, Ghc.varType <$> z)-    z    = Bare.plugSrc x +    z    = Bare.plugSrc x   ------------------------------------------------------------------------------------------cookSpecTypeE :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.PlugTV Ghc.Var -> LocBareType -              -> Bare.Lookup LocSpecType +cookSpecTypeE :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.PlugTV Ghc.Var -> LocBareType+              -> Bare.Lookup LocSpecType ----------------------------------------------------------------------------------------- cookSpecTypeE env sigEnv name@(ModName _ _) x bt-  = id-  . fmap (if doplug || not allowTC then plugHoles allowTC sigEnv name x else id) -  . 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 (if doplug || not allowTC then maybePlug allowTC  sigEnv name x else id)-  -- we do not qualify/resolve Expr/Pred when typeclass is enabled-  -- since ghci will not be able to recognize fully qualified names-  -- instead, we leave qualification to ghc elaboration-  . fmap (Bare.qualifyTop env name l )-  . bareSpecType       env name -  . bareExpandType     rtEnv-  $ bt +  = fmap f . bareSpecType env name $ bareExpandType rtEnv bt   where+    f = (if doplug || not allowTC then plugHoles allowTC sigEnv name x else id)+        . fmap (addTyConInfo embs tyi)+        . Bare.txRefSort tyi embs+        . fmap txExpToBind -- What does this function DO+        . (specExpandType rtEnv . fmap (generalizeWith x))+        . (if doplug || not allowTC then maybePlug allowTC sigEnv name x else id)+        -- we do not qualify/resolve Expr/Pred when typeclass is enabled+        -- since ghci will not be able to recognize fully qualified names+        -- instead, we leave qualification to ghc elaboration+        . Bare.qualifyTop env name l+     allowTC = typeclass (getConfig env)     -- modT   = mname `S.member` wiredInMods     doplug@@ -522,24 +516,24 @@       = True     _msg i = "cook-" ++ show i ++ " : " ++ F.showpp x     rtEnv  = Bare.sigRTEnv    sigEnv-    embs   = Bare.sigEmbs     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 +generalizeWith :: Bare.PlugTV Ghc.Var -> SpecType -> SpecType+generalizeWith (Bare.HsTV v) t = generalizeVar v t+generalizeWith  Bare.RawTV   t = t+generalizeWith _             t = RT.generalize t -generalizeVar :: Ghc.Var -> SpecType -> SpecType -generalizeVar v t = mkUnivs (zip as (repeat mempty)) [] t -  where +generalizeVar :: Ghc.Var -> SpecType -> SpecType+generalizeVar v t = mkUnivs (zip as (repeat mempty)) [] t+  where     as            = filter isGen (freeTyVars t)-    (vas,_)       = Ghc.splitForAllTys (GM.expandVarType v) -    isGen (RTVar (RTV a) _) = a `elem` vas +    (vas,_)       = Ghc.splitForAllTys (GM.expandVarType v)+    isGen (RTVar (RTV a) _) = a `elem` vas  -- splitForAllTys :: Type -> ([TyVar], Type) -- @@ -547,28 +541,28 @@ -- generalize t = mkUnivs (freeTyVars t) [] [] t   -bareExpandType :: BareRTEnv -> LocBareType -> LocBareType -bareExpandType = expandLoc +bareExpandType :: BareRTEnv -> LocBareType -> LocBareType+bareExpandType = expandLoc  specExpandType :: BareRTEnv -> LocSpecType -> LocSpecType-specExpandType = expandLoc +specExpandType = expandLoc -bareSpecType :: Bare.Env -> ModName -> LocBareType -> Bare.Lookup LocSpecType -bareSpecType env name bt = case Bare.ofBareTypeE env name (F.loc bt) Nothing (val bt) of -  Left e  -> Left e +bareSpecType :: Bare.Env -> ModName -> LocBareType -> Bare.Lookup LocSpecType+bareSpecType env name bt = case Bare.ofBareTypeE env name (F.loc bt) Nothing (val bt) of+  Left e  -> Left e   Right t -> Right (F.atLoc bt t) -maybePlug :: Bool -> Bare.SigEnv -> ModName -> Bare.PlugTV Ghc.Var -> LocSpecType -> LocSpecType -maybePlug allowTC sigEnv name kx = case Bare.plugSrc kx of -                             Nothing -> id  -                             Just _  -> plugHoles allowTC sigEnv name kx +maybePlug :: Bool -> Bare.SigEnv -> ModName -> Bare.PlugTV Ghc.Var -> LocSpecType -> LocSpecType+maybePlug allowTC sigEnv name kx = case Bare.plugSrc kx of+                             Nothing -> id+                             Just _  -> plugHoles allowTC sigEnv name kx -plugHoles :: Bool -> Bare.SigEnv -> ModName -> Bare.PlugTV Ghc.Var -> LocSpecType -> LocSpecType +plugHoles :: Bool -> Bare.SigEnv -> ModName -> Bare.PlugTV Ghc.Var -> LocSpecType -> LocSpecType plugHoles allowTC sigEnv name = Bare.makePluggedSig allowTC name embs tyi exports-  where -    embs              = Bare.sigEmbs     sigEnv -    tyi               = Bare.sigTyRTyMap sigEnv -    exports           = Bare.sigExports  sigEnv +  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. @@ -628,7 +622,7 @@     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 (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)@@ -636,8 +630,8 @@     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 (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)@@ -679,7 +673,7 @@   where     re              = F.val lre     args            = F.mkSubst <$> Misc.zipMaybe (rtVArgs re) es-    err             :: UserError +    err             :: UserError     err             = ErrAliasApp sp alias sp' msg     sp              = GM.sourcePosSrcSpan l     alias           = pprint           (rtName re)@@ -695,7 +689,7 @@ txExpToBind   :: SpecType -> SpecType ------------------------------------------------------------------------------- txExpToBind t = evalState (expToBindT t) (ExSt 0 M.empty πs)-  where +  where     πs        = M.fromList [(pname p, p) | p <- ty_preds $ toRTypeRep t ]  data ExSt = ExSt { fresh :: Int@@ -714,10 +708,10 @@        t2' <- expToBindT t2        expToBindRef r >>= addExists . RFun x i t1' t2' expToBindT (RAllT a t r)-  = do t' <- expToBindT t -       expToBindRef r >>= addExists . RAllT a t' +  = do t' <- expToBindT t+       expToBindRef r >>= addExists . RAllT a t' expToBindT (RAllP p t)-  = liftM (RAllP p) (expToBindT t)+  = fmap (RAllP p) (expToBindT t) expToBindT (RApp c ts rs r)   = do ts' <- mapM expToBindT ts        rs' <- mapM expToBindReft rs@@ -743,39 +737,39 @@  getBinds :: State ExSt (M.HashMap F.Symbol (RSort, F.Expr)) getBinds-  = do bds <- emap <$> get+  = do bds <- gets emap        modify $ \st -> st{emap = M.empty}        return bds  addExists :: SpecType -> State ExSt SpecType-addExists t = liftM (M.foldlWithKey' addExist t) getBinds+addExists t = fmap (M.foldlWithKey' addExist t) getBinds  addExist :: SpecType -> F.Symbol -> (RSort, F.Expr) -> SpecType addExist t x (tx, e) = REx x t' t-  where -    t'               = (ofRSort tx) `strengthen` uTop r+  where+    t'               = ofRSort tx `strengthen` uTop r     r                = F.exprReft e  expToBindRef :: UReft r -> State ExSt (UReft r) expToBindRef (MkUReft r (Pr p))-  = mapM expToBind p >>= return . (MkUReft r) . Pr+  = mapM expToBind p <&> (MkUReft r . 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) +expToBind p = do+  res <- gets (M.lookup (pname p) . pmap)+  case res of+    Nothing ->+      panic Nothing ("expToBind: " ++ show p)     Just π  -> do       let pargs0 = zip (pargs p) (Misc.fst3 <$> pargs π)       pargs' <- mapM expToBindParg pargs0       return $ p { pargs = pargs' }  expToBindParg :: (((), F.Symbol, F.Expr), RSort) -> State ExSt ((), F.Symbol, F.Expr)-expToBindParg ((t, s, e), s') = liftM ((,,) t s) (expToBindExpr e s')+expToBindParg ((t, s, e), s') = fmap ((,,) t s) (expToBindExpr e s')  expToBindExpr :: F.Expr ->  RSort -> State ExSt F.Expr-expToBindExpr e@(EVar s) _ +expToBindExpr e@(EVar s) _   | Char.isLower $ F.headSym $ F.symbol s   = return e expToBindExpr e t@@ -785,7 +779,7 @@  freshSymbol :: State ExSt F.Symbol freshSymbol-  = do n <- fresh <$> get+  = do n <- gets fresh        modify $ \s -> s {fresh = n+1}        return $ F.symbol $ "ex#" ++ show n
src/Language/Haskell/Liquid/Bare/Laws.hs view
@@ -3,52 +3,52 @@ import qualified Data.Maybe                                 as Mb import qualified Data.List                                  as L import qualified Data.HashMap.Strict                        as M-import           Control.Monad (join)+import           Control.Monad ((<=<))  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 qualified Liquid.GHC.Misc           as GM+import           Language.Haskell.Liquid.Bare.Types         as Bare import           Language.Haskell.Liquid.Bare.Resolve       as Bare import           Language.Haskell.Liquid.Bare.Expand        as Bare import           Language.Haskell.Liquid.Types-import           Language.Haskell.Liquid.GHC.API            +import           Liquid.GHC.API   -makeInstanceLaws :: Bare.Env -> Bare.SigEnv -> [(Var,LocSpecType)] +makeInstanceLaws :: Bare.Env -> Bare.SigEnv -> [(Var,LocSpecType)]                 -> Bare.ModSpecs -> [LawInstance]-makeInstanceLaws env sigEnv sigs specs -  = [makeInstanceLaw env sigEnv sigs name rilaw +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  +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 +  , liSupers  = mkTy <$> rilSupers rilaw   , lilTyArgs = mkTy <$> rilTyArgs rilaw-  , lilEqus   = [(mkVar l, mkTypedVar r) | (l,r)<- rilEqus rilaw ]  +  , lilEqus   = [(mkVar l, mkTypedVar r) | (l,r)<- rilEqus rilaw ]   , lilPos    = GM.sourcePosSrcSpan $ loc $ rilPos rilaw-  } +  }   where-    tc    :: Maybe Class +    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  +    classTc = tyConClass_maybe <=< (Bare.maybeResolveSym env name "makeClass" . btc_tc)      mkTy :: LocBareType -> LocSpecType-    mkTy = Bare.cookSpecType env sigEnv name Bare.GenTV -    mkVar :: LocSymbol -> VarOrLocSymbol -    mkVar x = case Bare.maybeResolveSym env name "makeInstanceLaw" x of -                Just v -> Left v -                _      -> Right x +    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 +    mkTypedVar l = case mkVar l of                      Left x -> (Left x, Just $ Mb.fromMaybe (dummyLoc $ ofType $ varType x) (L.lookup x sigs))                      Right x -> (Right x, Nothing)
src/Language/Haskell/Liquid/Bare/Measure.hs view
@@ -34,95 +34,95 @@ 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 Liquid.GHC.API       as Ghc+import qualified Liquid.GHC.Misc      as GM import qualified Language.Haskell.Liquid.Types.RefType as RT import           Language.Haskell.Liquid.Types -- import           Language.Haskell.Liquid.Types.Bounds import qualified Language.Haskell.Liquid.Measure       as Ms -import qualified Language.Haskell.Liquid.Bare.Types    as Bare -import qualified Language.Haskell.Liquid.Bare.Resolve  as Bare -import qualified Language.Haskell.Liquid.Bare.Expand   as Bare -import qualified Language.Haskell.Liquid.Bare.DataType as Bare -import qualified Language.Haskell.Liquid.Bare.ToBare   as Bare +import qualified Language.Haskell.Liquid.Bare.Types    as Bare+import qualified Language.Haskell.Liquid.Bare.Resolve  as Bare+import qualified Language.Haskell.Liquid.Bare.Expand   as Bare+import qualified Language.Haskell.Liquid.Bare.DataType as Bare+import qualified Language.Haskell.Liquid.Bare.ToBare   as Bare import Control.Monad (mapM)  -------------------------------------------------------------------------------- makeHaskellMeasures :: Bool -> GhcSrc -> Bare.TycEnv -> LogicMap -> Ms.BareSpec                     -> [Measure (Located BareType) LocSymbol] ---------------------------------------------------------------------------------makeHaskellMeasures allowTC src tycEnv lmap spec +makeHaskellMeasures allowTC src tycEnv lmap spec           = Bare.measureToBare <$> ms-  where -    ms    = makeMeasureDefinition allowTC tycEnv lmap cbs <$> mSyms -    cbs   = nonRecCoreBinds   (_giCbs src) +  where+    ms    = makeMeasureDefinition allowTC tycEnv lmap cbs <$> mSyms+    cbs   = nonRecCoreBinds   (_giCbs src)     mSyms = S.toList (Ms.hmeas spec)-  -makeMeasureDefinition :: Bool -> Bare.TycEnv -> LogicMap -> [Ghc.CoreBind] -> LocSymbol ++makeMeasureDefinition :: Bool -> Bare.TycEnv -> LogicMap -> [Ghc.CoreBind] -> LocSymbol                       -> Measure LocSpecType Ghc.DataCon-makeMeasureDefinition allowTC tycEnv lmap cbs x = +makeMeasureDefinition allowTC tycEnv lmap cbs x =   case GM.findVarDef (val x) cbs of-    Nothing       -> Ex.throw $ errHMeas x "Cannot extract measure from haskell function"-    Just (v, def) -> Ms.mkM vx vinfo mdef MsLifted (makeUnSorted allowTC (Ghc.varType v) mdef) -                     where +    Nothing        -> Ex.throw $ errHMeas x "Cannot extract measure from haskell function"+    Just (v, cexp) -> Ms.mkM vx vinfo mdef MsLifted (makeUnSorted allowTC (Ghc.varType v) mdef)+                     where                        vx           = F.atLoc x (F.symbol v)-                       mdef         = coreToDef' allowTC tycEnv lmap vx v def+                       mdef         = coreToDef' allowTC tycEnv lmap vx v cexp                        vinfo        = GM.varLocInfo (logicType allowTC) v  makeUnSorted :: Bool -> Ghc.Type -> [Def LocSpecType Ghc.DataCon] -> UnSortedExprs-makeUnSorted allowTC t defs-  | isMeasureType ta +makeUnSorted allowTC ty defs+  | isMeasureType ta   = mempty   | otherwise   = map defToUnSortedExpr defs   where-    ta = go $ Ghc.expandTypeSynonyms t+    ta = go $ Ghc.expandTypeSynonyms ty -    go (Ghc.ForAllTy _ t) = go t -    go (Ghc.FunTy { Ghc.ft_arg = p, Ghc.ft_res = t}) | isErasable p = go t -    go (Ghc.FunTy { Ghc.ft_arg = t }) = t +    go (Ghc.ForAllTy _ t) = go t+    go Ghc.FunTy{ Ghc.ft_arg = p, Ghc.ft_res = t} | isErasable p = go t+    go Ghc.FunTy{ Ghc.ft_arg = t } = t     go t                  = t -- this should never happen!      isMeasureType (Ghc.TyConApp _ ts) = all Ghc.isTyVarTy ts-    isMeasureType _                   = False  +    isMeasureType _                   = False -    defToUnSortedExpr def = (xx:(fst <$> binds def), -                             Ms.bodyPred (F.mkEApp (measure def) [F.expr xx]) (body def)) +    defToUnSortedExpr defn = (xx:(fst <$> binds defn),+                             Ms.bodyPred (F.mkEApp (measure defn) [F.expr xx]) (body defn))      xx = F.vv $ Just 10000     isErasable = if allowTC then GM.isEmbeddedDictType else Ghc.isClassPred -coreToDef' :: Bool -> Bare.TycEnv -> LogicMap -> LocSymbol -> Ghc.Var -> Ghc.CoreExpr -           -> [Def LocSpecType Ghc.DataCon] -coreToDef' allowTC tycEnv lmap vx v def = -  case runToLogic embs lmap dm (errHMeas vx) (coreToDef allowTC vx v def) of+coreToDef' :: Bool -> Bare.TycEnv -> LogicMap -> LocSymbol -> Ghc.Var -> Ghc.CoreExpr+           -> [Def LocSpecType Ghc.DataCon]+coreToDef' allowTC tycEnv lmap vx v defn =+  case runToLogic embs lmap dm (errHMeas vx) (coreToDef allowTC vx v defn) of     Right l -> l     Left e  -> Ex.throw e-  where -    embs    = Bare.tcEmbs       tycEnv -    dm      = Bare.tcDataConMap tycEnv  +  where+    embs    = Bare.tcEmbs       tycEnv+    dm      = Bare.tcDataConMap tycEnv  errHMeas :: LocSymbol -> String -> Error errHMeas x str = ErrHMeas (GM.sourcePosSrcSpan $ loc x) (pprint $ val x) (text str)  ---------------------------------------------------------------------------------makeHaskellInlines :: Bool -> GhcSrc -> F.TCEmb Ghc.TyCon -> LogicMap -> Ms.BareSpec +makeHaskellInlines :: Bool -> GhcSrc -> F.TCEmb Ghc.TyCon -> LogicMap -> Ms.BareSpec                    -> [(LocSymbol, LMap)] ---------------------------------------------------------------------------------makeHaskellInlines allowTC src embs lmap spec -         = makeMeasureInline allowTC embs lmap cbs <$> inls +makeHaskellInlines allowTC src embs lmap spec+         = makeMeasureInline allowTC embs lmap cbs <$> inls   where-    cbs  = nonRecCoreBinds (_giCbs src) +    cbs  = nonRecCoreBinds (_giCbs src)     inls = S.toList        (Ms.inlines spec)  makeMeasureInline :: Bool -> F.TCEmb Ghc.TyCon -> LogicMap -> [Ghc.CoreBind] -> LocSymbol                   -> (LocSymbol, LMap)-makeMeasureInline allowTC embs lmap cbs x = -  case GM.findVarDef (val x) cbs of -    Nothing       -> Ex.throw $ errHMeas x "Cannot inline haskell function"-    Just (v, def) -> (vx, coreToFun' allowTC embs Nothing lmap vx v def ok)-                     where +makeMeasureInline allowTC embs lmap cbs x =+  case GM.findVarDef (val x) cbs of+    Nothing        -> Ex.throw $ errHMeas x "Cannot inline haskell function"+    Just (v, defn) -> (vx, coreToFun' allowTC embs Nothing lmap vx v defn ok)+                     where                        vx         = F.atLoc x (F.symbol v)                        ok (xs, e) = LMap vx (F.symbol <$> xs) (either id id e) @@ -133,26 +133,27 @@  coreToFun' :: Bool -> F.TCEmb Ghc.TyCon -> Maybe Bare.DataConMap -> LogicMap -> LocSymbol -> Ghc.Var -> Ghc.CoreExpr            -> (([Ghc.Var], Either F.Expr F.Expr) -> a) -> a-coreToFun' allowTC embs dmMb lmap x v def ok = either Ex.throw ok act -  where -    act  = runToLogic embs lmap dm err xFun -    xFun = coreToFun allowTC x v def  -    err  = errHMeas x  -    dm   = Mb.fromMaybe mempty dmMb +coreToFun' allowTC embs dmMb lmap x v defn ok = either Ex.throw ok act+  where+    act  = runToLogic embs lmap dm err xFun+    xFun = coreToFun allowTC x v defn+    err  = errHMeas x+    dm   = Mb.fromMaybe mempty dmMb   nonRecCoreBinds :: [Ghc.CoreBind] -> [Ghc.CoreBind]-nonRecCoreBinds            = concatMap go -  where +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] +makeHaskellDataDecls :: Config -> ModName -> Ms.BareSpec -> [Ghc.TyCon]                      -> [DataDecl] -------------------------------------------------------------------------------- makeHaskellDataDecls cfg name spec tcs-  | exactDCFlag cfg = Mb.mapMaybe tyConDataDecl+  | exactDCFlag cfg = Bare.dataDeclSize spec+                    . Mb.mapMaybe tyConDataDecl                     -- . F.tracepp "makeHaskellDataDecls-3"                     . zipMap   (hasDataDecl name spec . fst)                     -- . F.tracepp "makeHaskellDataDecls-2"@@ -167,7 +168,7 @@ isReflectableTyCon  = Ghc.isFamInstTyCon .||. Ghc.isVanillaAlgTyCon  liftableTyCons :: [Ghc.TyCon] -> [(Ghc.TyCon, DataName)]-liftableTyCons +liftableTyCons   = F.notracepp "LiftableTCs 3"   . zipMapMaybe (tyConDataName True)   . F.notracepp "LiftableTCs 2"@@ -183,25 +184,25 @@ zipMapMaybe f = Mb.mapMaybe (\x -> (x, ) <$> f x)  hasDataDecl :: ModName -> Ms.BareSpec -> Ghc.TyCon -> HasDataDecl-hasDataDecl mod spec-                 = \tc -> F.notracepp (msg tc) $ M.lookupDefault def (tcName tc) decls+hasDataDecl modName spec+                 = \tc -> F.notracepp (msg tc) $ M.lookupDefault defn (tcName tc) decls   where     msg tc       = "hasDataDecl " ++ show (tcName tc)-    def          = NoDecl Nothing-    tcName       = fmap (qualifiedDataName mod) . tyConDataName True-    dcName       =       qualifiedDataName mod  . tycName+    defn         = NoDecl Nothing+    tcName       = fmap (qualifiedDataName modName) . tyConDataName True+    dcName       =       qualifiedDataName modName  . tycName     decls        = M.fromList [ (Just dn, hasDecl d)                                 | d     <- Ms.dataDecls spec                                 , let dn = dcName d]  qualifiedDataName :: ModName -> DataName -> DataName-qualifiedDataName mod (DnName lx) = DnName (qualifyModName mod <$> lx)-qualifiedDataName mod (DnCon  lx) = DnCon  (qualifyModName mod <$> lx)+qualifiedDataName modName (DnName lx) = DnName (qualifyModName modName <$> lx)+qualifiedDataName modName (DnCon  lx) = DnCon  (qualifyModName modName <$> lx)  {-tyConDataDecl :: {tc:TyCon | isAlgTyCon tc} -> Maybe DataDecl @-} tyConDataDecl :: ((Ghc.TyCon, DataName), HasDataDecl) -> Maybe DataDecl tyConDataDecl (_, HasDecl)-  = Nothing +  = Nothing tyConDataDecl ((tc, dn), NoDecl szF)   = Just $ DataDecl       { tycName   = dn@@ -217,8 +218,8 @@  tyConDataName :: Bool -> Ghc.TyCon -> Maybe DataName tyConDataName full tc-  | vanillaTc  = Just (DnName ((post . F.symbol) <$> GM.locNamedThing tc))-  | d:_ <- dcs = Just (DnCon  ((post . F.symbol) <$> GM.locNamedThing d ))+  | 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@@ -233,11 +234,11 @@     xts           = [(Bare.makeDataConSelector Nothing d i, RT.bareOfType t) | (i, t) <- its ]     dx            = F.symbol <$> GM.locNamedThing d     its           = zip [1..] ts-    (as,_ps,ts,t)  = Ghc.dataConSig d-    outT          = Just (RT.bareOfType t :: BareType) +    (as,_ps,ts,ty)  = Ghc.dataConSig d+    outT          = Just (RT.bareOfType ty :: BareType)     _outT :: Maybe BareType     _outT-      | isGadt    = Just (RT.bareOfType t)+      | isGadt    = Just (RT.bareOfType ty)       | otherwise = Nothing  @@ -251,13 +252,13 @@  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.+  = Misc.condNull (exactDCFlag cfg) (checker : Mb.mapMaybe go' fields) --  internal measures, needed for reflection+ ++ Misc.condNull autofields (Mb.mapMaybe go fields) --  user-visible measures.   where-    dc         = dcpCon    c -    isGadt     = dcpIsGadt c +    dc         = dcpCon    c+    isGadt     = dcpIsGadt c     xts        = dcpTyArgs c-    autofields = not (isGadt)+    autofields = not isGadt     go ((x, t), i)       -- do not make selectors for functional fields       | isFunTy t && not (higherOrderFlag cfg)@@ -292,18 +293,18 @@  -- bkDataCon :: DataCon -> Int -> ([RTVar RTyVar RSort], [SpecType], (Symbol, SpecType, RReft)) bkDataCon :: (F.Reftable (RTProp RTyCon RTyVar r), PPrint r, F.Reftable r) => Bool -> Ghc.DataCon -> Int -> ([RTVar RTyVar RSort], [RRType r], (F.Symbol, RFInfo, RRType r, r))-bkDataCon permitTC dc nFlds  = (as, ts, (F.dummySymbol, classRFInfo permitTC, t, mempty))+bkDataCon permitTC dcn nFlds  = (as, ts, (F.dummySymbol, classRFInfo permitTC, t, mempty))   where     ts                = RT.ofType <$> Misc.takeLast nFlds (map Ghc.irrelevantMult _ts)     t                 = -- Misc.traceShow ("bkDataConResult" ++ GM.showPpr (dc, _t, _t0)) $                           RT.ofType  $ Ghc.mkTyConApp tc tArgs'     as                = makeRTVar . RT.rTyVar <$> (αs ++ αs')-    ((αs,αs',_,_,_ts,_t), _t0) = hammer dc+    ((αs,αs',_,_,_ts,_t), _t0) = hammer dcn     tArgs'            = take (nArgs - nVars) tArgs ++ (Ghc.mkTyVarTy <$> αs)     nVars             = length αs     nArgs             = length tArgs     (tc, tArgs)       = Mb.fromMaybe err (Ghc.splitTyConApp_maybe _t)-    err               = GM.namedPanic dc ("Cannot split result type of DataCon " ++ show dc)+    err               = GM.namedPanic dcn ("Cannot split result type of DataCon " ++ show dcn)     hammer dc         = (Ghc.dataConFullSig dc, Ghc.varType . Ghc.dataConWorkId $ dc)  data DataConSel = Check | Proj Int@@ -324,15 +325,15 @@ makeMeasureSelector x s dc n i = M { msName = x, msSort = s, msEqns = [eqn], msKind = MsSelector, msUnSorted = mempty}   where     eqn                        = Def x dc Nothing args (E (F.EVar $ mkx i))-    args                       = ((, Nothing) . mkx) <$> [1 .. n]+    args                       = (, Nothing) . mkx <$> [1 .. n]     mkx j                      = F.symbol ("xx" ++ show j)  makeMeasureChecker :: LocSymbol -> SpecType -> Ghc.DataCon -> Int -> Measure SpecType Ghc.DataCon makeMeasureChecker x s0 dc n = M { msName = x, msSort = s, msEqns = eqn : (eqns <$> filter (/= dc) dcs), msKind = MsChecker, msUnSorted = mempty }   where     s       = F.notracepp ("makeMeasureChecker: " ++ show x) s0-    eqn     = Def x dc Nothing (((, Nothing) . mkx) <$> [1 .. n])       (P F.PTrue)-    eqns d  = Def x d  Nothing (((, Nothing) . mkx) <$> [1 .. nArgs d]) (P F.PFalse)+    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)@@ -341,41 +342,41 @@ ---------------------------------------------------------------------------------------------- makeMeasureSpec' :: Bool -> MSpec SpecType Ghc.DataCon -> ([(Ghc.Var, SpecType)], [(LocSymbol, RRType F.Reft)]) -----------------------------------------------------------------------------------------------makeMeasureSpec' allowTC mspec0 = (ctorTys, measTys) -  where +makeMeasureSpec' allowTC mspec0 = (ctorTys, measTys)+  where     ctorTys             = Misc.mapSnd RT.uRType <$> ctorTys0-    (ctorTys0, measTys) = Ms.dataConTypes allowTC mspec +    (ctorTys0, measTys) = Ms.dataConTypes allowTC mspec     mspec               = first (mapReft ur_reft) mspec0  -----------------------------------------------------------------------------------------------makeMeasureSpec :: Bare.Env -> Bare.SigEnv -> ModName -> (ModName, Ms.BareSpec) -> +makeMeasureSpec :: Bare.Env -> Bare.SigEnv -> ModName -> (ModName, Ms.BareSpec) ->                    Bare.Lookup (Ms.MSpec SpecType Ghc.DataCon) -----------------------------------------------------------------------------------------------makeMeasureSpec env sigEnv myName (name, spec) -  = mkMeasureDCon env               name -  . mkMeasureSort env               name -  . first val -  . bareMSpec     env sigEnv myName name -  $ spec +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 +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 +    force      = name == myName+    inScope1 z = F.notracepp ("inScope1: " ++ F.showpp (msName z)) (force ||  okSort z)+    inScope2 z = F.notracepp ("inScope2: " ++ F.showpp (msName z)) (force || (okSort z && okCtors z))+    okSort     = Bare.knownGhcType env name . msSort+    okCtors    = all (Bare.knownGhcDataCon env name . ctor) . msEqns  mkMeasureDCon :: Bare.Env -> ModName -> Ms.MSpec t LocSymbol -> Bare.Lookup (Ms.MSpec t Ghc.DataCon) mkMeasureDCon env name m = do   let ns = measureCtors m-  dcs   <- mapM (Bare.lookupGhcDataCon env name "measure-datacon") ns +  dcs   <- mapM (Bare.lookupGhcDataCon env name "measure-datacon") ns   return $ mkMeasureDCon_ m (zip (val <$> ns) dcs)  -- mkMeasureDCon env name m = mkMeasureDCon_ m [ (val n, symDC n) | n <- measureCtors m ]@@ -392,53 +393,53 @@ measureCtors ::  Ms.MSpec t LocSymbol -> [LocSymbol] measureCtors = Misc.sortNub . fmap ctor . concat . M.elems . Ms.ctorMap -mkMeasureSort :: Bare.Env -> ModName -> Ms.MSpec BareType LocSymbol +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) +mkMeasureSort env name (Ms.MSpec c mm cm im) =+  Ms.MSpec (map txDef <$> c) (tx <$> mm) (tx <$> cm) (tx <$> im)     where       ofMeaSort :: F.SourcePos -> BareType -> SpecType-      ofMeaSort l = Bare.ofBareType env name l Nothing +      ofMeaSort l = Bare.ofBareType env name l Nothing        tx :: Measure BareType ctor -> Measure SpecType ctor       tx (M n s eqs k u) = M n (ofMeaSort l s) (txDef <$> eqs) k u where l = GM.fSourcePos n        txDef :: Def BareType ctor -> Def SpecType ctor-      txDef d = first (ofMeaSort l) d                              where l = GM.fSourcePos (measure d) +      txDef d = first (ofMeaSort l) d                              where l = GM.fSourcePos (measure d)  -  + -------------------------------------------------------------------------------- -- | Expand Measures ----------------------------------------------------------- -------------------------------------------------------------------------------- -- type BareMeasure = Measure LocBareType LocSymbol  expandMeasure :: Bare.Env -> ModName -> BareRTEnv -> BareMeasure -> BareMeasure-expandMeasure env name rtEnv m = m +expandMeasure env name rtEnv m = m   { msSort = RT.generalize                   <$> msSort m-  , msEqns = expandMeasureDef env name rtEnv <$> msEqns m +  , msEqns = expandMeasureDef env name rtEnv <$> msEqns m   }  expandMeasureDef :: Bare.Env -> ModName -> BareRTEnv -> Def t LocSymbol -> Def t LocSymbol-expandMeasureDef env name rtEnv d = d +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) +  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 +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 +knownVars env = [ v | (_, xThings)   <- M.toList (Bare._reTyThings env)+                    , (_,Ghc.AnId v) <- xThings                 ]  varSpecType :: (Monoid r) => Ghc.Var -> Located (RRType r)@@ -449,7 +450,7 @@  makeClassMeasureSpec :: MSpec (RType c tv (UReft r2)) t                      -> [(LocSymbol, CMeasure (RType c tv r2))]-makeClassMeasureSpec (Ms.MSpec {..}) = tx <$> M.elems cmeasMap+makeClassMeasureSpec Ms.MSpec{..} = tx <$> M.elems cmeasMap   where     tx (M n s _ _ _) = (n, CM n (mapReft ur_reft s))
src/Language/Haskell/Liquid/Bare/Misc.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts         #-} -module Language.Haskell.Liquid.Bare.Misc ++module Language.Haskell.Liquid.Bare.Misc   ( joinVar   , mkVarExpr   , vmap@@ -14,17 +15,16 @@  import           Prelude                               hiding (error) -import           Language.Haskell.Liquid.GHC.API       as Ghc  hiding (Located, showPpr)+import           Liquid.GHC.API       as Ghc  hiding (Located, showPpr)  import           Control.Monad.Except                  (MonadError, throwError) import           Control.Monad.State import qualified Data.Maybe                            as Mb --(fromMaybe, isNothing) -import qualified Text.PrettyPrint.HughesPJ             as PJ +import qualified Text.PrettyPrint.HughesPJ             as PJ import qualified Data.List                             as L-import           Language.Fixpoint.Misc                as Misc -- (singleton, sortNub) import qualified Language.Fixpoint.Types as F-import           Language.Haskell.Liquid.GHC.Misc+import           Liquid.GHC.Misc import           Language.Haskell.Liquid.Types.RefType import           Language.Haskell.Liquid.Types.Types @@ -48,7 +48,7 @@       hasBasicArgs (FunTy _ tx t)   = isBaseTy tx && hasBasicArgs t       hasBasicArgs _              = True --} +-}  {-  HEAD@@ -101,12 +101,12 @@ --     f γ _ r xs = let F.Reft (v, _) = F.toReft r in --                  [ x | x <- F.syms r, x /= v, not (x `F.memberSEnv` γ)] : xs --} +-} ------------------------------------------------------------------------------- -- Renaming Type Variables in Haskell Signatures ------------------------------ ------------------------------------------------------------------------------- runMapTyVars :: Bool -> Type -> SpecType -> (PJ.Doc -> PJ.Doc -> Error) -> Either Error MapTyVarST-runMapTyVars allowTC τ t err = execStateT (mapTyVars allowTC τ t) (MTVST [] err) +runMapTyVars allowTC τ t err = execStateT (mapTyVars allowTC τ t) (MTVST [] err)  data MapTyVarST = MTVST   { vmap   :: [(Var, RTyVar)]@@ -116,7 +116,7 @@ mapTyVars :: Bool -> Type -> SpecType -> StateT MapTyVarST (Either Error) () mapTyVars allowTC t (RImpF _ _ _ t' _)    = mapTyVars allowTC t t'-mapTyVars allowTC (FunTy { ft_arg = τ, ft_res = τ'}) t +mapTyVars allowTC (FunTy { ft_arg = τ, ft_res = τ'}) t   | isErasable τ   = mapTyVars allowTC τ' t   where isErasable = if allowTC then isEmbeddedDictType else isClassPred@@ -150,8 +150,8 @@ mapTyVars allowTC (ForAllTy _ τ) t   = mapTyVars allowTC τ t mapTyVars _ hsT lqT-  = do err <- errmsg <$> get-       throwError (err (F.pprint hsT) (F.pprint lqT)) +  = do err <- gets errmsg+       throwError (err (F.pprint hsT) (F.pprint lqT))  isKind :: Kind -> Bool isKind = classifiesTypeWithValues -- TODO:GHC-863 isStarKind k --  typeKind k@@ -166,7 +166,7 @@       Nothing             -> return $ MTVST ((α,a):αas) err  matchKindArgs' :: [Type] -> [SpecType] -> [SpecType]-matchKindArgs' ts1 ts2 = reverse $ go (reverse ts1) (reverse ts2)+matchKindArgs' ts1' = reverse . go (reverse ts1') . reverse   where     go (_:ts1) (t2:ts2) = t2:go ts1 ts2     go ts      []       | all isKind ts@@ -175,7 +175,7 @@   matchKindArgs :: [SpecType] -> [SpecType] -> [SpecType]-matchKindArgs ts1 ts2 = reverse $ go (reverse ts1) (reverse ts2)+matchKindArgs ts1' = reverse . go (reverse ts1') . reverse   where     go (_:ts1) (t2:ts2) = t2:go ts1 ts2     go ts      []       = ts
src/Language/Haskell/Liquid/Bare/Plugged.hs view
@@ -1,8 +1,7 @@ {-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE TupleSections         #-} {-# LANGUAGE PartialTypeSignatures #-} -module Language.Haskell.Liquid.Bare.Plugged +module Language.Haskell.Liquid.Bare.Plugged   ( makePluggedSig   , makePluggedDataCon   ) where@@ -15,16 +14,16 @@ import qualified Control.Exception                 as Ex import qualified Data.HashMap.Strict               as M import qualified Data.HashSet                      as S-import qualified Data.Maybe                        as Mb -import qualified Data.List                         as L +import qualified Data.Maybe                        as Mb+import qualified Data.List                         as L import qualified Language.Fixpoint.Types           as F import qualified Language.Fixpoint.Types.Visitor   as F-import qualified Language.Haskell.Liquid.GHC.Misc  as GM -import qualified Language.Haskell.Liquid.GHC.API   as Ghc -import           Language.Haskell.Liquid.GHC.Types (StableName, mkStableName)+import qualified Liquid.GHC.Misc  as GM+import qualified Liquid.GHC.API   as Ghc+import           Liquid.GHC.Types (StableName, mkStableName) import           Language.Haskell.Liquid.Types.RefType () import           Language.Haskell.Liquid.Types-import qualified Language.Haskell.Liquid.Misc       as Misc +import qualified Language.Haskell.Liquid.Misc       as Misc import qualified Language.Haskell.Liquid.Bare.Types as Bare import qualified Language.Haskell.Liquid.Bare.Misc  as Bare @@ -52,10 +51,10 @@                -> Bare.PlugTV Ghc.Var -> LocSpecType                -> LocSpecType -makePluggedSig allowTC name embs tyi exports kx t -  | Just x <- kxv = mkPlug x +makePluggedSig allowTC name embs tyi exports kx t+  | Just x <- kxv = mkPlug x   | otherwise     = t-  where +  where     kxv           = Bare.plugSrc kx     mkPlug x      = plugHoles allowTC kx embs tyi  r τ t       where@@ -65,12 +64,12 @@   -- makePluggedDataCon = makePluggedDataCon_old --- plugHoles          = plugHoles_old +-- plugHoles          = plugHolesOld  -- makePluggedDataCon = makePluggedDataCon_new  --- plugHoles _         = plugHoles_old+-- plugHoles _         = plugHolesOld -plugHoles :: (Ghc.NamedThing a, PPrint a, Show a) +plugHoles :: (Ghc.NamedThing a, PPrint a, Show a)           => Bool           -> Bare.PlugTV a           -> F.TCEmb Ghc.TyCon@@ -79,37 +78,37 @@           -> Ghc.Type           -> LocSpecType           -> LocSpecType-plugHoles allowTC (Bare.HsTV x) a b = plugHoles_old allowTC a b x -plugHoles allowTC (Bare.LqTV x) a b = plugHoles_new allowTC a b x +plugHoles allowTC (Bare.HsTV x) a b = plugHolesOld allowTC a b x+plugHoles allowTC (Bare.LqTV x) a b = plugHolesNew allowTC a b x plugHoles _ _                   _ _ = \_ _ t -> t   makePluggedDataCon :: Bool -> F.TCEmb Ghc.TyCon -> Bare.TyConMap -> Located DataConP -> Located DataConP-makePluggedDataCon allowTC embs tyi ldcp +makePluggedDataCon allowTC embs tyi ldcp   | mismatchFlds      = Ex.throw (err "fields") -- (err $  "fields:" <+> F.pprint (length dts) <+> " vs " <+> F.pprint ( dcArgs))   | mismatchTyVars    = Ex.throw (err "type variables")-  | otherwise         = F.atLoc ldcp $ F.notracepp "makePluggedDataCon" $ dcp +  | otherwise         = F.atLoc ldcp $ F.notracepp "makePluggedDataCon" $ dcp                           { dcpFreeTyVars = dcVars-                          , dcpTyArgs     = reverse tArgs -                          , dcpTyRes      = tRes +                          , dcpTyArgs     = reverse tArgs+                          , dcpTyRes      = tRes                           }-  where +  where     (tArgs, tRes)     = plugMany allowTC  embs tyi ldcp (das, dts, dt) (dcVars, dcArgs, dcpTyRes dcp)     (das, _, dts, dt) = {- F.notracepp ("makePluggedDC: " ++ F.showpp dc) $ -} Ghc.dataConSig dc-    dcArgs            = filter (not . (if allowTC then isEmbeddedClass else isClassType) . snd) $ reverse (dcpTyArgs dcp)-    dcVars            = if isGADT -                          then padGADVars $ L.nub (dcpFreeTyVars dcp ++ (concatMap (map ty_var_value . freeTyVars) (dcpTyRes dcp:(snd <$> dcArgs))))-                          else dcpFreeTyVars dcp +    dcArgs            = reverse $ filter (not . (if allowTC then isEmbeddedClass else isClassType) . snd) (dcpTyArgs dcp)+    dcVars            = if isGADT+                          then padGADVars $ L.nub (dcpFreeTyVars dcp ++ concatMap (map ty_var_value . freeTyVars) (dcpTyRes dcp:(snd <$> dcArgs)))+                          else dcpFreeTyVars dcp     dc                = dcpCon        dcp-    dcp               = val           ldcp +    dcp               = val           ldcp      isGADT            = Ghc.isGadtSyntaxTyCon $ Ghc.dataConTyCon dc      -- hack to match LH and GHC GADT vars, since it is unclear how ghc generates free vars      padGADVars vs = (RTV <$> take (length das - length vs) das) ++ vs -    mismatchFlds      = length dts /= length dcArgs -    mismatchTyVars    = length das /= length dcVars +    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  @@ -128,29 +127,29 @@ --  --   and not, forall b. a -> a -> Bool. -plugMany :: Bool -> F.TCEmb Ghc.TyCon -> Bare.TyConMap -         -> Located DataConP            +plugMany :: Bool -> F.TCEmb Ghc.TyCon -> Bare.TyConMap+         -> Located DataConP          -> ([Ghc.Var], [Ghc.Type],             Ghc.Type)   -- ^ hs type           -> ([RTyVar] , [(F.Symbol, SpecType)], SpecType)   -- ^ lq type           -> ([(F.Symbol, SpecType)], SpecType)              -- ^ plugged lq type-plugMany allowTC embs tyi ldcp (hsAs, hsArgs, hsRes) (lqAs, lqArgs, lqRes) -                     = F.notracepp msg (drop nTyVars (zip xs ts), t) -  where -    (_,(xs,_,ts,_), t) = bkArrow (val pT) +plugMany allowTC embs tyi ldcp (hsAs, hsArgs, hsRes) (lqAs, lqArgs, lqRes)+                     = F.notracepp msg (drop nTyVars (zip xs ts), t)+  where+    (_,(xs,_,ts,_), t) = bkArrow (val pT)     pT               = plugHoles allowTC (Bare.LqTV dcName) embs tyi (const killHoles) hsT (F.atLoc ldcp lqT)-    hsT              = foldr (Ghc.mkFunTy Ghc.VisArg Ghc.Many) hsRes hsArgs' -    lqT              = foldr (uncurry (rFun' (classRFInfo allowTC))) lqRes lqArgs' -    hsArgs'          = [ Ghc.mkTyVarTy a               | a <- hsAs] ++ hsArgs -    lqArgs'          = [(F.dummySymbol, RVar a mempty) | a <- lqAs] ++ lqArgs +    hsT              = foldr (Ghc.mkFunTy Ghc.VisArg Ghc.Many) hsRes hsArgs'+    lqT              = foldr (uncurry (rFun' (classRFInfo allowTC))) lqRes lqArgs'+    hsArgs'          = [ Ghc.mkTyVarTy a               | a <- hsAs] ++ hsArgs+    lqArgs'          = [(F.dummySymbol, RVar a mempty) | a <- lqAs] ++ lqArgs     nTyVars          = length hsAs -- == length lqAs     dcName           = Ghc.dataConName . dcpCon . val $ ldcp     msg              = "plugMany: " ++ F.showpp (dcName, hsT, lqT) -plugHoles_old, plugHoles_new +plugHolesOld, plugHolesNew   :: (Ghc.NamedThing a, PPrint a, Show a)   => Bool   -> F.TCEmb Ghc.TyCon-  -> Bare.TyConMap +  -> Bare.TyConMap   -> a   -> (SpecType -> RReft -> RReft)   -> Ghc.Type@@ -158,102 +157,102 @@   -> LocSpecType  -- NOTE: this use of toType is safe as rt' is derived from t.-plugHoles_old allowTC tce tyi x f t0 zz@(Loc l l' st0) -    = Loc l l' -    . mkArrow (zip (updateRTVar <$> αs') rs) ps' [] [] -    . makeCls cs' -    . goPlug tce tyi err f (subts su rt) -    . mapExprReft (\_ -> F.applyCoSub coSub) -    . subts su +plugHolesOld allowTC tce tyi xx f t0 zz@(Loc l l' st0)+    = Loc l l'+    . mkArrow (zip (updateRTVar <$> αs') rs) ps' [] []+    . makeCls cs'+    . goPlug tce tyi err f (subts su rt)+    . mapExprReft (\_ -> F.applyCoSub coSub)+    . subts su     $ st-  where +  where     tyvsmap      = case Bare.runMapTyVars allowTC (toType False rt) st err of-                          Left e  -> Ex.throw e +                          Left e  -> Ex.throw e                           Right s -> Bare.vmap s     su           = [(y, rTyVar x)           | (x, y) <- tyvsmap]     su'          = [(y, RVar (rTyVar x) ()) | (x, y) <- tyvsmap] :: [(RTyVar, RSort)]     coSub        = M.fromList [(F.symbol y, F.FObj (F.symbol x)) | (y, x) <- su]     ps'          = fmap (subts su') <$> ps-    cs'          = [(F.dummySymbol, RApp c ts [] mempty) | (c, ts) <- cs ] +    cs'          = [(F.dummySymbol, RApp c ts [] mempty) | (c, ts) <- cs2 ]     (αs', rs)    = unzip αs-    (αs,_,cs,rt) = bkUnivClass (F.notracepp "hs-spec" $ ofType (Ghc.expandTypeSynonyms t0) :: SpecType)+    (αs,_,cs2,rt) = bkUnivClass (F.notracepp "hs-spec" $ ofType (Ghc.expandTypeSynonyms t0) :: SpecType)     (_,ps,_ ,st) = bkUnivClass (F.notracepp "lq-spec" st0)      makeCls cs t = foldr (uncurry (rFun' (classRFInfo allowTC))) t cs-    err hsT lqT  = ErrMismatch (GM.fSrcSpan zz) (pprint x) +    err hsT lqT  = ErrMismatch (GM.fSrcSpan zz) (pprint xx)                           (text "Plugged Init types old")                           (pprint $ Ghc.expandTypeSynonyms t0)                           (pprint $ toRSort st0)                           (Just (hsT, lqT))-                          (Ghc.getSrcSpan x) +                          (Ghc.getSrcSpan xx)   -plugHoles_new allowTC@False tce tyi x f t0 zz@(Loc l l' st0) -    = Loc l l' -    . mkArrow (zip (updateRTVar <$> as'') rs) ps [] [] -    . makeCls cs' -    . goPlug tce tyi err f rt' -    $ st -  where +plugHolesNew allowTC@False tce tyi xx f t0 zz@(Loc l l' st0)+    = Loc l l'+    . mkArrow (zip (updateRTVar <$> as'') rs) ps [] []+    . makeCls cs'+    . goPlug tce tyi err f rt'+    $ st+  where     rt'          = tx rt     as''         = subRTVar su <$> as'-    (as',rs)     = unzip as -    cs'          = [ (F.dummySymbol, ct) | (c, t) <- cs, let ct = tx (RApp c t [] mempty) ]+    (as',rs)     = unzip as+    cs'          = [ (F.dummySymbol, ct) | (c, t) <- tyCons, let ct = tx (RApp c t [] mempty) ]     tx           = subts su     su           = case Bare.runMapTyVars allowTC (toType False rt) st err of-                          Left e  -> Ex.throw e +                          Left e  -> Ex.throw e                           Right s -> [ (rTyVar x, y) | (x, y) <- Bare.vmap s]-    (as,_,cs,rt) = bkUnivClass (ofType (Ghc.expandTypeSynonyms t0) :: SpecType)+    (as,_,tyCons,rt) = bkUnivClass (ofType (Ghc.expandTypeSynonyms t0) :: SpecType)     (_,ps,_ ,st) = bkUnivClass st0      makeCls cs t = foldr (uncurry (rFun' (classRFInfo allowTC))) t cs-    err hsT lqT  = ErrMismatch (GM.fSrcSpan zz) (pprint x) +    err hsT lqT  = ErrMismatch (GM.fSrcSpan zz) (pprint xx)                           (text "Plugged Init types new")                           (pprint $ Ghc.expandTypeSynonyms t0)                           (pprint $ toRSort st0)                           (Just (hsT, lqT))-                          (Ghc.getSrcSpan x) +                          (Ghc.getSrcSpan xx)  -plugHoles_new allowTC@True tce tyi x f t0 zz@(Loc l l' st0) -    = Loc l l' +plugHolesNew allowTC@True tce tyi a f t0 zz@(Loc l l' st0)+    = Loc l l'     . mkArrow (zip (updateRTVar <$> as'') rs) ps [] (if length cs > length cs' then cs else cs')     -- . makeCls cs' -    . goPlug tce tyi err f rt' -    $ st -  where +    . goPlug tce tyi err f rt'+    $ st+  where     rt'          = tx rt     as''         = subRTVar su <$> as'-    (as',rs)     = unzip as +    (as',rs)     = unzip as     -- cs'          = [ (F.dummySymbol, ct) | (c, t) <- cs, let ct = tx (RApp c t [] mempty) ]     tx           = subts su     su           = case Bare.runMapTyVars allowTC (toType False rt) st err of-                          Left e  -> Ex.throw e +                          Left e  -> Ex.throw e                           Right s -> [ (rTyVar x, y) | (x, y) <- Bare.vmap s]     (as,_,cs0,rt) = bkUnivClass' (ofType (Ghc.expandTypeSynonyms t0) :: SpecType)     (_,ps,cs0' ,st) = bkUnivClass' st0     cs  = [ (x, classRFInfo allowTC, t, r) | (x,t,r)<-cs0]     cs' = [ (x, classRFInfo allowTC, t, r) | (x,t,r)<-cs0'] -    err hsT lqT  = ErrMismatch (GM.fSrcSpan zz) (pprint x) +    err hsT lqT  = ErrMismatch (GM.fSrcSpan zz) (pprint a)                           (text "Plugged Init types new")                           (pprint $ Ghc.expandTypeSynonyms t0)                           (pprint $ toRSort st0)                           (Just (hsT, lqT))-                          (Ghc.getSrcSpan x) +                          (Ghc.getSrcSpan a) -subRTVar :: [(RTyVar, RTyVar)] -> SpecRTVar -> SpecRTVar +subRTVar :: [(RTyVar, RTyVar)] -> SpecRTVar -> SpecRTVar subRTVar su a@(RTVar v i) = Mb.maybe a (`RTVar` i) (lookup v su)  goPlug :: F.TCEmb Ghc.TyCon -> Bare.TyConMap -> (Doc -> Doc -> Error) -> (SpecType -> RReft -> RReft) -> SpecType -> SpecType        -> SpecType-goPlug tce tyi err f = go +goPlug tce tyi err f = go   where-    go t (RHole r) = (addHoles t') { rt_reft = f t r }+    go st (RHole r) = (addHoles t') { rt_reft = f st r }       where-        t'         = everywhere (mkT $ addRefs tce tyi) t-        addHoles   = everywhere (mkT $ addHole)+        t'         = everywhere (mkT $ addRefs tce tyi) st+        addHoles   = everywhere (mkT addHole)         -- NOTE: make sure we only add holes to RVar and RApp (NOT RFun)         addHole :: SpecType -> SpecType         addHole t@(RVar v _)       = RVar v (f t (uReft ("v", hole)))@@ -272,7 +271,7 @@     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)   +    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))
src/Language/Haskell/Liquid/Bare/Resolve.hs view
@@ -3,7 +3,6 @@ --   2. USE the environment to translate plain symbols into Var, TyCon, etc.   {-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE TypeSynonymInstances  #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE LambdaCase            #-}@@ -12,29 +11,29 @@ {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE TupleSections         #-} -module Language.Haskell.Liquid.Bare.Resolve +module Language.Haskell.Liquid.Bare.Resolve   ( -- * Creating the Environment-    makeEnv +    makeEnv      -- * Resolving symbols    , ResolveSym (..)   , Qualify (..)   , Lookup   , qualifyTop, qualifyTopDummy-  +   -- * Looking up names-  , maybeResolveSym -  , lookupGhcDataCon -  , lookupGhcDnTyCon -  , lookupGhcTyCon -  , lookupGhcVar -  , lookupGhcNamedVar +  , maybeResolveSym+  , lookupGhcDataCon+  , lookupGhcDnTyCon+  , lookupGhcTyCon+  , lookupGhcVar+  , lookupGhcNamedVar    -- * Checking if names exist-  , knownGhcVar -  , knownGhcTyCon -  , knownGhcDataCon -  , knownGhcType +  , knownGhcVar+  , knownGhcTyCon+  , knownGhcDataCon+  , knownGhcType    -- * Misc    , srcVars@@ -50,37 +49,37 @@   , errResolve    -- * Fixing local variables-  , resolveLocalBinds -  , partitionLocalBinds -  ) where +  , resolveLocalBinds+  , partitionLocalBinds+  ) where -import qualified Control.Exception                 as Ex -import qualified Data.List                         as L -import qualified Data.HashSet                      as S +import qualified Control.Exception                 as Ex+import qualified Data.List                         as L+import qualified Data.HashSet                      as S import qualified Data.Maybe                        as Mb import qualified Data.HashMap.Strict               as M import qualified Data.Text                         as T-import qualified Text.PrettyPrint.HughesPJ         as PJ +import qualified 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.Fixpoint.Utils.Files         as F+import qualified Language.Fixpoint.Types               as F+import qualified Language.Fixpoint.Types.Visitor       as F+import qualified Language.Fixpoint.Misc                as Misc+import qualified Liquid.GHC.API       as Ghc+import qualified Liquid.GHC.Misc      as GM+import qualified Language.Haskell.Liquid.Misc          as Misc import qualified Language.Haskell.Liquid.Types.RefType as RT-import qualified Language.Haskell.Liquid.Types.Errors  as Errors -import           Language.Haskell.Liquid.Types.Types   +import qualified Language.Haskell.Liquid.Types.Errors  as Errors+import           Language.Haskell.Liquid.Types.Types import           Language.Haskell.Liquid.Measure       (BareSpec) import           Language.Haskell.Liquid.Types.Specs   hiding (BareSpec)-import           Language.Haskell.Liquid.Types.Visitors -import           Language.Haskell.Liquid.Bare.Types -import           Language.Haskell.Liquid.Bare.Misc   -import           Language.Haskell.Liquid.WiredIn +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 +myTracepp = F.notracepp  -- type Lookup a = Misc.Validate [Error] a type Lookup a = Either [Error] a@@ -88,49 +87,49 @@ ------------------------------------------------------------------------------- -- | Creating an environment  --------------------------------------------------------------------------------makeEnv :: Config -> GhcSrc -> LogicMap -> [(ModName, BareSpec)] -> Env -makeEnv cfg src lmap specs = RE +makeEnv :: Config -> GhcSrc -> LogicMap -> [(ModName, BareSpec)] -> Env+makeEnv cfg src lmap specs = RE   { reLMap      = lmap-  , reSyms      = syms -  , _reSubst    = makeVarSubst   src -  , _reTyThings = makeTyThingMap src +  , reSyms      = syms+  , _reSubst    = makeVarSubst   src+  , _reTyThings = makeTyThingMap src   , reQualImps  = _gsQualImps     src   , reAllImps   = _gsAllImps      src-  , reLocalVars = makeLocalVars  src +  , reLocalVars = makeLocalVars  src   , reSrc       = src-  , reGlobSyms  = S.fromList     globalSyms +  , reGlobSyms  = S.fromList     globalSyms   , reCfg       = cfg-  } -  where +  }+  where     globalSyms  = concatMap getGlobalSyms specs-    syms        = [ (F.symbol v, v) | v <- vars ] +    syms        = [ (F.symbol v, v) | v <- vars ]     vars        = srcVars src  getGlobalSyms :: (ModName, BareSpec) -> [F.Symbol]-getGlobalSyms (_, spec) -  = filter (not . GM.isQualifiedSym) -       $ (mbName <$> measures  spec) +getGlobalSyms (_, spec)+  = filter (not . GM.isQualifiedSym)+       $ (mbName <$> measures  spec)       ++ (mbName <$> cmeasures spec)       ++ (mbName <$> imeasures spec)-  where +  where     mbName = F.val . msName -makeLocalVars :: GhcSrc -> LocalVars +makeLocalVars :: GhcSrc -> LocalVars makeLocalVars = localVarMap . localBinds . _giCbs  -- TODO: rewrite using CoreVisitor localBinds :: [Ghc.CoreBind] -> [Ghc.Var]-localBinds                    = concatMap (bgo S.empty) +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 +    add  x g                  = maybe g (`S.insert` g) (localKey x)+    adds b g                  = foldr add g (Ghc.bindersOf b)+    take' x g                 = maybe [] (\k -> [x | not (S.member k g)]) (localKey x)+    pgo g (x, e)              = take' x g ++ go (add x g) e+    bgo g (Ghc.NonRec x e)    = pgo g (x, e)+    bgo g (Ghc.Rec xes)       = concatMap (pgo g) xes     go  g (Ghc.App e a)       = concatMap (go  g) [e, a]     go  g (Ghc.Lam _ e)       = go g e-    go  g (Ghc.Let b e)       = bgo g b ++ go (adds b g) e +    go  g (Ghc.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@@ -138,28 +137,28 @@     go  _ _                   = []  localVarMap :: [Ghc.Var] -> LocalVars-localVarMap vs = -  Misc.group [ (x, (i, v)) | v    <- vs-                           , x    <- Mb.maybeToList (localKey v) +localVarMap vs =+  Misc.group [ (x, (i, v)) | v <- vs                            , let i = F.unPos (F.srcLine v)+                           , x <- Mb.maybeToList (localKey v)              ]  localKey   :: Ghc.Var -> Maybe F.Symbol-localKey v -  | isLocal m = Just x +localKey v+  | isLocal m = Just x   | otherwise = Nothing-  where -    (m, x)    = splitModuleNameExact . GM.dropModuleUnique . F.symbol $ v +  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) +makeVarSubst :: GhcSrc -> F.Subst+makeVarSubst src = F.mkSubst unqualSyms+  where+    unqualSyms   = [ (x, mkVarExpr v)+                       | (x, mxs) <- M.toList (makeSymMap src)                        , not (isWiredInName x)-                   ] -    me           = F.symbol (_giTargetMod src) +                       , v <- Mb.maybeToList (okUnqualified me mxs)+                   ]+    me           = F.symbol (_giTargetMod src)  -- | @okUnqualified mod mxs@ takes @mxs@ which is a list of modulenames-var  --   pairs all of which have the same unqualified symbol representation. @@ -167,85 +166,85 @@ --   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 +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)) +makeSymMap src = Misc.group [ (sym, (m, x))                                 | x           <- srcVars src                                 , let (m, sym) = qualifiedSymbol x ] -makeTyThingMap :: GhcSrc -> TyThingMap +makeTyThingMap :: GhcSrc -> TyThingMap makeTyThingMap src =   Misc.group [ (x, (m, t))  | t         <- srcThings src                             , tSym      <- Mb.maybeToList (tyThingSymbol t)-                            , let (m, x) = qualifiedSymbol tSym +                            , let (m, x) = qualifiedSymbol tSym                             , not (isLocal m)-             ] +             ] -tyThingSymbol :: Ghc.TyThing -> Maybe F.Symbol +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 (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 :: 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 +isLocal = isEmptySymbol  qualifiedSymbol :: (F.Symbolic a) => a -> (F.Symbol, F.Symbol)-qualifiedSymbol = splitModuleNameExact . F.symbol +qualifiedSymbol = splitModuleNameExact . F.symbol -isEmptySymbol :: F.Symbol -> Bool -isEmptySymbol x = F.lengthSym x == 0 +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) +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 +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 +    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 +srcTyCons src = concat+  [ _gsTcs     src+  , _gsFiTcs   src   , _gsPrimTcs src-  , srcVarTcs src +  , srcVarTcs src   ]  srcVarTcs :: GhcSrc -> [Ghc.TyCon]-srcVarTcs = varTyCons . srcVars +srcVarTcs = varTyCons . srcVars  varTyCons :: [Ghc.Var] -> [Ghc.TyCon]-varTyCons = concatMap (typeTyCons . Ghc.dropForAlls . Ghc.varType) +varTyCons = concatMap (typeTyCons . Ghc.dropForAlls . Ghc.varType)  typeTyCons :: Ghc.Type -> [Ghc.TyCon]-typeTyCons t = tops t ++ inners t -  where +typeTyCons t = tops t ++ inners t+  where     tops     = Mb.maybeToList . Ghc.tyConAppTyCon_maybe-    inners   = concatMap typeTyCons . snd . Ghc.splitAppTys +    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 @@ -255,144 +254,141 @@ --      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 +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-IMP" 2 <$> _giImpVars src+  , key "SRC-VAR-USE" 3 <$> _giUseVars src   , key "SRC-VAR-THN" 4 <$> [ x | Ghc.AnId x <- _gsTyThings src ]   ]-  where +  where     key :: String -> Int -> Ghc.Var -> (Int, F.Symbol, Ghc.Var)-    key _ i x  = (i, F.symbol x, {- dump s -} x) +    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 -  ] +dataConVars dcs = (Ghc.dataConWorkId <$> dcs) ++ (Ghc.dataConWrapId <$> dcs)  ------------------------------------------------------------------------------- -- | Qualify various names  --------------------------------------------------------------------------------qualifyTop :: (Qualify a) => Env -> ModName -> F.SourcePos -> a -> a +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 :: (Qualify a) => Env -> ModName -> a -> a qualifyTopDummy env name = qualifyTop env name dummySourcePos -dummySourcePos :: F.SourcePos +dummySourcePos :: F.SourcePos dummySourcePos = F.loc (F.dummyLoc ()) -class Qualify a where -  qualify :: Env -> ModName -> F.SourcePos -> [F.Symbol] -> a -> a +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 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 +instance Qualify TyConP where   qualify env name _ bs tcp = tcp { tcpSizeFun = qualify env name (tcpLoc tcp) bs <$> tcpSizeFun tcp } -instance Qualify SizeFun where +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 +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 +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 -> 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     = 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) +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 (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 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) +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 +instance Qualify TyConInfo where   qualify env name l bs tci = tci { sizeFunction = qualify env name l bs <$> sizeFunction tci } -instance Qualify RTyCon where +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 +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 +    { msName = qualify env name l bs     lname+    , msEqns = qualify env name l bs <$> msEqns m     }-    where +    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 +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 +instance Qualify BareMeasure where+  qualify env name l bs m = m     { msEqns = qualify env name l bs (msEqns m)-    } +    } -instance Qualify DataCtor where +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) +    { 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 ++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) -    } +    , 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 ModSpecs where+  qualify env name l bs = Misc.hashMapMapWithKey (\_ -> qualify env name l bs) -instance Qualify b => Qualify (a, b) where +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 +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) +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)@@ -400,8 +396,8 @@   , 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 +  }+  where f      = qualify env name l bs  instance Qualify a => Qualify (RTAlias F.Symbol a) where   qualify env name l bs rtAlias@@ -411,40 +407,40 @@              , rtBody  = qualify env name l bs (rtBody rtAlias)              } -instance Qualify F.Expr where -  qualify = substEnv +instance Qualify F.Expr where+  qualify = substEnv -instance Qualify RReft where +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 +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) +substEnv :: (F.Subable a) => Env -> ModName -> F.SourcePos -> [F.Symbol] -> a -> a+substEnv env name l bs = F.substa (qualifySymbol env name l bs) -instance Qualify SpecType where -  qualify x1 x2 x3 x4 x5 = emapReft (substFreeEnv x1 x2 x3) x4 x5            +instance Qualify SpecType where+  qualify x1 x2 x3 x4 x5 = emapReft (substFreeEnv x1 x2 x3) x4 x5 -instance Qualify BareType where -  qualify x1 x2 x3 x4 x5 = emapReft (substFreeEnv x1 x2 x3) x4 x5 +instance Qualify BareType where+  qualify x1 x2 x3 x4 x5 = emapReft (substFreeEnv x1 x2 x3) x4 x5 -substFreeEnv :: (F.Subable a) => Env -> ModName -> F.SourcePos -> [F.Symbol] -> a -> a -substFreeEnv env name l bs = F.substf (F.EVar . qualifySymbol env name l bs) +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 +  where     lx                       = GM.namedLocSymbol z -lookupGhcVar :: Env -> ModName -> String -> LocSymbol -> Lookup Ghc.Var -lookupGhcVar env name kind lx = case resolveLocSym env name kind lx of -    Right v -> Mb.maybe (Right v) Right (lookupLocalVar env lx [v]) -    Left  e -> Mb.maybe (Left  e) Right (lookupLocalVar env lx []) +lookupGhcVar :: Env -> ModName -> String -> LocSymbol -> Lookup Ghc.Var+lookupGhcVar env name kind lx = case resolveLocSym env name kind lx of+    Right v -> Mb.maybe (Right v) Right (lookupLocalVar env lx [v])+    Left  e -> Mb.maybe (Left  e) Right (lookupLocalVar env lx [])    -- where     -- err e   = Misc.errorP "error-lookupGhcVar" (F.showpp (e, F.loc lx, lx))@@ -456,18 +452,18 @@  lookupLocalVar :: Env -> LocSymbol -> [Ghc.Var] -> Maybe Ghc.Var lookupLocalVar env lx gvs = Misc.findNearest lxn kvs-  where +  where     _msg                  = "LOOKUP-LOCAL: " ++ F.showpp (F.val lx, lxn, kvs)-    kvs                   = gs ++ M.lookupDefault [] x (reLocalVars env) +    kvs                   = gs ++ M.lookupDefault [] x (reLocalVars env)     gs                    = [(F.unPos (F.srcLine v), v) | v <- gvs]     lxn                   = F.unPos (F.srcLine lx)     (_, x)                = unQualifySymbol (F.val lx) -lookupGhcDataCon :: Env -> ModName -> String -> LocSymbol -> Lookup Ghc.DataCon +lookupGhcDataCon :: Env -> ModName -> String -> LocSymbol -> Lookup Ghc.DataCon lookupGhcDataCon = resolveLocSym -- strictResolveSym  -lookupGhcTyCon :: Env -> ModName -> String -> LocSymbol -> Lookup Ghc.TyCon -lookupGhcTyCon env name k lx = myTracepp ("LOOKUP-TYCON: " ++ F.showpp (val lx)) +lookupGhcTyCon :: Env -> ModName -> String -> LocSymbol -> Lookup Ghc.TyCon+lookupGhcTyCon env name k lx = myTracepp ("LOOKUP-TYCON: " ++ F.showpp (val lx))                                $ {- strictResolveSym -} resolveLocSym env name k lx  lookupGhcDnTyCon :: Env -> ModName -> String -> DataName -> Lookup (Maybe Ghc.TyCon)@@ -475,78 +471,78 @@ lookupGhcDnTyCon env name msg = failMaybe env name . lookupGhcDnTyConE env name msg  lookupGhcDnTyConE :: Env -> ModName -> String -> DataName -> Lookup Ghc.TyCon-lookupGhcDnTyConE env name msg (DnCon  s) +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 +lookupGhcDnTyConE env name msg (DnName s)+  = case resolveLocSym env name msg s of+      Right r -> Right r+      Left  e -> case lookupGhcDnCon  env name msg s of+                   Right r -> Right r                    Left  _ -> Left  e  -lookupGhcDnCon :: Env -> ModName -> String -> LocSymbol -> Lookup Ghc.TyCon +lookupGhcDnCon :: Env -> ModName -> String -> LocSymbol -> Lookup Ghc.TyCon lookupGhcDnCon env name msg = fmap Ghc.dataConTyCon . resolveLocSym env name msg  ------------------------------------------------------------------------------- -- | Checking existence of names  ------------------------------------------------------------------------------- knownGhcType :: Env ->  ModName -> LocBareType -> Bool-knownGhcType env name (F.Loc l _ t) = -  case ofBareTypeE env name l Nothing t of -    Left e  -> myTracepp ("knownType: " ++ F.showpp (t, e)) $ False -    Right _ -> True +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 +_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 +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 +    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 +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 +    v = maybeResolveSym env name "known-tycon" lx -knownGhcDataCon :: Env -> ModName -> LocSymbol -> Bool -knownGhcDataCon env name lx = Mb.isJust v -  where +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 +    v = myTracepp ("knownGhcDataCon" ++ F.showpp lx)+      $ maybeResolveSym env name "known-datacon" lx  ------------------------------------------------------------------------------- -- | Using the environment  --------------------------------------------------------------------------------class ResolveSym a where +class ResolveSym a where   resolveLocSym :: Env -> ModName -> String -> LocSymbol -> Lookup a -instance ResolveSym Ghc.Var where -  resolveLocSym = resolveWith "variable" $ \case -                    Ghc.AnId x -> Just x +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 +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 +instance ResolveSym Ghc.DataCon where+  resolveLocSym = resolveWith "data constructor" $ \case+                    Ghc.AConLike (Ghc.RealDataCon x) -> Just x                     _                                -> Nothing  @@ -611,26 +607,26 @@   -resolveWith :: (PPrint a) => PJ.Doc -> (Ghc.TyThing -> Maybe a) -> Env -> ModName -> String -> LocSymbol -            -> Lookup a +resolveWith :: (PPrint a) => PJ.Doc -> (Ghc.TyThing -> Maybe a) -> Env -> ModName -> String -> LocSymbol+            -> Lookup a resolveWith kind f env name str lx =   -- case Mb.mapMaybe f things of    case rankedThings f things of     []  -> Left [errResolve kind str lx]-    [x] -> Right x +    [x] -> Right x     xs  -> Left [ErrDupNames sp (pprint (F.val lx)) (pprint <$> xs)]   where     _xSym   = F.val lx     sp      = GM.fSrcSpanSrcSpan (F.srcSpan lx)-    things  = myTracepp msg $ lookupTyThing env name lx +    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 +rankedThings f ias = case Misc.sortOn fst (Misc.groupList ibs) of                        (_,ts):_ -> ts                        []       -> []-  where +  where     ibs            = Mb.mapMaybe (\(k, x) -> (k,) <$> f x) ias  -------------------------------------------------------------------------------@@ -642,19 +638,19 @@ ------------------------------------------------------------------------------- lookupTyThing :: Env -> ModName -> LocSymbol -> [((Int, F.Symbol), Ghc.TyThing)] --------------------------------------------------------------------------------lookupTyThing env name lsym = [ (k, t) | (k, ts) <- ordMatches, t <- ts] -                              -  where +lookupTyThing env mdname lsym = [ (k, t) | (k, ts) <- ordMatches, t <- ts]++  where     ordMatches             = Misc.sortOn fst (Misc.groupList matches)     matches                = myTracepp ("matches-" ++ msg)                              [ ((k, m), t) | (m, t) <- lookupThings env x-                                           , k      <- myTracepp msg $ mm nameSym m 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 +                                           , k      <- myTracepp msg $ mm nameSym m mds ]+    msg                    = "lookupTyThing: " ++ F.showpp (lsym, x, mds)+    (x, mds)               = symbolModules env (F.val lsym)+    nameSym                = F.symbol mdname+    allowExt               = allowExtResolution env lsym+    mm name m mods         = myTracepp ("matchMod: " ++ F.showpp (lsym, name, m, mods, allowExt)) $+                               matchMod env name m allowExt mods  -- | [NOTE:External-Resolution] @allowExtResolution@ determines whether a @LocSymbol@  --   can be resolved by a @TyThing@ that is _outside_ the module corresponding to @LocSymbol@. @@ -664,37 +660,37 @@ --   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 +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) +    fileMb  = Errors.srcSpanFileMb (GM.fSrcSpan lx) -lookupThings :: Env -> F.Symbol -> [(F.Symbol, Ghc.TyThing)] -lookupThings env x = myTracepp ("lookupThings: " ++ F.showpp x) +lookupThings :: Env -> F.Symbol -> [(F.Symbol, Ghc.TyThing)]+lookupThings env x = myTracepp ("lookupThings: " ++ F.showpp x)                    $ Misc.fromFirstMaybes [] (get <$> [x, GM.stripParensSym x])-  where +  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 +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 +     |  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 +     where        isExt              = any (`isParentModuleOf` defName) ms  -- | Returns 'True' if the 'Symbol' given as a first argument represents a parent module for the second.@@ -721,11 +717,11 @@   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)  +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 @@ -733,32 +729,32 @@ --   * 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  ++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 +    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) +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) +splitModuleNameExact x' = myTracepp ("splitModuleNameExact for " ++ F.showpp x)                           (GM.takeModuleNames x, GM.dropModuleNames x)   where-    x = GM.stripParensSym x' +    x = GM.stripParensSym x' -errResolve :: PJ.Doc -> String -> LocSymbol -> Error -errResolve k msg lx = ErrResolve (GM.fSrcSpan lx) k (F.pprint (F.val lx)) (PJ.text msg) +errResolve :: PJ.Doc -> String -> LocSymbol -> Error+errResolve k msg lx = ErrResolve (GM.fSrcSpan lx) k (F.pprint (F.val lx)) (PJ.text msg)  -- -- | @strictResolve@ wraps the plain @resolve@ to throw an error  -- --   if the name being searched for is unknown.@@ -769,54 +765,54 @@  -- | @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 -  +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 +ofBareType :: Env -> ModName -> F.SourcePos -> Maybe [PVar BSort] -> BareType -> SpecType+ofBareType env name l ps t = either fail' id (ofBareTypeE env name l ps t)+  where+    fail'                  = Ex.throw     -- fail                   = Misc.errorP "error-ofBareType" . F.showpp  -ofBareTypeE :: Env -> ModName -> F.SourcePos -> Maybe [PVar BSort] -> BareType -> Lookup SpecType -ofBareTypeE env name l ps t = ofBRType env name (resolveReft env name l ps t) l t +ofBareTypeE :: Env -> ModName -> F.SourcePos -> Maybe [PVar BSort] -> BareType -> Lookup SpecType+ofBareTypeE env name l ps t = ofBRType env name (resolveReft env name l ps t) l t -resolveReft :: Env -> ModName -> F.SourcePos -> Maybe [PVar BSort] -> BareType -> [F.Symbol] -> RReft -> RReft +resolveReft :: Env -> ModName -> F.SourcePos -> Maybe [PVar BSort] -> BareType -> [F.Symbol] -> RReft -> RReft resolveReft env name l ps t bs-        = qualify env name l 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+    π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) } +coSubRReft :: F.CoSub -> RReft -> RReft+coSubRReft su r = r { ur_reft = coSubReft su (ur_reft r) } -coSubReft :: F.CoSub -> F.Reft -> F.Reft +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 -> ModName -> F.SourcePos -> BSort -> RSort ofBSort env name l t = either (Misc.errorP "error-ofBSort" . F.showpp) id (ofBSortE env name l t) -ofBSortE :: Env -> ModName -> F.SourcePos -> BSort -> Lookup RSort -ofBSortE env name l t = ofBRType env name (const id) l t -  +ofBSortE :: Env -> ModName -> F.SourcePos -> BSort -> Lookup RSort+ofBSortE env name l t = ofBRType env name (const id) l t+ ofBPVar :: Env -> ModName -> F.SourcePos -> BPVar -> RPVar-ofBPVar env name l = fmap (ofBSort env name l) +ofBPVar env name l = fmap (ofBSort env name l)  -------------------------------------------------------------------------------- txParam :: F.SourcePos -> ((UsedPVar -> UsedPVar) -> t) -> [UsedPVar] -> RType c tv r -> t@@ -829,7 +825,7 @@           | otherwise            = pargs π'     π'    = Mb.fromMaybe err $ M.lookup (pname π) m     err   = uError $ ErrUnbPred sp (pprint π)-    sp    = GM.sourcePosSrcSpan l +    sp    = GM.sourcePosSrcSpan l  predMap :: [UsedPVar] -> RType c tv r -> M.HashMap F.Symbol UsedPVar predMap πs t = M.fromList [(pname π, π) | π <- πs ++ rtypePredBinds t]@@ -845,32 +841,32 @@                     , 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 +ofBRType :: (Expandable r) => Env -> ModName -> ([F.Symbol] -> r -> r) -> F.SourcePos -> BRType r          -> Lookup (RRType r)-ofBRType env name f l t  = go [] t +ofBRType env name f l = go []   where-    goReft bs r             = return (f bs r) +    goReft bs r             = return (f bs r)     goRImpF bs x i t1 t2 r  = RImpF x i <$> (rebind x <$> go bs t1) <*> go (x:bs) t2 <*> goReft bs r     goRFun  bs x i t1 t2 r  = RFun  x i{permitTC = Just (typeclass (getConfig env))} <$> (rebind x <$> go bs t1) <*> go (x:bs) t2 <*> goReft bs r     rebind x t              = F.subst1 t (x, F.EVar $ rTypeValueVar t)     go bs (RAppTy t1 t2 r)  = RAppTy <$> go bs t1 <*> go bs t2 <*> goReft bs r-    go bs (RApp tc ts rs r) = goRApp bs tc ts rs r -    go bs (RImpF x i t1 t2 r) = goRImpF bs x i t1 t2 r -    go bs (RFun  x i t1 t2 r) = goRFun  bs x i t1 t2 r +    go bs (RApp tc ts rs r) = goRApp bs tc ts rs r+    go bs (RImpF x i t1 t2 r) = goRImpF bs x i t1 t2 r+    go bs (RFun  x i t1 t2 r) = goRFun  bs x i t1 t2 r     go bs (RVar a r)        = RVar (RT.bareRTyVar a) <$> goReft bs r-    go bs (RAllT a t r)     = RAllT a' <$> go bs t <*> goReft bs r -      where a'              = dropTyVarInfo (mapTyVarValue RT.bareRTyVar a) -    go bs (RAllP a t)       = RAllP a' <$> go bs t -      where a'              = ofBPVar env name l a +    go bs (RAllT a t r)     = RAllT a' <$> go bs t <*> goReft bs r+      where a'              = dropTyVarInfo (mapTyVarValue RT.bareRTyVar a)+    go bs (RAllP a t)       = RAllP a' <$> go bs t+      where a'              = ofBPVar env name l a     go bs (RAllE x t1 t2)   = RAllE x  <$> go bs t1    <*> go bs t2     go bs (REx x t1 t2)     = REx   x  <$> go bs t1    <*> go (x:bs) t2     go bs (RRTy xts r o t)  = RRTy  <$> xts' <*> goReft bs r <*> pure o <*> go bs t       where xts'            = mapM (Misc.mapSndM (go bs)) xts     go bs (RHole r)         = RHole    <$> goReft bs r-    go bs (RExprArg le)     = return    $ RExprArg (qualify env name l bs le) +    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 +    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)@@ -899,23 +895,23 @@ matchTyCon :: Env -> ModName -> LocSymbol -> Int -> Lookup Ghc.TyCon matchTyCon env name lc@(Loc _ _ c) arity   | isList c && arity == 1  = Right Ghc.listTyCon-  | isTuple c               = Right tuplTc -  | otherwise               = resolveLocSym env name msg lc -  where +  | isTuple c               = Right tuplTc+  | otherwise               = resolveLocSym env name msg lc+  where     msg                     = "matchTyCon: " ++ F.showpp c-    tuplTc                  = Ghc.tupleTyCon Ghc.Boxed arity +    tuplTc                  = Ghc.tupleTyCon Ghc.Boxed arity  -bareTCApp :: (Expandable r) +bareTCApp :: (Expandable r)           => r           -> Located Ghc.TyCon           -> [RTProp RTyCon RTyVar r]           -> [RType 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) +  = 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+      else tyApp (RT.subsTyVarsMeet su $ RT.ofType rhs) (drop nts ts) rs r     where        tvs = [ v | (v, b) <- zip (GM.tyConTyVarsDef c) (Ghc.tyConBinders c), GM.isAnonBinder b]        su  = zipWith (\a t -> (RT.rTyVar a, toRSort t, t)) tvs ts@@ -924,8 +920,8 @@        err :: Error        err = ErrAliasApp (GM.sourcePosSrcSpan l) (pprint c) (Ghc.getSrcSpan c)                          (PJ.hcat [ PJ.text "Expects"-                                  , pprint (GM.realTcArity c) -                                  , PJ.text "arguments, but is given" +                                  , pprint (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@@ -936,11 +932,11 @@   = RT.rApp c ts rs r  -tyApp :: F.Reftable r => RType c tv r -> [RType c tv r] -> [RTProp c tv r] -> 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"+tyApp _                 _  _   _  = panic Nothing "Bare.Type.tyApp on invalid inputs"  expandRTypeSynonyms :: (Expandable r) => RRType r -> RRType r expandRTypeSynonyms = RT.ofType . Ghc.expandTypeSynonyms . RT.toType False@@ -968,28 +964,28 @@ 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'+addSymSort :: Ghc.SrcSpan -> F.TCEmb Ghc.TyCon -> TyConMap -> SpecType -> SpecType+addSymSort sp tce tyi (RApp rc@RTyCon{} ts rs rr)+  = RApp rc ts (zipWith3 (addSymSortRef sp rc) pvs rargs [1..]) r2   where     (_, pvs)           = RT.appRTyCon tce tyi rc ts     -- pvs             = rTyConPVs rc'     (rargs, rrest)     = splitAt (length pvs) rs-    r'                 = L.foldl' go r rrest+    r2                 = L.foldl' go rr rrest     go r (RProp _ (RHole r')) = r' `F.meet` r     go r (RProp  _ t' )       = let r' = Mb.fromMaybe mempty (stripRTypeBase t') in r `F.meet` r'  addSymSort _ _ _ t   = t -addSymSortRef :: (PPrint s) => Ghc.SrcSpan -> s -> RPVar -> SpecProp -> Int -> SpecProp +addSymSortRef :: (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' :: (PPrint s) => Ghc.SrcSpan -> s -> Int -> RPVar -> SpecProp -> SpecProp addSymSortRef' _ _ _ p (RProp s (RVar v r)) | isDummy v   = RProp xs t     where@@ -1016,7 +1012,7 @@       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)+spliceArgs msg syms p = go (fst <$> syms) (pargs p)   where     go []     []           = []     go []     ((s,x,_):as) = (x, s):go [] as@@ -1030,43 +1026,43 @@ --   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])] +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 +  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 +replaceVisitor :: CoreVisitor SymMap SigMap+replaceVisitor = CoreVisitor   { envF  = addBind   , bindF = updSigMap-  , exprF = \_ m _ -> m +  , exprF = \_ m _ -> m   } -addBind :: SymMap -> Ghc.Var -> SymMap -addBind env v = case localKey v of -  Just vx -> M.insert vx (F.symbol v) env +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 ++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 +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)) +    xs                     = ty_binds (toRTypeRep (F.val t)) -qualifySymMap :: SymMap -> F.Symbol -> F.Symbol -qualifySymMap env x = M.lookupDefault x x env +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
src/Language/Haskell/Liquid/Bare/Slice.hs view
@@ -1,14 +1,6 @@-{-# LANGUAGE DerivingVia                #-}-{-# LANGUAGE DerivingStrategies         #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE TypeSynonymInstances       #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE DerivingStrategies         #-} {-# LANGUAGE DerivingVia                #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RecordWildCards            #-}   -- | This module has a function that computes the "slice" i.e. subset of the `Ms.BareSpec` that
src/Language/Haskell/Liquid/Bare/ToBare.hs view
@@ -14,8 +14,8 @@  import           Language.Fixpoint.Misc (mapSnd) import qualified Language.Fixpoint.Types as F-import           Language.Haskell.Liquid.GHC.Misc-import           Language.Haskell.Liquid.GHC.API+import           Liquid.GHC.Misc+import           Liquid.GHC.API import           Language.Haskell.Liquid.Types -- import           Language.Haskell.Liquid.Measure -- import           Language.Haskell.Liquid.Types.RefType@@ -37,7 +37,7 @@ measureToBare = bimap (fmap specToBare) dataConToBare  dataConToBare :: DataCon -> LocSymbol-dataConToBare d = (dropModuleNames . F.symbol) <$> locNamedThing d+dataConToBare d = dropModuleNames . F.symbol <$> locNamedThing d   where     _msg  = "dataConToBare dc = " ++ show d ++ " v = " ++ show v ++ " vx = " ++ show vx     v     = dataConWorkId d@@ -83,7 +83,7 @@ txRTV cF vF (RTVar α z) = RTVar (vF α) (txRType cF vF <$> z)  txPV :: (c1 -> c2) -> (tv1 -> tv2) -> PVU c1 tv1 -> PVU c2 tv2-txPV cF vF (PV x k y txes) = PV x k' y txes'+txPV cF vF (PV sym k y txes) = PV sym k' y txes'   where     txes'                  = [ (tx t, x, e) | (t, x, e) <- txes]     k'                     = tx <$> k
src/Language/Haskell/Liquid/Bare/Typeclass.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings         #-} {-# LANGUAGE FlexibleContexts          #-}+ module Language.Haskell.Liquid.Bare.Typeclass   ( compileClasses   , elaborateClassDcp@@ -19,9 +20,9 @@ import qualified Language.Fixpoint.Misc        as Misc import           Optics import           Language.Haskell.Liquid.Bare.Elaborate-import qualified Language.Haskell.Liquid.GHC.Misc+import qualified Liquid.GHC.Misc                                                as GM-import qualified Language.Haskell.Liquid.GHC.API+import qualified Liquid.GHC.API                                                as Ghc import qualified Language.Haskell.Liquid.Misc  as Misc import           Language.Haskell.Liquid.Types@@ -45,7 +46,7 @@   -> [(ModName, Ms.BareSpec)]   -> (Ms.BareSpec, [(Ghc.ClsInst, [Ghc.Var])]) compileClasses src env (name, spec) rest =-  (spec { sigs = sigs' } <> clsSpec, instmethods)+  (spec { sigs = sigsNew } <> clsSpec, instmethods)  where   clsSpec = mempty     { dataDecls = clsDecls@@ -62,13 +63,13 @@     }   clsDecls                = makeClassDataDecl (M.toList refinedMethods)       -- class methods-  (refinedMethods, sigs') = foldr grabClassSig (mempty, mempty) (sigs spec)+  (refinedMethods, sigsNew) = foldr grabClassSig (mempty, mempty) (sigs spec)   grabClassSig     :: (F.LocSymbol, ty)     -> (M.HashMap Ghc.Class [(Ghc.Id, ty)], [(F.LocSymbol, ty)])     -> (M.HashMap Ghc.Class [(Ghc.Id, ty)], [(F.LocSymbol, ty)])-  grabClassSig sig@(lsym, ref) (refs, sigs') = case clsOp of-    Nothing         -> (refs, sig : sigs')+  grabClassSig sigPair@(lsym, ref) (refs, sigs') = case clsOp of+    Nothing         -> (refs, sigPair : sigs')     Just (cls, sig) -> (M.alter (merge sig) cls refs, sigs')    where     clsOp = do@@ -231,19 +232,19 @@     t   -- YL: is this redundant if we already have strengthenClassSel?   strengthenTy :: F.Symbol -> SpecType -> SpecType-  strengthenTy x t = mkUnivs tvs pvs (RFun z i cls (t' `RT.strengthen` mt) r)+  strengthenTy x t = mkUnivs tvs pvs (RFun z i clas (t' `RT.strengthen` mt) r)    where-    (tvs, pvs, RFun z i cls t' r) = bkUniv t+    (tvs, pvs, RFun z i clas t' r) = bkUniv t     vv = rTypeValueVar t'     mt = RT.uReft (vv, F.PAtom F.Eq (F.EVar vv) (F.EApp (F.EVar x) (F.EVar z)))   elaborateMethod :: F.Symbol -> S.HashSet F.Symbol -> SpecType -> SpecType-elaborateMethod dc methods t = mapExprReft-  (\_ -> substClassOpBinding tcbind dc methods)-  t+elaborateMethod dc methods st = mapExprReft+  (\_ -> substClassOpBinding tcbindSym dc methods)+  st  where-  tcbind = grabtcbind t+  tcbindSym = grabtcbind st   grabtcbind :: SpecType -> F.Symbol   grabtcbind t =     F.notracepp "grabtcbind"@@ -260,7 +261,7 @@ -- After: Funcctor.fmap ($p1Applicative##GHC.Base.Applicative) substClassOpBinding   :: F.Symbol -> F.Symbol -> S.HashSet F.Symbol -> F.Expr -> F.Expr-substClassOpBinding tcbind dc methods e = go e+substClassOpBinding tcbind dc methods = go  where   go :: F.Expr -> F.Expr   go (F.EApp e0 e1)@@ -309,8 +310,8 @@   = RRTy (over (each % _2) (renameTvs rename) env) r obl (renameTvs rename ty)   | RHole _ <- t   = t-   + makeClassAuxTypes ::      (SpecType -> Ghc.TcRn SpecType)   -> [F.Located DataConP]@@ -353,19 +354,19 @@     elaboratedSig  <- flip addCoherenceOblig preft <$> elab fullSig      let retSig =  mapExprReft (\_ -> substAuxMethod dfunSym methodsSet) (F.notracepp ("elaborated" ++ GM.showPpr method) elaboratedSig)-    let tysub  = F.notracepp "tysub" $ M.fromList $ zip (F.notracepp "newtype-vars" $ allTyVars' (F.notracepp "new-type" $  retSig)) (F.notracepp "ghc-type-vars" (allTyVars' ((F.notracepp "ghc-type" $ ofType (Ghc.varType method)) :: SpecType)))+    let tysub  = F.notracepp "tysub" $ M.fromList $ zip (F.notracepp "newtype-vars" $ allTyVars' (F.notracepp "new-type" retSig)) (F.notracepp "ghc-type-vars" (allTyVars' ((F.notracepp "ghc-type" $ ofType (Ghc.varType method)) :: SpecType)))         cosub  = M.fromList [ (F.symbol a, F.fObj (GM.namedLocSymbol b)) |  (a,RTV b) <- M.toList tysub]         tysubf x = F.notracepp ("cosub:" ++ F.showpp cosub) $ tysub ^. at x % non x         subbedTy = mapReft (Bare.coSubRReft cosub) (renameTvs tysubf retSig)     -- need to make the variable names consistent-    pure (method, F.dummyLoc (F.notracepp ("vars:" ++ F.showpp (F.symbol <$> allTyVars' subbedTy)) $ subbedTy))+    pure (method, F.dummyLoc (F.notracepp ("vars:" ++ F.showpp (F.symbol <$> allTyVars' subbedTy)) subbedTy))    -- "is" is used as a shorthand for instance, following the convention of the Ghc api   where     -- recsel = F.symbol ("lq$recsel" :: String)     (_,predTys,_,_) = Ghc.instanceSig inst     dfunApped = F.mkEApp dfunSymL [F.eVar $ F.vv (Just i) | (i,_) <- zip [0,1..] predTys]-    prefts  = L.reverse . take (length yts) $ fmap (F.notracepp "prefts" . Just . (flip MkUReft mempty) . mconcat) preftss ++ repeat Nothing+    prefts  = L.reverse . take (length yts) $ fmap (F.notracepp "prefts" . Just . flip MkUReft mempty . mconcat) preftss ++ repeat Nothing     preftss = F.notracepp "preftss" $ (fmap.fmap) (uncurry (GM.coherenceObligToRefE dfunApped)) (GM.buildCoherenceOblig cls)     yts' = zip (fst <$> yts) (zip (snd <$> yts) prefts)     cls = Mb.fromJust . Ghc.tyConClass_maybe $ Ghc.dataConTyCon (dcpCon dcp)@@ -398,10 +399,10 @@     clsTvs = dcpFreeTyVars dcp         -- copy/pasted from Bare/Class.hs     subst [] t = t-    subst ((a, ta):su) t = subsTyVar_meet' (a, ta) (subst su t)+    subst ((a, ta):su) t = subsTyVarMeet' (a, ta) (subst su t)  substAuxMethod :: F.Symbol -> M.HashMap F.Symbol F.Symbol -> F.Expr -> F.Expr-substAuxMethod dfun methods e = F.notracepp "substAuxMethod" $ go e+substAuxMethod dfun methods = F.notracepp "substAuxMethod" . go   where go :: F.Expr -> F.Expr         go (F.EApp e0 e1)           | F.EVar x <- F.notracepp "e0" e0
src/Language/Haskell/Liquid/Bare/Types.hs view
@@ -28,7 +28,6 @@   , 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@@ -37,8 +36,8 @@ import qualified Language.Haskell.Liquid.Types.RefType as RT  import           Language.Haskell.Liquid.Types.Types import           Language.Haskell.Liquid.Types.Specs   hiding (BareSpec)-import           Language.Haskell.Liquid.GHC.API       as Ghc hiding (Located, Env)-import           Language.Haskell.Liquid.GHC.Types     (StableName)+import           Liquid.GHC.API       as Ghc hiding (Located, Env)+import           Liquid.GHC.Types     (StableName)   type ModSpecs = M.HashMap ModName Ms.BareSpec@@ -130,7 +129,7 @@   , meDataCons    :: ![(Ghc.Var,  LocSpecType)]              , meClasses     :: ![DataConP]                              , meMethods     :: ![(ModName, Ghc.Var, LocSpecType)]  -  , meCLaws       :: !([(Ghc.Class, [(ModName, Ghc.Var, LocSpecType)])])  +  , meCLaws       :: ![(Ghc.Class, [(ModName, Ghc.Var, LocSpecType)])]     }  instance Semigroup MeasEnv where
src/Language/Haskell/Liquid/Constraint/Constraint.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances    #-}  -- TODO: what exactly is the purpose of this module? What do these functions do?@@ -36,18 +35,18 @@           (last (fst <$> xts), r))           | xts <- xss]   where-   xts      = init binds-   (xs, ts) = unzip xts+   symRts   = init binds+   (xs, ts) = unzip symRts    r        = snd $ last binds    xss      = combinations ((\t -> [(x, t) | x <- localBindsOfType t γ]) <$> ts)  subConstraintToLogicOne :: (Foldable t, Reftable r, Reftable r1)                         => t (Symbol, (Symbol, RType t1 t2 r))                         -> (Symbol, (Symbol, RType t3 t4 r1)) -> Expr-subConstraintToLogicOne xts (x', (x, t)) = PImp (pAnd rs) r+subConstraintToLogicOne xts (sym', (sym, rt)) = PImp (pAnd rs) r   where-        (rs , su) = foldl go ([], []) xts-        ([r], _ ) = go ([], su) (x', (x, t))+        (rs , symExprs) = foldl go ([], []) xts+        ([r], _ ) = go ([], symExprs) (sym', (sym, rt))         go (acc, su) (x', (x, t)) = let (Reft(v, p)) = toReft (fromMaybe mempty (stripRTypeBase t))                                         su'          = (x', EVar x):(v, EVar x) : su                                     in
src/Language/Haskell/Liquid/Constraint/Env.hs view
@@ -1,15 +1,9 @@ {-# LANGUAGE ScopedTypeVariables       #-} {-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE TypeSynonymInstances      #-} {-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE BangPatterns              #-}-{-# LANGUAGE PatternGuards             #-}-{-# LANGUAGE DeriveFunctor             #-} {-# LANGUAGE MultiParamTypeClasses     #-} {-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ImplicitParams            #-} {-# LANGUAGE PartialTypeSignatures     #-} @@ -72,9 +66,9 @@   -import           Language.Haskell.Liquid.GHC.API hiding (panic)+import           Liquid.GHC.API hiding (panic) import           Language.Haskell.Liquid.Types.RefType-import qualified Language.Haskell.Liquid.GHC.SpanStack as Sp+import qualified Liquid.GHC.SpanStack as Sp import           Language.Haskell.Liquid.Types            hiding (binds, Loc, loc, freeTyVars, Def) import           Language.Haskell.Liquid.Constraint.Types import           Language.Haskell.Liquid.Constraint.Fresh ()@@ -94,7 +88,7 @@  -- RJ: REnv-Split-Bug? filterREnv :: (SpecType -> Bool) -> REnv -> REnv-filterREnv f rE        = rE `updREnvLocal` (M.filter f)+filterREnv f rE        = rE `updREnvLocal` M.filter f  fromListREnv :: [(F.Symbol, SpecType)] -> [(F.Symbol, SpecType)] -> REnv fromListREnv gXts lXts = REnv@@ -104,10 +98,10 @@  -- RJ: REnv-Split-Bug? deleteREnv :: F.Symbol -> REnv -> REnv-deleteREnv x rE = rE `updREnvLocal` (M.delete x)+deleteREnv x rE = rE `updREnvLocal` M.delete x  insertREnv :: F.Symbol -> SpecType -> REnv -> REnv-insertREnv x y rE = {- trace ("insertREnv: " ++ show x) $ -} rE `updREnvLocal` (M.insert x y)+insertREnv x y rE = {- trace ("insertREnv: " ++ show x) $ -} rE `updREnvLocal` M.insert x y  lookupREnv :: F.Symbol -> REnv -> Maybe SpecType lookupREnv x rE = msum $ M.lookup x <$> renvMaps rE@@ -142,7 +136,7 @@ extendEnvWithVV :: CGEnv -> SpecType -> CG CGEnv -------------------------------------------------------------------------------- extendEnvWithVV γ t-  | F.isNontrivialVV vv && not (vv `memberREnv` (renv γ))+  | F.isNontrivialVV vv && not (vv `memberREnv` renv γ)   = γ += ("extVV", vv, t)   | otherwise   = return γ@@ -155,7 +149,7 @@ addBind :: SrcSpan -> F.Symbol -> F.SortedReft -> CG ((F.Symbol, F.Sort), F.BindId) addBind l x r = do   st          <- get-  let (i, bs') = F.insertBindEnv x r (binds st)+  let (i, bs') = F.insertBindEnv x r (Ci l Nothing Nothing) (binds st)   put          $ st { binds = bs' } { bindSpans = M.insert i l (bindSpans st) }   return ((x, F.sr_sort r), {- traceShow ("addBind: " ++ showpp x) -} i) @@ -169,8 +163,8 @@   γ' <- addCGEnv tx γ (eMsg, y', tyy)   addCGEnv tx γ' (eMsg, x, tyx `F.subst1` (y, F.EVar y')) -addCGEnv tx γ (eMsg, x, RAllE yy tyy tyx)-  = addCGEnv tx γ (eMsg, x, t)+addCGEnv tx γ (eMsg, sym, RAllE yy tyy tyx)+  = addCGEnv tx γ (eMsg, sym, t)   where     xs            = localBindsOfType tyy (renv γ)     t             = L.foldl' F.meet ttrue [ tyx' `F.subst1` (yy, F.EVar x) | x <- xs]@@ -182,13 +176,13 @@   let t  = tx $ normalize idx t'   let l  = getLocation γ   let γ' = γ { renv = insertREnv x t (renv γ) }-  tem   <- getTemplates +  tem   <- getTemplates   is    <- (:) <$> addBind l x (rTypeSortedReft' γ' tem t) <*> addClassBind γ' l t   return $ γ' { fenv = insertsFEnv (fenv γ) is }  rTypeSortedReft' :: (PPrint r, F.Reftable r, SubsTy RTyVar RSort r, F.Reftable (RTProp RTyCon RTyVar r))     => CGEnv -> F.Templates -> RRType r -> F.SortedReft-rTypeSortedReft' γ t +rTypeSortedReft' γ t   = pruneUnsortedReft (feEnv $ fenv γ) t . f    where    f         = rTypeSortedReft (emb γ)@@ -198,7 +192,7 @@ normalize idx = normalizeVV idx . normalizePds  normalizeVV :: Integer -> SpecType -> SpecType-normalizeVV idx t@(RApp _ _ _ _)+normalizeVV idx t@RApp{}   | not (F.isNontrivialVV (rTypeValueVar t))   = shiftVV t (F.vv $ Just idx) @@ -221,7 +215,7 @@   where     s = unlines [ eMsg ++ " Duplicate binding for " ++ F.symbolString x                 , "   New: " ++ showpp r-                , "   Old: " ++ showpp (x `lookupREnv` (renv γ)) ]+                , "   Old: " ++ showpp (x `lookupREnv` renv γ) ]  -------------------------------------------------------------------------------- globalize :: CGEnv -> CGEnv
src/Language/Haskell/Liquid/Constraint/Fresh.hs view
@@ -3,18 +3,18 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE TypeSynonymInstances  #-} {-# LANGUAGE UndecidableInstances  #-} {-# LANGUAGE BangPatterns          #-} {-# LANGUAGE ConstraintKinds       #-} +{-# OPTIONS_GHC -Wno-orphans #-}+ module Language.Haskell.Liquid.Constraint.Fresh   ( -- module Language.Haskell.Liquid.Types.Fresh     -- ,      refreshArgsTop-  , freshTy_type-  , freshTy_expr+  , freshTyType+  , freshTyExpr   , trueTy   , addKuts   )@@ -37,8 +37,8 @@ -- 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 -import           Language.Haskell.Liquid.GHC.API as Ghc+import qualified Liquid.GHC.Misc as GM+import           Liquid.GHC.API as Ghc  -------------------------------------------------------------------------------- -- | This is all hardwiring stuff to CG ----------------------------------------@@ -64,26 +64,26 @@ -- | Right now, we generate NO new pvars. Rather than clutter code --   with `uRType` calls, put it in one place where the above --   invariant is /obviously/ enforced.---   Constraint generation should ONLY use @freshTy_type@ and @freshTy_expr@+--   Constraint generation should ONLY use @freshTyType@ and @freshTyExpr@ -freshTy_type        :: Bool -> KVKind -> CoreExpr -> Type -> CG SpecType-freshTy_type allowTC k e τ  =  F.notracepp ("freshTy_type: " ++ F.showpp k ++ GM.showPpr e) -                   <$> freshTy_reftype allowTC k (ofType τ)+freshTyType        :: Bool -> KVKind -> CoreExpr -> Type -> CG SpecType+freshTyType allowTC k e τ  =  F.notracepp ("freshTyType: " ++ F.showpp k ++ GM.showPpr e)+                   <$> freshTyReftype allowTC k (ofType τ) -freshTy_expr        :: Bool -> KVKind -> CoreExpr -> Type -> CG SpecType-freshTy_expr allowTC k e _  = freshTy_reftype allowTC k $ exprRefType e+freshTyExpr        :: Bool -> KVKind -> CoreExpr -> Type -> CG SpecType+freshTyExpr allowTC k e _  = freshTyReftype allowTC k $ exprRefType e -freshTy_reftype     :: Bool -> KVKind -> SpecType -> CG SpecType-freshTy_reftype allowTC k _t = (fixTy t >>= refresh allowTC) =>> addKVars k+freshTyReftype     :: Bool -> KVKind -> SpecType -> CG SpecType+freshTyReftype allowTC k _t = (fixTy t >>= refresh allowTC) =>> addKVars k   where-    t                = {- F.tracepp ("freshTy_reftype:" ++ show k) -} _t+    t                = {- F.tracepp ("freshTyReftype:" ++ show k) -} _t  -- | Used to generate "cut" kvars for fixpoint. Typically, KVars for recursive --   definitions, and also to update the KVar profile. addKVars        :: KVKind -> SpecType -> CG () addKVars !k !t  = do-    cfg <- getConfig  <$> gets ghcI-    when (True)        $ modify $ \s -> s { kvProf = updKVProf k ks (kvProf s) }+    cfg <- gets (getConfig . ghcI)+    when True          $ modify $ \s -> s { kvProf = updKVProf k ks (kvProf s) }     when (isKut cfg k) $ addKuts k t   where     ks         = F.KS $ S.fromList $ specTypeKVars t@@ -102,7 +102,7 @@        | otherwise  = {- F.tracepp ("addKuts: " ++ showpp _x) -} ks'  specTypeKVars :: SpecType -> [F.KVar]-specTypeKVars = foldReft False (\ _ r ks -> (kvarsExpr $ F.reftPred $ ur_reft r) ++ ks) []+specTypeKVars = foldReft False (\ _ r ks -> kvarsExpr (F.reftPred $ ur_reft r) ++ ks) []  -------------------------------------------------------------------------------- trueTy  :: Bool -> Type -> CG SpecType@@ -113,8 +113,8 @@ ofType' = fixTy . ofType  fixTy :: SpecType -> CG SpecType-fixTy t = do tyi   <- tyConInfo  <$> get-             tce   <- tyConEmbed <$> get+fixTy t = do tyi   <- gets tyConInfo+             tce   <- gets tyConEmbed              return $ addTyConInfo tce tyi t  exprRefType :: CoreExpr -> SpecType
src/Language/Haskell/Liquid/Constraint/Generate.hs view
@@ -1,42 +1,36 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE DeriveFoldable            #-} {-# LANGUAGE DeriveTraversable         #-}+{-# LANGUAGE LambdaCase                #-} {-# LANGUAGE StandaloneDeriving        #-} {-# LANGUAGE ScopedTypeVariables       #-} {-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE TypeSynonymInstances      #-} {-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE TupleSections             #-}-{-# LANGUAGE BangPatterns              #-} {-# LANGUAGE PatternGuards             #-}-{-# LANGUAGE DeriveFunctor             #-} {-# LANGUAGE MultiParamTypeClasses     #-} {-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ImplicitParams            #-} +{-# OPTIONS_GHC -Wno-orphans #-}+ -- | This module defines the representation of Subtyping and WF Constraints, --   and the code for syntax-directed constraint generation.  module Language.Haskell.Liquid.Constraint.Generate ( generateConstraints, generateConstraintsWithEnv, caseEnv, consE ) where -#if !MIN_VERSION_base(4,14,0)-import Control.Monad.Fail-#endif- import           Prelude                                       hiding (error) import           GHC.Stack-import           Language.Haskell.Liquid.GHC.API                   as Ghc hiding ( panic+import           Liquid.GHC.API                   as Ghc hiding ( panic                                                                                  , checkErr                                                                                  , (<+>)                                                                                  , text                                                                                  , vcat                                                                                  )-import           Language.Haskell.Liquid.GHC.TypeRep           ()-import           Text.PrettyPrint.HughesPJ hiding ((<>)) +import           Liquid.GHC.TypeRep           ()+import           Text.PrettyPrint.HughesPJ hiding ((<>)) import           Control.Monad.State-import           Data.Maybe                                    (fromMaybe, catMaybes, isJust)+import           Data.Functor ((<&>))+import           Data.Maybe                                    (fromMaybe, catMaybes, isJust, mapMaybe) import qualified Data.HashMap.Strict                           as M import qualified Data.HashSet                                  as S import qualified Data.List                                     as L@@ -52,17 +46,18 @@ import           Language.Haskell.Liquid.Constraint.Env import           Language.Haskell.Liquid.Constraint.Monad import           Language.Haskell.Liquid.Constraint.Split+import           Language.Haskell.Liquid.Constraint.Relational (consAssmRel, consRelTop) import           Language.Haskell.Liquid.Types.Dictionaries-import           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 qualified Language.Haskell.Liquid.GHC.Misc         as GM -- ( isInternal, collectArguments, tickSrcSpan, showPpr )+import           Liquid.GHC.Play          (isHoleVar)+import qualified Liquid.GHC.Resugar           as Rs+import qualified Liquid.GHC.SpanStack         as Sp+import qualified Liquid.GHC.Misc         as GM -- ( isInternal, collectArguments, tickSrcSpan, showPpr ) import           Language.Haskell.Liquid.Misc import           Language.Haskell.Liquid.Constraint.Types import           Language.Haskell.Liquid.Constraint.Constraint import           Language.Haskell.Liquid.Transforms.Rec-import           Language.Haskell.Liquid.Transforms.CoreToLogic (weakenResult)-import           Language.Haskell.Liquid.Bare.DataType (makeDataConChecker)+import           Language.Haskell.Liquid.Transforms.CoreToLogic (weakenResult, runToLogic, coreToLogic)+import           Language.Haskell.Liquid.Bare.DataType (dataConMap, makeDataConChecker)  import           Language.Haskell.Liquid.Types hiding (binds, Loc, loc, Def) @@ -85,16 +80,20 @@  consAct :: CGEnv -> Config -> TargetInfo -> CG () consAct γ cfg info = do-  let sSpc = gsSig . giSpec $ info  +  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) +  γ' <- foldM (consCBTop cfg info) γ (giCbs gSrc)+  -- Relational Checking: the following only runs when the list of relational specs is not empty+  (ψ, γ'') <- foldM (consAssmRel cfg info) ([], γ') (gsAsmRel sSpc ++ gsRelation sSpc)+  mapM_ (consRelTop cfg info γ'' ψ) (gsRelation sSpc)+  -- End: Relational Checking+  mapM_ (consClass γ) (gsMethods $ gsSig $ giSpec info)   hcs <- gets hsCs   hws <- gets hsWfs   fcs <- concat <$> mapM (splitC (typeclass (getConfig info))) hcs   fws <- concat <$> mapM splitW hws-  modify $ \st -> st { fEnv     = feEnv (fenv γ)+  modify $ \st -> st { fEnv     = fEnv    st `mappend` feEnv (fenv γ)                      , cgLits   = litEnv   γ                      , cgConsts = cgConsts st `mappend` constEnv γ                      , fixCs    = fcs@@ -107,12 +106,12 @@ --------------------------------------------------------------------------------  consClass :: CGEnv -> (Var, MethodType LocSpecType) -> CG ()-consClass γ (x,mt) -  | Just ti <- tyInstance mt -  , Just tc <- tyClass    mt +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 () +consClass _ _+  = return ()  -------------------------------------------------------------------------------- -- | TERMINATION TYPE ----------------------------------------------------------@@ -121,7 +120,7 @@ makeDecrIndex (x, Assumed t, args)   = do dindex <- makeDecrIndexTy x t args        case dindex of-         Left _  -> return []+         Left msg -> addWarning msg >> return []          Right i -> return i makeDecrIndex (x, Asserted t, args)   = do dindex <- makeDecrIndexTy x t args@@ -131,24 +130,25 @@ makeDecrIndex _ = return []  makeDecrIndexTy :: Var -> SpecType -> [Var] -> CG (Either (TError t) [Int])-makeDecrIndexTy x t args-  = do spDecr <- specDecr <$> get-       autosz <- autoSize <$> get+makeDecrIndexTy x st args+  = do spDecr <- gets specDecr+       autosz <- gets autoSize        hint   <- checkHint' autosz (L.lookup x spDecr)        case dindex autosz of          Nothing -> return $ Left msg          Just i  -> return $ Right $ fromMaybe [i] hint     where-       ts         = ty_args trep-       tvs        = zip ts args-       checkHint' = \autosz -> checkHint x ts (isDecreasing autosz cenv)-       dindex     = \autosz -> L.findIndex (p autosz) tvs-       p autosz (t, v) = isDecreasing autosz cenv t && not (isIdTRecBound v)-       msg        = ErrTermin (getSrcSpan x) [F.pprint x] (text "No decreasing parameter")-       cenv       = makeNumEnv ts-       trep       = toRTypeRep $ unOCons t+       ts   = ty_args trep+       tvs  = zip ts args+       msg  = ErrTermin (getSrcSpan x) [F.pprint x] (text "No decreasing parameter")+       cenv = makeNumEnv ts+       trep = toRTypeRep $ unOCons st +       p autosz (t, v)   = isDecreasing autosz cenv t && not (isIdTRecBound v)+       checkHint' autosz = checkHint x ts (isDecreasing autosz cenv)+       dindex     autosz = L.findIndex (p autosz) tvs + recType :: F.Symbolic a         => S.HashSet TyCon         -> (([a], [Int]), (t, [Int], SpecType))@@ -172,7 +172,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 @@ -192,14 +192,14 @@     trep       = toRTypeRep $ unOCons t  unOCons :: RType c tv r -> RType c tv r-unOCons (RAllT v t r)      = RAllT v (unOCons t) r +unOCons (RAllT v t r)      = RAllT v (unOCons t) r unOCons (RAllP p t)        = RAllP p $ unOCons t unOCons (RFun x i tx t r)  = RFun x i (unOCons tx) (unOCons t) r unOCons (RRTy _ _ OCons t) = unOCons t unOCons t                  = t  mergecondition :: RType c tv r -> RType c tv r -> RType c tv r-mergecondition (RAllT _ t1 _) (RAllT v t2 r2)          = RAllT v (mergecondition t1 t2) r2 +mergecondition (RAllT _ t1 _) (RAllT v t2 r2)          = RAllT v (mergecondition t1 t2) r2 mergecondition (RAllP _ t1) (RAllP p t2)               = RAllP p (mergecondition t1 t2) mergecondition (RRTy xts r OCons t1) t2                = RRTy xts r OCons (mergecondition t1 t2) mergecondition (RFun _ _ t11 t12 _) (RFun x2 i t21 t22 r2) = RFun x2 i (mergecondition t11 t21) (mergecondition t12 t22) r2@@ -222,7 +222,7 @@     dx  = F.pprint x  checkHint x ts f (Just ns)-  = (mapM (checkValidHint x ts f) ns) >>= (return . Just . catMaybes)+  = mapM (checkValidHint x ts f) ns <&> (Just . catMaybes)  checkValidHint :: (NamedThing a, PPrint a, PPrint a1)                => a -> [a1] -> (a1 -> Bool) -> Int -> CG (Maybe Int)@@ -241,7 +241,7 @@ consCBLet :: CGEnv -> CoreBind -> CG CGEnv -------------------------------------------------------------------------------- consCBLet γ cb = do-  oldtcheck <- tcheck <$> get+  oldtcheck <- gets tcheck   isStr     <- doTermCheck (getConfig γ) cb   -- TODO: yuck.   modify $ \s -> s { tcheck = oldtcheck && isStr }@@ -254,16 +254,16 @@ -------------------------------------------------------------------------------- consCBTop :: Config -> TargetInfo -> CGEnv -> CoreBind -> CG CGEnv ---------------------------------------------------------------------------------consCBTop cfg info γ cb+consCBTop cfg info cgenv cb   | all (trustVar cfg info) xs-  = foldM addB γ xs+  = foldM addB cgenv xs     where        xs   = bindersOf cb        tt   = trueTy (typeclass cfg) . varType        addB γ x = tt x >>= (\t -> γ += ("derived", F.symbol x, t))  consCBTop _ _ γ cb-  = do oldtcheck <- tcheck <$> get+  = do oldtcheck <- gets tcheck        -- lazyVars  <- specLazy <$> get        isStr     <- doTermCheck (getConfig γ) cb        modify $ \s -> s { tcheck = oldtcheck && isStr}@@ -284,11 +284,11 @@ derivedVar src x = S.member x (giDerVars src)  doTermCheck :: Config -> Bind Var -> CG Bool-doTermCheck cfg bind = do -  lazyVs    <- specLazy   <$> get -  termVs    <- specTmVars <$> get+doTermCheck cfg bind = do+  lazyVs    <- gets specLazy+  termVs    <- gets specTmVars   let skip   = any (\x -> S.member x lazyVs || nocheck x) xs-  let chk    = not (structuralTerm cfg) || any (\x -> S.member x termVs) xs+  let chk    = not (structuralTerm cfg) || any (`S.member` termVs) xs   return     $ chk && not skip   where     nocheck  = if typeclass cfg then GM.isEmbeddedDictVar else GM.isInternal@@ -299,43 +299,43 @@ -- RJ: AAAAAAARGHHH!!!!!! THIS CODE IS HORRIBLE!!!!!!!!! consCBSizedTys :: CGEnv -> [(Var, CoreExpr)] -> CG CGEnv consCBSizedTys γ xes-  = do xets     <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))-       autoenv  <- autoSize <$> get-       ts       <- mapM (T.mapM refreshArgs) $ (thd3 <$> xets)-       let vs    = zipWith collectArgs ts es-       is       <- mapM makeDecrIndex (zip3 xs ts vs) >>= checkSameLens-       let xeets = (\vis -> [(vis, x) | x <- zip3 xs is $ map unTemplate ts]) <$> (zip vs is)-       (L.transpose <$> mapM checkIndex (zip4 xs vs ts is)) >>= checkEqTypes+  = do xets     <- forM xes $ \(x, e) -> fmap (x, e,) (varTemplate γ (x, Just e))+       autoenv  <- gets autoSize+       ts       <- mapM (T.mapM refreshArgs) (thd3 <$> xets)+       let vs    = zipWith collectArgs' ts es+       is       <- mapM makeDecrIndex (zip3 vars ts vs) >>= checkSameLens+       let xeets = (\vis -> [(vis, x) | x <- zip3 vars is $ map unTemplate ts]) <$> zip vs is+       _ <- mapM checkIndex (zip4 vars vs ts is) >>= checkEqTypes . L.transpose        let rts   = (recType autoenv <$>) <$> xeets-       let xts   = zip xs ts+       let xts   = zip vars ts        γ'       <- foldM extender γ xts-       let γs    = zipWith makeRecInvariants [γ' `setTRec` zip xs rts' | rts' <- rts] (filter (not . noMakeRec) <$> vs)-       let xets' = zip3 xs es ts+       let γs    = zipWith makeRecInvariants [γ' `setTRec` zip vars rts' | rts' <- rts] (filter (not . noMakeRec) <$> vs)+       let xets' = zip3 vars es ts        mapM_ (uncurry $ consBind True) (zip γs xets')        return γ'   where        noMakeRec      = if allowTC then GM.isEmbeddedDictVar else GM.isPredVar        allowTC        = typeclass (getConfig γ)-       (xs, es)       = unzip xes-       dxs            = F.pprint <$> xs-       collectArgs    = GM.collectArguments . length . ty_binds . toRTypeRep . unOCons . unTemplate+       (vars, es)     = unzip xes+       dxs            = F.pprint <$> vars+       collectArgs'   = GM.collectArguments . length . ty_binds . toRTypeRep . unOCons . unTemplate        checkEqTypes :: [[Maybe SpecType]] -> CG [[SpecType]]-       checkEqTypes x = mapM (checkAll err1 toRSort) (catMaybes <$> x)-       checkSameLens  = checkAll err2 length+       checkEqTypes x = mapM (checkAll' err1 toRSort) (catMaybes <$> x)+       checkSameLens  = checkAll' err2 length        err1           = ErrTermin loc dxs $ text "The decreasing parameters should be of same type"        err2           = ErrTermin loc dxs $ text "All Recursive functions should have the same number of decreasing parameters"-       loc            = getSrcSpan (head xs)+       loc            = getSrcSpan (head vars) -       checkAll _   _ []            = return []-       checkAll err f (x:xs)-         | all (==(f x)) (f <$> xs) = return (x:xs)+       checkAll' _   _ []            = return []+       checkAll' err f (x:xs)+         | all (== f x) (f <$> xs) = return (x:xs)          | otherwise                = addWarning err >> return []  consCBWithExprs :: CGEnv -> [(Var, CoreExpr)] -> CG CGEnv consCBWithExprs γ xes-  = do xets     <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))-       texprs    <- termExprs <$> get-       let xtes   = catMaybes $ (`lookup` texprs) <$> xs+  = do xets     <- forM xes $ \(x, e) -> fmap (x, e,) (varTemplate γ (x, Just e))+       texprs   <- gets termExprs+       let xtes  = mapMaybe (`lookup'` texprs) xs        let ts    = safeFromAsserted err . thd3 <$> xets        ts'      <- mapM refreshArgs ts        let xts   = zip xs (Asserted <$> ts')@@ -345,8 +345,8 @@        mapM_ (uncurry $ consBind True) (zip γs xets')        return γ'   where (xs, es) = unzip xes-        lookup k m | Just x <- M.lookup k m = Just (k, x)-                   | otherwise              = Nothing+        lookup' k m | Just x <- M.lookup k m = Just (k, x)+                    | otherwise              = Nothing         err      = "Constant: consCBWithExprs"  makeTermEnvs :: CGEnv -> [(Var, [F.Located F.Expr])] -> [(Var, CoreExpr)]@@ -354,19 +354,19 @@              -> [CGEnv] makeTermEnvs γ xtes xes ts ts' = setTRec γ . zip xs <$> rts   where-    vs   = zipWith collectArgs ts es-    ys   = (fst5 . bkArrowDeep) <$> ts-    ys'  = (fst5 . bkArrowDeep) <$> ts'-    sus' = zipWith mkSub ys ys'-    sus  = zipWith mkSub ys ((F.symbol <$>) <$> vs)-    ess  = (\x -> (safeFromJust (err x) $ (x `L.lookup` xtes))) <$> xs+    vs   = zipWith collectArgs' ts ces+    syms = fst5 . bkArrowDeep <$> ts+    syms' = fst5 . bkArrowDeep <$> ts'+    sus' = zipWith mkSub syms syms'+    sus  = zipWith mkSub syms ((F.symbol <$>) <$> vs)+    ess  = (\x -> safeFromJust (err x) (x `L.lookup` xtes)) <$> xs     tes  = zipWith (\su es -> F.subst su <$> es)  sus ess     tes' = zipWith (\su es -> F.subst su <$> es)  sus' ess     rss  = zipWith makeLexRefa tes' <$> (repeat <$> tes)     rts  = zipWith (addObligation OTerm) ts' <$> rss-    (xs, es)     = unzip xes+    (xs, ces)    = unzip xes     mkSub ys ys' = F.mkSubst [(x, F.EVar y) | (x, y) <- zip ys ys']-    collectArgs  = GM.collectArguments . length . ty_binds . toRTypeRep+    collectArgs' = GM.collectArguments . length . ty_binds . toRTypeRep     err x        = "Constant: makeTermEnvs: no terminating expression for " ++ GM.showPpr x  addObligation :: Oblig -> SpecType -> RReft -> SpecType@@ -382,19 +382,19 @@ -------------------------------------------------------------------------------- -- do termination checking consCB True _ γ (Rec xes)-  = do texprs <- termExprs <$> get+  = do texprs <- gets termExprs        modify $ \i -> i { recCount = recCount i + length xes }-       let xxes = catMaybes $ (`lookup` texprs) <$> xs+       let xxes = mapMaybe (`lookup'` texprs) xs        if null xxes          then consCBSizedTys γ xes          else check xxes <$> consCBWithExprs γ xes     where-      xs = fst (unzip xes)+      xs = map fst xes       check ys r | length ys == length xs = r-                 | otherwise              = panic (Just loc) $ msg+                 | otherwise              = panic (Just loc) msg       msg        = "Termination expressions must be provided for all mutually recursive binders"       loc        = getSrcSpan (head xs)-      lookup k m = (k,) <$> M.lookup k m+      lookup' k m = (k,) <$> M.lookup k m  -- don't do termination checking, but some strata checks? consCB _ False γ (Rec xes)@@ -407,7 +407,7 @@  -- don't do termination checking, and don't do any strata checks either? consCB _ _ γ (Rec xes)-  = do xets   <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))+  = do xets   <- forM xes $ \(x, e) -> fmap (x, e,) (varTemplate γ (x, Just e))        modify $ \i -> i { recCount = recCount i + length xes }        let xts = [(x, to) | (x, _, to) <- xets]        γ'     <- foldM extender (γ `setRecs` (fst <$> xts)) xts@@ -424,30 +424,30 @@   consCB _ _ γ (NonRec x _ ) | isHoleVar x && typedHoles (getConfig γ)-  = return γ +  = return γ  consCB _ _ γ (NonRec x def)   | Just (w, τ) <- grepDictionary def   , Just d      <- dlookup (denv γ) w-  = do t        <- mapM (trueTy (typeclass (getConfig γ))) τ-       mapM addW (WfC γ <$> t)-       let xts   = dmap (fmap (f t)) d+  = do st       <- mapM (trueTy (typeclass (getConfig γ))) τ+       mapM_ addW (WfC γ <$> st)+       let xts   = dmap (fmap (f st)) d        let  γ'   = γ { denv = dinsert (denv γ) x xts }        t        <- trueTy (typeclass (getConfig γ)) (varType x)        extender γ' (x, Assumed t)    where-    f [t']    (RAllT α te _) = subsTyVar_meet' (ty_var_value α, t') te-    f (t':ts) (RAllT α te _) = f ts $ subsTyVar_meet' (ty_var_value α, t') te+    f [t']    (RAllT α te _) = subsTyVarMeet' (ty_var_value α, t') te+    f (t':ts) (RAllT α te _) = f ts $ subsTyVarMeet' (ty_var_value α, t') te     f _ _ = impossible Nothing "consCB on Dictionary: this should not happen"  consCB _ _ γ (NonRec x e)   = do to  <- varTemplate γ (x, Nothing)-       to' <- consBind False γ (x, e, to) >>= (addPostTemplate γ)+       to' <- consBind False γ (x, e, to) >>= addPostTemplate γ        extender γ (x, makeSingleton γ (simplify e) <$> to')  grepDictionary :: CoreExpr -> Maybe (Var, [Type]) grepDictionary = go []-  where +  where     go ts (App (Var w) (Type t)) = Just (w, reverse (t:ts))     go ts (App e (Type t))       = go (t:ts) e     go ts (App e (Var _))        = go ts e@@ -461,24 +461,24 @@   | 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)+consBind isRec' γ (x, e, Asserted spect)   = do let γ'       = γ `setBind` x            (_,πs,_) = bkUniv spect-       γπ    <- foldM addPToEnv γ' πs+       cgenv    <- foldM addPToEnv γ' πs         -- take implcits out of the function's SpecType and into the env        let tyr = toRTypeRep spect        let spect' = fromRTypeRep (tyr { ty_ebinds = [], ty_einfo = [], ty_eargs = [], ty_erefts = [] })-       γπ <- foldM (+=) γπ $ (\(y,t)->("implicitError",y,t)) <$> zip (ty_ebinds tyr) (ty_eargs tyr)+       γπ <- foldM (+=) cgenv $ (\(y,t)->("implicitError",y,t)) <$> zip (ty_ebinds tyr) (ty_eargs tyr)         cconsE γπ e (weakenResult (typeclass (getConfig γ)) x spect')        when (F.symbol x `elemHEnv` holes γ) $          -- have to add the wf constraint here for HOLEs so we have the proper env          addW $ WfC γπ $ fmap killSubst spect-       addIdA x (defAnn isRec spect)+       addIdA x (defAnn isRec' spect)        return $ Asserted spect -consBind isRec γ (x, e, Internal spect)+consBind isRec' γ (x, e, Internal spect)   = do let γ'       = γ `setBind` x            (_,πs,_) = bkUniv spect        γπ    <- foldM addPToEnv γ' πs@@ -487,24 +487,24 @@        when (F.symbol x `elemHEnv` holes γ) $          -- have to add the wf constraint here for HOLEs so we have the proper env          addW $ WfC γπ $ fmap killSubst spect-       addIdA x (defAnn isRec spect)+       addIdA x (defAnn isRec' spect)        return $ Internal spect   where     explanation = "Cannot give singleton type to the function definition." -consBind isRec γ (x, e, Assumed spect)+consBind isRec' γ (x, e, Assumed spect)   = do let γ' = γ `setBind` x        γπ    <- foldM addPToEnv γ' πs        cconsE γπ e =<< true (typeclass (getConfig γ)) spect-       addIdA x (defAnn isRec spect)+       addIdA x (defAnn isRec' spect)        return $ Asserted spect     where πs   = ty_preds $ toRTypeRep spect -consBind isRec γ (x, e, Unknown)+consBind isRec' γ (x, e, Unknown)   = do t'    <- consE (γ `setBind` x) e        t     <- topSpecType x t'-       addIdA x (defAnn isRec t)-       when (isExportedId x) (addKuts x t)+       addIdA x (defAnn isRec' t)+       when (GM.isExternalId x) (addKuts x t)        return $ Asserted t  killSubst :: RReft -> RReft@@ -589,7 +589,7 @@       (_, Just t, _, _) -> Asserted <$> refreshArgsTop (x, t)       (_, _, _, Just t) -> Internal <$> refreshArgsTop (x, t)       (_, _, Just t, _) -> Assumed  <$> refreshArgsTop (x, t)-      (Just e, _, _, _) -> do t  <- freshTy_expr (typeclass (getConfig γ)) (RecBindE x) e (exprType e)+      (Just e, _, _, _) -> do t  <- freshTyExpr (typeclass (getConfig γ)) (RecBindE x) e (exprType e)                               addW (WfC γ t)                               Asserted <$> refreshArgsTop (x, t)       (_,      _, _, _) -> return Unknown@@ -597,7 +597,7 @@ -- | @topSpecType@ strips out the top-level refinement of "derived var" topSpecType :: Var -> SpecType -> CG SpecType topSpecType x t = do-  info  <- ghcI <$> get+  info <- gets ghcI   return $ if derivedVar (giSrc info) x then topRTypeBase t else t  --------------------------------------------------------------------------------@@ -622,8 +622,8 @@     in void $ consCBLet γ' (Rec [(x, e')])  cconsE' γ e@(Let b@(NonRec x _) ee) t-  = do sp <- specLVars <$> get-       if (x `S.member` sp)+  = do sp <- gets specLVars+       if x `S.member` sp          then cconsLazyLet γ e t          else do γ'  <- consCBLet γ b                  cconsE γ' ee t@@ -645,12 +645,12 @@        forM_ cases $ cconsCase γ' x t nonDefAlts     where        nonDefAlts = [a | (a, _, _) <- cases, a /= DEFAULT]-       _msg = "cconsE' #nonDefAlts = " ++ show (length (nonDefAlts))+       _msg = "cconsE' #nonDefAlts = " ++ show (length nonDefAlts)  cconsE' γ (Lam α e) (RAllT α' t r) | isTyVar α   = do γ' <- updateEnvironment γ α        addForAllConstraint γ' α e (RAllT α' t r)-       cconsE γ' e $ subsTyVar_meet' (ty_var_value α', rVar α) t+       cconsE γ' e $ subsTyVarMeet' (ty_var_value α', rVar α) t  cconsE' γ (Lam x e) (RFun y i ty t r)   | not (isTyVar x)@@ -664,7 +664,7 @@     r'  = r `F.subst1` (y, F.EVar x')  cconsE' γ (Tick tt e) t-  = cconsE (γ `setLocation` (Sp.Tick tt)) e t+  = cconsE (γ `setLocation` Sp.Tick tt) e t  cconsE' γ (Cast e co) t   -- See Note [Type classes with a single method]@@ -676,44 +676,47 @@        addC (SubC γ (F.notracepp ("Casted Type for " ++ GM.showPpr e ++ "\n init type " ++ showpp t) t') t) ("cconsE Cast: " ++ GM.showPpr e)  cconsE' γ (Var x) t | isHoleVar x && typedHoles (getConfig γ)-  = addHole x t γ +  = addHole x t γ  cconsE' γ e t   = do  te  <- consE γ e         te' <- instantiatePreds γ e te >>= addPost γ         addC (SubC γ te' t) ("cconsE: " ++ "\n t = " ++ showpp t ++ "\n te = " ++ showpp te ++ GM.showPpr e) -lambdaSingleton :: CGEnv -> F.TCEmb TyCon -> Var -> CoreExpr -> UReft F.Reft+lambdaSingleton :: CGEnv -> F.TCEmb TyCon -> Var -> CoreExpr -> CG (UReft F.Reft) lambdaSingleton γ tce x e-  | higherOrderFlag γ, Just e' <- lamExpr γ e-  = uTop $ F.exprReft $ F.ELam (F.symbol x, sx) e'+  | higherOrderFlag γ+  = lamExpr γ e >>= \case+      Just e' -> return $ uTop $ F.exprReft $ F.ELam (F.symbol x, sx) e'+      _ -> return mempty   where     sx = typeSort tce $ Ghc.expandTypeSynonyms $ varType x lambdaSingleton _ _ _ _-  = mempty+  = return mempty  addForAllConstraint :: CGEnv -> Var -> CoreExpr -> SpecType -> CG ()-addForAllConstraint γ _ _ (RAllT a t r)-  | F.isTauto r +addForAllConstraint γ _ _ (RAllT rtv rt rr)+  | F.isTauto rr   = return ()   | otherwise-  = do t'       <- true (typeclass (getConfig γ)) t-       let truet = RAllT a $ unRAllP t'-       addC (SubC γ (truet mempty) $ truet r) "forall constraint true"-  where unRAllP (RAllT a t r) = RAllT a (unRAllP t) r  -        unRAllP (RAllP _ t)   = unRAllP t -        unRAllP t             = t +  = do t'       <- true (typeclass (getConfig γ)) rt+       let truet = RAllT rtv $ unRAllP t'+       addC (SubC γ (truet mempty) $ truet rr) "forall constraint true"+  where unRAllP (RAllT a t r) = RAllT a (unRAllP t) r+        unRAllP (RAllP _ t)   = unRAllP t+        unRAllP t             = t addForAllConstraint γ _ _ _   = impossible (Just $ getLocation γ) "addFunctionConstraint: called on non function argument" -  + addFunctionConstraint :: CGEnv -> Var -> CoreExpr -> SpecType -> CG () addFunctionConstraint γ x e (RFun y i ty t r)   = do ty'      <- true (typeclass (getConfig γ)) ty        t'       <- true (typeclass (getConfig γ)) t        let truet = RFun y i ty' t'-       case (lamExpr γ e, higherOrderFlag γ) of-          (Just e', True) -> do tce    <- tyConEmbed <$> get+       lamE <- lamExpr γ e+       case (lamE, higherOrderFlag γ) of+          (Just e', True) -> do tce    <- gets tyConEmbed                                 let sx  = typeSort tce $ varType x                                 let ref = uTop $ F.exprReft $ F.ELam (F.symbol x, sx) e'                                 addC (SubC γ (truet ref) $ truet r)    "function constraint singleton"@@ -806,6 +809,20 @@  -- [NOTE: PLE-OPT] We *disable* refined instantiation for  -- reflected functions inside proofs.++-- If datacon definitions have references to self for fancy termination,+-- ignore them at the construction. +consE γ (Var x) | GM.isDataConId x+  = do t0 <- varRefType γ x+       -- NV: The check is expected to fail most times, so +       --     it is cheaper than direclty fmap ignoreSelf. +       let hasSelf = selfSymbol `elem` F.syms t0+       let t = if hasSelf+                then fmap ignoreSelf <$> t0+                else t0+       addLocA (Just x) (getLocation γ) (varAnn γ x t)+       return t+ consE γ (Var x)   = do t <- varRefType γ x        addLocA (Just x) (getLocation γ) (varAnn γ x t)@@ -816,17 +833,17 @@  consE γ e'@(App e a@(Type τ))   = do RAllT α te _ <- checkAll ("Non-all TyApp with expr", e) γ <$> consE γ e-       t            <- if not (nopolyinfer (getConfig γ)) && isPos α && isGenericVar (ty_var_value α) te -                         then freshTy_type (typeclass (getConfig γ)) TypeInstE e τ +       t            <- if not (nopolyinfer (getConfig γ)) && isPos α && isGenericVar (ty_var_value α) te+                         then freshTyType (typeclass (getConfig γ)) TypeInstE e τ                          else trueTy (typeclass (getConfig γ)) τ        addW          $ WfC γ t        t'           <- refreshVV t-       tt0          <- instantiatePreds γ e' (subsTyVar_meet' (ty_var_value α, t') te)+       tt0          <- instantiatePreds γ e' (subsTyVarMeet' (ty_var_value α, t') te)        let tt        = makeSingleton γ (simplify e') $ subsTyReft γ (ty_var_value α) τ tt0        case rTVarToBind α of          Just (x, _) -> return $ maybe (checkUnbound γ e' x tt a) (F.subst1 tt . (x,)) (argType τ)          Nothing     -> return tt-  where +  where     isPos α = not (extensionality (getConfig γ)) || rtv_is_pol (ty_var_info α)  consE γ e'@(App e a) | Just aDict <- getExprDict γ a@@ -843,18 +860,18 @@         addPost γ'        $ maybe (checkUnbound γ' e' x t a) (F.subst1 t . (x,)) (argExpr γ a)  consE γ e'@(App e a)-  = do ([], πs, te) <- bkUniv <$> consE γ ({- GM.tracePpr ("APP-EXPR: " ++ GM.showPpr (exprType e)) -} e)-       te'          <- instantiatePreds γ e' $ foldr RAllP te πs-       (γ', te''')  <- dropExists γ te'-       te''         <- dropConstraints γ te'''-       updateLocA (exprLoc e) te''-       (hasGhost, γ'', te''')     <- instantiateGhosts γ' te''-       let RFun x _ tx t _ = checkFun ("Non-fun App with caller ", e') γ te'''+  = do ([], πs, te) <- bkUniv <$> consE γ {- GM.tracePpr ("APP-EXPR: " ++ GM.showPpr (exprType e)) -} e+       te1        <- instantiatePreds γ e' $ foldr RAllP te πs+       (γ', te2)  <- dropExists γ te1+       te3        <- dropConstraints γ te2+       updateLocA (exprLoc e) te3+       (hasGhost, γ'', te4)     <- instantiateGhosts γ' te3+       let RFun x _ tx t _ = checkFun ("Non-fun App with caller ", e') γ te4        cconsE γ'' a tx-       tout <- makeSingleton γ'' (simplify e') <$> (addPost γ'' $ maybe (checkUnbound γ'' e' x t a) (F.subst1 t . (x,)) (argExpr γ $ simplify a))+       tout <- makeSingleton γ'' (simplify e') <$> addPost γ'' (maybe (checkUnbound γ'' e' x t a) (F.subst1 t . (x,)) (argExpr γ $ simplify a))        if hasGhost           then do-           tk   <- freshTy_type (typeclass (getConfig γ)) ImplictE e' $ exprType e'+           tk   <- freshTyType (typeclass (getConfig γ)) ImplictE e' $ exprType e'            addW $ WfC γ tk            addC (SubC γ'' tout tk) ""            return tk@@ -866,13 +883,14 @@        return $ RAllT (makeRTVar $ rTyVar α) t' mempty  consE γ  e@(Lam x e1)-  = do tx      <- freshTy_type (typeclass (getConfig γ)) LamE (Var x) τx+  = do tx      <- freshTyType (typeclass (getConfig γ)) LamE (Var x) τx        γ'      <- γ += ("consE", F.symbol x, tx)        t1      <- consE γ' e1        addIdA x $ AnnDef tx        addW     $ WfC γ tx-       tce     <- tyConEmbed <$> get-       return   $ RFun (F.symbol x) (mkRFInfo $ getConfig γ) tx t1 $ lambdaSingleton γ tce x e1+       tce     <- gets tyConEmbed+       lamSing <- lambdaSingleton γ tce x e1+       return   $ RFun (F.symbol x) (mkRFInfo $ getConfig γ) tx t1 lamSing     where       FunTy { ft_arg = τx } = exprType e @@ -880,7 +898,7 @@   = cconsFreshE LetE γ e  consE γ e@(Case _ _ _ [_])-  | Just p@(Rs.PatProject {}) <- Rs.lift e+  | Just p@Rs.PatProject{} <- Rs.lift e   = consPattern γ p (exprType e)  consE γ e@(Case _ _ _ cs)@@ -944,9 +962,9 @@ -- -------------------------------------------------------------------------------- -subsTyReft :: CGEnv -> RTyVar -> Type -> SpecType -> SpecType -subsTyReft γ a t = mapExprReft (\_ -> F.applyCoSub coSub) -  where +subsTyReft :: CGEnv -> RTyVar -> Type -> SpecType -> SpecType+subsTyReft γ a t = mapExprReft (\_ -> F.applyCoSub coSub)+  where     coSub        = M.fromList [(F.symbol a, typeSort (emb γ) t)]  --------------------------------------------------------------------------------@@ -965,8 +983,7 @@   tx <- checkMonad (msg, e1) γ <$> consE γ e1   γ' <- γ += ("consPattern", F.symbol x, tx)   addIdA x (AnnDef tx)-  mt <- consE γ' e2-  return mt+  consE γ' e2   where     msg = "This expression has a refined monadic type; run with --no-pattern-inline: " @@ -990,7 +1007,7 @@  consPattern γ (Rs.PatProject xe _ τ c ys i) _ = do   let yi = ys !! i-  t    <- (addW . WfC γ) <<= freshTy_type (typeclass (getConfig γ)) ProjectE (Var yi) τ+  t    <- (addW . WfC γ) <<= freshTyType (typeclass (getConfig γ)) ProjectE (Var yi) τ   γ'   <- caseEnv γ xe [] (DataAlt c) ys (Just [i])   ti   <- {- γ' ??= yi -} varRefType γ' yi   addC (SubC γ' ti t) "consPattern:project"@@ -999,19 +1016,19 @@ 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" +mkRAppTy :: SpecType -> SpecType -> SpecType -> SpecType+mkRAppTy mt et RAppTy{}          = RAppTy mt et mempty+mkRAppTy _  et (RApp c [_] [] _) = RApp c [et] [] mempty+mkRAppTy _  _  _                 = panic Nothing "Unexpected return-pattern"  checkMonad :: (Outputable a) => (String, a) -> CGEnv -> SpecType -> SpecType checkMonad x g = go . unRRTy  where    go (RApp _ ts [] _)-     | length ts > 0 = last ts+     | not (null ts) = last ts    go (RAppTy _ t _) = t    go t              = checkErr x g t @@ -1028,9 +1045,7 @@  castTy γ t e (SymCo (AxiomInstCo ca _ _))   = do mtc <- lookupNewType (coAxiomTyCon ca)-       case mtc of-        Just tc -> cconsE γ e tc-        Nothing -> return ()+       F.forM_ mtc (cconsE γ e)        castTy' γ t e  castTy γ t e _@@ -1038,17 +1053,17 @@   castTy' γ τ (Var x)-  = do t <- trueTy (typeclass (getConfig γ)) τ-       -- tx <- varRefType γ x -- NV HERE: the refinements of the var x do not get into the -       --                      -- environment. Check -       let ce = if typeclass (getConfig γ) && (noADT (getConfig γ)) then F.expr x-                else eCoerc (typeSort (emb γ) $ Ghc.expandTypeSynonyms $ varType x) -                       (typeSort (emb γ) τ) -                       $ F.expr x  -       return ((t `strengthen` (uTop $ F.uexprReft $ ce)) {- `F.meet` tx -})-  where eCoerc s t e +  = do t0 <- trueTy (typeclass (getConfig γ)) τ+       tx <- varRefType γ x +       let t = mergeCastTys t0 tx +       let ce = if typeclass (getConfig γ) && noADT (getConfig γ) then F.expr x+                else eCoerc (typeSort (emb γ) $ Ghc.expandTypeSynonyms $ varType x)+                       (typeSort (emb γ) τ)+                       $ F.expr x+       return (t `strengthen` uTop (F.uexprReft ce) {- `F.meet` tx -})+  where eCoerc s t e          | s == t    = e-         | otherwise = F.ECoerc s t e +         | otherwise = F.ECoerc s t e  castTy' γ t (Tick _ e)   = castTy' γ t e@@ -1056,7 +1071,25 @@ castTy' _ _ e   = panic Nothing $ "castTy cannot handle expr " ++ GM.showPpr e + {-+mergeCastTys tcorrect trefined +  tcorrect has the correct GHC skeleton, +  trefined has the correct refinements (before coercion)+  mergeCastTys keeps the trefined when the two GHC types match +-}++mergeCastTys :: SpecType -> SpecType -> SpecType +mergeCastTys t1 t2 +  | toType False t1 == toType False t2 +  = t2 +mergeCastTys (RApp c1 ts1 ps1 r1) (RApp c2 ts2 _ _) +  | c1 == c2 +  = RApp c1 (zipWith mergeCastTys ts1 ts2) ps1 r1+mergeCastTys t _ +  = t++{- showCoercion :: Coercion -> String showCoercion (AxiomInstCo co1 co2 co3)   = "AxiomInstCo " ++ showPpr co1 ++ "\t\t " ++ showPpr co2 ++ "\t\t" ++ showPpr co3 ++ "\n\n" ++@@ -1115,7 +1148,7 @@ -------------------------------------------------------------------------------- cconsFreshE :: KVKind -> CGEnv -> CoreExpr -> CG SpecType cconsFreshE kvkind γ e = do-  t   <- freshTy_type (typeclass (getConfig γ)) kvkind e $ exprType e+  t   <- freshTyType (typeclass (getConfig γ)) kvkind e $ exprType e   addW $ WfC γ t   cconsE γ e t   return t@@ -1124,7 +1157,7 @@ checkUnbound :: (Show a, Show a2, F.Subable a)              => CGEnv -> CoreExpr -> F.Symbol -> a -> a2 -> a checkUnbound γ e x t a-  | x `notElem` (F.syms t) = t+  | x `notElem` F.syms t = t   | otherwise              = panic (Just $ getLocation γ) msg   where     msg = unlines [ "checkUnbound: " ++ show x ++ " is elem of syms of " ++ show t@@ -1136,14 +1169,14 @@ dropExists γ t            = return (γ, t)  dropConstraints :: CGEnv -> SpecType -> CG SpecType-dropConstraints γ (RFun x i tx@(RApp c _ _ _) t r) | isErasable c-  = (flip (RFun x i tx)) r <$> dropConstraints γ t+dropConstraints cgenv (RFun x i tx@(RApp c _ _ _) t r) | isErasable c+  = flip (RFun x i tx) r <$> dropConstraints cgenv t   where-    isErasable = if typeclass (getConfig γ) then isEmbeddedDict else isClass-dropConstraints γ (RRTy cts _ OCons t)-  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ xts+    isErasable = if typeclass (getConfig cgenv) then isEmbeddedDict else isClass+dropConstraints cgenv (RRTy cts _ OCons rt)+  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) cgenv xts        addC (SubC  γ' t1 t2)  "dropConstraints"-       dropConstraints γ t+       dropConstraints cgenv rt   where     (xts, t1, t2) = envToSub cts @@ -1169,29 +1202,44 @@ ------------------------------------------------------------------------------------- caseEnv   :: CGEnv -> Var -> [AltCon] -> AltCon -> [Var] -> Maybe [Int] -> CG CGEnv --------------------------------------------------------------------------------------caseEnv γ x _   (DataAlt c) ys pIs = do +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+  let rt           = shiftVV xt0 x'+  tdc             <- γ ??= dataConWorkId c >>= refreshVV+  let (rtd,yts',_) = unfoldR tdc rt ys   yts             <- projectTypes (typeclass (getConfig γ))  pIs yts'   let ys''         = F.symbol <$> filter (not . if allowTC then GM.isEmbeddedDictVar else GM.isEvVar) ys   let r1           = dataConReft   c   ys''   let r2           = dataConMsReft rtd ys''-  let xt           = (xt0 `F.meet` rtd) `strengthen` (uTop (r1 `F.meet` r2))-  let cbs          = safeZip "cconsCase" (x':ys') (xt0 : yts)-  cγ'             <- addBinders γ   x' cbs-  addBinders cγ' x' [(x', xt)]+  let xt           = (xt0 `F.meet` rtd) `strengthen` uTop (r1 `F.meet` r2)+  let cbs          = safeZip "cconsCase" (x':ys')+                         (map (`F.subst1` (selfSymbol, F.EVar x'))+                         (xt0 : yts))+  cγ'             <- addBinders γ x' cbs+  addBinders cγ' x' [(x', substSelf <$> xt)]   where allowTC    = typeclass (getConfig γ)-  -caseEnv γ x acs a _ _ = do ++caseEnv γ x acs a _ _ = do   let x'  = F.symbol x   xt'    <- (`strengthen` uTop (altReft γ acs a)) <$> (γ ??= x)-  cγ     <- addBinders γ x' [(x', xt')]-  return cγ+  addBinders γ x' [(x', xt')] ++------------------------------------------------------+-- SELF special substitutions +------------------------------------------------------++substSelf :: UReft F.Reft -> UReft F.Reft+substSelf (MkUReft r p) = MkUReft (substSelfReft r) p++substSelfReft :: F.Reft -> F.Reft+substSelfReft (F.Reft (v, e)) = F.Reft (v, F.subst1 e (selfSymbol, F.EVar v))++ignoreSelf :: F.Reft -> F.Reft+ignoreSelf = F.mapExpr (\r -> if selfSymbol `elem` F.syms r then F.PTrue else r)+ -------------------------------------------------------------------------------- -- | `projectTypes` masks (i.e. true's out) all types EXCEPT those --   at given indices; it is used to simplify the environment used@@ -1199,7 +1247,7 @@ -------------------------------------------------------------------------------- projectTypes :: Bool -> Maybe [Int] -> [SpecType] -> CG [SpecType] projectTypes _ Nothing   ts = return ts-projectTypes allowTC (Just is) ts = mapM (projT is) (zip [0..] ts)+projectTypes allowTC (Just ints) ts = mapM (projT ints) (zip [0..] ts)   where     projT is (j, t)       | j `elem` is       = return t@@ -1221,10 +1269,10 @@         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') +        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'])+        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@@ -1234,27 +1282,27 @@  instantiateTys :: SpecType -> [SpecType] -> SpecType instantiateTys = L.foldl' go-  where -    go (RAllT α tbody _) t = subsTyVar_meet' (ty_var_value α, t) tbody+  where+    go (RAllT α tbody _) t = subsTyVarMeet' (ty_var_value α, t) tbody     go _ _                 = panic Nothing "Constraint.instantiateTy"  instantiatePvs :: SpecType -> [SpecProp] -> SpecType instantiatePvs           = L.foldl' go-  where +  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 _ _ t@RApp{} = t+checkTyCon x g t        = checkErr x g t  checkFun :: (Outputable a) => (String, a) -> CGEnv -> SpecType -> SpecType-checkFun _ _ t@(RFun _ _ _ _ _) = t-checkFun x g t                  = checkErr x g t+checkFun _ _ t@RFun{} = t+checkFun x g t        = checkErr x g t  checkAll :: (Outputable a) => (String, a) -> CGEnv -> SpecType -> SpecType-checkAll _ _ t@(RAllT _ _ _)  = t-checkAll x g t                = checkErr x g t+checkAll _ _ t@RAllT{} = t+checkAll x g t         = checkErr x g t  checkErr :: (Outputable a) => (String, a) -> CGEnv -> SpecType -> SpecType checkErr (msg, e) γ t         = panic (Just sp) $ msg ++ GM.showPpr e ++ ", type: " ++ showpp t@@ -1270,10 +1318,10 @@ -- | Helpers: Creating Fresh Refinement ------------------------------- ----------------------------------------------------------------------- freshPredRef :: CGEnv -> CoreExpr -> PVar RSort -> CG SpecProp-freshPredRef γ e (PV _ (PVProp τ) _ as)-  = do t    <- freshTy_type (typeclass (getConfig γ))  PredInstE e (toType False τ)-       args <- mapM (\_ -> fresh) as-       let targs = [(x, s) | (x, (s, y, z)) <- zip args as, (F.EVar y) == z ]+freshPredRef γ e (PV _ (PVProp rsort) _ as)+  = do t    <- freshTyType (typeclass (getConfig γ))  PredInstE e (toType False rsort)+       args <- mapM (const fresh) as+       let targs = [(x, s) | (x, (s, y, z)) <- zip args as, F.EVar y == z ]        γ' <- foldM (+=) γ [("freshPredRef", x, ofRSort τ) | (x, τ) <- targs]        addW $ WfC γ' t        return $ RProp targs t@@ -1303,29 +1351,18 @@ argExpr _ (Var v)     = Just $ F.eVar v argExpr γ (Lit c)     = snd  $ literalConst (emb γ) c argExpr γ (Tick _ e)  = argExpr γ e-argExpr γ (App e (Type _)) = argExpr γ e +argExpr γ (App e (Type _)) = argExpr γ e argExpr _ _           = Nothing  --- NIKI TODO: merge arg/lam/fun-Expr-lamExpr :: CGEnv -> CoreExpr -> Maybe F.Expr-lamExpr _ (Var v)     =  Just $ F.eVar v-lamExpr γ (Lit c)     = snd  $ literalConst (emb γ) c-lamExpr γ (Tick _ e)  = lamExpr γ e-lamExpr γ (App e (Type _)) = lamExpr γ e-lamExpr γ (App e1 e2) = case (lamExpr γ e1, lamExpr γ e2) of-                              (Just p1, Just p2) | not ((if allowTC then GM.isEmbeddedDictExpr else GM.isPredExpr) e2) -- (isClassPred $ exprType e2)-                                                 -> Just $ F.EApp p1 p2-                              (Just p1, Just _ ) -> Just p1-                              _  -> Nothing-  where allowTC = typeclass (getConfig γ)-lamExpr γ (Let (NonRec x ex) e) = case (lamExpr γ ex, lamExpr γ e) of-                                       (Just px, Just p) -> Just (p `F.subst1` (F.symbol x, px))-                                       _  -> Nothing-lamExpr γ (Lam x e)   = case lamExpr γ e of-                            Just p -> Just $ F.ELam (F.symbol x, typeSort (emb γ) $ Ghc.expandTypeSynonyms $ varType x) p-                            _ -> Nothing-lamExpr _ _           = Nothing+lamExpr :: CGEnv -> CoreExpr -> CG (Maybe F.Expr)+lamExpr g e = do+    adts <- gets cgADTs+    allowTC <- gets cgiTypeclass+    let dm = dataConMap adts+    case runToLogic (emb g) mempty dm (\x -> todo Nothing ("coreToLogic not working lamExpr: " ++ x)) (coreToLogic allowTC e) of+               Left  _  -> return Nothing+               Right ce -> return (Just ce)  -------------------------------------------------------------------------------- (??=) :: (?callStack :: CallStack) => CGEnv -> Var -> CG SpecType@@ -1342,20 +1379,19 @@ -------------------------------------------------------------------------------- varRefType :: (?callStack :: CallStack) => CGEnv -> Var -> CG SpecType ---------------------------------------------------------------------------------varRefType γ x = do-  xt <- varRefType' γ x <$> (γ ??= x)-  return xt -- F.tracepp (printf "varRefType x = [%s]" (showpp x))+varRefType γ x =+  varRefType' γ x <$> (γ ??= x) -- F.tracepp (printf "varRefType x = [%s]" (showpp x))  varRefType' :: CGEnv -> Var -> SpecType -> SpecType varRefType' γ x t'   | Just tys <- trec γ, Just tr  <- M.lookup x' tys-  = strengthen tr xr+  = strengthen' tr xr   | otherwise-  = strengthen t' xr+  = strengthen' t' xr   where     xr = singletonReft x     x' = F.symbol x-    strengthen+    strengthen'       | higherOrderFlag γ       = strengthenMeet       | otherwise@@ -1363,26 +1399,26 @@  -- | create singleton types for function application makeSingleton :: CGEnv -> CoreExpr -> SpecType -> SpecType-makeSingleton γ e t-  | higherOrderFlag γ, App f x <- simplify e+makeSingleton γ cexpr t+  | higherOrderFlag γ, App f x <- simplify cexpr   = case (funExpr γ f, argForAllExpr x) of       (Just f', Just x')-                 | not (if (typeclass (getConfig γ)) then GM.isEmbeddedDictExpr x else GM.isPredExpr x) -- (isClassPred $ exprType x)+                 | not (if typeclass (getConfig γ) then GM.isEmbeddedDictExpr x else GM.isPredExpr x) -- (isClassPred $ exprType x)                  -> strengthenMeet t (uTop $ F.exprReft (F.EApp f' x'))       (Just f', Just _)                  -> strengthenMeet t (uTop $ F.exprReft f')       _ -> t   | rankNTypes (getConfig γ)-  = case argExpr γ (simplify e) of -       Just e' -> strengthenMeet t $ (uTop $ F.exprReft e')-       _       -> t  +  = case argExpr γ (simplify cexpr) of+       Just e' -> strengthenMeet t $ uTop (F.exprReft e')+       _       -> t   | otherwise   = t-  where +  where     argForAllExpr (Var x)       | rankNTypes (getConfig γ)       , Just e <- M.lookup x (forallcb γ)-      = Just e +      = Just e     argForAllExpr e       = argExpr γ e @@ -1390,7 +1426,7 @@  funExpr :: CGEnv -> CoreExpr -> Maybe F.Expr -funExpr _ (Var v) +funExpr _ (Var v)   = Just $ F.EVar (F.symbol v)  funExpr γ (App e1 e2)@@ -1408,7 +1444,7 @@ simplify (Tick _ e)       = simplify e simplify (App e (Type _)) = simplify e simplify (App e1 e2)      = App (simplify e1) (simplify e2)-simplify (Lam x e) | isTyVar x = simplify e +simplify (Lam x e) | isTyVar x = simplify e simplify e                = e  @@ -1452,8 +1488,8 @@  -- | @isGenericVar@ determines whether the @RTyVar@ has no class constraints isGenericVar :: RTyVar -> SpecType -> Bool-isGenericVar α t =  all (\(c, α') -> (α'/=α) || isGenericClass c ) (classConstrs t)-  where +isGenericVar α st =  all (\(c, α') -> (α'/=α) || isGenericClass c ) (classConstrs st)+  where     classConstrs t = [(c, ty_var_value α')                         | (c, ts) <- tyClasses t                         , t'      <- ts@@ -1463,5 +1499,5 @@ -- instance MonadFail CG where  --  fail msg = panic Nothing msg -instance MonadFail Data.Functor.Identity.Identity where +instance MonadFail Data.Functor.Identity.Identity where   fail msg = panic Nothing msg
src/Language/Haskell/Liquid/Constraint/Init.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE ScopedTypeVariables       #-} {-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE TypeSynonymInstances      #-} {-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE TupleSections             #-}@@ -17,7 +16,7 @@  import           Prelude                                       hiding (error, undefined) import           Control.Monad.State-import           Data.Maybe                                    (isNothing, fromMaybe, catMaybes)+import           Data.Maybe                                    (isNothing, fromMaybe, catMaybes, mapMaybe) import qualified Data.HashMap.Strict                           as M import qualified Data.HashSet                                  as S import qualified Data.List                                     as L@@ -28,9 +27,9 @@ import           Language.Haskell.Liquid.Constraint.Fresh import           Language.Haskell.Liquid.Constraint.Env import           Language.Haskell.Liquid.WiredIn               (dictionaryVar)-import qualified Language.Haskell.Liquid.GHC.SpanStack         as Sp-import           Language.Haskell.Liquid.GHC.Misc             ( idDataConM, hasBaseTypeVar, isDataConId) -- dropModuleNames, simplesymbol)-import           Language.Haskell.Liquid.GHC.API               as Ghc hiding (mapSndM)+import qualified Liquid.GHC.SpanStack         as Sp+import           Liquid.GHC.Misc             ( idDataConM, hasBaseTypeVar, isDataConId) -- dropModuleNames, simplesymbol)+import           Liquid.GHC.API               as Ghc hiding (mapSndM) import           Language.Haskell.Liquid.Misc import           Language.Fixpoint.Misc import           Language.Haskell.Liquid.Constraint.Types@@ -45,7 +44,7 @@        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 allowTC $ varType x)+       defaults <- forM fVars $ \x -> fmap (x,) (trueTy allowTC $ varType x)        dcsty    <- forM dcs   (makeDataConTypes allowTC)        dcsty'   <- forM dcs'  (makeDataConTypes allowTC)        (hs,f0)  <- refreshHoles allowTC $ grty info                           -- asserted refinements     (for defined vars)@@ -55,60 +54,60 @@        f1'      <- refreshArgs' $ makeExactDc dcsty                   -- data constructors        f2       <- refreshArgs' $ assm info                           -- assumed refinements      (for imported vars)        f3'      <- refreshArgs' =<< recSelectorsTy info                      -- assumed refinements      (for record selectors)-       f3       <- addPolyInfo' <$> (refreshArgs' $ vals gsAsmSigs (gsSig sp))                 -- assumed refinedments     (with `assume`)-       f40      <- makeExactDc <$> (refreshArgs' $ vals gsCtors (gsData sp)) -- constructor refinements  (for measures)+       f3       <- addPolyInfo' <$> refreshArgs' (vals gsAsmSigs (gsSig sp))                 -- assumed refinedments     (with `assume`)+       f40      <- makeExactDc <$> refreshArgs' (vals gsCtors (gsData sp)) -- constructor refinements  (for measures)        f5       <- refreshArgs' $ vals gsInSigs (gsSig sp)                   -- internal refinements     (from Haskell measures)        fi       <- refreshArgs' $ catMaybes $ [(x,) . val <$> getMethodType mt | (x, mt) <- gsMethods $ gsSig $ giSpec info ]        (invs1, f41) <- mapSndM refreshArgs' $ makeAutoDecrDataCons dcsty  (gsAutosize (gsTerm sp)) dcs        (invs2, f42) <- mapSndM refreshArgs' $ makeAutoDecrDataCons dcsty' (gsAutosize (gsTerm sp)) dcs'        let f4    = mergeDataConTypes tce (mergeDataConTypes tce f40 (f41 ++ f42)) (filter (isDataConId . fst) f2)        let tx    = mapFst F.symbol . addRInv ialias . predsUnify sp-       f6       <- (map tx . addPolyInfo') <$> (refreshArgs' $ vals gsRefSigs (gsSig sp))  +       f6       <- map tx . addPolyInfo' <$> refreshArgs' (vals gsRefSigs (gsSig sp))        let bs    = (tx <$> ) <$> [f0 ++ f0' ++ fi, f1 ++ f1', f2, f3 ++ f3', f4, f5]        modify $ \s -> s { dataConTys = f4 }-       lt1s     <- F.toListSEnv . cgLits <$> get+       lt1s     <- gets (F.toListSEnv . cgLits)        let lt2s  = [ (F.symbol x, rTypeSort tce t) | (x, t) <- f1' ]        let tcb   = mapSnd (rTypeSort tce) <$> concat bs        let cbs   = giCbs . giSrc $ info-       rTrue   <- mapM (mapSndM (true allowTC)) f6 +       rTrue   <- mapM (mapSndM (true allowTC)) f6        let γ0    = measEnv sp (head bs) cbs tcb lt1s lt2s (f6 ++ bs!!3) (bs!!5) hs info-       γ  <- globalize <$> foldM (+=) γ0 ( [("initEnv", x, y) | (x, y) <- concat $ (rTrue:tail bs)])+       γ  <- globalize <$> foldM (+=) γ0 ( [("initEnv", x, y) | (x, y) <- concat (rTrue:tail bs)])        return γ {invs = is (invs1 ++ invs2)}   where-    allowTC        = typeclass (getConfig info)+    allowTC      = typeclass (getConfig info)     sp           = giSpec info     ialias       = mkRTyConIAl (gsIaliases (gsData sp))     vals f       = map (mapSnd val) . f-    mapSndM f    = \(x,y) -> ((x,) <$> f y)-    makeExactDc dcs = if exactDCFlag info then map strengthenDataConType dcs else dcs     is autoinv   = mkRTyConInv    (gsInvariants (gsData sp) ++ ((Nothing,) <$> autoinv))-    addPolyInfo' = if reflection (getConfig info) then map (mapSnd addPolyInfo) else id +    addPolyInfo' = if reflection (getConfig info) then map (mapSnd addPolyInfo) else id +    makeExactDc dcs = if exactDCFlag info then map strengthenDataConType dcs else dcs+ addPolyInfo :: SpecType -> SpecType-addPolyInfo t = mkUnivs (go <$> as) ps t' -  where -    (as, ps, t') = bkUniv t -    pos          = tyVarsPosition t' -    go (a,r) = if {- ty_var_value a `elem` ppos pos && -}  ty_var_value a `notElem` pneg pos -               then (setRtvPol a False,r)  -               else (a,r) +addPolyInfo t = mkUnivs (go <$> as) ps t'+  where+    (as, ps, t') = bkUniv t+    pos          = tyVarsPosition t'+    go (a,r) = if {- ty_var_value a `elem` ppos pos && -}  ty_var_value a `notElem` pneg pos+               then (setRtvPol a False,r)+               else (a,r)  makeDataConTypes :: Bool -> Var -> CG (Var, SpecType)-makeDataConTypes allowTC x = (x,) <$> (trueTy allowTC $ varType x)+makeDataConTypes allowTC x = (x,) <$> trueTy allowTC (varType x)  makeAutoDecrDataCons :: [(Id, SpecType)] -> S.HashSet TyCon -> [Id] -> ([LocSpecType], [(Id, SpecType)]) makeAutoDecrDataCons dcts specenv dcs-  = (simplify invs, tys)+  = (simplify rsorts, tys)   where-    (invs, tys) = unzip $ concatMap go tycons-    tycons      = L.nub $ catMaybes $ map idTyCon dcs+    (rsorts, tys) = unzip $ concatMap go tycons+    tycons      = L.nub $ mapMaybe idTyCon dcs      go tycon       | S.member tycon specenv =  zipWith (makeSizedDataCons dcts) (tyConDataCons tycon) [0..]     go _       = [] -    simplify invs = dummyLoc . (`strengthen` invariant) .  fmap (\_ -> mempty) <$> L.nub invs+    simplify invs = dummyLoc . (`strengthen` invariant) .  fmap (const mempty) <$> L.nub invs     invariant = MkUReft (F.Reft (F.vv_, F.PAtom F.Ge (lenOf F.vv_) (F.ECon $ F.I 0)) ) mempty  idTyCon :: Id -> Maybe TyCon@@ -121,11 +120,11 @@ makeSizedDataCons dcts x' n = (toRSort $ ty_res trep, (x, fromRTypeRep trep{ty_res = tres}))     where       x      = dataConWorkId x'-      t      = fromMaybe (impossible Nothing "makeSizedDataCons: this should never happen") $ L.lookup x dcts-      trep   = toRTypeRep t+      st     = fromMaybe (impossible Nothing "makeSizedDataCons: this should never happen") $ L.lookup x dcts+      trep   = toRTypeRep st       tres   = ty_res trep `strengthen` MkUReft (F.Reft (F.vv_, F.PAtom F.Eq (lenOf F.vv_) computelen)) mempty -      recarguments = filter (\(t,_) -> (toRSort t == toRSort tres)) (zip (ty_args trep) (ty_binds trep))+      recarguments = filter (\(t,_) -> toRSort t == toRSort tres) (zip (ty_args trep) (ty_binds trep))       computelen   = foldr (F.EBin F.Plus) (F.ECon $ F.I n) (lenOf .  snd <$> recarguments)  mergeDataConTypes ::  F.TCEmb TyCon -> [(Var, SpecType)] -> [(Var, SpecType)] -> [(Var, SpecType)]@@ -208,7 +207,7 @@ assm = assmGrty (giImpVars . giSrc)  grty :: TargetInfo -> [(Var, SpecType)]-grty = assmGrty (giDefVars . giSrc) +grty = assmGrty (giDefVars . giSrc)  assmGrty :: (TargetInfo -> [Var]) -> TargetInfo -> [(Var, SpecType)] assmGrty f info = [ (x, val t) | (x, t) <- sigs, x `S.member` xs ]@@ -224,9 +223,9 @@     isTop v      = isExportedVar (giSrc info) v && not (v `S.member` sigVs) &&  isRecordSelector v     sigVs        = S.fromList [v | (v,_) <- gsTySigs sp ++ gsAsmSigs sp ++ gsRefSigs sp ++ gsInSigs sp]     sp           = gsSig . giSpec $ info-      + grtyTop :: TargetInfo -> CG [(Var, SpecType)] grtyTop info     = forM topVs $ \v -> (v,) <$> trueTy (typeclass (getConfig info)) (varType v)   where@@ -269,9 +268,10 @@   , termExprs  = M.fromList [(v, es) | (v, _, es) <- gsTexprs (gsSig spc) ]   , specDecr   = gsDecr  tspc   , specLVars  = gsLvars (gsVars spc)-  , specLazy   = dictionaryVar `S.insert` (gsLazy tspc)+  , specLazy   = dictionaryVar `S.insert` gsLazy tspc   , specTmVars = gsNonStTerm tspc   , tcheck     = terminationCheck cfg+  , cgiTypeclass = typeclass cfg   , pruneRefs  = pruneUnsorted cfg   , logErrors  = []   , kvProf     = emptyKVProf@@ -283,7 +283,7 @@   , unsorted   = F.notracepp "UNSORTED" $ F.makeTemplates $ gsUnsorted $ gsData spc   }   where-    tce        = gsTcEmbeds nspc +    tce        = gsTcEmbeds nspc     tspc       = gsTerm spc     spc        = giSpec info     tyi        = gsTyconEnv nspc
src/Language/Haskell/Liquid/Constraint/Monad.hs view
@@ -1,10 +1,7 @@ -- | This module contains various functions that add/update in the CG monad. -{-# LANGUAGE TupleSections             #-} {-# LANGUAGE BangPatterns              #-}-{-# LANGUAGE PatternGuards             #-} {-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE ImplicitParams            #-} {-# LANGUAGE FlexibleContexts          #-}  module Language.Haskell.Liquid.Constraint.Monad  where@@ -13,14 +10,14 @@ import qualified Data.Text           as T  import           Control.Monad-import           Control.Monad.State (get, modify)+import           Control.Monad.State (get, gets, modify) import           Language.Haskell.Liquid.Types hiding (loc) import           Language.Haskell.Liquid.Constraint.Types import           Language.Haskell.Liquid.Constraint.Env import           Language.Fixpoint.Misc hiding (errorstar)-import           Language.Haskell.Liquid.GHC.Misc -- (concatMapM)-import           Language.Haskell.Liquid.GHC.SpanStack (srcSpan)-import           Language.Haskell.Liquid.GHC.API as Ghc hiding (panic, showPpr)+import           Liquid.GHC.Misc -- (concatMapM)+import           Liquid.GHC.SpanStack (srcSpan)+import           Liquid.GHC.API as Ghc hiding (panic, showPpr)  -------------------------------------------------------------------------------- -- | `addC` adds a subtyping constraint into the global pool.@@ -29,11 +26,11 @@ -------------------------------------------------------------------------------- addC c@(SubC γ t1 t2) _msg   | toType False t1 /= toType False t2-  = panic (Just $ getLocation γ) $ "addC: malformed constraint:\n" ++ _msg ++ showpp t1 ++ "\n <: \n" ++ showpp t2 +  = panic (Just $ getLocation γ) $ "addC: malformed constraint:\n" ++ _msg ++ showpp t1 ++ "\n <: \n" ++ showpp t2   | otherwise-  = modify $ \s -> s { hsCs  = c : (hsCs s) }- +  = modify $ \s -> s { hsCs  = c : hsCs s } + addC c _msg   = modify $ \s -> s { hsCs  = c : hsCs s } @@ -42,29 +39,29 @@ -------------------------------------------------------------------------------- addPost :: CGEnv -> SpecType -> CG SpecType ---------------------------------------------------------------------------------addPost γ (RRTy e r OInv t)-  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("addPost", x,t)) γ e-       addC (SubR γ' OInv r) "precondition-oinv" >> return t+addPost cgenv (RRTy e r OInv rt)+  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("addPost", x,t)) cgenv e+       addC (SubR γ' OInv r) "precondition-oinv" >> return rt -addPost γ (RRTy e r OTerm t)-  = do γ' <- foldM (\γ (x, t) -> γ += ("addPost", x, t)) γ e-       addC (SubR γ' OTerm r) "precondition-oterm" >> return t+addPost cgenv (RRTy e r OTerm rt)+  = do γ' <- foldM (\γ (x, t) -> γ += ("addPost", x, t)) cgenv e+       addC (SubR γ' OTerm r) "precondition-oterm" >> return rt -addPost γ (RRTy cts _ OCons t)-  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ xts+addPost cgenv (RRTy cts _ OCons rt)+  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) cgenv xts        addC (SubC  γ' t1 t2)  "precondition-ocons"-       addPost γ t+       addPost cgenv rt   where     (xts, t1, t2) = envToSub cts-addPost _ t -  = return t +addPost _ t+  = return t  -------------------------------------------------------------------------------- -- | Add Well formedness Constraint -------------------------------------------------------------------------------- addW   :: WfC -> CG () ---------------------------------------------------------------------------------addW !w = modify $ \s -> s { hsWfs = w : (hsWfs s) }+addW !w = modify $ \s -> s { hsWfs = w : hsWfs s }  -------------------------------------------------------------------------------- -- | Add a warning@@ -93,14 +90,14 @@  -- | Used for annotating holes  -addHole :: Var -> SpecType -> CGEnv -> CG () -addHole x t γ -  | typedHoles (getConfig γ) = -      do  st <- get +addHole :: Var -> SpecType -> CGEnv -> CG ()+addHole x t γ+  | typedHoles (getConfig γ) =+      do  st <- get           modify $ \s -> s {holesMap = M.insert x (hinfo (st, γ)) $ holesMap s}           -- addWarning $ ErrHole loc ("hole found") (reGlobal env <> reLocal env) x' t    | otherwise = return ()-    where +    where       hinfo = HoleInfo t loc env       loc   = srcSpan $ cgLoc γ       env   = mconcat [renv γ, grtys γ, assms γ, intys γ]@@ -129,7 +126,7 @@  lookupNewType :: Ghc.TyCon -> CG (Maybe SpecType) lookupNewType tc-  = M.lookup tc . newTyEnv <$> get+  = gets (M.lookup tc . newTyEnv)   --------------------------------------------------------------------------------
src/Language/Haskell/Liquid/Constraint/Qualifier.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE ViewPatterns          #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE FlexibleContexts      #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}  module Language.Haskell.Liquid.Constraint.Qualifier-  ( giQuals +  ( giQuals   , useSpcQuals   )   where@@ -19,10 +19,10 @@ import qualified Language.Fixpoint.Types.Config as FC import           Language.Fixpoint.SortCheck import           Language.Haskell.Liquid.Types.RefType-import           Language.Haskell.Liquid.GHC.Misc         (getSourcePos)+import           Liquid.GHC.Misc         (getSourcePos) import           Language.Haskell.Liquid.Misc             (condNull) import           Language.Haskell.Liquid.Types.PredType-import           Language.Haskell.Liquid.GHC.API hiding (Expr, mkQual, panic)+import           Liquid.GHC.API hiding (Expr, mkQual, panic)  import           Language.Haskell.Liquid.Types @@ -62,7 +62,7 @@ useAlsQuals i = useQuals i && i `hasOpt` higherOrderFlag && not (needQuals i)  useQuals :: (HasConfig t) => t -> Bool-useQuals = not . (FC.All == ) . eliminate . getConfig+useQuals = (FC.All /=) . eliminate . getConfig  needQuals :: (HasConfig t) => t -> Bool needQuals = (FC.None == ) . eliminate . getConfig@@ -106,18 +106,18 @@ qualifyingBinders :: TargetInfo -> S.HashSet Var qualifyingBinders info = S.difference sTake sDrop   where-    sTake              = S.fromList $ giDefVars src ++ giUseVars src ++ scrapeVars cfg src +    sTake              = S.fromList $ giDefVars src ++ giUseVars src ++ scrapeVars cfg src     sDrop              = S.fromList $ specAxiomVars info-    cfg                = getConfig info -    src                = giSrc     info -    +    cfg                = getConfig info+    src                = giSrc     info+ -- NOTE: this mines extra, useful qualifiers but causes -- a significant increase in running time, so we hide it -- behind `--scrape-imports` and `--scrape-used-imports` scrapeVars :: Config -> TargetSrc -> [Var]-scrapeVars cfg src -  | cfg `hasOpt` scrapeUsedImports = giUseVars src -  | cfg `hasOpt` scrapeImports     = giImpVars src +scrapeVars cfg src+  | cfg `hasOpt` scrapeUsedImports = giUseVars src+  | cfg `hasOpt` scrapeImports     = giImpVars src   | otherwise                      = []  specBinders :: TargetInfo -> [(Var, LocSpecType)]@@ -162,7 +162,7 @@     goBind x t γ t'           = go (add x t γ) t'     go γ t@(RVar _ _)         = scrape γ t     go γ (RAllT _ t _)        = go γ t-    go γ (RAllP p t)          = go (insertSEnv (pname p) (rTypeSort tce $ (pvarRType p :: RSort)) γ) t+    go γ (RAllP p t)          = go (insertSEnv (pname p) (rTypeSort tce (pvarRType p :: RSort)) γ) t     go γ t@(RAppTy t1 t2 _)   = go γ t1 ++ go γ t2 ++ scrape γ t     go γ (RFun x _ t t' _)    = go γ t ++ goBind x t γ t'     go γ t@(RApp c ts rs _)   = scrape γ t ++ concatMap (go γ') ts ++ goRefs c γ' rs@@ -189,7 +189,7 @@                    , pa                        <- conjuncts ra                    , not $ isHole    pa                    , not $ isGradual pa-                   , notracepp ("refTopQuals: " ++ showpp pa) +                   , notracepp ("refTopQuals: " ++ showpp pa)                      $ isNothing $ checkSorted (srcSpan l) (insertSEnv v so γ') pa     ]     ++
+ src/Language/Haskell/Liquid/Constraint/Relational.hs view
@@ -0,0 +1,791 @@+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE PatternGuards              #-}+{-# LANGUAGE ScopedTypeVariables        #-}++-- | This module defines the representation of Subtyping and WF Constraints,+--   and the code for syntax-directed constraint generation.++module Language.Haskell.Liquid.Constraint.Relational (consAssmRel, consRelTop) where++import           Control.Monad.State+import           Data.Bifunctor                                 ( Bifunctor(bimap) )+import qualified Data.HashMap.Strict                            as M+import qualified Data.List                                      as L+import           Data.String                                    ( IsString(..) )+import qualified Language.Fixpoint.Types                        as F+import qualified Language.Fixpoint.Types.Visitor                as F+import           Language.Haskell.Liquid.Constraint.Env+import           Language.Haskell.Liquid.Constraint.Fresh+import           Language.Haskell.Liquid.Constraint.Monad+import           Language.Haskell.Liquid.Constraint.Types+import           Liquid.GHC.API                 ( Alt+                                                , AltCon(..)+                                                , Bind(..)+                                                , CoreBind+                                                , CoreBndr+                                                , CoreExpr+                                                , Expr(..)+                                                , Type(..)+                                                , TyVar+                                                , Var(..))+import qualified Liquid.GHC.API                as Ghc+import qualified Liquid.GHC.Misc               as GM+import           Liquid.GHC.Play               (Subable(sub, subTy))+import qualified Liquid.GHC.SpanStack          as Sp+import           Liquid.GHC.TypeRep            ()+import           Language.Haskell.Liquid.Misc+import           Language.Haskell.Liquid.Types                  hiding (Def,+                                                                 Loc, binds,+                                                                 loc)+import           System.Console.CmdArgs.Verbosity               (whenLoud)+import           System.IO.Unsafe                               (unsafePerformIO)++data RelPred+  = RelPred { fun1 :: Var+            , fun2 :: Var+            , args1 :: [(F.Symbol, [F.Symbol])]+            , args2 :: [(F.Symbol, [F.Symbol])]+            , prop :: RelExpr+            } deriving Show++type PrEnv = [RelPred]++consAssmRel :: Config -> TargetInfo -> (PrEnv, CGEnv) -> (Var, Var, LocSpecType, LocSpecType, RelExpr, RelExpr) -> CG (PrEnv, CGEnv)+consAssmRel _ _ (ψ, γ) (x, y, t, s, _, rp) = traceChk "Assm" x y t s p $ do+  traceWhenLoud ("ASSUME " ++ F.showpp (fromRelExpr p', p)) $ subUnarySig γ' x t'+  subUnarySig γ' y s'+  γ'' <- if base t' && base s'+    then γ' `addPred` F.subst+      (F.mkSubst [(resL, F.EVar $ F.symbol x), (resR, F.EVar $ F.symbol y)])+      (fromRelExpr rp)+    else return γ'+  return (RelPred x' y' bs cs rp : ψ, γ'')+ where+    p = fromRelExpr rp+    γ' = γ `setLocation` Sp.Span (GM.fSrcSpan (F.loc t))+    (x', y') = mkRelCopies x y+    t' = val t+    s' = val s+    (vs, ts) = vargs t'+    (us, ss) = vargs s'+    bs = zip vs (fst . vargs <$> ts)+    cs = zip us (fst . vargs <$> ss)+    p' = L.foldl (\q (v, u) -> unapplyRelArgsR v u q) rp (zip vs us)++consRelTop :: Config -> TargetInfo -> CGEnv -> PrEnv -> (Var, Var, LocSpecType, LocSpecType, RelExpr, RelExpr) -> CG ()+consRelTop _ ti γ ψ (x, y, t, s, ra, rp) = traceChk "Init" e d t s p $ do+  subUnarySig γ' x t'+  subUnarySig γ' y s'+  consRelCheckBind γ' ψ e d t' s' ra rp+  where+    p = fromRelExpr rp+    γ' = γ `setLocation` Sp.Span (GM.fSrcSpan (F.loc t))+    cbs = giCbs $ giSrc ti+    e = lookupBind x cbs+    d = lookupBind y cbs+    t' = removeAbsRef $ val t+    s' = removeAbsRef $ val s++removeAbsRef :: SpecType -> SpecType+removeAbsRef (RVar v (MkUReft r _)) +  = out+    where +      r' = MkUReft r mempty+      out = RVar  v r' +removeAbsRef (RFun  b i s t (MkUReft r _))  +  = out+    where +      r' = MkUReft r mempty+      out = RFun  b i (removeAbsRef s) (removeAbsRef t) r'+removeAbsRef (RImpF b i s t (MkUReft r _))  +  = out+    where +      r' = MkUReft r mempty+      out = RImpF b i (removeAbsRef s) (removeAbsRef t) r'+removeAbsRef (RAllT b t r)      +  = RAllT b (removeAbsRef t) r+removeAbsRef (RAllP p t)        +  = removeAbsRef (forgetRAllP p t)+removeAbsRef (RApp  (RTyCon c _ i) as _ (MkUReft r _))   +  = out+    where +      c' = RTyCon c [] i+      as' = map removeAbsRef as+      r' = MkUReft r mempty+      out = RApp c' as' [] r'+removeAbsRef (RAllE b a t)      +  = RAllE b (removeAbsRef a) (removeAbsRef t)+removeAbsRef (REx   b a t)      +  = REx   b (removeAbsRef a) (removeAbsRef t)+removeAbsRef (RAppTy s t r)     +  = RAppTy (removeAbsRef s) (removeAbsRef t) r+removeAbsRef (RRTy  e r o t)    +  = RRTy  e r o (removeAbsRef t)+removeAbsRef t +  = t++--------------------------------------------------------------+-- Core Checking Rules ---------------------------------------+--------------------------------------------------------------++resL, resR :: F.Symbol+resL = fromString "r1"+resR = fromString "r2"++relSuffixL, relSuffixR :: String+relSuffixL = "l"+relSuffixR = "r"++-- recursion rule+consRelCheckBind :: CGEnv -> PrEnv -> CoreBind -> CoreBind -> SpecType -> SpecType -> RelExpr -> RelExpr -> CG ()+consRelCheckBind γ ψ b1@(NonRec _ e1) b2@(NonRec _ e2) t1 t2 ra rp+  | Nothing <- args e1 e2 t1 t2 p =+  traceChk "Bind NonRec" b1 b2 t1 t2 p $ do+    γ' <- γ `addPred` a+    consRelCheck γ' ψ e1 e2 t1 t2 p+  where+    a = fromRelExpr ra+    p = fromRelExpr rp++consRelCheckBind γ ψ (NonRec x1 e1) b2 t1 t2 a p =+  consRelCheckBind γ ψ (Rec [(x1, e1)]) b2 t1 t2 a p++consRelCheckBind γ ψ b1 (NonRec x2 e2) t1 t2 a p =+  consRelCheckBind γ ψ b1 (Rec [(x2, e2)]) t1 t2 a p++consRelCheckBind γ ψ b1@(Rec [(f1, e1)]) b2@(Rec [(f2, e2)]) t1 t2 ra rp+  | Just (xs1, xs2, vs1, vs2, ts1, ts2, qs) <- args e1 e2 t1 t2 p+  = traceChk "Bind Rec" b1 b2 t1 t2 p $ do+    forM_ (refts t1 ++ refts t2) (\r -> entlFunReft γ r "consRelCheckBind Rec")+    let xs' = zipWith mkRelCopies xs1 xs2+    let (xs1', xs2') = unzip xs'+    let (e1'', e2'') = L.foldl' subRel (e1', e2') (zip xs1 xs2)+    γ' <- γ += ("Bind Rec f1", F.symbol f1', t1) >>= (+= ("Bind Rec f2", F.symbol f2', t2))+    γ'' <- foldM (\γγ (x, t) -> γγ += ("Bind Rec x1", F.symbol x, t)) γ' (zip (xs1' ++ xs2') (ts1 ++ ts2))+    let vs2xs =  F.subst $ F.mkSubst $ zip (vs1 ++ vs2) $ map (F.EVar . F.symbol) (xs1' ++ xs2')+    let (ho, fo) = partitionArgs xs1 xs2 ts1 ts2 qs+    γ''' <- γ'' `addPreds` traceWhenLoud ("PRECONDITION " ++ F.showpp (vs2xs (F.PAnd fo)) ++ "\n" +++                                          "ASSUMPTION " ++ F.showpp (vs2xs a))+                              map vs2xs [F.PAnd fo, a]+    let p' = unapp rp (zip vs1 vs2)+    let ψ' = ho ++ ψ+    consRelCheck γ''' ψ' (xbody e1'') (xbody e2'') (vs2xs $ ret t1) (vs2xs $ ret t2) (vs2xs $ concl (fromRelExpr p'))+  where+    a = fromRelExpr ra+    p = fromRelExpr rp+    (f1', f2') = mkRelCopies f1 f2+    (e1', e2') = subRelCopies e1 f1 e2 f2+    unapp :: RelExpr -> [(F.Symbol, F.Symbol)] -> RelExpr+    unapp = L.foldl' (\p' (v1, v2) -> unapplyRelArgsR v1 v2 p')+    subRel (e1'', e2'') (x1, x2) = subRelCopies e1'' x1 e2'' x2++consRelCheckBind _ _ (Rec [(_, e1)]) (Rec [(_, e2)]) t1 t2 _ rp+  = F.panic $ "consRelCheckBind Rec: exprs, types, and pred should have same number of args " +++    show (args e1 e2 t1 t2 p)+    where+      p = fromRelExpr rp++consRelCheckBind _ _ b1@(Rec _) b2@(Rec _) _ _ _ _+  = F.panic $ "consRelCheckBind Rec: multiple binders are not supported " ++ F.showpp (b1, b2)++consRelCheck :: CGEnv -> PrEnv -> CoreExpr -> CoreExpr ->+  SpecType -> SpecType -> F.Expr -> CG ()+consRelCheck γ ψ (Tick tt e) d t s p =+  consRelCheck (γ `setLocation` Sp.Tick tt) ψ e d t s p++consRelCheck γ ψ e (Tick tt d) t s p =+  consRelCheck (γ `setLocation` Sp.Tick tt) ψ e d t s p++consRelCheck γ ψ l1@(Lam α1 e1) e2 rt1@(RAllT s1 t1 r1) t2 p+  | Ghc.isTyVar α1+  = traceChk "Lam Type L" l1 e2 rt1 t2 p $ do+    entlFunReft γ r1 "consRelCheck Lam Type"+    γ'  <- γ `extendWithTyVar` α1+    consRelCheck γ' ψ e1 e2 (sb (s1, α1) t1) t2 p+  where sb (s, α) = subsTyVarMeet' (ty_var_value s, rVar α)++consRelCheck γ ψ e1 l2@(Lam α2 e2) t1 rt2@(RAllT s2 t2 r2) p+  | Ghc.isTyVar α2+  = traceChk "Lam Type" e1 l2 t1 rt2 p $ do+    entlFunReft γ r2 "consRelCheck Lam Type"+    γ'  <- γ `extendWithTyVar` α2+    consRelCheck γ' ψ e1 e2 t1 (sb (s2, α2) t2) p+  where sb (s, α) = subsTyVarMeet' (ty_var_value s, rVar α)++consRelCheck γ ψ l1@(Lam α1 e1) l2@(Lam α2 e2) rt1@(RAllT s1 t1 r1) rt2@(RAllT s2 t2 r2) p+  | Ghc.isTyVar α1 && Ghc.isTyVar α2+  = traceChk "Lam Type" l1 l2 rt1 rt2 p $ do+    entlFunRefts γ r1 r2 "consRelCheck Lam Type"+    γ'  <- γ `extendWithTyVar` α1+    γ'' <- γ' `extendWithTyVar` α2+    consRelCheck γ'' ψ e1 e2 (sb (s1, α1) t1) (sb (s2, α2) t2) p+  where sb (s, α) = subsTyVarMeet' (ty_var_value s, rVar α)++consRelCheck γ ψ l1@(Lam x1 e1) l2@(Lam x2 e2) rt1@(RFun v1 _ s1 t1 r1) rt2@(RFun v2 _ s2 t2 r2) pr@(F.PImp q p)+  = traceChk "Lam Expr" l1 l2 rt1 rt2 pr $ do+    entlFunRefts γ r1 r2 "consRelCheck Lam Expr"+    let (pvar1, pvar2) = (F.symbol evar1, F.symbol evar2)+    let subst = F.subst $ F.mkSubst [(v1, F.EVar pvar1), (v2, F.EVar pvar2)]+    γ'  <- γ += ("consRelCheck Lam L", pvar1, subst s1)+    γ'' <- γ' += ("consRelCheck Lam R", pvar2, subst s2)+    let p'    = unapplyRelArgs v1 v2 p+    let (ho, fo) = partitionArg x1 x2 s1 s2 q+    γ''' <- γ'' `addPreds` traceWhenLoud ("PRECONDITION " ++ F.showpp (map subst fo)) map subst fo+    consRelCheck γ''' (ho ++ ψ) e1' e2' (subst t1) (subst t2) (subst p')+  where+    (evar1, evar2) = mkRelCopies x1 x2+    (e1', e2')     = subRelCopies e1 x1 e2 x2++consRelCheck γ ψ l1@(Let (NonRec x1 d1) e1) l2@(Let (NonRec x2 d2) e2) t1 t2 p+  = traceChk "Let" l1 l2 t1 t2 p $ do+    (s1, s2, _) <- consRelSynth γ ψ d1 d2+    let (evar1, evar2) = mkRelCopies x1 x2+    let (e1', e2')     = subRelCopies e1 x1 e2 x2+    γ'  <- γ += ("consRelCheck Let L", F.symbol evar1, s1)+    γ'' <- γ' += ("consRelCheck Let R", F.symbol evar2, s2)+    consRelCheck γ'' ψ e1' e2' t1 t2 p+  ++consRelCheck γ ψ l1@(Let (Rec []) e1) l2@(Let (Rec []) e2) t1 t2 p+  = traceChk "Let Rec Nil" l1 l2 t1 t2 p $ do+    consRelCheck γ ψ e1 e2 t1 t2 p++consRelCheck γ ψ l1@(Let (Rec ((x1, d1):bs1)) e1) l2@(Let (Rec ((x2, d2):bs2)) e2) t1 t2 p+  = traceChk "Let Rec Cons" l1 l2 t1 t2 p $ do+    (s1, s2, _) <- consRelSynth γ ψ d1 d2+    let (evar1, evar2) = mkRelCopies x1 x2+    let (e1', e2')     = subRelCopies e1 x1 e2 x2+    γ'  <- γ += ("consRelCheck Let L", F.symbol evar1, s1)+    γ'' <- γ' += ("consRelCheck Let R", F.symbol evar2, s2)+    consRelCheck γ'' ψ (Let (Rec bs1) e1') (Let (Rec bs2) e2') t1 t2 p++consRelCheck γ ψ c1@(Case e1 x1 _ alts1) e2 t1 t2 p =+  traceChk "Case Async L" c1 e2 t1 t2 p $ do+    s1 <- consUnarySynth γ e1+    γ' <- γ += ("consRelCheck Case Async L", x1', s1)+    forM_ alts1 $ consRelCheckAltAsyncL γ' ψ t1 t2 p x1' s1 e2+  where+    x1' = F.symbol $ mkCopyWithSuffix relSuffixL x1++consRelCheck γ ψ e1 c2@(Case e2 x2 _ alts2) t1 t2 p =+  traceChk "Case Async R" e1 c2 t1 t2 p $ do+    s2 <- consUnarySynth γ e2+    γ' <- γ += ("consRelCheck Case Async R", x2', s2)+    forM_ alts2 $ consRelCheckAltAsyncR γ' ψ t1 t2 p e1 x2' s2+  where+    x2' = F.symbol $ mkCopyWithSuffix relSuffixR x2++consRelCheck γ ψ e d t1 t2 p =+  traceChk "Synth" e d t1 t2 p $ do+  (s1, s2, qs) <- consRelSynth γ ψ e d+  let psubst = F.substf (matchFunArgs t1 s1) . F.substf (matchFunArgs t2 s2)+  consRelSub γ s1 s2 (F.PAnd qs) (psubst p)+  addC (SubC γ s1 t1) ("consRelCheck (Synth): s1 = " ++ F.showpp s1 ++ " t1 = " ++ F.showpp t1)+  addC (SubC γ s2 t2) ("consRelCheck (Synth): s2 = " ++ F.showpp s2 ++ " t2 = " ++ F.showpp t2)++consExtAltEnv :: CGEnv -> F.Symbol -> SpecType -> AltCon -> [Var] -> CoreExpr -> String -> CG (CGEnv, CoreExpr)+consExtAltEnv γ x s c bs e suf = do+  ct <- ctorTy γ c s+  unapply γ x s bs (removeAbsRef ct) e suf++consRelCheckAltAsyncL :: CGEnv -> PrEnv -> SpecType -> SpecType -> F.Expr ->+  F.Symbol -> SpecType -> CoreExpr -> Alt CoreBndr -> CG ()+consRelCheckAltAsyncL γ ψ t1 t2 p x1 s1 e2 (c, bs1, e1) = do+  (γ', e1') <- consExtAltEnv γ x1 s1 c bs1 e1 relSuffixL+  consRelCheck γ' ψ e1' e2 t1 t2 p++consRelCheckAltAsyncR :: CGEnv -> PrEnv -> SpecType -> SpecType -> F.Expr ->+  CoreExpr -> F.Symbol -> SpecType -> Alt CoreBndr -> CG ()+consRelCheckAltAsyncR γ ψ t1 t2 p e1 x2 s2 (c, bs2, e2) = do+  (γ', e2') <- consExtAltEnv γ x2 s2 c bs2 e2 relSuffixR+  consRelCheck γ' ψ e1 e2' t1 t2 p++ctorTy :: CGEnv -> AltCon -> SpecType -> CG SpecType+ctorTy γ (DataAlt c) (RApp _ ts _ _)+  | Just ct <- mbct = refreshTy $ ct `instantiateTys` ts+  | Nothing <- mbct = F.panic $ "ctorTy: data constructor out of scope" ++ F.showpp c+  where mbct = γ ?= F.symbol (Ghc.dataConWorkId c)+ctorTy _ (DataAlt _) t =+  F.panic $ "ctorTy: type " ++ F.showpp t ++ " doesn't have top-level data constructor"+ctorTy _ (LitAlt c) _ = return $ uTop <$> literalFRefType c+ctorTy _ DEFAULT t = return t++unapply :: CGEnv -> F.Symbol -> SpecType -> [Var] -> SpecType -> CoreExpr -> String -> CG (CGEnv, CoreExpr)+unapply γ y yt (z : zs) (RFun x _ s t _) e suffix = do+  γ' <- γ += ("unapply arg", evar, s)+  unapply γ' y yt zs (t `F.subst1` (x, F.EVar evar)) e' suffix+  where+    z' = mkCopyWithSuffix suffix z+    evar = F.symbol z'+    e' = subVarAndTy z z' e+unapply _ _ _ (_ : _) t _ _ = F.panic $ "can't unapply type " ++ F.showpp t+unapply γ y yt [] t e _ = do+  let yt' = t `F.meet` yt+  γ' <- γ += ("unapply res", y, yt')+  return $ traceWhenLoud ("SCRUTINEE " ++ F.showpp (y, yt')) (γ', e)++instantiateTys :: SpecType -> [SpecType] -> SpecType+instantiateTys = L.foldl' go+ where+  go (RAllT α tbody _) t = subsTyVarMeet' (ty_var_value α, t) tbody+  go tbody             t =+    F.panic $ "instantiateTys: non-polymorphic type " ++ F.showpp tbody ++ " to instantiate with " ++ F.showpp t++--------------------------------------------------------------+-- Core Synthesis Rules --------------------------------------+--------------------------------------------------------------++consRelSynth :: CGEnv -> PrEnv -> CoreExpr -> CoreExpr -> CG (SpecType, SpecType, [F.Expr])+consRelSynth γ ψ (Tick tt e) d =+  consRelSynth (γ `setLocation` Sp.Tick tt) ψ e d++consRelSynth γ ψ e (Tick tt d) =+  consRelSynth (γ `setLocation` Sp.Tick tt) ψ e d++consRelSynth γ ψ a1@(App e1 d1) e2 | Type t1 <- GM.unTickExpr d1 =+  traceSyn "App Ty L" a1 e2 $ do+    (ft1', t2, ps) <- consRelSynth γ ψ e1 e2+    let (α1, ft1, _) = unRAllT ft1' "consRelSynth App Ty L"+    t1' <- trueTy (typeclass (getConfig γ)) t1+    return (subsTyVarMeet' (ty_var_value α1, t1') ft1, t2, ps)++consRelSynth γ ψ e1 a2@(App e2 d2) | Type t2 <- GM.unTickExpr d2 =+  traceSyn "App Ty R" e1 a2 $ do+    (t1, ft2', ps) <- consRelSynth γ ψ e1 e2+    let (α2, ft2, _) = unRAllT ft2' "consRelSynth App Ty R"+    t2' <- trueTy (typeclass (getConfig γ)) t2+    return (t1, subsTyVarMeet' (ty_var_value α2, t2') ft2, ps)++consRelSynth γ ψ a1@(App e1 d1) a2@(App e2 d2) = traceSyn "App Exp Exp" a1 a2 $ do+  (ft1, ft2, fps) <- consRelSynth γ ψ e1 e2+  (t1, t2, ps) <- consRelSynthApp γ ψ ft1 ft2 fps d1 d2+  return (t1, t2, ps)++consRelSynth γ ψ e d = traceSyn "Unary" e d $ do+  t <- consUnarySynth γ e >>= refreshTy+  s <- consUnarySynth γ d >>= refreshTy+  let ps = lookupRelSig ψ e d t s+  return (t, s, traceWhenLoud ("consRelSynth Unary synthed preds:" ++ F.showpp ps) ps)+    +lookupRelSig :: PrEnv -> CoreExpr -> CoreExpr -> SpecType -> SpecType -> [F.Expr] +lookupRelSig ψ (Var x1) (Var x2) t1 t2 = concatMap match ψ+  where +    match :: RelPred -> [F.Expr]+    match (RelPred f1 f2 bs1 bs2 p) | f1 == x1, f2 == x2 = +        let (vs1, ts1') = vargs t1+            (vs2, ts2') = vargs t2+            vs1' = concatMap (fst . vargs) ts1'+            vs2' = concatMap (fst . vargs) ts2'+            bs1' = concatMap snd bs1+            bs2' = concatMap snd bs2+            bs2vs = F.mkSubst $ zip (map fst bs1 ++ map fst bs2 ++ bs1' ++ bs2') $ map F.EVar (vs1 ++ vs2 ++ vs1' ++ vs2')+          in [F.subst bs2vs (fromRelExpr p)]+    match _ = []+lookupRelSig _ _ _ _ _ = []++consRelSynthApp :: CGEnv -> PrEnv -> SpecType -> SpecType ->+  [F.Expr] -> CoreExpr -> CoreExpr -> CG (SpecType, SpecType, [F.Expr])+consRelSynthApp γ ψ ft1 ft2 ps e1 (Tick _ e2) =+  consRelSynthApp γ ψ ft1 ft2 ps e1 e2+consRelSynthApp γ ψ ft1 ft2 ps (Tick t1 e1) e2 =+  consRelSynthApp (γ `setLocation` Sp.Tick t1) ψ ft1 ft2 ps e1 e2++consRelSynthApp γ ψ ft1@(RFun v1 _ s1 t1 r1) ft2@(RFun v2 _ s2 t2 r2) ps@[F.PImp q p] d1@(Var x1) d2@(Var x2)+  = traceSynApp ft1 ft2 ps d1 d2 $ do+    entlFunRefts γ r1 r2 "consRelSynthApp HO"+    let qsubst = F.subst $ F.mkSubst [(v1, F.EVar resL), (v2, F.EVar resR)]+    consRelCheck γ ψ d1 d2 s1 s2 (qsubst q)+    let subst = F.subst $ F.mkSubst [(v1, F.EVar $ F.symbol x1), (v2, F.EVar $ F.symbol x2)]+    return (subst t1, subst t2, [(subst . unapplyRelArgs v1 v2) p])+consRelSynthApp γ ψ ft1@(RFun v1 _ s1 t1 r1) ft2@(RFun v2 _ s2 t2 r2) ps@[] d1@(Var x1) d2@(Var x2)+  = traceSynApp ft1 ft2 ps d1 d2 $ do+    entlFunRefts γ r1 r2 "consRelSynthApp FO"+    consUnaryCheck γ d1 s1+    consUnaryCheck γ d2 s2+    (_, _, qs) <- consRelSynth γ ψ d1 d2+    let subst =+          F.subst $ F.mkSubst+            [(v1, F.EVar $ F.symbol x1), (v2, F.EVar $ F.symbol x2)]+    return (subst t1, subst t2, map subst qs)+consRelSynthApp _ _ RFun{} RFun{} ps d1@(Var _) d2@(Var _)+  = F.panic $ "consRelSynthApp: multiple rel sigs not supported " ++ F.showpp (ps, d1, d2)+consRelSynthApp _ _ RFun{} RFun{} _ d1 d2 =+  F.panic $ "consRelSynthApp: expected application to variables, got" ++ F.showpp (d1, d2)+consRelSynthApp _ _ t1 t2 p d1 d2 =+  F.panic $ "consRelSynthApp: malformed function types or predicate for arguments " ++ F.showpp (t1, t2, p, d1, d2)++--------------------------------------------------------------+-- Unary Rules -----------------------------------------------+--------------------------------------------------------------++symbolType :: CGEnv -> Var -> String -> SpecType+symbolType γ x msg+  | Just t <- γ ?= F.symbol x = t+  | otherwise = F.panic $ msg ++ " " ++ F.showpp x ++ " not in scope " ++ F.showpp γ++consUnarySynth :: CGEnv -> CoreExpr -> CG SpecType+consUnarySynth γ (Tick t e) = consUnarySynth (γ `setLocation` Sp.Tick t) e+consUnarySynth γ (Var x) = return $ traceWhenLoud ("SELFIFICATION " ++ F.showpp (x, removeAbsRef $ selfify t x)) removeAbsRef $ selfify t x+  where t = symbolType γ x "consUnarySynth (Var)"+consUnarySynth _ e@(Lit c) =+  traceUSyn "Lit" e $ do+  return $ removeAbsRef $ uRType $ literalFRefType c+consUnarySynth γ e@(Let _ _) =+  traceUSyn "Let" e $ do+  t   <- freshTyType (typeclass (getConfig γ)) LetE e $ Ghc.exprType e+  addW $ WfC γ t+  consUnaryCheck γ e t+  return $ removeAbsRef t+consUnarySynth γ e'@(App e d) =+  traceUSyn "App" e' $ do+  et <- consUnarySynth γ e+  consUnarySynthApp γ et d+consUnarySynth γ e'@(Lam α e) | Ghc.isTyVar α =+                             traceUSyn "LamTyp" e' $ do+  γ' <- γ `extendWithTyVar` α+  t' <- consUnarySynth γ' e+  return $ removeAbsRef $ RAllT (makeRTVar $ rTyVar α) t' mempty+consUnarySynth γ e@(Lam x d)  =+  traceUSyn "Lam" e $ do+  let Ghc.FunTy { ft_arg = s' } = checkFun e $ Ghc.exprType e+  s  <- freshTyType (typeclass (getConfig γ)) LamE (Var x) s'+  γ' <- γ += ("consUnarySynth (Lam)", F.symbol x, s)+  t  <- consUnarySynth γ' d+  addW $ WfC γ s+  return $ removeAbsRef $ RFun (F.symbol x) (mkRFInfo $ getConfig γ) s t mempty+consUnarySynth γ e@(Case _ _ _ alts) =+  traceUSyn "Case" e $ do+  t   <- freshTyType (typeclass (getConfig γ)) (caseKVKind alts) e $ Ghc.exprType e+  addW $ WfC γ t+  return $ removeAbsRef t+consUnarySynth _ e@(Cast _ _) = F.panic $ "consUnarySynth is undefined for Cast " ++ F.showpp e+consUnarySynth _ e@(Type _) = F.panic $ "consUnarySynth is undefined for Type " ++ F.showpp e+consUnarySynth _ e@(Coercion _) = F.panic $ "consUnarySynth is undefined for Coercion " ++ F.showpp e++caseKVKind :: [Alt Var] -> KVKind+caseKVKind [(DataAlt _, _, Var _)] = ProjectE+caseKVKind cs                      = CaseE (length cs)++checkFun :: CoreExpr -> Type -> Type+checkFun _ t@Ghc.FunTy{} = t+checkFun e t = F.panic $ "FunTy was expected but got " ++ F.showpp t ++ "\t for expression" ++ F.showpp e++base :: SpecType -> Bool+base RApp{} = True+base RVar{} = True+base _      = False++selfifyExpr :: SpecType -> F.Expr -> Maybe SpecType+selfifyExpr (RFun v i s t r) f = (\t' -> RFun v i s t' r) <$> selfifyExpr t (F.EApp f (F.EVar v))+selfifyExpr t e | base t = Just $ t `strengthen` eq e+  where eq = uTop . F.exprReft+selfifyExpr _ _ = Nothing++selfify :: F.Symbolic a => SpecType -> a -> SpecType+selfify t x | base t = t `strengthen` eq x+  where eq = uTop . F.symbolReft . F.symbol+selfify t e | Just t' <- selfifyExpr t (F.EVar $ F.symbol e) = t'+selfify t _ = t++consUnarySynthApp :: CGEnv -> SpecType -> CoreExpr -> CG SpecType+consUnarySynthApp γ t (Tick y e) = do+  consUnarySynthApp (γ `setLocation` Sp.Tick y) t e+consUnarySynthApp γ (RFun x _ s t _) d@(Var y) = do+  consUnaryCheck γ d s+  return $ t `F.subst1` (x, F.EVar $ F.symbol y)+consUnarySynthApp γ (RAllT α t _) (Type s) = do+    s' <- trueTy (typeclass (getConfig γ)) s+    return $ subsTyVarMeet' (ty_var_value α, s') t+consUnarySynthApp _ RFun{} d =+  F.panic $ "consUnarySynthApp expected Var as a funciton arg, got " ++ F.showpp d+consUnarySynthApp γ t@(RAllP{}) e+  = consUnarySynthApp γ (removeAbsRef t) e++consUnarySynthApp _ ft d =+  F.panic $ "consUnarySynthApp malformed function type " ++ F.showpp ft +++            " for argument " ++ F.showpp d++consUnaryCheck :: CGEnv -> CoreExpr -> SpecType -> CG ()+consUnaryCheck γ (Let (NonRec x d) e) t = do+  s <- consUnarySynth γ d+  γ' <- γ += ("consUnaryCheck Let", F.symbol x, s)+  consUnaryCheck γ' e t+consUnaryCheck γ e t = do+  s <- consUnarySynth γ e+  addC (SubC γ s t) ("consUnaryCheck (Synth): s = " ++ F.showpp s ++ " t = " ++ F.showpp t)++--------------------------------------------------------------+-- Rel. Predicate Subtyping  ---------------------------------+--------------------------------------------------------------++consRelSub :: CGEnv -> SpecType -> SpecType -> F.Expr -> F.Expr -> CG ()+consRelSub γ f1@(RFun g1 _ s1@RFun{} t1 _) f2@(RFun g2 _ s2@RFun{} t2 _)+             pr1@(F.PImp qr1@F.PImp{} p1)  pr2@(F.PImp qr2@F.PImp{} p2)+  = traceSub "hof" f1 f2 pr1 pr2 $ do+    consRelSub γ s1 s2 qr2 qr1+    γ' <- γ += ("consRelSub HOF", F.symbol g1, s1)+    γ'' <- γ' += ("consRelSub HOF", F.symbol g2, s2)+    let psubst = unapplyArg resL g1 <> unapplyArg resR g2+    consRelSub γ'' t1 t2 (psubst p1) (psubst p2)+consRelSub γ f1@(RFun g1 _ s1@RFun{} t1 _) f2@(RFun g2 _ s2@RFun{} t2 _)+             pr1@(F.PAnd [F.PImp qr1@F.PImp{} p1])            pr2@(F.PImp qr2@F.PImp{} p2)+  = traceSub "hof" f1 f2 pr1 pr2 $ do+    consRelSub γ s1 s2 qr2 qr1+    γ' <- γ += ("consRelSub HOF", F.symbol g1, s1)+    γ'' <- γ' += ("consRelSub HOF", F.symbol g2, s2)+    let psubst = unapplyArg resL g1 <> unapplyArg resR g2+    consRelSub γ'' t1 t2 (psubst p1) (psubst p2)+consRelSub γ f1@(RFun x1 _ s1 e1 _) f2 p1 p2 =+  traceSub "fun" f1 f2 p1 p2 $ do+    γ' <- γ += ("consRelSub RFun L", F.symbol x1, s1)+    let psubst = unapplyArg resL x1+    consRelSub γ' e1 f2 (psubst p1) (psubst p2)+consRelSub γ f1 f2@(RFun x2 _ s2 e2 _) p1 p2 =+  traceSub "fun" f1 f2 p1 p2 $ do+    γ' <- γ += ("consRelSub RFun R", F.symbol x2, s2)+    let psubst = unapplyArg resR x2+    consRelSub γ' f1 e2 (psubst p1) (psubst p2)+consRelSub γ t1 t2 p1 p2 | isBase t1 && isBase t2 =+  traceSub "base" t1 t2 p1 p2 $ do+    rl <- fresh+    rr <- fresh+    γ' <- γ += ("consRelSub Base L", rl, t1)+    γ'' <- γ' += ("consRelSub Base R", rr, t2)+    let cstr = F.subst (F.mkSubst [(resL, F.EVar rl), (resR, F.EVar rr)]) $ F.PImp p1 p2+    entl γ'' (traceWhenLoud ("consRelSub Base cstr " ++ F.showpp cstr) cstr) "consRelSub Base"+consRelSub _ t1@(RHole _) t2@(RHole _) _ _ = F.panic $ "consRelSub is undefined for RHole " ++ show (t1, t2)+consRelSub _ t1@(RExprArg _) t2@(RExprArg _) _ _ = F.panic $ "consRelSub is undefined for RExprArg " ++ show (t1, t2)+consRelSub _ t1@REx {} t2@REx {} _ _ = F.panic $ "consRelSub is undefined for REx " ++ show (t1, t2)+consRelSub _ t1@RAllE {} t2@RAllE {} _ _ = F.panic $ "consRelSub is undefined for RAllE " ++ show (t1, t2)+consRelSub _ t1@RRTy {} t2@RRTy {} _ _ = F.panic $ "consRelSub is undefined for RRTy " ++ show (t1, t2)+consRelSub _ t1@RAllP {} t2@RAllP {} _ _ = F.panic $ "consRelSub is undefined for RAllP " ++ show (t1, t2)+consRelSub _ t1@RAllT {} t2@RAllT {} _ _ = F.panic $ "consRelSub is undefined for RAllT " ++ show (t1, t2)+consRelSub _ t1@RImpF {} t2@RImpF {} _ _ = F.panic $ "consRelSub is undefined for RImpF " ++ show (t1, t2)+consRelSub _ t1 t2 _ _ =  F.panic $ "consRelSub is undefined for different types " ++ show (t1, t2)++--------------------------------------------------------------+-- Helper Definitions ----------------------------------------+--------------------------------------------------------------++isFuncPred :: F.Expr -> Bool+isFuncPred (F.PImp _ _) = True+isFuncPred _            = False++partitionArg :: Var -> Var -> SpecType -> SpecType -> F.Expr -> (PrEnv, [F.Expr])+partitionArg x1 x2 s1 s2 q = partitionArgs [x1] [x2] [s1] [s2] [q]++partitionArgs :: [Var] -> [Var] -> [SpecType] -> [SpecType] -> [F.Expr] -> (PrEnv, [F.Expr])+partitionArgs xs1 xs2 ts1 ts2 qs = (map toRel ho, map toUnary fo)+ where+  (ho, fo) = L.partition (isFuncPred . toUnary) (zip5 xs1 xs2 ts1 ts2 qs)+  toRel (f1, f2, t1, t2, q) =+    let (vs1, ts1') = vargs t1+    in  let (vs2, ts2') = vargs t2+        in  let bs1 = zip vs1 (fst . vargs <$> ts1')+            in  let bs2 = zip vs2 (fst . vargs <$> ts2')+                in  let rp = RelPred f1 f2 bs1 bs2 $ ERBasic q+                    in traceWhenLoud ("partitionArgs toRel: " ++ F.showpp (f1, f2, bs1, bs2, q)) rp+  toUnary (_, _, _, _, q) = q++unRAllT :: SpecType -> String -> (RTVU RTyCon RTyVar, SpecType, RReft)+unRAllT (RAllT α2 ft2 r2) _ = (α2, ft2, r2)+unRAllT t msg = F.panic $ msg ++ ": expected RAllT, got: " ++ F.showpp t++forgetRAllP :: PVU RTyCon RTyVar -> SpecType -> SpecType+forgetRAllP _ t = t++args :: CoreExpr -> CoreExpr -> SpecType -> SpecType -> F.Expr ->+  Maybe ([Var], [Var], [F.Symbol], [F.Symbol], [SpecType], [SpecType], [F.Expr])+args e1 e2 t1 t2 ps+  | xs1 <- xargs e1, xs2 <- xargs e2,+    (vs1, ts1) <- vargs t1, (vs2, ts2) <- vargs t2,+    qs  <- prems ps,+    all (length qs ==) [length xs1, length xs2, length vs1, length vs2, length ts1, length ts2]+  = Just (xs1, xs2, vs1, vs2, ts1, ts2, qs)+args e1 e2 t1 t2 ps = traceWhenLoud ("args guard" ++ F.showpp (xargs e1, xargs e2, vargs t1, vargs t2, prems ps)) Nothing++xargs :: CoreExpr -> [Var]+xargs (Tick _ e) = xargs e+xargs (Lam  x e) | Ghc.isTyVar x = xargs e+xargs (Lam  x e) = x : xargs e+xargs _          = []++xbody :: CoreExpr -> CoreExpr+xbody (Tick _ e) = xbody e+xbody (Lam  _ e) = xbody e+xbody e          = e++refts :: SpecType -> [RReft]+refts (RAllT _ t r ) = r : refts t+refts (RFun _ _ _ t r) = r : refts t+refts _              = []++vargs :: SpecType -> ([F.Symbol], [SpecType])+vargs (RAllT _ t _ ) = vargs t+vargs (RFun v _ s t _) = bimap (v :) (s :) $ vargs t+vargs _              = ([], [])++ret :: SpecType -> SpecType+ret (RAllT _ t _ ) = ret t+ret (RFun _ _ _ t _) = ret t+ret t              = t++prems :: F.Expr -> [F.Expr]+prems (F.PImp q p) = q : prems p+prems _            = []++concl :: F.Expr -> F.Expr+concl (F.PImp _ p) = concl p+concl p            = p++extendWithTyVar :: CGEnv -> TyVar -> CG CGEnv+extendWithTyVar γ a+  | isValKind (Ghc.tyVarKind a)+  = γ += ("extendWithTyVar", F.symbol a, kindToRType $ Ghc.tyVarKind a)+  | otherwise+  = return γ++matchFunArgs :: SpecType -> SpecType -> F.Symbol -> F.Expr+matchFunArgs (RAllT _ t1 _) t2 x = matchFunArgs t1 t2 x+matchFunArgs t1 (RAllT _ t2 _) x = matchFunArgs t1 t2 x+matchFunArgs (RFun x1 _ _ t1 _) (RFun x2 _ _ t2 _) x =+  if x == x1 then F.EVar x2 else matchFunArgs t1 t2 x+matchFunArgs t1 t2 x | isBase t1 && isBase t2 = F.EVar x+matchFunArgs t1 t2 _ = F.panic $ "matchFunArgs undefined for " ++ F.showpp (t1, t2)++entl :: CGEnv -> F.Expr -> String -> CG ()+entl γ p = addC (SubR γ OCons $ uReft (F.vv_, F.PIff (F.EVar F.vv_) p))++entlFunReft :: CGEnv -> RReft -> String -> CG ()+entlFunReft γ r msg = do+  entl γ (F.reftPred $ ur_reft r) $ "entlFunRefts " ++ msg++entlFunRefts :: CGEnv -> RReft -> RReft -> String -> CG ()+entlFunRefts γ r1 r2 msg = do+  entlFunReft γ r1 $ msg ++ " L"+  entlFunReft γ r2 $ msg ++ " R"++subRelCopies :: CoreExpr -> Var -> CoreExpr -> Var -> (CoreExpr, CoreExpr)+subRelCopies e1 x1 e2 x2 = (subVarAndTy x1 evar1 e1, subVarAndTy x2 evar2 e2)+  where (evar1, evar2) = mkRelCopies x1 x2++subVarAndTy :: Var -> Var -> CoreExpr -> CoreExpr+subVarAndTy x v = subTy (M.singleton x $ TyVarTy v) . sub (M.singleton x $ Var v)++mkRelCopies :: Var -> Var -> (Var, Var)+mkRelCopies x1 x2 = (mkCopyWithSuffix relSuffixL x1, mkCopyWithSuffix relSuffixR x2)++mkCopyWithName :: String -> Var -> Var+mkCopyWithName s v =+  Ghc.setVarName v $ Ghc.mkSystemName (Ghc.getUnique v) (Ghc.mkVarOcc s)++mkCopyWithSuffix :: String -> Var -> Var+mkCopyWithSuffix s v = mkCopyWithName (Ghc.getOccString v ++ s) v++lookupBind :: Var -> [CoreBind] -> CoreBind+lookupBind x bs = case lookup x (concatMap binds bs) of+  Nothing -> F.panic $ "Not found definition for " ++ show x+  Just e  -> e+ where+  binds b@(NonRec x' _) = [ (x', b) ]+  binds   (Rec bs'    ) = [ (x', Rec [(x',e)]) | (x',e) <- bs' ]++subUnarySig :: CGEnv -> Var -> SpecType -> CG ()+subUnarySig γ x tRel =+  forM_ mkargs $ \(rt, ut) -> addC (SubC γ ut rt) $ "subUnarySig tUn = " ++ F.showpp ut ++ " tRel = " ++ F.showpp rt+  where+    mkargs = zip (snd $ vargs tRel) (snd $ vargs tUn)+    tUn = symbolType γ x $ "subUnarySig " ++ F.showpp x++addPred :: CGEnv -> F.Expr -> CG CGEnv+addPred γ p = extendWithExprs γ [p]++addPreds :: CGEnv -> [F.Expr] -> CG CGEnv+addPreds = extendWithExprs++extendWithExprs :: CGEnv -> [F.Expr] -> CG CGEnv+extendWithExprs γ ps = do+  dummy <- fresh+  let reft = uReft (F.vv_, F.PAnd ps)+  γ += ("extend with predicate env", dummy, RVar (symbolRTyVar F.dummySymbol) reft)++unapplyArg :: F.Symbol -> F.Symbol -> F.Expr -> F.Expr+unapplyArg f y e = F.mapExpr sb e+  where+    sb :: F.Expr -> F.Expr+    sb (F.EApp (F.EVar r) (F.EVar x))+      | r == f && x == y = F.EVar r+    sb e' = e'++unapplyRelArgs :: F.Symbol -> F.Symbol -> F.Expr -> F.Expr+unapplyRelArgs x1 x2 = unapplyArg resL x1 . unapplyArg resR x2++unapplyRelArgsR :: F.Symbol -> F.Symbol -> RelExpr -> RelExpr+unapplyRelArgsR x1 x2 (ERBasic e) = ERBasic (unapplyRelArgs x1 x2 e)+unapplyRelArgsR x1 x2 (ERChecked e re) = ERChecked (unapplyRelArgs x1 x2 e) (unapplyRelArgsR x1 x2 re)+unapplyRelArgsR x1 x2 (ERUnChecked e re) = ERUnChecked (unapplyRelArgs x1 x2 e) (unapplyRelArgsR x1 x2 re)++--------------------------------------------------------------+-- RelExpr & F.Expr ------------------------------------------+--------------------------------------------------------------++fromRelExpr :: RelExpr -> F.Expr+fromRelExpr (ERBasic e) = e+fromRelExpr (ERChecked a b) = F.PImp a (fromRelExpr b)+fromRelExpr (ERUnChecked a b) = F.PImp a (fromRelExpr b)++--------------------------------------------------------------+-- Debug -----------------------------------------------------+--------------------------------------------------------------+++traceSub :: (PPrint t, PPrint s, PPrint p, PPrint q) => String -> t -> s -> p -> q -> a -> a+traceSub msg t s p q = traceWhenLoud (msg ++ " RelSub\n"+                      ++ "t: " ++ F.showpp t ++ "\n\n"+                      ++ "s: " ++ F.showpp s ++ "\n\n"+                      ++ "p: " ++ F.showpp p ++ "\n\n"+                      ++ "q: " ++ F.showpp q)+++traceChk+  :: (PPrint e, PPrint d, PPrint t, PPrint s, PPrint p)+  => String -> e -> d -> t -> s -> p -> a -> a+traceChk expr = trace (expr ++ " To CHECK")++traceSyn+  :: (PPrint e, PPrint d, PPrint a, PPrint b, PPrint c)+  => String -> e -> d -> CG (a, b, c) -> CG (a, b, c)+traceSyn expr e d cg+  = do+    (a, b, c) <- cg+    trace (expr ++ " To SYNTH") e d a b c cg++traceSynApp+  :: (PPrint e, PPrint d, PPrint a, PPrint b, PPrint c)+  => e -> d -> a -> b -> c -> t -> t+traceSynApp = trace "SYNTH APP TO "++traceUSyn+  :: (PPrint e, PPrint a)+  => String -> e -> CG a -> CG a+traceUSyn expr e cg = do+  t <- cg+  trace (expr ++ " To SYNTH UNARY") e dummy t dummy dummy cg+  where dummy = F.PTrue++trace+  :: (PPrint e, PPrint d, PPrint t, PPrint s, PPrint p)+  => String -> e -> d -> t -> s -> p -> a -> a+trace msg e d t s p = traceWhenLoud (msg ++ "\n"+                      ++ "e: " ++ F.showpp e ++ "\n\n"+                      ++ "d: " ++ F.showpp d ++ "\n\n"+                      ++ "t: " ++ F.showpp t ++ "\n\n"+                      ++ "s: " ++ F.showpp s ++ "\n\n"+                      ++ "p: " ++ F.showpp p)++traceWhenLoud :: String -> a -> a+traceWhenLoud s a = unsafePerformIO $ whenLoud (putStrLn s) >> return a
src/Language/Haskell/Liquid/Constraint/Split.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE ImplicitParams        #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE FlexibleContexts      #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ -------------------------------------------------------------------------------- -- | Constraint Splitting ------------------------------------------------------ --------------------------------------------------------------------------------@@ -28,9 +29,9 @@  import           Text.PrettyPrint.HughesPJ hiding (first, parens) -import           Data.Maybe          (fromMaybe) +import           Data.Maybe          (fromMaybe) import           Control.Monad-import           Control.Monad.State (get)+import           Control.Monad.State (gets) import qualified Control.Exception as Ex  import qualified Language.Fixpoint.Types            as F@@ -103,7 +104,7 @@         return $ ws ++ ws'  splitW (WfC γ (RRTy _ _ _ t))-  = splitW (WfC γ t) +  = splitW (WfC γ t)  splitW (WfC _ t)   = panic Nothing $ "splitW cannot handle: " ++ showpp t@@ -122,7 +123,7 @@ bsplitW :: CGEnv -> SpecType -> CG [FixWfC] bsplitW γ t =   do temp  <- getTemplates-     isHO  <- allowHO   <$> get+     isHO  <- gets allowHO      return $ bsplitW' γ t temp isHO  bsplitW' :: (PPrint r, F.Reftable r, SubsTy RTyVar RSort r, F.Reftable (RTProp RTyCon RTyVar r))@@ -245,7 +246,7 @@        cs' <- splitC allowTC $ SubC γ' t1 (F.subst su t2'')        return (cs ++ cs')   where-    t2'' = subsTyVar_meet' (ty_var_value α2, RVar (ty_var_value α1) mempty) t2+    t2'' = subsTyVarMeet' (ty_var_value α2, RVar (ty_var_value α1) mempty) t2     su = case (rTVarToBind α1, rTVarToBind α2) of           (Just (x1, _), Just (x2, _)) -> F.mkSubst [(x1, F.EVar x2)]           _                            -> F.mkSubst []@@ -253,10 +254,10 @@ splitC allowTC (SubC _ (RApp c1 _ _ _) (RApp c2 _ _ _)) | (if allowTC then isEmbeddedDict else isClass) c1 && c1 == c2   = return [] -splitC _ (SubC γ t1@(RApp _ _ _ _) t2@(RApp _ _ _ _))+splitC _ (SubC γ t1@RApp{} t2@RApp{})   = do (t1',t2') <- unifyVV t1 t2        cs    <- bsplitC γ t1' t2'-       γ'    <- if (bscope (getConfig γ)) then γ `extendEnvWithVV` t1' else return γ+       γ'    <- if bscope (getConfig γ) then γ `extendEnvWithVV` t1' else return γ        let RApp c t1s r1s _ = t1'        let RApp _ t2s r2s _ = t2'        let isapplied = True -- TC.tyConArity (rtc_tc c) == length t1s@@ -289,9 +290,9 @@     src = getLocation γ     g   = reLocal $ renv γ -traceTy :: SpecType -> String +traceTy :: SpecType -> String traceTy (RVar v _)      = parens ("RVar " ++ showpp v)-traceTy (RApp c ts _ _) = parens ("RApp " ++ showpp c ++ unwords (traceTy <$> ts)) +traceTy (RApp c ts _ _) = parens ("RApp " ++ showpp c ++ unwords (traceTy <$> ts)) traceTy (RAllP _ t)     = parens ("RAllP " ++ traceTy t) traceTy (RAllT _ t _)   = parens ("RAllT " ++ traceTy t) traceTy (RImpF _ _ t t' _) = parens ("RImpF " ++ parens (traceTy t) ++ parens (traceTy t'))@@ -316,7 +317,7 @@                     -> [Variance]                     -> CG [FixSubC] splitsCWithVariance γ t1s t2s variants-  = concatMapM (\(t1, t2, v) -> splitfWithVariance (\s1 s2 -> (splitC (typeclass (getConfig γ)) (SubC γ s1 s2))) t1 t2 v) (zip3 t1s t2s variants)+  = concatMapM (\(t1, t2, v) -> splitfWithVariance (\s1 s2 -> splitC (typeclass (getConfig γ)) (SubC γ s1 s2)) t1 t2 v) (zip3 t1s t2s variants)  rsplitsCWithVariance :: Bool                      -> CGEnv@@ -336,7 +337,7 @@         -> CG [F.SubC Cinfo] bsplitC γ t1 t2 = do   temp   <- getTemplates-  isHO   <- allowHO   <$> get+  isHO   <- gets allowHO   t1'    <- addLhsInv γ <$> refreshVV t1   return  $ bsplitC' γ t1' t2 temp isHO @@ -363,12 +364,13 @@     γ'  = feBinds $ fenv γ     r1' = rTypeSortedReft' γ tem t1     r2' = rTypeSortedReft' γ tem t2-    ci  = \sr -> Ci src (err sr) (cgVar γ)     tag = getTag γ-    err = \sr -> Just $ fromMaybe (ErrSubType src (text "subtype") Nothing g t1 (replaceTop t2 sr)) (cerr γ)     src = getLocation γ     g   = reLocal $ renv γ +    ci sr  = Ci src (err sr) (cgVar γ)+    err sr = Just $ fromMaybe (ErrSubType src (text "subtype") Nothing g t1 (replaceTop t2 sr)) (cerr γ)+ mkSubC :: F.IBindEnv -> F.SortedReft -> F.SortedReft -> F.Tag -> (F.SortedReft -> a) -> [F.SubC a] mkSubC g sr1 sr2 tag ci = concatMap (\sr2' -> F.subC g sr1 sr2' Nothing tag (ci sr2')) (splitSortedReft sr2) @@ -393,12 +395,12 @@     F.Reft (vr,p)         = r  unifyVV :: SpecType -> SpecType -> CG (SpecType, SpecType)-unifyVV t1@(RApp _ _ _ _) t2@(RApp _ _ _ _)-  = do vv     <- (F.vv . Just) <$> fresh-       return  $ (shiftVV t1 vv,  (shiftVV t2 vv) )+unifyVV t1@RApp{} t2@RApp{}+  = do vv <- F.vv . Just <$> fresh+       return (shiftVV t1 vv, shiftVV t2 vv)  unifyVV _ _-  = panic Nothing $ "Constraint.Generate.unifyVV called on invalid inputs"+  = panic Nothing "Constraint.Generate.unifyVV called on invalid inputs"  rsplitC :: CGEnv         -> SpecProp@@ -420,7 +422,7 @@ -- | Reftypes from F.Fixpoint Expressions -------------------------------------- -------------------------------------------------------------------------------- forallExprRefType     :: CGEnv -> SpecType -> SpecType-forallExprRefType γ t = t `strengthen` (uTop r')+forallExprRefType γ t = t `strengthen` uTop r'   where     r'                = fromMaybe mempty $ forallExprReft γ r     r                 = F.sr_reft $ rTypeSortedReft (emb γ) t@@ -465,4 +467,4 @@ -- | Constraint Generation Panic ----------------------------------------------- -------------------------------------------------------------------------------- panicUnbound :: (PPrint x) => CGEnv -> x -> a-panicUnbound γ x = Ex.throw $ (ErrUnbound (getLocation γ) (F.pprint x) :: Error)+panicUnbound γ x = Ex.throw (ErrUnbound (getLocation γ) (F.pprint x) :: Error)
src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE FlexibleContexts          #-}++{-# OPTIONS_GHC -Wno-name-shadowing #-}+ module Language.Haskell.Liquid.Constraint.ToFixpoint   ( cgInfoFInfo   , fixConfig@@ -7,8 +10,8 @@   ) where  import           Prelude hiding (error)-import qualified Language.Haskell.Liquid.GHC.API as Ghc-import           Language.Haskell.Liquid.GHC.API (Var, Id, TyCon)+import qualified Liquid.GHC.API as Ghc+import           Liquid.GHC.API (Var, Id, TyCon) import qualified Language.Fixpoint.Types.Config as FC import           System.Console.CmdArgs.Default (def) import qualified Language.Fixpoint.Types        as F@@ -23,7 +26,7 @@ -- imports for AxiomEnv import qualified Language.Haskell.Liquid.UX.Config as Config import           Language.Haskell.Liquid.UX.DiffCheck (coreDefs, coreDeps, dependsOn, Def(..))-import qualified Language.Haskell.Liquid.GHC.Misc  as GM -- (simplesymbol)+import qualified Liquid.GHC.Misc  as GM -- (simplesymbol) import qualified Data.List                         as L import qualified Data.HashMap.Strict               as M import qualified Data.HashSet                      as S@@ -47,14 +50,16 @@   , FC.elimBound                = elimBound         cfg   , FC.allowHO                  = higherOrderFlag   cfg   , FC.allowHOqs                = higherorderqs     cfg-  , FC.smtTimeout               = smtTimeout        cfg +  , FC.smtTimeout               = smtTimeout        cfg   , FC.stringTheory             = stringTheory      cfg   , FC.gradual                  = gradual           cfg   , FC.ginteractive             = ginteractive       cfg   , FC.noslice                  = noslice           cfg   , FC.rewriteAxioms            = Config.allowPLE   cfg+  , FC.pleWithUndecidedGuards   = Config.pleWithUndecidedGuards cfg   , FC.etaElim                  = not (exactDC cfg) && extensionality cfg -- SEE: https://github.com/ucsd-progsys/liquidhaskell/issues/1601-  , FC.extensionality           = extensionality    cfg +  , FC.extensionality           = extensionality    cfg+  , FC.interpreter              = interpreter    cfg   , FC.oldPLE                   = oldPLE cfg   , FC.rwTerminationCheck       = rwTerminationCheck cfg   , FC.noLazyPLE                = noLazyPLE cfg@@ -88,18 +93,18 @@  makeAxiomEnvironment :: TargetInfo -> [(Var, SpecType)] -> M.HashMap F.SubcId (F.SubC Cinfo) -> F.AxiomEnv makeAxiomEnvironment info xts fcs-  = F.AEnv eqs  +  = F.AEnv eqs            (concatMap makeSimplify xts)            (doExpand sp cfg <$> fcs)            (makeRewrites info <$> fcs)   where     eqs      = if oldPLE cfg                 then makeEquations (typeclass cfg) sp ++ map (uncurry $ specTypeEq emb) xts-                else axioms  +                else axioms     emb      = gsTcEmbeds (gsName sp)     cfg      = getConfig  info     sp       = giSpec     info-    axioms   = gsMyAxioms refl ++ gsImpAxioms refl +    axioms   = gsMyAxioms refl ++ gsImpAxioms refl     refl     = gsRefl sp  @@ -119,7 +124,7 @@         Nothing ->           Mb.listToMaybe $ do             D s e v <- coreDefs $ giCbs $ giSrc info-            let (Ghc.RealSrcSpan cc _) = (ci_loc $ F.sinfo sub)+            let (Ghc.RealSrcSpan cc _) = ci_loc $ F.sinfo sub             guard $ s <= Ghc.srcSpanStartLine cc && e >= Ghc.srcSpanEndLine cc             return v @@ -160,9 +165,9 @@       []   where     tres = ty_res tRep-    tRep = toRTypeRep $ val t -  -makeRewriteOne :: (F.TCEmb TyCon) -> (Var, LocSpecType) -> [F.AutoRewrite]+    tRep = toRTypeRep $ val t++makeRewriteOne :: F.TCEmb TyCon -> (Var, LocSpecType) -> [F.AutoRewrite] makeRewriteOne tce (_, t)   = [rw | (lhs, rhs) <- refinementEQs t , rw <- rewrites lhs rhs ]   where@@ -178,16 +183,15 @@       (sym, arg) <- zip (ty_binds tRep) (ty_args tRep)       let e = maybe F.PTrue (F.reftPred . F.toReft) (stripRTypeBase arg)       return $ F.RR (rTypeSort tce arg) (F.Reft (sym, e))-       -    tRep = toRTypeRep $ val t  +    tRep = toRTypeRep $ val t+ _isClassOrDict :: Id -> Bool-_isClassOrDict x = F.tracepp ("isClassOrDict: " ++ F.showpp x) -                    $ (hasClassArg x || GM.isDictionary x || Mb.isJust (Ghc.isClassOpId_maybe x))+_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 +hasClassArg x = F.tracepp msg (GM.isDataConId x && any Ghc.isClassPred (t:ts'))+  where     msg       = "hasClassArg: " ++ showpp (x, t:ts')     (ts, t)   = Ghc.splitFunTys . snd . Ghc.splitForAllTys . Ghc.varType $ x     ts'       = map Ghc.irrelevantMult ts@@ -217,8 +221,8 @@ makeSimplify :: (Var, SpecType) -> [F.Rewrite] makeSimplify (x, t)   | not (GM.isDataConId x)-  = [] -  | otherwise +  = []+  | otherwise   = go $ specTypeToResultRef (F.eApps (F.EVar $ F.symbol x) (F.EVar <$> ty_binds (toRTypeRep t))) t   where     go (F.PAnd es) = concatMap go es@@ -226,13 +230,13 @@     go (F.PAtom eq (F.EApp (F.EVar f) dc) bd)       | eq `elem` [F.Eq, F.Ueq]       , (F.EVar dc, xs) <- F.splitEApp dc-      , dc == F.symbol x +      , dc == F.symbol x       , all isEVar xs       = [F.SMeasure f dc (fromEVar <$> xs) bd]      go (F.PIff (F.EApp (F.EVar f) dc) bd)       | (F.EVar dc, xs) <- F.splitEApp dc-      , dc == F.symbol x +      , dc == F.symbol x       , all isEVar xs       = [F.SMeasure f dc (fromEVar <$> xs) bd] @@ -258,12 +262,12 @@  makeEquations :: Bool -> TargetSpec -> [F.Equation] makeEquations allowTC sp = [ F.mkEquation f xts (equationBody allowTC (F.EVar f) xArgs e mbT) t-                      | F.Equ f xts e t _ <- axioms +                      | F.Equ f xts e t _ <- axioms                       , let xArgs          = F.EVar . fst <$> xts                       , let mbT            = if null xArgs then Nothing else M.lookup f sigs                    ]   where-    axioms       = gsMyAxioms refl ++ gsImpAxioms refl +    axioms       = gsMyAxioms refl ++ gsImpAxioms refl     refl         = gsRefl sp     sigs         = M.fromList [ (GM.simplesymbol v, t) | (v, t) <- gsTySigs (gsSig sp) ] @@ -293,9 +297,9 @@     okClass = all (F.isTauto . snd) cls     okArgs  = all okArg ts -    okArg (RVar _ _)       = True-    okArg t@(RApp _ _ _ _) = F.isTauto (t{rt_reft = mempty})-    okArg _                = False+    okArg (RVar _ _) = True+    okArg t@RApp{}   = F.isTauto (t{rt_reft = mempty})+    okArg _          = False       su           = F.mkSubst $ zip xs es
src/Language/Haskell/Liquid/Constraint/Types.hs view
@@ -1,10 +1,9 @@ {-# LANGUAGE OverloadedStrings    #-} {-# LANGUAGE FlexibleContexts     #-} {-# LANGUAGE TupleSections        #-}-{-# LANGUAGE EmptyDataDecls       #-}-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances    #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}  module Language.Haskell.Liquid.Constraint.Types   ( -- * Constraint Generation Monad@@ -58,16 +57,16 @@   ) where  import Prelude hiding (error)-import           Text.PrettyPrint.HughesPJ hiding ((<>)) +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           Data.Maybe               (isJust, mapMaybe) import           Control.Monad.State -import           Language.Haskell.Liquid.GHC.SpanStack-import           Language.Haskell.Liquid.GHC.API    as Ghc hiding ( (<+>)+import           Liquid.GHC.SpanStack+import           Liquid.GHC.API    as Ghc hiding ( (<+>)                                                                   , vcat                                                                   , parens                                                                   , ($+$)@@ -104,7 +103,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 +  , forallcb :: !(M.HashMap Var F.Expr)              -- ^ Polymorhic let bindings   , holes  :: !HEnv                                  -- ^ Types with holes, will need refreshing   , lcs    :: !LConstraint                           -- ^ Logical Constraints   , cerr   :: !(Maybe (TError SpecType))             -- ^ error that should be reported at the user@@ -115,7 +114,7 @@ instance HasConfig CGEnv where   getConfig = getConfig . cgInfo -data LConstraint = LC [[(F.Symbol, SpecType)]]+newtype LConstraint = LC [[(F.Symbol, SpecType)]]  instance Monoid LConstraint where   mempty  = LC []@@ -151,15 +150,15 @@ data WfC      = WfC  !CGEnv !SpecType               -- deriving (Data, Typeable) -type FixSubC  = F.SubC Cinfo-type FixWfC   = F.WfC Cinfo-+type FixSubC    = F.SubC Cinfo+type FixWfC     = F.WfC Cinfo+type FixBindEnv = F.BindEnv Cinfo  subVar :: FixSubC -> Maybe Var subVar = ci_var . F.sinfo  instance PPrint SubC where-  pprintTidy k c@(SubC {}) =+  pprintTidy k c@SubC {} =     "The environment:"     $+$     ""@@ -178,7 +177,7 @@                    , "<:"                    , pprintTidy k (rhs c) ] -  pprintTidy k c@(SubR {}) =+  pprintTidy k c@SubR {} =     "The environment:"     $+$     ""@@ -203,24 +202,24 @@ -------------------------------------------------------------------------------- -- | Generation: Types --------------------------------------------------------- ---------------------------------------------------------------------------------data CGInfo = CGInfo +data CGInfo = CGInfo   { fEnv       :: !(F.SEnv F.Sort)             -- ^ top-level fixpoint env   , hsCs       :: ![SubC]                      -- ^ subtyping constraints over RType   , hsWfs      :: ![WfC]                       -- ^ wellformedness constraints over RType   , fixCs      :: ![FixSubC]                   -- ^ subtyping over Sort (post-splitting)   , fixWfs     :: ![FixWfC]                    -- ^ wellformedness constraints over Sort (post-splitting)   , freshIndex :: !Integer                     -- ^ counter for generating fresh KVars-  , binds      :: !F.BindEnv                   -- ^ set of environment binders+  , binds      :: !FixBindEnv                   -- ^ set of environment binders   , ebinds     :: ![F.BindId]                  -- ^ existentials   , annotMap   :: !(AnnInfo (Annot SpecType))  -- ^ source-position annotation map   , holesMap   :: !(M.HashMap Var (HoleInfo (CGInfo, CGEnv) SpecType))    -- ^ information for ghc hole expressions   , tyConInfo  :: !TyConMap                    -- ^ information about type-constructors-  , specDecr   :: ![(Var, [Int])]              -- ^ ^ Lexicographic order of decreasing args (DEPRECATED) +  , specDecr   :: ![(Var, [Int])]              -- ^ ^ Lexicographic order of decreasing args (DEPRECATED)   , newTyEnv   :: !(M.HashMap Ghc.TyCon SpecType)        -- ^ Mapping of new type type constructors with their refined types.   , termExprs  :: !(M.HashMap Var [F.Located F.Expr])   -- ^ Terminating Metrics for Recursive functions   , specLVars  :: !(S.HashSet Var)             -- ^ Set of variables to ignore for termination checking   , specLazy   :: !(S.HashSet Var)             -- ^ "Lazy binders", skip termination checking-  , specTmVars :: !(S.HashSet Var)             -- ^ Binders that FAILED struct termination check that MUST be checked +  , specTmVars :: !(S.HashSet Var)             -- ^ Binders that FAILED struct termination check that MUST be checked   , autoSize   :: !(S.HashSet Ghc.TyCon)        -- ^ ? FIX THIS   , tyConEmbed :: !(F.TCEmb Ghc.TyCon)          -- ^ primitive Sorts into which TyCons should be embedded   , kuts       :: !F.Kuts                      -- ^ Fixpoint Kut variables (denoting "back-edges"/recursive KVars)@@ -229,6 +228,7 @@   , cgConsts   :: !(F.SEnv F.Sort)             -- ^ Distinct constant symbols in the refinement logic   , cgADTs     :: ![F.DataDecl]                -- ^ ADTs extracted from Haskell 'data' definitions   , tcheck     :: !Bool                        -- ^ Check Termination (?)+  , cgiTypeclass :: !Bool                      -- ^ Enable typeclass support   , pruneRefs  :: !Bool                        -- ^ prune unsorted refinements   , logErrors  :: ![Error]                     -- ^ Errors during constraint generation   , kvProf     :: !KVProf                      -- ^ Profiling distribution of KVars@@ -242,12 +242,12 @@   getTemplates :: CG F.Templates-getTemplates = do -  fg     <- pruneRefs <$> get-  ts     <- unsorted  <$> get-  return $ if fg then F.anything else ts -       +getTemplates = do+  fg    <- gets pruneRefs+  ts    <- gets unsorted+  return $ if fg then F.anything else ts + instance PPrint CGInfo where   pprintTidy = pprCGInfo @@ -320,7 +320,7 @@ lookupRInv (RApp c ts _ _) m   = case M.lookup c m of       Nothing   -> Nothing-      Just invs -> Just (catMaybes $ goodInvs ts <$> invs)+      Just invs -> Just (mapMaybe (goodInvs ts) invs) lookupRInv _ _   = Nothing @@ -340,7 +340,7 @@ addRInv :: RTyConInv -> (Var, SpecType) -> (Var, SpecType) addRInv m (x, t)   | x `elem` ids , Just invs <- lookupRInv (res t) m-  = (x, addInvCond t (mconcat $ catMaybes (stripRTypeBase <$> invs)))+  = (x, addInvCond t (mconcat $ mapMaybe stripRTypeBase invs))   | otherwise   = (x, t)    where@@ -378,7 +378,7 @@         | otherwise         = True     binds (NonRec x _) = [x]-    binds (Rec xes)    = fst $ unzip xes+    binds (Rec xes)    = map fst xes  restoreInvariant :: CGEnv -> RTyConInv -> CGEnv restoreInvariant γ is = γ {invs = is}
− src/Language/Haskell/Liquid/GHC/API.hs 
@@ -1,871 +0,0 @@-{-| This module re-exports a bunch of the GHC API.--The intended use of this module is to shelter LiquidHaskell from changes to the GHC API, so this is the-/only/ module LiquidHaskell should import when trying to access any ghc-specific functionality.----}--{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE BangPatterns #-}--module Language.Haskell.Liquid.GHC.API (-    module Ghc-  , module StableModule---- Specific exports for 8.6.5-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) && !MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)-  , pattern Bndr-  , pattern LitString-  , pattern LitFloat-  , pattern LitDouble-  , pattern LitChar-  , VarBndr-#endif-#endif---- Specific exports for 8.6.5 and 8.8.x-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) && !MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)-  , AnonArgFlag(..)-  , pattern FunTy-  , pattern AnonTCB-  , ft_af, ft_mult, ft_arg, ft_res-  , bytesFS-  , mkFunTy-  , isEvVarType-  , isEqPrimPred-  , noExtField-  , Mult-  , pattern Many-#endif-#endif--  , tyConRealArity-  , dataConExTyVars---- Specific exports for 8.8.x-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) && !MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)-  , isEqPred-#endif-#endif---- Specific exports for 8.10.x-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) && !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)-  , Mult-  , pattern Many-  , pattern FunTy-  , mkFunTy-  , ft_af, ft_mult, ft_arg, ft_res-#endif-#endif---- Shared exports for GHC < 9-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)-  , pattern RealSrcSpan-  , pattern UnhelpfulSpan-  , UnhelpfulSpanReason(..)-  , scaledThing-  , Scaled(..)-  , mkScaled-  , irrelevantMult-  , dataConInstArgTys-  , dataConOrigArgTys-  , dataConRepArgTys-  , mkLocalVar-  , DataConAppContext(..)-  , deepSplitProductType_maybe-  , splitFunTys-  , mkUserLocal-  , dataConWrapperType-  , apiAnnComments-  , getDependenciesModuleNames-  , GenWithIsBoot(..)-  , ModuleNameWithIsBoot-  , IsBootInterface-  , isBootSummary-  , mkIntExprInt-  , dataConFullSig-#endif-#endif---- Specific exports for 9.x-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)-  , fsToUnitId-  , moduleUnitId-  , thisPackage-  , renderWithStyle-  , mkUserStyle-  , pattern LitNumber-  , dataConSig-  , getDependenciesModuleNames-  , gcatch-#endif-#endif--  ) where--import           Language.Haskell.Liquid.GHC.API.StableModule      as StableModule-import           GHC                                               as Ghc hiding ( Warning-                                                                                 , SrcSpan(RealSrcSpan, UnhelpfulSpan)-                                                                                 , exprType-                                                                                 , dataConInstArgTys-                                                                                 )---- Shared imports for GHC < 9-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)--import CoreFVs                  as Ghc (exprFreeVarsList)-import OccurAnal                as Ghc (occurAnalysePgm)-import Annotations              as Ghc-import ApiAnnotation            as Ghc-import Avail                    as Ghc-import Bag                      as Ghc-import BasicTypes               as Ghc-import Class                    as Ghc-import CoAxiom                  as Ghc-import Coercion                 as Ghc-import ConLike                  as Ghc-import CoreLint                 as Ghc hiding (dumpIfSet)-import CoreMonad                as Ghc (CoreToDo(..))-import CoreSubst                as Ghc (deShadowBinds, substExpr, emptySubst, extendCvSubst)-import CoreSyn                  as Ghc hiding (AnnExpr, AnnExpr' (..), AnnRec, AnnCase)-import CoreUtils                as Ghc (exprType)-import CostCentre               as Ghc-import Data.Map.Strict (Map)-import DataCon                  as Ghc hiding (dataConInstArgTys, dataConOrigArgTys, dataConRepArgTys, dataConFullSig)-import qualified DataCon        as Ghc-import Digraph                  as Ghc-import DriverPhases             as Ghc (Phase(StopLn))-import DriverPipeline           as Ghc hiding (P, getLocation)-import DsMonad                  as Ghc-import DynFlags                 as Ghc-import ErrUtils                 as Ghc-import FamInst                  as Ghc-import FamInstEnv               as Ghc hiding (pprFamInst)-import Finder                   as Ghc-import ForeignCall              (CType)-import GHC                      as Ghc (SrcSpan)-import GhcMonad                 as Ghc (withSession)-import GhcPlugins               as Ghc (deserializeWithData , fromSerialized , toSerialized, extendIdSubst)-import HscMain                  as Ghc-import HscTypes                 as Ghc hiding (IsBootInterface, isBootSummary)-import Id                       as Ghc hiding (lazySetIdInfo, setIdExported, setIdNotExported, mkUserLocal)-import IdInfo                   as Ghc-import IfaceSyn                 as Ghc-import InstEnv                  as Ghc-import Literal                  as Ghc-import MkCore                   as Ghc hiding (mkIntExprInt)-import MkId                     (mkDataConWorkId)-import Module                   as Ghc-import Name                     as Ghc hiding (varName)-import NameEnv                  (lookupNameEnv_NF)-import NameSet                  as Ghc-import Outputable               as Ghc hiding ((<>))-import Pair                     as Ghc-import Panic                    as Ghc-import Plugins                  as Ghc (defaultPlugin, Plugin(..), CommandLineOption, purePlugin)-import PrelInfo                 as Ghc-import PrelNames                as Ghc hiding (wildCardName)-import RdrName                  as Ghc-import SrcLoc                   as Ghc hiding (RealSrcSpan, SrcSpan(UnhelpfulSpan))-import TcRnDriver               as Ghc-import TcRnMonad                as Ghc hiding (getGHCiMonad)-import TcRnTypes                as Ghc-import TysPrim                  as Ghc-import TysWiredIn               as Ghc-import Unify                    as Ghc-import UniqDFM                  as Ghc-import UniqFM                   as Ghc-import UniqSet                  as Ghc-import UniqSupply               as Ghc-import Unique                   as Ghc-import Var                      as Ghc hiding (mkLocalVar)-import VarEnv                   as Ghc-import VarSet                   as  Ghc-import qualified                SrcLoc-import qualified Data.Bifunctor as Bi-import qualified Data.Data      as Data-import qualified DataCon        as Ghc-import qualified GhcMake-import qualified HscTypes       as Ghc-import qualified Id             as Ghc-import qualified MkCore         as Ghc-import qualified Var            as Ghc-import qualified WwLib          as Ghc-import           RnExpr         as Ghc (rnLExpr)-import           TcExpr         as Ghc (tcInferSigma)-import           TcBinds        as Ghc (tcValBinds)-import           Inst           as Ghc (deeplyInstantiate)-import           TcSimplify     as Ghc ( simplifyInfer, simplifyInteractive-                                       , InferMode (..))-import           TcHsSyn        as Ghc (zonkTopLExpr)-import           TcEvidence     as Ghc ( TcEvBinds (EvBinds))-import           DsExpr         as Ghc (dsLExpr)-#endif-#endif------- Compatibility layer for different GHC versions.---------- Specific imports for GHC 8.6.5----#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) && !MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)--import qualified Literal as Lit-import FastString        as Ghc hiding (bytesFS, LitString)-import TcType            as Ghc hiding (typeKind, mkFunTy)-import Type              as Ghc hiding (typeKind, mkFunTy, splitFunTys, extendCvSubst)-import qualified Type    as Ghc-import qualified Var     as Var-import qualified GHC.Real--- import PrelNames      (eqPrimTyConKey, eqReprPrimTyConKey, gHC_REAL, varQual_RDR)-#endif-#endif------- Specific imports for GHC 8.6.5 & 8.8.x----#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) && !MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)--import                   Binary-import                   Data.ByteString (ByteString)-import                   Data.Data (Data)-import Kind              as Ghc-import TyCoRep           as Ghc hiding (Type (FunTy), mkFunTy, extendCvSubst)-import TyCon             as Ghc hiding (mkAnonTyConBinders, TyConBndrVis(AnonTCB))-import qualified TyCoRep as Ty hiding (extendCvSubst)-import qualified TyCon   as Ty-import Platform as Ghc-import qualified HsExtension--- import PrelNames      (eqPrimTyConKey, eqReprPrimTyConKey, gHC_REAL, varQual_RDR)--#endif-#endif------- Specific imports for 8.8.x----#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) && !MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)--import FastString           as Ghc hiding (bytesFS)-import TcType               as Ghc hiding (typeKind, mkFunTy, isEqPred)-import Type                 as Ghc hiding (typeKind, mkFunTy, isEvVarType, isEqPred, splitFunTys, extendCvSubst)-import qualified Type       as Ghc-import qualified Type       as Ghc (isEvVarType)-import qualified PrelNames  as Ghc-import Data.Foldable        (asum)--- import PrelNames      (eqPrimTyConKey, eqReprPrimTyConKey, gHC_REAL, varQual_RDR)-#endif-#endif------- Specific imports for GHC 8.10----#ifdef MIN_VERSION_GLASGOW_HASKELL--#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) && !MIN_VERSION_GLASGOW_HASKELL (9,0,0,0)-import DynFlags          as  Ghc (targetPlatform)-import GHC.Platform      as  Ghc (Platform)-import Type              as  Ghc hiding (typeKind , isPredTy, splitFunTys, extendCvSubst)-import qualified Type    as  Ghc hiding (extendCvSubst)-import TyCon             as  Ghc-import qualified TyCoRep as  Ty-import TcType            as  Ghc-import TyCoRep           as  Ghc hiding (Type (FunTy), mkFunTy, ft_arg, ft_res, ft_af)-import FastString        as  Ghc-import Predicate      as Ghc (getClassPredTys_maybe, isEvVarType, getClassPredTys, isDictId)-import TcOrigin       as Ghc (lexprCtOrigin)-import Data.Foldable  (asum)-import Util           (lengthIs)--- import PrelNames      (eqPrimTyConKey, eqReprPrimTyConKey, gHC_REAL, varQual_RDR)-#endif-#endif------- Specific imports for GHC 9----#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) && !MIN_VERSION_GLASGOW_HASKELL (9,1,0,0)--import Optics-import qualified Control.Monad.Catch as Ex--import Data.Foldable                  (asum)-import GHC.Builtin.Names              as Ghc-import GHC.Builtin.Types              as Ghc-import GHC.Builtin.Types.Prim         as Ghc-import GHC.Builtin.Utils              as Ghc-import GHC.Core                       as Ghc hiding (AnnExpr, AnnExpr' (..), AnnRec, AnnCase)-import GHC.Core.Class                 as Ghc-import GHC.Core.Coercion              as Ghc-import GHC.Core.Coercion.Axiom        as Ghc-import GHC.Core.ConLike               as Ghc-import GHC.Core.DataCon               as Ghc-import GHC.Core.FamInstEnv            as Ghc hiding (pprFamInst)-import GHC.Core.InstEnv               as Ghc-import GHC.Core.Lint                  as Ghc hiding (dumpIfSet)-import GHC.Core.Make                  as Ghc-import GHC.Core.Opt.Monad             as Ghc (CoreToDo(..))-import GHC.Core.Opt.WorkWrap.Utils    as Ghc-import GHC.Core.Predicate             as Ghc (getClassPredTys_maybe, getClassPredTys, isEvVarType, isEqPrimPred, isEqPred, isClassPred, isDictId)-import GHC.Core.Subst                 as Ghc (deShadowBinds, emptySubst, extendCvSubst)-import GHC.Core.TyCo.Rep              as Ghc hiding (extendCvSubst)-import GHC.Core.TyCon                 as Ghc-import GHC.Core.Type                  as Ghc hiding (typeKind , isPredTy, extendCvSubst, linear)-import GHC.Core.Unify                 as Ghc-import GHC.Core.Utils                 as Ghc (exprType)-import GHC.Data.Bag                   as Ghc-import GHC.Data.FastString            as Ghc-import GHC.Data.Graph.Directed        as Ghc-import GHC.Data.Pair                  as Ghc-import GHC.Driver.Finder              as Ghc-import GHC.Driver.Main                as Ghc-import GHC.Driver.Phases              as Ghc (Phase(StopLn))-import GHC.Driver.Pipeline            as Ghc (compileFile)-import GHC.Driver.Session             as Ghc-import GHC.Driver.Types               as Ghc-import GHC.Driver.Monad               as Ghc (withSession)-import GHC.HsToCore.Monad             as Ghc-import GHC.Iface.Syntax               as Ghc-import GHC.Plugins                    as Ghc ( deserializeWithData-                                             , fromSerialized-                                             , toSerialized-                                             , defaultPlugin-                                             , Plugin(..)-                                             , CommandLineOption-                                             , purePlugin-                                             , extendIdSubst-                                             , substExpr-                                             )-import GHC.Tc.Instance.Family         as Ghc-import GHC.Tc.Module                  as Ghc-import GHC.Tc.Types                   as Ghc-import GHC.Tc.Utils.Monad             as Ghc hiding (getGHCiMonad)-import GHC.Tc.Utils.TcType            as Ghc (tcSplitDFunTy, tcSplitMethodTy)-import GHC.Types.Annotations          as Ghc-import GHC.Types.Avail                as Ghc-import GHC.Types.Basic                as Ghc-import GHC.Types.CostCentre           as Ghc-import GHC.Types.Id                   as Ghc hiding (lazySetIdInfo, setIdExported, setIdNotExported)-import GHC.Types.Id.Info              as Ghc-import GHC.Types.Literal              as Ghc hiding (LitNumber)-import GHC.Types.Name                 as Ghc hiding (varName, isWiredIn)-import GHC.Types.Name.Reader          as Ghc-import GHC.Types.Name.Set             as Ghc-import GHC.Types.SrcLoc               as Ghc-import GHC.Types.Unique               as Ghc-import GHC.Types.Unique.DFM           as Ghc-import GHC.Types.Unique.FM            as Ghc-import GHC.Types.Unique.Set           as Ghc-import GHC.Types.Unique.Supply        as Ghc-import GHC.Types.Var                  as Ghc-import GHC.Types.Var.Env              as Ghc-import GHC.Types.Var.Set              as Ghc-import GHC.Unit.Module                as Ghc-import GHC.Utils.Error                as Ghc-import GHC.Utils.Outputable           as Ghc hiding ((<>), renderWithStyle, mkUserStyle)-import GHC.Utils.Panic                as Ghc-import qualified GHC.Types.Literal    as Ghc-import qualified GHC.Utils.Outputable as Ghc-import GHC.Tc.Types.Origin            as Ghc (lexprCtOrigin)-import GHC.Rename.Expr                as Ghc (rnLExpr)-import GHC.Tc.Gen.Expr                as Ghc (tcInferSigma, tcInferRho)-import GHC.Tc.Gen.Bind                as Ghc (tcValBinds)-import GHC.Tc.Solver                  as Ghc-import GHC.Tc.Utils.Zonk              as Ghc-import GHC.Core.FVs                   as Ghc (exprFreeVarsList)-import GHC.Tc.Types.Evidence          as Ghc-import GHC.HsToCore.Expr              as Ghc-import GHC.Core.Predicate             as Ghc (mkClassPred)-import GHC.Core.Opt.OccurAnal         as Ghc-#endif-#endif------- Compat shim for GHC < 9 (shared parts)----#ifdef MIN_VERSION_GLASGOW_HASKELL-#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)--data BufSpan--pattern RealSrcSpan :: SrcLoc.RealSrcSpan -> Maybe BufSpan -> SrcLoc.SrcSpan-pattern RealSrcSpan rss mbSpan <- ((,Nothing) -> (SrcLoc.RealSrcSpan rss, mbSpan))-  where-    RealSrcSpan rss _mbSpan = SrcLoc.RealSrcSpan rss--data UnhelpfulSpanReason-  = UnhelpfulNoLocationInfo-  | UnhelpfulWiredIn-  | UnhelpfulInteractive-  | UnhelpfulGenerated-  | UnhelpfulOther !FastString-  deriving (Eq, Show)--pattern UnhelpfulSpan :: UnhelpfulSpanReason -> SrcLoc.SrcSpan-pattern UnhelpfulSpan reason <- (toUnhelpfulReason -> Just reason)-  where-    UnhelpfulSpan reason = SrcLoc.UnhelpfulSpan (fromUnhelpfulReason reason)--fromUnhelpfulReason :: UnhelpfulSpanReason -> FastString-fromUnhelpfulReason = \case-  UnhelpfulNoLocationInfo -> fsLit "UnhelpfulNoLocationInfo"-  UnhelpfulWiredIn        -> fsLit "UnhelpfulWiredIn"-  UnhelpfulInteractive    -> fsLit "UnhelpfulInteractive"-  UnhelpfulGenerated      -> fsLit "UnhelpfulGenerated"-  UnhelpfulOther fs       -> fs--toUnhelpfulReason :: SrcLoc.SrcSpan -> Maybe UnhelpfulSpanReason-toUnhelpfulReason (SrcLoc.RealSrcSpan _) = Nothing-toUnhelpfulReason (SrcLoc.UnhelpfulSpan fs) = Just $ case unpackFS fs of-  "UnhelpfulNoLocationInfo" -> UnhelpfulNoLocationInfo-  "UnhelpfulWiredIn"        -> UnhelpfulWiredIn-  "UnhelpfulInteractive"    -> UnhelpfulInteractive-  "UnhelpfulGenerated"      -> UnhelpfulGenerated-  _                         -> UnhelpfulOther fs---- Backporting multiplicity--data Scaled a = Scaled Mult a-  deriving (Data.Data)--instance (Outputable a) => Outputable (Scaled a) where-   ppr (Scaled _cnt t) = ppr t--irrelevantMult :: Scaled a -> a-irrelevantMult = scaledThing--mkScaled :: Mult -> a -> Scaled a-mkScaled = Scaled--scaledThing :: Scaled a -> a-scaledThing (Scaled _ t) = t--type Mult = Type--pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon-pcDataCon n univs tys tycon = data_con-  where-    data_con = mkDataCon n-                         False-                         (mkPrelTyConRepName n)-                         (map (const (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)) tys)-                         []-                         univs-                         []-                         (error "[TyVarBinder]")-                         []-                         []-                         tys-                         (mkTyConApp tycon (mkTyVarTys univs))-                         NoRRI-                         tycon-                         (lookupNameEnv_NF (mkTyConTagMap tycon) n)-                         []-                         (mkDataConWorkId (mkDataConWorkerName data_con (dataConWorkerUnique (nameUnique n))) data_con)-                         NoDataConRep---mkDataConWorkerName :: DataCon -> Unique -> Name-mkDataConWorkerName data_con wrk_key =-    mkWiredInName modu wrk_occ wrk_key-                  (AnId (dataConWorkId data_con)) UserSyntax-  where-    modu    = nameModule dc_name-    dc_name = dataConName data_con-    dc_occ  = nameOccName dc_name-    wrk_occ = mkDataConWorkerOcc dc_occ--pcTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon-pcTyCon name cType tyvars cons-  = mkAlgTyCon name-                (mkAnonTyConBinders VisArg tyvars)-                liftedTypeKind-                (map (const Representational) tyvars)-                cType-                []              -- No stupid theta-                (mkDataTyConRhs cons)-                (VanillaAlgTyCon (mkPrelTyConRepName name))-                False           -- Not in GADT syntax---mkWiredInDataConName :: BuiltInSyntax -> Module -> FastString -> Unique -> DataCon -> Name-mkWiredInDataConName built_in modu fs unique datacon-  = mkWiredInName modu (mkDataOccFS fs) unique-                  (AConLike (RealDataCon datacon))    -- Relevant DataCon-                  built_in--multiplicityTyConKey :: Unique-multiplicityTyConKey = mkPreludeTyConUnique 192--multiplicityTyConName :: Name-multiplicityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Multiplicity")-                          multiplicityTyConKey multiplicityTyCon--manyDataConName :: Name-manyDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "Many") manyDataConKey manyDataCon--multiplicityTyCon :: TyCon-multiplicityTyCon = pcTyCon multiplicityTyConName Nothing [] [manyDataCon]--manyDataCon :: DataCon-manyDataCon = pcDataCon manyDataConName [] [] multiplicityTyCon--manyDataConKey :: Unique-manyDataConKey = mkPreludeDataConUnique 116--manyDataConTy :: Type-manyDataConTy = mkTyConTy manyDataConTyCon--manyDataConTyCon :: TyCon-manyDataConTyCon = promoteDataCon manyDataCon--pattern Many :: Mult-pattern Many <- (isManyDataConTy -> True)-  where Many = manyDataConTy--isManyDataConTy :: Mult -> Bool-isManyDataConTy ty-  | Just tc <- tyConAppTyCon_maybe ty-  = tc `hasKey` manyDataConKey-isManyDataConTy _ = False------- Dependencies and Boot----type IsBootInterface = GhcMake.IsBoot---- | This data type just pairs a value 'mod' with an IsBootInterface flag. In--- practice, 'mod' is usually a @Module@ or @ModuleName@'.-data GenWithIsBoot mod = GWIB-  { gwib_mod :: mod-  , gwib_isBoot :: IsBootInterface-  } deriving ( Eq, Ord, Show-             , Functor, Foldable, Traversable-             )--type ModuleNameWithIsBoot = GenWithIsBoot ModuleName--isBootSummary :: ModSummary -> IsBootInterface-isBootSummary ms = case Ghc.isBootSummary ms of-  True  -> GhcMake.IsBoot-  False -> GhcMake.NotBoot--getDependenciesModuleNames :: Dependencies -> [ModuleNameWithIsBoot]-getDependenciesModuleNames = map f . dep_mods-  where-    f :: (ModuleName, Bool) -> ModuleNameWithIsBoot-    f (modName, b) = let isBoot = if b then GhcMake.IsBoot else GhcMake.NotBoot in GWIB modName isBoot--dataConInstArgTys :: DataCon -> [Type] -> [Scaled Type]-dataConInstArgTys dc tys = map (mkScaled Many) (Ghc.dataConInstArgTys dc tys)--dataConOrigArgTys :: DataCon -> [Scaled Type]-dataConOrigArgTys dc = map (mkScaled Many) (Ghc.dataConOrigArgTys dc)--dataConRepArgTys :: DataCon -> [Scaled Type]-dataConRepArgTys dc = map (mkScaled Many) (Ghc.dataConRepArgTys dc)--mkLocalVar :: IdDetails -> Name -> Mult -> Type -> IdInfo -> Id-mkLocalVar idDetails name _ ty info = Ghc.mkLocalVar idDetails name ty info--mkUserLocal :: OccName -> Unique -> Mult -> Type -> SrcSpan -> Id-mkUserLocal occName u _mult ty srcSpan = Ghc.mkUserLocal occName u ty srcSpan--dataConWrapperType :: DataCon -> Type-dataConWrapperType = dataConUserType---- WWlib--data DataConAppContext-  = DataConAppContext-  { dcac_dc      :: !DataCon-  , dcac_tys     :: ![Type]-  , dcac_arg_tys :: ![(Scaled Type, StrictnessMark)]-  , dcac_co      :: !Coercion-  }--deepSplitProductType_maybe :: FamInstEnvs -> Type -> Maybe DataConAppContext-deepSplitProductType_maybe famInstEnv ty = do-  (dc, tys, tysWithStricts, co) <- Ghc.deepSplitProductType_maybe famInstEnv ty-  pure $ DataConAppContext dc tys (map (Bi.first (mkScaled Many)) tysWithStricts) co--splitFunTys :: Type -> ([Scaled Type], Type)-splitFunTys ty = Bi.first (map (mkScaled Many)) $ Ghc.splitFunTys ty--apiAnnComments :: (Map ApiAnnKey [SrcSpan], Map SrcSpan [Located AnnotationComment])-               -> Map SrcSpan [Located AnnotationComment]-apiAnnComments = snd--mkIntExprInt :: Platform -> Int -> CoreExpr-mkIntExprInt _ int = Ghc.mkIntExprInt unsafeGlobalDynFlags int--dataConFullSig :: DataCon -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Scaled Type], Type)-dataConFullSig dc =-  let (tyvars, tycovars, eqspecs, theta, tys, ty) = Ghc.dataConFullSig dc-  in  (tyvars, tycovars, eqspecs, theta, map (mkScaled Many) tys, ty)---#endif-#endif------- Compat shim for GHC 8.6.5--#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) && !MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)--pattern LitString :: ByteString -> Lit.Literal-pattern LitString bs <- Lit.MachStr bs where-    LitString bs = Lit.MachStr bs--pattern LitFloat :: GHC.Real.Ratio Integer -> Lit.Literal-pattern LitFloat f <- Lit.MachFloat f where-    LitFloat f = Lit.MachFloat f--pattern LitDouble :: GHC.Real.Ratio Integer -> Lit.Literal-pattern LitDouble d <- Lit.MachDouble d where-    LitDouble d = Lit.MachDouble d--pattern LitChar :: Char -> Lit.Literal-pattern LitChar c <- Lit.MachChar c where-    LitChar c = Lit.MachChar c--pattern Bndr :: var -> argf -> Var.TyVarBndr var argf-pattern Bndr var argf <- TvBndr var argf where-    Bndr var argf = TvBndr var argf--type VarBndr = TyVarBndr--isEqPrimPred :: Type -> Bool-isEqPrimPred = Ghc.isPredTy---- See NOTE [isEvVarType].-isEvVarType :: Type -> Bool-isEvVarType = Ghc.isPredTy--tyConRealArity :: TyCon -> Int-tyConRealArity = tyConArity--#endif-#endif------- Compat shim for GHC-8.6.5 and GHC-8.8.x----#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) && !MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)---- | The non-dependent version of 'ArgFlag'.---- Appears here partly so that it's together with its friend ArgFlag,--- but also because it is used in IfaceType, rather early in the--- compilation chain--- See Note [AnonArgFlag vs. ForallVisFlag]-data AnonArgFlag-  = VisArg    -- ^ Used for @(->)@: an ordinary non-dependent arrow.-              --   The argument is visible in source code.-  | InvisArg  -- ^ Used for @(=>)@: a non-dependent predicate arrow.-              --   The argument is invisible in source code.-  deriving (Eq, Ord, Data)--instance Outputable AnonArgFlag where-  ppr VisArg   = text "[vis]"-  ppr InvisArg = text "[invis]"--instance Binary AnonArgFlag where-  put_ bh VisArg   = putByte bh 0-  put_ bh InvisArg = putByte bh 1--  get bh = do-    h <- getByte bh-    case h of-      0 -> return VisArg-      _ -> return InvisArg--mkAnonTyConBinders :: AnonArgFlag -> [TyVar] -> [TyConBinder]-mkAnonTyConBinders _ = Ty.mkAnonTyConBinders--bytesFS :: FastString -> ByteString-bytesFS = fastStringToByteString--mkFunTy :: AnonArgFlag -> Mult -> Type -> Type -> Type-mkFunTy _ _ = Ty.FunTy--pattern FunTy :: AnonArgFlag -> Mult -> Type -> Type -> Type-pattern FunTy { ft_af, ft_mult, ft_arg, ft_res } <- ((VisArg,Many,) -> (ft_af, ft_mult, Ty.FunTy ft_arg ft_res)) where-    FunTy _ft_af _ft_mult ft_arg ft_res = Ty.FunTy ft_arg ft_res--pattern AnonTCB :: AnonArgFlag -> Ty.TyConBndrVis-pattern AnonTCB af <- ((VisArg,) -> (af, Ty.AnonTCB)) where-    AnonTCB _af = Ty.AnonTCB--noExtField :: NoExt-noExtField = NoExt--#endif---- Compat shim for GHC 8.8.x--#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) && !MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)--isEqPrimPred :: Type -> Bool-isEqPrimPred ty-  | Just tc <- tyConAppTyCon_maybe ty-  = tc `hasKey` Ghc.eqPrimTyConKey || tc `hasKey` Ghc.eqReprPrimTyConKey-  | otherwise-  = False--isEqPred :: Type -> Bool-isEqPred ty-  | Just tc <- tyConAppTyCon_maybe ty-  , Just cls <- tyConClass_maybe tc-  = cls `hasKey` Ghc.eqTyConKey || cls `hasKey` Ghc.heqTyConKey-  | otherwise-  = False---- See NOTE [isEvVarType].-isEvVarType :: Type -> Bool-isEvVarType = Ghc.isEvVarType--#endif-#endif--{- | [NOTE:tyConRealArity]--The semantics of 'tyConArity' changed between GHC 8.6.5 and GHC 8.10, mostly due to the-Visible Dependent Quantification (VDQ). As a result, given the following:--data family EntityField record :: * -> *--Calling `tyConArity` on this would yield @2@ for 8.6.5 but @1@ an 8.10, so we try to backport-the old behaviour in 8.10 by \"looking\" at the 'Kind' of the input 'TyCon' and trying to recursively-split the type apart with either 'splitFunTy_maybe' or 'splitForAllTy_maybe'.---}--{- | [NOTE:isEvVarType]--For GHC < 8.8.1 'isPredTy' is effectively the same as the new 'isEvVarType', which covers the cases-for coercion types and \"normal\" type coercions. The 8.6.5 version of 'isPredTy' had a special case to-handle a 'TyConApp' in the case of type equality (i.e. ~ ) which was removed in the implementation-for 8.8.1, which essentially calls 'tcIsConstraintKind' straight away.--}------- Support for GHC >= 8.8-----#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) && !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)---- See NOTE [tyConRealArity].-tyConRealArity :: TyCon -> Int-tyConRealArity tc = go 0 (tyConKind tc)-  where-    go :: Int -> Kind -> Int-    go !acc k =-      case asum [fmap snd (splitFunTy_maybe k), fmap snd (splitForAllTy_maybe k)] of-        Nothing -> acc-        Just ks -> go (acc + 1) ks--dataConExTyVars :: DataCon -> [TyVar]-dataConExTyVars = dataConExTyCoVars--#endif------- Compat shim for 8.10.x-----#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) && !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)-pattern FunTy :: AnonArgFlag -> Mult -> Type -> Type -> Type-pattern FunTy { ft_af, ft_mult, ft_arg, ft_res } <- ((Many,) -> (ft_mult, Ty.FunTy ft_af ft_arg ft_res)) where-    FunTy ft_af _ft_mult ft_arg ft_res = Ty.FunTy ft_af ft_arg ft_res--mkFunTy :: AnonArgFlag -> Mult -> Type -> Type -> Type-mkFunTy af _ arg res = Ty.FunTy af arg res-#endif------- Compat shim for 9.0.x--#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)---- 'fsToUnitId' is gone in GHC 9, but we can bring code it in terms of 'fsToUnit' and 'toUnitId'.-fsToUnitId :: FastString -> UnitId-fsToUnitId = toUnitId . fsToUnit--moduleUnitId :: Module -> UnitId-moduleUnitId = toUnitId . moduleUnit--thisPackage :: DynFlags -> UnitId-thisPackage = toUnitId . homeUnit---- See NOTE [tyConRealArity].-tyConRealArity :: TyCon -> Int-tyConRealArity tc = go 0 (tyConKind tc)-  where-    go :: Int -> Kind -> Int-    go !acc k =-      case asum [fmap (view _3) (splitFunTy_maybe k), fmap snd (splitForAllTy_maybe k)] of-        Nothing -> acc-        Just ks -> go (acc + 1) ks--dataConExTyVars :: DataCon -> [TyVar]-dataConExTyVars = dataConExTyCoVars--getDependenciesModuleNames :: Dependencies -> [ModuleNameWithIsBoot]-getDependenciesModuleNames = dep_mods--renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String-renderWithStyle dynflags sdoc style = Ghc.renderWithStyle (Ghc.initSDocContext dynflags style) sdoc--mkUserStyle :: DynFlags -> PrintUnqualified -> Depth -> PprStyle-mkUserStyle _ = Ghc.mkUserStyle------- Literal------- In GHC 9 'LitNumber' doesn't have the extra 3rd argument, so we simply ignore it in the construction.--pattern LitNumber :: Ghc.LitNumType -> Integer -> Ghc.Type -> Ghc.Literal-pattern LitNumber numType integer ty <- ((intPrimTy,) -> (ty, Ghc.LitNumber numType integer))-  where-    LitNumber numType integer _ = Ghc.LitNumber numType integer---- This function is gone in GHC 9.-dataConSig :: DataCon -> ([TyCoVar], ThetaType, [Type], Type)-dataConSig dc-  = (dataConUnivAndExTyCoVars dc, dataConTheta dc, map irrelevantMult $ dataConOrigArgTys dc, dataConOrigResTy dc)--gcatch :: (Ex.MonadCatch m, Exception e) => m a -> (e -> m a) -> m a-gcatch = Ex.catch--#endif------- End of compatibility shim.----#endif
− src/Language/Haskell/Liquid/GHC/API/StableModule.hs 
@@ -1,101 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}-module Language.Haskell.Liquid.GHC.API.StableModule (-    StableModule-  -- * Constructing a 'StableModule'-  , mkStableModule-  -- * Converting a 'StableModule' into a standard 'Module'-  , unStableModule-  -- * Utility functions-  , toStableModule-  , renderModule-  ) where--import qualified GHC--#ifdef MIN_VERSION_GLASGOW_HASKELL-#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)-import qualified Module as GHC-#else-import qualified GHC.Unit.Types as GHC-import qualified GHC.Unit.Module as GHC-#endif-#endif--import           Data.Hashable-import           GHC.Generics            hiding (to, moduleName)-import           Data.Binary---- | A newtype wrapper around a 'Module' which:------ * Allows a 'Module' to be serialised (i.e. it has a 'Binary' instance)--- * It tries to use stable comparison and equality under the hood.----newtype StableModule =-  StableModule { unStableModule :: GHC.Module }-  deriving Generic---- | Converts a 'Module' into a 'StableModule'.-toStableModule :: GHC.Module -> StableModule-toStableModule = StableModule--moduleUnitId :: GHC.Module -> GHC.UnitId-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)-moduleUnitId = GHC.moduleUnitId-#else-moduleUnitId = GHC.toUnitId . GHC.moduleUnit-#endif-#endif--renderModule :: GHC.Module -> String-renderModule m =    "Module { unitId = " <> (GHC.unitIdString . moduleUnitId $ m)-                 <> ", name = " <> show (GHC.moduleName m)-                 <> " }"---- These two orphans originally lived inside module 'Language.Haskell.Liquid.Types.Types'.-instance Hashable GHC.ModuleName where-  hashWithSalt i = hashWithSalt i . show--instance Show GHC.ModuleName where-  show = GHC.moduleNameString--instance Hashable StableModule where-  hashWithSalt s (StableModule mdl) = hashWithSalt s (GHC.moduleStableString mdl)--instance Ord StableModule where-  (StableModule m1) `compare` (StableModule m2) = GHC.stableModuleCmp m1 m2--instance Eq StableModule where-  (StableModule m1) == (StableModule m2) = (m1 `GHC.stableModuleCmp` m2) == EQ--instance Show StableModule where-    show (StableModule mdl) = "Stable" ++ renderModule mdl--instance Binary StableModule where--    put (StableModule mdl) = do-      put (GHC.unitIdString . moduleUnitId $ mdl)-      put (GHC.moduleNameString . GHC.moduleName $ mdl)--    get = do-      uidStr <- get-      mnStr  <- get-      pure $ mkStableModule (GHC.stringToUnitId uidStr) (GHC.mkModuleName mnStr)------- Compat shim layer------- | Creates a new 'StableModule' out of a 'ModuleName' and a 'UnitId'.-mkStableModule :: GHC.UnitId -> GHC.ModuleName -> StableModule-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)-mkStableModule uid modName = StableModule (GHC.mkModule uid modName)-#else-mkStableModule uid modName =-  let realUnit = GHC.RealUnit $ GHC.Definite uid-  in StableModule (GHC.Module realUnit modName)-#endif-#endif-
− src/Language/Haskell/Liquid/GHC/GhcMonadLike.hs 
@@ -1,336 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}--- | This module introduces a \"lighter\" "GhcMonad" typeclass which doesn't require an instance of--- 'ExceptionMonad', and can therefore be used for both 'CoreM' and 'Ghc'.-----module Language.Haskell.Liquid.GHC.GhcMonadLike (-  -- * Types and type classes-    HasHscEnv-  , GhcMonadLike-  , ModuleInfo-  , TypecheckedModule(..)--  -- * Functions and typeclass methods--  , askHscEnv-  , getModuleGraph-  , getModSummary-  , lookupModSummary-  , lookupGlobalName-  , lookupName-  , modInfoLookupName-  , moduleInfoTc-  , parseModule-  , typecheckModule-  , desugarModule-  , findModule-  , lookupModule-  , isBootInterface-  , apiComments-  ) where--import Control.Monad-import Control.Monad.IO.Class-import Control.Exception (throwIO)--import Data.IORef (readIORef)--import qualified Language.Haskell.Liquid.GHC.API   as Ghc-import           Language.Haskell.Liquid.GHC.API   hiding ( ModuleInfo-                                                          , findModule-                                                          , desugarModule-                                                          , typecheckModule-                                                          , parseModule-                                                          , lookupName-                                                          , lookupGlobalName-                                                          , getModSummary-                                                          , getModuleGraph-                                                          , modInfoLookupName-                                                          , lookupModule-                                                          , TypecheckedModule-                                                          , tm_parsed_module-                                                          , tm_renamed_source-                                                          )---- Shared imports for GHC < 9-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)-import qualified CoreMonad-import qualified EnumSet-import Maybes-import GhcMake-import Exception (ExceptionMonad)-#else-import GHC.Data.Maybe-import GHC.Driver.Make-import GHC.Utils.Exception (ExceptionMonad)-import qualified GHC.Core.Opt.Monad as CoreMonad-import qualified GHC.Data.EnumSet as EnumSet-#endif-#endif--import qualified Data.Map.Strict as M-import Optics--class HasHscEnv m where-  askHscEnv :: m HscEnv--instance HasHscEnv CoreMonad.CoreM where-  askHscEnv = CoreMonad.getHscEnv--instance HasHscEnv Ghc where-  askHscEnv = getSession--instance HasHscEnv (IfM lcl) where-  askHscEnv = getTopEnv--instance HasHscEnv TcM where-  askHscEnv = env_top <$> getEnv--instance HasHscEnv Hsc where-  askHscEnv = Hsc $ \e w -> pure (e, w)--instance (ExceptionMonad m, HasHscEnv m) => HasHscEnv (GhcT m) where-  askHscEnv = getSession---- | A typeclass which is /very/ similar to the existing 'GhcMonad', but it doesn't impose a--- 'ExceptionMonad' constraint.-class (Functor m, MonadIO m, HasHscEnv m, HasDynFlags m) => GhcMonadLike m--instance GhcMonadLike CoreMonad.CoreM-instance GhcMonadLike Ghc-instance GhcMonadLike (IfM lcl)-instance GhcMonadLike TcM-instance GhcMonadLike Hsc-instance (ExceptionMonad m, GhcMonadLike m) => GhcMonadLike (GhcT m)---- NOTE(adn) Taken from the GHC API, adapted to work for a 'GhcMonadLike' monad.-getModuleGraph :: GhcMonadLike m => m ModuleGraph-getModuleGraph = liftM hsc_mod_graph askHscEnv---- NOTE(adn) Taken from the GHC API, adapted to work for a 'GhcMonadLike' monad.-getModSummary :: GhcMonadLike m => ModuleName -> m ModSummary-getModSummary mdl = do-   mg <- liftM hsc_mod_graph askHscEnv-   let mods_by_name = [ ms | ms <- mgModSummaries mg-                      , ms_mod_name ms == mdl-                      , not (isBootInterface . isBootSummary $ ms) ]-   case mods_by_name of-     [] -> do dflags <- getDynFlags-              liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph")-     [ms] -> return ms-     multiple -> do dflags <- getDynFlags-                    liftIO $ throwIO $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple)----- Converts a 'IsBootInterface' into a 'Bool'.-isBootInterface :: IsBootInterface -> Bool-isBootInterface IsBoot  = True-isBootInterface NotBoot = False--lookupModSummary :: GhcMonadLike m => ModuleName -> m (Maybe ModSummary)-lookupModSummary mdl = do-   mg <- liftM hsc_mod_graph askHscEnv-   let mods_by_name = [ ms | ms <- mgModSummaries mg-                      , ms_mod_name ms == mdl-                      , not (isBootInterface . isBootSummary $ ms) ]-   case mods_by_name of-     [ms] -> pure (Just ms)-     _    -> pure Nothing---- NOTE(adn) Taken from the GHC API, adapted to work for a 'GhcMonadLike' monad.-lookupGlobalName :: GhcMonadLike m => Name -> m (Maybe TyThing)-lookupGlobalName name = do-  hsc_env <- askHscEnv-  liftIO $ lookupTypeHscEnv hsc_env name---- NOTE(adn) Taken from the GHC API, adapted to work for a 'GhcMonadLike' monad.-lookupName :: GhcMonadLike m => Name -> m (Maybe TyThing)-lookupName name = do-  hsc_env <- askHscEnv-  liftIO $ hscTcRcLookupName hsc_env name---- | Our own simplified version of 'ModuleInfo' to overcome the fact we cannot construct the \"original\"--- one as the constructor is not exported, and 'getHomeModuleInfo' and 'getPackageModuleInfo' are not--- exported either, so we had to backport them as well.-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)---- For GHC < 9, UniqFM has a single parameter.-data ModuleInfo = ModuleInfo { minf_type_env :: UniqFM TyThing }-#else--- For GHC >= 9, UniqFM has two parameters.--- just fine.-data ModuleInfo = ModuleInfo { minf_type_env :: UniqFM Name TyThing }-#endif-#endif--modInfoLookupName :: GhcMonadLike m-                  => ModuleInfo-                  -> Name-                  -> m (Maybe TyThing)-modInfoLookupName minf name = do-  hsc_env <- askHscEnv-  case lookupTypeEnv (minf_type_env minf) name of-    Just tyThing -> return (Just tyThing)-    Nothing      -> do-      eps   <- liftIO $ readIORef (hsc_EPS hsc_env)-      return $! lookupType (hsc_dflags hsc_env) (hsc_HPT hsc_env) (eps_PTE eps) name--moduleInfoTc :: GhcMonadLike m => ModSummary -> TcGblEnv -> m ModuleInfo-moduleInfoTc ms tcGblEnv = do-  hsc_env <- askHscEnv-  let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }-  details <- md_types <$> liftIO (makeSimpleDetails hsc_env_tmp tcGblEnv)-  pure ModuleInfo { minf_type_env = details }------- Parsing, typechecking and desugaring a module----parseModule :: GhcMonadLike m => ModSummary -> m ParsedModule-parseModule ms = do-  hsc_env <- askHscEnv-  let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }-  hpm <- liftIO $ hscParse hsc_env_tmp ms-  return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm)-                           (hpm_annotations hpm))---- | Our own simplified version of 'TypecheckedModule'.-data TypecheckedModule = TypecheckedModule { -    tm_parsed_module  :: ParsedModule-  , tm_renamed_source :: Maybe RenamedSource-  , tm_mod_summary    :: ModSummary-  , tm_gbl_env        :: TcGblEnv-  }--typecheckModule :: GhcMonadLike m => ParsedModule -> m TypecheckedModule-typecheckModule pmod = do-  -- Suppress all the warnings, so that they won't be printed (which would result in them being-  -- printed twice, one by GHC and once here).-  let ms = pm_mod_summary pmod-  hsc_env <- askHscEnv-  let dynFlags' = ms_hspp_opts ms-  let hsc_env_tmp = hsc_env { hsc_dflags = dynFlags' { warningFlags = EnumSet.empty } }-  (tc_gbl_env, rn_info)-        <- liftIO $ hscTypecheckRename hsc_env_tmp ms $-                       HsParsedModule { hpm_module = parsedSource pmod,-                                        hpm_src_files = pm_extra_src_files pmod,-                                        hpm_annotations = pm_annotations pmod }-  return TypecheckedModule {-      tm_parsed_module  = pmod-    , tm_renamed_source = rn_info-    , tm_mod_summary    = ms-    , tm_gbl_env        = tc_gbl_env-    }--{- | [NOTE:ghc810]-Something changed in the GHC bowels such that the 'hscTarget' that the 'ModSummary' was inheriting-was /not/ the one we were setting in 'configureDynFlags'. This is important, because if the 'hscTarget'-is not 'HscInterpreted' or 'HscNothing', the call to 'targetRetainsAllBindings' will yield 'False'. This-function is used internally by GHC to do dead-code-elimination and to mark functions as "exported" or not.-Therefore, the 'CoreBind's passed to LiquidHaskell would be different between GHC 8.6.5 and GHC 8.10.--}--class IsTypecheckedModule t where-  tmParsedModule :: Lens'  t ParsedModule-  tmModSummary   :: Lens'  t ModSummary-  tmGblEnv       :: Getter t TcGblEnv--instance IsTypecheckedModule TypecheckedModule where-  tmParsedModule = lens tm_parsed_module (\s x -> s { tm_parsed_module = x })-  tmModSummary   = lens tm_mod_summary   (\s x -> s { tm_mod_summary = x })-  tmGblEnv       = to tm_gbl_env--instance IsTypecheckedModule Ghc.TypecheckedModule where-  tmParsedModule = lens Ghc.tm_parsed_module (\s x -> s { Ghc.tm_parsed_module = x })-  tmModSummary   = lens (pm_mod_summary . Ghc.tm_parsed_module)-                        (\s x -> over tmParsedModule (\pm -> pm { Ghc.pm_mod_summary = x }) s )-  tmGblEnv       = to (fst . Ghc.tm_internals_)---- | Desugar a typechecked module.-desugarModule :: (GhcMonadLike m, IsTypecheckedModule t) => ModSummary -> t -> m ModGuts-desugarModule originalModSum typechecked = do-  -- See [NOTE:ghc810] on why we override the dynFlags here before calling 'desugarModule'.-  dynFlags          <- getDynFlags-  let modSum         = originalModSum { ms_hspp_opts = dynFlags }-  let parsedMod'     = (view tmParsedModule typechecked) { pm_mod_summary = modSum }-  let typechecked'   = set tmParsedModule parsedMod' typechecked--  hsc_env <- askHscEnv-  let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts (view tmModSummary typechecked') }-  liftIO $ hscDesugar hsc_env_tmp (view tmModSummary typechecked') (view tmGblEnv typechecked')---- | Takes a 'ModuleName' and possibly a 'UnitId', and consults the--- filesystem and package database to find the corresponding 'Module',--- using the algorithm that is used for an @import@ declaration.-findModule :: GhcMonadLike m => ModuleName -> Maybe FastString -> m Module-findModule mod_name maybe_pkg = do-  hsc_env <- askHscEnv-  let-    dflags   = hsc_dflags hsc_env-    this_pkg = thisPackage dflags-  ---  case maybe_pkg of-    Just pkg | fsToUnitId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do-      res <- findImportedModule hsc_env mod_name maybe_pkg-      case res of-        Found _ m -> return m-        err       -> throwOneError $ noModError dflags noSrcSpan mod_name err-    _otherwise -> do-      home <- lookupLoadedHomeModule mod_name-      case home of-        Just m  -> return m-        Nothing -> liftIO $ do-           res <- findImportedModule hsc_env mod_name maybe_pkg-           case res of-             Found loc m | moduleUnitId m /= this_pkg -> return m-                         | otherwise -> modNotLoadedError dflags m loc-             err -> throwOneError $ noModError dflags noSrcSpan mod_name err---lookupLoadedHomeModule :: GhcMonadLike m => ModuleName -> m (Maybe Module)-lookupLoadedHomeModule mod_name = do-  hsc_env <- askHscEnv-  case lookupHpt (hsc_HPT hsc_env) mod_name of-    Just mod_info      -> return (Just (mi_module (hm_iface mod_info)))-    _not_a_home_module -> return Nothing---modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a-modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $-   text "module is not loaded:" <+>-   quotes (ppr (moduleName m)) <+>-   parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))---lookupModule :: GhcMonadLike m => ModuleName -> Maybe FastString -> m Module-lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg)-lookupModule mod_name Nothing = do-  hsc_env <- askHscEnv-  home <- lookupLoadedHomeModule mod_name-  case home of-    Just m  -> return m-    Nothing -> liftIO $ do-      res <- findExposedPackageModule hsc_env mod_name Nothing-      case res of-        Found _ m -> return m-        err       -> throwOneError $ noModError (hsc_dflags hsc_env) noSrcSpan mod_name err---- Compatibility shim to extract the comments out of an 'ApiAnns', as modern GHCs now puts the--- comments (i.e. Haskell comments) in a different field ('apiAnnRogueComments').-apiComments :: ApiAnns -> [Ghc.Located AnnotationComment]-apiComments apiAnns =-  let comments = concat . M.elems . apiAnnComments $ apiAnns-  in-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)-      comments-#else-     map toRealSrc $ mappend comments (apiAnnRogueComments apiAnns)-  where-    toRealSrc (L x e) = L (RealSrcSpan x Nothing) e-#endif-#endif
− src/Language/Haskell/Liquid/GHC/Interface.hs 
@@ -1,1058 +0,0 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE NoMonomorphismRestriction  #-}-{-# LANGUAGE LambdaCase                 #-}-{-# LANGUAGE TypeSynonymInstances       #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE TupleSections              #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE PartialTypeSignatures      #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE ViewPatterns               #-}--module Language.Haskell.Liquid.GHC.Interface (--  -- * Determine the build-order for target files-   realTargets--  , getInterfaceDynFlags--  -- * Extract all information needed for verification-  , getTargetInfos-  , runLiquidGhc--  -- * Printer-  , pprintCBs--  -- * predicates-  -- , isExportedVar-  -- , exportedVars--  -- * Internal exports (provisional)-  , extractSpecComments-  , extractSpecQuotes'-  , makeLogicMap-  , classCons-  , derivedVars-  , importVars-  , makeGhcSrc-  , allImports-  , qualifiedImports-  , modSummaryHsFile-  , makeFamInstEnv-  , findAndParseSpecFiles-  , parseSpecFile-  , noTerm-  , clearSpec-  , checkFilePragmas-  , keepRawTokenStream-  , ignoreInline-  , lookupTyThings-  , availableTyCons-  , availableVars-  , updLiftedSpec-  , loadDependenciesOf-  ) where--import Prelude hiding (error)--import GHC.Paths (libdir)-import GHC.Serialized--import           Language.Haskell.Liquid.GHC.GhcMonadLike (isBootInterface)-import           Language.Haskell.Liquid.GHC.API as Ghc hiding ( text-                                                               , (<+>)-                                                               , panic-                                                               , vcat-                                                               , showPpr-                                                               , isHomeModule-                                                               , Target-                                                               , Located-                                                               )-import qualified Language.Haskell.Liquid.GHC.API as Ghc-import qualified Language.Haskell.Liquid.GHC.API as O-import GHC.LanguageExtensions--import Control.Exception-import Control.Monad--import Data.Bifunctor-import Data.Data-import Data.List hiding (intersperse)-import Data.Maybe--import Data.Generics.Aliases (mkT)-import Data.Generics.Schemes (everywhere)--import qualified Data.HashSet        as S-import qualified Data.HashMap.Strict as HM--import System.Console.CmdArgs.Verbosity hiding (Loud)-import System.Directory-import System.FilePath-import System.IO-import System.IO.Temp-import Text.Megaparsec.Error-import Text.PrettyPrint.HughesPJ        hiding (first, (<>))-import Language.Fixpoint.Types          hiding (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.Types (MGIModGuts(..), miModGuts)-import Language.Haskell.Liquid.GHC.Play-import qualified Language.Haskell.Liquid.GHC.GhcMonadLike as GhcMonadLike-import Language.Haskell.Liquid.GHC.GhcMonadLike (GhcMonadLike, askHscEnv)-import Language.Haskell.Liquid.WiredIn (isDerivedInstance) -import qualified Language.Haskell.Liquid.Measure  as Ms-import qualified Language.Haskell.Liquid.Misc     as Misc-import Language.Haskell.Liquid.Parse-import Language.Haskell.Liquid.Transforms.ANF-import Language.Haskell.Liquid.Types hiding (Spec)--- import Language.Haskell.Liquid.Types.PrettyPrint--- import Language.Haskell.Liquid.Types.Visitors-import Language.Haskell.Liquid.UX.CmdLine-import Language.Haskell.Liquid.UX.QuasiQuoter-import Language.Haskell.Liquid.UX.Tidy-import Language.Fixpoint.Utils.Files--import Optics--import qualified Debug.Trace as Debug ------------------------------------------------------------------------------------{- | @realTargets mE cfg targets@ uses `Interface.configureGhcTargets` to -     return a list of files--       [i1, i2, ... ] ++ [f1, f2, ...]--     1. Where each file only (transitively imports) PRECEDIING ones; -     2. `f1..` are a permutation of the original `targets`;-     3. `i1..` either don't have "fresh" .bspec files. -- -}----------------------------------------------------------------------------------realTargets :: Maybe HscEnv -> Config -> [FilePath] -> IO [FilePath] -realTargets  mbEnv cfg tgtFs -  | noCheckImports cfg = return tgtFs-  | otherwise          = do -    incDir   <- Misc.getIncludeDir -    allFs    <- orderTargets mbEnv cfg tgtFs-    let srcFs = filter (not . Misc.isIncludeFile incDir) allFs-    realFs   <- filterM check srcFs-    dir      <- getCurrentDirectory-    return      (makeRelative dir <$> realFs)-  where -    check f    = not <$> skipTarget tgts f -    tgts       = S.fromList tgtFs--getInterfaceDynFlags :: Maybe HscEnv -> Config -> IO DynFlags-getInterfaceDynFlags mbEnv cfg = runLiquidGhc mbEnv cfg $ getSessionDynFlags--orderTargets :: Maybe HscEnv -> Config -> [FilePath] -> IO [FilePath] -orderTargets mbEnv cfg tgtFiles = runLiquidGhc mbEnv cfg $ do -  homeModules <- configureGhcTargets tgtFiles-  return         (modSummaryHsFile <$> mgModSummaries homeModules)---skipTarget :: S.HashSet FilePath -> FilePath -> IO Bool-skipTarget tgts f -  | S.member f tgts = return False          -- Always check target file -  | otherwise       = hasFreshBinSpec f     -- But skip an import with fresh .bspec--hasFreshBinSpec :: FilePath -> IO Bool-hasFreshBinSpec srcF = do -  let specF = extFileName BinSpec srcF-  srcMb    <- Misc.lastModified srcF -  specMb   <- Misc.lastModified specF -  case (srcMb, specMb) of -    (Just srcT, Just specT) -> return (srcT < specT)-    _                       -> return False--------------------------------------------------------------------------------------- | GHC Interface Pipeline ---------------------------------------------------------------------------------------------------------------------------------------getTargetInfos :: Maybe HscEnv -> Config -> [FilePath] -> IO ([TargetInfo], HscEnv)-getTargetInfos hscEnv cfg tgtFiles' = do-  tgtFiles <- mapM canonicalizePath tgtFiles'-  _        <- mapM checkFilePresent tgtFiles-  _        <- mapM_ createTempDirectoryIfMissing tgtFiles-  logicMap <- liftIO makeLogicMap-  runLiquidGhc hscEnv cfg (getTargetInfos' cfg logicMap tgtFiles)--checkFilePresent :: FilePath -> IO ()-checkFilePresent f = do-  b <- doesFileExist f-  unless b $ panic Nothing ("Cannot find file: " ++ f)--getTargetInfos' :: Config -> LogicMap -> [FilePath] -> Ghc ([TargetInfo], HscEnv)-getTargetInfos' cfg logicMap tgtFiles = do-  _           <- compileCFiles cfg-  homeModules <- configureGhcTargets tgtFiles-  depGraph    <- buildDepGraph homeModules-  ghcInfos    <- processModules cfg logicMap tgtFiles depGraph homeModules-  hscEnv      <- getSession-  return (ghcInfos, hscEnv)--createTempDirectoryIfMissing :: FilePath -> IO ()-createTempDirectoryIfMissing tgtFile = Misc.tryIgnore "create temp directory" $-  createDirectoryIfMissing False $ tempDirectory tgtFile------------------------------------------------------------------------------------- | GHC Configuration & Setup -----------------------------------------------------------------------------------------------------------------------------------runLiquidGhc :: Maybe HscEnv -> Config -> Ghc a -> IO a-runLiquidGhc hscEnv cfg act =-  withSystemTempDirectory "liquid" $ \tmp ->-    runGhc (Just libdir) $ do-      maybe (return ()) setSession hscEnv-      df <- configureDynFlags cfg tmp-      prettyPrintGhcErrors df act--updateIncludePaths :: DynFlags -> [FilePath] -> IncludeSpecs -updateIncludePaths df ps = addGlobalInclude (includePaths df) ps --configureDynFlags :: Config -> FilePath -> Ghc DynFlags-configureDynFlags cfg tmp = do-  df <- getSessionDynFlags-  (df',_,_) <- parseDynamicFlags df $ map noLoc $ ghcOptions cfg-  loud <- liftIO isLoud-  let df'' = df' { importPaths  = nub $ idirs cfg ++ importPaths df'-                 , libraryPaths = nub $ idirs cfg ++ libraryPaths df'-                 , includePaths = updateIncludePaths df' (idirs cfg) -- addGlobalInclude (includePaths df') (idirs cfg) -                 , packageFlags = ExposePackage ""-                                                (PackageArg "ghc-prim")-                                                (ModRenaming True [])-                                : (packageFlags df')--                 , debugLevel   = 1               -- insert SourceNotes-                 -- , profAuto     = ProfAutoCalls-                 , ghcLink      = LinkInMemory-                 , hscTarget    = HscInterpreted-                 , ghcMode      = CompManager-                 -- prevent GHC from printing anything, unless in Loud mode-                 , log_action   = if loud-                                    then defaultLogAction-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)-                                    else \_ _ _ _ _ _ -> return ()-#else-                                    else \_ _ _ _ _   -> return ()-#endif-#endif-                 -- redirect .hi/.o/etc files to temp directory-                 , objectDir    = Just tmp-                 , hiDir        = Just tmp-                 , stubDir      = Just tmp-                 } `gopt_set` Opt_ImplicitImportQualified-                   `gopt_set` Opt_PIC-                   `gopt_set` Opt_DeferTypedHoles-                   `xopt_set` MagicHash-                   `xopt_set` DeriveGeneric-                   `xopt_set` StandaloneDeriving-  _ <- setSessionDynFlags df''-  return df''--configureGhcTargets :: [FilePath] -> Ghc ModuleGraph-configureGhcTargets tgtFiles = do-  targets         <- mapM (`guessTarget` Nothing) tgtFiles-  _               <- setTargets targets-  moduleGraph     <- depanal [] False -- see [NOTE:DROP-BOOT-FILES]--  let homeModules  = filter (not . isBootInterface . isBootSummary) $-                     flattenSCCs $ topSortModuleGraph False moduleGraph Nothing-  let homeNames    = moduleName . ms_mod <$> homeModules-  _               <- setTargetModules homeNames-  liftIO $ whenLoud $ print    ("Module Dependencies", homeNames)-  return $ mkModuleGraph homeModules--setTargetModules :: [ModuleName] -> Ghc ()-setTargetModules modNames = setTargets $ mkTarget <$> modNames-  where-    mkTarget modName = Ghc.Target (TargetModule modName) True Nothing--compileCFiles :: Config -> Ghc ()-compileCFiles cfg = do-  df  <- getSessionDynFlags-  _   <- setSessionDynFlags $-           df { includePaths = updateIncludePaths df (idirs cfg) -              , importPaths  = nub $ idirs cfg ++ importPaths df-              , libraryPaths = nub $ idirs cfg ++ libraryPaths df }-  hsc <- getSession-  os  <- mapM (\x -> liftIO $ compileFile hsc StopLn (x,Nothing)) (nub $ cFiles cfg)-  df  <- getSessionDynFlags-  void $ setSessionDynFlags $ df { ldInputs = nub $ map (FileOption "") os ++ ldInputs df }--{- | [NOTE:DROP-BOOT-FILES] Drop hs-boot files from the graph.-      We do it manually rather than using the flag to topSortModuleGraph-      because otherwise the order of mutually recursive modules depends-      on the modulename, e.g. given--      Bar.hs --> Foo.hs --> Bar.hs-boot--      we'll get-      -      [Bar.hs, Foo.hs]-    -      which is backwards..- -}------------------------------------------------------------------------------------ Home Module Dependency Graph -----------------------------------------------------------------------------------------------------------------------------------type DepGraph = Graph DepGraphNode-type DepGraphNode = Node Module ()--reachableModules :: DepGraph -> Module -> [Module]-reachableModules depGraph mod =-  node_key <$> tail (reachableG depGraph (DigraphNode () mod []))--buildDepGraph :: ModuleGraph -> Ghc DepGraph-buildDepGraph homeModules =-  graphFromEdgedVerticesOrd <$> mapM mkDepGraphNode (mgModSummaries homeModules)--mkDepGraphNode :: ModSummary -> Ghc DepGraphNode-mkDepGraphNode modSummary = -  DigraphNode () (ms_mod modSummary) <$> (filterM isHomeModule =<< modSummaryImports modSummary)--isHomeModule :: GhcMonadLike m => Module -> m Bool-isHomeModule mod = do-  homePkg <- thisPackage <$> getDynFlags-  return   $ moduleUnitId mod == homePkg--modSummaryImports :: GhcMonadLike m => ModSummary -> m [Module]-modSummaryImports modSummary =-  mapM (importDeclModule (ms_mod modSummary))-       (ms_textual_imps modSummary)--importDeclModule :: GhcMonadLike m => Module -> (Maybe FastString,  Ghc.Located ModuleName) -> m Module-importDeclModule fromMod (pkgQual, locModName) = do-  hscEnv <- askHscEnv-  let modName = unLoc locModName-  result <- liftIO $ findImportedModule hscEnv modName pkgQual-  case result of-    Ghc.Found _ mod -> return mod-    _ -> do-      dflags <- getDynFlags-      liftIO $ throwGhcExceptionIO $ ProgramError $-        O.showPpr dflags (moduleName fromMod) ++ ": " ++-        O.showSDoc dflags (cannotFindModule dflags modName result)------------------------------------------------------------------------------------- | Extract Ids --------------------------------------------------------------------------------------------------------------------------------------------------classCons :: Maybe [ClsInst] -> [Id]-classCons Nothing   = []-classCons (Just cs) = concatMap (dataConImplicitIds . head . tyConDataCons . classTyCon . is_cls) cs--derivedVars :: Config -> MGIModGuts -> [Var]  -derivedVars cfg mg  = concatMap (dFunIdVars cbs . is_dfun) derInsts -  where -    derInsts        -      | checkDer    = insts -      | otherwise   = filter isDerivedInstance insts-    insts           = mgClsInstances mg -    checkDer        = checkDerived cfg-    cbs             = mgi_binds mg-               --mgClsInstances :: MGIModGuts -> [ClsInst]-mgClsInstances = fromMaybe [] . mgi_cls_inst --dFunIdVars :: CoreProgram -> DFunId -> [Id]-dFunIdVars cbs fd  = notracepp msg $ concatMap bindersOf cbs' ++ deps-  where-    msg            = "DERIVED-VARS-OF: " ++ showpp fd-    cbs'           = filter f cbs-    f (NonRec x _) = eqFd x-    f (Rec xes)    = any eqFd (fst <$> xes)-    eqFd x         = varName x == varName fd-    deps           = concatMap unfoldDep unfolds-    unfolds        = unfoldingInfo . idInfo <$> concatMap bindersOf cbs'--unfoldDep :: Unfolding -> [Id]-unfoldDep (DFunUnfolding _ _ e)       = concatMap exprDep e-unfoldDep CoreUnfolding {uf_tmpl = e} = exprDep e-unfoldDep _                           = []--exprDep :: CoreExpr -> [Id]-exprDep = freeVars S.empty--importVars :: CoreProgram -> [Id]-importVars = freeVars S.empty--_definedVars :: CoreProgram -> [Id]-_definedVars = concatMap defs-  where-    defs (NonRec x _) = [x]-    defs (Rec xes)    = map fst xes------------------------------------------------------------------------------------- | Per-Module Pipeline ------------------------------------------------------------------------------------------------------------------------------------------type SpecEnv = ModuleEnv (ModName, Ms.BareSpec)--processModules :: Config -> LogicMap -> [FilePath] -> DepGraph -> ModuleGraph -> Ghc [TargetInfo]-processModules cfg logicMap tgtFiles depGraph homeModules = do-  -- DO NOT DELETE: liftIO $ putStrLn $ "Process Modules: TargetFiles = " ++ show tgtFiles-  catMaybes . snd <$> Misc.mapAccumM go emptyModuleEnv (mgModSummaries homeModules)-  where                                             -    go = processModule cfg logicMap (S.fromList tgtFiles) depGraph--processModule :: Config -> LogicMap -> S.HashSet FilePath -> DepGraph -> SpecEnv -> ModSummary-              -> Ghc (SpecEnv, Maybe TargetInfo)-processModule cfg logicMap tgtFiles depGraph specEnv modSummary = do-  let mod              = ms_mod modSummary-  -- DO-NOT-DELETE _                <- liftIO $ whenLoud $ putStrLn $ "Process Module: " ++ showPpr (moduleName mod)-  file                <- liftIO $ canonicalizePath $ modSummaryHsFile modSummary-  let isTarget         = file `S.member` tgtFiles-  _                   <- loadDependenciesOf $ moduleName mod-  parsed              <- parseModule $ keepRawTokenStream modSummary-  let specComments     = extractSpecComments (pm_annotations parsed)-  typechecked         <- typecheckModule $ ignoreInline parsed-  let specQuotes       = extractSpecQuotes typechecked-  _                   <- loadModule' typechecked-  (modName, commSpec) <- either throw return $ hsSpecificationP (moduleName mod) specComments specQuotes--  liftedSpec          <- liftIO $ if isTarget || null specComments then return Nothing else loadLiftedSpec cfg file -  let bareSpec         = updLiftedSpec commSpec liftedSpec-  _                   <- checkFilePragmas $ Ms.pragmas bareSpec-  let specEnv'         = extendModuleEnv specEnv mod (modName, noTerm bareSpec)-  (specEnv', ) <$> if isTarget-                     then Just <$> processTargetModule cfg logicMap depGraph specEnv file typechecked bareSpec-                     else return Nothing--updLiftedSpec :: Ms.BareSpec -> Maybe Ms.BareSpec -> Ms.BareSpec -updLiftedSpec s1 Nothing   = s1 -updLiftedSpec s1 (Just s2) = (clearSpec s1) `mappend` s2 --clearSpec :: Ms.BareSpec -> Ms.BareSpec-clearSpec s = s { sigs = [], asmSigs = [], aliases = [], ealiases = [], qualifiers = [], dataDecls = [] }--keepRawTokenStream :: ModSummary -> ModSummary-keepRawTokenStream modSummary = modSummary-  { ms_hspp_opts = ms_hspp_opts modSummary `gopt_set` Opt_KeepRawTokenStream }--loadDependenciesOf :: GhcMonad m => ModuleName -> m ()-loadDependenciesOf modName = do-  loadResult <- load $ LoadDependenciesOf modName-  when (failed loadResult) $ liftIO $ throwGhcExceptionIO $ ProgramError $-   "Failed to load dependencies of module " ++ showPpr modName--loadModule' :: TypecheckedModule -> Ghc TypecheckedModule-loadModule' tm = loadModule tm'-  where-    pm   = tm_parsed_module tm-    ms   = pm_mod_summary pm-    df   = ms_hspp_opts ms-    df'  = df { hscTarget = HscNothing, ghcLink = NoLink }-    ms'  = ms { ms_hspp_opts = df' }-    pm'  = pm { pm_mod_summary = ms' }-    tm'  = tm { tm_parsed_module = pm' }-----      -- -- we should be able to setContext regardless of whether-      -- -- we use the ghc api. However, ghc will complain-      -- -- if the filename does not match the module name-      -- when (typeclass cfg) $ do-      --   Ghc.setContext [iimport |(modName, _) <- allSpecs legacyBareSpec,-      --                   let iimport = if isTarget modName-      --                                 then Ghc.IIModule (getModName modName)-      --                                 else Ghc.IIDecl (Ghc.simpleImportDecl (getModName modName))]-      --   void $ Ghc.execStmt-      --     "let {infixr 1 ==>; True ==> False = False; _ ==> _ = True}"-      --     Ghc.execOptions-      --   void $ Ghc.execStmt-      --     "let {infixr 1 <=>; True <=> False = False; _ <=> _ = True}"-      --     Ghc.execOptions-      --   void $ Ghc.execStmt-      --     "let {infix 4 ==; (==) :: a -> a -> Bool; _ == _ = undefined}"-      --     Ghc.execOptions-      --   void $ Ghc.execStmt-      --     "let {infix 4 /=; (/=) :: a -> a -> Bool; _ /= _ = undefined}"-      --     Ghc.execOptions-      --   void $ Ghc.execStmt-      --     "let {infixl 7 /; (/) :: Num a => a -> a -> a; _ / _ = undefined}"-      --     Ghc.execOptions        -      --   void $ Ghc.execStmt-      --     "let {len :: [a] -> Int; len _ = undefined}"-      --     Ghc.execOptions        -processTargetModule :: Config -> LogicMap -> DepGraph -> SpecEnv -> FilePath -> TypecheckedModule -> Ms.BareSpec-                    -> Ghc TargetInfo-processTargetModule cfg0 logicMap depGraph specEnv file typechecked bareSpec = do-  withPragmas cfg0 file (Ms.pragmas bareSpec) $ \cfg -> do-    let modSum    = pm_mod_summary (tm_parsed_module typechecked)-    ghcSrc       <- makeGhcSrc    cfg file     typechecked modSum-    dependencies <- makeDependencies cfg depGraph specEnv modSum bareSpec--    let targetSrc = view targetSrcIso ghcSrc-    dynFlags <- getDynFlags-  -- set up the interactive context-    when (typeclass cfg) $-      loadContext (view bareSpecIso bareSpec) dependencies targetSrc-    (msgs, specM) <- Ghc.withSession $ \hsc_env -> liftIO $ runTcInteractive hsc_env-      (makeTargetSpec cfg logicMap targetSrc (view bareSpecIso bareSpec) dependencies)-    case specM of-      Nothing -> panic Nothing  $ O.showSDoc dynFlags $ O.sep (Ghc.pprErrMsgBagWithLoc (snd msgs))-      Just spec ->-        case spec of-          Left diagnostics -> do-            mapM_ (liftIO . printWarning dynFlags) (allWarnings diagnostics)-            throw (allErrors diagnostics)-          Right (warns, targetSpec, liftedSpec) -> do-            mapM_ (liftIO . printWarning dynFlags) warns-            -- The call below is temporary, we should really load & save directly 'LiftedSpec's.-            _          <- liftIO $ saveLiftedSpec (_giTarget ghcSrc) (unsafeFromLiftedSpec liftedSpec)-            return      $ TargetInfo targetSrc targetSpec--  -- cfg          <- liftIO $ withPragmas cfg0 file (Ms.pragmas bareSpec)-  -- let modSum    = pm_mod_summary (tm_parsed_module typechecked)-  -- ghcSrc       <- makeGhcSrc    cfg file     typechecked modSum-  -- dependencies <- makeDependencies cfg depGraph specEnv modSum bareSpec--  -- let targetSrc = view targetSrcIso ghcSrc-  -- dynFlags <- getDynFlags-  -- -- set up the interactive context-  -- when (typeclass cfg) $-  --   loadContext (view bareSpecIso bareSpec) dependencies targetSrc-  -- (msgs, specM) <- Ghc.withSession $ \hsc_env -> liftIO $ runTcInteractive hsc_env-  --   (makeTargetSpec cfg logicMap targetSrc (view bareSpecIso bareSpec) dependencies)-  -- case specM of-  --   Nothing -> panic Nothing  $ O.showSDoc dynFlags $ O.sep (Ghc.pprErrMsgBagWithLoc (snd msgs))-  --   Just spec ->-  --     case spec of-  --       Left diagnostics -> do-  --         mapM_ (liftIO . printWarning dynFlags) (allWarnings diagnostics)-  --         throw (allErrors diagnostics)-  --       Right (warns, targetSpec, liftedSpec) -> do-  --         mapM_ (liftIO . printWarning dynFlags) warns-      -  --     -- makeTargetSpec cfg logicMap targetSrc (view bareSpecIso bareSpec) dependencies >>= \case-  --     --   Left  validationErrors -> Bare.checkThrow (Left validationErrors)-  --     --   Right (targetSpec, liftedSpec) -> do-      -  --     -- The call below is temporary, we should really load & save directly 'LiftedSpec's.-  --         _          <- liftIO $ saveLiftedSpec (_giTarget ghcSrc) (unsafeFromLiftedSpec liftedSpec)-  --         return      $ TargetInfo targetSrc targetSpec---loadContext :: BareSpec -> TargetDependencies -> TargetSrc -> Ghc ()-loadContext bareSpec dependencies targetSrc = do-  Ghc.setContext $ [Ghc.IIModule (getModName modName) |(modName, _) <- allSpecs legacyBareSpec,-                    isTarget modName]--  where-    toLegacyDep :: (StableModule, LiftedSpec) -> (ModName, Ms.BareSpec)-    toLegacyDep (sm, ls) = (ModName SrcImport (Ghc.moduleName . unStableModule $ sm), unsafeFromLiftedSpec ls)--    toLegacyTarget :: Ms.BareSpec -> (ModName, Ms.BareSpec)-    toLegacyTarget validatedSpec = (giTargetMod targetSrc, validatedSpec)--    legacyDependencies :: [(ModName, Ms.BareSpec)]-    legacyDependencies = map toLegacyDep . HM.toList . getDependencies $ dependencies--    allSpecs :: Ms.BareSpec -> [(ModName, Ms.BareSpec)]-    allSpecs validSpec = toLegacyTarget validSpec : legacyDependencies--    -- legacyBareSpec :: Spec LocBareType F.LocSymbol-    legacyBareSpec = review bareSpecIso bareSpec-------------------------------------------------------------------------------------------- | @makeGhcSrc@ builds all the source-related information needed for consgen ------------------------------------------------------------------------------------------makeGhcSrc :: Config -> FilePath -> TypecheckedModule -> ModSummary -> Ghc GhcSrc -makeGhcSrc cfg file typechecked modSum = do-  modGuts'          <- GhcMonadLike.desugarModule modSum typechecked--  let modGuts        = makeMGIModGuts modGuts'-  hscEnv            <- getSession-  coreBinds         <- liftIO $ anormalize cfg hscEnv modGuts'-  _                 <- liftIO $ whenNormal $ Misc.donePhase Misc.Loud "A-Normalization"-  let dataCons       = concatMap (map dataConWorkId . tyConDataCons) (mgi_tcs modGuts)-  (fiTcs, fiDcs)    <- makeFamInstEnv <$> liftIO (getFamInstances hscEnv)-  things            <- lookupTyThings hscEnv modSum (fst $ tm_internals_ typechecked)--  availableTcs      <- availableTyCons hscEnv modSum (fst $ tm_internals_ typechecked) (mg_exports modGuts')--  let impVars        = importVars coreBinds ++ classCons (mgi_cls_inst modGuts)-  incDir            <- liftIO $ Misc.getIncludeDir--  --liftIO $ do-  --  print $ "_gsTcs   => " ++ show (nub $ (mgi_tcs      modGuts) ++ availableTcs)-  --  print $ "_gsFiTcs => " ++ show fiTcs-  --  print $ "_gsFiDcs => " ++ show fiDcs-  --  print $ "dataCons => " ++ show dataCons-  --  print $ "defVars  => " ++ show (dataCons ++ (letVars coreBinds))--  return $ Src -    { _giIncDir    = incDir -    , _giTarget    = file-    , _giTargetMod = ModName Target (moduleName (ms_mod modSum))-    , _giCbs       = coreBinds-    , _giImpVars   = impVars -    , _giDefVars   = dataCons ++ (letVars coreBinds) -    , _giUseVars   = readVars coreBinds-    , _giDerVars   = S.fromList (derivedVars cfg modGuts) -    , _gsExports   = mgi_exports  modGuts -    , _gsTcs       = nub $ (mgi_tcs      modGuts) ++ availableTcs-    , _gsCls       = mgi_cls_inst modGuts -    , _gsFiTcs     = fiTcs -    , _gsFiDcs     = fiDcs-    , _gsPrimTcs   = Ghc.primTyCons-    , _gsQualImps  = qualifiedImports (maybe mempty (view _2) (tm_renamed_source typechecked))-    , _gsAllImps   = allImports       (maybe mempty (view _2) (tm_renamed_source typechecked))-    , _gsTyThings  = [ t | (_, Just t) <- things ] -    }--_impThings :: [Var] -> [TyThing] -> [TyThing]-_impThings vars  = filter ok-  where-    vs          = S.fromList vars -    ok (AnId x) = S.member x vs  -    ok _        = True --allImports :: [LImportDecl GhcRn] -> S.HashSet Symbol -allImports = \case-  []-> Debug.trace "WARNING: Missing RenamedSource" mempty -  imps -> S.fromList (symbol . unLoc . ideclName . unLoc <$> imps)--qualifiedImports :: [LImportDecl GhcRn] -> QImports -qualifiedImports = \case-  []   -> Debug.trace "WARNING: Missing RenamedSource" (qImports mempty) -  imps -> qImports [ (qn, n) | i         <- imps-                                          , let decl   = unLoc i-                                          , let m      = unLoc (ideclName decl)  -                                          , qm        <- maybeToList (unLoc <$> ideclAs decl) -                                          , let [n,qn] = symbol <$> [m, qm] -                                          ]--qImports :: [(Symbol, Symbol)] -> QImports -qImports qns  = QImports -  { qiNames   = Misc.group qns -  , qiModules = S.fromList (snd <$> qns) -  }--------------------------------------------------------------------------------------------- | @lookupTyThings@ grabs all the @Name@s and associated @TyThing@ known to GHC ---   for this module; we will use this to create our name-resolution environment ---   (see `Bare.Resolve`)                                          -----------------------------------------------------------------------------------------lookupTyThings :: GhcMonadLike m => HscEnv -> ModSummary -> TcGblEnv -> m [(Name, Maybe TyThing)]-lookupTyThings hscEnv modSum tcGblEnv = forM names (lookupTyThing hscEnv modSum tcGblEnv)-  where-    names :: [Ghc.Name] -    names  = liftM2 (++)-             (fmap Ghc.gre_name . Ghc.globalRdrEnvElts . tcg_rdr_env)-             (fmap is_dfun_name . tcg_insts) tcGblEnv--- | Lookup a single 'Name' in the GHC environment, yielding back the 'Name' alongside the 'TyThing',--- if one is found.-lookupTyThing :: GhcMonadLike m => HscEnv -> ModSummary -> TcGblEnv -> Name -> m (Name, Maybe TyThing)-lookupTyThing hscEnv modSum tcGblEnv n = do-  mi  <- GhcMonadLike.moduleInfoTc modSum tcGblEnv-  tt1 <-          GhcMonadLike.lookupName      n-  tt2 <- liftIO $ Ghc.hscTcRcLookupName hscEnv n-  tt3 <-          GhcMonadLike.modInfoLookupName mi n-  tt4 <-          GhcMonadLike.lookupGlobalName n-  return (n, Misc.firstMaybes [tt1, tt2, tt3, tt4])--availableTyThings :: GhcMonadLike m => HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> m [TyThing]-availableTyThings hscEnv modSum tcGblEnv avails = fmap (catMaybes . mconcat) $ forM avails $ \a -> do-  results <- case a of-    Avail n        -> pure <$> lookupTyThing hscEnv modSum tcGblEnv n-    AvailTC n ns _ -> forM (n : ns) $ lookupTyThing hscEnv modSum tcGblEnv-  pure . map snd $ results---- | Returns all the available (i.e. exported) 'TyCon's (type constructors) for the input 'Module'.-availableTyCons :: GhcMonadLike m => HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> m [Ghc.TyCon]-availableTyCons hscEnv modSum tcGblEnv avails = -  fmap (\things -> [tyCon | (ATyCon tyCon) <- things]) (availableTyThings hscEnv modSum tcGblEnv avails)---- | Returns all the available (i.e. exported) 'Var's for the input 'Module'.-availableVars :: GhcMonadLike m => HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> m [Ghc.Var]-availableVars hscEnv modSum tcGblEnv avails = -  fmap (\things -> [var | (AnId var) <- things]) (availableTyThings hscEnv modSum tcGblEnv avails)---- lookupTyThings :: HscEnv -> TypecheckedModule -> MGIModGuts -> Ghc [(Name, Maybe TyThing)] --- lookupTyThings hscEnv tcm mg =---   forM (mgNames mg ++ instNames mg) $ \n -> do ---     tt1 <-          lookupName                   n ---     tt2 <- liftIO $ Ghc.hscTcRcLookupName hscEnv n ---     tt3 <-          modInfoLookupName mi         n ---     tt4 <-          lookupGlobalName             n ---     return (n, Misc.firstMaybes [tt1, tt2, tt3, tt4])---     where ---       mi = tm_checked_module_info tcm----- lookupName        :: GhcMonad m => Name -> m (Maybe TyThing) --- hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)--- modInfoLookupName :: GhcMonad m => ModuleInfo -> Name -> m (Maybe TyThing)  --- lookupGlobalName  :: GhcMonad m => Name -> m (Maybe TyThing)  --_dumpTypeEnv :: TypecheckedModule -> IO () -_dumpTypeEnv tm = do -  print "DUMP-TYPE-ENV"-  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 -------------------------------------------------------------------------------------------- | @makeDependencies@ loads BareSpec for target and imported modules --- /IMPORTANT(adn)/: We \"cheat\" a bit by creating a 'Module' out the 'ModuleName' we --- parse from the spec, and convert the former into a 'StableModule' for the purpose--- of dependency tracking. This means, in practice, that all the \"wired-in-prelude\"--- specs will share the same `UnitId`, which for the sake of the executable is an--- acceptable compromise, as long as we don't create duplicates.-----------------------------------------------------------------------------------------makeDependencies :: Config -> DepGraph -> SpecEnv -> ModSummary -> Ms.BareSpec -                 -> Ghc TargetDependencies-makeDependencies cfg depGraph specEnv modSum _ = do -  let paths     = S.fromList $ idirs cfg ++ importPaths (ms_hspp_opts modSum)-  _            <- liftIO $ whenLoud $ putStrLn $ "paths = " ++ show paths-  let reachable = reachableModules depGraph (ms_mod modSum)-  specSpecs    <- findAndParseSpecFiles cfg paths modSum reachable-  let homeSpecs = cachedBareSpecs specEnv reachable--  -- NOTE:(adn) Unfortunately for the executable we might have 3 different 'Prelude' specs-  -- (one for the Prelude functions, one for the Real/NonReal and one for the PatErr, so we-  -- cannot really assume all the module names will be disjointed. As a result we have to-  -- hack our way around this by replacing the 'UnitId' with some unique enumeration, at-  -- least unique in this local scope.--  let combine ix (mn, sp) = ((mn, ix), sp)-  let impSpecs  = map (bimap mkStableModule (view liftedSpecGetter)) (zipWith combine [0..] (specSpecs ++ homeSpecs))--  return        $ TargetDependencies $ HM.fromList impSpecs-  where-    mkStableModule :: (ModName, Int) -> StableModule-    mkStableModule (modName, ix) =-      Ghc.mkStableModule (fakeUnitId (moduleUnitId targetModule) ix) (getModName modName)--    fakeUnitId :: UnitId -> Int -> UnitId-    fakeUnitId uid ix = stringToUnitId $ unitIdString uid ++ show ix--    targetModule :: Module-    targetModule = ms_mod modSum--modSummaryHsFile :: ModSummary -> FilePath-modSummaryHsFile modSummary =-  fromMaybe-    (panic Nothing $-      "modSummaryHsFile: missing .hs file for " ++-      showPpr (ms_mod modSummary))-    (ml_hs_file $ ms_location modSummary)--cachedBareSpecs :: SpecEnv -> [Module] -> [(ModName, Ms.BareSpec)]-cachedBareSpecs specEnv mods = lookupBareSpec <$> mods-  where-    lookupBareSpec m         = fromMaybe (err m) (lookupModuleEnv specEnv m)-    err m                    = impossible Nothing ("lookupBareSpec: missing module " ++ showPpr m)--checkFilePragmas :: GhcMonadLike m => [Located String] -> m ()-checkFilePragmas = Misc.applyNonNull (return ()) throw . mapMaybe err-  where-    err pragma-      | check (val pragma) = Just (ErrFilePragma $ fSrcSpan pragma :: Error)-      | otherwise          = Nothing-    check pragma           = any (`isPrefixOf` pragma) bad-    bad =-      [ "-i", "--idirs"-      , "-g", "--ghc-option"-      , "--c-files", "--cfiles"-      ]------------------------------------------------------------------------------------- | Family instance information----------------------------------------------------------------------------------makeFamInstEnv :: [FamInst] -> ([Ghc.TyCon], [(Symbol, DataCon)])-makeFamInstEnv famInsts =-  let fiTcs = [ tc            | FamInst { fi_flavor = DataFamilyInst tc } <- famInsts ]-      fiDcs = [ (symbol d, d) | tc <- fiTcs, d <- tyConDataCons tc ]-  in (fiTcs, fiDcs)--getFamInstances :: HscEnv -> IO [FamInst]-getFamInstances env = do-  (_, Just (pkg_fie, home_fie)) <- runTcInteractive env tcGetFamInstEnvs-  return $ famInstEnvElts home_fie ++ famInstEnvElts pkg_fie- ------------------------------------------------------------------------------------ | Extract Specifications from GHC -----------------------------------------------------------------------------------------------------------------------------extractSpecComments :: ApiAnns -> [(SourcePos, String)]-extractSpecComments = mapMaybe extractSpecComment . GhcMonadLike.apiComments---- | 'extractSpecComment' pulls out the specification part from a full comment---   string, i.e. if the string is of the form:---   1. '{-@ S @-}' then it returns the substring 'S',---   2. '{-@ ... -}' then it throws a malformed SPECIFICATION ERROR, and---   3. Otherwise it is just treated as a plain comment so we return Nothing.--extractSpecComment :: Ghc.Located AnnotationComment -> Maybe (SourcePos, String)-extractSpecComment (Ghc.L sp (AnnBlockComment text))-  | isPrefixOf "{-@" text && isSuffixOf "@-}" text          -- valid   specification-  = Just (offsetPos, take (length text - 6) $ drop 3 text)-  | isPrefixOf "{-@" text                                   -- invalid specification-  = uError $ ErrParseAnn sp "A valid specification must have a closing '@-}'."-  where-    offsetPos = case srcSpanSourcePos sp of-      SourcePos file line col -> safeSourcePos file (unPos line) (unPos col + 3)-extractSpecComment _ = Nothing--extractSpecQuotes :: TypecheckedModule -> [BPspec]-extractSpecQuotes = -  extractSpecQuotes' (ms_mod . pm_mod_summary . tm_parsed_module) -                     (tcg_anns . fst . tm_internals_)--extractSpecQuotes' :: (a -> Module) -> (a -> [Annotation]) -> a -> [BPspec]-extractSpecQuotes' thisModule getAnns a = mapMaybe extractSpecQuote anns-  where-    anns = map ann_value $-           filter (isOurModTarget . ann_target) $-           getAnns a--    isOurModTarget (ModuleTarget mod1) = mod1 == thisModule a-    isOurModTarget _ = False--extractSpecQuote :: AnnPayload -> Maybe BPspec-extractSpecQuote payload = -  case fromSerialized deserializeWithData payload of-    Nothing -> Nothing-    Just qt -> Just $ refreshSymbols $ liquidQuoteSpec qt--refreshSymbols :: Data a => a -> a-refreshSymbols = everywhere (mkT refreshSymbol)--refreshSymbol :: Symbol -> Symbol-refreshSymbol = symbol . symbolText------------------------------------------------------------------------------------- | Finding & Parsing Files ---------------------------------------------------------------------------------------------------------------------------------------- | Handle Spec Files -----------------------------------------------------------findAndParseSpecFiles :: GhcMonadLike m-                      => Config-                      -> S.HashSet FilePath-                      -> ModSummary-                      -> [Module]-                      -> m [(ModName, Ms.BareSpec)]-findAndParseSpecFiles cfg paths modSummary reachable = do-  modGraph <- GhcMonadLike.getModuleGraph-  impSumms <- mapM GhcMonadLike.getModSummary (moduleName <$> reachable)-  imps''   <- nub . concat <$> mapM modSummaryImports (modSummary : impSumms)-  imps'    <- filterM ((not <$>) . isHomeModule) imps''-  let imps  = m2s <$> imps'-  fs'      <- liftIO $ moduleFiles modGraph Spec paths imps-  -- liftIO  $ whenLoud  $ print ("moduleFiles-imps'': "  ++ show (m2s <$> imps''))-  -- liftIO  $ whenLoud  $ print ("moduleFiles-imps' : "  ++ show (m2s <$> imps'))-  -- liftIO  $ whenLoud  $ print ("moduleFiles-imps  : "  ++ show imps)-  -- liftIO  $ whenLoud  $ print ("moduleFiles-Paths : "  ++ show paths)-  -- liftIO  $ whenLoud  $ print ("moduleFiles-Specs : "  ++ show fs')-  patSpec  <- liftIO $ getPatSpec  modGraph paths $ totalityCheck cfg-  rlSpec   <- liftIO $ getRealSpec modGraph paths $ not (linear cfg)-  let fs    = patSpec ++ rlSpec ++ fs'-  liftIO $ transParseSpecs modGraph paths mempty mempty fs-  where-    m2s = moduleNameString . moduleName--getPatSpec :: ModuleGraph -> S.HashSet FilePath -> Bool -> IO [FilePath]-getPatSpec modGraph paths totalitycheck- | totalitycheck = moduleFiles modGraph Spec paths [patErrorName]- | otherwise     = return []- where-  patErrorName   = "PatErr"--getRealSpec :: ModuleGraph -> S.HashSet FilePath -> Bool -> IO [FilePath]-getRealSpec modGraph paths freal-  | freal     = moduleFiles modGraph Spec paths [realSpecName]-  | otherwise = moduleFiles modGraph Spec paths [notRealSpecName]-  where-    realSpecName    = "Real"-    notRealSpecName = "NotReal"--transParseSpecs :: ModuleGraph-                -> S.HashSet FilePath-                -> S.HashSet FilePath -                -> [(ModName, Ms.BareSpec)]-                -> [FilePath]-                -> IO [(ModName, Ms.BareSpec)]-transParseSpecs _ _ _ specs [] = return specs-transParseSpecs modGraph paths seenFiles specs newFiles = do-  -- liftIO $ print ("TRANS-PARSE-SPECS", seenFiles, newFiles)-  newSpecs      <- liftIO $ mapM parseSpecFile newFiles-  impFiles      <- moduleFiles modGraph Spec paths $ specsImports newSpecs-  let seenFiles' = seenFiles `S.union` S.fromList newFiles-  let specs'     = specs ++ map (second noTerm) newSpecs-  let newFiles'  = filter (not . (`S.member` seenFiles')) impFiles-  transParseSpecs modGraph paths seenFiles' specs' newFiles'-  where-    specsImports ss = nub $ concatMap (map symbolString . Ms.imports . snd) ss--noTerm :: Ms.BareSpec -> Ms.BareSpec-noTerm spec = spec { Ms.decr = mempty, Ms.lazy = mempty, Ms.termexprs = mempty }---- | Parse a spec file by path.------ On a parse error, we fail.------ TODO, Andres: It would be better to fail more systematically, but currently we--- seem to have an option between throwing an error which will be reported badly,--- or printing the error ourselves.----parseSpecFile :: FilePath -> IO (ModName, Ms.BareSpec)-parseSpecFile file = do-  contents <- Misc.sayReadFile file-  case specSpecificationP file contents of-    Left peb -> do-      hPutStrLn stderr (errorBundlePretty peb)-      panic Nothing "parsing spec file failed"-    Right x  -> pure x---- Find Hquals Files --------------------------------------------------------------- _moduleHquals :: MGIModGuts---              -> [FilePath]---              -> FilePath---              -> [String]---              -> [FilePath]---              -> Ghc [FilePath]--- _moduleHquals mgi paths target imps incs = do---   hqs   <- specIncludes Hquals paths incs---   hqs'  <- moduleFiles Hquals paths (mgi_namestring mgi : imps)---   hqs'' <- liftIO $ filterM doesFileExist [extFileName Hquals target]---   return $ Misc.sortNub $ hqs'' ++ hqs ++ hqs'---- Find Files for Modules --------------------------------------------------------moduleFiles :: ModuleGraph -> Ext -> S.HashSet FilePath -> [String] -> IO [FilePath]-moduleFiles modGraph ext paths names = catMaybes <$> mapM (moduleFile modGraph ext paths) names--moduleFile :: ModuleGraph -> Ext -> S.HashSet FilePath -> String -> IO (Maybe FilePath)-moduleFile modGraph ext (S.toList -> paths) name-  | ext `elem` [Hs, LHs] = do-    let graph = mgModSummaries modGraph-    case find (\m -> not (isBootInterface . isBootSummary $ m) &&-                     name == moduleNameString (ms_mod_name m)) graph of-      Nothing -> getFileInDirs (extModuleName name ext) paths-      Just ms -> return $ normalise <$> ml_hs_file (ms_location ms)-  | otherwise = getFileInDirs (extModuleName name ext) paths-------------------------------------------------------------------------------------- Assemble Information for Spec Extraction -----------------------------------------------------------------------------------------------------------------------makeMGIModGuts :: ModGuts -> MGIModGuts-makeMGIModGuts modGuts = miModGuts deriv modGuts-  where-    deriv   = Just $ instEnvElts $ mg_inst_env modGuts--makeLogicMap :: IO LogicMap-makeLogicMap = do-  lg    <- Misc.getCoreToLogicPath-  lspec <- Misc.sayReadFile lg-  case parseSymbolToLogic lg lspec of-    Left peb -> do-      hPutStrLn stderr (errorBundlePretty peb)-      panic Nothing "makeLogicMap failed"-    Right lm -> return (lm <> listLMap)--listLMap :: LogicMap -- TODO-REBARE: move to wiredIn-listLMap  = toLogicMap [ (dummyLoc nilName , []     , hNil)-                       , (dummyLoc consName, [x, xs], hCons (EVar <$> [x, xs])) ]-  where-    x     = "x"-    xs    = "xs"-    hNil  = mkEApp (dcSym Ghc.nilDataCon ) []-    hCons = mkEApp (dcSym Ghc.consDataCon)-    dcSym = dummyLoc . dropModuleUnique . symbol--------------------------------------------------------------------------------------- | Pretty Printing ----------------------------------------------------------------------------------------------------------------------------------------------instance PPrint TargetSpec where-  pprintTidy k spec = vcat-    [ "******* Target Variables ********************"-    , pprintTidy k $ gsTgtVars (gsVars spec)-    , "******* Type Signatures *********************"-    , pprintLongList k (gsTySigs (gsSig spec))-    , "******* Assumed Type Signatures *************"-    , pprintLongList k (gsAsmSigs (gsSig spec))-    , "******* DataCon Specifications (Measure) ****"-    , pprintLongList k (gsCtors (gsData spec))-    , "******* Measure Specifications **************"-    , pprintLongList k (gsMeas (gsData spec))       ]--instance PPrint TargetInfo where-  pprintTidy k info = vcat-    [ -- "*************** Imports *********************"-      -- , intersperse comma $ text <$> imports info-      -- , "*************** Includes ********************"-      -- , intersperse comma $ text <$> includes info-      "*************** Imported Variables **********"-    , pprDoc $ _giImpVars (review targetSrcIso $ giSrc info)-    , "*************** Defined Variables ***********"-    , pprDoc $ _giDefVars (review targetSrcIso $ giSrc info)-    , "*************** Specification ***************"-    , pprintTidy k $ giSpec info-    , "*************** Core Bindings ***************"-    , pprintCBs $ _giCbs (review targetSrcIso $ giSrc info) ]---- RJ: the silly guards below are to silence the unused-var checker-pprintCBs :: [CoreBind] -> Doc-pprintCBs-  | otherwise = pprintCBsTidy-  | otherwise = pprintCBsVerbose-  where-    pprintCBsTidy    = pprDoc . tidyCBs-    pprintCBsVerbose = text . O.showSDocDebug unsafeGlobalDynFlags . O.ppr . tidyCBs--instance Show TargetInfo where-  show = showpp--instance PPrint TargetVars where-  pprintTidy _ AllVars   = text "All Variables"-  pprintTidy k (Only vs) = text "Only Variables: " <+> pprintTidy k vs----------------------------------------------------------------------------- Dealing with Errors ------------------------------------------------------------------------------------------------------------------------------instance Result SourceError where-  result = (`Crash` "Invalid Source") . sourceErrors ""
− src/Language/Haskell/Liquid/GHC/Logging.hs 
@@ -1,73 +0,0 @@-{- | This module exposes variations over the standard GHC's logging functions to work with the 'Doc'-     type from the \"pretty\" package. We would like LiquidHaskell to emit diagnostic messages using the very-     same GHC machinery, so that IDE-like programs (e.g. \"ghcid\", \"ghcide\" etc) would be able to-     correctly show errors and warnings to the users, in ther editors.--     Unfortunately, this is not possible to do out of the box because LiquidHaskell uses the 'Doc' type from-     the \"pretty\" package but GHC uses (for historical reasons) its own version. Due to the fact none of-     the constructors are exported, we simply cannot convert between the two types effortlessly, but we have-     to pay the price of a pretty-printing \"roundtrip\".--}--{-# LANGUAGE CPP #-}--module Language.Haskell.Liquid.GHC.Logging (-    fromPJDoc-  , putWarnMsg-  , putErrMsg-  , mkLongErrAt-  ) where--import qualified Language.Haskell.Liquid.GHC.API as GHC-import qualified Text.PrettyPrint.HughesPJ as PJ---- Unfortunately we need the import below to bring in scope 'PPrint' instances.-import Language.Haskell.Liquid.Types.Errors ()--fromPJDoc :: PJ.Doc -> GHC.SDoc-fromPJDoc = GHC.text . PJ.render---- | Like the original 'putLogMsg', but internally converts the input 'Doc' (from the \"pretty\" library)--- into GHC's internal 'SDoc'.-putLogMsg :: GHC.DynFlags-          -> GHC.WarnReason-          -> GHC.Severity-          -> GHC.SrcSpan-          -> Maybe GHC.PprStyle-          -> PJ.Doc-          -> IO ()-putLogMsg dynFlags reason sev srcSpan _mbStyle =-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)- GHC.putLogMsg dynFlags reason sev srcSpan style' . GHC.text . PJ.render-   where-    style' :: GHC.PprStyle-    style' = case _mbStyle of-               Nothing  -> defaultErrStyle dynFlags-               Just sty -> sty-#else-  GHC.putLogMsg dynFlags reason sev srcSpan . GHC.text . PJ.render-#endif-#endif---defaultErrStyle :: GHC.DynFlags -> GHC.PprStyle-defaultErrStyle _dynFlags =-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)-  GHC.defaultErrStyle _dynFlags-#else-  GHC.defaultErrStyle-#endif-#endif--putWarnMsg :: GHC.DynFlags -> GHC.SrcSpan -> PJ.Doc -> IO ()-putWarnMsg dynFlags srcSpan doc =-  putLogMsg dynFlags GHC.NoReason GHC.SevWarning srcSpan (Just $ defaultErrStyle dynFlags) doc--putErrMsg :: GHC.DynFlags -> GHC.SrcSpan -> PJ.Doc -> IO ()-putErrMsg dynFlags srcSpan doc = putLogMsg dynFlags GHC.NoReason GHC.SevError srcSpan Nothing doc---- | Like GHC's 'mkLongErrAt', but it builds the final 'ErrMsg' out of two \"HughesPJ\"'s 'Doc's.-mkLongErrAt :: GHC.SrcSpan -> PJ.Doc -> PJ.Doc -> GHC.TcRn GHC.ErrMsg-mkLongErrAt srcSpan msg extra = GHC.mkLongErrAt srcSpan (fromPJDoc msg) (fromPJDoc extra)
− src/Language/Haskell/Liquid/GHC/Misc.hs 
@@ -1,1141 +0,0 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE TypeSynonymInstances      #-}-{-# LANGUAGE UndecidableInstances      #-}-{-# LANGUAGE ViewPatterns              #-}-{-# LANGUAGE PatternSynonyms           #-}---- | This module contains a wrappers and utility functions for--- accessing GHC module information. It should NEVER depend on--- ANY module inside the Language.Haskell.Liquid.* tree.--module Language.Haskell.Liquid.GHC.Misc where--import           Data.String-import qualified Data.List as L-import           Debug.Trace--import           Prelude                                    hiding (error)-import           Language.Haskell.Liquid.GHC.API            as Ghc hiding ( L-                                                                          , sourceName-                                                                          , showPpr-                                                                          , showSDocDump-                                                                          , panic-                                                                          , showSDoc-                                                                          )-import qualified Language.Haskell.Liquid.GHC.API            as Ghc (GenLocated (L), showSDoc, panic, showSDocDump)---import           Data.Char                                  (isLower, isSpace, isUpper)-import           Data.Maybe                                 (isJust, fromMaybe, fromJust, maybeToList)-import           Data.Hashable-import qualified Data.HashSet                               as S-import qualified Data.Map.Strict                            as OM-import           Control.Monad.State                        (evalState, get, modify)--import qualified Data.Text.Encoding.Error                   as TE-import qualified Data.Text.Encoding                         as T-import qualified Data.Text                                  as T-import           Control.Arrow                              (second)-import           Control.Monad                              ((>=>), foldM)-import qualified Text.PrettyPrint.HughesPJ                  as PJ-import           Language.Fixpoint.Types                    hiding (L, panic, Loc (..), SrcSpan, Constant, SESearch (..))-import qualified Language.Fixpoint.Types                    as F-import           Language.Fixpoint.Misc                     (safeHead, safeLast, errorstar) -- , safeLast, safeInit)-import           Language.Haskell.Liquid.Misc               (keyDiff) -import           Control.DeepSeq-import           Language.Haskell.Liquid.Types.Errors---isAnonBinder :: Ghc.TyConBinder -> Bool-isAnonBinder (Bndr _ (AnonTCB _)) = True-isAnonBinder (Bndr _ _)           = False--mkAlive :: Var -> Id-mkAlive x-  | isId x && isDeadOcc (idOccInfo x)-  = setIdInfo x (setOccInfo (idInfo x) noOccInfo)-  | otherwise-  = x-------------------------------------------------------------------------------------- | Encoding and Decoding Location ------------------------------------------------------------------------------------------------------------------------------srcSpanTick :: Module -> SrcSpan -> Tickish a-srcSpanTick m sp = ProfNote (AllCafsCC m sp) False True--tickSrcSpan ::  Outputable a => Tickish a -> SrcSpan-tickSrcSpan (ProfNote cc _ _) = cc_loc cc-tickSrcSpan (SourceNote ss _) = RealSrcSpan ss Nothing-tickSrcSpan _                 = noSrcSpan------------------------------------------------------------------------------------- | Generic Helpers for Accessing GHC Innards ---------------------------------------------------------------------------------------------------------------------- FIXME: reusing uniques like this is really dangerous-stringTyVar :: String -> TyVar-stringTyVar s = mkTyVar name liftedTypeKind-  where -    name      = mkInternalName (mkUnique 'x' 24)  occ noSrcSpan-    occ       = mkTyVarOcc s---- FIXME: reusing uniques like this is really dangerous-stringVar :: String -> Type -> Var-stringVar s t = mkLocalVar VanillaId name Many t vanillaIdInfo-   where-      name = mkInternalName (mkUnique 'x' 25) occ noSrcSpan-      occ  = mkVarOcc s---- FIXME: plugging in dummy type like this is really dangerous-maybeAuxVar :: Symbol -> Maybe Var-maybeAuxVar s-  | isMethod sym = Just sv-  | otherwise = Nothing -  where (_, uid) = splitModuleUnique s-        sym = dropModuleNames s-        sv = mkExportedLocalId VanillaId name anyTy -        -- 'x' is chosen for no particular reason..-        name = mkInternalName (mkUnique 'x' uid) occ noSrcSpan-        occ = mkVarOcc (T.unpack (symbolText sym))--stringTyCon :: Char -> Int -> String -> TyCon-stringTyCon = stringTyConWithKind anyTy---- FIXME: reusing uniques like this is really dangerous-stringTyConWithKind :: Kind -> Char -> Int -> String -> TyCon-stringTyConWithKind k c n s = Ghc.mkKindTyCon name [] k [] name-  where-    name          = mkInternalName (mkUnique c n) occ noSrcSpan-    occ           = mkTcOcc s--hasBaseTypeVar :: Var -> Bool-hasBaseTypeVar = isBaseType . varType---- same as Constraint isBase-isBaseType :: Type -> Bool-isBaseType (ForAllTy _ _)  = False-isBaseType (FunTy { ft_arg = t1, ft_res = t2}) = isBaseType t1 && isBaseType t2-isBaseType (TyVarTy _)     = True-isBaseType (TyConApp _ ts) = all isBaseType ts-isBaseType (AppTy t1 t2)   = isBaseType t1 && isBaseType t2-isBaseType _               = False--isTmpVar :: Var -> Bool -isTmpVar = isTmpSymbol . dropModuleNamesAndUnique . symbol --isTmpSymbol    :: Symbol -> Bool-isTmpSymbol x  = any (`isPrefixOfSym` x) [anfPrefix, tempPrefix, "ds_"]--validTyVar :: String -> Bool-validTyVar s@(c:_) = isLower c && all (not . isSpace) s-validTyVar _       = False--tvId :: TyVar -> String-tvId α = {- traceShow ("tvId: α = " ++ show α) $ -} showPpr α ++ show (varUnique α)--tidyCBs :: [CoreBind] -> [CoreBind]-tidyCBs = map unTick--unTick :: CoreBind -> CoreBind-unTick (NonRec b e) = NonRec b (unTickExpr e)-unTick (Rec bs)     = Rec $ map (second unTickExpr) bs--unTickExpr :: CoreExpr -> CoreExpr-unTickExpr (App e a)          = App (unTickExpr e) (unTickExpr a)-unTickExpr (Lam b e)          = Lam b (unTickExpr e)-unTickExpr (Let b e)          = Let (unTick b) (unTickExpr e)-unTickExpr (Case e b t as)    = Case (unTickExpr e) b t (map unTickAlt as)-    where unTickAlt (a, b, e) = (a, b, unTickExpr e)-unTickExpr (Cast e c)         = Cast (unTickExpr e) c-unTickExpr (Tick _ e)         = unTickExpr e-unTickExpr x                  = x--isFractionalClass :: Class -> Bool-isFractionalClass clas = classKey clas `elem` fractionalClassKeys--isOrdClass :: Class -> Bool-isOrdClass clas = classKey clas == ordClassKey------------------------------------------------------------------------------------- | Pretty Printers ---------------------------------------------------------------------------------------------------------------------------------------------notracePpr :: Outputable a => String -> a -> a-notracePpr _ x = x--tracePpr :: Outputable a => String -> a -> a-tracePpr s x = trace ("\nTrace: [" ++ s ++ "] : " ++ showPpr x) x--pprShow :: Show a => a -> Ghc.SDoc-pprShow = text . show---toFixSDoc :: Fixpoint a => a -> PJ.Doc-toFixSDoc = PJ.text . PJ.render . toFix--sDocDoc :: Ghc.SDoc -> PJ.Doc-sDocDoc   = PJ.text . showSDoc--pprDoc :: Outputable a => a -> PJ.Doc-pprDoc    = sDocDoc . ppr---- Overriding Outputable functions because they now require DynFlags!-showPpr :: Outputable a => a -> String-showPpr       = showSDoc . ppr---- FIXME: somewhere we depend on this printing out all GHC entities with--- fully-qualified names...-showSDoc :: Ghc.SDoc -> String-showSDoc sdoc = Ghc.renderWithStyle unsafeGlobalDynFlags sdoc (Ghc.mkUserStyle unsafeGlobalDynFlags myQualify {- Ghc.alwaysQualify -} Ghc.AllTheWay)--myQualify :: Ghc.PrintUnqualified-myQualify = Ghc.neverQualify { Ghc.queryQualifyName = Ghc.alwaysQualifyNames }--- { Ghc.queryQualifyName = \_ _ -> Ghc.NameNotInScope1 }--showSDocDump :: Ghc.SDoc -> String-showSDocDump  = Ghc.showSDocDump unsafeGlobalDynFlags--instance Outputable a => Outputable (S.HashSet a) where-  ppr = ppr . S.toList--typeUniqueString :: Outputable a => a -> String-typeUniqueString = {- ("sort_" ++) . -} showSDocDump . ppr-------------------------------------------------------------------------------------- | Manipulating Source Spans ------------------------------------------------------------------------------------------------------------------------------------newtype Loc    = L (Int, Int) deriving (Eq, Ord, Show)--instance Hashable Loc where-  hashWithSalt i (L z) = hashWithSalt i z----instance (Uniquable a) => Hashable a where--instance Hashable SrcSpan where-  hashWithSalt i (UnhelpfulSpan reason) = case reason of-    UnhelpfulNoLocationInfo -> hashWithSalt i (uniq $ fsLit "UnhelpfulNoLocationInfo")-    UnhelpfulWiredIn        -> hashWithSalt i (uniq $ fsLit "UnhelpfulWiredIn")-    UnhelpfulInteractive    -> hashWithSalt i (uniq $ fsLit "UnhelpfulInteractive")-    UnhelpfulGenerated      -> hashWithSalt i (uniq $ fsLit "UnhelpfulGenerated")-    UnhelpfulOther fs       -> hashWithSalt i (uniq fs)-  hashWithSalt i (RealSrcSpan s _)      = hashWithSalt i (srcSpanStartLine s, srcSpanStartCol s, srcSpanEndCol s)--fSrcSpan :: (F.Loc a) => a -> SrcSpan-fSrcSpan = fSrcSpanSrcSpan . F.srcSpan--fSourcePos :: (F.Loc a) => a -> F.SourcePos -fSourcePos = F.sp_start . F.srcSpan --fSrcSpanSrcSpan :: F.SrcSpan -> SrcSpan-fSrcSpanSrcSpan (F.SS p p') = sourcePos2SrcSpan p p'--srcSpanFSrcSpan :: SrcSpan -> F.SrcSpan-srcSpanFSrcSpan sp = F.SS p p'-  where-    p              = srcSpanSourcePos sp-    p'             = srcSpanSourcePosE sp--sourcePos2SrcSpan :: SourcePos -> SourcePos -> SrcSpan-sourcePos2SrcSpan p p' = RealSrcSpan (realSrcSpan f (unPos l) (unPos c) (unPos l') (unPos c')) Nothing-  where-    (f, l,  c)         = F.sourcePosElts p-    (_, l', c')        = F.sourcePosElts p'--sourcePosSrcSpan   :: SourcePos -> SrcSpan-sourcePosSrcSpan p@(SourcePos file line col) = sourcePos2SrcSpan p (SourcePos file line (succPos col))--sourcePosSrcLoc    :: SourcePos -> SrcLoc-sourcePosSrcLoc (SourcePos file line col) = mkSrcLoc (fsLit file) (unPos line) (unPos col)--srcSpanSourcePos :: SrcSpan -> SourcePos-srcSpanSourcePos (UnhelpfulSpan _) = dummyPos "<no source information>"-srcSpanSourcePos (RealSrcSpan s _) = realSrcSpanSourcePos s--srcSpanSourcePosE :: SrcSpan -> SourcePos-srcSpanSourcePosE (UnhelpfulSpan _) = dummyPos "<no source information>"-srcSpanSourcePosE (RealSrcSpan s _) = realSrcSpanSourcePosE s--srcSpanFilename :: SrcSpan -> String-srcSpanFilename    = maybe "" unpackFS . srcSpanFileName_maybe--srcSpanStartLoc :: RealSrcSpan -> Loc-srcSpanStartLoc l  = L (srcSpanStartLine l, srcSpanStartCol l)--srcSpanEndLoc :: RealSrcSpan -> Loc-srcSpanEndLoc l    = L (srcSpanEndLine l, srcSpanEndCol l)---oneLine :: RealSrcSpan -> Bool-oneLine l          = srcSpanStartLine l == srcSpanEndLine l--lineCol :: RealSrcSpan -> (Int, Int)-lineCol l          = (srcSpanStartLine l, srcSpanStartCol l)--realSrcSpanSourcePos :: RealSrcSpan -> SourcePos-realSrcSpanSourcePos s = safeSourcePos file line col-  where-    file               = unpackFS $ srcSpanFile s-    line               = srcSpanStartLine       s-    col                = srcSpanStartCol        s---realSrcSpanSourcePosE :: RealSrcSpan -> SourcePos-realSrcSpanSourcePosE s = safeSourcePos file line col-  where-    file                = unpackFS $ srcSpanFile s-    line                = srcSpanEndLine       s-    col                 = srcSpanEndCol        s--getSourcePos :: NamedThing a => a -> SourcePos-getSourcePos = srcSpanSourcePos  . getSrcSpan--getSourcePosE :: NamedThing a => a -> SourcePos-getSourcePosE = srcSpanSourcePosE . getSrcSpan--locNamedThing :: NamedThing a => a -> F.Located a-locNamedThing x = F.Loc l lE x-  where-    l          = getSourcePos  x-    lE         = getSourcePosE x--instance F.Loc Var where -  srcSpan v = SS (getSourcePos v) (getSourcePosE v) --namedLocSymbol :: (F.Symbolic a, NamedThing a) => a -> F.Located F.Symbol-namedLocSymbol d = F.symbol <$> locNamedThing d--varLocInfo :: (Type -> a) -> Var -> F.Located a-varLocInfo f x = f . varType <$> locNamedThing x--namedPanic :: (NamedThing a) => a -> String -> b-namedPanic x msg = panic (Just (getSrcSpan x)) msg------------------------------------------------------------------------------------- | Manipulating CoreExpr ----------------------------------------------------------------------------------------------------------------------------------------collectArguments :: Int -> CoreExpr -> [Var]-collectArguments n e = if length xs > n then take n xs else xs-  where-    (vs', e')        = collectValBinders' $ snd $ collectTyBinders e-    vs               = fst $ collectBinders $ ignoreLetBinds e'-    xs               = vs' ++ vs--{--collectTyBinders :: CoreExpr -> ([Var], CoreExpr)-collectTyBinders expr-  = go [] expr-  where-    go tvs (Lam b e) | isTyVar b = go (b:tvs) e-    go tvs e                     = (reverse tvs, e)--}--collectValBinders' :: Ghc.Expr Var -> ([Var], Ghc.Expr Var)-collectValBinders' = go []-  where-    go tvs (Lam b e) | isTyVar b = go tvs     e-    go tvs (Lam b e) | isId    b = go (b:tvs) e-    go tvs (Tick _ e)            = go tvs e-    go tvs e                     = (reverse tvs, e)--ignoreLetBinds :: Ghc.Expr t -> Ghc.Expr t-ignoreLetBinds (Let (NonRec _ _) e')-  = ignoreLetBinds e'-ignoreLetBinds e-  = e------------------------------------------------------------------------------------- | Predicates on CoreExpr and DataCons --------------------------------------------------------------------------------------------------------------------------isTupleId :: Id -> Bool-isTupleId = maybe False Ghc.isTupleDataCon . idDataConM--idDataConM :: Id -> Maybe DataCon-idDataConM x = case idDetails x of-  DataConWorkId d -> Just d-  DataConWrapId d -> Just d-  _               -> Nothing --isDataConId :: Id -> Bool-isDataConId = isJust . idDataConM--getDataConVarUnique :: Var -> Unique-getDataConVarUnique v-  | isId v && isDataConId v = getUnique (idDataCon v)-  | otherwise               = getUnique v--isDictionaryExpression :: Ghc.Expr Id -> Maybe Id-isDictionaryExpression (Tick _ e) = isDictionaryExpression e-isDictionaryExpression (Var x)    | isDictionary x = Just x-isDictionaryExpression _          = Nothing--realTcArity :: TyCon -> Arity-realTcArity = tyConArity--{--  tracePpr ("realTcArity of " ++ showPpr c-     ++ "\n tyConKind = " ++ showPpr (tyConKind c)-     ++ "\n kindArity = " ++ show (kindArity (tyConKind c))-     ++ "\n kindArity' = " ++ show (kindArity' (tyConKind c)) -- this works for TypeAlias-     ) $ kindArity' (tyConKind c)--}--kindTCArity :: TyCon -> Arity-kindTCArity = go . tyConKind-  where-    go (FunTy { ft_res = res}) = 1 + go res-    go _               = 0---kindArity :: Kind -> Arity-kindArity (ForAllTy _ res)-  = 1 + kindArity res-kindArity _-  = 0--uniqueHash :: Uniquable a => Int -> a -> Int-uniqueHash i = hashWithSalt i . getKey . getUnique---- slightly modified version of DynamicLoading.lookupRdrNameInModule-lookupRdrName :: HscEnv -> ModuleName -> RdrName -> IO (Maybe Name)-lookupRdrName hsc_env mod_name rdr_name = do-    -- First find the package the module resides in by searching exposed packages and home modules-    found_module <- findImportedModule hsc_env mod_name Nothing-    case found_module of-        Found _ mod -> do-            -- Find the exports of the module-            (_, mb_iface) <- getModuleInterface hsc_env mod-            case mb_iface of-                Just iface -> do-                    -- Try and find the required name in the exports-                    let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name-                                                , is_qual = False, is_dloc = noSrcSpan }-                        provenance = Just $ ImpSpec decl_spec ImpAll-                        env = case mi_globals iface of-                                Nothing -> mkGlobalRdrEnv (gresFromAvails provenance (mi_exports iface))-                                Just e -> e-                    case lookupGRE_RdrName rdr_name env of-                        [gre] -> return (Just (gre_name gre))-                        []    -> return Nothing-                        _     -> Ghc.panic "lookupRdrNameInModule"-                Nothing -> throwCmdLineErrorS dflags $ Ghc.hsep [Ghc.ptext (sLit "Could not determine the exports of the module"), ppr mod_name]-        err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err-  where dflags = hsc_dflags hsc_env-        throwCmdLineErrorS dflags = throwCmdLineError . Ghc.showSDoc dflags-        throwCmdLineError = throwGhcException . CmdLineError---- qualImportDecl :: ModuleName -> ImportDecl name--- qualImportDecl mn = (simpleImportDecl mn) { ideclQualified = True }--ignoreInline :: ParsedModule -> ParsedModule-ignoreInline x = x {pm_parsed_source = go <$> pm_parsed_source x}-  where -    go  x      = x {hsmodDecls = filter go' (hsmodDecls x) }-    go' :: LHsDecl GhcPs -> Bool-    go' x -      | SigD _ (InlineSig {}) <-  unLoc x = False-      | otherwise                         = True------------------------------------------------------------------------------------- | Symbol Conversions -------------------------------------------------------------------------------------------------------------------------------------------symbolTyConWithKind :: Kind -> Char -> Int -> Symbol -> TyCon-symbolTyConWithKind k x i n = stringTyConWithKind k x i (symbolString n)--symbolTyCon :: Char -> Int -> Symbol -> TyCon-symbolTyCon x i n = stringTyCon x i (symbolString n)--symbolTyVar :: Symbol -> TyVar-symbolTyVar = stringTyVar . symbolString--localVarSymbol ::  Var -> Symbol-localVarSymbol v-  | us `isSuffixOfSym` vs = vs-  | otherwise             = suffixSymbol vs us-  where-    us                    = symbol $ showPpr $ getDataConVarUnique v-    vs                    = exportedVarSymbol v --exportedVarSymbol :: Var -> Symbol-exportedVarSymbol x = notracepp msg . symbol . getName $ x            -  where -    msg = "exportedVarSymbol: " ++ showPpr x --qualifiedNameSymbol :: Name -> Symbol-qualifiedNameSymbol n = symbol $ concatFS [modFS, occFS, uniqFS]-  where-  _msg   = showSDoc (ppr n) -- getOccString n-  modFS = case nameModule_maybe n of-            Nothing -> fsLit ""-            Just m  -> concatFS [moduleNameFS (moduleName m), fsLit "."]--  occFS = occNameFS (getOccName n)-  uniqFS-    | isSystemName n-    = concatFS [fsLit "_",  fsLit (showPpr (getUnique n))]-    | otherwise-    = fsLit ""--instance Symbolic FastString where-  symbol = symbol . fastStringText--fastStringText :: FastString -> T.Text-fastStringText = T.decodeUtf8With TE.lenientDecode . bytesFS--tyConTyVarsDef :: TyCon -> [TyVar]-tyConTyVarsDef c-  | noTyVars c = []-  | otherwise  = Ghc.tyConTyVars c-  --where-  --  none         = tracepp ("tyConTyVarsDef: " ++ show c) (noTyVars c)--noTyVars :: TyCon -> Bool-noTyVars c =  (Ghc.isPrimTyCon c || isFunTyCon c || Ghc.isPromotedDataCon c)------------------------------------------------------------------------------------- | Symbol Instances-----------------------------------------------------------------------------------instance Symbolic TyCon where-  symbol = symbol . getName--instance Symbolic Class where-  symbol = symbol . getName--instance Symbolic Name where-  symbol = symbol . qualifiedNameSymbol---- | [NOTE:REFLECT-IMPORTS] we **eschew** the `unique` suffix for exported vars,--- to make it possible to lookup names from symbols _across_ modules;--- anyways exported names are top-level and you shouldn't have local binders--- that shadow them. However, we **keep** the `unique` suffix for local variables,--- as otherwise there are spurious, but extremely problematic, name collisions--- in the fixpoint environment.--instance Symbolic Var where   -- TODO:reflect-datacons varSymbol-  symbol v-    | isExportedId v = exportedVarSymbol v-    | otherwise      = localVarSymbol    v---instance Hashable Var where-  hashWithSalt = uniqueHash--instance Hashable TyCon where-  hashWithSalt = uniqueHash--instance Hashable Class where-  hashWithSalt = uniqueHash--instance Hashable DataCon where-  hashWithSalt = uniqueHash--instance Fixpoint Var where-  toFix = pprDoc--instance Fixpoint Name where-  toFix = pprDoc--instance Fixpoint Type where-  toFix = pprDoc--instance Show Name where-  show = symbolString . symbol--instance Show Var where-  show = show . getName--instance Show Class where-  show = show . getName--instance Show TyCon where-  show = show . getName--instance NFData Class where-  rnf t = seq t ()--instance NFData TyCon where-  rnf t = seq t ()--instance NFData Type where-  rnf t = seq t ()--instance NFData Var where-  rnf t = seq t ()------------------------------------------------------------------------------------- | Manipulating Symbols -----------------------------------------------------------------------------------------------------------------------------------------takeModuleUnique :: Symbol -> Symbol-takeModuleUnique = mungeNames tailName sepUnique   "takeModuleUnique: "-  where-    tailName msg = symbol . safeLast msg--splitModuleUnique :: Symbol -> (Symbol, Int)-splitModuleUnique x = (dropModuleNamesAndUnique x, base62ToI (takeModuleUnique x))--base62ToI :: Symbol -> Int-base62ToI s =  fromMaybe (errorstar "base62ToI Out Of Range") $ go (F.symbolText s)-  where-    digitToI :: OM.Map Char Int-    digitToI = OM.fromList $ zip (['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z']) [0..]-    f acc (flip OM.lookup digitToI -> x) = (acc * 62 +) <$> x-    go s = foldM f 0 (T.unpack s)---splitModuleName :: Symbol -> (Symbol, Symbol)-splitModuleName x = (takeModuleNames x, dropModuleNamesAndUnique x)--dropModuleNamesAndUnique :: Symbol -> Symbol-dropModuleNamesAndUnique = dropModuleUnique . dropModuleNames--dropModuleNames  :: Symbol -> Symbol-dropModuleNames = dropModuleNamesCorrect -{- -dropModuleNames = mungeNames lastName sepModNames "dropModuleNames: "- where-   lastName msg = symbol . safeLast msg--}--dropModuleNamesCorrect  :: Symbol -> Symbol-dropModuleNamesCorrect = F.symbol . go . F.symbolText-  where-    go s = case T.uncons s of-             Just (c,tl) -> if isUpper c  && T.any (== '.') tl-                              then go $ snd $ fromJust $ T.uncons $ T.dropWhile (/= '.') s-                              else s-             Nothing -> s--takeModuleNames  :: Symbol -> Symbol-takeModuleNames  = F.symbol . go [] . F.symbolText-  where-    go acc s = case T.uncons s of-                Just (c,tl) -> if isUpper c && T.any (== '.') tl-                                 then go (getModule s:acc) $ snd $ fromJust $ T.uncons $ T.dropWhile (/= '.') s-                                 else T.intercalate "." (reverse acc) -                Nothing -> T.intercalate "." (reverse acc) -    getModule 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)-  || (dropModuleUnique coreSym == dropModuleUnique         logicSym)--sepModNames :: T.Text-sepModNames = "."--sepUnique :: T.Text-sepUnique = "#"--mungeNames :: (String -> [T.Text] -> Symbol) -> T.Text -> String -> Symbol -> Symbol-mungeNames _ _ _ ""  = ""-mungeNames f d msg s'@(symbolText -> s)-  | s' == tupConName = tupConName-  | otherwise        = f (msg ++ T.unpack s) $ T.splitOn d $ stripParens s--qualifySymbol :: Symbol -> Symbol -> Symbol-qualifySymbol (symbolText -> m) x'@(symbolText -> x)-  | isQualified x  = x'-  | isParened x    = symbol (wrapParens (m `mappend` "." `mappend` stripParens x))-  | otherwise      = symbol (m `mappend` "." `mappend` x)--isQualifiedSym :: Symbol -> Bool-isQualifiedSym (symbolText -> x) = isQualified x --isQualified :: T.Text -> Bool-isQualified y = "." `T.isInfixOf` y--wrapParens :: (IsString a, Monoid a) => a -> a-wrapParens x  = "(" `mappend` x `mappend` ")"--isParened :: T.Text -> Bool-isParened xs  = xs /= stripParens xs--isDictionary :: Symbolic a => a -> Bool-isDictionary = isPrefixOfSym "$f" . dropModuleNames . symbol--isMethod :: Symbolic a => a -> Bool-isMethod = isPrefixOfSym "$c" . dropModuleNames . symbol--isInternal :: Symbolic a => a -> Bool-isInternal   = isPrefixOfSym "$"  . dropModuleNames . symbol--isWorker :: Symbolic a => a -> Bool -isWorker s = notracepp ("isWorkerSym: s = " ++ ss) $ "$W" `L.isInfixOf` ss -  where -    ss     = symbolString (symbol s)--isSCSel :: Symbolic a => a -> Bool-isSCSel  = isPrefixOfSym "$p" . dropModuleNames . symbol--stripParens :: T.Text -> T.Text-stripParens t = fromMaybe t (strip t)-  where-    strip = T.stripPrefix "(" >=> T.stripSuffix ")"--stripParensSym :: Symbol -> Symbol-stripParensSym (symbolText -> t) = symbol (stripParens t)--desugarModule :: TypecheckedModule -> Ghc DesugaredModule-desugarModule tcm = do-  let ms = pm_mod_summary $ tm_parsed_module tcm-  -- let ms = modSummary tcm-  let (tcg, _) = tm_internals_ tcm-  hsc_env <- getSession-  let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }-  guts <- liftIO $ hscDesugar{- WithLoc -} hsc_env_tmp ms tcg-  return DesugaredModule { dm_typechecked_module = tcm, dm_core_module = guts }------------------------------------------------------------------------------------- | GHC Compatibility Layer --------------------------------------------------------------------------------------------------------------------------------------gHC_VERSION :: String-gHC_VERSION = show __GLASGOW_HASKELL__--symbolFastString :: Symbol -> FastString-symbolFastString = mkFastStringByteString . T.encodeUtf8 . symbolText--lintCoreBindings :: [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc)-lintCoreBindings = Ghc.lintCoreBindings (defaultDynFlags undefined (undefined "LlvmTargets")) CoreDoNothing--synTyConRhs_maybe :: TyCon -> Maybe Type-synTyConRhs_maybe = Ghc.synTyConRhs_maybe--tcRnLookupRdrName :: HscEnv -> Ghc.Located RdrName -> IO (Messages, Maybe [Name])-tcRnLookupRdrName = Ghc.tcRnLookupRdrName--showCBs :: Bool -> [CoreBind] -> String-showCBs untidy-  | untidy    = Ghc.showSDocDebug unsafeGlobalDynFlags . ppr . tidyCBs-  | otherwise = showPpr---ignoreCoreBinds :: S.HashSet Var -> [CoreBind] -> [CoreBind]-ignoreCoreBinds vs cbs -  | S.null vs         = cbs -  | otherwise         = concatMap go cbs-  where-    go :: CoreBind -> [CoreBind]-    go b@(NonRec x _) -      | S.member x vs = [] -      | otherwise     = [b] -    go (Rec xes)      = [Rec (filter ((`notElem` vs) . fst) xes)]---findVarDef :: Symbol -> [CoreBind] -> Maybe (Var, CoreExpr)-findVarDef x cbs = case xCbs of-                     (NonRec v def   : _ ) -> Just (v, def)-                     (Rec [(v, def)] : _ ) -> Just (v, def)-                     _                     -> Nothing-  where-    xCbs            = [ cb | cb <- concatMap unRec cbs, x `elem` coreBindSymbols cb ]-    unRec (Rec xes) = [NonRec x es | (x,es) <- xes]-    unRec nonRec    = [nonRec]---findVarDefMethod :: Symbol -> [CoreBind] -> Maybe (Var, CoreExpr)-findVarDefMethod x cbs =-  case rcbs  of-                     (NonRec v def   : _ ) -> Just (v, def)-                     (Rec [(v, def)] : _ ) -> Just (v, def)-                     _                     -> Nothing-  where-    rcbs | isMethod x = mCbs-         | isDictionary (dropModuleNames x) = dCbs-         | otherwise  = xCbs-    xCbs            = [ cb | cb <- concatMap unRec cbs, x `elem` coreBindSymbols cb -                           ]-    mCbs            = [ cb | cb <- concatMap unRec cbs, x `elem` methodSymbols cb]-    dCbs            = [ cb | cb <- concatMap unRec cbs, x `elem` dictionarySymbols cb]-    unRec (Rec xes) = [NonRec x es | (x,es) <- xes]-    unRec nonRec    = [nonRec]--dictionarySymbols :: CoreBind -> [Symbol]-dictionarySymbols = filter isDictionary . map (dropModuleNames . symbol) . binders---methodSymbols :: CoreBind -> [Symbol]-methodSymbols = filter isMethod . map (dropModuleNames . symbol) . binders----coreBindSymbols :: CoreBind -> [Symbol]-coreBindSymbols = map (dropModuleNames . simplesymbol) . binders--simplesymbol :: (NamedThing t) => t -> Symbol-simplesymbol = symbol . getName--binders :: Bind a -> [a]-binders (NonRec z _) = [z]-binders (Rec xes)    = fst <$> xes--expandVarType :: Var -> Type-expandVarType = expandTypeSynonyms . varType------------------------------------------------------------------------------------- | The following functions test if a `CoreExpr` or `CoreVar` can be---   embedded in logic. With type-class support, we can no longer erase---   such expressions arbitrarily.----------------------------------------------------------------------------------isEmbeddedDictExpr :: CoreExpr -> Bool-isEmbeddedDictExpr = isEmbeddedDictType . exprType--isEmbeddedDictVar :: Var -> Bool-isEmbeddedDictVar v = F.notracepp msg . isEmbeddedDictType . varType $ v-  where-    msg     =  "isGoodCaseBind v = " ++ show v--isEmbeddedDictType :: Type -> Bool-isEmbeddedDictType = anyF [isOrdPred, isNumericPred, isEqPred, isPrelEqPred]---- unlike isNumCls, isFracCls, these two don't check if the argument's--- superclass is Ord or Num. I believe this is the more predictable behavior--isPrelEqPred :: Type -> Bool-isPrelEqPred ty = case tyConAppTyCon_maybe ty of-  Just tyCon -> isPrelEqTyCon tyCon-  _          -> False---isPrelEqTyCon :: TyCon -> Bool-isPrelEqTyCon tc = tc `hasKey` eqClassKey--isOrdPred :: Type -> Bool-isOrdPred ty = case tyConAppTyCon_maybe ty of-  Just tyCon -> tyCon `hasKey` ordClassKey-  _          -> False---- Not just Num, but Fractional, Integral as well-isNumericPred :: Type -> Bool-isNumericPred ty = case tyConAppTyCon_maybe ty of-  Just tyCon -> getUnique tyCon `elem` numericClassKeys-  _          -> False--------------------------------------------------------------------------------------- | The following functions test if a `CoreExpr` or `CoreVar` are just types---   in disguise, e.g. have `PredType` (in the GHC sense of the word), and so---   shouldn't appear in refinements.----------------------------------------------------------------------------------isPredExpr :: CoreExpr -> Bool-isPredExpr = isPredType . Ghc.exprType--isPredVar :: Var -> Bool-isPredVar v = F.notracepp msg . isPredType . varType $ v-  where-    msg     =  "isGoodCaseBind v = " ++ show v--isPredType :: Type -> Bool-isPredType = anyF [ isClassPred, isEqPred, isEqPrimPred ]--anyF :: [a -> Bool] -> a -> Bool-anyF ps x = or [ p x | p <- ps ]----- | 'defaultDataCons t ds' returns the list of '(dc, types)' pairs,---   corresponding to the _missing_ cases, i.e. _other_ than those in 'ds',---   that are being handled by DEFAULT.-defaultDataCons :: Type -> [AltCon] -> Maybe [(DataCon, [TyVar], [Type])]-defaultDataCons (TyConApp tc argτs) ds = do -  allDs     <- Ghc.tyConDataCons_maybe tc-  let seenDs = [d | DataAlt d <- ds ]-  let defDs  = keyDiff showPpr allDs seenDs -  return [ (d, Ghc.dataConExTyVars d, map irrelevantMult $ Ghc.dataConInstArgTys d argτs) | d <- defDs ] --defaultDataCons _ _ = -  Nothing----isEvVar :: Id -> Bool -isEvVar x = isPredVar x || isTyVar x || isCoVar x-------------------------------------------------------------------------------------- | Elaboration------------------------------------------------------------------------------------- FIXME: the handling of exceptions seems to be broken---- partially stolen from GHC'sa exprType---- elaborateHsExprInst---   :: GhcMonad m => LHsExpr GhcPs -> m (Messages, Maybe CoreExpr)--- elaborateHsExprInst expr = elaborateHsExpr TM_Inst expr----- elaborateHsExpr---   :: GhcMonad m => TcRnExprMode -> LHsExpr GhcPs -> m (Messages, Maybe CoreExpr)--- elaborateHsExpr mode expr =---   withSession $ \hsc_env -> liftIO $ hscElabHsExpr hsc_env mode expr---- hscElabHsExpr :: HscEnv -> TcRnExprMode -> LHsExpr GhcPs -> IO (Messages, Maybe CoreExpr)--- hscElabHsExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do---   hsc_env <- Ghc.getHscEnv---   liftIO $ elabRnExpr hsc_env mode expr--#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)-elabRnExpr-  :: TcRnExprMode -> LHsExpr GhcPs -> TcRn CoreExpr-elabRnExpr mode rdr_expr = do-    (rn_expr, _fvs) <- rnLExpr rdr_expr-    failIfErrsM-    uniq <- newUnique-    let fresh_it = itName uniq (getLoc rdr_expr)-        orig     = Ghc.lexprCtOrigin rn_expr-    (tclvl, lie, (tc_expr, res_ty)) <- pushLevelAndCaptureConstraints $ do-      (_tc_expr, expr_ty) <- tcInferSigma rn_expr-      expr_ty'            <- if inst-        then snd <$> deeplyInstantiate orig expr_ty-        else return expr_ty-      return (_tc_expr, expr_ty')-    (_, _, evbs, residual, _) <- simplifyInfer tclvl-                                            infer_mode-                                            []    {- No sig vars -}-                                            [(fresh_it, res_ty)]-                                            lie-    evbs' <- perhaps_disable_default_warnings $ simplifyInteractive residual-    full_expr <- zonkTopLExpr (mkHsDictLet (EvBinds evbs') (mkHsDictLet evbs tc_expr))-    initDsTc $ dsLExpr full_expr- where-  (inst, infer_mode, perhaps_disable_default_warnings) = case mode of-    TM_Inst    -> (True, NoRestrictions, id)-    TM_NoInst  -> (False, NoRestrictions, id)-    TM_Default -> (True, EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults)-#else-elabRnExpr-  :: TcRnExprMode -> LHsExpr GhcPs -> TcRn CoreExpr-elabRnExpr mode rdr_expr = do-    (rn_expr, _fvs) <- rnLExpr rdr_expr-    failIfErrsM--        -- Now typecheck the expression, and generalise its type-        -- it might have a rank-2 type (e.g. :t runST)-    uniq <- newUnique ;-    let fresh_it  = itName uniq (getLoc rdr_expr) -    ((tclvl, (tc_expr, res_ty)), lie)-          <- captureTopConstraints $-             pushTcLevelM          $-             tc_infer rn_expr--    -- Generalise-    (qtvs, dicts, evbs, residual, _)-         <- simplifyInfer tclvl infer_mode-                          []    {- No sig vars -}-                          [(fresh_it, res_ty)]-                          lie--    -- Ignore the dictionary bindings-    evbs' <- perhaps_disable_default_warnings $-         simplifyInteractive residual-    full_expr <- zonkTopLExpr (mkHsDictLet (EvBinds evbs') (mkHsDictLet evbs tc_expr))-    initDsTc $ dsLExpr full_expr-  where-    tc_infer expr | inst      = tcInferRho expr-                  | otherwise = tcInferSigma expr-                  -- tcInferSigma: see Note [Implementing :type]--    -- See Note [TcRnExprMode]-    (inst, infer_mode, perhaps_disable_default_warnings) = case mode of-      TM_Inst    -> (True,  NoRestrictions, id)-      TM_NoInst  -> (False, NoRestrictions, id)-      TM_Default -> (True,  EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults)-#endif-newtype HashableType = HashableType {getHType :: Type}--instance Eq HashableType where-  x == y = eqType (getHType x) (getHType y)--instance Ord HashableType where-  compare x y = nonDetCmpType (getHType x) (getHType y)--instance Outputable HashableType where-  ppr = ppr . getHType-------------------------------------------------------------------------------------- | Superclass coherence-----------------------------------------------------------------------------------canonSelectorChains :: PredType -> OM.Map HashableType [Id]-canonSelectorChains t = foldr (OM.unionWith const) mempty (zs : xs)- where-  (cls, ts) = Ghc.getClassPredTys t-  scIdTys   = classSCSelIds cls-  ys        = fmap (\d -> (d, piResultTys (idType d) (ts ++ [t]))) scIdTys-  zs        = OM.fromList $ fmap (\(x, y) -> (HashableType y, [x])) ys-  xs        = fmap (\(d, t') -> fmap (d :) (canonSelectorChains t')) ys--buildCoherenceOblig :: Class -> [[([Id], [Id])]]-buildCoherenceOblig cls = evalState (mapM f xs) OM.empty- where-  (ts, _, selIds, _) = classBigSig cls-  tts                = mkTyVarTy <$> ts-  t                  = mkClassPred cls tts-  ys = fmap (\d -> (d, piResultTys (idType d) (tts ++ [t]))) selIds-  xs                 = fmap (\(d, t') -> fmap (d:) (canonSelectorChains t')) ys-  f tid = do-    ctid' <- get-    modify (flip (OM.unionWith const) tid)-    pure . OM.elems $ OM.intersectionWith (,) ctid' (fmap tail tid)----- to be zipped onto the super class selectors-coherenceObligToRef :: (F.Symbolic s) => s -> [Id] -> [Id] -> F.Reft-coherenceObligToRef d = coherenceObligToRefE (F.eVar $ F.symbol d)--coherenceObligToRefE :: F.Expr -> [Id] -> [Id] -> F.Reft-coherenceObligToRefE e rps0 rps1 = F.Reft (F.vv_, F.PAtom F.Eq lhs rhs)-  where lhs = L.foldr EApp e ps0-        rhs = L.foldr EApp (F.eVar F.vv_) ps1-        ps0 = F.eVar . F.symbol <$> L.reverse rps0-        ps1 = F.eVar . F.symbol <$> L.reverse rps1--data TcWiredIn = TcWiredIn {-    tcWiredInName :: Name-  , tcWiredInFixity :: Maybe (Int, FixityDirection)-  , tcWiredInType :: LHsType GhcRn-  }---- | Run a computation in GHC's typechecking monad with wired in values locally bound in the typechecking environment.-withWiredIn :: TcM a -> TcM a-withWiredIn m = discardConstraints $ do-  -- undef <- lookupUndef-  wiredIns <- mkWiredIns-  -- snd <$> tcValBinds Ghc.NotTopLevel (binds undef wiredIns) (sigs wiredIns) m-  snd <$> tcValBinds Ghc.NotTopLevel [] (sigs wiredIns) m-- where-  -- lookupUndef = do-  --   lookupOrig gHC_ERR (Ghc.mkVarOcc "undefined")-  --   -- tcLookupGlobal undefName--  -- binds :: Name -> [TcWiredIn] -> [(Ghc.RecFlag, LHsBinds GhcRn)]-  -- binds undef wiredIns = map (\w -> -  --     let ext = Ghc.unitNameSet undef in -- $ varName $ tyThingId undef in-  --     let co_fn = idHsWrapper in-  --     let matches = -  --           let ctxt = LambdaExpr in-  --           let grhss = GRHSs Ghc.noExtField [Ghc.L locSpan (GRHS Ghc.noExtField [] (Ghc.L locSpan (HsVar Ghc.noExtField (Ghc.L locSpan undef))))] (Ghc.L locSpan emptyLocalBinds) in-  --           MG Ghc.noExtField (Ghc.L locSpan [Ghc.L locSpan (Match Ghc.noExtField ctxt [] grhss)]) Ghc.Generated -  --     in-  --     let b = FunBind ext (Ghc.L locSpan $ tcWiredInName w) matches co_fn [] in-  --     (Ghc.NonRecursive, unitBag (Ghc.L locSpan b))-  --   ) wiredIns--  sigs wiredIns = concatMap (\w ->-      let inf = maybeToList $ fmap (\(fPrec, fDir) -> Ghc.L locSpan $ FixSig Ghc.noExtField $ FixitySig Ghc.noExtField [Ghc.L locSpan (tcWiredInName w)] $ Ghc.Fixity Ghc.NoSourceText fPrec fDir) $ tcWiredInFixity w in-      let t = -            let ext = -#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) && !MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)-                      HsIBRn {hsib_vars = [], hsib_closed = True} in -- TODO: What goes here? XXX-#else-                      [] in-#endif-#endif-            let ext' = [] in-            [Ghc.L locSpan $ TypeSig Ghc.noExtField [Ghc.L locSpan (tcWiredInName w)] $ HsWC ext' $ HsIB ext $ tcWiredInType w]-      in-      inf <> t-    ) wiredIns--  locSpan = UnhelpfulSpan (UnhelpfulOther "Language.Haskell.Liquid.GHC.Misc: WiredIn")--  mkHsFunTy :: LHsType GhcRn -> LHsType GhcRn -> LHsType GhcRn-  mkHsFunTy a b = nlHsFunTy a b--  mkWiredIns = sequence [impl, dimpl, eq, len]--  toName s = do-    u <- getUniqueM-    return $ Ghc.mkInternalName u (Ghc.mkVarOcc s) locSpan--  toLoc = Ghc.L locSpan-  nameToTy = Ghc.L locSpan . HsTyVar Ghc.noExtField Ghc.NotPromoted--  boolTy :: LHsType GhcRn-  boolTy = nameToTy $ toLoc boolTyConName-    -- boolName <- lookupOrig (Module (stringToUnitId "Data.Bool") (mkModuleName "Data.Bool")) (Ghc.mkVarOcc "Bool")-    -- return $ Ghc.L locSpan $ HsTyVar Ghc.noExtField Ghc.NotPromoted $ Ghc.L locSpan boolName-  intTy = nameToTy $ toLoc intTyConName-  listTy lt = toLoc $ HsAppTy Ghc.noExtField (nameToTy $ toLoc listTyConName) lt- -  -- infixr 1 ==> :: Bool -> Bool -> Bool-  impl = do-    n <- toName "==>"-    let ty = mkHsFunTy boolTy (mkHsFunTy boolTy boolTy)-    return $ TcWiredIn n (Just (1, Ghc.InfixR)) ty--  -- infixr 1 <=> :: Bool -> Bool -> Bool-  dimpl = do-    n <- toName "<=>"-    let ty = mkHsFunTy boolTy (mkHsFunTy boolTy boolTy)-    return $ TcWiredIn n (Just (1, Ghc.InfixR)) ty--  -- infix 4 == :: forall a . a -> a -> Bool-  eq = do-    n <- toName "=="-    aName <- Ghc.L locSpan <$> toName "a"-    let aTy = nameToTy aName-    let ty = noLoc $ HsForAllTy Ghc.noExtField-#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)-#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)-             ForallInvis-#endif-             [Ghc.L locSpan $ UserTyVar Ghc.noExtField aName] $ mkHsFunTy aTy (mkHsFunTy aTy boolTy)-#else-             (mkHsForAllInvisTele [Ghc.L locSpan $ UserTyVar Ghc.noExtField SpecifiedSpec aName]) $ mkHsFunTy aTy (mkHsFunTy aTy boolTy)-#endif-    return $ TcWiredIn n (Just (4, Ghc.InfixN)) ty-  -  -- TODO: This is defined as a measure in liquid-base GHC.Base. We probably want to insert all measures to the environment.-  -- len :: forall a. [a] -> Int-  len = do-    n <- toName "len"-    aName <- Ghc.L locSpan <$> toName "a"-    let aTy = nameToTy aName-    let ty =-          noLoc $ HsForAllTy Ghc.noExtField-#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)-#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)-               ForallInvis-#endif-               [Ghc.L locSpan $ UserTyVar Ghc.noExtField aName] $ mkHsFunTy (listTy aTy) intTy-    return $ TcWiredIn n Nothing ty-#else-               (mkHsForAllInvisTele [Ghc.L locSpan $ UserTyVar Ghc.noExtField SpecifiedSpec aName]) $ mkHsFunTy (listTy aTy) intTy-    return $ TcWiredIn n Nothing ty-#endif----prependGHCRealQual :: FastString -> RdrName-prependGHCRealQual = varQual_RDR gHC_REAL--isFromGHCReal :: NamedThing a => a -> Bool-isFromGHCReal x = Ghc.nameModule (Ghc.getName x) == gHC_REAL
− src/Language/Haskell/Liquid/GHC/Play.hs 
@@ -1,148 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE TypeSynonymInstances      #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE PatternSynonyms           #-}--module Language.Haskell.Liquid.GHC.Play where--import Prelude hiding (error)--import           Control.Arrow       ((***))-import qualified Data.HashMap.Strict as M-import qualified Data.List           as L--import Language.Haskell.Liquid.GHC.API as Ghc hiding (substTysWith, panic)-import Language.Haskell.Liquid.GHC.Misc ()-import Language.Haskell.Liquid.Types.Errors---isRecursivenewTyCon :: TyCon -> Bool -isRecursivenewTyCon c -  | not (isNewTyCon c)-  = False -isRecursivenewTyCon c -  = go t -  where -    t = snd $ newTyConRhs c-    go (AppTy t1 t2)      = go t1 || go t2 -    go (TyConApp c' ts)   = c == c' || any go ts -    go (ForAllTy _ t1)    = go t1 -    go (FunTy _ _ t1 t2)  = go t1 || go t2-    go (CastTy t1 _)      = go t1 -    go _                  = False   -  --isHoleVar :: Var -> Bool -isHoleVar x = L.isPrefixOf "_" (show x)--dataConImplicitIds :: DataCon -> [Id]-dataConImplicitIds dc = [ x | AnId x <- dataConImplicitTyThings dc]--class Subable a where-  sub   :: M.HashMap CoreBndr CoreExpr -> a -> a-  subTy :: M.HashMap TyVar Type -> a -> a--instance Subable CoreExpr where-  sub s (Var v)        = M.lookupDefault (Var v) v s-  sub _ (Lit l)        = Lit l-  sub s (App e1 e2)    = App (sub s e1) (sub s e2)-  sub s (Lam b e)      = Lam b (sub s e)-  sub s (Let b e)      = Let (sub s b) (sub s e)-  sub s (Case e b t a) = Case (sub s e) (sub s b) t (map (sub s) a)-  sub s (Cast e c)     = Cast (sub s e) c-  sub s (Tick t e)     = Tick t (sub s e)-  sub _ (Type t)       = Type t-  sub _ (Coercion c)   = Coercion c--  subTy s (Var v)      = Var (subTy s v)-  subTy _ (Lit l)      = Lit l-  subTy s (App e1 e2)  = App (subTy s e1) (subTy s e2)-  subTy s (Lam b e)    | isTyVar b = Lam v' (subTy s e)-   where v' = case M.lookup b s of-               Just (TyVarTy v) -> v-               _                -> b--  subTy s (Lam b e)      = Lam (subTy s b) (subTy s e)-  subTy s (Let b e)      = Let (subTy s b) (subTy s e)-  subTy s (Case e b t a) = Case (subTy s e) (subTy s b) (subTy s t) (map (subTy s) a)-  subTy s (Cast e c)     = Cast (subTy s e) (subTy s c)-  subTy s (Tick t e)     = Tick t (subTy s e)-  subTy s (Type t)       = Type (subTy s t)-  subTy s (Coercion c)   = Coercion (subTy s c)--instance Subable Coercion where-  sub _ c                = c-  subTy _ _              = panic Nothing "subTy Coercion"--instance Subable (Alt Var) where- sub s (a, b, e)   = (a, map (sub s) b,   sub s e)- subTy s (a, b, e) = (a, map (subTy s) b, subTy s e)--instance Subable Var where- sub s v   | M.member v s = subVar $ s M.! v-           | otherwise    = v- subTy s v = setVarType v (subTy s (varType v))--subVar :: Expr t -> Id-subVar (Var x) = x-subVar  _      = panic Nothing "sub Var"--instance Subable (Bind Var) where- sub s (NonRec x e)   = NonRec (sub s x) (sub s e)- sub s (Rec xes)      = Rec ((sub s *** sub s) <$> xes)-- subTy s (NonRec x e) = NonRec (subTy s x) (subTy s e)- subTy s (Rec xes)    = Rec ((subTy s  *** subTy s) <$> xes)--instance Subable Type where- sub _ e   = e- subTy     = substTysWith--substTysWith :: M.HashMap Var Type -> Type -> Type-substTysWith s tv@(TyVarTy v)      = M.lookupDefault tv v s-substTysWith s (FunTy aaf m t1 t2) = FunTy aaf m (substTysWith s t1) (substTysWith s t2)-substTysWith s (ForAllTy v t)      = ForAllTy v (substTysWith (M.delete (binderVar v) s) t)-substTysWith s (TyConApp c ts)     = TyConApp c (map (substTysWith s) ts)-substTysWith s (AppTy t1 t2)       = AppTy (substTysWith s t1) (substTysWith s t2)-substTysWith _ (LitTy t)           = LitTy t-substTysWith s (CastTy t c)        = CastTy (substTysWith s t) c-substTysWith _ (CoercionTy c)      = CoercionTy c --substExpr :: M.HashMap Var Var -> CoreExpr -> CoreExpr-substExpr s = go -  where-    subsVar v                = M.lookupDefault v v s-    go (Var v)               = Var $ subsVar v-    go (Lit l)               = Lit l -    go (App e1 e2)           = App (go e1) (go e2) -    go (Lam x e)             = Lam (subsVar x) (go e)-    go (Let (NonRec x ex) e) = Let (NonRec (subsVar x) (go ex)) (go e) -    go (Let (Rec xes) e)     = Let (Rec [(subsVar x, go e) | (x,e) <- xes]) (go e)-    go (Case e b t alts)     = Case (go e) (subsVar b) t [(c, subsVar <$> xs, go e) | (c, xs, e) <- alts]-    go (Cast e c)            = Cast (go e) c -    go (Tick t e)            = Tick t (go e)-    go (Type t)              = Type t -    go (Coercion c)          = Coercion c --mapType :: (Type -> Type) -> Type -> Type-mapType f = go-  where-    go t@(TyVarTy _)        = f t-    go (AppTy t1 t2)        = f $ AppTy (go t1) (go t2)-    go (TyConApp c ts)      = f $ TyConApp c (go <$> ts)-    go (FunTy aaf m t1 t2)  = f $ FunTy aaf m (go t1) (go t2)-    go (ForAllTy v t)       = f $ ForAllTy v (go t)-    go t@(LitTy _)          = f t-    go (CastTy t c)         = CastTy (go t) c-    go (CoercionTy c)       = f $ CoercionTy c ---stringClassArg :: Type -> Maybe Type-stringClassArg t | isFunTy t -  = Nothing-stringClassArg t-  = case (tyConAppTyCon_maybe t, tyConAppArgs_maybe t) of-      (Just c, Just [t]) | isStringClassName == tyConName c-           -> Just t-      _    -> Nothing
src/Language/Haskell/Liquid/GHC/Plugin.hs view
@@ -1,17 +1,13 @@ -- | This module provides a GHC 'Plugin' that allows LiquidHaskell to be hooked directly into GHC's -- compilation pipeline, facilitating its usage and adoption. -{-# LANGUAGE MultiWayIf                 #-} {-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE LambdaCase                 #-} {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE RecordWildCards            #-}-{-# LANGUAGE TupleSections              #-}-{-# LANGUAGE TypeApplications           #-} {-# LANGUAGE ViewPatterns               #-}  module Language.Haskell.Liquid.GHC.Plugin (@@ -20,35 +16,38 @@    ) where -import qualified Language.Haskell.Liquid.GHC.API         as O-import           Language.Haskell.Liquid.GHC.API         as GHC hiding (Target)+import qualified Liquid.GHC.API         as O+import           Liquid.GHC.API         as GHC hiding (Target, Type) import qualified Text.PrettyPrint.HughesPJ               as PJ import qualified Language.Fixpoint.Types                 as F-import qualified Language.Haskell.Liquid.GHC.Misc        as LH+import qualified Liquid.GHC.Misc        as LH import qualified Language.Haskell.Liquid.UX.CmdLine      as LH-import qualified Language.Haskell.Liquid.GHC.Interface   as LH+import qualified Liquid.GHC.Interface   as LH import qualified Language.Haskell.Liquid.Liquid          as LH-import qualified Language.Haskell.Liquid.Types.PrettyPrint as LH (reportErrors)-import qualified Language.Haskell.Liquid.GHC.Logging     as LH   (fromPJDoc)+import qualified Language.Haskell.Liquid.Types.PrettyPrint as LH ( filterReportErrors+                                                                 , filterReportErrorsWith+                                                                 , defaultFilterReporter+                                                                 , reduceFilters )+import qualified Liquid.GHC.Logging     as LH   (fromPJDoc)  import           Language.Haskell.Liquid.GHC.Plugin.Types import           Language.Haskell.Liquid.GHC.Plugin.Util as Util import           Language.Haskell.Liquid.GHC.Plugin.SpecFinder                                                          as SpecFinder -import           Language.Haskell.Liquid.GHC.Types       (MGIModGuts(..), miModGuts)-import qualified Language.Haskell.Liquid.GHC.GhcMonadLike+import           Liquid.GHC.Types       (MGIModGuts(..), miModGuts)+import qualified Liquid.GHC.GhcMonadLike                                                          as GhcMonadLike-import           Language.Haskell.Liquid.GHC.GhcMonadLike ( GhcMonadLike+import           Liquid.GHC.GhcMonadLike ( GhcMonadLike                                                           , askHscEnv                                                           , isBootInterface                                                           ) import           GHC.LanguageExtensions  import           Control.Monad-import           Control.Exception                        (evaluate)  import           Data.Coerce+import           Data.Kind                                ( Type ) import           Data.List                               as L                                                    hiding ( intersperse ) import           Data.IORef@@ -60,7 +59,8 @@ import qualified Data.HashMap.Strict                     as HM  import           System.IO.Unsafe                         ( unsafePerformIO )-import           Language.Fixpoint.Types           hiding ( panic+import           Language.Fixpoint.Types           hiding ( errs+                                                          , panic                                                           , Error                                                           , Result                                                           , Expr@@ -75,6 +75,12 @@  import           Optics +-- | Represents an abnormal but non-fatal state of the plugin. Because it is not+-- meant to escape the plugin, it is not thrown in IO but instead carried around+-- in an `Either`'s `Left` case and handled at the top level of the plugin+-- function.+newtype LiquidCheckException = ErrorsOccurred [Filter] -- Unmatched expected errors+  deriving (Eq, Ord, Show)  --------------------------------------------------------------------------------- -- | State and configuration management -----------------------------------------@@ -121,17 +127,28 @@     liquidPlugin :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv     liquidPlugin opts summary gblEnv = do       dynFlags <- getDynFlags-      if gopt Opt_Haddock dynFlags-        then do-          -- Warn the user-          let msg     = PJ.vcat [ PJ.text "LH can't be run with Haddock."-                                , PJ.nest 4 $ PJ.text "Documentation will still be created."-                                ]-          let srcLoc  = mkSrcLoc (mkFastString $ ms_hspp_file summary) 1 1-          let warning = mkWarning (mkSrcSpan srcLoc srcLoc) msg-          liftIO $ printWarning dynFlags warning-          pure gblEnv-        else typecheckHook opts summary gblEnv+      withTiming dynFlags (text "LiquidHaskell" <+> brackets (ppr $ ms_mod_name summary)) (const ()) $ do+        if gopt Opt_Haddock dynFlags+          then do+            -- Warn the user+            let msg     = PJ.vcat [ PJ.text "LH can't be run with Haddock."+                                  , PJ.nest 4 $ PJ.text "Documentation will still be created."+                                  ]+            let srcLoc  = mkSrcLoc (mkFastString $ ms_hspp_file summary) 1 1+            let warning = mkWarning (mkSrcSpan srcLoc srcLoc) msg+            liftIO $ printWarning dynFlags warning+            pure gblEnv+          else do+            newGblEnv <- typecheckHook opts summary gblEnv+            case newGblEnv of+              -- Exit with success if all expected errors were found+              Left (ErrorsOccurred []) -> pure gblEnv+              -- Exit with error if there were unmatched expected errors+              Left (ErrorsOccurred errorFilters) -> do+                defaultFilterReporter (LH.modSummaryHsFile summary) errorFilters+                failM+              Right newGblEnv' ->+                pure newGblEnv'  -------------------------------------------------------------------------------- -- | GHC Configuration & Setup -------------------------------------------------@@ -165,7 +182,7 @@ -- desugaring the module during /parsing/ (before that's already too late) and we cache the core binds for -- the rest of the program execution. class Unoptimise a where-  type UnoptimisedTarget a :: *+  type UnoptimisedTarget a :: Type   unoptimise :: a -> UnoptimisedTarget a  instance Unoptimise DynFlags where@@ -201,7 +218,7 @@ --    grab from parsing (again) the module by using the GHC API, so we are really --    independent from the \"normal\" compilation pipeline. ---typecheckHook :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv+typecheckHook :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM (Either LiquidCheckException TcGblEnv) typecheckHook _ (unoptimise -> modSummary) tcGblEnv = do   debugLog $ "We are in module: " <> show (toStableModule thisModule) @@ -231,21 +248,37 @@                                                               }                    } --- | Partially calls into LiquidHaskell's GHC API.-liquidHaskellCheck :: PipelineData -> ModSummary -> TcGblEnv -> TcM TcGblEnv-liquidHaskellCheck pipelineData modSummary tcGblEnv = do-  cfg <- liftIO getConfig+serialiseSpec :: Module -> TcGblEnv -> LiquidLib -> TcM TcGblEnv+serialiseSpec thisModule tcGblEnv liquidLib = do+  -- ---+  -- -- CAN WE 'IGNORE' THE BELOW? TODO:IGNORE -- issue use `emptyLiquidLib` instead of pmrClientLib+  -- ProcessModuleResult{..} <- processModule lhContext -  -- The 'specQuotes' contain stuff we need from imported modules, extracted-  -- from the annotations in their interface files.-  let specQuotes :: [BPspec]-      specQuotes = LH.extractSpecQuotes' tcg_mod tcg_anns tcGblEnv+  -- liftIO $ putStrLn "liquidHaskellCheck 7" -  -- Here, we are calling Liquid Haskell's parser, acting on the unparsed-  -- spec comments stored in the pipeline data, supported by the specQuotes-  -- obtained from the imported modules.-  inputSpec :: BareSpec <- getLiquidSpec thisModule (pdSpecComments pipelineData) specQuotes+  -- -- Call into the existing Liquid interface+  -- out <- liftIO $ LH.checkTargetInfo pmrTargetInfo +  -- liftIO $ putStrLn "liquidHaskellCheck 8"++  -- -- Report the outcome of the checking+  -- LH.reportResult errorLogger cfg [giTarget (giSrc pmrTargetInfo)] out+  -- case o_result out of+  --   Safe _stats -> pure ()+  --   _           -> failM++  -- liftIO $ putStrLn "liquidHaskellCheck 9"+  -- ---++  let serialisedSpec = Util.serialiseLiquidLib liquidLib thisModule+  debugLog $ "Serialised annotation ==> " ++ (O.showSDocUnsafe . O.ppr $ serialisedSpec)++  -- liftIO $ putStrLn "liquidHaskellCheck 10"++  pure $ tcGblEnv { tcg_anns = serialisedSpec : tcg_anns tcGblEnv }++processInputSpec :: Config -> PipelineData -> ModSummary -> TcGblEnv -> BareSpec -> TcM (Either LiquidCheckException TcGblEnv)+processInputSpec cfg pipelineData modSummary tcGblEnv inputSpec = do   debugLog $ " Input spec: \n" ++ show inputSpec   debugLog $ "Relevant ===> \n" ++ unlines (renderModule <$> S.toList (relevantModules modGuts)) @@ -262,67 +295,98 @@       , lhModuleGuts      = pdUnoptimisedCore pipelineData       , lhRelevantModules = relevantModules modGuts       }-  +   -- liftIO $ putStrLn ("liquidHaskellCheck 6: " ++ show isIg)+  if isIgnore inputSpec+    then pure $ Left (ErrorsOccurred [])+    else do+      liquidLib' <- checkLiquidHaskellContext lhContext+      traverse (serialiseSpec thisModule tcGblEnv) liquidLib' -  liquidLib <- if isIgnore inputSpec -                then pure emptyLiquidLib -                else checkLiquidHaskellContext lhContext - -  -- --- -  -- -- CAN WE 'IGNORE' THE BELOW? TODO:IGNORE -- issue use `emptyLiquidLib` instead of pmrClientLib-  -- ProcessModuleResult{..} <- processModule lhContext-  -  -- liftIO $ putStrLn "liquidHaskellCheck 7"+  where+    thisModule :: Module+    thisModule = tcg_mod tcGblEnv -  -- -- Call into the existing Liquid interface-  -- out <- liftIO $ LH.checkTargetInfo pmrTargetInfo-  -- liftIO $ putStrLn "liquidHaskellCheck 8"+    modGuts :: ModGuts+    modGuts = fromUnoptimised . pdUnoptimisedCore $ pipelineData -  -- -- Report the outcome of the checking-  -- LH.reportResult errorLogger cfg [giTarget (giSrc pmrTargetInfo)] out-  -- case o_result out of-  --   Safe _stats -> pure ()-  --   _           -> failM+liquidHaskellCheckWithConfig :: Config -> PipelineData -> ModSummary -> TcGblEnv -> TcM (Either LiquidCheckException TcGblEnv)+liquidHaskellCheckWithConfig globalCfg pipelineData modSummary tcGblEnv = do+  -- The 'specQuotes' contain stuff we need from imported modules, extracted+  -- from the annotations in their interface files.+  let specQuotes :: [BPspec]+      specQuotes = LH.extractSpecQuotes' tcg_mod tcg_anns tcGblEnv -  -- liftIO $ putStrLn "liquidHaskellCheck 9"-  -- ---+  -- Here, we are calling Liquid Haskell's parser, acting on the unparsed+  -- spec comments stored in the pipeline data, supported by the specQuotes+  -- obtained from the imported modules.+  inputSpec' :: Either LiquidCheckException BareSpec <-+    getLiquidSpec thisFile thisModule (pdSpecComments pipelineData) specQuotes -  let serialisedSpec = Util.serialiseLiquidLib liquidLib thisModule-  debugLog $ "Serialised annotation ==> " ++ (O.showSDocUnsafe . O.ppr $ serialisedSpec)-  -  -- liftIO $ putStrLn "liquidHaskellCheck 10"+  case inputSpec' of+    Left e -> pure $ Left e+    Right inputSpec ->+      withPragmas globalCfg thisFile (Ms.pragmas $ review bareSpecIso inputSpec) $ \moduleCfg -> do+        processInputSpec moduleCfg pipelineData modSummary tcGblEnv inputSpec+          `gcatch` (\(e :: UserError) -> reportErrs moduleCfg [e])+          `gcatch` (\(e :: Error) -> reportErrs moduleCfg [e])+          `gcatch` (\(es :: [Error]) -> reportErrs moduleCfg es) -  pure $ tcGblEnv { tcg_anns = serialisedSpec : tcg_anns tcGblEnv }   where+    thisFile :: FilePath+    thisFile = LH.modSummaryHsFile modSummary++    continue :: TcM (Either LiquidCheckException TcGblEnv)+    continue = pure $ Left (ErrorsOccurred [])++    reportErrs :: (Show e, F.PPrint e) => Config -> [TError e] -> TcM (Either LiquidCheckException TcGblEnv)+    reportErrs cfg = LH.filterReportErrors thisFile GHC.failM continue (getFilters cfg) Full+     thisModule :: Module     thisModule = tcg_mod tcGblEnv -    modGuts :: ModGuts-    modGuts = fromUnoptimised . pdUnoptimisedCore $ pipelineData+-- | Partially calls into LiquidHaskell's GHC API.+liquidHaskellCheck :: PipelineData -> ModSummary -> TcGblEnv -> TcM (Either LiquidCheckException TcGblEnv)+liquidHaskellCheck pipelineData modSummary tcGblEnv = do+  cfg <- liftIO getConfig+  liquidHaskellCheckWithConfig cfg pipelineData modSummary tcGblEnv -checkLiquidHaskellContext :: LiquidHaskellContext -> TcM LiquidLib+checkLiquidHaskellContext :: LiquidHaskellContext -> TcM (Either LiquidCheckException LiquidLib) checkLiquidHaskellContext lhContext = do-  ProcessModuleResult{..} <- processModule lhContext--  -- Call into the existing Liquid interface-  out <- liftIO $ LH.checkTargetInfo pmrTargetInfo+  pmr <- processModule lhContext+  case pmr of+    Left e -> pure $ Left e+    Right ProcessModuleResult{..} -> do+      -- Call into the existing Liquid interface+      out <- liftIO $ LH.checkTargetInfo pmrTargetInfo -  let cfg = lhGlobalCfg lhContext-  -- Report the outcome of the checking-  LH.reportResult errorLogger cfg [giTarget (giSrc pmrTargetInfo)] out-  case o_result out of-    Safe _stats -> pure ()-    _           -> failM-  return pmrClientLib+      let bareSpec = lhInputSpec lhContext+          file = LH.modSummaryHsFile $ lhModuleSummary lhContext -errorLogger :: OutputResult -> TcM ()-errorLogger outputResult = do-  errs <- forM (LH.orMessages outputResult) $ \(spn, e) -> mkLongErrAt spn (LH.fromPJDoc e) O.empty-  GHC.reportErrors errs+      withPragmas (lhGlobalCfg lhContext) file (Ms.pragmas $ review bareSpecIso bareSpec) $ \moduleCfg ->  do+        let filters = getFilters moduleCfg+        -- Report the outcome of the checking+        LH.reportResult (errorLogger file filters) moduleCfg [giTarget (giSrc pmrTargetInfo)] out+        -- If there are unmatched filters or errors, and we are not reporting with+        -- json, we don't make it to this part of the code because errorLogger+        -- will throw an exception.+        case o_result out of+          F.Safe _ -> return $ Right pmrClientLib+          _ | json moduleCfg -> failM+            | otherwise -> return $ Left $ ErrorsOccurred [] -emptyLiquidLib :: LiquidLib-emptyLiquidLib = mkLiquidLib emptyLiftedSpec+errorLogger :: FilePath -> [Filter] -> OutputResult -> TcM ()+errorLogger file filters outputResult = do+  LH.filterReportErrorsWith+    FilterReportErrorsArgs { msgReporter = GHC.reportErrors+                           , filterReporter = LH.defaultFilterReporter file+                           , failure = GHC.failM+                           , continue = pure ()+                           , pprinter = \(spn, e) -> mkLongErrAt spn (LH.fromPJDoc e) O.empty+                           , matchingFilters = LH.reduceFilters (\(src, doc) -> PJ.render doc ++ " at " ++ LH.showPpr src) filters+                           , filters = filters+                           }+    (LH.orMessages outputResult)  isIgnore :: BareSpec -> Bool isIgnore (MkBareSpec sp) = any ((== "--skip-module") . F.val) (pragmas sp)@@ -419,24 +483,25 @@ -- spec quotes from the imported module. Also looks for -- "companion specs" for the current module and merges them in -- if it finds one.-getLiquidSpec :: Module -> [SpecComment] -> [BPspec] -> TcM BareSpec-getLiquidSpec thisModule specComments specQuotes = do-+getLiquidSpec :: FilePath -> Module -> [SpecComment] -> [BPspec] -> TcM (Either LiquidCheckException BareSpec)+getLiquidSpec thisFile thisModule specComments specQuotes = do+  globalCfg <- liftIO getConfig   let commSpecE :: Either [Error] (ModName, Spec LocBareType LocSymbol)       commSpecE = hsSpecificationP (moduleName thisModule) (coerce specComments) specQuotes   case commSpecE of-    Left errors -> do-      LH.reportErrors Full errors-      failM+    Left errors ->+      LH.filterReportErrors thisFile GHC.failM continue (getFilters globalCfg) Full errors     Right (view bareSpecIso . snd -> commSpec) -> do       res <- SpecFinder.findCompanionSpec thisModule       case res of         SpecFound _ _ companionSpec -> do           debugLog $ "Companion spec found for " ++ renderModule thisModule-          pure $ commSpec <> companionSpec-        _ -> pure commSpec+          pure $ Right $ commSpec <> companionSpec+        _ -> pure $ Right commSpec+  where+    continue = pure $ Left (ErrorsOccurred []) -processModule :: LiquidHaskellContext -> TcM ProcessModuleResult+processModule :: LiquidHaskellContext -> TcM (Either LiquidCheckException ProcessModuleResult) processModule LiquidHaskellContext{..} = do   debugLog ("Module ==> " ++ renderModule thisModule)   hscEnv              <- askHscEnv@@ -462,8 +527,8 @@     when debugLogs $       forM_ (HM.keys . getDependencies $ dependencies) $ debugLog . moduleStableString . unStableModule -    debugLog $ "mg_exports => " ++ (O.showSDocUnsafe $ O.ppr $ mg_exports modGuts)-    debugLog $ "mg_tcs => " ++ (O.showSDocUnsafe $ O.ppr $ mg_tcs modGuts)+    debugLog $ "mg_exports => " ++ O.showSDocUnsafe (O.ppr $ mg_exports modGuts)+    debugLog $ "mg_tcs => " ++ O.showSDocUnsafe (O.ppr $ mg_tcs modGuts)      targetSrc  <- makeTargetSrc moduleCfg file lhModuleTcData modGuts hscEnv     dynFlags <- getDynFlags@@ -472,17 +537,19 @@     -- Due to the fact the internals can throw exceptions from pure code at any point, we need to     -- call 'evaluate' to force any exception and catch it, if we can. +     result <--      (makeTargetSpec moduleCfg lhModuleLogicMap targetSrc bareSpec dependencies)-        `gcatch` (\(e :: UserError) -> LH.reportErrors Full [e] >> failM)-        `gcatch` (\(e :: Error)     -> LH.reportErrors Full [e] >> failM)+      makeTargetSpec moduleCfg lhModuleLogicMap targetSrc bareSpec dependencies -    case result of+    let continue = pure $ Left (ErrorsOccurred [])+        reportErrs :: (Show e, F.PPrint e) => [TError e] -> TcRn (Either LiquidCheckException ProcessModuleResult)+        reportErrs = LH.filterReportErrors file GHC.failM continue (getFilters moduleCfg) Full++    (case result of       -- Print warnings and errors, aborting the compilation.       Left diagnostics -> do         liftIO $ mapM_ (printWarning dynFlags)    (allWarnings diagnostics)-        LH.reportErrors Full (allErrors diagnostics)-        failM+        reportErrs $ allErrors diagnostics       Right (warnings, targetSpec, liftedSpec) -> do         liftIO $ mapM_ (printWarning dynFlags) warnings         let targetInfo = TargetInfo targetSrc targetSpec@@ -492,12 +559,15 @@          let clientLib  = mkLiquidLib liftedSpec & addLibDependencies dependencies -        let result = ProcessModuleResult {+        let result' = ProcessModuleResult {               pmrClientLib  = clientLib             , pmrTargetInfo = targetInfo             } -        pure result+        pure $ Right result')+      `gcatch` (\(e :: UserError) -> reportErrs [e])+      `gcatch` (\(e :: Error) -> reportErrs [e])+      `gcatch` (\(es :: [Error]) -> reportErrs es)    where     modGuts    = fromUnoptimised lhModuleGuts@@ -521,7 +591,7 @@   -- the ones exported. This covers the case of \"wrapper modules\" that simply re-exports   -- everything from the imported modules.   let availTcs    = tcAvailableTyCons tcData-  let allTcs      = L.nub $ (mgi_tcs mgiModGuts ++ availTcs)+  let allTcs      = L.nub (mgi_tcs mgiModGuts ++ availTcs)    let dataCons       = concatMap (map dataConWorkId . tyConDataCons) allTcs   let (fiTcs, fiDcs) = LH.makeFamInstEnv (getFamInstances modGuts)@@ -544,8 +614,8 @@   debugLog $ "gsFiDcs   => " ++ show fiDcs   debugLog $ "gsPrimTcs => " ++ (O.showSDocUnsafe . O.ppr $ GHC.primTyCons)   debugLog $ "things   => " ++ (O.showSDocUnsafe . O.vcat . map O.ppr $ things)-  debugLog $ "allImports => " ++ (show $ tcAllImports tcData)-  debugLog $ "qualImports => " ++ (show $ tcQualifiedImports tcData)+  debugLog $ "allImports => " ++ show (tcAllImports tcData)+  debugLog $ "qualImports => " ++ show (tcQualifiedImports tcData)    return $ TargetSrc     { giIncDir    = mempty
src/Language/Haskell/Liquid/GHC/Plugin/SpecFinder.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE RankNTypes   #-}@@ -12,7 +11,7 @@     , configToRedundantDependencies     ) where -import           Language.Haskell.Liquid.GHC.GhcMonadLike as GhcMonadLike ( GhcMonadLike+import           Liquid.GHC.GhcMonadLike as GhcMonadLike ( GhcMonadLike                                                                           , lookupModSummary                                                                           , askHscEnv                                                                           )@@ -25,8 +24,8 @@ import           Language.Fixpoint.Utils.Files            ( Ext(Spec), withExt )  import           Optics-import qualified Language.Haskell.Liquid.GHC.API         as O-import           Language.Haskell.Liquid.GHC.API         as GHC hiding (linear)+import qualified Liquid.GHC.API         as O+import           Liquid.GHC.API         as GHC  import           Data.Bifunctor import           Data.Maybe@@ -60,9 +59,7 @@                   -> [Module]                   -- ^ Any relevant module fetched during dependency-discovery.                   -> m [SpecFinderResult]-findRelevantSpecs eps hpt mods = do-  res  <- foldlM loadRelevantSpec mempty mods-  pure res+findRelevantSpecs eps hpt mods = foldlM loadRelevantSpec mempty mods   where      loadRelevantSpec :: [SpecFinderResult] -> Module -> m [SpecFinderResult]@@ -120,10 +117,10 @@ configToRedundantDependencies :: forall m. GhcMonadLike m => Config -> m [StableModule] configToRedundantDependencies cfg = do   env <- askHscEnv-  catMaybes <$> mapM (lookupModule env . first ($ cfg)) configSensitiveDependencies+  catMaybes <$> mapM (lookupModule' env . first ($ cfg)) configSensitiveDependencies   where-    lookupModule :: HscEnv -> (Bool, ModuleName) -> m (Maybe StableModule)-    lookupModule env (fetchModule, modName)+    lookupModule' :: HscEnv -> (Bool, ModuleName) -> m (Maybe StableModule)+    lookupModule' env (fetchModule, modName)       | fetchModule = liftIO $ lookupLiquidBaseModule env modName       | otherwise   = pure Nothing
src/Language/Haskell/Liquid/GHC/Plugin/Types.hs view
@@ -4,8 +4,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}@@ -64,8 +62,8 @@  import           Language.Fixpoint.Types.Spans import           Language.Haskell.Liquid.Types.Specs-import           Language.Haskell.Liquid.GHC.API         as GHC-import qualified Language.Haskell.Liquid.GHC.Interface   as LH+import           Liquid.GHC.API         as GHC+import qualified Liquid.GHC.Interface   as LH import           Language.Fixpoint.Types.Names            ( Symbol )  @@ -84,7 +82,7 @@  -- | Adds a set of dependencies to the input 'LiquidLib'. addLibDependencies :: TargetDependencies -> LiquidLib -> LiquidLib-addLibDependencies deps lib = lib { llDeps = deps <> (llDeps lib) }+addLibDependencies deps lib = lib { llDeps = deps <> llDeps lib }  -- | Returns the target 'LiftedSpec' of this 'LiquidLib'. libTarget :: LiquidLib -> LiftedSpec
src/Language/Haskell/Liquid/GHC/Plugin/Util.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveDataTypeable #-} module Language.Haskell.Liquid.GHC.Plugin.Util (         partitionMaybe       , extractSpecComments@@ -26,7 +25,7 @@ import           Data.Data import           Data.Either                              ( partitionEithers ) -import           Language.Haskell.Liquid.GHC.API+import           Liquid.GHC.API import           Language.Haskell.Liquid.GHC.Plugin.Types ( SpecComment                                                           , LiquidLib                                                           )
− src/Language/Haskell/Liquid/GHC/Resugar.hs 
@@ -1,165 +0,0 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE TypeSynonymInstances      #-}-{-# LANGUAGE UndecidableInstances      #-}---- | This module contains functions for "resugaring" low-level GHC `CoreExpr`---   into high-level patterns, that can receive special case handling in---   different phases (e.g. ANF, Constraint Generation, etc.)--module Language.Haskell.Liquid.GHC.Resugar (-  -- * High-level Source Patterns-    Pattern (..)--  -- * Lift a CoreExpr into a Pattern-  , lift--  -- * Lower a pattern back into a CoreExpr-  , lower-  ) where--import qualified Data.List as L-import           Language.Haskell.Liquid.GHC.API  as Ghc hiding (PatBind)-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------------------------------------------------------------------------------------- | Data type for high-level patterns ----------------------------------------------------------------------------------------------------------------------------data Pattern-  = PatBind-      { patE1  :: !CoreExpr-      , patX   :: !Var-      , patE2  :: !CoreExpr-      , patM   :: !Type-      , patDct :: !CoreExpr-      , patTyA :: !Type-      , patTyB :: !Type-      , patFF  :: !Var-      }                      -- ^ e1 >>= \x -> e2--  | PatReturn                -- return @ m @ t @ $dT @ e-     { patE    :: !CoreExpr  -- ^ e-     , patM    :: !Type      -- ^ m-     , patDct  :: !CoreExpr  -- ^ $dT-     , patTy   :: !Type      -- ^ t-     , patRet  :: !Var       -- ^ "return"-     }--  | PatProject               -- (case xe as x of C [x1,...,xn] -> xi) : ty-    { patXE    :: !Var       -- ^ xe-    , patX     :: !Var       -- ^ x-    , patTy    :: !Type      -- ^ ty-    , patCtor  :: !DataCon   -- ^ C-    , patBinds :: ![Var]     -- ^ [x1,...,xn]-    , patIdx   :: !Int       -- ^ i :: NatLT {len patBinds}-    }--  | PatSelfBind              -- let x = e in x-    { patX     :: !Var       -- ^ x-    , patE     :: !CoreExpr  -- ^ e-    }--  | PatSelfRecBind           -- letrec x = e in x-    { patX     :: !Var       -- ^ x-    , patE     :: !CoreExpr  -- ^ e-    }--instance F.PPrint Pattern where -  pprintTidy  = ppPat--ppPat :: F.Tidy -> Pattern -> PJ.Doc -ppPat k (PatReturn e m d t rv) = -  "PatReturn: " -  PJ.$+$ -  F.pprintKVs k-    [ ("rv" :: PJ.Doc, GM.pprDoc rv) -    , ("e " :: PJ.Doc, GM.pprDoc e) -    , ("m " :: PJ.Doc, GM.pprDoc m) -    , ("$d" :: PJ.Doc, GM.pprDoc d) -    , ("t " :: PJ.Doc, GM.pprDoc t) -    ] -ppPat _ _  = "TODO: PATTERN" -    --_mbId :: CoreExpr -> Maybe Var-_mbId (Var x)    = Just x-_mbId (Tick _ e) = _mbId e-_mbId _          = Nothing------------------------------------------------------------------------------------- | Lift expressions into High-level patterns -------------------------------------------------------------------------------------------------------------------lift :: CoreExpr -> Maybe Pattern----------------------------------------------------------------------------------lift e = exprArgs e (collectArgs e)--exprArgs :: CoreExpr -> (CoreExpr, [CoreExpr]) -> Maybe Pattern-exprArgs _e (Var op, [Type m, d, Type a, Type b, e1, Lam x e2])-  | op `is` Ghc.bindMName-  = Just (PatBind e1 x e2 m d a b op)--exprArgs (Case (Var xe) x t [(DataAlt c, ys, Var y)]) _-  | Just i <- y `L.elemIndex` ys-  = Just (PatProject xe x t c ys i)---{- TEMPORARILY DISABLED: TODO-REBARE; in reality it hasn't been working AT ALL -   since at least the GHC 8.2.1 port (?) because the TICKs get in the way -   of recognizing the pattern? Anyways, messes up --     tests/pattern/pos/Return00.hs  --   because we treat _all_ types of the form `m a` as "invariant" in the parameter `a`.-   Looks like the above tests only pass in earlier LH versions because this pattern -   was NOT getting tickled!--exprArgs _e (Var op, [Type m, d, Type t, e])-  | op `is` PN.returnMName-  = Just (PatReturn e m d t op)--}--{- TEMPORARILY DISBLED--exprArgs (Let (NonRec x e) e') _-  | Just y <- _mbId e', x == y-  = Just (PatSelfBind x e)--exprArgs (Let (Rec [(x, e)]) e') _-  | Just y <- _mbId e', x == y-  = Just (PatSelfRecBind x e)---}-exprArgs _ _-  = Nothing--is :: Var -> Name -> Bool-is v n = n == getName v------------------------------------------------------------------------------------- | Lower patterns back into expressions ------------------------------------------------------------------------------------------------------------------------lower :: Pattern -> CoreExpr----------------------------------------------------------------------------------lower (PatBind e1 x e2 m d a b op)-  = Ghc.mkCoreApps (Var op) [Type m, d, Type a, Type b, e1, Lam x e2]--lower (PatReturn e m d t op)-  = Ghc.mkCoreApps (Var op) [Type m, d, Type t, e]--lower (PatProject xe x t c ys i)-  = Case (Var xe) x t [(DataAlt c, ys, Var yi)] where yi = ys !! i--lower (PatSelfBind x e)-  = Let (NonRec x e) (Var x)--lower (PatSelfRecBind x e)-  = Let (Rec [(x, e)]) (Var x)
− src/Language/Haskell/Liquid/GHC/SpanStack.hs 
@@ -1,80 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module Language.Haskell.Liquid.GHC.SpanStack-   ( -- * Stack of positions-     Span (..)-   , SpanStack--     -- * Creating Stacks-   , empty, push--     -- * Using Stacks-   , srcSpan--     -- * Creating general spans-   , showSpan-   ) where--import           Prelude                   hiding (error)-import           Data.Maybe                       (listToMaybe, fromMaybe)-import           Language.Haskell.Liquid.GHC.Misc (tickSrcSpan, showPpr)-import qualified Language.Haskell.Liquid.GHC.API  as Ghc-import           Language.Haskell.Liquid.GHC.API  ( SrcSpan-                                                  , fsLit-                                                  , getSrcSpan-                                                  , isGoodSrcSpan-                                                  , mkGeneralSrcSpan-                                                  )---- | Opaque type for a stack of spans-newtype SpanStack = SpanStack { unStack :: [(Span, SrcSpan)] }-----------------------------------------------------------------------------------empty :: SpanStack----------------------------------------------------------------------------------empty = SpanStack []-----------------------------------------------------------------------------------push :: Span -> SpanStack -> SpanStack----------------------------------------------------------------------------------push !s stk -- @(SpanStack stk)-  | Just sp <- spanSrcSpan s = SpanStack ((s, sp) : unStack stk)-  | otherwise                = stk---- | A single span-data Span-  = Var  !Ghc.Var               -- ^ binder for whom we are generating constraint-  | Tick !(Ghc.Tickish Ghc.Var) -- ^ nearest known Source Span-  | Span SrcSpan--instance Show Span where-  show (Var x)   = show x-  show (Tick tt) = showPpr tt-  show (Span s)  = show s -----------------------------------------------------------------------------------srcSpan :: SpanStack -> SrcSpan----------------------------------------------------------------------------------srcSpan s  = fromMaybe noSpan (mbSrcSpan s)-  where-    noSpan = showSpan "Yikes! No source information"--mbSrcSpan :: SpanStack -> Maybe SrcSpan-mbSrcSpan = fmap snd . listToMaybe  . unStack--spanSrcSpan :: Span -> Maybe SrcSpan-spanSrcSpan      = maybeSpan Nothing . go-  where-    go (Var x)   = getSrcSpan x-    go (Tick tt) = tickSrcSpan tt-    go (Span s)  = s --maybeSpan :: Maybe SrcSpan -> SrcSpan -> Maybe SrcSpan-maybeSpan d sp-  | isGoodSrcSpan sp = Just sp-  | otherwise        = d-----------------------------------------------------------------------------------showSpan :: (Show a) => a -> SrcSpan----------------------------------------------------------------------------------showSpan = mkGeneralSrcSpan . fsLit . show
− src/Language/Haskell/Liquid/GHC/TypeRep.hs 
@@ -1,191 +0,0 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE TypeSynonymInstances      #-}-{-# LANGUAGE UndecidableInstances      #-}-{-# LANGUAGE ViewPatterns              #-}-{-# LANGUAGE PatternSynonyms           #-}-{-# LANGUAGE StandaloneDeriving        #-}---- | This module contains a wrappers and utility functions for--- accessing GHC module information. It should NEVER depend on-module Language.Haskell.Liquid.GHC.TypeRep (-  mkTyArg, --  showTy-  ) where--import           Language.Haskell.Liquid.GHC.Misc (showPpr)-import           Language.Haskell.Liquid.GHC.API as Ghc hiding (mkTyArg, showPpr, panic)-import           Language.Fixpoint.Types (symbol)---- e368f3265b80aeb337fbac3f6a70ee54ab14edfd--mkTyArg :: TyVar -> TyVarBinder-mkTyArg v = Bndr v Required--instance Eq Type where-  t1 == t2 = eqType' t1 t2--eqType' :: Type -> Type -> Bool -eqType' (LitTy l1) (LitTy l2) -  = l1 == l2  -eqType' (CoercionTy c1) (CoercionTy c2) -  = c1 == c2  -eqType'(CastTy t1 c1) (CastTy t2 c2) -  = eqType' t1 t2 && c1 == c2 -eqType' (FunTy a1 m1 t11 t12) (FunTy a2 m2 t21 t22)-  = a1 == a2 && m1 == m2 && eqType' t11 t21 && eqType' t12 t22  -eqType' (ForAllTy (Bndr v1 _) t1) (ForAllTy (Bndr v2 _) t2) -  = eqType' t1 (subst v2 (TyVarTy v1) t2) -eqType' (TyVarTy v1) (TyVarTy v2) -  = v1 == v2 -eqType' (AppTy t11 t12) (AppTy t21 t22) -  = eqType' t11 t21 && eqType' t12 t22  -eqType' (TyConApp c1 ts1) (TyConApp c2 ts2) -  = c1 == c2 && and (zipWith eqType' ts1 ts2) -eqType' _ _ -  = False ---deriving instance (Eq tyvar, Eq argf) => Eq (VarBndr tyvar argf)--instance Eq Coercion where-  _ == _ = True ---showTy :: Type -> String -showTy (TyConApp c ts) = "(RApp   " ++ showPpr c ++ " " ++ sep' ", " (showTy <$> ts) ++ ")"-showTy (AppTy t1 t2)   = "(TAppTy " ++ (showTy t1 ++ " " ++ showTy t2) ++ ")" -showTy (TyVarTy v)   = "(RVar " ++ show (symbol v)  ++ ")" -showTy (ForAllTy (Bndr v _) t)  = "ForAllTy " ++ show (symbol v) ++ ". (" ++  showTy t ++ ")"-showTy (FunTy af _m1 t1 t2) = "FunTy " ++ showPpr af ++ " " ++ showTy t1 ++ ". (" ++  showTy t2 ++ ")"-showTy (CastTy _ _)    = "CastTy"-showTy (CoercionTy _)  = "CoercionTy"-showTy (LitTy _)       = "LitTy"--sep' :: String -> [String] -> String-sep' _ [x] = x-sep' _ []  = []-sep' s (x:xs) = x ++ s ++ sep' s xs -------------------------------------------------------------------------------------- | GHC Type Substitutions -------------------------------------------------------------------------------------------------------------------------------------class SubstTy a where-  subst :: TyVar -> Type -> a -> a-  subst _ _ = id  --instance SubstTy Type where-  subst = substType--substType :: TyVar -> Type -> Type -> Type-substType x tx (TyConApp c ts) -  = TyConApp c (subst x tx <$> ts)-substType x tx (AppTy t1 t2)   -  = AppTy (subst x tx t1) (subst x tx t2) -substType x tx (TyVarTy y)   -  | symbol x == symbol y-  = tx -  | otherwise-  = TyVarTy y -substType x tx (FunTy aaf m t1 t2)-  = FunTy aaf m (subst x tx t1) (subst x tx t2)-substType x tx f@(ForAllTy b@(Bndr y _) t)  -  | symbol x == symbol y -  = f-  | otherwise -  = ForAllTy b (subst x tx t)-substType x tx (CastTy t c)    -  = CastTy (subst x tx t) (subst x tx c)-substType x tx (CoercionTy c)  -  = CoercionTy $ subst x tx c -substType _ _  (LitTy l)-  = LitTy l  ---instance SubstTy Coercion where-  subst = substCoercion--substCoercion :: TyVar -> Type -> Coercion -> Coercion-substCoercion x tx (TyConAppCo r c cs)-  = TyConAppCo (subst x tx r) c (subst x tx <$> cs)-substCoercion x tx (AppCo c1 c2)-  = AppCo (subst x tx c1) (subst x tx c2)-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)-substCoercion x tx (FunCo r c1 c2)-  = FunCo r (subst x tx c1) (subst x tx c2)-#else-substCoercion x tx (FunCo r cN c1 c2)-  = FunCo r cN (subst x tx c1) (subst x tx c2) -- TODO(adinapoli) Is this the correct substitution?-#endif-#endif-substCoercion x tx (ForAllCo y c1 c2)-  | symbol x == symbol y -  = (ForAllCo y c1 c2)-  | otherwise -  = ForAllCo y (subst x tx c1) (subst x tx c2)-substCoercion _ _ (CoVarCo y)-  = CoVarCo y -substCoercion x tx (AxiomInstCo co bi cs)-  = AxiomInstCo (subst x tx co) bi (subst x tx <$> cs)  -substCoercion x tx (UnivCo y r t1 t2)-  = UnivCo (subst x tx y) (subst x tx r) (subst x tx t1) (subst x tx t2)-substCoercion x tx (SymCo c)-  = SymCo (subst x tx c)-substCoercion x tx (TransCo c1 c2)-  = TransCo (subst x tx c1) (subst x tx c2)-substCoercion x tx (AxiomRuleCo ca cs)-  = AxiomRuleCo (subst x tx ca)  (subst x tx <$> cs)  -substCoercion x tx (NthCo r i c)-  = NthCo r i (subst x tx c)-substCoercion x tx (LRCo i c)-  = LRCo i (subst x tx c)-substCoercion x tx (InstCo c1 c2)-  = InstCo (subst x tx c1) (subst x tx c2)-substCoercion x tx (KindCo c)-  = KindCo (subst x tx c)-substCoercion x tx (SubCo c)-  = SubCo (subst x tx c)-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) && !MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)-substCoercion x tx (Refl r t)-  = Refl (subst x tx r) (subst x tx t)-substCoercion x tx (CoherenceCo c1 c2)-  = CoherenceCo (subst x tx c1) (subst x tx c2)-#endif-#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)-substCoercion x tx (Refl t)-  = Refl (subst x tx t)-substCoercion x tx (GRefl r t co) -- FIXME(adn) Is this a correct substitution?-  = GRefl r (subst x tx t) co     -- FIXME(adn) Is this a correct substitution?-substCoercion _x _tx (HoleCo cH)-  = HoleCo cH                     -- FIXME(adn) Is this a correct substitution?-#endif-#endif--instance SubstTy Role where-instance SubstTy (CoAxiom Branched) where--instance SubstTy UnivCoProvenance where-  subst x tx (PhantomProv c)-    = PhantomProv $ subst x tx c -  subst x tx (ProofIrrelProv c)-    = ProofIrrelProv $ subst x tx c -  subst _ _ ch -    = ch --instance SubstTy CoAxiomRule where-  subst x tx (CoAxiomRule n rs r ps) -    = CoAxiomRule n (subst x tx <$> rs) (subst x tx r) (\eq -> subst x tx (ps (subst x tx eq)))--instance (SubstTy a, Functor m) => SubstTy (m a) where-  subst x tx xs = subst x tx <$> xs
− src/Language/Haskell/Liquid/GHC/Types.hs 
@@ -1,79 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Language.Haskell.Liquid.GHC.Types where--import           Data.HashSet (HashSet, fromList)-import           Data.Hashable-import           GHC.Generics hiding (moduleName)-import           Language.Haskell.Liquid.GHC.API---- | A 'StableName' is virtually isomorphic to a GHC's 'Name' but crucially we don't use--- the 'Eq' instance defined on a 'Name' because it's 'Unique'-based. In particular, GHC--- doesn't guarantee that if we load an interface multiple times we would get the same 'Unique' for the--- same 'Name', and this is a problem when we rely on 'Name's to be the same when we call 'isExportedVar',--- which used to use a 'NameSet' derived from the '[AvailInfo]'. As the name implies, a 'NameSet' uses a--- 'Name's 'Unique' for duplicate detection and indexing, and this would lead to 'Var's being resolved to--- a 'Name' which is basically the same, but it has a /different/ 'Unique', and that would cause the lookup--- inside the 'NameSet' to fail.-newtype StableName =-  MkStableName { unStableName :: Name }-  deriving Generic--instance Show StableName where-  show (MkStableName n) = nameStableString n--instance Hashable StableName where-  hashWithSalt s (MkStableName n) = hashWithSalt s (nameStableString n)--instance Eq StableName where-  (MkStableName n1) == (MkStableName n2) = -- n1 `stableNameCmp` n2 == EQ-    let sameOccName = (occNameString $ nameOccName n1) == (occNameString $ nameOccName n2)-        sameModule  = nameModule  n1 == nameModule  n2-        sameSrcLoc  = nameSrcLoc  n1 == nameSrcLoc  n2-        sameSrcSpan = nameSrcSpan n1 == nameSrcSpan n2-    in sameOccName && sameModule && sameSrcLoc  && sameSrcSpan---- | Creates a new 'StableName' out of a 'Name'.-mkStableName :: Name -> StableName-mkStableName = MkStableName---- | Converts a list of 'AvailInfo' into a \"StableNameSet\", similarly to what 'availsToNameSet' would do.-availsToStableNameSet :: [AvailInfo] -> HashSet StableName-availsToStableNameSet avails = foldr add mempty avails-      where add av acc = acc <> fromList (map mkStableName (availNames av))------------------------------------------------------------------------------------- | Datatype For Holding GHC ModGuts ----------------------------------------------------------------------------------------------------------------------------data MGIModGuts = MI -  { mgi_binds     :: !CoreProgram-  , mgi_module    :: !Module-  , mgi_deps      :: !Dependencies-  , mgi_dir_imps  :: ![ModuleName]-  , mgi_rdr_env   :: !GlobalRdrEnv-  , mgi_tcs       :: ![TyCon]-  , mgi_fam_insts :: ![FamInst]-  , mgi_exports   :: !(HashSet StableName)-  , mgi_cls_inst  :: !(Maybe [ClsInst])-  }--miModGuts :: Maybe [ClsInst] -> ModGuts -> MGIModGuts-miModGuts cls mg  = MI -  { mgi_binds     = mg_binds mg-  , mgi_module    = mg_module mg-  , mgi_deps      = mg_deps mg-  , mgi_dir_imps  = mg_dir_imps mg-  , mgi_rdr_env   = mg_rdr_env mg-  , mgi_tcs       = mg_tcs mg-  , mgi_fam_insts = mg_fam_insts mg-  , mgi_exports   = availsToStableNameSet $ mg_exports mg-  , mgi_cls_inst  = cls-  }--nameSetToStableNameSet :: NameSet -> HashSet StableName-nameSetToStableNameSet = fromList . map mkStableName . nameSetElemsStable--mg_dir_imps :: ModGuts -> [ModuleName]-mg_dir_imps = map gwib_mod . getDependenciesModuleNames . mg_deps--mgi_namestring :: MGIModGuts -> String-mgi_namestring = moduleNameString . moduleName . mgi_module
src/Language/Haskell/Liquid/LawInstances.hs view
@@ -7,7 +7,7 @@  import           Language.Haskell.Liquid.Types import           Language.Haskell.Liquid.Types.Equality-import           Language.Haskell.Liquid.GHC.API            hiding ((<+>), text)+import           Liquid.GHC.API            hiding ((<+>), text) import qualified Language.Fixpoint.Types                    as F  checkLawInstances :: GhcSpecLaws -> Diagnostics@@ -63,7 +63,7 @@     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_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@@ -76,10 +76,10 @@     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)+    esubst1 = zip  (fst <$> args1) (F.EVar . fst <$> args2)      tsubst = reverse $ zip ((\(RTV v) -> v) <$> (findTyVars tc1 ++ (ty_var_value <$> concat argVars)))-                 (toType False <$> (argBds ++ (((`RVar` mempty) . ty_var_value) <$> (fst <$> ty_vars trep2))))+                 (toType False <$> (argBds ++ ((`RVar` mempty) . ty_var_value <$> (fst <$> ty_vars trep2))))      (argVars, argBds) = unzip (splitForall [] . val <$> lilTyArgs li)
src/Language/Haskell/Liquid/Liquid.hs view
@@ -1,7 +1,4 @@-{-# LANGUAGE NamedFieldPuns      #-}-{-# LANGUAGE TupleSections       #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards     #-}  {-@ LIQUID "--diff"     @-} @@ -42,18 +39,19 @@ 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, ignoreCoreBinds) -- howPpr)-import           Language.Haskell.Liquid.GHC.Interface+import           Liquid.GHC.Misc (showCBs, ignoreCoreBinds) -- howPpr)+import           Liquid.GHC.Interface import           Language.Haskell.Liquid.Constraint.Generate import           Language.Haskell.Liquid.Constraint.ToFixpoint import           Language.Haskell.Liquid.Constraint.Types import           Language.Haskell.Liquid.UX.Annotate (mkOutput) import qualified Language.Haskell.Liquid.Termination.Structural as ST-import qualified Language.Haskell.Liquid.GHC.Misc          as GM -import           Language.Haskell.Liquid.GHC.API as GHC hiding (text, vcat, ($+$), getOpts, (<+>))+import qualified Liquid.GHC.Misc          as GM +import           Liquid.GHC.API as GHC hiding (text, vcat, ($+$), getOpts, (<+>))  type MbEnv = Maybe HscEnv + -------------------------------------------------------------------------------- liquid :: [String] -> IO b --------------------------------------------------------------------------------@@ -87,7 +85,7 @@ checkTargets cfg  = go    where     go env []     = return (ExitSuccess, env)-    go env (f:fs) = do whenLoud $ colorPhaseLn Loud ("[Checking: " ++ f ++ "]") ""+    go env (f:fs) = do -- whenLoud $ colorPhaseLn Loud ("[Checking: " ++ f ++ "]") ""                        (ec, env') <- runLiquidTargets env cfg [f]                         case ec of                           ExitSuccess -> go env' fs@@ -170,7 +168,7 @@     check :: IO (Output Doc)     check       | compileSpec cfg = do-        donePhase Loud "Only compiling specifications [skipping verification]"+        -- donePhase Loud "Only compiling specifications [skipping verification]"         pure mempty { o_result = F.Safe mempty }       | otherwise = do         whenNormal $ donePhase Loud "Extracted Core using GHC"@@ -268,7 +266,7 @@                                  `addErrors` makeFailErrors (S.toList failBs) rf                                   `addErrors` makeFailUseErrors (S.toList failBs) (giCbs $ giSrc info)   let lErrors       = applySolution sol <$> logErrors cgi-  hErrors          <- if (typedHoles cfg) +  hErrors          <- if typedHoles cfg                          then synthesize tgt fcfg (cgi{holesMap = applySolution sol <$> holesMap  cgi})                          else return []    let resModel      = resModel' `addErrors` (e2u cfg sol <$> (lErrors ++ hErrors)) @@ -285,8 +283,8 @@   let e' = attachSubcId e    in fmap F.pprint (tidyError cfg s e')   where-    attachSubcId es@(ErrSubType{}) = es { cid = Just subcId }-    attachSubcId es@(ErrSubTypeModel{}) = es { cid = Just subcId }+    attachSubcId es@ErrSubType{}      = es { cid = Just subcId }+    attachSubcId es@ErrSubTypeModel{} = es { cid = Just subcId }     attachSubcId es = es  -- writeCGI tgt cgi = {-# SCC "ConsWrite" #-} writeFile (extFileName Cgi tgt) str@@ -312,7 +310,7 @@ makeFailErrors bs cis = [ mkError x | x <- bs, notElem (val x) vs ]     where      mkError  x = ErrFail (GM.sourcePosSrcSpan $ loc x) (pprint $ val x)-    vs         = [v | Just v <- (ci_var <$> cis) ]+    vs         = Mb.mapMaybe ci_var cis  splitFails :: S.HashSet Var -> F.FixResult (a, Cinfo) -> (F.FixResult (a, Cinfo),  [Cinfo]) splitFails _ r@(F.Crash _ _) = (r,mempty)
src/Language/Haskell/Liquid/Measure.hs view
@@ -3,7 +3,6 @@ {-# LANGUAGE UndecidableInstances   #-} {-# LANGUAGE OverloadedStrings      #-} {-# LANGUAGE ConstraintKinds        #-}-{-# LANGUAGE DeriveGeneric          #-}  module Language.Haskell.Liquid.Measure (   -- * Specifications@@ -33,8 +32,8 @@  import           Language.Fixpoint.Misc import           Language.Fixpoint.Types                hiding (panic, R, DataDecl, SrcSpan, LocSymbol)-import           Language.Haskell.Liquid.GHC.API        as Ghc hiding (Expr, showPpr, panic, (<+>))-import           Language.Haskell.Liquid.GHC.Misc+import           Liquid.GHC.API        as Ghc hiding (Expr, showPpr, panic, (<+>))+import           Liquid.GHC.Misc -- import qualified Language.Haskell.Liquid.Misc as Misc import           Language.Haskell.Liquid.Types.Types    -- hiding (GhcInfo(..), GhcSpec (..)) import           Language.Haskell.Liquid.Types.RefType@@ -69,14 +68,14 @@   checkDuplicateMeasure :: [Measure ty ctor] -> [Measure ty ctor]-checkDuplicateMeasure ms+checkDuplicateMeasure measures   = case M.toList dups of-      []         -> ms-      (m,ms):_   -> uError $ err m (msName <$> ms)+      []         -> measures+      (m,ms):_   -> uError $ mkErr m (msName <$> ms)     where-      gms        = group [(msName m , m) | m <- ms]+      gms        = group [(msName m , m) | m <- measures]       dups       = M.filter ((1 <) . length) gms-      err m ms   = ErrDupMeas (fSrcSpan m) (pprint (val m)) (fSrcSpan <$> ms)+      mkErr m ms = ErrDupMeas (fSrcSpan m) (pprint (val m)) (fSrcSpan <$> ms)   dataConTypes :: Bool -> MSpec (RRType Reft) DataCon -> ([(Var, RRType Reft)], [(LocSymbol, RRType Reft)])@@ -154,7 +153,7 @@   = t   where     rep = toRTypeRep t-    xs' = zipWith (\_ i -> symbol ("x" ++ show i)) (ty_binds rep) [1..]+    xs' = zipWith (\_ i -> symbol ("x" ++ show i)) (ty_binds rep) [(1::Int)..]     su  = mkSubst $ zip (ty_binds rep) (EVar <$> xs')  combineDCTypes :: String -> Type -> [RRType Reft] -> RRType Reft
src/Language/Haskell/Liquid/Misc.hs view
@@ -56,9 +56,9 @@ safeFromJust _  (Just x) = x safeFromJust err _       = errorstar err -safeFromLeft :: String -> Either a b -> a -safeFromLeft _   (Left l) = l -safeFromLeft err _        = errorstar err +safeFromLeft :: String -> Either a b -> a+safeFromLeft _   (Left l) = l+safeFromLeft err _        = errorstar err   takeLast :: Int -> [a] -> [a]@@ -153,17 +153,17 @@   -unzip4 :: [(t, t1, t2, t3)] -> ([t],[t1],[t2],[t3]) +unzip4 :: [(t, t1, t2, t3)] -> ([t],[t1],[t2],[t3]) unzip4 = go [] [] [] []-  where go a1 a2 a3 a4 ((x1,x2,x3,x4):xs) = go (x1:a1) (x2:a2) (x3:a3) (x4:a4) xs +  where go a1 a2 a3 a4 ((x1,x2,x3,x4):xs) = go (x1:a1) (x2:a2) (x3:a3) (x4:a4) xs         go a1 a2 a3 a4 [] = (reverse  a1, reverse a2, reverse a3, reverse a4)-   -isIncludeFile :: FilePath -> FilePath -> Bool ++isIncludeFile :: FilePath -> FilePath -> Bool isIncludeFile incDir src = -- do    -- incDir <- getIncludeDir    -- return -  (incDir `L.isPrefixOf` src)+  incDir `L.isPrefixOf` src  getIncludeDir :: IO FilePath getIncludeDir = dropFileName <$> getDataFileName ("include" </> "Prelude.spec")@@ -180,10 +180,10 @@     exePath <- dropFileName <$> getExecutablePath     let atExe = exePath </> fileName     exists <- doesFileExist atExe-    -    if exists then ++    if exists then       return atExe-    else +    else       fmap (</> fileName) getIncludeDir  @@ -213,7 +213,7 @@   mapNs :: (Eq a, Num a, Foldable t) => t a -> (a1 -> a1) -> [a1] -> [a1]-mapNs ns f xs = foldl (\xs n -> mapN n f xs) xs ns+mapNs ns f xs = foldl (\ys n -> mapN n f ys) xs ns  mapN :: (Eq a, Num a) => a -> (a1 -> a1) -> [a1] -> [a1] mapN 0 f (x:xs) = f x : xs@@ -253,7 +253,7 @@ firstMaybes = listToMaybe . catMaybes  fromFirstMaybes :: a -> [Maybe a] -> a-fromFirstMaybes x = fromMaybe x . firstMaybes +fromFirstMaybes x = fromMaybe x . firstMaybes -- fromFirstMaybes x = fromMaybe x . listToMaybe . catMaybes  hashMapMapWithKey   :: (k -> v1 -> v2) -> M.HashMap k v1 -> M.HashMap k v2@@ -267,17 +267,17 @@  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 +  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 ] +replaceWith f xs ys = snd <$> replaceSubset xs' ys'+  where+    xs'             = [ (f x, x) | x <- xs ]+    ys'             = [ (f y, y) | y <- ys ]   @@ -328,7 +328,7 @@ mkGraph = fmap S.fromList . group  tryIgnore :: String -> IO () -> IO ()-tryIgnore s a = +tryIgnore s a =   Ex.catch a $ \e -> do     let err = show (e :: Ex.IOException)     writeLoud ("Warning: Couldn't do " ++ s ++ ": " ++ err)@@ -370,7 +370,7 @@     tx (k, vs)  = Left  (k, vs)  uniqueByKey' :: (Eq k, Hashable k) => ((k, [v]) -> Either e v) -> [(k, v)] -> Either e [v]-uniqueByKey' tx = sequence . map tx . groupList+uniqueByKey' tx = mapM tx . groupList   join :: (Eq b, Hashable b) => [(a, b)] -> [(b, c)] -> [(a, c)]@@ -389,10 +389,10 @@ 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 +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 []     = ([], [])@@ -409,28 +409,28 @@ catEithers zs = case ls of   [] -> Right rs   _  -> Left ls-  where +  where     ls = [ l | Left  l <- zs ]     rs = [ r | Right r <- zs ]   keyDiff :: (Eq k, Hashable k) => (a -> k) -> [a] -> [a] -> [a] keyDiff f x1s x2s = M.elems (M.difference (m x1s) (m x2s))-  where -    m xs          = M.fromList [(f x, x) | x <- xs] +  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 +sayReadFile :: FilePath -> IO String+sayReadFile f = do   -- print ("SAY-READ-FILE: " ++ f)-  res <- readFile f +  res <- readFile f   Ex.evaluate res -lastModified :: FilePath -> IO (Maybe UTCTime) -lastModified f = do +lastModified :: FilePath -> IO (Maybe UTCTime)+lastModified f = do   ex  <- doesFileExist f   if ex then Just <$> getModificationTime f         else return   Nothing
src/Language/Haskell/Liquid/Parse.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE UndecidableInstances      #-}-{-# LANGUAGE TypeSynonymInstances      #-} {-# LANGUAGE TupleSections             #-} {-# LANGUAGE OverloadedStrings         #-} {-# LANGUAGE DeriveDataTypeable        #-}@@ -35,13 +34,13 @@ import           Data.Char                              (isSpace, isAlphaNum) import           Data.List                              (foldl', partition) import           GHC                                    (ModuleName, mkModuleName)-import qualified Text.PrettyPrint.HughesPJ              as PJ -import           Text.PrettyPrint.HughesPJ.Compat       ((<+>)) +import 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       hiding (getSourcePos)+import           Liquid.GHC.Misc       hiding (getSourcePos) import           Language.Haskell.Liquid.Types -- import           Language.Haskell.Liquid.Types.Errors-import qualified Language.Fixpoint.Misc                 as Misc      +import qualified Language.Fixpoint.Misc                 as Misc import qualified Language.Haskell.Liquid.Misc           as Misc import qualified Language.Haskell.Liquid.Measure        as Measure import           Language.Fixpoint.Parse                hiding (defineP, dataDeclP, refBindP, refP, refDefP, parseTest')@@ -61,21 +60,21 @@   case go ([], []) initPStateWithList $ reverse specComments of     ([], specs) ->       Right $ mkSpec (ModName SrcImport modName) (specs ++ specQuotes)-    (errs, _) ->-      Left errs+    (errors, _) ->+      Left errors   where     go :: ([Error], [BPspec])   -- accumulated errors and parsed specs (in reverse order)        -> PState                -- parser state (primarily infix operator priorities)        -> [(SourcePos, String)] -- remaining unparsed spec comments        -> ([Error], [BPspec])   -- final errors and parsed specs-    go (errs, specs) _ []-      = (reverse errs, reverse specs)-    go (errs, specs) pstate ((pos, specComment):xs)+    go (errors, specs) _ []+      = (reverse errors, reverse specs)+    go (errors, specs) pstate ((pos, specComment):xs)       = -- 'specP' parses a single spec comment, i.e., a single LH directive         -- we allow a "block" of specs now         case parseWithError pstate (block specP) pos specComment of-          Left err        -> go (parseErrorBundleToErrors err ++ errs, specs) pstate xs-          Right (st,spec) -> go (errs,spec ++ specs) st xs+          Left err'       -> go (parseErrorBundleToErrors err' ++ errors, specs) pstate xs+          Right (st,spec) -> go (errors,spec ++ specs) st xs  initPStateWithList :: PState initPStateWithList@@ -197,9 +196,9 @@ toLogicOneP :: Parser  (LocSymbol, [Symbol], Expr) toLogicOneP   = do reserved "define"-       (x:xs) <- some (locSymbolP)+       (x:xs) <- some locSymbolP        reservedOp "="-       e      <- exprP+       e      <- exprP <|> predP        return (x, val <$> xs, e)  @@ -253,16 +252,16 @@     PcExplicit b -> parseFun c b   <?> "btP"   where-    parseFun c@(PC sb t1) b  =-      ((do+    parseFun c@(PC sb t1) sym  =+      (do             reservedOp "->"             PC _ t2 <- btP-            return (PC sb (rFun b t1 t2)))+            return (PC sb (rFun sym t1 t2)))         <|>          (do             reservedOp "~>"             PC _ t2 <- btP-            return (PC sb (rImpF b t1 t2)))+            return (PC sb (rImpF sym t1 t2)))         <|>          (do             reservedOp "=>"@@ -273,8 +272,8 @@           (do              b <- locInfixSymbolP              PC _ t2 <- btP-             return $ PC sb $ (RApp (mkBTyCon b) [t1,t2] [] mempty))-         <|> return c)+             return $ PC sb $ RApp (mkBTyCon b) [t1,t2] [] mempty)+         <|> return c   compP :: Parser ParamComp@@ -288,7 +287,7 @@  <|> bareTypeBracesP                        -- starts with '{'  <|> unnamedCircleP  <|> anglesCircleP                          -- starts with '<'- <|> nullPC <$> (dummyP bbaseP)             -- starts with '_' or '[' or '(' or lower or "'" or upper+ <|> nullPC <$> dummyP bbaseP               -- starts with '_' or '[' or '(' or lower or "'" or upper  <?> "circleP"  anglesCircleP :: Parser ParamComp@@ -307,13 +306,12 @@ namedCircleP :: Parser ParamComp namedCircleP = do   lb <- locLowerIdP-  (do _ <- reservedOp ":"-      let b = val lb-      PC (PcExplicit b) <$> bareArgP b+  do _ <- reservedOp ":"+     let b = val lb+     PC (PcExplicit b) <$> bareArgP b     <|> do       b <- dummyBindP       PC (PcImplicit b) <$> dummyP (lowerIdTail (val lb))-    )  unnamedCircleP :: Parser ParamComp unnamedCircleP = do@@ -335,10 +333,7 @@ bareTypeBracesP :: Parser ParamComp bareTypeBracesP = do   t <-  try (braces (-            (try (do-               ct <- constraintP-               return $ Right ct-                     ))+            try (Right <$> constraintP)            <|>             (do                     x  <- symbolP@@ -363,7 +358,7 @@       = (reserved "_" >> return hole)      <|> try (pAnd <$> brackets (sepBy predP semi))     helper p = braces $ do-      t <- (RHole . uTop . Reft . ("VV",)) <$> p+      t <- RHole . uTop . Reft . ("VV",) <$> p       return (Left $ nullPC t)  @@ -371,7 +366,7 @@ bareArgP vvv   =  refDefP vvv refasHoleP bbaseP    -- starts with '{'  <|> holeP                            -- starts with '_'- <|> (dummyP bbaseP)+ <|> dummyP bbaseP  <|> parens bareTypeP                 -- starts with '('                                       -- starts with '_', '[', '(', lower, upper  <?> "bareArgP"@@ -381,7 +376,7 @@ bareAtomP ref   =  ref refasHoleP bbaseP  <|> holeP- <|> (dummyP bbaseP)+ <|> dummyP bbaseP  <?> "bareAtomP"  bareAtomBindP :: Parser BareType@@ -397,7 +392,7 @@              -> Parser BareType refBindBindP rp kindP'   = braces (-      ((do+      (do               x  <- symbolP               _ <- reservedOp ":"               -- NOSUBST i  <- freshIntP@@ -408,8 +403,8 @@               -- su replaces any use of x in the balance of the expression with the unique val               -- NOSUBST let xi = intSymbol x i               -- NOSUBST let su v = if v == x then xi else v-              return $ {- substa su $ NOSUBST -} t (Reft (x, ra)) ))-     <|> ((RHole . uTop . Reft . ("VV",)) <$> rp)+              return $ {- substa su $ NOSUBST -} t (Reft (x, ra)) )+     <|> (RHole . uTop . Reft . ("VV",) <$> rp)      <?> "refBindBindP"    ) @@ -418,8 +413,8 @@         -> Parser Expr         -> Parser (Reft -> BareType)         -> Parser BareType-refDefP vv rp kindP' = braces $ do-  x       <- optBindP vv+refDefP sym rp kindP' = braces $ do+  x       <- optBindP sym   -- NOSUBST i       <- freshIntP   t       <- try (kindP' <* reservedOp "|") <|> return (RHole . uTop) <?> "refDefP"   ra      <- rp@@ -434,6 +429,12 @@ refP :: Parser (Reft -> BareType) -> Parser BareType refP = refBindBindP refaP +relrefaP :: Parser RelExpr +relrefaP =+  try (ERUnChecked <$> refaP <* reserved ":=>" <*> relrefaP)+    <|> try (ERChecked <$> refaP <* reserved "!=>" <*> relrefaP)+    <|> ERBasic <$> refaP+ -- "sym :" or return the devault sym optBindP :: Symbol -> Parser Symbol optBindP x = try bindP <|> return x@@ -469,21 +470,21 @@      lowerIdTail l  maybeBind :: Parser a -> Parser (Maybe Symbol, a)-maybeBind p = do {bd <- maybeP' bbindP; ty <- p ; return (bd, ty)}+maybeBind parser = do {bd <- maybeP' bbindP; ty <- parser ; return (bd, ty)}   where     maybeP' p = try (Just <$> p)              <|> return Nothing  lowerIdTail :: Symbol -> Parser (Reft -> BareType) lowerIdTail l =-     (    (liftM2 bAppTy (return $ bTyVar l) (some bareTyArgP))-      <|> (liftM2 bRVar  (return $ bTyVar l) monoPredicateP))+          fmap (bAppTy (bTyVar l)) (some bareTyArgP)+      <|> fmap (bRVar (bTyVar l)) monoPredicateP  bTyConP :: Parser BTyCon bTyConP   =  (reservedOp "'" >> (mkPromotedBTyCon <$> locUpperIdP))  <|> mkBTyCon <$> locUpperIdP- <|> (reserved "*" >> (return $ mkBTyCon (dummyLoc $ symbol ("*" :: String))))+ <|> (reserved "*" >> return (mkBTyCon (dummyLoc $ symbol ("*" :: String))))  <?> "bTyConP"  mkPromotedBTyCon :: LocSymbol -> BTyCon@@ -515,7 +516,7 @@ bareAtomNoAppP :: Parser BareType bareAtomNoAppP   =  refP bbaseNoAppP- <|> (dummyP bbaseNoAppP)+ <|> dummyP bbaseNoAppP  <?> "bareAtomNoAppP"  @@ -524,13 +525,12 @@   = do xts <- constraintEnvP        t1  <- bareTypeP        reservedOp "<:"-       t2  <- bareTypeP-       return $ fromRTypeRep $ RTypeRep [] [] []+       fromRTypeRep . RTypeRep [] [] []                                         [] [] []                                         ((val . fst <$> xts) ++ [dummySymbol])                                         (replicate (length xts + 1) defRFInfo)                                         (replicate (length xts + 1) mempty)-                                        ((snd <$> xts) ++ [t1]) t2+                                        ((snd <$> xts) ++ [t1]) <$> bareTypeP  constraintEnvP :: Parser [(LocSymbol, BareType)] constraintEnvP@@ -552,37 +552,43 @@ --  "forall x y <z :: Nat, w :: Int> . TYPE" bareAllP :: Parser BareType bareAllP = do-  as <- tyVarDefsP-  ps <- angles inAngles-        <|> (return [])-  dot+  sp <- getSourcePos+  as  <- tyVarDefsP+  ps  <- angles inAngles+        <|> return []+  _ <- dot   t <- bareTypeP-  return $ foldr rAllT (foldr RAllP t ps) (makeRTVar <$> as)+  return $ foldr rAllT (foldr (rAllP sp) t ps) (makeRTVar <$> as)   where     rAllT a t = RAllT a t mempty-    inAngles =-      (-       (try  (sepBy  predVarDefP comma))-       )+    inAngles  = try  (sepBy  predVarDefP comma) +-- See #1907 for why we have to alpha-rename pvar binders+rAllP :: SourcePos -> PVar BSort -> BareType -> BareType+rAllP sp p t = RAllP p' ({- F.tracepp "rAllP" $ -} substPVar p p' t)+  where+    p'  = p { pname = pn' }+    pn' = pname p `intSymbol` lin `intSymbol` col+    lin = unPos (sourceLine sp)+    col = unPos (sourceColumn  sp)+ tyVarDefsP :: Parser [BTyVar] tyVarDefsP-  = (parens $ many (bTyVar <$> tyKindVarIdP))+  = parens (many (bTyVar <$> tyKindVarIdP))  <|> many (bTyVar <$> tyVarIdP)  <?> "tyVarDefsP"  tyKindVarIdP :: Parser Symbol tyKindVarIdP = do    tv <- tyVarIdP-   (  (do reservedOp "::"; _ <- kindP; return tv)-    <|> return tv)+   do reservedOp "::"; _ <- kindP; return tv <|> return tv  kindP :: Parser BareType kindP = bareAtomBindP  predVarDefsP :: Parser [PVar BSort] predVarDefsP-  =  (angles $ sepBy1 predVarDefP comma)+  =  angles (sepBy1 predVarDefP comma)  <|> return []  <?> "predVarDefP" @@ -598,7 +604,7 @@ bPVar p _ xts  = PV p (PVProp τ) dummySymbol τxs   where     (_, τ) = safeLast "bPVar last" xts-    τxs    = [ (τ, x, EVar x) | (x, τ) <- init xts ]+    τxs    = [ (τ', x, EVar x) | (x, τ') <- init xts ]     safeLast _ xs@(_:_) = last xs     safeLast msg _      = panic Nothing $ "safeLast with empty list " ++ msg @@ -606,16 +612,16 @@ propositionSortP = map (Misc.mapSnd toRSort) <$> propositionTypeP  propositionTypeP :: Parser [(Symbol, BareType)]-propositionTypeP = either fail return =<< (mkPropositionType <$> bareTypeP)+propositionTypeP = either fail return . mkPropositionType =<< bareTypeP  mkPropositionType :: BareType -> Either String [(Symbol, BareType)] mkPropositionType t   | isOk      = Right $ zip (ty_binds tRep) (ty_args tRep)-  | otherwise = Left err+  | otherwise = Left mkErr   where     isOk      = isPropBareType (ty_res tRep)     tRep      = toRTypeRep t-    err       = "Proposition type with non-Bool output: " ++ showpp t+    mkErr     = "Proposition type with non-Bool output: " ++ showpp t  xyP :: Parser x -> Parser a -> Parser y -> Parser (x, y) xyP lP sepP rP =@@ -661,7 +667,7 @@ predicatesP :: (IsString tv, Monoid r)             => Parser [Ref (RType c tv r) BareType] predicatesP-   =  (angles $ sepBy1 predicate1P comma)+   =  angles (sepBy1 predicate1P comma)   <|> return []   <?> "predicatesP" @@ -670,7 +676,7 @@ predicate1P    =  try (RProp <$> symsP <*> refP bbaseP)   <|> (rPropP [] . predUReft <$> monoPredicate1P)-  <|> (braces $ bRProp <$> symsP' <*> refaP)+  <|> braces (bRProp <$> symsP' <*> refaP)   <?> "predicate1P"    where     symsP'       = do ss    <- symsP@@ -697,8 +703,7 @@   <|> (pdVar <$>        predVarUseP)   <?> "monoPredicate1P" -predVarUseP :: IsString t-            => Parser (PVar t)+predVarUseP :: Parser (PVar String) predVarUseP   = do (p, xs) <- funArgsP        return   $ PV p (PVProp dummyTyId) dummySymbol [ (dummyTyId, dummySymbol, x) | x <- xs ]@@ -714,11 +719,10 @@ boundP = do   name   <- locUpperIdP   reservedOp "="-  vs     <- bvsP-  params <- many (parens tyBindP)-  args   <- bargsP-  body   <- predP-  return $ Bound name vs params args body+  vs      <- bvsP+  params' <- many (parens tyBindP)+  args    <- bargsP+  Bound name vs params' args <$> predP  where     bargsP =     ( do reservedOp "\\"                       xs <- many (parens tyBindP)@@ -762,12 +766,12 @@ bRProp :: [((Symbol, τ), Symbol)]        -> Expr -> Ref τ (RType c BTyVar (UReft Reft)) bRProp []    _    = panic Nothing "Parse.bRProp empty list"-bRProp syms' expr = RProp ss $ bRVar (BTV dummyName) mempty r+bRProp syms' epr  = RProp ss $ bRVar (BTV dummyName) mempty r   where-    (ss, (v, _))  = (init syms, last syms)-    syms          = [(y, s) | ((_, s), y) <- syms']+    (ss, (v, _))  = (init symsf, last symsf)+    symsf         = [(y, s) | ((_, s), y) <- syms']     su            = mkSubst [(x, EVar y) | ((x, _), y) <- syms']-    r             = su `subst` Reft (v, expr)+    r             = su `subst` Reft (v, epr)  bRVar :: tv -> Predicate -> r -> RType c tv (UReft r) bRVar α p r = RVar α (MkUReft r p)@@ -776,8 +780,8 @@      -> [RTProp BTyCon tv (UReft r)]      -> r      -> RType BTyCon tv (UReft r)-bLst (Just t) rs r        = RApp (mkBTyCon $ dummyLoc listConName) [t] rs (reftUReft r)-bLst (Nothing) rs r       = RApp (mkBTyCon $ dummyLoc listConName) []  rs (reftUReft r)+bLst (Just t) rs r = RApp (mkBTyCon $ dummyLoc listConName) [t] rs (reftUReft r)+bLst Nothing  rs r = RApp (mkBTyCon $ dummyLoc listConName) []  rs (reftUReft r)  bTup :: (PPrint r, Reftable r, Reftable (RType BTyCon BTyVar (UReft r)), Reftable (RTProp BTyCon BTyVar (UReft r)))      => [(Maybe Symbol, RType BTyCon BTyVar (UReft r))]@@ -786,12 +790,12 @@      -> RType BTyCon BTyVar (UReft r) bTup [(_,t)] _ r   | isTauto r  = t-  | otherwise  = t `strengthen` (reftUReft r)+  | otherwise  = t `strengthen` reftUReft r bTup ts rs r   | all Mb.isNothing (fst <$> ts) || length ts < 2   = RApp (mkBTyCon $ dummyLoc tupConName) (snd <$> ts) rs (reftUReft r)   | otherwise-  = RApp (mkBTyCon $ dummyLoc tupConName) ((top . snd) <$> ts) rs' (reftUReft r)+  = RApp (mkBTyCon $ dummyLoc tupConName) (top . snd <$> ts) rs' (reftUReft r)   where     args       = [(Mb.fromMaybe dummySymbol x, mapReft mempty t) | (x,t) <- ts]     makeProp i = RProp (take i args) ((snd <$> ts)!!i)@@ -844,6 +848,8 @@   | Impt    Symbol                                        -- ^ 'import' a specification module   | DDecl   DataDecl                                      -- ^ refined 'data'    declaration    | NTDecl  DataDecl                                      -- ^ refined 'newtype' declaration+  | Relational (LocSymbol, LocSymbol, ty, ty, RelExpr, RelExpr) -- ^ relational signature+  | AssmRel (LocSymbol, LocSymbol, ty, ty, RelExpr, RelExpr) -- ^ 'assume' relational signature   | Class   (RClass ty)                                   -- ^ refined 'class' definition   | CLaws   (RClass ty)                                   -- ^ 'class laws' definition   | ILaws   (RILaws ty)@@ -873,95 +879,96 @@   | CMeas   (Measure ty ())                               -- ^ 'class measure' definition   | IMeas   (Measure ty ctor)                             -- ^ 'instance measure' definition   | Varia   (LocSymbol, [Variance])                       -- ^ 'variance' annotations, marking type constructor params as co-, contra-, or in-variant+  | DSize   ([ty], LocSymbol)                             -- ^ 'data size' annotations, generating fancy termination metric    | BFix    ()                                            -- ^ fixity annotation   | Define  (LocSymbol, Symbol)                           -- ^ 'define' annotation for specifying aliases c.f. `include-CoreToLogic.lg`   deriving (Data, Show, Typeable) -instance (PPrint ty, PPrint ctor) => PPrint (Pspec ty ctor) where -  pprintTidy = ppPspec +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 +ppAsserts k lxs t mles   = PJ.hcat [ splice ", " (pprintTidy k <$> (val <$> lxs))-            , " :: " -            , pprintTidy k t   -            , ppLes les +            , " :: "+            , pprintTidy k t+            , ppLes mles             ]-  where +  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))) +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) +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)) +  = "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))        +ppPspec k (Alias   (Loc _ _ rta))+  = "type" <+> pprintTidy k rta+ppPspec k (EAlias  (Loc _ _ rte))+  = "predicate" <+> pprintTidy k rte+ppPspec k (Embed   (lx, tc, NoArgs))+  = "embed" <+> pprintTidy k (val lx)         <+> "as" <+> pprintTidy k tc+ppPspec k (Embed   (lx, tc, WithArgs))+  = "embed" <+> pprintTidy k (val lx) <+> "*" <+> "as" <+> pprintTidy k tc+ppPspec k (Qualif  q)+  = pprintTidy k q+ppPspec k (Decr (lx, ns))   = "decreasing" <+> pprintTidy k (val lx) <+> pprintTidy k ns-ppPspec k (LVars   lx) -  = "lazyvar" <+> pprintTidy k (val lx) -ppPspec k (Lazy   lx) -  = "lazy" <+> pprintTidy k (val lx) -ppPspec k (Rewrite   lx) -  = "rewrite" <+> pprintTidy k (val lx) -ppPspec k (Rewritewith (lx, lxs)) -  = "rewriteWith" <+> pprintTidy k (val lx) <+> (PJ.hsep $ map go lxs)+ppPspec k (LVars   lx)+  = "lazyvar" <+> pprintTidy k (val lx)+ppPspec k (Lazy   lx)+  = "lazy" <+> pprintTidy k (val lx)+ppPspec k (Rewrite   lx)+  = "rewrite" <+> pprintTidy k (val lx)+ppPspec k (Rewritewith (lx, lxs))+  = "rewriteWith" <+> pprintTidy k (val lx) <+> PJ.hsep (map go lxs)   where     go s = pprintTidy k $ val s-ppPspec k (Fail   lx) -  = "fail" <+> pprintTidy k (val lx) -ppPspec k (Insts   (lx, mbN)) -  = "automatic-instances" <+> pprintTidy k (val lx) <+> maybe "" (("with" <+>) . pprintTidy k) mbN -ppPspec k (HMeas   lx) -  = "measure" <+> pprintTidy k (val lx) -ppPspec k (Reflect lx) -  = "reflect" <+> pprintTidy k (val lx) -ppPspec k (Inline  lx) -  = "inline" <+> pprintTidy k (val lx) -ppPspec k (Ignore  lx) -  = "ignore" <+> pprintTidy k (val lx) -ppPspec k (HBound  lx) -  = "bound" <+> pprintTidy k (val lx) -ppPspec k (ASize   lx) -  = "autosize" <+> pprintTidy k (val lx) -ppPspec k (PBound  bnd) -  = pprintTidy k bnd -ppPspec _ (Pragma  (Loc _ _ s)) -  = "LIQUID" <+> PJ.text s -ppPspec k (CMeas   m) +ppPspec k (Fail   lx)+  = "fail" <+> pprintTidy k (val lx)+ppPspec k (Insts   (lx, mbN))+  = "automatic-instances" <+> pprintTidy k (val lx) <+> maybe "" (("with" <+>) . pprintTidy k) mbN+ppPspec k (HMeas   lx)+  = "measure" <+> pprintTidy k (val lx)+ppPspec k (Reflect lx)+  = "reflect" <+> pprintTidy k (val lx)+ppPspec k (Inline  lx)+  = "inline" <+> pprintTidy k (val lx)+ppPspec k (Ignore  lx)+  = "ignore" <+> pprintTidy k (val lx)+ppPspec k (HBound  lx)+  = "bound" <+> pprintTidy k (val lx)+ppPspec k (ASize   lx)+  = "autosize" <+> pprintTidy k (val lx)+ppPspec k (PBound  bnd)+  = pprintTidy k bnd+ppPspec _ (Pragma  (Loc _ _ s))+  = "LIQUID" <+> PJ.text s+ppPspec k (CMeas   m)   = "class measure" <+> pprintTidy k m-ppPspec k (IMeas   m) +ppPspec k (IMeas   m)   = "instance  measure" <+> pprintTidy k m ppPspec k (Class   cls)    = pprintTidy k cls @@ -971,12 +978,24 @@   = pprintTidy k inst  ppPspec k (Varia   (lx, vs))     = "data variance" <+> pprintTidy k (val lx) <+> splice " " (pprintTidy k <$> vs) +ppPspec k (DSize   (ds, ss))  +  = "data size" <+> splice " " (pprintTidy k <$> ds) <+> pprintTidy k (val ss)  ppPspec _ (BFix    _)           --    = "fixity"-ppPspec k (Define  (lx, y))     -  = "define" <+> pprintTidy k (val lx) <+> "=" <+> pprintTidy k y -ppPspec _ (ILaws {}) +ppPspec k (Define  (lx, y))+  = "define" <+> pprintTidy k (val lx) <+> "=" <+> pprintTidy k y+ppPspec _ ILaws{}   = "TBD-INSTANCE-LAWS"+ppPspec k (Relational (lxl, lxr, tl, tr, q, p))+  = "relational" +        <+> pprintTidy k (val lxl) <+> "::" <+> pprintTidy k tl <+> "~" +        <+> pprintTidy k (val lxr) <+> "::" <+> pprintTidy k tr <+> "|" +        <+> pprintTidy k q <+> "=>" <+> pprintTidy k p+ppPspec k (AssmRel (lxl, lxr, tl, tr, q, p))+  = "assume relational" +        <+> pprintTidy k (val lxl) <+> "::" <+> pprintTidy k tl <+> "~" +        <+> pprintTidy k (val lxr) <+> "::" <+> pprintTidy k tr <+> "|" +        <+> pprintTidy k q <+> "=>" <+> pprintTidy k p   -- | For debugging@@ -1048,7 +1067,7 @@   , Measure.localSigs  = []   , Measure.reflSigs   = []   , Measure.impSigs    = []-  , Measure.expSigs    = [] +  , Measure.expSigs    = []   , Measure.invariants = [(Nothing, t) | Invt   t <- xs]   , Measure.ialiases   = [t | Using t <- xs]   , Measure.imports    = [i | Impt   i <- xs]@@ -1066,8 +1085,11 @@   , Measure.cmeasures  = [m | CMeas  m <- xs]   , Measure.imeasures  = [m | IMeas  m <- xs]   , Measure.classes    = [c | Class  c <- xs]+  , Measure.relational = [r | Relational r <- xs]+  , Measure.asmRel     = [r | AssmRel r <- xs]   , Measure.claws      = [c | CLaws  c <- xs]   , Measure.dvariance  = [v | Varia  v <- xs]+  , Measure.dsize      = [v | DSize  v <- xs]   , Measure.rinstance  = [i | RInst  i <- xs]   , Measure.ilaws      = [i | ILaws  i <- xs]   , Measure.termexprs  = [(y, es) | Asrts (ys, (_, Just es)) <- xs, y <- ys]@@ -1089,65 +1111,68 @@ -- | Parse a single top level liquid specification specP :: Parser BPspec specP-  =     (fallbackSpecP "assume"     (liftM Assm    tyBindP  ))-    <|> (fallbackSpecP "assert"     (liftM Asrt    tyBindP  ))-    <|> (fallbackSpecP "autosize"   (liftM ASize   asizeP   ))-    <|> (reserved "local"         >> liftM LAsrt   tyBindP  )+  =     fallbackSpecP "assume"      +    ((reserved "relational" >>  fmap AssmRel relationalP)+        <|>                           fmap Assm   tyBindP  )+    <|> fallbackSpecP "assert"      (fmap Asrt    tyBindP  )+    <|> fallbackSpecP "autosize"    (fmap ASize   asizeP   )+    <|> (reserved "local"         >> fmap LAsrt   tyBindP  )      -- TODO: These next two are synonyms, kill one-    <|> (fallbackSpecP "axiomatize" (liftM Reflect axiomP   ))-    <|> (fallbackSpecP "reflect"    (liftM Reflect axiomP   ))+    <|> fallbackSpecP "axiomatize"  (fmap Reflect axiomP   )+    <|> fallbackSpecP "reflect"     (fmap Reflect axiomP   ) -    <|> (fallbackSpecP "measure"    hmeasureP)+    <|> fallbackSpecP "measure"    hmeasureP -    <|> (fallbackSpecP "define"     (liftM Define  defineP  ))-    <|> (reserved "infixl"        >> liftM BFix    infixlP  )-    <|> (reserved "infixr"        >> liftM BFix    infixrP  )-    <|> (reserved "infix"         >> liftM BFix    infixP   )-    <|> (fallbackSpecP "inline"     (liftM Inline  inlineP  ))-    <|> (fallbackSpecP "ignore"     (liftM Ignore  inlineP  ))+    <|> fallbackSpecP "define"      (fmap Define  defineP  )+    <|> (reserved "infixl"        >> fmap BFix    infixlP  )+    <|> (reserved "infixr"        >> fmap BFix    infixrP  )+    <|> (reserved "infix"         >> fmap BFix    infixP   )+    <|> fallbackSpecP "inline"      (fmap Inline  inlineP  )+    <|> fallbackSpecP "ignore"      (fmap Ignore  inlineP  ) -    <|> (fallbackSpecP "bound"    (((liftM PBound  boundP   )-                                <|> (liftM HBound  hboundP  ))))+    <|> fallbackSpecP "bound"       (fmap PBound  boundP+                                 <|> fmap HBound  hboundP  )     <|> (reserved "class"-         >> ((reserved "measure"  >> liftM CMeas  cMeasureP )-         <|> (reserved "laws"     >> liftM CLaws  classP)-         <|> liftM Class  classP                            ))+         >> ((reserved "measure"  >> fmap CMeas  cMeasureP )+         <|> (reserved "laws"     >> fmap CLaws  classP)+         <|> fmap Class  classP                            ))     <|> (reserved "instance"-         >> ((reserved "measure"  >> liftM IMeas  iMeasureP )-         <|> (reserved "laws"     >> liftM ILaws instanceLawP)-         <|> liftM RInst  instanceP ))+         >> ((reserved "measure"  >> fmap IMeas  iMeasureP )+         <|> (reserved "laws"     >> fmap ILaws instanceLawP)+         <|> fmap RInst  instanceP )) -    <|> (reserved "import"        >> liftM Impt   symbolP   )+    <|> (reserved "import"        >> fmap Impt   symbolP   )      <|> (reserved "data"-        >> ((reserved "variance"  >> liftM Varia  datavarianceP)-                                 <|> liftM DDecl  dataDeclP ))--    <|> (reserved "newtype"       >> liftM NTDecl dataDeclP )-    <|> (reserved "include"       >> liftM Incl   filePathP )-    <|> (fallbackSpecP "invariant"  (liftM Invt   invariantP))-    <|> (reserved "using"         >> liftM Using invaliasP )-    <|> (reserved "type"          >> liftM Alias  aliasP    )+        >> ((reserved "variance"  >> fmap Varia  datavarianceP)+        <|> (reserved "size"      >> fmap DSize  dsizeP)+        <|> fmap DDecl  dataDeclP ))+    <|> (reserved "newtype"       >> fmap NTDecl dataDeclP )+    <|> (reserved "relational"    >> fmap Relational relationalP )+    <|> (reserved "include"       >> fmap Incl   filePathP )+    <|> fallbackSpecP "invariant"   (fmap Invt   invariantP)+    <|> (reserved "using"          >> fmap Using invaliasP )+    <|> (reserved "type"          >> fmap Alias  aliasP    )      -- TODO: Next two are basically synonyms-    <|> (fallbackSpecP "predicate"  (liftM EAlias ealiasP   ))-    <|> (fallbackSpecP "expression" (liftM EAlias ealiasP   ))+    <|> fallbackSpecP "predicate"   (fmap EAlias ealiasP   )+    <|> fallbackSpecP "expression"  (fmap EAlias ealiasP   ) -    <|> (fallbackSpecP "embed"      (liftM Embed  embedP    ))-    <|> (fallbackSpecP "qualif"     (liftM Qualif (qualifierP sortP)))-    <|> (reserved "decrease"      >> liftM Decr   decreaseP )-    <|> (reserved "lazyvar"       >> liftM LVars  lazyVarP  )+    <|> fallbackSpecP "embed"       (fmap Embed  embedP    )+    <|> fallbackSpecP "qualif"      (fmap Qualif (qualifierP sortP))+    <|> (reserved "decrease"      >> fmap Decr   decreaseP )+    <|> (reserved "lazyvar"       >> fmap LVars  lazyVarP  ) -    <|> (reserved "lazy"          >> liftM Lazy   lazyVarP  )-    <|> (reserved "rewrite"       >> liftM Rewrite   rewriteVarP )-    <|> (reserved "rewriteWith"   >> liftM Rewritewith   rewriteWithP )-    <|> (reserved "fail"          >> liftM Fail   failVarP  )-    <|> (reserved "ple"           >> liftM Insts autoinstP  )-    <|> (reserved "automatic-instances" >> liftM Insts autoinstP  )-    <|> (reserved "LIQUID"        >> liftM Pragma pragmaP   )-    <|> (reserved "liquid"        >> liftM Pragma pragmaP   )-    <|> {- DEFAULT -}                liftM Asrts  tyBindsP+    <|> (reserved "lazy"          >> fmap Lazy   lazyVarP  )+    <|> (reserved "rewrite"       >> fmap Rewrite   rewriteVarP )+    <|> (reserved "rewriteWith"   >> fmap Rewritewith   rewriteWithP )+    <|> (reserved "fail"          >> fmap Fail   failVarP  )+    <|> (reserved "ple"           >> fmap Insts autoinstP  )+    <|> (reserved "automatic-instances" >> fmap Insts autoinstP  )+    <|> (reserved "LIQUID"        >> fmap Pragma pragmaP   )+    <|> (reserved "liquid"        >> fmap Pragma pragmaP   )+    <|> {- DEFAULT -}                fmap Asrts  tyBindsP     <?> "specP"  -- | Try the given parser on the tail after matching the reserved word, and if@@ -1156,7 +1181,7 @@ fallbackSpecP :: String -> Parser BPspec -> Parser BPspec fallbackSpecP kw p = do   (Loc l1 l2 _) <- locReserved kw-  (p <|> liftM Asrts (tyBindsRemP (Loc l1 l2 (symbol kw)) ))+  p <|> fmap Asrts (tyBindsRemP (Loc l1 l2 (symbol kw)) )  -- | Same as tyBindsP, except the single initial symbol has already been matched tyBindsRemP :: LocSymbol -> Parser ([LocSymbol], (Located BareType, Maybe [Located Expr]))@@ -1215,6 +1240,10 @@ datavarianceP :: Parser (Located Symbol, [Variance]) datavarianceP = liftM2 (,) locUpperIdP (many varianceP) +dsizeP :: Parser ([Located BareType], Located Symbol)+dsizeP = liftM2 (,) (parens $ sepBy (located genBareTypeP) comma) locBinderP++ varianceP :: Parser Variance varianceP = (reserved "bivariant"     >> return Bivariant)         <|> (reserved "invariant"     >> return Invariant)@@ -1237,8 +1266,7 @@ termBareTypeP :: Parser (Located BareType, Maybe [Located Expr]) termBareTypeP = do   t <- located genBareTypeP-  (termTypeP t-    <|> return (t, Nothing))+  termTypeP t <|> return (t, Nothing)  termTypeP :: Located BareType ->Parser (Located BareType, Maybe [Located Expr]) termTypeP t@@ -1296,18 +1324,17 @@ hmeasureP = do   setLayout   b <- locBinderP-  ((do reservedOp "::"-       ty <- located genBareTypeP-       popLayout >> popLayout-       eqns <- block $ try $ measureDefP (rawBodyP <|> tyBodyP ty)-       return (Meas $ Measure.mkM b ty eqns MsMeasure mempty))+  (do reservedOp "::"+      ty <- located genBareTypeP+      popLayout >> popLayout+      eqns <- block $ try $ measureDefP (rawBodyP <|> tyBodyP ty)+      return (Meas $ Measure.mkM b ty eqns MsMeasure mempty))     <|> (popLayout >> popLayout >> return (HMeas b))-    )  measureP :: Parser (Measure (Located BareType) LocSymbol) measureP = do   (x, ty) <- indentedLine tyBindP-  optional semi+  _ <- optional semi   eqns    <- block $ measureDefP (rawBodyP <|> tyBodyP ty)   return   $ Measure.mkM x ty eqns MsMeasure mempty @@ -1330,6 +1357,11 @@                <|> ((:) <$> (fmap bTyVar <$> locLowerIdP) <*> classParams)     sing x      = [x] ++superP :: Parser (Located BareType)+superP = located (toRCls <$> bareAtomBindP)+  where toRCls x = x+ instanceLawP :: Parser (RILaws (Located BareType)) instanceLawP   = do l1   <- getSourcePos@@ -1340,11 +1372,9 @@        l2   <- getSourcePos        return $ RIL c sups tvs ms (Loc l1 l2 ())   where-    superP   = located (toRCls <$> bareAtomBindP)-    supersP  = try (((parens (superP `sepBy1` comma)) <|> fmap pure superP)+    supersP  = try ((parens (superP `sepBy1` comma) <|> fmap pure superP)                        <* reservedOp "=>")                <|> return []-    toRCls x = x      eqBinderP = xyP xP (reservedOp "=") xP @@ -1354,18 +1384,16 @@ instanceP   = do _    <- supersP        c    <- classBTyConP-       tvs  <- (try oneClassArg) <|> (manyTill iargsP (try $ reserved "where"))+       tvs  <- try oneClassArg <|> manyTill iargsP (try $ reserved "where")        ms   <- block riMethodSigP        return $ RI c tvs ms   where-    superP   = located (toRCls <$> bareAtomBindP)-    supersP  = try (((parens (superP `sepBy1` comma)) <|> fmap pure superP)+    supersP  = try ((parens (superP `sepBy1` comma) <|> fmap pure superP)                        <* reservedOp "=>")                <|> return []-    toRCls x = x      iargsP   =   (mkVar . bTyVar <$> tyVarIdP)-            <|> (parens $ located $ bareTypeP)+            <|> parens (located bareTypeP)       mkVar v  = dummyLoc $ RVar v mempty@@ -1388,19 +1416,16 @@        ms   <- block tyBindP -- <|> sepBy tyBindP semi        return $ RClass c sups tvs ms   where-    superP   = located (toRCls <$> bareAtomBindP)-    supersP  = try (((parens (superP `sepBy1` comma)) <|> fmap pure superP)+    supersP  = try ((parens (superP `sepBy1` comma) <|> fmap pure superP)                        <* reservedOp "=>")                <|> return []-    toRCls x = x  rawBodyP :: Parser Body rawBodyP   = braces $ do       v <- symbolP       reservedOp "|"-      p <- predP-      return $ R v p+      R v <$> predP  tyBodyP :: Located BareType -> Parser Body tyBodyP ty@@ -1437,7 +1462,7 @@ -} binderP :: Parser Symbol binderP =-      (symbol . (\ x -> "(" <> x <> ")") . symbolText) <$> parens (infixBinderIdP)+      symbol . (\ x -> "(" <> x <> ")") . symbolText <$> parens infixBinderIdP   <|> binderIdP   -- Note: It is important that we do *not* use the LH/fixpoint reserved words here,   -- because, for example, we must be able to use "assert" as an identifier.@@ -1451,7 +1476,7 @@        (c, xs) <- measurePatP        reservedOp "="        body    <- bodyP-       let xs'  = (symbol . val) <$> xs+       let xs'  = symbol . val <$> xs        return   $ Def mname (symbol <$> c) Nothing ((, Nothing) <$> xs') body  measurePatP :: Parser (LocSymbol, [LocSymbol])@@ -1530,9 +1555,9 @@   return $ DataCtor x (tRepVars as tr) [] (tRepFields tr) (Just $ ty_res tr)  tRepVars :: Symbolic a => [Symbol] -> RTypeRep c a r -> [Symbol]-tRepVars as tr = case fst <$> ty_vars tr of -  [] -> as -  vs -> symbol . ty_var_value <$> vs +tRepVars as tr = case fst <$> ty_vars tr of+  [] -> as+  vs -> symbol . ty_var_value <$> vs  tRepFields :: RTypeRep c tv r -> [(Symbol, RType c tv r)] tRepFields tr = zip (ty_binds tr) (ty_args tr)@@ -1555,12 +1580,27 @@   = brackets (Just . SymSizeFun <$> locLowerIdP)   <|> return Nothing +relationalP :: Parser (LocSymbol, LocSymbol, LocBareType, LocBareType, RelExpr, RelExpr)+relationalP = do +   x <- locBinderP+   reserved "~"+   y <- locBinderP+   reserved "::"+   braces $ do +    tx <- located genBareTypeP+    reserved "~"+    ty <- located genBareTypeP+    reserved "|"+    assm <- try (relrefaP <* reserved "|-") <|> return (ERBasic PTrue)+    ex <- relrefaP+    return (x,y,tx,ty,assm,ex)+ dataDeclP :: Parser DataDecl dataDeclP = do   pos <- getSourcePos   x   <- locUpperOrInfixIdP   fsize <- dataSizeP-  (dataDeclBodyP pos x fsize <|> return (emptyDecl x pos fsize))+  dataDeclBodyP pos x fsize <|> return (emptyDecl x pos fsize)  emptyDecl :: LocSymbol -> SourcePos -> Maybe SizeFun -> DataDecl emptyDecl x pos fsize@(Just _)@@ -1596,7 +1636,7 @@ dataCtorsP as = do   (pTy, dcs) <-     (reservedOp "="     >> ((Nothing, ) <$>                 sepBy (dataConP    as) (reservedOp "|")))                 <|> (reserved   "where" >> ((Nothing, ) <$>                 block (adtDataConP as)                 ))-                <|> (                      ((,)         <$> dataPropTyP <*> block (adtDataConP as)                 ))+                <|>                        ((,)         <$> dataPropTyP <*> block (adtDataConP as)                  )   return (pTy, Misc.sortOn (val . dcName) dcs)  noWhere :: Parser Symbol
src/Language/Haskell/Liquid/Synthesize.hs view
@@ -8,7 +8,7 @@  import           Language.Haskell.Liquid.Types import           Language.Haskell.Liquid.Constraint.Types-import           Language.Haskell.Liquid.Constraint.Generate +import           Language.Haskell.Liquid.Constraint.Generate import qualified Language.Haskell.Liquid.Types.RefType as R import           Language.Haskell.Liquid.Synthesize.Termination import           Language.Haskell.Liquid.Synthesize.Generate@@ -18,22 +18,22 @@ import           Language.Haskell.Liquid.Constraint.Fresh (trueTy) import qualified Language.Fixpoint.Smt.Interface as SMT import           Language.Fixpoint.Types hiding (SEnv, SVar, Error)-import qualified Language.Fixpoint.Types        as F +import qualified Language.Fixpoint.Types        as F import qualified Language.Fixpoint.Types.Config as F import           Language.Haskell.Liquid.Synthesize.Env-import           Language.Haskell.Liquid.GHC.API as GHC hiding (text, ($+$))+import           Liquid.GHC.API as GHC hiding (text, ($+$))  import           Text.PrettyPrint.HughesPJ (text, ($+$)) import           Control.Monad.State.Lazy-import qualified Data.HashMap.Strict as M +import qualified Data.HashMap.Strict as M import           Data.Maybe  synthesize :: FilePath -> F.Config -> CGInfo -> IO [Error]-synthesize tgt fcfg cginfo = +synthesize tgt fcfg cginfo =   mapM go (M.toList $ holesMap cginfo)-  where +  where     measures = map (val . msName) ((gsMeasures . gsData . giSpec . ghcI) cginfo)-    go (x, HoleInfo _ loc env (cgi,cge)) = do +    go (x, HoleInfo _ loc env (cgi,cge)) = do       let topLvlBndr = fromMaybe (error "Top-level binder not found") (cgVar cge)           typeOfTopLvlBnd = fromMaybe (error "Type: Top-level symbol not found") (M.lookup (symbol topLvlBndr) (reGlobal env))           coreProgram = giCbs $ giSrc $ ghcI cgi@@ -48,7 +48,7 @@            ssenv0 = symbolToVar coreProgram topLvlBndr fromREnv           (senv1, foralls') = initSSEnv typeOfTopLvlBnd cginfo ssenv0-      +       ctx <- SMT.makeContext fcfg tgt       state0 <- initState ctx fcfg cgi cge env topLvlBndr (reverse uniVars) M.empty       let foralls = foralls' ++ fs@@ -57,20 +57,20 @@       return $ ErrHole loc (         if not (null fills)           then text "\n Hole Fills:" $+$ pprintMany (map (coreToHs typeOfTopLvlBnd topLvlBndr . fromAnf) fills)-          else mempty) mempty (symbol x) typeOfTopLvlBnd +          else mempty) mempty (symbol x) typeOfTopLvlBnd   synthesize' :: SMT.Context -> CGInfo -> SSEnv -> SpecType ->  Var -> SpecType -> [Var] -> SState -> IO [CoreExpr]-synthesize' ctx cgi senv tx xtop ttop foralls st2- = evalSM (go tx) ctx senv st2-  where +synthesize' ctx cgi ssenv tx xtop ttop foralls st2+ = evalSM (go tx) ctx ssenv st2+  where      go :: SpecType -> SM [CoreExpr]      -- Type Abstraction      go (RAllT a t _x)      = GHC.Lam (tyVarVar a) <$$> go t-          -    go t@(RApp c _ts _ _r) = do  ++    go t@(RApp c _ts _ _r) = do       let coreProgram = giCbs $ giSrc $ ghcI cgi           args  = drop 1 (argsP coreProgram xtop)           (_, (xs, _, txs, _), _) = bkArrow ttop@@ -82,7 +82,7 @@                   if null ts  then modify (\s -> s { sUGoalTy = Nothing } )                               else modify (\s -> s { sUGoalTy = Just ts } )                   modify (\s -> s {sForalls = (foralls, [])})-                  emem0 <- insEMem0 senv+                  emem0 <- insEMem0 ssenv                   modify (\s -> s { sExprMem = emem0 })                   synthesizeBasic t @@ -90,28 +90,28 @@      go (RRTy _env _ref _obl t) = go t -    go t@RFun{} +    go t@RFun{}          = do ys <- mapM freshVar txs-              let su = F.mkSubst $ zip xs (EVar . symbol <$> ys) -              mapM_ (uncurry addEnv) (zip ys ((subst su)<$> txs)) +              let su = F.mkSubst $ zip xs (EVar . symbol <$> ys)+              mapM_ (uncurry addEnv) (zip ys (subst su<$> txs))               let dt = decrType xtop ttop ys (zip xs txs)-              addEnv xtop dt -              mapM_ (uncurry addEmem) (zip ys (subst su <$> txs)) +              addEnv xtop dt+              mapM_ (uncurry addEmem) (zip ys (subst su <$> txs))               addEmem xtop dt               senv1 <- getSEnv-              let goalType = subst su to-                  hsGoalTy = toType False goalType +              let goalType' = subst su to+                  hsGoalTy = toType False goalType'                   ts = unifyWith hsGoalTy               if null ts  then modify (\s -> s { sUGoalTy = Nothing } )                           else modify (\s -> s { sUGoalTy = Just ts } )               modify (\s -> s { sForalls = (foralls, []) } )               emem0 <- insEMem0 senv1               modify (\s -> s { sExprMem = emem0 })-              mapM_ (\y -> addDecrTerm y []) ys+              mapM_ (`addDecrTerm` []) ys               scruts <- synthesizeScrut ys               modify (\s -> s { scrutinees = scruts })-              GHC.mkLams ys <$$> synthesizeBasic goalType-      where (_, (xs, _,txs, _), to) = bkArrow t +              GHC.mkLams ys <$$> synthesizeBasic goalType'+      where (_, (xs, _,txs, _), to) = bkArrow t      go t = error (" Unmatched t = " ++ show t) @@ -129,12 +129,12 @@ synthesizeMatch :: SpecType -> SM [CoreExpr] synthesizeMatch t = do   scruts <- scrutinees <$> get-  i <- incrCase +  i <- incrCase   case safeIxScruts i scruts of-    Nothing ->  return []-    Just id ->  if null scruts+    Nothing  ->  return []+    Just id' ->  if null scruts                   then return []-                  else withIncrDepth (matchOnExpr t (scruts !! id))+                  else withIncrDepth (matchOnExpr t (scruts !! id'))  synthesizeScrut :: [Var] -> SM [(CoreExpr, Type, TyCon)] synthesizeScrut vs = do@@ -142,17 +142,17 @@   let exprs' = map (\e -> (exprType e, e)) exprs       isDataCon v = case varType v of { TyConApp c _ -> not . isClassTyCon $ c; _ -> False }       vs0 = filter isDataCon vs-      es0 = map GHC.Var vs0 +      es0 = map GHC.Var vs0       es1 = map (\e -> (exprType e, e)) es0       es2 = [(e, t, c) | (t@(TyConApp c _), e) <- es1]   return (es2 ++ [(e, t, c) | (t@(TyConApp c _), e) <- exprs'])  matchOnExpr :: SpecType -> (CoreExpr, Type, TyCon) -> SM [CoreExpr]-matchOnExpr t (GHC.Var v, tx, c) +matchOnExpr t (GHC.Var v, tx, c)   = matchOn t (v, tx, c) matchOnExpr t (e, tx, c)   = do  freshV <- freshVarType tx-        freshSpecTy <- liftCG $ (trueTy False) tx+        freshSpecTy <- liftCG $ trueTy False tx         -- use consE         addEnv freshV freshSpecTy         es <- matchOn t (freshV, tx, c)@@ -164,17 +164,17 @@   makeAlt :: SpecType -> (Var, Type) -> DataCon -> SM [GHC.CoreAlt]-makeAlt t (x, TyConApp _ ts) c = locally $ do+makeAlt t (x, TyConApp _ kts) c = locally $ do   ts <- liftCG $ mapM (trueTy False) τs-  xs <- mapM freshVar ts    +  xs <- mapM freshVar ts   newScruts <- synthesizeScrut xs   modify (\s -> s { scrutinees = scrutinees s ++ newScruts } )-  addsEnv $ zip xs ts -  addsEmem $ zip xs ts +  addsEnv $ zip xs ts+  addsEmem $ zip xs ts   addDecrTerm x xs   liftCG0 (\γ -> caseEnv γ x mempty (GHC.DataAlt c) xs Nothing)   es <- synthesizeBasic t   return $ (GHC.DataAlt c, xs, ) <$> es-  where -    (_, _, τs) = dataConInstSig c ts+  where+    (_, _, τs) = dataConInstSig c kts makeAlt _ _ _ = error "makeAlt.bad argument "
src/Language/Haskell/Liquid/Synthesize/Check.hs view
@@ -1,6 +1,8 @@-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE BangPatterns #-}++{-# OPTIONS_GHC -Wno-name-shadowing #-}+ module Language.Haskell.Liquid.Synthesize.Check (check, hasType, isWellTyped, checkError) where  @@ -19,11 +21,11 @@ import           Language.Haskell.Liquid.Constraint.ToFixpoint import           Language.Haskell.Liquid.Synthesize.Monad import           Language.Haskell.Liquid.Synthesize.GHC-import           Language.Haskell.Liquid.GHC.API as Ghc+import           Liquid.GHC.API as Ghc import           Language.Haskell.Liquid.Misc   ( mapThd3 ) import           Control.Monad.State.Lazy import           System.Console.CmdArgs.Verbosity-import           Language.Haskell.Liquid.GHC.TypeRep+import           Liquid.GHC.TypeRep import           Language.Haskell.Liquid.Types  hasType :: SpecType -> CoreExpr -> SM Bool
src/Language/Haskell/Liquid/Synthesize/Env.hs view
@@ -1,7 +1,9 @@+{-# OPTIONS_GHC -Wno-name-shadowing #-}+ module Language.Haskell.Liquid.Synthesize.Env where   import           Language.Fixpoint.Types-import           Language.Haskell.Liquid.GHC.API as GHC+import           Liquid.GHC.API as GHC import           Language.Haskell.Liquid.Constraint.Types import           Language.Haskell.Liquid.Types import           Language.Haskell.Liquid.Synthesize.Monad
src/Language/Haskell/Liquid/Synthesize/GHC.hs view
@@ -1,15 +1,17 @@-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE CPP #-}++{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+ module Language.Haskell.Liquid.Synthesize.GHC where  import qualified Language.Fixpoint.Types       as F import           Language.Haskell.Liquid.Types import           Data.Default import           Data.Maybe                     ( fromMaybe )-import           Language.Haskell.Liquid.GHC.TypeRep-import           Language.Haskell.Liquid.GHC.API as GHC+import           Liquid.GHC.TypeRep+import           Liquid.GHC.API as GHC import           Language.Fixpoint.Types import qualified Data.HashMap.Strict           as M @@ -17,16 +19,16 @@ import           Data.List.Split  instance Default Type where-    def = TyVarTy alphaTyVar +    def = TyVarTy alphaTyVar  mkVar :: Maybe String -> Int -> Type -> Var-mkVar x i t = mkGlobalVar VanillaId name t vanillaIdInfo -  where +mkVar x i t = mkGlobalVar VanillaId name t vanillaIdInfo+  where     name = mkSystemName (mkUnique 'S' i) (mkVarOcc x')-    x'   = fromMaybe (freshName i) x +    x'   = fromMaybe (freshName i) x -freshName :: Int -> String -freshName i = "lSyn$" ++ show i +freshName :: Int -> String+freshName i = "lSyn$" ++ show i  -- | Assuming that the functions are instantiated when this function is called. goalType ::  Type ->   --  This is the goal type. It is used for basic types.@@ -48,8 +50,8 @@  subgoals :: Type ->               -- Given a function type,             Maybe (Type, [Type])  -- separate the result type from the input types.-subgoals t = if null gTys then Nothing else Just (resTy, inpTys) -  where gTys            = createSubgoals t +subgoals t = if null gTys then Nothing else Just (resTy, inpTys)+  where gTys            = createSubgoals t         (resTy, inpTys) = (last gTys, take (length gTys - 1) gTys)  @@ -57,18 +59,18 @@ -- returns all expressions in @ExprMemory@ that have the same type. withSubgoal :: [(Type, CoreExpr, Int)] -> Type -> [(CoreExpr, Int)] withSubgoal []                  _ = []-withSubgoal ((t, e, i) : exprs) τ = -  if τ == t +withSubgoal ((t, e, i) : exprs) τ =+  if τ == t     then (e, i) : withSubgoal exprs τ     else withSubgoal exprs τ  -- | Assuming that goals are type variables or constructors. --    Note: We maintain ordering from the goal type. --    Not handled (compared to @varsInType): function types, type applications-unifyWith :: Type -> [Type] -unifyWith v@(TyVarTy _)   = [v] -unifyWith (TyConApp _ ts) = ts -unifyWith t               = error $ " [ unifyWith ] " ++ showTy t +unifyWith :: Type -> [Type]+unifyWith v@(TyVarTy _)   = [v]+unifyWith (TyConApp _ ts) = ts+unifyWith t               = error $ " [ unifyWith ] " ++ showTy t  fromAnf :: CoreExpr -> CoreExpr fromAnf e = fst $ fromAnf' e []@@ -84,17 +86,17 @@   = case bnd of Rec {}       -> error " By construction, no recursive bindings in let expression. "                 NonRec rb lb -> let (lb', bnds') = fromAnf' lb bnds                                 in  fromAnf' e ((rb, lb') : bnds')-fromAnf' (Var var) bnds +fromAnf' (Var var) bnds   = (fromMaybe (Var var) (lookup var bnds), bnds) fromAnf' (Case scr bnd tp alts) bnds   = (Case scr bnd tp (map (\(altc, xs, e) -> (altc, xs, fst $ fromAnf' e bnds)) alts), bnds) fromAnf' (App e1 e2) bnds-  = let (e1', bnds')  = fromAnf' e1 bnds +  = let (e1', bnds')  = fromAnf' e1 bnds         (e2', bnds'') = fromAnf' e2 bnds'     in  (App e1' e2', bnds'')-fromAnf' t@Type{} bnds +fromAnf' t@Type{} bnds   = (t, bnds)-fromAnf' l@Lit{} bnds +fromAnf' l@Lit{} bnds   = (l, bnds) fromAnf' _ _   = error " Should not reach this point. "@@ -112,8 +114,8 @@ pprintSymbols txt = foldr (\x xs -> pprintSym symbols x ++ xs) [] txt  pprintSym :: String -> Char -> String-pprintSym symbols s -  = case find (== s) symbols of +pprintSym symbols s+  = case find (== s) symbols of       Nothing -> [s]       Just s' -> ['(', s', ')'] @@ -121,33 +123,31 @@ discardModName v = last (splitOn "." (show v))  rmModName :: String -> String-rmModName s = +rmModName s =   let ts = splitOn "." s   in  maintainLParen ts ++ last ts ++ maintainRParen ts  maintainLParen :: [String] -> String-maintainLParen ts +maintainLParen ts   = if length ts > 1 && head (head ts) == '('       then  "("       else  ""  maintainRParen :: [String] -> String-maintainRParen ts +maintainRParen ts   = if last (last ts) == '('       then  ")"       else  ""  pprintFormals :: Int -> Var -> CoreExpr -> Int -> [Var] -> String pprintFormals i v (Lam b e) cnt vs-  = if isTyVar b-      then pprintFormals i v e cnt vs-      else  if cnt > 0 -              then  pprintFormals i v e (cnt - 1) (b:vs)-              else  " " ++ show b ++ pprintFormals i v e cnt vs+  | isTyVar b = pprintFormals i v e cnt vs+  | cnt > 0 = pprintFormals i v e (cnt - 1) (b:vs)+  | otherwise = " " ++ show b ++ pprintFormals i v e cnt vs pprintFormals i _ e _ vs   = " =" ++ pprintBody vs i e -caseIndent :: Int +caseIndent :: Int caseIndent = 4  indent :: Int -> String@@ -156,22 +156,22 @@ errorExprPp :: CoreExpr -> Bool errorExprPp (GHC.App (GHC.App err@(GHC.Var _) (GHC.Type _)) _)   = show err == "Language.Haskell.Liquid.Synthesize.Error.err"-errorExprPp _ +errorExprPp _   = False -pprintVar :: Var -> String +pprintVar :: Var -> String pprintVar v = if isTyVar v then "" else " " ++ discardModName v  pprintBody :: [Var] -> Int -> CoreExpr -> String-pprintBody vs i (Lam b e) +pprintBody vs i (Lam b e)   = pprintFormals i b e 0 vs pprintBody vs _ (Var v)-  = case find (== v) vs of +  = case find (== v) vs of       Nothing -> pprintVar v       Just _  -> "" pprintBody vs _ e@App{}   = let pprintApp = fixApplication (show e)-        noTcVars  = filter (\x -> case find (== x) (map show vs) of +        noTcVars  = filter (\x -> case find (== x) (map show vs) of                                     Nothing -> True                                     Just _  -> False) (words pprintApp)     in  if errorExprPp e@@ -180,16 +180,16 @@ pprintBody _ _ l@Lit{}   = " " ++ show l pprintBody vs i (Case scr _ _ alts)-  = "\n" ++ indent i ++ -    "case" ++ pprintBody vs i scr ++ " of\n" ++ -    concatMap (pprintAlts vs (i + caseIndent)) alts -pprintBody _ _ Type{} +  = "\n" ++ indent i +++    "case" ++ pprintBody vs i scr ++ " of\n" +++    concatMap (pprintAlts vs (i + caseIndent)) alts+pprintBody _ _ Type{}   = "" pprintBody _ _ e   = error (" Not yet implemented for e = " ++ show e)  fixApplication :: String -> String-fixApplication e = +fixApplication e =   let ws' = words (replaceNewLine e)       ws = handleCommas ws'       cleanWs = rmTypeAppl ws@@ -213,56 +213,56 @@ fixParen :: [String] -> [String] fixParen [] = [] fixParen [x] = [x]-fixParen (x:y:xs) +fixParen (x:y:xs)   = if replicate (length y) ')' == y-      then  let w0 = x ++ y -                w = if head w0 == '(' && last w0 == ')' -                      then tail (init w0) +      then  let w0 = x ++ y+                w = if head w0 == '(' && last w0 == ')'+                      then tail (init w0)                       else w0             in  w : fixParen xs       else x : fixParen (y:xs)  rmTypeAppl :: [String] -> [String]-rmTypeAppl [] +rmTypeAppl []   = []-rmTypeAppl (c:cs) +rmTypeAppl (c:cs)   = if c == "@"-      then  case cs of +      then  case cs of               [] -> error " Type application: Badly formatted string. "-              (c': cs') -> +              (c': cs') ->                 let p = paren c'                 in  if null p then rmTypeAppl cs' else p : rmTypeAppl cs'       else c:rmTypeAppl cs -paren :: String -> String -paren [] +paren :: String -> String+paren []   = []-paren (c:cs) +paren (c:cs)   = if c == ')' then c : paren cs else paren cs  replaceNewLine :: String -> String-replaceNewLine [] +replaceNewLine []   = []-replaceNewLine (c:cs) -  = if c == '\n' -      then ' ' : replaceNewLine cs +replaceNewLine (c:cs)+  = if c == '\n'+      then ' ' : replaceNewLine cs       else c : replaceNewLine cs  pprintAlts :: [Var] -> Int -> Alt Var -> String pprintAlts vars i (DataAlt dataCon, vs, e)-  = indent i ++ show dataCon ++ concatMap (\v -> " " ++ show v) vs ++ " ->" ++ +  = indent i ++ show dataCon ++ concatMap (\v -> " " ++ show v) vs ++ " ->" ++     pprintBody vars (i+caseIndent) e ++ "\n" pprintAlts _ _ _   = error " Pretty printing for pattern match on datatypes. "  -- TODO Remove variables generated for type class constraints countTcConstraints :: SpecType -> Int-countTcConstraints t = +countTcConstraints t =   let ws = words (show t)        countCommas :: [String] -> Int       countCommas []     = 0-      countCommas (x:xs) = +      countCommas (x:xs) =         case find (== ',') x of           Nothing -> countCommas xs           Just _  -> 1 + countCommas xs@@ -270,9 +270,9 @@   in  case find (== "=>") ws of         Nothing -> 0         Just _  -> 1 + countCommas (takeWhile (/= "=>") ws)-    + ----------------------------------------------------------------------------------- --  |                          Prune trivial expressions                       | -- -----------------------------------------------------------------------------------@@ -281,7 +281,7 @@ nonTrivial _                        = True  nonTrivials :: [GHC.CoreExpr] -> Bool-nonTrivials = foldr (\x b -> nonTrivial x || b) False +nonTrivials = foldr (\x b -> nonTrivial x || b) False  trivial :: GHC.CoreExpr -> Bool trivial (GHC.App (GHC.Var _) (GHC.Type _)) = True -- Is this a nullary constructor?@@ -291,7 +291,7 @@ hasTrivial es = foldr (\x b -> trivial x || b) False es  allTrivial :: [[GHC.CoreExpr]] -> Bool-allTrivial es = foldr (\x b -> hasTrivial x && b) True es +allTrivial es = foldr (\x b -> hasTrivial x && b) True es  rmTrivials :: [(GHC.CoreExpr, Int)] -> [(GHC.CoreExpr, Int)] rmTrivials = filter (not . trivial . fst)@@ -305,10 +305,10 @@ isVar _           = False  returnsTuple :: Var -> Bool-returnsTuple v = +returnsTuple v =   case subgoals (varType v) of     Nothing      -> False-    Just (t, _) -> +    Just (t, _) ->       case t of         TyConApp c _ts -> c == pairTyCon         _              -> False@@ -320,7 +320,7 @@ type SSEnv = M.HashMap Symbol (SpecType, Var)  filterREnv :: M.HashMap Symbol SpecType -> M.HashMap Symbol SpecType-filterREnv renv = +filterREnv renv =   let renv_lst  = M.toList renv       renv_lst' = filter (\(_, specT) ->  let ht = toType False specT                                           in  showTy ht /= "(RApp   GHC.Prim.Addr# )") renv_lst@@ -332,19 +332,19 @@  -- | That' s a hack to get the type variables we need for instantiation. getUniVars :: GHC.CoreProgram -> Var -> ([Var], [Var])-getUniVars cp tlVar = -  case filter (`isInCB` tlVar) cp of +getUniVars cp tlVar =+  case filter (`isInCB` tlVar) cp of     [cb] -> getUniVars0 (getBody cb tlVar) ([], [])     _    -> error " Every top-level corebind must be unique! "  getUniVars0 :: GHC.CoreExpr -> ([Var], [Var]) -> ([Var], [Var]) getUniVars0 (Lam b e) (uvs, tcDicts)-  = case varType b of -      TyConApp c _ -> -        if isClassTyCon c +  = case varType b of+      TyConApp c _ ->+        if isClassTyCon c           then getUniVars0 e (uvs, b : tcDicts)           else getUniVars0 e (b:uvs, tcDicts)-      _ -> getUniVars0 e (b:uvs, tcDicts) +      _ -> getUniVars0 e (b:uvs, tcDicts) getUniVars0 _ vs   = vs @@ -354,13 +354,13 @@  --                       | Current top-level binder | varsP :: GHC.CoreProgram -> Var -> (GHC.CoreExpr -> [Var]) -> [Var]-varsP cp tlVar f = -  case filter (\cb -> isInCB cb tlVar) cp of+varsP cp tlVar f =+  case filter (`isInCB` tlVar) cp of     [cb] -> varsCB cb f     _    -> error " Every top-level corebind must be unique! "  isInCB :: GHC.CoreBind -> Var -> Bool-isInCB (GHC.NonRec b _) tlVar = b == tlVar +isInCB (GHC.NonRec b _) tlVar = b == tlVar isInCB (GHC.Rec recs) tlVar   = foldr ((\v b -> v == tlVar && b) . fst) True recs  varsCB :: GHC.CoreBind -> (GHC.CoreExpr -> [Var]) -> [Var]@@ -374,18 +374,18 @@ varsE (GHC.Tick _ e) = varsE e varsE _ = [] -caseVarsE :: GHC.CoreExpr -> [Var] -caseVarsE (GHC.Lam _ e) = caseVarsE e +caseVarsE :: GHC.CoreExpr -> [Var]+caseVarsE (GHC.Lam _ e) = caseVarsE e caseVarsE (GHC.Let (GHC.NonRec _ _) e) = caseVarsE e-caseVarsE (GHC.Case _ b _ alts) = foldr (\(_, _, e) res -> caseVarsE e ++ res) [b] alts -caseVarsE (GHC.Tick _ e) = caseVarsE e -caseVarsE _ = [] +caseVarsE (GHC.Case _ b _ alts) = foldr (\(_, _, e) res -> caseVarsE e ++ res) [b] alts+caseVarsE (GHC.Tick _ e) = caseVarsE e+caseVarsE _ = []  instance Default Var where   def = alphaTyVar  symbolToVar :: GHC.CoreProgram -> Var -> M.HashMap Symbol SpecType -> SSEnv-symbolToVar cp tlBndr renv = +symbolToVar cp tlBndr renv =   let vars = [(F.symbol x, x) | x <- varsP cp tlBndr varsE]       casevars = [F.symbol x | x <- varsP cp tlBndr caseVarsE]       tlVars = [(F.symbol x, x) | x <- getTopLvlBndrs cp]@@ -394,9 +394,9 @@       renv' = foldr M.delete renv casevars   in  M.fromList [ (s, (t, symbolVar s)) | (s, t) <- M.toList renv'] -argsP :: GHC.CoreProgram -> Var -> [Var] +argsP :: GHC.CoreProgram -> Var -> [Var] argsP []         tlVar = error $ " [ argsP ] " ++ show tlVar-argsP (cb : cbs) tlVar +argsP (cb : cbs) tlVar   | isInCB cb tlVar = argsCB cb   | otherwise = argsP cbs tlVar @@ -405,9 +405,10 @@ argsCB _                = error " [ argsCB ] "  argsE :: GHC.CoreExpr -> [Var]-argsE (GHC.Lam a e) = a : argsE e +argsE (GHC.Lam a e) = a : argsE e argsE (GHC.Let (GHC.NonRec _ _) e) = argsE e-argsE _ = [] +argsE _ = [] -notrace :: String -> a -> a +notrace :: String -> a -> a notrace _ a = a+
src/Language/Haskell/Liquid/Synthesize/Generate.hs view
@@ -1,11 +1,12 @@-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ module Language.Haskell.Liquid.Synthesize.Generate where -import           Language.Haskell.Liquid.GHC.API as GHC hiding (Depth)+import           Liquid.GHC.API as GHC hiding (Depth) import           Language.Haskell.Liquid.Types import           Language.Haskell.Liquid.Synthesize.GHC                                          hiding ( SSEnv )@@ -37,7 +38,7 @@ genTerms' i specTy =    do  goalTys <- sGoalTys <$> get       case find (== toType False specTy) goalTys of -        Nothing -> modify (\s -> s { sGoalTys = (toType False specTy) : sGoalTys s })+        Nothing -> modify (\s -> s { sGoalTys = toType False specTy : sGoalTys s })         Just _  -> return ()       fixEMem specTy        fnTys <- functionCands (toType False specTy)
src/Language/Haskell/Liquid/Synthesize/Misc.hs view
@@ -1,16 +1,16 @@-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+ module Language.Haskell.Liquid.Synthesize.Misc where  import qualified Language.Fixpoint.Types        as F import           Control.Monad.State.Lazy import           Text.PrettyPrint.HughesPJ (text, Doc, vcat, ($+$)) import           Language.Haskell.Liquid.Synthesize.GHC-import           Language.Haskell.Liquid.GHC.TypeRep-import           Language.Haskell.Liquid.GHC.API hiding (text, ($+$), vcat)+import           Liquid.GHC.TypeRep+import           Liquid.GHC.API hiding (text, ($+$), vcat) import           Language.Fixpoint.Types
src/Language/Haskell/Liquid/Synthesize/Monad.hs view
@@ -1,13 +1,12 @@-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ module Language.Haskell.Liquid.Synthesize.Monad where  -import           Language.Haskell.Liquid.GHC.API as GHC+import           Liquid.GHC.API as GHC import           Language.Haskell.Liquid.Bare.Resolve                                                as B import           Language.Haskell.Liquid.Types@@ -32,7 +31,7 @@ import           Data.List import           Data.Tuple.Extra -localMaxMatchDepth :: SM Int +localMaxMatchDepth :: SM Int localMaxMatchDepth = maxMatchDepth . getConfig . sCGEnv <$> get  -------------------------------------------------------------------------------@@ -46,17 +45,17 @@  type ExprMemory = [(Type, CoreExpr, Int)] type T = M.HashMap Type (CoreExpr, Int)-data SState -  = SState { rEnv       :: !REnv +data SState+  = SState { rEnv       :: !REnv            , ssEnv      :: !SSEnv -- Local Binders Generated during Synthesis             , ssIdx      :: !Int-           , ssDecrTerm :: !SSDecrTerm +           , ssDecrTerm :: !SSDecrTerm            , sContext   :: !SMT.Context            , sCGI       :: !CGInfo            , sCGEnv     :: !CGEnv            , sFCfg      :: !F.Config            , sDepth     :: !Int-           , sExprMem   :: !ExprMemory +           , sExprMem   :: !ExprMemory            , sExprId    :: !Int            , sArgsId    :: !Int            , sArgsDepth :: !Int@@ -75,67 +74,67 @@  type SM = StateT SState IO -localMaxAppDepth :: SM Int +localMaxAppDepth :: SM Int localMaxAppDepth = maxAppDepth . getConfig . sCGEnv <$> get  localMaxArgsDepth :: SM Int localMaxArgsDepth = maxArgsDepth . getConfig . sCGEnv <$> get -locally :: SM a -> SM a -locally act = do -  st <- get -  r <- act +locally :: SM a -> SM a+locally act = do+  st <- get+  r <- act   modify $ \s -> s{sCGEnv = sCGEnv st, sCGI = sCGI st, sExprMem = sExprMem st, scrutinees = scrutinees st}-  return r +  return r  -evalSM :: SM a -> SMT.Context -> SSEnv -> SState -> IO a -evalSM act ctx env st = do +evalSM :: SM a -> SMT.Context -> SSEnv -> SState -> IO a+evalSM act ctx env st = do   let st' = st {ssEnv = env}   r <- evalStateT act st'-  SMT.cleanupContext ctx -  return r +  _ <- SMT.cleanupContext ctx+  return r -initState :: SMT.Context -> F.Config -> CGInfo -> CGEnv -> REnv -> Var -> [Var] -> SSEnv -> IO SState -initState ctx fcfg cgi cgenv renv xtop uniVars env = +initState :: SMT.Context -> F.Config -> CGInfo -> CGEnv -> REnv -> Var -> [Var] -> SSEnv -> IO SState+initState ctx fcfg cgi cgenv renv xtop uniVars env =   return $ SState renv env 0 [] ctx cgi cgenv fcfg 0 exprMem0 0 0 0 uniVars xtop [] Nothing Nothing ([], []) 0 []   where exprMem0 = initExprMem env  getSEnv :: SM SSEnv-getSEnv = ssEnv <$> get +getSEnv = ssEnv <$> get  getSEMem :: SM ExprMemory getSEMem = sExprMem <$> get -getSFix :: SM Var +getSFix :: SM Var getSFix = sFix <$> get  getSUniVars :: SM [Var] getSUniVars = sUniVars <$> get -getSDecrTerms :: SM SSDecrTerm +getSDecrTerms :: SM SSDecrTerm getSDecrTerms = ssDecrTerm <$> get -addsEnv :: [(Var, SpecType)] -> SM () -addsEnv xts = -  mapM_ (\(x,t) -> modify (\s -> s {ssEnv = M.insert (symbol x) (t,x) (ssEnv s)})) xts  +addsEnv :: [(Var, SpecType)] -> SM ()+addsEnv xts =+  mapM_ (\(x,t) -> modify (\s -> s {ssEnv = M.insert (symbol x) (t,x) (ssEnv s)})) xts -addsEmem :: [(Var, SpecType)] -> SM () -addsEmem xts = do +addsEmem :: [(Var, SpecType)] -> SM ()+addsEmem xts = do   curAppDepth <- sExprId <$> get-  mapM_ (\(x,t) -> modify (\s -> s {sExprMem = (toType False t, GHC.Var x, curAppDepth+1) : (sExprMem s)})) xts  -  +  mapM_ (\(x,t) -> modify (\s -> s {sExprMem = (toType False t, GHC.Var x, curAppDepth+1) : sExprMem s})) xts + addEnv :: Var -> SpecType -> SM ()-addEnv x t = do +addEnv x t = do   liftCG0 (\γ -> γ += ("arg", symbol x, t))-  modify (\s -> s {ssEnv = M.insert (symbol x) (t,x) (ssEnv s)}) +  modify (\s -> s {ssEnv = M.insert (symbol x) (t,x) (ssEnv s)})  addEmem :: Var -> SpecType -> SM ()-addEmem x t = do +addEmem x t = do   let ht0 = toType False t   curAppDepth <- sExprId <$> get-  xtop <- getSFix +  xtop <- getSFix   (ht1, _) <- instantiateTL   let ht = if x == xtop then ht1 else ht0   modify (\s -> s {sExprMem = (ht, GHC.Var x, curAppDepth) : sExprMem s})@@ -145,8 +144,8 @@ --------------------------------------------------------------------------------------------- addDecrTerm :: Var -> [Var] -> SM () addDecrTerm x vars = do-  decrTerms <- getSDecrTerms -  case lookup x decrTerms of +  decrTerms <- getSDecrTerms+  case lookup x decrTerms of     Nothing    -> lookupAll x vars decrTerms     Just vars' -> do       let ix = elemIndex (x, vars') decrTerms@@ -174,14 +173,14 @@  -- | Entry point. structuralCheck :: [CoreExpr] -> SM [CoreExpr]-structuralCheck es +structuralCheck es   = do  decr <- ssDecrTerm <$> get         fix <- sFix <$> get         return (filter (notStructural decr fix) es)  structCheck :: Var -> CoreExpr -> (Maybe Var, [CoreExpr]) structCheck xtop var@(GHC.Var v)-  = if v == xtop +  = if v == xtop       then (Just xtop, [])       else (Nothing, [var]) structCheck xtop (GHC.App e1 (GHC.Type _))@@ -189,9 +188,9 @@ structCheck xtop (GHC.App e1 e2)   =  (mbVar, e2:es)     where (mbVar, es) = structCheck xtop e1-structCheck xtop (GHC.Let _ e) +structCheck xtop (GHC.Let _ e)   = structCheck xtop e-structCheck _ e +structCheck _ e   = error (" StructCheck " ++ show e)  notStructural :: SSDecrTerm -> Var -> CoreExpr -> Bool@@ -210,19 +209,19 @@ --                               END OF STRUCTURAL CHECK                                   -- --------------------------------------------------------------------------------------------- -liftCG0 :: (CGEnv -> CG CGEnv) -> SM () -liftCG0 act = do -  st <- get -  let (cgenv, cgi) = runState (act (sCGEnv st)) (sCGI st) -  modify (\s -> s {sCGI = cgi, sCGEnv = cgenv}) +liftCG0 :: (CGEnv -> CG CGEnv) -> SM ()+liftCG0 act = do+  st <- get+  let (cgenv, cgi) = runState (act (sCGEnv st)) (sCGI st)+  modify (\s -> s {sCGI = cgi, sCGEnv = cgenv})  -liftCG :: CG a -> SM a -liftCG act = do -  st <- get -  let (x, cgi) = runState act (sCGI st) +liftCG :: CG a -> SM a+liftCG act = do+  st <- get+  let (x, cgi) = runState act (sCGI st)   modify (\s -> s {sCGI = cgi})-  return x +  return x   freshVarType :: Type -> SM Var@@ -233,9 +232,9 @@ freshVar = freshVarType . toType False  withIncrDepth :: Monoid a => SM a -> SM a-withIncrDepth m = do +withIncrDepth m = do     s <- get-    matchBound <- localMaxMatchDepth +    matchBound <- localMaxMatchDepth     let d = sDepth s     if d + 1 > matchBound       then return mempty@@ -243,25 +242,25 @@               r <- m               modify $ \s -> s{sDepth = d}               return r-        -  -incrSM :: SM Int -incrSM = do s <- get +++incrSM :: SM Int+incrSM = do s <- get             put s{ssIdx = ssIdx s + 1}             return (ssIdx s) -incrCase :: SM Int +incrCase :: SM Int incrCase-  = do  s <- get +  = do  s <- get         put s { caseIdx = caseIdx s + 1 }         return (caseIdx s)-  + safeIxScruts :: Int -> [a] -> Maybe Int-safeIxScruts i l +safeIxScruts i l   | i >= length l = Nothing   | otherwise     = Just i -symbolExpr :: Type -> F.Symbol -> SM CoreExpr +symbolExpr :: Type -> F.Symbol -> SM CoreExpr symbolExpr τ x = incrSM >>= (\i -> return $ F.notracepp ("symExpr for " ++ F.showpp x) $  GHC.Var $ mkVar (Just $ F.symbolString x) i τ)  @@ -281,7 +280,7 @@ insEMem0 senv = do   xtop      <- getSFix   (ttop, _) <- instantiateTL-  mbUTy     <- sUGoalTy <$> get +  mbUTy     <- sUGoalTy <$> get   uniVs <- sUniVars <$> get    let ts = fromMaybe [] mbUTy@@ -289,11 +288,11 @@   fs0 <- fst . sForalls <$> get   modify ( \s -> s { sForalls = (fs0, ts : ts0) } ) -  let handleIt e = case e of  GHC.Var v -> if xtop == v -                                              then (instantiate e (Just uniVs), ttop) +  let handleIt e = case e of  GHC.Var v -> if xtop == v+                                              then (instantiate e (Just uniVs), ttop)                                               else change e                               _         -> change e-      change e =  let { e' = instantiateTy e mbUTy; t' = exprType e' } +      change e =  let { e' = instantiateTy e mbUTy; t' = exprType e' }                   in  (e', t')        em0 = initExprMem senv@@ -301,18 +300,16 @@                               in  (t', e', i)) em0  instantiateTy :: CoreExpr -> Maybe [Type] -> CoreExpr-instantiateTy e mbTy = -  case mbTy of +instantiateTy e mbTy =+  case mbTy of     Nothing  -> e-    Just tys -> case applyTy tys e of -                  Nothing -> e-                  Just e0 -> e0+    Just tys -> fromMaybe e (applyTy tys e)  -- | Used for instantiation: Applies types to an expression. --   > The result does not have @forall@. --   Nothing as a result suggests that there are more types than foralls in the expression. applyTy :: [Type] -> GHC.CoreExpr -> Maybe GHC.CoreExpr-applyTy []     e =  case exprType e of +applyTy []     e =  case exprType e of                       ForAllTy{} -> Nothing                       _          -> Just e applyTy (t:ts) e =  case exprType e of@@ -324,7 +321,7 @@ fixEMem t   = do  (fs, ts) <- sForalls <$> get         let uTys = unifyWith (toType False t)-        needsFix <- case find (== uTys) ts of +        needsFix <- case find (== uTys) ts of                       Nothing -> return True   -- not yet instantiated                       Just _  -> return False  -- already instantiated @@ -344,7 +341,7 @@ -- | Instantiate the top-level variable. instantiateTL :: SM (Type, GHC.CoreExpr) instantiateTL = do-  uniVars <- getSUniVars +  uniVars <- getSUniVars   xtop <- getSFix   let e = fromJust $ apply uniVars (GHC.Var xtop)   return (exprType e, e)@@ -354,40 +351,38 @@ --   parametricity (same number of @forall@) as the length of the 1st argument. --   > The result has zero @forall@. apply :: [Var] -> GHC.CoreExpr -> Maybe GHC.CoreExpr-apply []     e = -  case exprType e of +apply []     e =+  case exprType e of     ForAllTy {} -> Nothing     _           -> Just e-apply (v:vs) e -  = case exprType e of +apply (v:vs) e+  = case exprType e of       ForAllTy{} -> apply vs (GHC.App e (GHC.Type (TyVarTy v)))       _          -> Nothing  instantiate :: CoreExpr -> Maybe [Var] -> CoreExpr-instantiate e mbt = +instantiate e mbt =   case mbt of     Nothing     -> e-    Just tyVars -> case apply tyVars e of -                      Nothing -> e-                      Just e' -> e'+    Just tyVars -> fromMaybe e (apply tyVars e)  ----------------------------------------------------------------------------------------------------- -withTypeEs :: SpecType -> SM [CoreExpr] -withTypeEs t = do -    em <- sExprMem <$> get -    return (map snd3 (filter (\x -> fst3 x == toType False t) em)) +withTypeEs :: SpecType -> SM [CoreExpr]+withTypeEs t = do+    em <- sExprMem <$> get+    return (map snd3 (filter (\x -> fst3 x == toType False t) em))  findCandidates :: Type ->         -- Goal type: Find all candidate expressions of this type,                                   --   or that produce this type (i.e. functions).                   SM ExprMemory findCandidates goalTy = do   sEMem <- sExprMem <$> get-  return (filter ((goalType goalTy) . fst3) sEMem)+  return (filter (goalType goalTy . fst3) sEMem)  functionCands :: Type -> SM [(Type, GHC.CoreExpr, Int)]-functionCands goalTy = do -  all <- findCandidates goalTy +functionCands goalTy = do+  all <- findCandidates goalTy   return (filter (isFunction . fst3) all)  @@ -396,17 +391,17 @@ ---------------------------------------------------------------------------------  varError :: SM Var-varError = do +varError = do   info      <- ghcI . sCGI <$> get-  let env    = B.makeEnv (gsConfig $ giSpec info) (toGhcSrc $ giSrc info) mempty mempty +  let env    = B.makeEnv (gsConfig $ giSpec info) (toGhcSrc $ giSrc info) mempty mempty   let name   = giTargetMod $ giSrc info   let errSym = dummyLoc $ symbol "Language.Haskell.Liquid.Synthesize.Error.err"-  case B.lookupGhcVar env name "Var" errSym of +  case B.lookupGhcVar env name "Var" errSym of     Right v -> return v     Left e  -> error (show e)-   -toGhcSrc :: TargetSrc -> GhcSrc ++toGhcSrc :: TargetSrc -> GhcSrc toGhcSrc a = Src       { _giIncDir    = giIncDir a       , _giTarget    = giTarget a
src/Language/Haskell/Liquid/Synthesize/Termination.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances    #-}  module Language.Haskell.Liquid.Synthesize.Termination (@@ -9,7 +8,7 @@ import qualified Language.Haskell.Liquid.Types.RefType                                                as R import qualified Language.Fixpoint.Types       as F-import           Language.Haskell.Liquid.GHC.API+import           Liquid.GHC.API  decrType :: Var -> SpecType -> [Var] -> [(F.Symbol, SpecType)] -> SpecType decrType _x ti xs _xts =
src/Language/Haskell/Liquid/Termination/Structural.hs view
@@ -2,11 +2,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ module Language.Haskell.Liquid.Termination.Structural (terminationVars) where  import Language.Haskell.Liquid.Types hiding (isDecreasing)-import Language.Haskell.Liquid.GHC.Misc (showPpr)-import Language.Haskell.Liquid.GHC.API  as GHC hiding ( showPpr+import Liquid.GHC.Misc (showPpr)+import Liquid.GHC.API  as GHC hiding ( showPpr                                                       , Env                                                       , text                                                       )@@ -27,7 +29,7 @@  failingBinds :: TargetInfo -> [CoreBind] failingBinds info = filter (hasErrors . checkBind) structBinds-  where +  where     structCheckWholeProgram = structuralTerm info     program = giCbs . giSrc $ info     structFuns = gsStTerm . gsTerm . giSpec $ info@@ -59,7 +61,7 @@ nextBinds = \case   App e a -> nextBinds e ++ nextBinds a   Lam _ e -> nextBinds e-  Let b e -> [b] ++ 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@@ -77,7 +79,7 @@   , resultErrors :: [TermError]   } deriving (Show) -data TermError = TE +data TermError = TE   { teVar   :: Var   , teError :: UserError   } deriving (Show)
src/Language/Haskell/Liquid/Transforms/ANF.hs view
@@ -5,7 +5,6 @@ {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE NoMonomorphismRestriction  #-} {-# LANGUAGE TupleSections              #-}-{-# LANGUAGE TypeSynonymInstances       #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE ViewPatterns               #-}@@ -14,31 +13,31 @@ module Language.Haskell.Liquid.Transforms.ANF (anormalize) where  import           Prelude                          hiding (error)-import           Language.Haskell.Liquid.GHC.TypeRep-import           Language.Haskell.Liquid.GHC.API  as Ghc hiding ( mkTyArg+import           Liquid.GHC.TypeRep+import           Liquid.GHC.API  as Ghc hiding ( mkTyArg                                                                 , showPpr                                                                 , DsM                                                                 , panic)-import qualified Language.Haskell.Liquid.GHC.API  as Ghc+import qualified Liquid.GHC.API  as Ghc import           Control.Monad.State.Lazy import           System.Console.CmdArgs.Verbosity (whenLoud) import qualified Language.Fixpoint.Misc     as F import qualified Language.Fixpoint.Types    as F  import           Language.Haskell.Liquid.UX.Config  as UX-import qualified Language.Haskell.Liquid.Misc       as Misc -import           Language.Haskell.Liquid.GHC.Misc   as GM+import qualified Language.Haskell.Liquid.Misc       as Misc+import           Liquid.GHC.Misc   as GM import           Language.Haskell.Liquid.Transforms.Rec import           Language.Haskell.Liquid.Transforms.InlineAux import           Language.Haskell.Liquid.Transforms.Rewrite import           Language.Haskell.Liquid.Types.Errors -import qualified Language.Haskell.Liquid.GHC.SpanStack as Sp-import qualified Language.Haskell.Liquid.GHC.Resugar   as Rs+import qualified Liquid.GHC.SpanStack as Sp+import qualified Liquid.GHC.Resugar   as Rs import           Data.Maybe                       (fromMaybe) import           Data.List                        (sortBy, (\\)) import           Data.Function                    (on)-import qualified Text.Printf as Printf +import qualified Text.Printf as Printf import           Data.Hashable import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM@@ -56,7 +55,7 @@     putStrLn $ GM.showCBs untidy orig_cbs     putStrLn "***************************** RWR CoreBinds ***************************"     putStrLn $ GM.showCBs untidy rwr_cbs-  (fromMaybe err . snd) <$> initDsWithModGuts hscEnv modGuts act -- hscEnv m grEnv tEnv emptyFamInstEnv act+  fromMaybe err . snd <$> initDsWithModGuts hscEnv modGuts act -- hscEnv m grEnv tEnv emptyFamInstEnv act     where       err      = panic Nothing "Oops, cannot A-Normalize GHC Core!"       act      = Misc.concatMapM (normalizeTopBind γ0) rwr_cbs@@ -97,14 +96,14 @@  normalizeTyVars :: Bind Id -> Bind Id normalizeTyVars (NonRec x e) = NonRec (setVarType x t') $ normalizeForAllTys e-  where +  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)+  where+    nrec     = normalizeTyVars <$> (uncurry NonRec <$> xes)     xes'     = (\(NonRec x e) -> (x, e)) <$> nrec  subst :: String -> [TyVar] -> [TyVar] -> Type -> Type@@ -128,7 +127,7 @@ newtype DsM a = DsM {runDsM :: Ghc.DsM a}    deriving (Functor, Monad, MonadUnique, Applicative) -data DsST = DsST { st_binds :: [CoreBind] }+newtype DsST = DsST { st_binds :: [CoreBind] }  type DsMW = StateT DsST DsM @@ -180,8 +179,8 @@        return $ Var x  shouldNormalize :: Literal -> Bool-shouldNormalize (LitNumber {})  = True -shouldNormalize (LitString {})    = True +shouldNormalize (LitNumber {})  = True+shouldNormalize (LitString {})    = True shouldNormalize _               = False  add :: [CoreBind] -> DsMW ()@@ -203,7 +202,7 @@   , Just p <- Rs.lift e   = normalizePattern γ p -normalize γ (Lam x e) | isTyVar x +normalize γ (Lam x e) | isTyVar x   = do e' <- normalize γ e        return $ Lam x e' @@ -221,7 +220,7 @@   = 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 (incrCaseDepth c γ') e')+       as'   <- forM as $ \(c, xs, e') -> fmap (c, xs,) (stitch (incrCaseDepth c γ') e')        as''  <- lift $ expandDefaultCase γ τx as'        return $ Case n x' t as''     where τx = GM.expandVarType x@@ -297,9 +296,9 @@   ---------------------------------------------------------------------------------expandDefault :: AnfEnv -> Bool +expandDefault :: AnfEnv -> Bool ---------------------------------------------------------------------------------expandDefault γ = aeCaseDepth γ <= maxCaseExpand γ +expandDefault γ = aeCaseDepth γ <= maxCaseExpand γ  -------------------------------------------------------------------------------- expandDefaultCase :: AnfEnv@@ -316,46 +315,46 @@                      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) +                       else if maxCaseExpand γ /= 2+                            then return z+                            else return (trace (expandMessage False γ n) z)        Nothing -> return z --  expandDefaultCase _ _ z    = return z -expandDefaultCase' +expandDefaultCase'   :: AnfEnv -> Type -> [(AltCon, [Id], c)] -> DsM [(AltCon, [Id], c)] expandDefaultCase' γ t ((DEFAULT, _, e) : dcs)-  | Just dtss <- GM.defaultDataCons t (F.fst3 <$> dcs) = do +  | 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 -> e -> (DataCon, [TyVar], [Type]) -> DsM (AltCon, [Id], e)-cloneCase γ e (d, as, ts) = do -  xs  <- mapM (freshNormalVar γ) ts +cloneCase γ e (d, as, ts) = do+  xs  <- mapM (freshNormalVar γ) ts   return (DataAlt d, as ++ xs, e)  sortCases :: [(AltCon, b, c)] -> [(AltCon, b, c)]-sortCases = sortBy (cmpAltCon `on` F.fst3) +sortCases = sortBy (cmpAltCon `on` F.fst3) -warnCaseExpand :: AnfEnv -> [a] -> [a] -warnCaseExpand γ xs  -  | 10 < n          = trace (expandMessage True γ n) xs +warnCaseExpand :: AnfEnv -> [a] -> [a]+warnCaseExpand γ xs+  | 10 < n          = trace (expandMessage True γ n) xs   | otherwise       = xs-  where -   n                = length 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') +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) +      | otherwise   = ("Not expanding", "Enable" , d+1)     d               = aeCaseDepth γ     sp              = Sp.srcSpan (aeSrcSpan γ) @@ -398,9 +397,8 @@     -- We first use the default 'Eq' instance, which works on uniques (basically, integers) and is     -- efficient. If we get 'False' it means those 'Unique' are really different, but if we get 'True',     -- we need to be /really/ sure that's the case by using the 'stableNameCmp' function on the 'Name's.-    case id1 == id2 of-      False -> False -- Nothing to do, as the uniques are /really/ different-      True  -> stableNameCmp (getName id1) (getName id2) == EQ -- Avoid unique clashing.+    -- Nothing to do when id1 == id2 as the uniques are /really/ different.+    (id1 == id2) && (stableNameCmp (getName id1) (getName id2) == EQ) -- Avoid unique clashing.  -- For the 'Hashable' instance, we rely on the 'Unique'. This means in pratice there is a tiny chance -- of collision, but this should only marginally affects the efficiency of the data structure.@@ -428,9 +426,9 @@ extendAnfEnv :: AnfEnv -> Id -> Id -> AnfEnv extendAnfEnv γ (StableId -> x) y = γ { aeVarEnv = HM.insert x y (aeVarEnv γ) } -incrCaseDepth :: AltCon -> AnfEnv -> AnfEnv +incrCaseDepth :: AltCon -> AnfEnv -> AnfEnv incrCaseDepth DEFAULT γ = γ { aeCaseDepth = 1 + aeCaseDepth γ }-incrCaseDepth _       γ = γ +incrCaseDepth _       γ = γ  at :: AnfEnv -> Tickish Id -> AnfEnv at γ tt = γ { aeSrcSpan = Sp.push (Sp.Tick tt) (aeSrcSpan γ)}
src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs view
@@ -1,9 +1,12 @@ {-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE CPP                    #-} {-# LANGUAGE FlexibleContexts       #-} {-# LANGUAGE UndecidableInstances   #-} {-# LANGUAGE OverloadedStrings      #-} {-# LANGUAGE TupleSections          #-}++{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+ module Language.Haskell.Liquid.Transforms.CoreToLogic   ( coreToDef   , coreToFun@@ -12,7 +15,7 @@   , runToLogic   , runToLogicWithBoolBinds   , logicType-  , inlineSpecType  +  , inlineSpecType   , measureSpecType   , weakenResult   , normalize@@ -20,31 +23,31 @@  import           Data.ByteString                       (ByteString) import           Prelude                               hiding (error)-import           Language.Haskell.Liquid.GHC.TypeRep   () -- needed for Eq 'Type'-import           Language.Haskell.Liquid.GHC.API       hiding (Expr, Located, panic)-import qualified Language.Haskell.Liquid.GHC.API       as Ghc-import qualified Language.Haskell.Liquid.GHC.API       as C+import           Liquid.GHC.TypeRep   () -- needed for Eq 'Type'+import           Liquid.GHC.API       hiding (Expr, Located, panic)+import qualified Liquid.GHC.API       as Ghc+import qualified Liquid.GHC.API       as C import qualified Data.List                             as L-import           Data.Maybe                            (listToMaybe) +import           Data.Maybe                            (listToMaybe) import qualified Data.Text                             as T-import qualified Data.Char -import qualified Text.Printf as Printf +import qualified Data.Char+import qualified Text.Printf as Printf import           Data.Text.Encoding import           Data.Text.Encoding.Error import           Control.Monad.State import           Control.Monad.Except import           Control.Monad.Identity-import qualified Language.Fixpoint.Misc                as Misc -import qualified Language.Haskell.Liquid.Misc          as Misc +import qualified Language.Fixpoint.Misc                as Misc+import qualified Language.Haskell.Liquid.Misc          as Misc import           Language.Fixpoint.Types               hiding (panic, Error, R, simplify) import qualified Language.Fixpoint.Types               as F-import qualified Language.Haskell.Liquid.GHC.Misc      as GM+import qualified Liquid.GHC.Misc      as GM  -import           Language.Haskell.Liquid.Bare.Types -import           Language.Haskell.Liquid.Bare.DataType +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           Liquid.GHC.Play import           Language.Haskell.Liquid.Types.Types   --     hiding (GhcInfo(..), GhcSpec (..), LM) import           Language.Haskell.Liquid.Types.RefType @@ -73,8 +76,8 @@     isErasable     = if allowTC then isEmbeddedClass else isClassType     f              = dummyLoc (symbol v)     t              = ofType (GM.expandVarType v) :: SpecType-    mkA            = EVar . fst -    mkR            = if isBool res then propReft else exprReft +    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,@@ -85,16 +88,16 @@  -- formerly: strengthenResult' measureSpecType :: Bool -> Var -> SpecType-measureSpecType allowTC v = go mkT [] [1..] t-  where -    mkR | boolRes   = propReft -        | otherwise = exprReft  +measureSpecType allowTC v = go mkT [] [(1::Int)..] t+  where+    mkR | boolRes   = propReft+        | otherwise = exprReft     mkT xs          = MkUReft (mkR $ mkEApp f (EVar <$> reverse xs)) mempty-    f               = dummyLoc (symbol v) +    f               = dummyLoc (symbol v)     t               = ofType (GM.expandVarType v) :: SpecType-    boolRes         =  isBool $ ty_res $ toRTypeRep t +    boolRes         =  isBool $ ty_res $ toRTypeRep t -    go f args i (RAllT a t r)    = RAllT a (go f args i t) r +    go f args i (RAllT a t r)    = RAllT a (go f args i t) r     go f args i (RAllP p t)      = RAllP p $ go f args i t     go f args i (RFun x ii t1 t2 r)      | (if allowTC then isEmbeddedClass else isClassType) t1           = RFun x ii t1 (go f args i t2) r@@ -106,21 +109,21 @@     hasRApps (RFun _ _ t1 t2 _) = hasRApps t1 || hasRApps t2     hasRApps RApp {}          = True     hasRApps _                = False-    -   ++ -- | 'weakenResult foo t' drops the singleton constraint `v = foo x y`  --   that is added, e.g. for measures in /strengthenResult'.  --   This should only be used _when_ checking the body of 'foo'  --   where the output, is, by definition, equal to the singleton.-weakenResult :: Bool -> Var -> SpecType -> SpecType +weakenResult :: Bool -> Var -> SpecType -> SpecType weakenResult allowTC v t = F.notracepp msg t'-  where +  where     msg          = "weakenResult v =" ++ GM.showPpr v ++ " t = " ++ showpp t-    t'           = fromRTypeRep $ rep { ty_res = mapExprReft weaken (ty_res rep) } +    t'           = fromRTypeRep $ rep { ty_res = mapExprReft weaken (ty_res rep) }     rep          = toRTypeRep t-    weaken x     = pAnd . filter ((Just vE /=) . isSingletonExpr x) . conjuncts +    weaken x     = pAnd . filter ((Just vE /=) . isSingletonExpr x) . conjuncts     vE           = mkEApp vF xs-    xs           = EVar . fst <$> dropWhile ((if allowTC then isEmbeddedClass else isClassType) . snd) xts +    xs           = EVar . fst <$> dropWhile ((if allowTC then isEmbeddedClass else isClassType) . snd) xts     xts          = zip (ty_binds rep) (ty_args rep)     vF           = dummyLoc (symbol v) @@ -136,7 +139,7 @@  throw :: String -> LogicM a throw str = do-  fmkError  <- lsError <$> get+  fmkError  <- gets lsError   throwError $ fmkError str  getState :: LogicM LState@@ -159,17 +162,17 @@       , lsDCMap  = dm       } -coreAltToDef :: (Reftable r) => Bool -> LocSymbol -> Var -> [Var] -> Var -> Type -> [C.CoreAlt] +coreAltToDef :: (Reftable r) => Bool -> LocSymbol -> Var -> [Var] -> Var -> Type -> [C.CoreAlt]              -> LogicM [Def (Located (RRType r)) DataCon]-coreAltToDef allowTC x z zs y t alts  -  | not (null litAlts) = measureFail x "Cannot lift definition with literal alternatives" -  | otherwise          = do -      d1s <- F.notracepp "coreAltDefs-1" <$> mapM (mkAlt x cc myArgs z) dataAlts -      d2s <- F.notracepp "coreAltDefs-2" <$>       mkDef x cc myArgs z  defAlts defExpr +coreAltToDef allowTC x z zs y t alts+  | not (null litAlts) = measureFail x "Cannot lift definition with literal alternatives"+  | otherwise          = do+      d1s <- F.notracepp "coreAltDefs-1" <$> mapM (mkAlt x cc myArgs z) dataAlts+      d2s <- F.notracepp "coreAltDefs-2" <$>       mkDef x cc myArgs z  defAlts defExpr       return (d1s ++ d2s)-  where +  where     myArgs   = reverse zs-    cc       = if eqType t boolTy then P else E +    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 ]@@ -177,29 +180,29 @@      -- 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'))) +      = Def x {- (toArgs id args) -} d (Just $ varRType dx) (toArgs Just xs')+      . ctor+      . (`subst1` (F.symbol dx, F.mkEApp (GM.namedLocSymbol d) (F.eVar <$> xs')))      <$> coreToLg allowTC e       where xs' = filter (not . if allowTC then GM.isEmbeddedDictVar else GM.isEvVar) xs-    mkAlt _ _ _ _ alt +    mkAlt _ _ _ _ alt       = throw $ "Bad alternative" ++ GM.showPpr alt -    mkDef x ctor _args dx (Just dtss) (Just e) = do  +    mkDef x ctor _args dx (Just dtss) (Just e) = do       eDef   <- ctor <$> coreToLg allowTC e       -- let ys  = toArgs id args       let dxt = Just (varRType dx)       return  [ Def x {- ys -} d dxt (defArgs x ts) eDef | (d, _, ts) <- dtss ]-    -    mkDef _ _ _ _ _ _ = -      return []  +    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 +defArgs x     = zipWith (\i t -> (defArg i, defRTyp t)) [0..]+  where     defArg    = tempSymbol (val x)     defRTyp   = Just . F.atLoc x . ofType @@ -209,28 +212,28 @@   where     go args   (C.Lam  x e)        = go (x:args) e     go args   (C.Tick _ e)        = go args e-    go (z:zs) (C.Case _ y t alts) = coreAltToDef allowTC x z zs y t alts -    go (z:zs) e                   +    go (z:zs) (C.Case _ y t alts) = coreAltToDef allowTC x z zs y t alts+    go (z:zs) e       | Just t <- isMeasureArg z  = coreAltToDef allowTC x z zs z t [(C.DEFAULT, [], e)]-    go _ _                        = measureFail x "Does not have a case-of at the top-level" +    go _ _                        = measureFail x "Does not have a case-of at the top-level"      inlinePreds   = inline (eqType boolTy . GM.expandVarType)  measureFail       :: LocSymbol -> String -> a-measureFail x msg = panic sp e -  where +measureFail x msg = panic sp e+  where     sp            = Just (GM.fSrcSpan x)     e             = Printf.printf "Cannot create measure '%s': %s" (F.showpp x) msg-     + -- | 'isMeasureArg x' returns 'Just t' if 'x' is a valid argument for a measure.-isMeasureArg :: Var -> Maybe Type -isMeasureArg x -  | Just tc <- tcMb -  , Ghc.isAlgTyCon tc = F.notracepp "isMeasureArg" $ Just t -  | otherwise           = Nothing -  where -    t                   = GM.expandVarType x  +isMeasureArg :: Var -> Maybe Type+isMeasureArg x+  | Just tc <- tcMb+  , Ghc.isAlgTyCon tc = F.notracepp "isMeasureArg" $ Just t+  | otherwise           = Nothing+  where+    t                   = GM.expandVarType x     tcMb                = tyConAppTyCon_maybe t  @@ -246,8 +249,8 @@     go acc (C.Lam x e)  = go (x:acc) e     go acc (C.Tick _ e) = go acc e     go acc e            = (reverse acc,) . Right <$> coreToLg allowTC e-     + instance Show C.CoreExpr where   show = GM.showPpr @@ -257,20 +260,16 @@  coreToLg :: Bool -> C.CoreExpr -> LogicM Expr coreToLg allowTC  (C.Let (C.NonRec x (C.Coercion c)) e)-  = coreToLg allowTC (C.substExpr-#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)-                      C.empty-#endif-                      (C.extendCvSubst C.emptySubst x c) e)+  = coreToLg allowTC (C.substExpr (C.extendCvSubst C.emptySubst x c) e) coreToLg allowTC  (C.Let b e)   = subst1 <$> coreToLg allowTC e <*>  makesub allowTC b coreToLg allowTC (C.Tick _ e)          = coreToLg allowTC e coreToLg allowTC (C.App (C.Var v) e)   | ignoreVar v                = coreToLg allowTC e-coreToLg allowTC (C.Var x)+coreToLg _allowTC (C.Var x)   | x == falseDataConId        = return PFalse   | x == trueDataConId         = return PTrue-  | otherwise                  = (lsSymMap <$> getState) >>= eVarWithMap x+  | otherwise                  = getState >>= eVarWithMap x . lsSymMap coreToLg allowTC e@(C.App _ _)         = toPredApp allowTC e coreToLg allowTC (C.Case e b _ alts)   | eqType (GM.expandVarType b) boolTy  = checkBoolAlts alts >>= coreToIte allowTC e@@ -290,7 +289,7 @@ coreToLg True (C.Lam x e) = do p     <- coreToLg True e                                tce   <- lsEmb <$> getState                                return $ ELam (symbol x, typeSort tce (GM.expandVarType x)) p-coreToLg _ e@(C.Lam _ _)        = throw ("Cannot transform lambda abstraction to Logic:\t" ++ GM.showPpr e ++ +coreToLg _ e@(C.Lam _ _)        = throw ("Cannot transform lambda abstraction to Logic:\t" ++ GM.showPpr e ++                                             "\n\n Try using a helper function to remove the lambda.") coreToLg _ e                     = throw ("Cannot transform to Logic:\t" ++ GM.showPpr e) @@ -338,19 +337,19 @@ checkDataAlt :: C.AltCon -> Expr -> LogicM Expr checkDataAlt (C.DataAlt d) e = return $ EApp (EVar (makeDataConChecker d)) e checkDataAlt C.DEFAULT     _ = return PTrue-checkDataAlt (C.LitAlt l)  e -  | Just le <- mkLit l       = return (EEq le e)  +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 +normalizeAlts alts      = ctorAlts ++ defAlts+  where+    (defAlts, ctorAlts) = L.partition isDefault alts+    isDefault (c,_,_)   = c == C.DEFAULT  altToLg :: Bool -> Expr -> C.CoreAlt -> LogicM (C.AltCon, Expr)-altToLg allowTC de (a@(C.DataAlt d), xs, e) = do +altToLg allowTC de (a@(C.DataAlt d), xs, e) = do   p  <- coreToLg allowTC e   dm <- gets lsDCMap   let su = mkSubst $ concat [ dataConProj dm de d x i | (x, i) <- zip (filter (not . if allowTC then GM.isEmbeddedDictVar else GM.isEvVar) xs) [1..]]@@ -362,10 +361,10 @@ 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 +    t | primDataCon  d  = de       | otherwise       = EApp (EVar $ makeDataConSelector (Just dm) d i) de -primDataCon :: DataCon -> Bool +primDataCon :: DataCon -> Bool primDataCon d = d == intDataCon  coreToIte :: Bool -> C.CoreExpr -> (C.CoreExpr, C.CoreExpr) -> LogicM Expr@@ -403,15 +402,15 @@       = PAnd . deList <$> coreToLg allowTC es     go (_, _)       = toLogicApp allowTC p-    +     deList :: Expr -> [Expr]     deList (EApp (EApp (EVar cons) e) es)       | cons == symbol ("GHC.Types.:" :: String)-      = e:deList es +      = e:deList es     deList (EVar nil)       | nil == symbol ("GHC.Types.[]" :: String)-      = [] -    deList e +      = []+    deList e       = [e]  toLogicApp :: Bool -> C.CoreExpr -> LogicM Expr@@ -421,7 +420,7 @@     C.Var _ -> do args <- mapM (coreToLg allowTC) es                   lmap <- lsSymMap <$> getState                   def  <- (`mkEApp` args) <$> tosymbol f-                  ((\x -> makeApp def lmap x args) <$> (tosymbol' f))+                  (\x -> makeApp def lmap x args) <$> tosymbol' f     _       -> do fe   <- coreToLg allowTC f                   args <- mapM (coreToLg allowTC) es                   return $ foldl EApp fe args@@ -519,7 +518,7 @@     _      -> throw ("Bad Measure Definition:\n" ++ GM.showPpr e ++ "\t cannot be applied")  tosymbol' :: C.CoreExpr -> LogicM (Located Symbol)-tosymbol' (C.Var x) = return $ dummyLoc $ symbol x +tosymbol' (C.Var x) = return $ dummyLoc $ symbol x tosymbol' e        = throw ("Bad Measure Definition:\n" ++ GM.showPpr e ++ "\t cannot be applied")  makesub :: Bool -> C.CoreBind -> LogicM (Symbol, Expr)@@ -535,7 +534,7 @@ mkLit (LitFloat  n)    = mkR n mkLit (LitDouble n)    = mkR n mkLit (LitString    s)    = mkS s-mkLit (LitChar   c)    = mkC c +mkLit (LitChar   c)    = mkC c mkLit _                 = Nothing -- ELit sym sort  mkI :: Integer -> Maybe Expr@@ -548,9 +547,9 @@ 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 +mkC                    = Just . ECon . (`F.L` F.charSort)  . repr+  where+    repr               = T.pack . show . Data.Char.ord  ignoreVar :: Id -> Bool ignoreVar i = simpleSymbolVar i `elem` ["I#", "D#"]@@ -566,18 +565,18 @@ isBangInteger _ = False  isErasable :: Id -> Bool-isErasable v = F.notracepp msg $ isGhcSplId v && not (isDCId v) -  where +isErasable v = F.notracepp msg $ isGhcSplId v && not (isDCId v)+  where     msg      = "isErasable: " ++ GM.showPpr (v, Ghc.idDetails v)  isGhcSplId :: Id -> Bool isGhcSplId v = isPrefixOfSym (symbol ("$" :: String)) (simpleSymbolVar v)  isDCId :: Id -> Bool-isDCId v = case Ghc.idDetails v of -  DataConWorkId _ -> True -  DataConWrapId _ -> True -  _               -> False +isDCId v = case Ghc.idDetails v of+  DataConWorkId _ -> True+  DataConWrapId _ -> True+  _               -> False  isANF :: Id -> Bool isANF      v = isPrefixOfSym (symbol ("lq_anf" :: String)) (simpleSymbolVar v)@@ -621,7 +620,8 @@   simplify allowTC (C.Let xes e)     = C.Let (simplify allowTC xes) (simplify allowTC e)   simplify allowTC (C.Case e x _t alts@[(_,_,ee),_,_]) | isBangInteger alts-    = Misc.traceShow ("To simplify allowTC case") $ +  -- XXX(matt): seems to be for debugging?+    = -- Misc.traceShow ("To simplify allowTC case") $         sub (M.singleton x (simplify allowTC e)) (simplify allowTC ee)   simplify allowTC (C.Case e x t alts)     = C.Case (simplify allowTC e) x t (filter (not . isUndefined) (simplify allowTC <$> alts))@@ -651,7 +651,7 @@ isUndefined (_, _, e) = isUndefinedExpr e   where    -- auto generated undefined case: (\_ -> (patError @type "error message")) void-   isUndefinedExpr (C.App (C.Var x) _) | (show x) `elem` perrors = True+   isUndefinedExpr (C.App (C.Var x) _) | show x `elem` perrors = True    isUndefinedExpr (C.Let _ e) = isUndefinedExpr e    -- otherwise    isUndefinedExpr _ = False
src/Language/Haskell/Liquid/Transforms/InlineAux.hs view
@@ -1,26 +1,18 @@-{-# LANGUAGE CPP              #-} {-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ module Language.Haskell.Liquid.Transforms.InlineAux   ( inlineAux   ) where import qualified Language.Haskell.Liquid.UX.Config  as UX-import           Language.Haskell.Liquid.GHC.API+import           Liquid.GHC.API import           Control.Arrow                  (second)-import qualified Language.Haskell.Liquid.GHC.Misc+import qualified Liquid.GHC.Misc                                                as GM import qualified Data.HashMap.Strict           as M-import           Data.Functor.Foldable -buildDictSubst :: CoreProgram -> M.HashMap Id CoreExpr-buildDictSubst = cata f- where-  f Nil = M.empty-  f (Cons b s) | NonRec x e <- b, isDFunId x || isDictonaryId x = M.insert x e s-               | otherwise = s-- inlineAux :: UX.Config -> Module -> CoreProgram -> CoreProgram inlineAux cfg m cbs =  if UX.auxInline cfg then occurAnalysePgm m (const False) (const False) [] (map f cbs) else cbs  where@@ -56,44 +48,6 @@ --   go recs = pure recs --   subst = buildDictSubst cbs ---lookupIdSubstAll :: SDoc -> M.HashMap Id CoreExpr -> Id -> CoreExpr-lookupIdSubstAll doc env v | Just e <- M.lookup v env = e-                           | otherwise                = Var v---substExprAll :: SDoc -> M.HashMap Id CoreExpr -> CoreExpr -> CoreExpr-substExprAll doc subst orig_expr = subst_expr_all doc subst orig_expr---subst_expr_all :: SDoc -> M.HashMap Id CoreExpr -> CoreExpr -> CoreExpr-subst_expr_all doc subst expr = go expr- where-  go (Var v) = lookupIdSubstAll (doc $$ text "subst_expr_all") subst v-  go (Type     ty      ) = Type ty-  go (Coercion co      ) = Coercion co-  go (Lit      lit     ) = Lit lit-  go (App  fun     arg ) = App (go fun) (go arg)-  go (Tick tickish e   ) = Tick tickish (go e)-  go (Cast e       co  ) = Cast (go e) co-     -- Do not optimise even identity coercions-     -- Reason: substitution applies to the LHS of RULES, and-     --         if you "optimise" an identity coercion, you may-     --         lose a binder. We optimise the LHS of rules at-     --         construction time--  go (Lam  bndr    body) = Lam bndr (subst_expr_all doc subst body)--  go (Let  bind    body) = Let (mapBnd go bind) (subst_expr_all doc subst body)--  go (Case scrut bndr ty alts) =-    Case (go scrut) bndr ty (map (go_alt subst) alts)--  go_alt subst (con, bndrs, rhs) = (con, bndrs, subst_expr_all doc subst rhs)--- -- grab the dictionaries grepDFunIds :: CoreProgram -> [(DFunId, CoreExpr)] grepDFunIds = filter (isDFunId . fst) . flattenBinds@@ -123,12 +77,8 @@   go :: CoreExpr -> CoreExpr   go (Lam b body) = Lam b (go body)   go (Let b body)-    | NonRec x e <- b, isDictId x = go-     $ substExpr-#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)     -        empty-#endif-        (extendIdSubst emptySubst x e) body+    | NonRec x e <- b, isDictId x =+        go $ substExpr (extendIdSubst emptySubst x e) body     | otherwise = Let (mapBnd go b) (go body)   go (Case e x t alts) = Case (go e) x t (fmap (mapAlt go) alts)   go (Cast e c       ) = Cast (go e) c
src/Language/Haskell/Liquid/Transforms/Rec.hs view
@@ -1,11 +1,10 @@-{-# LANGUAGE DeriveDataTypeable        #-} {-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE TypeSynonymInstances      #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ module Language.Haskell.Liquid.Transforms.Rec (      transformRecExpr, transformScope      , outerScTr , innerScTr@@ -16,9 +15,9 @@ import           Control.Monad.State import qualified Data.HashMap.Strict                  as M import           Data.Hashable-import           Language.Haskell.Liquid.GHC.API      as Ghc hiding (panic, mapSndM)-import           Language.Haskell.Liquid.GHC.Misc-import           Language.Haskell.Liquid.GHC.Play+import           Liquid.GHC.API      as Ghc hiding (panic, mapSndM)+import           Liquid.GHC.Misc+import           Liquid.GHC.Play import           Language.Haskell.Liquid.Misc         (mapSndM) import           Language.Fixpoint.Misc               (mapSnd) -- , traceShow) import           Language.Haskell.Liquid.Types.Errors@@ -33,7 +32,7 @@   -- TODO-REBARE weird GHC crash on Data/Text/Array.hs = pg   -- TODO-REBARE weird GHC crash on Data/Text/Array.hs | otherwise   -- TODO-REBARE weird GHC crash on Data/Text/Array.hs = panic Nothing ("Type-check" ++ showSDoc (pprMessageBag e))-  where +  where     pg     = inlineFailCases pg0     pg0    = evalState (transPg (inlineLoopBreaker <$> cbs)) initEnv     -- (_, e) = lintCoreBindings [] pg@@ -47,7 +46,7 @@   where     (αs, as, be) = collectTyAndValBinders e -    e' = L.foldl' App (L.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@@ -76,7 +75,7 @@      goalt su (c, xs, e)     = (c, xs, go' su e) -    isFailId x  = isLocalId x && (isSystemName $ varName x) && L.isPrefixOf "fail" (show x)+    isFailId x  = isLocalId x && isSystemName (varName x) && L.isPrefixOf "fail" (show x)     getFailExpr = L.lookup      addFailExpr x (Lam _ e) su = (x, e):su@@ -88,7 +87,7 @@  -- No need for this transformation after ghc-8!!! transformScope :: [Bind Id] -> [Bind Id]-transformScope = outerScTr . innerScTr +transformScope = outerScTr . innerScTr  outerScTr :: [Bind Id] -> [Bind Id] outerScTr = mapNonRec (go [])@@ -126,12 +125,12 @@  transBd :: Bind CoreBndr         -> State TrEnv (Bind CoreBndr)-transBd (NonRec x e) = liftM (NonRec x) (transExpr =<< mapBdM transBd e)-transBd (Rec xes)    = liftM Rec $ mapM (mapSndM (mapBdM transBd)) xes+transBd (NonRec x e) = fmap (NonRec x) (transExpr =<< mapBdM transBd e)+transBd (Rec xes)    = Rec <$> mapM (mapSndM (mapBdM transBd)) xes  transExpr :: CoreExpr -> TE CoreExpr transExpr e-  | (isNonPolyRec e') && (not (null tvs))+  | isNonPolyRec e' && not (null tvs)   = trans tvs ids bs e'   | otherwise   = return e@@ -160,12 +159,12 @@       -> Expr Var       -> State TrEnv (Expr Id) trans vs ids bs (Let (Rec xes) e)-  = liftM (mkLam . mkLet) (makeTrans vs liveIds e')+  = fmap (mkLam . mkLet) (makeTrans vs liveIds e')   where liveIds = mkAlive <$> ids         mkLet e = foldr Let e bs         mkLam e = foldr Lam e $ vs ++ liveIds         e'      = Let (Rec xes') e-        xes'    = (second mkLet) <$> xes+        xes'    = second mkLet <$> xes  trans _ _ _ _ = panic Nothing "TransformRec.trans called with invalid input" @@ -197,7 +196,7 @@ mkSubs :: (Eq k, Hashable k)        => [k] -> [Var] -> [Id] -> [(k, Id)] -> M.HashMap k (Expr b) mkSubs ids tvs xs ys = M.fromList $ s1 ++ s2-  where s1 = (second (appTysAndIds tvs xs)) <$> ys+  where s1 = second (appTysAndIds tvs xs) <$> ys         s2 = zip ids (Var <$> xs)  mkFreshIds :: [TyVar]@@ -245,7 +244,7 @@   fresh _ = freshUnique  instance Freshable Var where-  fresh v = liftM (setVarUnique v) freshUnique+  fresh v = fmap (setVarUnique v) freshUnique  freshInt :: MonadState TrEnv m => m Int freshInt@@ -255,7 +254,7 @@        return n  freshUnique :: MonadState TrEnv m => m Unique-freshUnique = liftM (mkUnique 'X') freshInt+freshUnique = fmap (mkUnique 'X') freshInt   mapNonRec :: (b -> [Bind b] -> [Bind b]) -> [Bind b] -> [Bind b]
src/Language/Haskell/Liquid/Transforms/RefSplit.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+ module Language.Haskell.Liquid.Transforms.RefSplit (          splitXRelatedRefs
src/Language/Haskell/Liquid/Transforms/Rewrite.hs view
@@ -1,14 +1,14 @@-{-# LANGUAGE CPP                       #-} {-# LANGUAGE OverloadedStrings         #-} {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE GADTs                     #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE RankNTypes                #-} {-# LANGUAGE TupleSections             #-}-{-# LANGUAGE TypeSynonymInstances      #-} {-# LANGUAGE UndecidableInstances      #-} {-# LANGUAGE FlexibleContexts          #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ -- | This module contains functions for recursively "rewriting" --   GHC core using "rules". @@ -24,16 +24,16 @@    ) where -import           Language.Haskell.Liquid.GHC.API as Ghc hiding (showPpr, substExpr)-import           Language.Haskell.Liquid.GHC.TypeRep ()+import           Liquid.GHC.API as Ghc hiding (showPpr, substExpr)+import           Liquid.GHC.TypeRep () import           Data.Maybe     (fromMaybe) import           Control.Monad.State hiding (lift) import           Language.Fixpoint.Misc       ({- mapFst, -}  mapSnd) import qualified          Language.Fixpoint.Types as F import           Language.Haskell.Liquid.Misc (safeZipWithError, mapThd3, Nat)-import           Language.Haskell.Liquid.GHC.Play (substExpr)-import           Language.Haskell.Liquid.GHC.Resugar-import           Language.Haskell.Liquid.GHC.Misc (unTickExpr, isTupleId, showPpr, mkAlive) -- , showPpr, tracePpr)+import           Liquid.GHC.Play (substExpr)+import           Liquid.GHC.Resugar+import           Liquid.GHC.Misc (unTickExpr, isTupleId, showPpr, mkAlive) -- , showPpr, tracePpr) import           Language.Haskell.Liquid.UX.Config  (Config, noSimplifyCore) import qualified Data.List as L import qualified Data.HashMap.Strict as M@@ -43,14 +43,65 @@ -------------------------------------------------------------------------------- rewriteBinds :: Config -> [CoreBind] -> [CoreBind] rewriteBinds cfg-  | simplifyCore cfg -  = fmap (normalizeTuples . rewriteBindWith tidyTuples . rewriteBindWith simplifyPatTuple)-  | otherwise        +  | simplifyCore cfg+  = fmap (normalizeTuples +       . rewriteBindWith undollar +       . rewriteBindWith tidyTuples +       . rewriteBindWith simplifyPatTuple)+  | otherwise   = id  simplifyCore :: Config -> Bool simplifyCore = not . noSimplifyCore +undollar :: RewriteRule+undollar = go +  where +    go e +     -- matches `$ t1 t2 t3 f a`  +     | App e1 a  <- untick e+     , App e2 f  <- untick e1+     , App e3 t3 <- untick e2 +     , App e4 t2 <- untick e3 +     , App d t1  <- untick e4 +     , Var v     <- untick d +     , v `hasKey` dollarIdKey+     , Type _    <- untick t1+     , Type _    <- untick t2+     , Type _    <- untick t3+     = Just $ App f a +    go (Tick t e)+      = Tick t <$> go e+    go (Let (NonRec x ex) e)+      = do ex' <- go ex+           e'  <- go e+           return $ Let (NonRec x ex') e'+    go (Let (Rec bes) e)+      = Let <$> (Rec <$> mapM goRec bes) <*> go e+    go (Case e x t alts)+      = Case e x t <$> mapM goAlt alts+    go (App e1 e2)+      = App <$> go e1 <*> go e2+    go (Lam x e)+      = Lam x <$> go e+    go (Cast e c)+      = (`Cast` c) <$> go e+    go e+      = return e++    goRec (x, e)+      = (x,) <$> go e++    goAlt (c, bs, e)+      = (c, bs,) <$> go e++  + ++untick :: CoreExpr -> CoreExpr +untick (Tick _ e) = untick e +untick e          = e + tidyTuples :: RewriteRule tidyTuples e = Just $ evalState (go e) []   where@@ -87,23 +138,23 @@             Just bs' -> return (c, bs', substTuple bs' bs e)             Nothing  -> do let bs' = mkAlive <$> bs                            modify (((c,v),bs'):)-                           return $ (c, bs', e)+                           return (c, bs', e)    normalizeTuples :: CoreBind -> CoreBind-normalizeTuples b -  | NonRec x e <- b -  = NonRec x $ go e -  | Rec xes <- b -  = let (xs,es) = unzip xes in -    Rec $ zip xs (go <$> es) -  where +normalizeTuples b+  | NonRec x e <- b+  = NonRec x $ go e+  | Rec xes <- b+  = let (xs,es) = unzip xes in+    Rec $ zip xs (go <$> es)+  where     go (Let (NonRec x ex) e)-      | Case _ _ _ alts  <- unTickExpr ex -      , [(_, vs, Var z)] <- alts +      | Case _ _ _ alts  <- unTickExpr ex+      , [(_, vs, Var z)] <- alts       , z `elem` vs-      = Let (NonRec z (go ex)) (substTuple [z] [x] (go e)) +      = Let (NonRec z (go ex)) (substTuple [z] [x] (go e))     go (Let (NonRec x ex) e)       = Let (NonRec x (go ex)) (go e)     go (Let (Rec xes) e)@@ -115,17 +166,17 @@     go (Case e b t alt)       = Case (go e) b t (mapThd3 go <$> alt)     go (Cast e c)-      = Cast (go e) c +      = Cast (go e) c     go (Tick t e)       = Tick t (go e)     go (Type t)-      = Type t +      = Type t     go (Coercion c)       = Coercion c     go (Lit l)-      = Lit l +      = Lit l     go (Var x)-      = Var x +      = Var x   --------------------------------------------------------------------------------@@ -250,7 +301,7 @@  _tidyAlt n (Just (Let (NonRec x e) rest))   | Just (yes, e') <- takeBinds n rest-  = Just $ Let (NonRec x e) $ foldl (\e (x, ex) -> Let (NonRec x ex) e) e' ((reverse $ go $ reverse yes))+  = Just $ Let (NonRec x e) $ foldl (\e (x, ex) -> Let (NonRec x ex) e) e' (reverse $ go $ reverse yes)    where     go xes@((_, e):_) = let bs = grapBinds e in mapSnd (replaceBinds bs) <$> xes@@ -312,8 +363,8 @@  isProjection :: CoreExpr -> Bool isProjection e = case lift e of-                   Just (PatProject {}) -> True-                   _                    -> False+                   Just PatProject{} -> True+                   _                 -> False  -------------------------------------------------------------------------------- -- | `hasTuple ys e` CHECKS if `e` contains a tuple that "looks like" (y1...yn)@@ -411,7 +462,7 @@ isIrrefutErrorVar :: Var -> Bool -- isIrrefutErrorVar _x = False -- Ghc.iRREFUT_PAT_ERROR_ID == x -- TODO:GHC-863 isIrrefutErrorVar x = x == Ghc.pAT_ERROR_ID- + -------------------------------------------------------------------------------- -- | `substTuple xs ys e'` returns e' [y1 := x1,...,yn := xn] --------------------------------------------------------------------------------
src/Language/Haskell/Liquid/Types/Bounds.hs view
@@ -4,6 +4,8 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric      #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ module Language.Haskell.Liquid.Types.Bounds (      Bound(..),@@ -77,7 +79,7 @@ makeBound (Bound _  vs ps xs p) ts qs          = RRTy cts mempty OCons   where-    cts  = (\(x, t) -> (x, foldr subsTyVar_meet t su)) <$> cts'+    cts  = (\(x, t) -> (x, foldr subsTyVarMeet t su)) <$> cts'      cts' = makeBoundType penv rs xs
src/Language/Haskell/Liquid/Types/Dictionaries.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE TupleSections        #-} module Language.Haskell.Liquid.Types.Dictionaries (     makeDictionaries   , makeDictionary@@ -19,8 +18,8 @@ import           Prelude                                   hiding (error) import qualified Language.Fixpoint.Types as F import           Language.Haskell.Liquid.Types.PrettyPrint ()-import qualified Language.Haskell.Liquid.GHC.Misc       as GM -import qualified Language.Haskell.Liquid.GHC.API        as Ghc+import qualified Liquid.GHC.Misc       as GM+import qualified Liquid.GHC.API        as Ghc import           Language.Haskell.Liquid.Types.Types -- import           Language.Haskell.Liquid.Types.Visitors (freeVars) import           Language.Haskell.Liquid.Types.RefType ()@@ -42,7 +41,7 @@ makeDictionaryName t ts   = F.notracepp _msg $ F.symbol ("$f" ++ F.symbolString (val t) ++ concatMap mkName ts)   where-    mkName = makeDicTypeName sp . dropUniv . val +    mkName = makeDicTypeName sp . dropUniv . val     sp     = GM.fSrcSpan t     _msg   = "MAKE-DICTIONARY " ++ F.showpp (val t, ts) @@ -51,13 +50,13 @@ --   class resolution.  makeDicTypeName :: Ghc.SrcSpan -> SpecType -> String-makeDicTypeName _ (RFun _ _ _ _ _) = "(->)"+makeDicTypeName _ RFun{}           = "(->)" makeDicTypeName _ (RApp c _ _ _)   = F.symbolString . GM.dropModuleNamesCorrect . F.symbol . rtc_tc $ c-makeDicTypeName _ (RVar (RTV a) _) = show (Ghc.getName a)      +makeDicTypeName _ (RVar (RTV a) _) = show (Ghc.getName a) makeDicTypeName sp t               = panic (Just sp) ("makeDicTypeName: called with invalid type " ++ show t) -dropUniv :: SpecType -> SpecType -dropUniv t = t' where (_,_,t') = bkUniv t +dropUniv :: SpecType -> SpecType+dropUniv t = t' where (_,_,t') = bkUniv t  -------------------------------------------------------------------------------- -- | Dictionary Environment ----------------------------------------------------
src/Language/Haskell/Liquid/Types/Equality.hs view
@@ -1,13 +1,14 @@-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances    #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ -- Syntactic Equality of Types up tp forall type renaming  module Language.Haskell.Liquid.Types.Equality where   import qualified Language.Fixpoint.Types as F import           Language.Haskell.Liquid.Types-import qualified Language.Haskell.Liquid.GHC.API as Ghc+import qualified Liquid.GHC.API as Ghc  import Control.Monad.Writer.Lazy -- import Control.Monad@@ -19,7 +20,7 @@ compareRType :: SpecType -> SpecType -> Bool  compareRType i1 i2 = res && unify vs      where -    unify vs = and (sndEq <$> (L.groupBy (\(x1,_) (x2,_) -> x1 == x2) vs)) +    unify vs = and (sndEq <$> L.groupBy (\(x1,_) (x2,_) -> x1 == x2) vs)      sndEq [] = True      sndEq [_] = True      sndEq ((_,y):xs) = all (==y) (snd <$> xs)@@ -48,7 +49,7 @@     go (RApp x1 ts1 ps1 r1) (RApp x2 ts2 ps2 r2)       | x1 == x2 &&           r1 =*= r2 && and (zipWith (=*=) ps1 ps2) -      = and <$> (zipWithM go ts1 ts2)+      = 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
src/Language/Haskell/Liquid/Types/Errors.hs view
@@ -1,14 +1,13 @@-{-# LANGUAGE ImplicitParams      #-}-{-# LANGUAGE TupleSections       #-} {-# LANGUAGE FlexibleInstances   #-} {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE DeriveGeneric       #-} {-# LANGUAGE DeriveDataTypeable  #-} {-# LANGUAGE DeriveFunctor       #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE DerivingStrategies  #-} {-# LANGUAGE DerivingVia         #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- TODO(#1918): Only needed for GHC <9.0.1.+{-# OPTIONS_GHC -Wno-orphans #-} -- PPrint and aeson instances.+ -- | This module contains the *types* related creating Errors. --   It depends only on Fixpoint and basic haskell libraries, --   and hence, should be importable everywhere.@@ -50,7 +49,7 @@   , srcSpanFileMb   ) where -import           Prelude                      hiding (error)+import           Prelude                      hiding (error, span)  import           GHC.Generics import           Control.DeepSeq@@ -69,7 +68,7 @@ import           Text.PrettyPrint.HughesPJ import qualified Text.Megaparsec              as P -import           Language.Haskell.Liquid.GHC.API as Ghc hiding ( Expr+import           Liquid.GHC.API as Ghc hiding ( Expr                                                                , panicDoc                                                                , ($+$)                                                                , nest@@ -86,6 +85,7 @@                                                                , panic                                                                , int                                                                , hcat+                                                               , spans                                                                ) import           Language.Fixpoint.Types      (pprint, showpp, Tidy (..), PPrint (..), Symbol, Expr, SubcId) import qualified Language.Fixpoint.Misc       as Misc@@ -163,7 +163,7 @@ makeContext _ _ _  []  = empty makeContext l c c' [s] = makeContext1 l c c' s makeContext l _ _  ss  = vcat $ text " "-                              : (zipWith makeContextLine [l..] ss)+                              : zipWith makeContextLine [l..] ss                               ++ [ text " "                                  , text " " ] @@ -475,6 +475,12 @@                 , msg :: !Doc                 } +  | ErrPosTyCon { pos  :: SrcSpan+                , tc   :: !Doc+                , dc   :: !Doc+                }++   | ErrOther    { pos   :: SrcSpan                 , msg   :: !Doc                 } -- ^ Sigh. Other.@@ -537,7 +543,7 @@     hcat $ [ pathDoc <-> colon            , int sline <-> colon            , int scol-           ] ++ if ecol - scol <= 1 then [] else [char '-' <-> int (ecol - 1)]+           ] ++ [char '-' <-> int (ecol - 1) | (ecol - scol) > 1]   | otherwise =     hcat [ pathDoc <-> colon          , parens (int sline <-> comma <-> int scol)@@ -629,7 +635,7 @@  ppContext :: PPrint t => Tidy -> M.HashMap Symbol t -> Doc ppContext td c-  | 0 < length xts = nests 2 [ text "in the context"+  | not (null xts) = nests 2 [ text "in the context"                              , vsep (map (uncurry (pprintBind td)) xts)                              ]   | otherwise      = empty@@ -640,7 +646,7 @@ pprintBind td v t = pprintTidy td v <+> char ':' <+> pprintTidy td t  ppReqModelInContext-  :: (PPrint t) => Tidy -> WithModel t -> t -> (M.HashMap Symbol (WithModel t)) -> Doc+  :: (PPrint t) => Tidy -> WithModel t -> t -> M.HashMap Symbol (WithModel t) -> Doc ppReqModelInContext td tA tE c   = sepVcat blankLine       [ nests 2 [ text "The inferred type"@@ -718,9 +724,9 @@  instance FromJSON SrcSpan where   parseJSON (Object v) = do tag <- v .: "realSpan"-                            case tag of-                              False -> return noSrcSpan-                              True  -> RealSrcSpan <$> v .: "spanInfo" <*> pure Nothing+                            if tag+                              then RealSrcSpan <$> v .: "spanInfo" <*> pure Nothing+                              else return noSrcSpan   parseJSON _          = mempty  -- Default definition use ToJSON and FromJSON@@ -728,8 +734,8 @@ instance FromJSONKey SrcSpan  instance (PPrint a, Show a) => ToJSON (TError a) where-  toJSON e = object [ "pos" .= (pos e)-                    , "msg" .= (render $ ppError' Full empty e)+  toJSON e = object [ "pos" .= pos e+                    , "msg" .= render (ppError' Full empty e)                     ]  instance FromJSON (TError a) where@@ -759,7 +765,7 @@ ppError' td dCtx (ErrAssType _ o _ c p)   = pprintTidy td o         $+$ dCtx-        $+$ (ppFull td $ ppPropInContext td p c)+        $+$ ppFull td (ppPropInContext td p c)  ppError' td dCtx err@(ErrSubType _ _ _ _ _ tE)   | totalityType td tE@@ -779,28 +785,28 @@  ppError' td dCtx (ErrSubType _ _ cid c tA tE)   = text "Liquid Type Mismatch"-    $+$ nest 4 -          (blankLine +    $+$ nest 4+          (blankLine            $+$ dCtx-           $+$ (ppFull td $ ppReqInContext td tA tE c)+           $+$ ppFull td (ppReqInContext td tA tE c)            $+$ maybe mempty (\i -> text "Constraint id" <+> text (show i)) cid)  ppError' td dCtx (ErrSubTypeModel _ _ cid c tA tE)   = text "Liquid Type Mismatch"-    $+$ nest 4 +    $+$ nest 4           (dCtx-          $+$ (ppFull td $ ppReqModelInContext td tA tE c)+          $+$ ppFull td (ppReqModelInContext td tA tE c)           $+$ maybe mempty (\i -> text "Constraint id" <+> text (show i)) cid)  ppError' td  dCtx (ErrFCrash _ _ c tA tE)   = text "Fixpoint Crash on Constraint"         $+$ dCtx-        $+$ (ppFull td $ ppReqInContext td tA tE c)+        $+$ ppFull td (ppReqInContext td tA tE c)  ppError' _ dCtx (ErrParse _ _ e)   = text "Cannot parse specification:"         $+$ dCtx-        $+$ (nest 4 $ pprint e)+        $+$ nest 4 (pprint e)  ppError' _ dCtx (ErrTySpec _ _k v t s)   = ("Illegal type specification for" <+> ppTicks v) --  <-> ppKind k <-> ppTicks v)@@ -843,9 +849,9 @@ ppError' _ dCtx (ErrTermSpec _ v msg e t s)   = text "Illegal termination specification for" <+> ppTicks v         $+$ dCtx-        $+$ (nest 4 $ ((text "Termination metric" <+> ppTicks e <+> text "is" <+> msg <+> "in type signature")-                        $+$ nest 4 (pprint t)-                        $+$ pprint s))+        $+$ nest 4 ((text "Termination metric" <+> ppTicks e <+> text "is" <+> msg <+> "in type signature")+                     $+$ nest 4 (pprint t)+                     $+$ pprint s)  ppError' _ _ (ErrInvt _ t s)   = text "Bad Invariant Specification"@@ -886,7 +892,7 @@ ppError' _ dCtx (ErrDupField _ dc x)   = text "Malformed refined data constructor" <+> dc         $+$ dCtx-        $+$ (nest 4 $ text "Duplicated definitions for field" <+> ppTicks x)+        $+$ nest 4 (text "Duplicated definitions for field" <+> ppTicks x)  ppError' _ dCtx (ErrDupNames _ x ns)   = text "Ambiguous specification symbol" <+> ppTicks x@@ -909,7 +915,7 @@ ppError' _ dCtx (ErrGhc _ s)   = text "GHC Error"         $+$ dCtx-        $+$ (nest 4 $ pprint s)+        $+$ nest 4 (pprint s)  ppError' _ _ (ErrFail _ s)   = text "Failure Error:"@@ -918,17 +924,17 @@ ppError' _ _ (ErrFailUsed _ s xs)   = text "Failure Error:"         $+$ text "Binder" <+> pprint s <+> text "declared to fail is used by"-        <+> (hsep $ L.intersperse comma xs)+        <+> hsep (L.intersperse comma xs)  ppError' _ dCtx (ErrResolve _ kind v msg)   = (text "Unknown" <+> kind <+> ppTicks v)         $+$ dCtx-        $+$ (nest 4 msg)+        $+$ nest 4 msg  ppError' _ dCtx (ErrPartPred _ c p i eN aN)   = text "Malformed predicate application"         $+$ dCtx-        $+$ (nest 4 $ vcat+        $+$ nest 4 (vcat                         [ "The" <+> text (Misc.intToString i) <+> "argument of" <+> c <+> "is predicate" <+> ppTicks p                         , "which expects" <+> pprint eN <+> "arguments" <+> "but is given only" <+> pprint aN                         , " "@@ -940,14 +946,14 @@ ppError' _ dCtx e@(ErrMismatch _ x msg τ t cause hsSp)   = "Specified type does not refine Haskell type for" <+> ppTicks x <+> parens msg         $+$ dCtx-        $+$ (sepVcat blankLine+        $+$ sepVcat blankLine               [ "The Liquid type"               , nest 4 t               , "is inconsistent with the Haskell type"               , nest 4 τ               , "defined at" <+> pprint hsSp               , maybe empty ppCause cause-              ])+              ]     where       ppCause (hsD, lqD) = sepVcat blankLine               [ "Specifically, the Liquid component"@@ -960,7 +966,7 @@ ppError' _ dCtx (ErrAliasCycle _ acycle)   = text "Cyclic type alias definition for" <+> ppTicks n0         $+$ dCtx-        $+$ (nest 4 $ sepVcat blankLine (hdr : map describe acycle))+        $+$ nest 4 (sepVcat blankLine (hdr : map describe acycle))   where     hdr             = text "The following alias definitions form a cycle:"     describe (p, n) = text "*" <+> ppTicks n <+> parens (text "defined at:" <+> pprint p)@@ -975,8 +981,8 @@ ppError' _ dCtx (ErrAliasApp _ name dl s)   = text "Malformed application of type alias" <+> ppTicks name         $+$ dCtx-        $+$ (nest 4 $ vcat [ text "The alias" <+> ppTicks name <+> "defined at:" <+> pprint dl-                           , s ] )+        $+$ nest 4 (vcat [ text "The alias" <+> ppTicks name <+> "defined at:" <+> pprint dl+                           , s ])  ppError' _ dCtx (ErrSaved _ name s)   = name -- <+> "(saved)"@@ -1004,7 +1010,7 @@ ppError' _ dCtx (ErrTermin _ xs s)   = text "Termination Error"         $+$ dCtx-        <+> (hsep $ L.intersperse comma xs) $+$ s+        <+> hsep (L.intersperse comma xs) $+$ s  ppError' _ dCtx (ErrStTerm _ x s)   = text "Structural Termination Error"@@ -1019,11 +1025,11 @@   = text "Standalone class method refinement"     $+$ dCtx     $+$ (text "Invalid type specification for" <+> v)-    $+$ (text "Use class or instance refinements instead.")+    $+$ text "Use class or instance refinements instead."  ppError' _ _ (ErrRClass p0 c is)   = text "Refined classes cannot have refined instances"-    $+$ (nest 4 $ sepVcat blankLine $ describeCls : map describeInst is)+    $+$ nest 4 (sepVcat blankLine $ describeCls : map describeInst is)   where     describeCls       =   text "Refined class definition for:" <+> c@@ -1041,6 +1047,16 @@   = text "Rewrite error"         $+$ dCtx         $+$ nest 4 msg++ppError' _ dCtx (ErrPosTyCon _ tc dc)+  = text "Negative occurence of" <+> tc <+> "in" <+> dc+        $+$ dCtx+        $+$ vcat+            ["\n"+             , "To deactivate or understand the need of positivity check, see:"+             , " "+             , nest 2 "https://ucsd-progsys.github.io/liquidhaskell/options/#positivity-check"+            ]  ppError' _ dCtx (ErrParseAnn _ msg)   = text "Malformed annotation"
src/Language/Haskell/Liquid/Types/Fresh.hs view
@@ -4,11 +4,11 @@ {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TupleSections         #-}-{-# LANGUAGE TypeSynonymInstances  #-} {-# LANGUAGE UndecidableInstances  #-}-{-# LANGUAGE BangPatterns          #-} {-# LANGUAGE ConstraintKinds       #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ module Language.Haskell.Liquid.Types.Fresh   ( Freshable(..)   , refreshTy@@ -231,7 +231,7 @@ refreshVVRef (RProp ss t)   = do xs    <- mapM (const fresh) (fst <$> ss)        let su = F.mkSubst $ zip (fst <$> ss) (F.EVar <$> xs)-       (RProp (zip xs (snd <$> ss)) . F.subst su) <$> refreshVV t+       RProp (zip xs (snd <$> ss)) . F.subst su <$> refreshVV t  -------------------------------------------------------------------------------- refreshArgs :: (FreshM m) => SpecType -> m SpecType
src/Language/Haskell/Liquid/Types/Literals.hs view
@@ -8,8 +8,8 @@   ) where  import Prelude hiding (error)-import Language.Haskell.Liquid.GHC.TypeRep ()-import Language.Haskell.Liquid.GHC.API hiding (panic)+import Liquid.GHC.TypeRep ()+import Liquid.GHC.API hiding (panic)  import Language.Haskell.Liquid.Types.Types import Language.Haskell.Liquid.Types.RefType
src/Language/Haskell/Liquid/Types/Meet.hs view
@@ -8,7 +8,7 @@ import qualified Language.Fixpoint.Types as F import           Language.Haskell.Liquid.Types.Types import           Language.Haskell.Liquid.Types.RefType ()-import           Language.Haskell.Liquid.GHC.API as Ghc+import           Liquid.GHC.API as Ghc  meetVarTypes :: F.TCEmb TyCon -> Doc -> (SrcSpan, SpecType) -> (SrcSpan, SpecType) -> SpecType meetVarTypes _emb _v hs lq = {- meetError emb err -} F.meet hsT lqT
src/Language/Haskell/Liquid/Types/Names.hs view
@@ -1,5 +1,5 @@ module Language.Haskell.Liquid.Types.Names-  (lenLocSymbol, anyTypeSymbol, functionComposisionSymbol) where+  (lenLocSymbol, anyTypeSymbol, functionComposisionSymbol, selfSymbol) where  import Language.Fixpoint.Types @@ -14,3 +14,7 @@ --  defined in include/GHC/Base.hs functionComposisionSymbol :: Symbol functionComposisionSymbol = symbol ("GHC.Base.." :: String)+++selfSymbol :: Symbol+selfSymbol = symbol ("liquid_internal_this" :: String)
src/Language/Haskell/Liquid/Types/PredType.hs view
@@ -1,10 +1,12 @@-{-# LANGUAGE DeriveDataTypeable   #-} {-# LANGUAGE FlexibleContexts     #-} {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE OverloadedStrings    #-} {-# LANGUAGE TupleSections        #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+ module Language.Haskell.Liquid.Types.PredType (     PrType   , TyConP (..), DataConP (..)@@ -27,11 +29,12 @@    -- * should be elsewhere   , dataConWorkRep+  , substPVar   ) where  import           Prelude                         hiding (error) import           Text.PrettyPrint.HughesPJ-import           Language.Haskell.Liquid.GHC.API hiding ( panic+import           Liquid.GHC.API hiding ( panic                                                         , (<+>)                                                         , hsep                                                         , punctuate@@ -39,10 +42,10 @@                                                         , parens                                                         , showPpr                                                         )-import           Language.Haskell.Liquid.GHC.TypeRep ()+import           Liquid.GHC.TypeRep () import           Data.Hashable import qualified Data.HashMap.Strict             as M-import qualified Data.Maybe                                 as Mb +import qualified Data.Maybe                                 as Mb import qualified Data.List         as L -- (foldl', partition) -- import           Data.List                       (nub) @@ -50,31 +53,31 @@  -- import           Language.Fixpoint.Types         hiding (Expr, Predicate) import qualified Language.Fixpoint.Types                    as F-import qualified Language.Haskell.Liquid.GHC.API            as Ghc -import           Language.Haskell.Liquid.GHC.Misc+import qualified Liquid.GHC.API            as Ghc+import           Liquid.GHC.Misc import           Language.Haskell.Liquid.Misc import           Language.Haskell.Liquid.Types.RefType hiding (generalize) import           Language.Haskell.Liquid.Types.Types import           Data.Default  makeTyConInfo :: F.TCEmb Ghc.TyCon -> [Ghc.TyCon] -> [TyConP] -> TyConMap-makeTyConInfo tce fiTcs tcps = TyConMap +makeTyConInfo tce fiTcs tcps = TyConMap   { tcmTyRTy    = tcM-  , tcmFIRTy    = tcInstM +  , tcmFIRTy    = tcInstM   , tcmFtcArity = arities   }-  where +  where     tcM         = M.fromList [(tcpCon tcp, mkRTyCon tcp) | tcp <- tcps ]-    tcInstM     = mkFInstRTyCon tce fiTcs tcM +    tcInstM     = mkFInstRTyCon tce fiTcs tcM     arities     = safeFromList "makeTyConInfo" [ (c, length ts) | (c, ts) <- M.keys tcInstM ]  mkFInstRTyCon :: F.TCEmb Ghc.TyCon -> [Ghc.TyCon] -> M.HashMap Ghc.TyCon RTyCon -> M.HashMap (Ghc.TyCon, [F.Sort]) RTyCon-mkFInstRTyCon tce fiTcs tcm = M.fromList -  [ ((c, typeSort tce <$> ts), rtc) +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)@@ -152,8 +155,8 @@ meetWorkWrapRep :: DataCon -> SpecRep -> SpecRep -> SpecRep meetWorkWrapRep c workR wrapR   | 0 <= pad-  = workR { ty_binds = xs ++ (ty_binds wrapR)-          , ty_args  = ts ++ zipWith F.meet ts' (ty_args wrapR) +  = workR { ty_binds = xs ++ ty_binds wrapR+          , ty_args  = ts ++ zipWith F.meet ts' (ty_args wrapR)           , ty_res   = strengthenRType (ty_res workR)    (ty_res  wrapR)           , ty_preds = ty_preds wrapR           }@@ -180,7 +183,7 @@   where     isCls    = Ghc.isClassTyCon $ Ghc.dataConTyCon dc     (xs, ts) = unzip (reverse yts)-    mkDSym z = (F.symbol z) `F.suffixSymbol` (F.symbol dc)+    mkDSym z = F.symbol z `F.suffixSymbol` F.symbol dc     ys       = mkDSym <$> xs     tx _  []     []     []     = []     tx su (x:xs) (y:ys) (t:ts) = (y, classRFInfo allowTC , if allowTC && isCls then t else F.subst (F.mkSubst su) t, mempty)@@ -194,31 +197,31 @@     makeVars' = zip makeVars (repeat mempty)  instance PPrint TyConP where-  pprintTidy k tc = "data" <+> pprintTidy k (tcpCon tc) -                           <+> ppComm     k (tcpFreeTyVarsTy tc) -                           <+> ppComm     k (tcpFreePredTy   tc) +  pprintTidy k tc = "data" <+> pprintTidy k (tcpCon tc)+                           <+> ppComm     k (tcpFreeTyVarsTy tc)+                           <+> ppComm     k (tcpFreePredTy   tc)       --  (parens $ hsep (punctuate comma (pprintTidy k <$> vs))) <+>       -- (parens $ hsep (punctuate comma (pprintTidy k <$> ps))) <+>       -- (parens $ hsep (punctuate comma (pprintTidy k <$> ls))) -ppComm :: PPrint a => F.Tidy -> [a] -> Doc +ppComm :: PPrint a => F.Tidy -> [a] -> Doc ppComm k = parens . hsep . punctuate comma . fmap (pprintTidy k)  -     + instance Show TyConP where  show = showpp -- showSDoc . ppr  instance PPrint DataConP where   pprintTidy k (DataConP _ dc vs ps cs yts t isGadt mname _)      =  pprintTidy k dc-    <+> (parens $ hsep (punctuate comma (pprintTidy k <$> vs)))-    <+> (parens $ hsep (punctuate comma (pprintTidy k <$> ps)))-    <+> (parens $ hsep (punctuate comma (pprintTidy k <$> cs)))-    <+> (parens $ hsep (punctuate comma (pprintTidy k <$> yts)))-    <+> (pprintTidy k isGadt)-    <+> (pprintTidy k mname)+    <+> parens (hsep (punctuate comma (pprintTidy k <$> vs)))+    <+> parens (hsep (punctuate comma (pprintTidy k <$> ps)))+    <+> parens (hsep (punctuate comma (pprintTidy k <$> cs)))+    <+> parens (hsep (punctuate comma (pprintTidy k <$> yts)))+    <+> pprintTidy k isGadt+    <+> pprintTidy k mname     <+>  pprintTidy k t  instance Show DataConP where@@ -257,7 +260,7 @@ pVartoRConc p (v, args)   = pApp (pname p) $ F.EVar v : args'   where-    args' = (thd3 <$> args) ++ (drop (length args) (thd3 <$> pargs p))+    args' = (thd3 <$> args) ++ drop (length args) (thd3 <$> pargs p)  ----------------------------------------------------------------------- -- | @pvarRType π@ returns a trivial @RType@ corresponding to the@@ -317,6 +320,37 @@ --   where go z (π, RProp t) = substPred msg   (π, t)     z --         go z (π, RPropP r) = replacePVarReft (π, r) <$> z +-------------------------------------------------------------------------------------+substPVar :: PVar BSort -> PVar BSort -> BareType -> BareType+-------------------------------------------------------------------------------------+substPVar src dst = go+  where+    go :: BareType -> BareType+    go (RVar a r)         = RVar a (goRR r)+    go (RApp c ts rs r)   = RApp c (go <$> ts) (goR <$> rs) (goRR r)+    go (RAllP q t)+     | pname q == pname src = RAllP q t+     | otherwise            = RAllP q (go t)+    go (RAllT a t r)      = RAllT a   (go t)  (goRR r)+    go (RFun x i t t' r)  = RFun x i  (go t)  (go t') (goRR r)+    go (RImpF x i t t' r) = RImpF x i (go t)  (go t') (goRR r)+    go (RAllE x t t')     = RAllE x   (go t)  (go t')+    go (REx x t t')       = REx x     (go t)  (go t')+    go (RRTy e r o t)     = RRTy e'   (goRR r) o (go t) where e' = [(x, go t) | (x, t) <- e]+    go (RAppTy t1 t2 r)   = RAppTy    (go t1) (go t2) (goRR r)+    go (RHole r)          = RHole     (goRR r)+    go t@(RExprArg  _)    = t+    goR :: BRProp RReft -> BRProp RReft+    goR rp = rp {rf_body = go (rf_body rp) }+    goRR :: RReft -> RReft+    goRR rr = rr { ur_pred = goP (ur_pred rr) }+    goP :: Predicate -> Predicate+    goP (Pr ps) = Pr (goPV <$> ps)+    goPV :: UsedPVar -> UsedPVar+    goPV pv+      | pname pv == pname src = pv { pname = pname dst }+      | otherwise             = pv+ ------------------------------------------------------------------------------- substPred :: String -> (RPVar, SpecProp) -> SpecType -> SpecType -------------------------------------------------------------------------------@@ -336,7 +370,7 @@     t'                          = RApp c (substPred msg su <$> ts) (substPredP msg su <$> rs) r     (r2', πs)                   = splitRPvar π r -substPred msg (p, tp) (RAllP (q@(PV _ _ _ _)) t)+substPred msg (p, tp) (RAllP q@PV{} t)   | p /= q                      = RAllP q $ substPred msg (p, tp) t   | otherwise                   = RAllP q t @@ -397,7 +431,7 @@      su = F.mkSubst $ zipWith (\s1 s2 -> (s1, F.EVar s2)) (rvs t1) (rvs t2) -    rvs      = foldReft False (\_ r acc -> rvReft r : acc) [] +    rvs      = foldReft False (\_ r acc -> rvReft r : acc) []     rvReft r = let F.Reft(s,_) = F.toReft r in s  substRCon msg su t _ _        = {- panic Nothing -} errorP "substRCon: " $ msg ++ " " ++ showpp (su, t)@@ -460,7 +494,7 @@   = L.nub $ concatMap (freeArgsPs p) (snd <$> env) ++ freeArgsPsRef p r ++ freeArgsPs p t  freeArgsPsRef :: PVar t1 -> UReft t -> [F.Symbol]-freeArgsPsRef p (MkUReft _ (Pr ps)) = [x | (_, x, w) <- (concatMap pargs ps'),  (F.EVar x) == w]+freeArgsPsRef p (MkUReft _ (Pr ps)) = [x | (_, x, w) <- concatMap pargs ps', F.EVar x == w]   where    ps' = f <$> filter (uPVar p ==) ps    f q = q {pargs = pargs q ++ drop (length (pargs q)) (pargs $ uPVar p)}@@ -475,14 +509,14 @@                      -> Ref τ (RType t1 t2 t3)                      -> Ref τ (RType t1 t2 t3)                      -> Ref τ (RType t1 t2 t3)-meetListWithPSubsRef πs ss r1 r2 = L.foldl' ((meetListWithPSubRef ss) r1) r2 πs+meetListWithPSubsRef πs ss r1 r2 = L.foldl' (meetListWithPSubRef ss r1) r2 πs  meetListWithPSub ::  (F.Reftable r, PPrint t) => [(F.Symbol, RSort)]-> r -> r -> PVar t -> r meetListWithPSub ss r1 r2 π   | all (\(_, x, F.EVar y) -> x == y) (pargs π)   = r2 `F.meet` r1   | all (\(_, x, F.EVar y) -> x /= y) (pargs π)-  = r2 `F.meet` (F.subst su r1)+  = r2 `F.meet` F.subst su r1   | otherwise   = panic Nothing $ "PredType.meetListWithPSub partial application to " ++ showpp π   where@@ -500,9 +534,9 @@   = panic Nothing "PredType.meetListWithPSubRef called with invalid input" meetListWithPSubRef ss (RProp s1 r1) (RProp s2 r2) π   | all (\(_, x, F.EVar y) -> x == y) (pargs π)-  = RProp s1 $ (F.subst su' r2) `F.meet` r1+  = RProp s1 $ F.subst su' r2 `F.meet` r1   | all (\(_, x, F.EVar y) -> x /= y) (pargs π)-  = RProp s2 $ r2 `F.meet` (F.subst su r1)+  = RProp s2 $ r2 `F.meet` F.subst su r1   | otherwise   = panic Nothing $ "PredType.meetListWithPSubRef partial application to " ++ showpp π   where@@ -527,7 +561,7 @@ substParg :: Functor f => (F.Symbol, F.Expr) -> f Predicate -> f Predicate substParg (x, y) = fmap fp   where-    fxy s        = if (s == F.EVar x) then y else s+    fxy s        = if s == F.EVar x then y else s     fp           = subvPredicate (\pv -> pv { pargs = mapThd3 fxy <$> pargs pv })  -------------------------------------------------------------------------------
src/Language/Haskell/Liquid/Types/PrettyPrint.hs view
@@ -7,9 +7,13 @@ {-# LANGUAGE TupleSections        #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MonoLocalBinds       #-}-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE RecordWildCards      #-}+{-# LANGUAGE ScopedTypeVariables  #-} +{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+ module Language.Haskell.Liquid.Types.PrettyPrint   ( -- * Printable RTypes     OkRT@@ -26,20 +30,28 @@   , printWarning   , printError +  -- * Filtering errors+  , Filter(..)+  , getFilters+  , reduceFilters+  , defaultFilterReporter+   -- * Reporting errors in the typechecking phase-  , reportErrors+  , FilterReportErrorsArgs(..)+  , filterReportErrorsWith+  , filterReportErrors    ) where -import           Control.Monad-+import           Control.Monad                           (void) import qualified Data.HashMap.Strict              as M import qualified Data.List                        as L                               -- (sort)+import qualified Data.Set                         as Set import           Data.String import           Language.Fixpoint.Misc import qualified Language.Fixpoint.Types          as F-import qualified Language.Haskell.Liquid.GHC.API  as Ghc-import           Language.Haskell.Liquid.GHC.API  as Ghc ( Class+import qualified Liquid.GHC.API  as Ghc+import           Liquid.GHC.API  as Ghc ( Class                                                          , SrcSpan                                                          , PprPrec                                                          , DynFlags@@ -54,13 +66,21 @@                                                          , srcSpanStartLine                                                          , srcSpanStartCol                                                          )-import           Language.Haskell.Liquid.GHC.Logging (putErrMsg, mkLongErrAt)-import           Language.Haskell.Liquid.GHC.Misc+import           Liquid.GHC.Logging (putErrMsg, mkLongErrAt)+import           Liquid.GHC.Misc import           Language.Haskell.Liquid.Misc import           Language.Haskell.Liquid.Types.Types import           Prelude                          hiding (error) import           Text.PrettyPrint.HughesPJ        hiding ((<>)) +-- | `Filter`s match errors. They are used to ignore classes of errors they+-- match. `AnyFilter` matches all errors. `StringFilter` matches any error whose+-- \"representation\" contains the given `String`. A \"representation\" is+-- pretty-printed String of the error.+data Filter = StringFilter String+            | AnyFilter+  deriving (Eq, Ord, Show)+ -------------------------------------------------------------------------------- pprManyOrdered :: (PPrint a, Ord a) => F.Tidy -> String -> [a] -> [Doc] --------------------------------------------------------------------------------@@ -127,7 +147,7 @@  pprAnnInfoBinds :: (PPrint a, PPrint b) => F.Tidy -> (SrcSpan, [(Maybe a, b)]) -> Doc pprAnnInfoBinds k (l, xvs)-  = vcat $ (pprAnnInfoBind k . (l,)) <$> xvs+  = vcat $ pprAnnInfoBind k . (l,) <$> xvs  pprAnnInfoBind :: (PPrint a, PPrint b) => F.Tidy -> (SrcSpan, (Maybe a, b)) -> Doc pprAnnInfoBind k (Ghc.RealSrcSpan sp _, xv)@@ -156,7 +176,7 @@                                  , nest 2 $ text "axiom-map"                                  , nest 4 $ pprint am                                  ]-                    + -------------------------------------------------------------------------------- -- | Pretty Printing RefType --------------------------------------------------- --------------------------------------------------------------------------------@@ -175,11 +195,11 @@             <+> 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 ********************" +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@@ -188,7 +208,7 @@ -------------------------------------------------------------------------------- rtypeDoc :: (OkRT c tv r) => F.Tidy -> RType c tv r -> Doc ---------------------------------------------------------------------------------rtypeDoc k      = ppr_rtype (ppE k) topPrec+rtypeDoc k      = pprRtype (ppE k) topPrec   where     ppE F.Lossy = ppEnvShort ppEnv     ppE F.Full  = ppEnv@@ -197,54 +217,54 @@   pprintTidy _ F.Full  = "Full"   pprintTidy _ F.Lossy = "Lossy" -type Prec = PprPrec +type Prec = PprPrec  ---------------------------------------------------------------------------------ppr_rtype :: (OkRT c tv r) => PPEnv -> Prec -> RType c tv r -> Doc+pprRtype :: (OkRT c tv r) => PPEnv -> Prec -> RType c tv r -> Doc ---------------------------------------------------------------------------------ppr_rtype bb p t@(RAllT _ _ r)-  = F.ppTy r $ ppr_forall bb p t-ppr_rtype bb p t@(RAllP _ _)-  = ppr_forall bb p t-ppr_rtype _ _ (RVar a r)+pprRtype bb p t@(RAllT _ _ r)+  = F.ppTy r $ pprForall bb p t+pprRtype bb p t@(RAllP _ _)+  = pprForall bb p t+pprRtype _ _ (RVar a r)   = F.ppTy r $ pprint a-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)-ppr_rtype bb p (RApp c [t] rs r)+pprRtype bb p t@RImpF{}+  = maybeParen p funPrec (pprRtyFun bb empty t)+pprRtype bb p t@RFun{}+  = maybeParen p funPrec (pprRtyFun bb empty t)+pprRtype bb p (RApp c [t] rs r)   | isList c-  = F.ppTy r $ brackets (ppr_rtype bb p t) <-> ppReftPs bb p rs-ppr_rtype bb p (RApp c ts rs r)+  = F.ppTy r $ brackets (pprRtype bb p t) <-> ppReftPs bb p rs+pprRtype bb p (RApp c ts rs r)   | isTuple c-  = F.ppTy r $ parens (intersperse comma (ppr_rtype bb p <$> ts)) <-> ppReftPs bb p rs-ppr_rtype bb p (RApp c ts rs r)+  = F.ppTy r $ parens (intersperse comma (pprRtype bb p <$> ts)) <-> ppReftPs bb p rs+pprRtype bb p (RApp c ts rs r)   | isEmpty rsDoc && isEmpty tsDoc   = F.ppTy r $ ppT c   | otherwise   = F.ppTy r $ parens $ ppT c <+> rsDoc <+> tsDoc   where     rsDoc            = ppReftPs bb p rs-    tsDoc            = hsep (ppr_rtype bb p <$> ts)+    tsDoc            = hsep (pprRtype bb p <$> ts)     ppT              = ppTyConB bb -ppr_rtype bb p t@(REx _ _ _)+pprRtype bb p t@REx{}   = ppExists bb p t-ppr_rtype bb p t@(RAllE _ _ _)+pprRtype bb p t@RAllE{}   = ppAllExpr bb p t-ppr_rtype _ _ (RExprArg e)+pprRtype _ _ (RExprArg e)   = braces $ pprint e-ppr_rtype bb p (RAppTy t t' r)-  = F.ppTy r $ ppr_rtype bb p t <+> ppr_rtype bb p t'-ppr_rtype bb p (RRTy e _ OCons t)-  = sep [braces (ppr_rsubtype bb p e) <+> "=>", ppr_rtype bb p t]-ppr_rtype bb p (RRTy e r o t)-  = sep [ppp (pprint o <+> ppe <+> pprint r), ppr_rtype bb p t]+pprRtype bb p (RAppTy t t' r)+  = F.ppTy r $ pprRtype bb p t <+> pprRtype bb p t'+pprRtype bb p (RRTy e _ OCons t)+  = sep [braces (pprRsubtype bb p e) <+> "=>", pprRtype bb p t]+pprRtype bb p (RRTy e r o t)+  = sep [ppp (pprint o <+> ppe <+> pprint r), pprRtype bb p t]   where-    ppe  = (hsep $ punctuate comma (ppxt <$> e)) <+> dcolon-    ppp  = \doc -> text "<<" <+> doc <+> text ">>"-    ppxt = \(x, t) -> pprint x <+> ":" <+> ppr_rtype bb p t-ppr_rtype _ _ (RHole r)+    ppe         = hsep (punctuate comma (ppxt <$> e)) <+> dcolon+    ppp  doc    = text "<<" <+> doc <+> text ">>"+    ppxt (x, t) = pprint x <+> ":" <+> pprRtype bb p t+pprRtype _ _ (RHole r)   = F.ppTy r $ text "_"  ppTyConB :: TyConable c => PPEnv -> c -> Doc@@ -255,17 +275,17 @@ shortModules :: Doc -> Doc shortModules = text . F.symbolString . dropModuleNames . F.symbol . render -ppr_rsubtype+pprRsubtype   :: (OkRT c tv r, PPrint a, PPrint (RType c tv r), PPrint (RType c tv ()))   => PPEnv -> Prec -> [(a, RType c tv r)] -> Doc-ppr_rsubtype bb p e-  = pprint_env <+> text "|-" <+> ppr_rtype bb p tl <+> "<:" <+> ppr_rtype bb p tr+pprRsubtype bb p e+  = pprint_env <+> text "|-" <+> pprRtype bb p tl <+> "<:" <+> pprRtype bb p tr   where     (el, r)  = (init e,  last e)     (env, l) = (init el, last el)-    tr   = snd $ r-    tl   = snd $ l-    pprint_bind (x, t) = pprint x <+> colon <-> colon <+> ppr_rtype bb p t+    tr   = snd r+    tl   = snd l+    pprint_bind (x, t) = pprint x <+> colon <-> colon <+> pprRtype bb p t     pprint_env         = hsep $ punctuate comma (pprint_bind <$> env)  -- | From GHC: TypeRep@@ -280,7 +300,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 [pprDbind bb topPrec x t | (x, t) <- zs]) <-> dot <-> pprRtype bb p t'     where (zs,  t')               = split [] t           split zs (REx x t t')   = split ((x,t):zs) t'           split zs t                = (reverse zs, t)@@ -289,8 +309,8 @@   :: (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 +  = text "forall" <+> brackets (intersperse comma [pprDbind bb topPrec x t | (x, t) <- zs]) <-> dot <-> pprRtype bb p t'+    where       (zs,  t')               = split [] t       split zs (RAllE x t t') = split ((x,t):zs) t'       split zs t              = (reverse zs, t)@@ -302,57 +322,57 @@ ppReftPs _ _ rs   | all F.isTauto rs   = empty   | not (ppPs ppEnv) = empty-  | otherwise        = angleBrackets $ hsep $ punctuate comma $ ppr_ref <$> rs+  | otherwise        = angleBrackets $ hsep $ punctuate comma $ pprRef <$> rs -ppr_dbind+pprDbind   :: (OkRT c tv r, PPrint (RType c tv r), PPrint (RType c tv ()))   => PPEnv -> Prec -> F.Symbol -> RType c tv r -> Doc-ppr_dbind bb p x t+pprDbind bb p x t   | F.isNonSymbol x || (x == F.dummySymbol)-  = ppr_rtype bb p t+  = pprRtype bb p t   | otherwise-  = pprint x <-> colon <-> ppr_rtype bb p t+  = pprint x <-> colon <-> pprRtype bb p t   -ppr_rty_fun+pprRtyFun   :: ( 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])+pprRtyFun 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]+    dOut                = pprRtype bb topPrec out+    ppArg (b, t, a)     = [pprDbind bb funPrec b t, a]     (args, out)         = brkFun t -{- -ppr_rty_fun bb prefix t-  = prefix <+> ppr_rty_fun' bb t+{-+pprRtyFun bb prefix t+  = prefix <+> pprRtyFun' bb t -ppr_rty_fun'+pprRtyFun'   :: ( 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'-ppr_rty_fun' bb t-  = ppr_rtype bb topPrec t+pprRtyFun' bb (RImpF b t t' r)+  = F.ppTy r $ pprDbind bb funPrec b t $+$ pprRtyFun bb (text "~>") t'+pprRtyFun' bb (RFun b t t' r)+  = F.ppTy r $ pprDbind bb funPrec b t $+$ pprRtyFun bb arrow t'+pprRtyFun' bb t+  = pprRtype bb topPrec t -} -brkFun :: RType c tv r -> ([(F.Symbol, RType c tv r, Doc)], RType c tv r) -brkFun (RImpF b _ t t' _) = ((b, t, (text "~>")) : args, out)   where (args, out)     = brkFun t'  -brkFun (RFun b _ t t' _)  = ((b, t, (text "->")) : args, out)   where (args, out)     = brkFun t'  -brkFun out                = ([], out) +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_foralls (ppPs bb) (fst <$> ty_vars trep) (ty_preds trep)-                    , ppr_clss cls-                    , ppr_rtype bb topPrec t'+pprForall :: (OkRT c tv r) => PPEnv -> Prec -> RType c tv r -> Doc+pprForall bb p t = maybeParen p funPrec $ sep [+                      pprForalls (ppPs bb) (fst <$> ty_vars trep) (ty_preds trep)+                    , pprClss cls+                    , pprRtype bb topPrec t'                     ]   where     trep          = toRTypeRep t@@ -360,58 +380,58 @@     (cls, t')     = bkClass $ fromRTypeRep $ trep {ty_vars = [], ty_preds = []}     -- t' = fromRTypeRep $ trep {ty_vars = [], ty_preds = []} -    ppr_foralls False _ _  = empty-    ppr_foralls _    [] [] = empty-    ppr_foralls True αs πs = text "forall" <+> dαs αs <+> dπs (ppPs bb) πs <-> dot+    pprForalls False _ _  = empty+    pprForalls _    [] [] = empty+    pprForalls True αs πs = text "forall" <+> dαs αs <+> dπs (ppPs bb) πs <-> dot -    ppr_clss []               = empty-    ppr_clss cs               = (parens $ hsep $ punctuate comma (uncurry (ppr_cls bb p) <$> cs)) <+> text "=>"+    pprClss []               = empty+    pprClss cs               = parens (hsep $ punctuate comma (uncurry (pprCls bb p) <$> cs)) <+> text "=>" -    dαs αs                    = ppr_rtvar_def αs+    dαs αs                    = pprRtvarDef αs      -- dπs :: Bool -> [PVar a] -> Doc     dπs _ []                  = empty     dπs False _               = empty-    dπs True πs               = angleBrackets $ intersperse comma $ ppr_pvar_def bb p <$> πs+    dπs True πs               = angleBrackets $ intersperse comma $ pprPvarDef bb p <$> πs -ppr_rtvar_def :: (PPrint tv) => [RTVar tv (RType c tv ())] -> Doc-ppr_rtvar_def = sep . map (pprint . ty_var_value)+pprRtvarDef :: (PPrint tv) => [RTVar tv (RType c tv ())] -> Doc+pprRtvarDef = sep . map (pprint . ty_var_value) -ppr_cls+pprCls   :: (OkRT c tv r, PPrint a, PPrint (RType c tv r),       PPrint (RType c tv ()))   => PPEnv -> Prec -> a -> [RType c tv r] -> Doc-ppr_cls bb p c ts-  = pp c <+> hsep (map (ppr_rtype bb p) ts)+pprCls bb p c ts+  = pp c <+> hsep (map (pprRtype bb p) ts)   where     pp | ppShort bb = text . F.symbolString . dropModuleNames . F.symbol . render . pprint        | otherwise  = pprint  -ppr_pvar_def :: (OkRT c tv ()) => PPEnv -> Prec -> PVar (RType c tv ()) -> Doc-ppr_pvar_def bb p (PV s t _ xts)-  = pprint s <+> dcolon <+> intersperse arrow dargs <+> ppr_pvar_kind bb p t+pprPvarDef :: (OkRT c tv ()) => PPEnv -> Prec -> PVar (RType c tv ()) -> Doc+pprPvarDef bb p (PV s t _ xts)+  = pprint s <+> dcolon <+> intersperse arrow dargs <+> pprPvarKind bb p t   where-    dargs = [ppr_pvar_sort bb p xt | (xt,_,_) <- xts]+    dargs = [pprPvarSort bb p xt | (xt,_,_) <- xts]  -ppr_pvar_kind :: (OkRT c tv ()) => PPEnv -> Prec -> PVKind (RType c tv ()) -> Doc-ppr_pvar_kind bb p (PVProp t) = ppr_pvar_sort bb p t <+> arrow <+> ppr_name F.boolConName -- propConName-ppr_pvar_kind _ _ (PVHProp)   = panic Nothing "TODO: ppr_pvar_kind:hprop" -- ppr_name hpropConName+pprPvarKind :: (OkRT c tv ()) => PPEnv -> Prec -> PVKind (RType c tv ()) -> Doc+pprPvarKind bb p (PVProp t) = pprPvarSort bb p t <+> arrow <+> pprName F.boolConName -- propConName+pprPvarKind _ _ PVHProp     = panic Nothing "TODO: pprPvarKind:hprop" -- pprName hpropConName -ppr_name :: F.Symbol -> Doc-ppr_name                      = text . F.symbolString+pprName :: F.Symbol -> Doc+pprName                      = text . F.symbolString -ppr_pvar_sort :: (OkRT c tv ()) => PPEnv -> Prec -> RType c tv () -> Doc-ppr_pvar_sort bb p t = ppr_rtype bb p t+pprPvarSort :: (OkRT c tv ()) => PPEnv -> Prec -> RType c tv () -> Doc+pprPvarSort bb p t = pprRtype bb p t -ppr_ref :: (OkRT c tv r) => Ref (RType c tv ()) (RType c tv r) -> Doc-ppr_ref  (RProp ss s) = ppRefArgs (fst <$> ss) <+> pprint s--- ppr_ref (RProp ss s) = ppRefArgs (fst <$> ss) <+> pprint (fromMaybe mempty (stripRTypeBase s))+pprRef :: (OkRT c tv r) => Ref (RType c tv ()) (RType c tv r) -> Doc+pprRef  (RProp ss s) = ppRefArgs (fst <$> ss) <+> pprint s+-- pprRef (RProp ss s) = ppRefArgs (fst <$> ss) <+> pprint (fromMaybe mempty (stripRTypeBase s))  ppRefArgs :: [F.Symbol] -> Doc ppRefArgs [] = empty-ppRefArgs ss = text "\\" <-> hsep (ppRefSym <$> ss ++ [F.vv Nothing]) <+> arrow +ppRefArgs ss = text "\\" <-> hsep (ppRefSym <$> ss ++ [F.vv Nothing]) <+> arrow  ppRefSym :: (Eq a, IsString a, PPrint a) => a -> Doc ppRefSym "" = text "_"@@ -435,8 +455,114 @@ printError :: (Show e, F.PPrint e) => F.Tidy -> DynFlags -> TError e -> IO () printError k dyn err = putErrMsg dyn (pos err) (ppError k empty err) --- | Similar in spirit to 'reportErrors' from the GHC API, but it uses our pretty-printer--- and shim functions under the hood.-reportErrors :: (Show e, F.PPrint e) => F.Tidy -> [TError e] -> Ghc.TcRn ()-reportErrors k errs =-  forM errs (\err -> mkLongErrAt (pos err) (ppError k empty err) mempty) >>= Ghc.reportErrors+-- | Similar in spirit to 'reportErrors' from the GHC API, but it uses our+-- pretty-printer and shim functions under the hood. Also filters the errors+-- according to the given `Filter` list.+--+-- @filterReportErrors failure continue filters k@ will call @failure@ if there+-- are unexpected errors, or will call @continue@ otherwise.+--+-- An error is expected if there is any filter that matches it.+filterReportErrors :: forall e' a. (Show e', F.PPrint e') => FilePath -> Ghc.TcRn a -> Ghc.TcRn a -> [Filter] -> F.Tidy -> [TError e'] -> Ghc.TcRn a+filterReportErrors path failure continue filters k =+  filterReportErrorsWith+    FilterReportErrorsArgs { msgReporter = Ghc.reportErrors+                           , filterReporter = defaultFilterReporter path+                           , failure = failure+                           , continue = continue+                           , pprinter = \err -> mkLongErrAt (pos err) (ppError k empty err) mempty+                           , matchingFilters = reduceFilters renderer filters+                           , filters = filters+                           }+  where+    renderer e = render (ppError k empty e $+$ pprint (pos e))+++-- | Retrieve the `Filter`s from the Config.+getFilters :: Config -> [Filter]+getFilters cfg = anyFilter <> stringFilters+  where+    anyFilter = [AnyFilter | expectAnyError cfg]+    stringFilters = StringFilter <$> expectErrorContaining cfg++-- | Return the list of @filters@ that matched the @err@ , given a @renderer@+-- for the @err@ and some @filters@+reduceFilters :: (e -> String) -> [Filter] -> e -> [Filter]+reduceFilters renderer fs err = filter (filterDoesMatchErr renderer err) fs++filterDoesMatchErr :: (e -> String) -> e -> Filter -> Bool+filterDoesMatchErr _        _ AnyFilter = True+filterDoesMatchErr renderer e (StringFilter filter) = stringMatch filter (renderer e)++stringMatch :: String -> String -> Bool+stringMatch filter str = filter `L.isInfixOf` str++-- | Used in `filterReportErrorsWith'`+data FilterReportErrorsArgs m filter msg e a =+  FilterReportErrorsArgs+  {+    -- | Report the @msgs@ to the monad (usually IO)+    msgReporter :: [msg] -> m ()+  ,+    -- | Report unmatched @filters@ to the monad+    filterReporter :: [filter] -> m ()+  ,+    -- | Continuation for when there are unmatched filters or unmatched errors+    failure :: m a+  ,+    -- | Continuation for when there are no unmatched errors or filters+    continue :: m a+  ,+    -- | Compute a representation of the given error; does not report the error+    pprinter :: e -> m msg+  ,+    -- | Yields the filters that map a given error. Must only yield+    -- filters in the @filters@ field.+    matchingFilters :: e -> [filter]+  ,+    -- | List of filters which could have been matched+    filters :: [filter]+  }++-- | Calls the continuations in FilterReportErrorsArgs depending on whethere there+-- are unmatched errors, unmatched filters or none.+filterReportErrorsWith :: (Monad m, Ord filter) => FilterReportErrorsArgs m filter msg e a -> [e] -> m a+filterReportErrorsWith FilterReportErrorsArgs {..} errs =+  let+    (unmatchedErrors, matchedFilters) =+      L.partition (null . snd) [ (e, fs) | e <- errs, let fs = matchingFilters e ]+    unmatchedFilters = Set.toList $+      Set.fromList filters `Set.difference` Set.fromList (concatMap snd matchedFilters)+  in+    if null unmatchedErrors then+      if null unmatchedFilters then+        continue+      else do+        filterReporter unmatchedFilters+        failure+    else do+      msgs <- traverse (pprinter . fst) unmatchedErrors+      void $ msgReporter msgs+      failure++-- | Report errors via GHC's API stating the given `Filter`s did not get+-- matched. Does nothing if the list of filters is empty.+defaultFilterReporter :: FilePath -> [Filter] -> Ghc.TcRn ()+defaultFilterReporter _ [] = pure ()+defaultFilterReporter path fs = Ghc.reportError =<< mkLongErrAt srcSpan (vcat $ leaderMsg : (nest 4 <$> filterMsgs)) empty+  where+    leaderMsg :: Doc+    leaderMsg = text "Could not match the following expected errors with actual thrown errors:"++    filterToMsg :: Filter -> Doc+    filterToMsg AnyFilter = text "<Any Liquid error>"+    filterToMsg (StringFilter s) = text "String filter: " <-> quotes (text s)++    filterMsgs :: [Doc]+    filterMsgs = filterToMsg <$> fs++    beginningOfFile :: Ghc.SrcLoc+    beginningOfFile = Ghc.mkSrcLoc (fromString path) 1 1++    srcSpan :: SrcSpan+    srcSpan = Ghc.mkSrcSpan beginningOfFile beginningOfFile
src/Language/Haskell/Liquid/Types/RefType.hs view
@@ -6,15 +6,17 @@ {-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE UndecidableInstances      #-}-{-# LANGUAGE TypeSynonymInstances      #-} {-# LANGUAGE TupleSections             #-} {-# LANGUAGE RankNTypes                #-} {-# LANGUAGE GADTs                     #-} {-# LANGUAGE PatternGuards             #-}-{-# LANGUAGE ImplicitParams            #-} {-# LANGUAGE ConstraintKinds           #-} {-# LANGUAGE ViewPatterns              #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- TODO(#1918): Only needed for GHC <9.0.1.+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+ -- | Refinement Types. Mostly mirroring the GHC Type definition, but with --   room for refinements of various sorts. -- TODO: Desperately needs re-organization.@@ -51,8 +53,8 @@    -- * Substitutions   , subts, subvPredicate, subvUReft-  , subsTyVar_meet, subsTyVar_meet', subsTyVar_nomeet-  , subsTyVars_nomeet, subsTyVars_meet+  , subsTyVarMeet, subsTyVarMeet', subsTyVarNoMeet+  , subsTyVarsNoMeet, subsTyVarsMeet    -- * Destructors   , addTyConInfo@@ -83,7 +85,7 @@   , isBaseTy   , updateRTVar, isValKind, kindToRType   , rTVarInfo-  +   , tyVarsPosition, Positions(..)    , isNumeric@@ -93,7 +95,8 @@ -- import           GHC.Stack import Prelude hiding (error) -- import qualified Prelude-import           Data.Maybe               (fromMaybe, isJust, fromJust)+import           Data.Maybe               (fromMaybe, isJust)+import           Data.Bifunctor           (first) import           Data.Monoid              (First(..)) import           Data.Hashable import qualified Data.HashMap.Strict  as M@@ -101,7 +104,7 @@ import qualified Data.List as L import           Control.Monad  (void) import           Text.Printf-import           Text.PrettyPrint.HughesPJ hiding ((<>)) +import           Text.PrettyPrint.HughesPJ hiding ((<>), first) import           Language.Fixpoint.Misc import           Language.Fixpoint.Types hiding (DataDecl (..), DataCtor (..), panic, shiftVV, Predicate, isNumeric) import           Language.Fixpoint.Types.Visitor (mapKVars, Visitable)@@ -113,11 +116,10 @@ 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, isRecursivenewTyCon)-import           Language.Haskell.Liquid.GHC.API        as Ghc hiding ( Expr+import qualified Liquid.GHC.Misc as GM+import           Liquid.GHC.Play (mapType, stringClassArg, isRecursivenewTyCon)+import           Liquid.GHC.API        as Ghc hiding ( Expr                                                                       , Located-                                                                      , mapType                                                                       , tyConName                                                                       , punctuate                                                                       , hcat@@ -131,21 +133,21 @@                                                                       , panic                                                                       , text                                                                       )-import           Language.Haskell.Liquid.GHC.TypeRep () -- Eq Type instance+import           Liquid.GHC.TypeRep () -- Eq Type instance import Data.List (foldl')   -    + strengthenDataConType :: (Var, SpecType) -> (Var, SpecType) strengthenDataConType (x, t) = (x, fromRTypeRep trep {ty_res = tres})   where     tres     = F.notracepp _msg $ ty_res trep `strengthen` MkUReft (exprReft expr) mempty     trep     = toRTypeRep t-    _msg     = "STRENGTHEN-DATACONTYPE x = " ++ F.showpp (x, (zip xs ts))+    _msg     = "STRENGTHEN-DATACONTYPE x = " ++ F.showpp (x, zip xs ts)     (xs, ts) = dataConArgs trep     as       = ty_vars  trep     x'       = symbol x@@ -235,13 +237,13 @@     | 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)+                               subst (mkSubst $ zip (fst <$> s2) (EVar . fst <$> s1)) r2    (<>) (RProp s1 t1) (RProp s2 t2)     | isTrivial t1 = RProp s2 t2     | isTrivial t2 = RProp s1 t1     | otherwise    = RProp s1 $ t1  `strengthenRefType`-                                (subst (mkSubst $ zip (fst <$> s2) (EVar . fst <$> s1)) t2)+                                subst (mkSubst $ zip (fst <$> s2) (EVar . fst <$> s1)) t2  -- TODO: remove and use only Semigroup? instance ( SubsTy tv (RType c tv ()) c@@ -406,7 +408,7 @@ -- Eq Instances ------------------------------------------------------  -- MOVE TO TYPES-instance (Eq c, Eq tv, Hashable tv, PPrint tv, TyConable c, PPrint c, Reftable (RTProp c tv ())) +instance (Eq c, Eq tv, Hashable tv, PPrint tv, TyConable c, PPrint c, Reftable (RTProp c tv ()))       => Eq (RType c tv ()) where   (==) = eqRSort M.empty @@ -494,7 +496,7 @@   { rtv_name   = symbol    $ varName a   , rtv_kind   = k2t       $ tyVarKind a   , rtv_is_val = isValKind $ tyVarKind a-  , rtv_is_pol = True +  , rtv_is_pol = True   }  kindToRType :: Monoid r => Type -> RRType r@@ -518,7 +520,7 @@ bTyVar      = BTV  symbolRTyVar :: Symbol -> RTyVar-symbolRTyVar = rTyVar . GM.symbolTyVar +symbolRTyVar = rTyVar . GM.symbolTyVar  bareRTyVar :: BTyVar -> RTyVar bareRTyVar (BTV tv) = symbolRTyVar tv@@ -566,7 +568,7 @@  addPds :: Foldable t        => t (PVar (RType c tv ())) -> RType c tv r -> RType c tv r-addPds ps (RAllT v t r) = RAllT v (addPds ps t) r +addPds ps (RAllT v t r) = RAllT v (addPds ps t) r addPds ps t             = foldl' (flip rPred) t ps  nlzP :: (OkRT c tv r) => [PVar (RType c tv ())] -> RType c tv r -> (RType c tv r, [PVar (RType c tv ())])@@ -587,17 +589,17 @@ nlzP ps (RAllT v t r)  = (RAllT v t' r, ps ++ ps')   where (t', ps') = nlzP [] t-nlzP ps t@(RApp _ _ _ _)+nlzP ps t@RApp{}  = (t, ps) nlzP ps (RAllP p t)  = (t', [p] ++ ps ++ ps')   where (t', ps') = nlzP [] t-nlzP ps t@(REx _ _ _)+nlzP ps t@REx{}  = (t, ps) nlzP ps t@(RRTy _ _ _ t')  = (t, ps ++ ps')  where ps' = snd $ nlzP [] t'-nlzP ps t@(RAllE _ _ _)+nlzP ps t@RAllE{}  = (t, ps) nlzP _ t  = panic Nothing $ "RefType.nlzP: cannot handle " ++ show t@@ -628,10 +630,10 @@     f (RVar v1 r1) t  = RVar v1 (r1 `meet` fromMaybe mempty (stripRTypeBase t))     f t (RVar _ r1)  = t `strengthen` r1     f t1 t2           = panic Nothing $ printf "strengthenRefTypeGen on differently shaped types \nt1 = %s [shape = %s]\nt2 = %s [shape = %s]"-                         (pprt_raw t1) (showpp (toRSort t1)) (pprt_raw t2) (showpp (toRSort t2))+                         (pprRaw t1) (showpp (toRSort t1)) (pprRaw t2) (showpp (toRSort t2)) -pprt_raw :: (OkRT c tv r) => RType c tv r -> String-pprt_raw = render . rtypeDoc Full+pprRaw :: (OkRT c tv r) => RType c tv r -> String+pprRaw = render . rtypeDoc Full  {- [NOTE:StrengthenRefType] disabling the `meetable` check because @@ -648,19 +650,19 @@  -}  strengthenRefType 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))+  -- | _meetable t1 t2+  = strengthenRefType_ const t1 t2+  -- | otherwise+  -- = panic Nothing msg+  -- where+  --   msg = printf "strengthen on differently shaped reftypes \nt1 = %s [shape = %s]\nt2 = %s [shape = %s]"+  --           (showpp t1) (showpp (toRSort t1)) (showpp t2) (showpp (toRSort t2))  _meetable :: (OkRT c tv r) => RType c tv r -> RType c tv r -> Bool _meetable t1 t2 = toRSort t1 == toRSort t2  strengthenRefType_ f (RAllT a1 t1 r1) (RAllT a2 t2 r2)-  = RAllT a1 (strengthenRefType_ f t1 (subsTyVar_meet (ty_var_value a2, toRSort t, t) t2)) (r1 `meet` r2)+  = RAllT a1 (strengthenRefType_ f t1 (subsTyVarMeet (ty_var_value a2, toRSort t, t) t2)) (r1 `meet` r2)   where t = RVar (ty_var_value a1) mempty  strengthenRefType_ f (RAllT a t1 r1) t2@@ -699,11 +701,18 @@  -- YL: Evidence that we need a Monoid instance for RFInfo? strengthenRefType_ f (RFun x1 i1 t1 t1' r1) (RFun x2 i2 t2 t2' r2)+  | x2 /= F.dummySymbol   = RFun x2 i1{permitTC = getFirst b} t t' (r1 `meet` r2)     where t  = strengthenRefType_ f t1 t2           t' = strengthenRefType_ f (subst1 t1' (x1, EVar x2)) t2'           b  = First (permitTC i1) <> First (permitTC i2) +strengthenRefType_ f (RFun x1 i1 t1 t1' r1) (RFun x2 i2 t2 t2' r2)+  = RFun x1 i1{permitTC = getFirst b} t t' (r1 `meet` r2)+    where t  = strengthenRefType_ f t1 t2+          t' = strengthenRefType_ f t1' (subst1 t2' (x2, EVar x1))+          b  = First (permitTC i1) <> First (permitTC i2)+ strengthenRefType_ f (RApp tid t1s rs1 r1) (RApp _ t2s rs2 r2)   = RApp tid ts rs (r1 `meet` r2)     where ts  = zipWith (strengthenRefType_ f) t1s t2s@@ -753,7 +762,7 @@ 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+expandRApp tce tyi t@RApp{} = RApp rc' ts rs' r   where     RApp rc ts rs r            = t     (rc', _)                   = appRTyCon tce tyi rc as@@ -781,7 +790,7 @@    => PVar (RType c tv ()) -> Ref (RType c tv ()) (RType c tv r) rtPropTop pv = case ptype pv of                  PVProp t -> RProp xts $ ofRSort t-                 PVHProp  -> RProp xts $ mempty+                 PVHProp  -> RProp xts mempty                where                  xts      =  pvArgs pv @@ -797,7 +806,7 @@          -> Ref (RType c tv ()) (RType c tv r)          -> Ref (RType c tv ()) (RType c tv r) mkRTProp pv (RProp ss (RHole r))-  = RProp ss $ (ofRSort $ pvType pv) `strengthen` r+  = RProp ss $ ofRSort (pvType pv) `strengthen` r  mkRTProp pv (RProp ss t)   | length (pargs pv) == length ss@@ -837,55 +846,55 @@  -}  appRTyCon :: (ToTypeable r) => TCEmb TyCon -> TyConMap -> RTyCon -> [RRType r] -> (RTyCon, [RPVar])-appRTyCon tce tyi rc ts = F.notracepp _msg (resTc, ps'') +appRTyCon tce tyi rc ts = F.notracepp _msg (resTc, ps'')   where     _msg  = "appRTyCon-family: " ++ showpp (Ghc.isFamilyTyCon c, Ghc.tyConRealArity c, toType False <$> ts)     resTc = RTyCon c ps'' (rtc_info rc'')     c     = rtc_tc rc-   +     (rc', ps') = rTyConWithPVars tyi rc (rTypeSort tce <$> ts)     -- TODO:faminst-preds rc'   = M.lookupDefault rc c (tcmTyRTy tyi)     -- TODO:faminst-preds ps'   = rTyConPVs rc'       -- TODO:faminst-preds: these substitutions may be WRONG if we are using FAMINST.-    ps''  = subts (zip (RTV <$> αs) ts') <$> ps' -      where +    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 +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 +  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 +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 +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) +    Just (c', ts) -> F.notracepp ("famInstArgs: " ++ F.showpp (c, cArity, ts))+                     $ Just (c', take (length ts - cArity) ts)     Nothing       -> Nothing-    where +    where       cArity      = Ghc.tyConRealArity c  -- TODO:faminst-preds: case Ghc.tyConFamInst_maybe c of@@ -904,8 +913,8 @@ --   '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 +plainRTyConPVars tyi rc = (rc', rTyConPVs rc')+  where     rc'                   = M.lookupDefault rc (rtc_tc rc) (tcmTyRTy tyi)  @@ -913,7 +922,7 @@ -- RJ: The code of `isNumeric` is incomprehensible. -- Please fix it to use intSort instead of intFTyCon isNumeric :: TCEmb TyCon -> RTyCon -> Bool-isNumeric tce c = F.isNumeric mySort +isNumeric tce c = F.isNumeric mySort   where     -- mySort      = M.lookupDefault def rc tce     mySort      = maybe def fst (F.tceLookup rc tce)@@ -935,7 +944,7 @@ allTyVars' t = fmap ty_var_value $ vs ++ vs'   where     vs      = map fst . fst3 . bkUniv $ t-    vs'     = freeTyVars    $ t+    vs'     = freeTyVars t   freeTyVars :: Eq tv => RType c tv r -> [RTVar tv (RType c tv ())]@@ -976,50 +985,50 @@ -- TODO: Rewrite subsTyvars with Traversable -------------------------------------------------------------------------------- -subsTyVars_meet+subsTyVarsMeet   :: (Eq tv, Foldable t, Hashable tv, Reftable r, TyConable c,       SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,       SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,       SubsTy tv (RType c tv ()) tv,       SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))   => t (tv, RType c tv (), RType c tv r) -> RType c tv r -> RType c tv r-subsTyVars_meet        = subsTyVars True+subsTyVarsMeet        = subsTyVars True -subsTyVars_nomeet+subsTyVarsNoMeet   :: (Eq tv, Foldable t, Hashable tv, Reftable r, TyConable c,       SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,       SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,       SubsTy tv (RType c tv ()) tv,       SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))   => t (tv, RType c tv (), RType c tv r) -> RType c tv r -> RType c tv r-subsTyVars_nomeet      = subsTyVars False+subsTyVarsNoMeet      = subsTyVars False -subsTyVar_nomeet+subsTyVarNoMeet   :: (Eq tv, Hashable tv, Reftable r, TyConable c,       SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,       SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,       SubsTy tv (RType c tv ()) tv,       SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))   => (tv, RType c tv (), RType c tv r) -> RType c tv r -> RType c tv r-subsTyVar_nomeet       = subsTyVar False+subsTyVarNoMeet       = subsTyVar False -subsTyVar_meet+subsTyVarMeet   :: (Eq tv, Hashable tv, Reftable r, TyConable c,       SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,       SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,       SubsTy tv (RType c tv ()) tv,       SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))   => (tv, RType c tv (), RType c tv r) -> RType c tv r -> RType c tv r-subsTyVar_meet         = subsTyVar True+subsTyVarMeet         = subsTyVar True -subsTyVar_meet'+subsTyVarMeet'   :: (Eq tv, Hashable tv, Reftable r, TyConable c,       SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,       SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,       SubsTy tv (RType c tv ()) tv,       SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))   => (tv, RType c tv r) -> RType c tv r -> RType c tv r-subsTyVar_meet' (α, t) = subsTyVar_meet (α, toRSort t, t)+subsTyVarMeet' (α, t) = subsTyVarMeet (α, toRSort t, t)  subsTyVars   :: (Eq tv, Foldable t, Hashable tv, Reftable r, TyConable c,@@ -1071,7 +1080,7 @@           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'+  = if meet then t' `strengthen` subt (α, τ) r else t'   | otherwise   = RVar (subt (α', τ) α) r subsFree m s z (RAllE x t t')@@ -1248,22 +1257,22 @@  instance SubsTy Symbol Symbol (BRType r) where   subt (x,y) (RVar v r)-    | BTV x == v = RVar (BTV y) r -    | otherwise  = RVar v r +    | BTV x == v = RVar (BTV y) r+    | otherwise  = RVar v r   subt (x, y) (RAllT (RTVar v i) t r)     | BTV x == v = RAllT (RTVar v i) t r     | otherwise  = RAllT (RTVar v i) (subt (x,y) t) r-  subt su (RFun x i t1 t2 r)  = RFun x i (subt su t1) (subt su t2) r +  subt su (RFun x i t1 t2 r)  = RFun x i (subt su t1) (subt su t2) r   subt su (RImpF x i t1 t2 r) = RImpF x i (subt su t1) (subt su t2) r   subt su (RAllP p t)       = RAllP p (subt su t)-  subt su (RApp c ts ps r)  = RApp c (subt su <$> ts) (subt su <$> ps) r +  subt su (RApp c ts ps r)  = RApp c (subt su <$> ts) (subt su <$> ps) r   subt su (RAllE x t1 t2)   = RAllE x (subt su t1) (subt su t2)   subt su (REx x t1 t2)     = REx x (subt su t1) (subt su t2)-  subt _  (RExprArg e)      = RExprArg e -  subt su (RAppTy t1 t2 r)  = RAppTy (subt su t1) (subt su t2) r +  subt _  (RExprArg e)      = RExprArg e+  subt su (RAppTy t1 t2 r)  = RAppTy (subt su t1) (subt su t2) r   subt su (RRTy e r o t)    = RRTy [(x, subt su p) | (x,p) <- e] r o (subt su t)-  subt _ (RHole r)          = RHole r -  +  subt _ (RHole r)          = RHole r+ instance SubsTy Symbol Symbol (RTProp BTyCon BTyVar r) where   subt su (RProp e t) =  RProp [(x, subt su xt) | (x,xt) <- e] (subt su t) @@ -1327,20 +1336,20 @@  -- NOTE: This DOES NOT substitute at the binders instance SubsTy RTyVar RSort PrType where-  subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ)+  subt (α, τ) = subsTyVarMeet (α, τ, ofRSort τ)  instance SubsTy RTyVar RSort SpecType where-  subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ)+  subt (α, τ) = subsTyVarMeet (α, τ, ofRSort τ)  instance SubsTy TyVar Type SpecType where-  subt (α, τ) = subsTyVar_meet (RTV α, ofType τ, ofType τ)+  subt (α, τ) = subsTyVarMeet (RTV α, ofType τ, ofType τ)  instance SubsTy RTyVar RTyVar SpecType where   subt (α, a) = subt (α, RVar a () :: RSort)   instance SubsTy RTyVar RSort RSort where-  subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ)+  subt (α, τ) = subsTyVarMeet (α, τ, ofRSort τ)  instance SubsTy tv RSort Predicate where   subt _ = id -- NV TODO@@ -1353,11 +1362,11 @@   subt _ t = t  instance SubsTy BTyVar BSort BSort where-  subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ)+  subt (α, τ) = subsTyVarMeet (α, τ, ofRSort τ)  instance (SubsTy tv ty (UReft r), SubsTy tv ty (RType c tv ())) => SubsTy tv ty (RTProp c tv (UReft r))  where-  subt m (RProp ss (RHole p)) = RProp ((mapSnd (subt m)) <$> ss) $ RHole $ subt m p-  subt m (RProp ss t) = RProp ((mapSnd (subt m)) <$> ss) $ fmap (subt m) t+  subt m (RProp ss (RHole p)) = RProp (mapSnd (subt m) <$> ss) $ RHole $ subt m p+  subt m (RProp ss t) = RProp (mapSnd (subt m) <$> ss) $ fmap (subt m) t  subvUReft     :: (UsedPVar -> UsedPVar) -> UReft Reft -> UReft Reft subvUReft f (MkUReft r p) = MkUReft r (subvPredicate f p)@@ -1413,7 +1422,7 @@ 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 +  | t == holeLit           = RHole mempty   | otherwise              = rF listTyCon [rF charTyCon [] [] mempty] [] mempty  holeLit :: TyLit@@ -1464,7 +1473,7 @@ isBaseTy (TyVarTy _)      = True isBaseTy (AppTy _ _)      = False isBaseTy (TyConApp _ ts)  = and $ isBaseTy <$> ts-isBaseTy (FunTy _ _ _ _)  = False+isBaseTy FunTy{}          = False isBaseTy (ForAllTy _ _)   = False isBaseTy (LitTy _)        = True isBaseTy (CastTy _ _)     = False@@ -1503,7 +1512,7 @@   = toType useRFInfo t toType _ (RVar (RTV α) _)   = TyVarTy α-toType useRFInfo (RApp (RTyCon {rtc_tc = c}) ts _ _)+toType useRFInfo (RApp RTyCon{rtc_tc = c} ts _ _)   = TyConApp c (toType useRFInfo <$> filter notExprArg ts)   where     notExprArg (RExprArg _) = False@@ -1521,7 +1530,7 @@ toType useRFInfo (RRTy _ _ _ t)   = toType useRFInfo t toType _ (RHole _)-  = LitTy holeLit  +  = LitTy holeLit -- toType t --  = {- impossible Nothing -} Prelude.error $ "RefType.toType cannot handle: " ++ show t @@ -1584,8 +1593,8 @@  -------------------------------------------------------------------------------- -- 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 :: (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') }@@ -1630,11 +1639,11 @@     go t@FunTy{}        = typeSortFun tce t     go τ@(ForAllTy _ _) = typeSortForAll tce τ     -- go (TyConApp c τs)  = fApp (tyConFTyCon tce c) (go <$> τs)-    go (TyConApp c τs)  +    go (TyConApp c τs)       | isNewTyCon c-      , not (isRecursivenewTyCon c) +      , not (isRecursivenewTyCon c)       = go (Ghc.newTyConInstRhs c τs)-      | otherwise  +      | otherwise       = tyConFTyCon tce c (go <$> τs)     go (AppTy t1 t2)    = fApp (go t1) [go t2]     go (TyVarTy tv)     = tyVarSort tv@@ -1642,17 +1651,17 @@     go τ                = FObj (typeUniqueSymbol τ)  tyConFTyCon :: TCEmb TyCon -> TyCon -> [Sort] -> Sort-tyConFTyCon tce c ts = case tceLookup c tce of -                         Just (t, WithArgs) -> t -                         Just (t, NoArgs)   -> fApp t ts  -                         Nothing            -> fApp (fTyconSort niTc) ts +tyConFTyCon tce c ts = case tceLookup c tce of+                         Just (t, WithArgs) -> t+                         Just (t, NoArgs)   -> fApp t ts+                         Nothing            -> fApp (fTyconSort niTc) ts   where     niTc             = symbolNumInfoFTyCon (dummyLoc $ tyConName c) (isNumCls c) (isFracCls c)     -- oldRes           = F.notracepp _msg $ M.lookupDefault def c tce     -- _msg             = "tyConFTyCon c = " ++ show c ++ "default " ++ show (def, Ghc.isFamInstTyCon c)  tyVarSort :: TyVar -> Sort-tyVarSort = FObj . symbol +tyVarSort = FObj . symbol  typeUniqueSymbol :: Type -> Symbol typeUniqueSymbol = symbol . GM.typeUniqueString@@ -1677,7 +1686,7 @@  typeSortFun :: TCEmb TyCon -> Type -> Sort typeSortFun tce t = mkFFunc 0 sos-  where +  where     sos           = typeSort tce <$> τs     τs            = grabArgs [] t @@ -1695,10 +1704,7 @@ grabArgs τs τ   = reverse (τ:τs) -isNonValueTy :: Type -> Bool-isNonValueTy = GM.isPredType-- GM.isEmbeddedDictType  - 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@@ -1718,7 +1724,7 @@             -> [(Symbol, RFInfo, RType RTyCon RTyVar r, t)] mkProductTy (τ, x, i, t, r) = maybe [(x, i, t, r)] f $ do   DataConAppContext{..} <- deepSplitProductType_maybe menv τ-  pure $ (dcac_dc, dcac_tys, map (\(t,s) -> (irrelevantMult t, s)) dcac_arg_tys, dcac_co)+  pure (dcac_dc, dcac_tys, map (first irrelevantMult) dcac_arg_tys, dcac_co)   where     f    :: (DataCon, [Type], [(Type, StrictnessMark)], Coercion) -> [(Symbol, RFInfo, RType RTyCon RTyVar r, t)]     f    = map ((dummySymbol, defRFInfo, , mempty) . ofType . fst) . third4@@ -1733,14 +1739,14 @@   = [(symbol a, trueSortedReft FFrac) | (RVar a _) <- ts]   | isNumCls c   = [(symbol a, trueSortedReft FNum) | (RVar a _) <- ts]-classBinds emb (RApp c [_, _, (RVar a _), t] _ _)+classBinds emb (RApp c [_, _, RVar a _, t] _ _)   | isEqual c   = [(symbol a, rTypeSortedReft emb t)]-classBinds  emb ty@(RApp c [_, (RVar a _), t] _ _)-  | isEqualityConstr ty +classBinds  emb ty@(RApp c [_, RVar a _, t] _ _)+  | isEqualityConstr ty   = [(symbol a, rTypeSortedReft emb t)]-  | otherwise -  = notracepp ("CLASSBINDS-0: " ++ showpp c) [] +  | otherwise+  = notracepp ("CLASSBINDS-0: " ++ showpp c) [] classBinds _ t   = notracepp ("CLASSBINDS-1: " ++ showpp (toType False t, isEqualityConstr t)) [] @@ -1770,7 +1776,7 @@ makeDecrType :: Symbolic a              => S.HashSet TyCon              -> [(a, (Symbol, RType RTyCon t (UReft Reft)))]-             -> Either (Symbol, RType RTyCon t (UReft Reft)) String +             -> Either (Symbol, RType RTyCon t (UReft Reft)) String makeDecrType autoenv = mkDType autoenv [] []  mkDType :: Symbolic a@@ -1778,7 +1784,7 @@         -> [(Symbol, Symbol, Symbol -> Expr)]         -> [Expr]         -> [(a, (Symbol, RType RTyCon t (UReft Reft)))]-        -> Either (Symbol, RType RTyCon t (UReft Reft)) String +        -> Either (Symbol, RType RTyCon t (UReft Reft)) String mkDType autoenv xvs acc [(v, (x, t))]   = Left ((x, ) $ t `strengthen` tr)   where@@ -1816,7 +1822,8 @@ -- | [NOTE]: THIS IS WHERE THE TERMINATION METRIC REFINEMENTS ARE CREATED. cmpLexRef :: [(t1, t1, t1 -> Expr)] -> (t, t, t -> Expr) -> Expr cmpLexRef vxs (v, x, g)-  = pAnd $  (PAtom Lt (g x) (g v)) : (PAtom Ge (g x) zero)+  = pAnd $   PAtom Lt (g x) (g v)+         :   PAtom Ge (g x) zero          :  [PAtom Eq (f y) (f z) | (y, z, f) <- vxs]          ++ [PAtom Ge (f y) zero  | (y, _, f) <- vxs]   where zero = ECon $ I 0@@ -1833,8 +1840,8 @@ makeLexReft old acc (e:es) (e':es')   = makeLexReft ((e,e'):old) (r:acc) es es'   where-    r    = pAnd $  (PAtom Lt e' e)-                :  (PAtom Ge e' zero)+    r    = pAnd $   PAtom Lt e' e+                :   PAtom Ge e' zero                 :  [PAtom Eq o' o    | (o,o') <- old]                 ++ [PAtom Ge o' zero | (_,o') <- old]     zero = ECon $ I 0@@ -1849,68 +1856,6 @@     defTv                     = makeTyConVariance c  -makeTyConVariance :: TyCon -> VarianceInfo-makeTyConVariance c = varSignToVariance <$> tvs-  where-    tvs = GM.tyConTyVarsDef c--    varsigns = if Ghc.isTypeSynonymTyCon c-                  then go True (fromJust $ Ghc.synTyConRhs_maybe c)-                  else L.nub $ concatMap goDCon $ Ghc.tyConDataCons c--    varSignToVariance v = case filter (\p -> GM.showPpr (fst p) == GM.showPpr v) varsigns of-                            []       -> Invariant-                            [(_, b)] -> if b then Covariant else Contravariant-                            _        -> Bivariant---    goDCon dc = concatMap (go True) (map irrelevantMult $ Ghc.dataConOrigArgTys dc)--    go pos (FunTy _ _ t1 t2) = go (not pos) t1 ++ go pos t2-    go pos (ForAllTy _ t)    = go pos t-    go pos (TyVarTy v)       = [(v, pos)]-    go pos (AppTy t1 t2)     = go pos t1 ++ go pos t2-    go pos (TyConApp c' ts)-       | c == c'-       = []---- NV fix that: what happens if we have mutually recursive data types?--- now just provide "default" Bivariant for mutually rec types.--- but there should be a finer solution-       | mutuallyRecursive c c'-       = concatMap (goTyConApp pos Bivariant) ts-       | otherwise-       = concat $ zipWith (goTyConApp pos) (makeTyConVariance c') ts--    go _   (LitTy _)       = []-    go _   (CoercionTy _)  = []-    go pos (CastTy t _)    = go pos t--    goTyConApp _   Invariant     _ = []-    goTyConApp pos Bivariant     t = goTyConApp pos Contravariant t ++ goTyConApp pos Covariant t-    goTyConApp pos Covariant     t = go pos       t-    goTyConApp pos Contravariant t = go (not pos) t--    mutuallyRecursive c c' = c `S.member` (dataConsOfTyCon c')---dataConsOfTyCon :: TyCon -> S.HashSet TyCon-dataConsOfTyCon = dcs S.empty-  where-    dcs vis c                 = mconcat $ go vis <$> [irrelevantMult t | dc <- Ghc.tyConDataCons c, t <- Ghc.dataConOrigArgTys dc]-    go  vis (FunTy _ _ t1 t2) = go vis t1 `S.union` go vis t2-    go  vis (ForAllTy _ t)    = go vis t-    go  _   (TyVarTy _)       = S.empty-    go  vis (AppTy t1 t2)     = go vis t1 `S.union` go vis t2-    go  vis (TyConApp c ts)-      | c `S.member` vis-      = S.empty-      | otherwise-      = (S.insert c $ mconcat $ go vis <$> ts) `S.union` dcs (S.insert c vis) c-    go  _   (LitTy _)       = S.empty-    go  _   (CoercionTy _)  = S.empty-    go  vis (CastTy t _)    = go vis t- -------------------------------------------------------------------------------- -- | Printing Refinement Types ------------------------------------------------- --------------------------------------------------------------------------------@@ -1933,15 +1878,15 @@ instance PPrint DataCtor where   -- pprintTidy k (DataCtor c as _   xts Nothing)  = pprintTidy k c <+> dcolon ppVars as <+> braces (ppFields k ", " xts)   -- pprintTidy k (DataCtor c as ths xts (Just t)) = pprintTidy k c <+> dcolon <+> ppVars as <+> ppThetas ths <+> (ppFields k " ->" xts) <+> "->" <+> pprintTidy k t-  pprintTidy k (DataCtor c as ths xts t) = pprintTidy k c <+> dcolon <+> ppVars k as <+> ppThetas ths <+> (ppFields k " ->" xts) <+> "->" <+> res +  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 +      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)) <+> "." +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)@@ -1970,34 +1915,34 @@ -- | (in positive positions, in negative positions, in undetermined positions) -- | undetermined positions are due to type constructors and type application --------------------------------------------------------------------------------tyVarsPosition :: RType RTyCon tv r -> Positions tv +tyVarsPosition :: RType RTyCon tv r -> Positions tv tyVarsPosition = go (Just True)-  where +  where     go p (RVar t _)        = report p t-    go p (RFun _ _ t1 t2 _)  = go (flip p) t1 <> go p t2 -    go p (RImpF _ _ t1 t2 _) = go (flip p) t1 <> go p t2 -    go p (RAllT _ t _)     = go p t -    go p (RAllP _ t)       = go p t +    go p (RFun _ _ t1 t2 _)  = go (flip p) t1 <> go p t2+    go p (RImpF _ _ t1 t2 _) = go (flip p) t1 <> go p t2+    go p (RAllT _ t _)     = go p t+    go p (RAllP _ t)       = go p t     go p (RApp c ts _ _)   = mconcat (zipWith go (getPosition p <$> varianceTyArgs (rtc_info c)) ts)-    go p (RAllE _ t1 t2)   = go p t1 <> go p t2 +    go p (RAllE _ t1 t2)   = go p t1 <> go p t2     go p (REx _ t1 t2)     = go p t1 <> go p t2     go _ (RExprArg _)      = mempty-    go p (RAppTy t1 t2 _)  = go p t1 <> go p t2 -    go p (RRTy _ _ _ t)    = go p t +    go p (RAppTy t1 t2 _)  = go p t1 <> go p t2+    go p (RRTy _ _ _ t)    = go p t     go _ (RHole _)         = mempty      getPosition :: Maybe Bool -> Variance -> Maybe Bool-    getPosition b Contravariant = not <$> b -    getPosition b _             = b  +    getPosition b Contravariant = not <$> b+    getPosition b _             = b -    report Nothing v      = (Pos [] [] [v])-    report (Just True) v  = (Pos [v] [] [])-    report (Just False) v = (Pos [] [v] [])+    report Nothing v      = Pos [] [] [v]+    report (Just True) v  = Pos [v] [] []+    report (Just False) v = Pos [] [v] []     flip = fmap not  data Positions a = Pos {ppos :: [a], pneg ::  [a], punknown :: [a]} -instance Monoid (Positions a) where +instance Monoid (Positions a) where   mempty = Pos [] [] []-instance Semigroup (Positions a) where +instance Semigroup (Positions a) where   (Pos x1 x2 x3) <> (Pos y1 y2 y3) = Pos (x1 ++ y1) (x2 ++ y2) (x3 ++ y3)
src/Language/Haskell/Liquid/Types/Specs.hs view
@@ -2,15 +2,13 @@ -- | This module contains the top-level structures that hold  --   information about specifications. -{-# LANGUAGE TypeSynonymInstances       #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE DerivingStrategies         #-} {-# LANGUAGE DerivingVia                #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RecordWildCards            #-} +{-# OPTIONS_GHC -Wno-orphans #-}+ module Language.Haskell.Liquid.Types.Specs (   -- * Different types of specifications   -- $differentSpecTypes@@ -80,8 +78,8 @@ import           Language.Haskell.Liquid.Types.Generics import           Language.Haskell.Liquid.Types.Variance import           Language.Haskell.Liquid.Types.Bounds -import           Language.Haskell.Liquid.GHC.API hiding (text, (<+>))-import           Language.Haskell.Liquid.GHC.Types+import           Liquid.GHC.API hiding (text, (<+>))+import           Liquid.GHC.Types import           Text.PrettyPrint.HughesPJ              (text, (<+>))  @@ -236,6 +234,8 @@   , gsDicts    :: !(DEnv Var LocSpecType)            -- ^ Refined Classes from Instances    , gsMethods  :: ![(Var, MethodType LocSpecType)]   -- ^ Refined Classes from Classes    , gsTexprs   :: ![(Var, LocSpecType, [F.Located F.Expr])]  -- ^ Lexicographically ordered expressions for termination+  , gsRelation :: ![(Var, Var, LocSpecType, LocSpecType, RelExpr, RelExpr)]+  , gsAsmRel   :: ![(Var, Var, LocSpecType, LocSpecType, RelExpr, RelExpr)]   }  instance Semigroup GhcSpecSig where@@ -248,7 +248,8 @@     , gsDicts    = gsDicts x    <> gsDicts y        , gsMethods  = gsMethods x  <> gsMethods y        , gsTexprs   = gsTexprs x   <> gsTexprs y   -+    , gsRelation = gsRelation x <> gsRelation y+    , gsAsmRel   = gsAsmRel x   <> gsAsmRel y     }  @@ -258,7 +259,7 @@   instance Monoid GhcSpecSig where-  mempty = SpSig mempty mempty mempty mempty mempty mempty mempty mempty  +  mempty = SpSig mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty    data GhcSpecData = SpData    { gsCtors      :: ![(Var, LocSpecType)]         -- ^ Data Constructor Measure Sigs@@ -328,7 +329,7 @@                   mempty mempty mempty                   mempty mempty mempty data GhcSpecLaws = SpLaws -  { gsLawDefs :: !([(Class, [(Var, LocSpecType)])])+  { gsLawDefs :: ![(Class, [(Var, LocSpecType)])]   , gsLawInst :: ![LawInstance]   } @@ -408,10 +409,13 @@   , imeasures  :: ![Measure ty bndr]              -- ^ Mappings from (measure,type) -> measure   , classes    :: ![RClass ty]                    -- ^ Refined Type-Classes   , claws      :: ![RClass ty]                    -- ^ Refined Type-Classe Laws+  , relational :: ![(LocSymbol, LocSymbol, ty, ty, RelExpr, RelExpr)] -- ^ Relational types+  , asmRel     :: ![(LocSymbol, LocSymbol, ty, ty, RelExpr, RelExpr)] -- ^ Assumed relational types   , termexprs  :: ![(F.LocSymbol, [F.Located F.Expr])] -- ^ Terminating Conditions for functions   , rinstance  :: ![RInstance ty]   , ilaws      :: ![RILaws ty]   , dvariance  :: ![(F.LocSymbol, [Variance])]         -- ^ ? Where do these come from ?!+  , dsize      :: ![([ty], F.LocSymbol)]      -- ^ Size measure to enforce fancy termination    , bounds     :: !(RRBEnv ty)   , defs       :: !(M.HashMap F.LocSymbol F.Symbol)    -- ^ Temporary (?) hack to deal with dictionaries in specifications                                                        --   see tests/pos/NatClass.hs@@ -449,10 +453,13 @@            , imeasures  =           imeasures  s1 ++ imeasures  s2            , classes    =           classes    s1 ++ classes    s2            , claws      =           claws      s1 ++ claws      s2+           , relational =           relational s1 ++ relational s2 +           , asmRel     =           asmRel     s1 ++ asmRel     s2             , termexprs  =           termexprs  s1 ++ termexprs  s2            , rinstance  =           rinstance  s1 ++ rinstance  s2            , ilaws      =               ilaws  s1 ++ ilaws      s2             , dvariance  =           dvariance  s1 ++ dvariance  s2+           , dsize      =               dsize  s1 ++ dsize      s2            , axeqs      =           axeqs s1      ++ axeqs s2            , embeds     = mappend   (embeds   s1)  (embeds   s2)            , lvars      = S.union   (lvars    s1)  (lvars    s2)@@ -508,11 +515,14 @@            , cmeasures  = []            , imeasures  = []            , classes    = []-           , claws      = [] +           , claws      = []+           , relational = []  +           , asmRel     = []              , termexprs  = []            , rinstance  = []            , ilaws      = []             , dvariance  = []+           , dsize      = []            , axeqs      = []            , bounds     = M.empty            , defs       = M.empty@@ -589,6 +599,7 @@     -- ^ Refined Type-Classe Laws   , liftedRinstance  :: HashSet (RInstance LocBareType)   , liftedIlaws      :: HashSet (RILaws LocBareType)+  , liftedDsize      :: [([LocBareType], F.LocSymbol)]   , liftedDvariance  :: HashSet (F.LocSymbol, [Variance])     -- ^ ? Where do these come from ?!   , liftedBounds     :: RRBEnv LocBareType@@ -630,6 +641,7 @@   , liftedRinstance  = mempty   , liftedIlaws      = mempty   , liftedDvariance  = mempty+  , liftedDsize      = mempty   , liftedBounds     = mempty   , liftedDefs       = mempty   , liftedAxeqs      = mempty@@ -817,6 +829,7 @@       , liftedRinstance  = S.fromList . rinstance $ a       , liftedIlaws      = S.fromList . ilaws $ a       , liftedDvariance  = S.fromList . dvariance $ a+      , liftedDsize      = dsize a        , liftedBounds     = bounds a       , liftedDefs       = defs a       , liftedAxeqs      = S.fromList . axeqs $ a@@ -833,6 +846,8 @@   , sigs       = S.toList . liftedSigs $ a   , localSigs  = mempty   , reflSigs   = mempty+  , relational = mempty +  , asmRel     = mempty    , invariants = S.toList . liftedInvariants $ a   , ialiases   = S.toList . liftedIaliases $ a   , imports    = S.toList . liftedImports $ a@@ -865,6 +880,7 @@   , rinstance  = S.toList . liftedRinstance $ a   , ilaws      = S.toList . liftedIlaws $ a   , dvariance  = S.toList . liftedDvariance $ a+  , dsize      = liftedDsize  a   , bounds     = liftedBounds a   , defs       = liftedDefs a   , axeqs      = S.toList . liftedAxeqs $ a
src/Language/Haskell/Liquid/Types/Types.hs view
@@ -1,23 +1,19 @@-{-# 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              #-}-{-# LANGUAGE DerivingStrategies         #-} {-# LANGUAGE DerivingVia                #-} +{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+ -- | This module should contain all the global type definitions and basic instances.  module Language.Haskell.Liquid.Types.Types (@@ -86,6 +82,9 @@   -- * Refinements   , UReft(..) +  -- * Relational predicates+  , RelExpr (..)+   -- * Parse-time entities describing refined data types   , SizeFun  (..), szFun   , DataDecl (..)@@ -125,7 +124,7 @@   , isBase   , isFunTy   , isTrivial-  , hasHole +  , hasHole    -- * Traversing `RType`   , efoldReft, foldReft, foldReft'@@ -144,7 +143,7 @@   , AnnInfo (..)   , Annot (..) -  -- * Hole Information +  -- * Hole Information   , HoleInfo(..)    -- * Overall Output@@ -204,7 +203,7 @@   , Def (..)   , Body (..)   , MSpec (..)-  +   -- * Scoping Info   , BScope @@ -239,14 +238,14 @@   -- , rtyVarUniqueSymbol, tyVarUniqueSymbol   , rtyVarType, tyVarVar -  -- * Refined Function Info +  -- * Refined Function Info   , RFInfo(..), defRFInfo, mkRFInfo, classRFInfo, classRFInfoType    , ordSrcSpan   )   where -import           Language.Haskell.Liquid.GHC.API as Ghc hiding ( Expr+import           Liquid.GHC.API as Ghc hiding ( Expr                                                                , Target                                                                , isFunTy                                                                , LM@@ -278,7 +277,7 @@ import           Prelude                          hiding  (error) import qualified Prelude -import           Control.Monad                          (liftM, liftM2, liftM3, liftM4)+import           Control.Monad                          (liftM2, liftM3, liftM4, void) import           Control.DeepSeq import           Data.Bifunctor import           Data.Typeable                          (Typeable)@@ -289,19 +288,19 @@ import qualified Data.HashMap.Strict                    as M import qualified Data.HashSet                           as S import qualified Data.List                              as L-import           Data.Maybe                             (fromMaybe, mapMaybe)+import           Data.Maybe                             (mapMaybe) import           Data.Function                          (on) import           Data.List                              as L (foldl', nub, null) import           Data.Text                              (Text)-import           Text.PrettyPrint.HughesPJ              hiding (first, (<>)) +import           Text.PrettyPrint.HughesPJ              hiding (first, (<>)) import           Text.Printf import           Language.Fixpoint.Misc  import qualified Language.Fixpoint.Types as F  import           Language.Haskell.Liquid.Types.Generics-import           Language.Haskell.Liquid.GHC.Misc-import           Language.Haskell.Liquid.GHC.Logging as GHC+import           Liquid.GHC.Misc+import           Liquid.GHC.Logging as GHC import           Language.Haskell.Liquid.Types.Variance import           Language.Haskell.Liquid.Types.Errors import           Language.Haskell.Liquid.Misc@@ -317,25 +316,25 @@ If BScope = False, then the outer binder out is not in scope on ri -} -type BScope = Bool    +type BScope = Bool ----------------------------------------------------------------------------- -- | Information about Type Constructors ------------------------------------------------------------------------------data TyConMap = TyConMap -  { tcmTyRTy    :: M.HashMap TyCon             RTyCon  -- ^ Map from GHC TyCon to RTyCon +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 +  , tcmFtcArity :: M.HashMap TyCon             Int     -- ^ Arity of each Family-Tycon   }-  -data RFInfo = RFInfo {permitTC :: Maybe Bool }++newtype RFInfo = RFInfo {permitTC :: Maybe Bool }   deriving (Generic, Data, Typeable, Show, Eq)  defRFInfo :: RFInfo-defRFInfo = RFInfo Nothing +defRFInfo = RFInfo Nothing  classRFInfo :: Bool -> RFInfo-classRFInfo b = RFInfo (Just b) +classRFInfo b = RFInfo (Just b)  classRFInfoType :: Bool -> RType c tv r -> RType c tv r classRFInfoType b = fromRTypeRep .@@ -343,7 +342,7 @@                     toRTypeRep  mkRFInfo :: Config  -> RFInfo-mkRFInfo cfg = RFInfo $ Just (typeclass cfg)  +mkRFInfo cfg = RFInfo $ Just (typeclass cfg)  instance Hashable RFInfo instance NFData RFInfo@@ -353,17 +352,17 @@ -- | Printer ---------------------------------------------------------------- ----------------------------------------------------------------------------- -data PPEnv = PP -  { ppPs    :: Bool -- ^ print abstract-predicates +data PPEnv = PP+  { ppPs    :: Bool -- ^ print abstract-predicates   , ppTyVar :: Bool -- ^ print the unique suffix for each tyvar-  , ppShort :: Bool -- ^ print the tycons without qualification +  , ppShort :: Bool -- ^ print the tycons without qualification   , ppDebug :: Bool -- ^ gross with full info   }   deriving (Show)  ppEnv :: PPEnv-ppEnv = ppEnvDef -          { ppPs    = True }   +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`@@ -457,7 +456,7 @@ -- TODO: just use Located instead of dc_loc, dc_locE data DataConP = DataConP   { dcpLoc        :: !F.SourcePos-  , dcpCon        :: !DataCon                -- ^ Corresponding GHC DataCon +  , dcpCon        :: !DataCon                -- ^ Corresponding GHC DataCon   , dcpFreeTyVars :: ![RTyVar]               -- ^ Type parameters   , dcpFreePred   :: ![PVar RSort]           -- ^ Abstract Refinement parameters   , dcpTyConstrs  :: ![SpecType]             -- ^ ? Class constraints (via `dataConStupidTheta`)@@ -533,7 +532,7 @@  type UsedPVar      = PVar () -newtype Predicate  = Pr [UsedPVar] +newtype Predicate  = Pr [UsedPVar]   deriving (Generic, Data, Typeable)   deriving Hashable via Generically Predicate @@ -590,7 +589,16 @@  instance NFData r => NFData (UReft r) +data RelExpr = ERBasic F.Expr | ERChecked Expr RelExpr | ERUnChecked Expr RelExpr+  deriving (Eq, Show, Data, Generic) +instance B.Binary RelExpr++instance F.PPrint RelExpr where+  pprintTidy k (ERBasic e)       = F.pprintTidy k e+  pprintTidy k (ERChecked e r)   = F.pprintTidy k e <+> "!=>" <+> F.pprintTidy k r+  pprintTidy k (ERUnChecked e r) = F.pprintTidy k e <+> ":=>" <+> F.pprintTidy k r+ newtype BTyVar = BTV Symbol deriving (Show, Generic, Data, Typeable)  newtype RTyVar = RTV TyVar deriving (Generic, Data, Typeable)@@ -640,7 +648,7 @@   deriving (Generic, Data, Typeable)  instance F.Symbolic RTyCon where-  symbol = F.symbol . rtc_tc +  symbol = F.symbol . rtc_tc  instance F.Symbolic BTyCon where   symbol = F.val . btc_tc@@ -664,7 +672,7 @@ -- | Accessors for @RTyCon@  isBool :: RType RTyCon t t1 -> Bool-isBool (RApp (RTyCon{rtc_tc = c}) _ _ _) = c == boolTyCon+isBool (RApp RTyCon{rtc_tc = c} _ _ _) = c == boolTyCon isBool _                                 = False  isRVar :: RType c tv r -> Bool@@ -782,7 +790,7 @@   -- | "forall x y <z :: Nat, w :: Int> . TYPE"   --               ^^^^^^^^^^^^^^^^^^^ (rt_pvbind)   | RAllP {-      rt_pvbind :: !(PVU c tv)  -- ar (RType c tv ()))+      rt_pvbind :: !(PVU c tv)     , rt_ty     :: !(RType c tv r)     } @@ -855,7 +863,7 @@ makeRTVar a = RTVar a (RTVNoInfo True)  instance (Eq tv) => Eq (RTVar tv s) where-  t1 == t2 = (ty_var_value t1) == (ty_var_value t2)+  t1 == t2 = ty_var_value t1 == ty_var_value t2  data RTVar tv s = RTVar   { ty_var_value :: tv@@ -874,28 +882,28 @@   | RTVInfo { rtv_name   :: Symbol             , rtv_kind   :: s             , rtv_is_val :: Bool-            , rtv_is_pol :: Bool -- true iff the type variable gets instantiated with -                                 -- any refinement (ie is polymorphic on refinements), -                                 -- false iff instantiation is with true refinement +            , rtv_is_pol :: Bool -- true iff the type variable gets instantiated with+                                 -- any refinement (ie is polymorphic on refinements),+                                 -- false iff instantiation is with true refinement             } deriving (Generic, Data, Typeable, Functor)               deriving Hashable via Generically (RTVInfo s)  -setRtvPol :: RTVar tv a -> Bool -> RTVar tv a +setRtvPol :: RTVar tv a -> Bool -> RTVar tv a setRtvPol (RTVar a i) b = RTVar a (i{rtv_is_pol = b})  rTVarToBind :: RTVar RTyVar s  -> Maybe (Symbol, s) rTVarToBind = go . ty_var_info   where-    go (RTVInfo {..}) | rtv_is_val = Just (rtv_name, rtv_kind)-    go _                           = Nothing+    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+tyVarIsVal :: RTVar tv s -> Bool+tyVarIsVal = rtvinfoIsVal . ty_var_info -rtvinfo_is_val :: RTVInfo s -> Bool-rtvinfo_is_val (RTVNoInfo {..}) = False-rtvinfo_is_val (RTVInfo {..})   = rtv_is_val+rtvinfoIsVal :: RTVInfo s -> Bool+rtvinfoIsVal RTVNoInfo{} = False+rtvinfoIsVal RTVInfo{..} = rtv_is_val  instance (B.Binary tv, B.Binary s) => B.Binary (RTVar tv s) instance (NFData tv, NFData s)     => NFData   (RTVar tv s)@@ -964,16 +972,16 @@ type SpecProp    = RRProp    RReft type RRProp r    = Ref       RSort (RRType r) type BRProp r    = Ref       BSort (BRType r)-type SpecRTVar   = RTVar     RTyVar RSort +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 SpecRTEnv   = RTEnv RTyVar SpecType+type BareRTEnv   = RTEnv Symbol BareType+type BareRTAlias = RTAlias Symbol BareType type SpecRTAlias = RTAlias RTyVar SpecType  @@ -1042,9 +1050,9 @@   ppTycon    = text . showPpr    isNumCls c  = maybe False (isClassOrSubClass isNumericClass)-                (tyConClass_maybe $ c)+                (tyConClass_maybe c)   isFracCls c = maybe False (isClassOrSubClass isFractionalClass)-                (tyConClass_maybe $ c)+                (tyConClass_maybe c)   isOrdCls c  = maybe False isOrdClass                 (tyConClass_maybe c)   isEqCls  c  = isPrelEqTyCon c@@ -1081,7 +1089,7 @@ instance Eq BTyCon where   x == y = btc_tc x == btc_tc y -instance Ord BTyCon where +instance Ord BTyCon where   compare x y = compare (btc_tc x) (btc_tc y)  instance F.Fixpoint RTyCon where@@ -1097,12 +1105,12 @@   show = show . F.toFix  instance F.PPrint RTyCon where-  pprintTidy k c -    | ppDebug ppEnv = F.pprintTidy k tc  <-> (angleBrackets $ F.pprintTidy k pvs)+  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 +    where+      tc            = F.symbol (rtc_tc c)+      pvs           = rtc_pvars c  instance F.PPrint BTyCon where   pprintTidy _ = text . F.symbolString . F.val . btc_tc@@ -1116,8 +1124,8 @@ instance Show BTyCon where   show = F.showpp -instance F.Loc BTyCon where -  srcSpan = F.srcSpan . btc_tc +instance F.Loc BTyCon where+  srcSpan = F.srcSpan . btc_tc  -------------------------------------------------------------------------------- -- | Refined Instances ---------------------------------------------------------@@ -1144,16 +1152,16 @@   deriving Hashable via Generically (RISig t)  instance F.PPrint t => F.PPrint (RISig t) where-  pprintTidy k = ppRISig k (empty :: Doc) +  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 +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 +  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)@@ -1166,9 +1174,9 @@ 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 +getMethodType :: MethodType t -> Maybe t+getMethodType (MT (Just t) _ ) = Just t+getMethodType (MT _ t) = t  -------------------------------------------------------------------------- -- | Values Related to Specifications ------------------------------------@@ -1189,13 +1197,13 @@  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)  +++                                         "\nFun Name: " ++ showPpr n +++                                         "\nReal Name: " ++ showPpr v +++                                         "\nData Con: " ++ showPpr c +++                                         "\nArguments:" ++ showPpr bs  ++                                          -- "\nTypes    :" ++ (showPpr ts)  ++-                                         "\nLHS      :" ++ (showPpr lhs) ++-                                         "\nRHS      :" ++ (showPpr rhs)+                                         "\nLHS      :" ++ showPpr lhs +++                                         "\nRHS      :" ++ showPpr rhs  -------------------------------------------------------------------------------- -- | Data type refinements@@ -1223,7 +1231,7 @@   { 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 +  , dcFields :: [(Symbol, BareType)]   -- ^ field-name and field-Type pairs   , dcResult :: Maybe BareType         -- ^ Possible output (if in GADT form)   } deriving (Data, Typeable, Generic)     deriving Hashable via Generically DataCtor@@ -1311,7 +1319,7 @@   show (DnCon  c) = "datacon:" ++ show (F.val c)  instance F.PPrint SizeFun where-  pprintTidy _ (IdSizeFun)    = "[id]"+  pprintTidy _ IdSizeFun      = "[id]"   pprintTidy _ (SymSizeFun x) = brackets (F.pprint (F.val x))  instance F.Symbolic DataName where@@ -1367,11 +1375,11 @@   , ty_info   :: [RFInfo]   , ty_refts  :: [r]   , ty_args   :: [RType c tv r]-  , ty_res    :: (RType c tv r)+  , ty_res    :: RType c tv r   }  fromRTypeRep :: RTypeRep c tv r -> RType c tv r-fromRTypeRep (RTypeRep {..})+fromRTypeRep RTypeRep{..}   = mkArrow ty_vars ty_preds earrs arrs ty_res   where     arrs  = safeZip4WithError ("fromRTypeRep: " ++ show (length ty_binds, length ty_info, length ty_args, length ty_refts)) ty_binds ty_info ty_args ty_refts@@ -1407,7 +1415,7 @@                            , ([Symbol], [RFInfo], [RType t t1 a], [a])                            , RType t t1 a ) bkArrow t                = ((xs,is,ts,rs),(xs',is',ts',rs'),t'')-  where +  where     (xs, is, ts, rs, t')     = bkImp t     (xs', is', ts', rs', t'') = bkFun t' @@ -1420,11 +1428,11 @@ bkImp (RImpF x i t t' r) = let (xs, is, ts, rs, t'') = bkImp t'  in (x:xs, i:is, t:ts, r:rs, t'') bkImp t                  = ([], [], [], [], t) -safeBkArrow ::(F.PPrint (RType t t1 a)) +safeBkArrow ::(F.PPrint (RType t t1 a))             => RType t t1 a -> ( ([Symbol], [RFInfo], [RType t t1 a], [a])                                , ([Symbol], [RFInfo], [RType t t1 a], [a])                                , RType t t1 a )-safeBkArrow t@(RAllT _ _ _) = Prelude.error {- panic Nothing -} $ "safeBkArrow on RAllT" ++ F.showpp t+safeBkArrow t@RAllT {} = Prelude.error {- panic Nothing -} $ "safeBkArrow on RAllT" ++ F.showpp t safeBkArrow (RAllP _ _)     = Prelude.error {- panic Nothing -} "safeBkArrow on RAllP" safeBkArrow t               = bkArrow t @@ -1436,8 +1444,8 @@ mkUnivs αs πs t = foldr (\(a,r) t -> RAllT a t r) (foldr RAllP t πs) αs  bkUnivClass :: SpecType -> ([(SpecRTVar, RReft)],[PVar RSort], [(RTyCon, [SpecType])], SpecType )-bkUnivClass t        = (as, ps, cs, t2) -  where +bkUnivClass t        = (as, ps, cs, t2)+  where     (as, ps, t1) = bkUniv  t     (cs, t2)     = bkClass t1 @@ -1530,8 +1538,8 @@    ofUReft _ = mempty  instance (F.PPrint r, F.Reftable r) => F.Reftable (UReft r) where-  isTauto               = isTauto_ureft-  ppTy                  = ppTy_ureft+  isTauto               = isTautoUreft+  ppTy                  = ppTyUreft   toReft (MkUReft r ps) = F.toReft r `F.meet` F.toReft ps   params (MkUReft r _)  = F.params r   bot (MkUReft r _)     = MkUReft (F.bot r) (Pr [])@@ -1543,24 +1551,24 @@   -isTauto_ureft :: F.Reftable r => UReft r -> Bool-isTauto_ureft u      = F.isTauto (ur_reft u) && F.isTauto (ur_pred u) +isTautoUreft :: F.Reftable r => UReft r -> Bool+isTautoUreft u = F.isTauto (ur_reft u) && F.isTauto (ur_pred u) -ppTy_ureft :: F.Reftable r => UReft r -> Doc -> Doc-ppTy_ureft u@(MkUReft r p) d-  | isTauto_ureft  u  = d-  | otherwise         = ppr_reft r (F.ppTy p d)+ppTyUreft :: F.Reftable r => UReft r -> Doc -> Doc+ppTyUreft u@(MkUReft r p) d+  | isTautoUreft u = d+  | otherwise      = pprReft r (F.ppTy p d) -ppr_reft :: (F.Reftable r) => r -> Doc -> Doc-ppr_reft r d = braces (F.pprint v <+> colon <+> d <+> text "|" <+> F.pprint r')+pprReft :: (F.Reftable r) => r -> Doc -> Doc+pprReft r d = braces (F.pprint v <+> colon <+> d <+> text "|" <+> F.pprint r')   where     r'@(F.Reft (v, _)) = F.toReft r  instance F.Subable r => F.Subable (UReft r) where   syms (MkUReft r p)     = F.syms r ++ F.syms p-  subst s (MkUReft r z)  = MkUReft (F.subst s r)  (F.subst s z)  -  substf f (MkUReft r z) = MkUReft (F.substf f r) (F.substf f z) -  substa f (MkUReft r z) = MkUReft (F.substa f r) (F.substa f z) +  subst s (MkUReft r z)  = MkUReft (F.subst s r)  (F.subst s z)+  substf f (MkUReft r z) = MkUReft (F.substf f r) (F.substf f z)+  substa f (MkUReft r z) = MkUReft (F.substa f r) (F.substa f z)  instance (F.Reftable r, TyConable c) => F.Subable (RTProp c tv r) where   syms (RProp  ss r)     = (fst <$> ss) ++ F.syms r@@ -1591,7 +1599,7 @@   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)+           | otherwise        = d <-> angleBrackets (F.pprint r)    toReft (Pr ps@(p:_))        = F.Reft (parg p, F.pAnd $ pToRef <$> ps)   toReft _                    = mempty@@ -1600,7 +1608,7 @@   ofReft = todo Nothing "TODO: Predicate.ofReft"  pToRef :: PVar a -> F.Expr-pToRef p = pApp (pname p) $ (F.EVar $ parg p) : (thd3 <$> pargs p)+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)@@ -1622,7 +1630,7 @@ -- const False (not dropping dict) is probably fine since there will not be refinement on -- dictionaries isTrivial :: (F.Reftable r, TyConable c) => RType c tv r -> Bool-isTrivial t = foldReft False (\_ r b -> F.isTauto r && b) True t+isTrivial = foldReft False (\_ r b -> F.isTauto r && b) True  mapReft ::  (r1 -> r2) -> RType c tv r1 -> RType c tv r2 mapReft f = emapReft (const f) []@@ -1648,9 +1656,9 @@ emapExprArg :: ([Symbol] -> Expr -> Expr) -> [Symbol] -> RType c tv r -> RType c tv r emapExprArg f = go   where-    go _ t@(RVar {})        = t-    go _ t@(RHole {})       = t-    go γ (RAllT α t r)      = RAllT α (go γ t) r +    go _ t@RVar{}           = t+    go _ t@RHole{}          = t+    go γ (RAllT α t r)      = RAllT α (go γ t) r     go γ (RAllP π t)        = RAllP π (go γ t)     go γ (RImpF x i t t' r) = RImpF x i (go γ t) (go (x:γ) t') r     go γ (RFun x i t t' r)  = RFun  x i (go γ t) (go (x:γ) t') r@@ -1660,18 +1668,18 @@     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)+    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 _ RHole{}) = a     prep a (RProp _ t)      = step a t-    go a (RVar {})          = a-    go a (RHole {})         = a-    go a (RExprArg {})      = a+    go a RVar{}             = a+    go a RHole{}            = a+    go a RExprArg{}         = a     go a (RAllT _ t _)      = step a t     go a (RAllP _ t)        = step a t     go a (RImpF _ _ t t' _) = foldl' step a [t, t']@@ -1696,8 +1704,8 @@ isBase (RAllP _ t)      = isBase t isBase (RVar _ _)       = True isBase (RApp _ ts _ _)  = all isBase ts-isBase (RImpF _ _ _ _ _)  = False-isBase (RFun _ _ _ _ _)   = False+isBase RImpF{}          = False+isBase RFun{}           = False isBase (RAppTy t1 t2 _) = isBase t1 && isBase t2 isBase (RRTy _ _ _ t)   = isBase t isBase (RAllE _ _ t)    = isBase t@@ -1705,17 +1713,17 @@ isBase _                = False  hasHoleTy :: RType t t1 t2 -> Bool-hasHoleTy (RVar _ _)       = False -hasHoleTy (RAllT _ t _)    = hasHoleTy t +hasHoleTy (RVar _ _)       = False+hasHoleTy (RAllT _ t _)    = hasHoleTy t hasHoleTy (RAllP _ t)      = hasHoleTy t hasHoleTy (RImpF _ _ t t' _) = hasHoleTy t || hasHoleTy t' hasHoleTy (RFun _ _ t t' _)  = hasHoleTy t || hasHoleTy t'-hasHoleTy (RApp _ ts _ _)  = any hasHoleTy ts +hasHoleTy (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 (RExprArg _)     = False hasHoleTy (RAppTy t t' _)  = hasHoleTy t || hasHoleTy t'-hasHoleTy (RHole _)        = True +hasHoleTy (RHole _)        = True hasHoleTy (RRTy xts _ _ t) = hasHoleTy t || any hasHoleTy (snd <$> xts)  @@ -1724,15 +1732,15 @@ isFunTy (RAllE _ _ t)    = isFunTy t isFunTy (RAllT _ t _)    = isFunTy t isFunTy (RAllP _ t)      = isFunTy t-isFunTy (RImpF _ _ _ _ _)= True-isFunTy (RFun _ _ _ _ _) = True+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 (RVar α r)         = fmap    (RVar  α)   (f r) mapReftM f (RAllT α t r)      = liftM2  (RAllT α)   (mapReftM f t)          (f r)-mapReftM f (RAllP π t)        = liftM   (RAllP π)   (mapReftM f t)+mapReftM f (RAllP π t)        = fmap    (RAllP π)   (mapReftM f t) mapReftM f (RImpF x i t t' r) = liftM3  (RImpF x i) (mapReftM f t)          (mapReftM f t')       (f r) mapReftM f (RFun x i t t' r)  = liftM3  (RFun x i)  (mapReftM f t)          (mapReftM f t')       (f r) mapReftM f (RApp c ts rs r)   = liftM3  (RApp  c)   (mapM (mapReftM f) ts)  (mapM (mapRefM f) rs) (f r)@@ -1740,16 +1748,16 @@ 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 (RHole r)          = fmap    RHole       (f r) mapReftM f (RRTy xts r o t)   = liftM4  RRTy (mapM (mapSndM (mapReftM f)) xts) (f r) (return o) (mapReftM f t) -mapRefM  :: (Monad m) => (t -> m s) -> (RTProp c tv t) -> m (RTProp c tv s)-mapRefM  f (RProp s t)         = liftM   (RProp s)      (mapReftM f t)+mapRefM  :: (Monad m) => (t -> m s) -> RTProp c tv t -> m (RTProp c tv s)+mapRefM  f (RProp s t)        = fmap    (RProp s)      (mapReftM f t)  mapPropM :: (Monad m) => (RTProp c tv r -> m (RTProp c tv r)) -> RType c tv r -> m (RType c tv r) mapPropM _ (RVar α r)         = return $ RVar  α r mapPropM f (RAllT α t r)      = liftM2  (RAllT α)   (mapPropM f t)          (return r)-mapPropM f (RAllP π t)        = liftM   (RAllP π)   (mapPropM f t)+mapPropM f (RAllP π t)        = fmap    (RAllP π)   (mapPropM f t) mapPropM f (RImpF x i t t' r) = liftM3  (RImpF x i)    (mapPropM f t)         (mapPropM f t') (return r) mapPropM f (RFun x i t t' r)  = liftM3  (RFun x i)    (mapPropM f t)          (mapPropM f t') (return r) mapPropM f (RApp c ts rs r)   = liftM3  (RApp  c)   (mapM (mapPropM f) ts)  (mapM f rs)     (return r)@@ -1779,10 +1787,10 @@           -> (F.SEnv b -> Maybe (RType c tv r) -> r -> a -> a)           -> a -> RType c tv r -> a ---------------------------------------------------------------------------------foldReft' logicBind bsc g f -  = efoldReft logicBind bsc +foldReft' logicBind bsc g f+  = efoldReft logicBind bsc               (\_ _ -> [])-              (\_ -> [])+              (const [])               g               (\γ t r z -> f γ t r z)               (\_ γ -> γ)@@ -1808,10 +1816,10 @@     -- folding over RType     go γ z me@(RVar _ r)                = f γ (Just me) r z     go γ z me@(RAllT a t r)-       | ty_var_is_val a                = f γ (Just me) r (go (insertsSEnv γ (dty a)) z t)+       | tyVarIsVal a                   = f γ (Just me) r (go (insertsSEnv γ (dty a)) z t)        | otherwise                      = f γ (Just me) r (go γ z t)     go γ z (RAllP p t)                  = go (fp p γ) z t-    go γ z (RImpF x i t t' r)             = go γ z (RFun x i t t' r)+    go γ z (RImpF x i t t' r)           = go γ z (RFun x i t t' r)     go γ z me@(RFun _ RFInfo{permitTC = permitTC} (RApp c ts _ _) t' r)        | (if permitTC == Just True then isEmbeddedDict else isClass)          c  = f γ (Just me) r (go (insertsSEnv γ (cb c ts)) (go' γ z ts) t')@@ -1821,7 +1829,7 @@        where          γ'                             = insertSEnv x (g t) γ     go γ z me@(RApp _ ts rs r)          = f γ (Just me) r (ho' γ (go' γ' z ts) rs)-       where γ' = if bsc then insertSEnv (rTypeValueVar me) (g me) γ else γ +       where γ' = if bsc then insertSEnv (rTypeValueVar me) (g me) γ else γ      go γ z (RAllE x t t')               = go (insertSEnv x (g t) γ) (go γ z t) t'     go γ z (REx x t t')                 = go (insertSEnv x (g t) γ) (go γ z t) t'@@ -1833,7 +1841,7 @@      -- 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+    ho  γ z (RProp ss t)               = go (insertsSEnv γ (mapSnd (g . ofRSort) <$> ss)) z t      -- folding over [RType]     go' γ z ts                 = foldr (flip $ go γ) z ts@@ -1902,7 +1910,7 @@ ofRSort = fmap mempty  toRSort :: RType c tv r -> RType c tv ()-toRSort = stripAnnotations . mapBind (const F.dummySymbol) . fmap (const ())+toRSort = stripAnnotations . mapBind (const F.dummySymbol) . void  stripAnnotations :: RType c tv r -> RType c tv r stripAnnotations (RAllT α t r)    = RAllT α (stripAnnotations t) r@@ -1930,7 +1938,7 @@ 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+rTypeReft = maybe F.trueReft F.toReft . stripRTypeBase  -- stripRTypeBase ::  RType a -> Maybe a stripRTypeBase :: RType c tv r -> Maybe r@@ -1945,7 +1953,7 @@ stripRTypeBase (RAppTy _ _ x)   = Just x stripRTypeBase (RAllT _ _ x)-  = Just x +  = Just x stripRTypeBase _   = Nothing @@ -1965,12 +1973,12 @@ -----------------------------------------------------------------------------  instance F.PPrint (PVar a) where-  pprintTidy _ = ppr_pvar+  pprintTidy _ = pprPvar -ppr_pvar :: PVar a -> Doc-ppr_pvar (PV s _ _ xts) = F.pprint s <+> hsep (F.pprint <$> dargs xts)+pprPvar :: PVar a -> Doc+pprPvar (PV s _ _ xts) = F.pprint s <+> hsep (F.pprint <$> dargs xts)   where-    dargs               = map thd3 . takeWhile (\(_, x, y) -> F.EVar x /= y)+    dargs              = map thd3 . takeWhile (\(_, x, y) -> F.EVar x /= y)   instance F.PPrint Predicate where@@ -1985,14 +1993,14 @@ --   + global : many bindings, shared across all constraints --   + local  : few bindings, relevant to particular constraints -type REnv = AREnv SpecType +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 +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@@ -2011,14 +2019,14 @@     $+$     F.pprintTidy k (reGlobal re) -instance Semigroup REnv where -  REnv g1 l1 <> REnv g2 l2 = REnv (g1 <> g2) (l1 <> l2)  +instance Semigroup REnv where+  REnv g1 l1 <> REnv g2 l2 = REnv (g1 <> g2) (l1 <> l2) -instance Monoid REnv where +instance Monoid REnv where   mempty = REnv mempty mempty  instance NFData REnv where-  rnf (REnv {}) = ()+  rnf REnv{} = ()  -------------------------------------------------------------------------------- -- | Diagnostic info -----------------------------------------------------------@@ -2080,11 +2088,12 @@ -- | Source Information Associated With Constraints ---------------------------- -------------------------------------------------------------------------------- -data Cinfo    = Ci { ci_loc :: !SrcSpan-                   , ci_err :: !(Maybe Error)-                   , ci_var :: !(Maybe Var)-                   }-                deriving (Eq, Generic)+data Cinfo    = Ci+  { ci_loc :: !SrcSpan+  , ci_err :: !(Maybe Error)+  , ci_var :: !(Maybe Var)+  }+  deriving (Eq, Generic)  instance F.Loc Cinfo where   srcSpan = srcSpanFSrcSpan . ci_loc@@ -2095,16 +2104,16 @@ -- | Module Names -------------------------------------------------------------- -------------------------------------------------------------------------------- -data ModName = ModName !ModType !ModuleName +data ModName = ModName !ModType !ModuleName   deriving (Eq, Ord, Show, Generic, Data, Typeable) -data ModType = Target | SrcImport | SpecImport +data ModType = Target | SrcImport | SpecImport   deriving (Eq, Ord, Show, Generic, Data, Typeable) --- instance B.Binary ModType --- instance B.Binary ModName +-- instance B.Binary ModType+-- instance B.Binary ModName -instance Hashable ModType +instance Hashable ModType  instance Hashable ModName where   hashWithSalt i (ModName t n) = hashWithSalt i (t, show n)@@ -2119,9 +2128,9 @@   symbol = F.symbol . moduleNameFS  -isTarget :: ModName -> Bool -isTarget (ModName Target _) = True -isTarget _                  = False +isTarget :: ModName -> Bool+isTarget (ModName Target _) = True+isTarget _                  = False  isSrcImport :: ModName -> Bool isSrcImport (ModName SrcImport _) = True@@ -2158,7 +2167,7 @@ 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)) +-- 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) } @@ -2191,7 +2200,7 @@   { msName :: F.LocSymbol   , msSort :: ty   , msEqns :: [Def ty ctor]-  , msKind :: !MeasureKind +  , msKind :: !MeasureKind   , msUnSorted :: !UnSortedExprs -- potential unsorted expressions used at measure denifinitions   } deriving (Eq, Data, Typeable, Generic, Functor)     deriving Hashable via Generically (Measure ty ctor)@@ -2199,32 +2208,32 @@ type UnSortedExprs = [UnSortedExpr] -- mempty = [] type UnSortedExpr  = ([F.Symbol], F.Expr) -data MeasureKind -  = MsReflect     -- ^ due to `reflect foo` +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 +  | 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 ...` +  | MsSelector    -- ^ due to selector-fields e.g. `data Foo = Foo { fld :: Int }`+  | MsChecker     -- ^ due to checkers  e.g. `is-F` for `data Foo = F ... | G ...`   deriving (Eq, Ord, Show, Data, Typeable, Generic)   deriving Hashable via Generically MeasureKind -instance F.Loc (Measure a b) where +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+  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 +  second f (M n s es k u) = M n s (second f <$> es)    k u -instance                             B.Binary MeasureKind +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)@@ -2266,7 +2275,7 @@   instance F.Subable (Measure ty ctor) where-  syms  m     = concatMap F.syms (msEqns m) +  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 }@@ -2313,44 +2322,44 @@     deriving Hashable via Generically (RClass ty)  -instance F.PPrint t => F.PPrint (RClass t) where -  pprintTidy k (RClass n ts as mts) -                = ppMethods k ("class" <+> supers ts) n as [(m, RISig t) | (m, t) <- mts] -    where -      supers [] = "" +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 [] = "" +  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) +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 +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 +      bind m t = F.pprintTidy k m <+> "=" <+> F.pprintTidy k t -ppMethods :: (F.PPrint x, F.PPrint t, F.PPrint a, F.PPrint n) +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 +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 +      bind m t = ppRISig k m t -- F.pprintTidy k m <+> "::" <+> F.pprintTidy k t  instance B.Binary ty => B.Binary (RClass ty) @@ -2361,12 +2370,12 @@  data HoleInfo i t = HoleInfo {htype :: t, hloc :: SrcSpan, henv :: AREnv t, info :: i } -instance Functor (HoleInfo i) where +instance Functor (HoleInfo i) where   fmap f hinfo = hinfo{htype = f (htype hinfo), henv = fmap f (henv hinfo)}  instance (F.PPrint t) => F.PPrint (HoleInfo  i t) where-  pprintTidy k hinfo = text "type:" <+> F.pprintTidy k (htype hinfo) -                       <+> text "\n loc:" <+> F.pprintTidy k (hloc hinfo) +  pprintTidy k hinfo = text "type:" <+> F.pprintTidy k (htype hinfo)+                       <+> text "\n loc:" <+> F.pprintTidy k (hloc hinfo)   -- to print the hole environment uncomment the following   --                     <+> text "\n env:" <+> F.pprintTidy k (henv hinfo) @@ -2476,8 +2485,8 @@ hole = F.PKVar "HOLE" mempty  isHole :: Expr -> Bool-isHole (F.PKVar ("HOLE") _) = True-isHole _                    = False+isHole (F.PKVar "HOLE" _) = True+isHole _                  = False  hasHole :: F.Reftable r => r -> Bool hasHole = any isHole . F.conjuncts . F.reftPred . F.toReft@@ -2488,20 +2497,20 @@ instance F.PPrint DataCon where   pprintTidy _ = text . showPpr -instance Ord TyCon where -  compare = compare `on` F.symbol +instance Ord TyCon where+  compare = compare `on` F.symbol -instance Ord DataCon where -  compare = compare `on` F.symbol +instance Ord DataCon where+  compare = compare `on` F.symbol -instance F.PPrint TyThing where -  pprintTidy _ = text . showPpr +instance F.PPrint TyThing where+  pprintTidy _ = text . showPpr  instance Show DataCon where   show = F.showpp --- instance F.Symbolic TyThing where ---  symbol = tyThingSymbol +-- instance F.Symbolic TyThing where+--  symbol = tyThingSymbol  liquidBegin :: String liquidBegin = ['{', '-', '@']@@ -2524,7 +2533,7 @@   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+  pprintTidy k =  vcat . fmap (F.pprintTidy k . snd) . M.toList . measMap  instance (Show ty, Show ctor, F.PPrint ctor, F.PPrint ty) => Show (MSpec ty ctor) where   show (MSpec ct m cm im)
src/Language/Haskell/Liquid/Types/Variance.hs view
@@ -1,21 +1,33 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric      #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DerivingVia        #-} -module Language.Haskell.Liquid.Types.Variance ( Variance(..), VarianceInfo ) where+{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- TODO(#1918): Only needed for GHC <9.0.1.+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-} +module Language.Haskell.Liquid.Types.Variance (+  Variance(..), VarianceInfo, makeTyConVariance, flipVariance+  ) where+ import Prelude hiding (error) import Control.DeepSeq-import Data.Typeable-import Data.Data+import Data.Typeable hiding (TyCon)+import Data.Data     hiding (TyCon) import GHC.Generics import Data.Binary import Data.Hashable import Text.PrettyPrint.HughesPJ++import           Data.Maybe                (fromJust)+import qualified Data.List               as L+import qualified Data.HashSet            as S+ import qualified Language.Fixpoint.Types as F -import Language.Haskell.Liquid.Types.Generics+import           Language.Haskell.Liquid.Types.Generics+import qualified Liquid.GHC.Misc as GM+import           Liquid.GHC.API        as Ghc hiding (text)  type VarianceInfo = [Variance] @@ -23,7 +35,89 @@               deriving (Eq, Data, Typeable, Show, Generic)               deriving Hashable via Generically Variance +flipVariance :: Variance -> Variance+flipVariance Invariant     = Invariant+flipVariance Bivariant     = Bivariant+flipVariance Contravariant = Covariant+flipVariance Covariant     = Contravariant++instance Semigroup Variance where+  Bivariant     <> _         = Bivariant+  _             <> Bivariant = Bivariant+  Invariant     <> v         = v+  v             <> Invariant = v+  Covariant     <> v         = v+  Contravariant <> v         = flipVariance v++instance Monoid Variance where+  mempty = Bivariant+ instance Binary Variance instance NFData Variance instance F.PPrint Variance where   pprintTidy _ = text . show++++makeTyConVariance :: TyCon -> VarianceInfo+makeTyConVariance c = varSignToVariance <$> tvs+  where+    tvs = GM.tyConTyVarsDef c++    varsigns = if Ghc.isTypeSynonymTyCon c+                  then go True (fromJust $ Ghc.synTyConRhs_maybe c)+                  else L.nub $ concatMap goDCon $ Ghc.tyConDataCons c++    varSignToVariance v = case filter (\p -> GM.showPpr (fst p) == GM.showPpr v) varsigns of+                            []       -> Invariant+                            [(_, b)] -> if b then Covariant else Contravariant+                            _        -> Bivariant+++    goDCon dc = concatMap (go True . irrelevantMult) (Ghc.dataConOrigArgTys dc)++    go pos (FunTy _ _ t1 t2) = go (not pos) t1 ++ go pos t2+    go pos (ForAllTy _ t)    = go pos t+    go pos (TyVarTy v)       = [(v, pos)]+    go pos (AppTy t1 t2)     = go pos t1 ++ go pos t2+    go pos (TyConApp c' ts)+       | c == c'+       = []++-- NV fix that: what happens if we have mutually recursive data types?+-- now just provide "default" Bivariant for mutually rec types.+-- but there should be a finer solution+       | mutuallyRecursive c c'+       = concatMap (goTyConApp pos Bivariant) ts+       | otherwise+       = concat $ zipWith (goTyConApp pos) (makeTyConVariance c') ts++    go _   (LitTy _)       = []+    go _   (CoercionTy _)  = []+    go pos (CastTy t _)    = go pos t++    goTyConApp _   Invariant     _ = []+    goTyConApp pos Bivariant     t = goTyConApp pos Contravariant t ++ goTyConApp pos Covariant t+    goTyConApp pos Covariant     t = go pos       t+    goTyConApp pos Contravariant t = go (not pos) t++    mutuallyRecursive c c' = c `S.member` dataConsOfTyCon c'+++dataConsOfTyCon :: TyCon -> S.HashSet TyCon+dataConsOfTyCon = dcs S.empty+  where+    dcs vis c                 = mconcat $ go vis <$> [irrelevantMult t | dc <- Ghc.tyConDataCons c, t <- Ghc.dataConOrigArgTys dc]+    go  vis (FunTy _ _ t1 t2) = go vis t1 `S.union` go vis t2+    go  vis (ForAllTy _ t)    = go vis t+    go  _   (TyVarTy _)       = S.empty+    go  vis (AppTy t1 t2)     = go vis t1 `S.union` go vis t2+    go  vis (TyConApp c ts)+      | c `S.member` vis+      = S.empty+      | otherwise+      = S.insert c (mconcat $ go vis <$> ts) `S.union` dcs (S.insert c vis) c+    go  _   (LitTy _)       = S.empty+    go  _   (CoercionTy _)  = S.empty+    go  vis (CastTy t _)    = go vis t+
src/Language/Haskell/Liquid/Types/Visitors.hs view
@@ -1,18 +1,15 @@ {-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE TypeSynonymInstances      #-} {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE DeriveDataTypeable        #-} {-# LANGUAGE ScopedTypeVariables       #-}-+{-# OPTIONS_GHC -Wno-name-shadowing #-}  module Language.Haskell.Liquid.Types.Visitors (-  +   CBVisitable (..)-  +   -- * visitors-  , coreVisitor +  , coreVisitor   , CoreVisitor (..)    ) where@@ -23,8 +20,8 @@ import qualified Data.HashSet                     as S import           Prelude                          hiding (error) import           Language.Fixpoint.Misc-import           Language.Haskell.Liquid.GHC.API-import           Language.Haskell.Liquid.GHC.Misc ()+import           Liquid.GHC.API+import           Liquid.GHC.Misc ()   ------------------------------------------------------------------------------@@ -75,7 +72,7 @@ exprFreeVars :: S.HashSet Id -> Expr Id -> [Id] exprFreeVars = go   where-    go env (Var x)         = if x `S.member` env then [] else [x]+    go env (Var x)         = [x | not (x `S.member` env)]     go env (App e a)       = go env e ++ go env a     go env (Lam x e)       = go (extendEnv env [x]) e     go env (Let b e)       = freeVars env b ++ go (extendEnv env (bindings b)) e@@ -155,22 +152,22 @@ ---------------------------------------------------------------------------------------- -- | @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 +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) +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  +    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 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) @@ -181,18 +178,18 @@         -- es                       = snd <$> xes         -- foldl' (\(env, acc) (x, e) ->  ) -    stepE env acc e              = goE env (exprF vis env acc e) 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 _   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 (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 +    goE _   acc _                = acc -    goC env acc (_, xs, e)       = stepE  env' acc' e +    goC env acc (_, xs, e)       = stepE  env' acc' e       where-        env'                     = foldl' (envF  vis)     env xs +        env'                     = foldl' (envF  vis)     env xs         acc'                     = foldl' (bindF vis env) acc xs
src/Language/Haskell/Liquid/UX/ACSS.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wno-name-shadowing #-}+ -- | Formats Haskell source code as HTML with CSS and Mouseover Type Annotations module Language.Haskell.Liquid.UX.ACSS (     hscolour@@ -10,7 +12,7 @@   ) where  import Prelude hiding (error)-import qualified Language.Haskell.Liquid.GHC.API as SrcLoc+import qualified Liquid.GHC.API as SrcLoc  import Language.Haskell.HsColour.Anchors import Language.Haskell.HsColour.Classify as Classify@@ -20,13 +22,13 @@ import Data.Either (partitionEithers) import Data.Maybe  (fromMaybe) import qualified Data.HashMap.Strict as M-import Data.List   (find, isPrefixOf, findIndex, elemIndices, intercalate)+import Data.List   (find, isPrefixOf, findIndex, elemIndices, intercalate, elemIndex) import Data.Char   (isSpace) import Text.Printf-import Language.Haskell.Liquid.GHC.Misc+import Liquid.GHC.Misc import Language.Haskell.Liquid.Types.Errors (panic, impossible) -data AnnMap  = Ann +data AnnMap  = Ann   { types   :: M.HashMap Loc (String, String) -- ^ Loc -> (Var, Type)   , errors  :: [(Loc, Loc, String)]           -- ^ List of error intervals   , status  :: !Status@@ -79,7 +81,7 @@     . annotTokenise baseLoc tx  tokeniseWithLoc :: CommentTransform -> String -> [(TokenType, String, Loc)]-tokeniseWithLoc tx str = zipWith (\(x,y) z -> (x, y, z)) toks spans  +tokeniseWithLoc tx str = zipWith (\(x,y) z -> (x, y, z)) toks spans   where     toks       = tokeniseWithCommentTransform tx str     spans      = tokenSpans Nothing $ map snd toks@@ -98,7 +100,7 @@ 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]+    e = "ERROR" <$ find (span `inRange`) [(x,y) | (x,y,_) <- es]     b = spanLine w span  spanLine :: t -> Loc -> Maybe (Int, t)@@ -122,8 +124,8 @@ plusLoc :: Loc -> String -> Loc plusLoc (L (l, c)) s   = case '\n' `elemIndices` s of-      [] -> L (l, (c + n))-      is -> L ((l + length is), (n - maximum is))+      [] -> L (l, c + n)+      is -> L (l + length is, n - maximum is)     where n = length s  renderAnnotToken :: (TokenType, String, Annotation) -> String@@ -148,7 +150,7 @@ renderLinAnnot Nothing  s   = s  lineString :: Show t => (t, Int) -> [Char]-lineString (i, w) = (replicate (w - (length is)) ' ') ++ is+lineString (i, w) = replicate (w - length is) ' ' ++ is   where is        = show i  {- Example Annotation:@@ -164,10 +166,10 @@  stitch ::  Eq b => [(b, c)] -> [Either a b] -> [Either a c] stitch xys ((Left a) : rest)-  = (Left a) : stitch xys rest+  = Left a : stitch xys rest stitch ((x,y):xys) ((Right x'):rest)   | x == x'-  = (Right y) : stitch xys rest+  = Right y : stitch xys rest   | otherwise   = panic Nothing "stitch" stitch _ []@@ -178,7 +180,7 @@ splitSrcAndAnns ::  String -> (String, AnnMap) splitSrcAndAnns s =   let ls = lines s in-  case findIndex (breakS ==) ls of+  case elemIndex breakS ls of     Nothing -> (s, Ann M.empty [] Safe mempty)     Just i  -> (src, ann)                where (codes, _:mname:annots) = splitAt i ls@@ -190,7 +192,7 @@  tokenModule :: [(TokenType, [Char])] -> Maybe [Char] tokenModule toks-  = do i <- findIndex ((Keyword, "module") ==) toks+  = do i <- elemIndex (Keyword, "module") toks        let (_, toks')  = splitAt (i+2) toks        j <- findIndex ((Space ==) . fst) toks'        let (toks'', _) = splitAt j toks'@@ -217,19 +219,19 @@  parseLines mname i (_:_:l:c:"0":l':c':rest')   = Right (L (line, col), L (line', col')) : parseLines mname (i + 7) rest'-    where line  = (read l)  :: Int-          col   = (read c)  :: Int-          line' = (read l') :: Int-          col'  = (read c') :: Int+    where line  = read l  :: Int+          col   = read c  :: Int+          line' = read l' :: Int+          col'  = read c' :: Int  parseLines mname i (x:f:l:c:n:rest)   | f /= mname   = parseLines mname (i + 5 + num) rest'   | otherwise   = Left (L (line, col), (x, anns)) : parseLines mname (i + 5 + num) rest'-    where line  = (read l) :: Int-          col   = (read c) :: Int-          num   = (read n) :: Int+    where line  = read l :: Int+          col   = read c :: Int+          num   = read n :: Int           anns  = intercalate "\n" $ take num rest           rest' = drop num rest @@ -237,9 +239,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
@@ -1,10 +1,10 @@ {-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE TupleSections              #-} {-# LANGUAGE NoMonomorphismRestriction  #-} {-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE TypeSynonymInstances       #-} {-# LANGUAGE FlexibleInstances          #-} +{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}  --------------------------------------------------------------------------- -- | This module contains the code that uses the inferred types to generate@@ -51,13 +51,13 @@ 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.Misc                 as Misc import qualified Language.Haskell.Liquid.UX.ACSS              as ACSS import           Language.Haskell.HsColour.Classify import           Language.Fixpoint.Utils.Files import           Language.Fixpoint.Misc-import           Language.Haskell.Liquid.GHC.Misc-import qualified Language.Haskell.Liquid.GHC.API              as SrcLoc+import           Liquid.GHC.Misc+import qualified Liquid.GHC.API              as SrcLoc import           Language.Fixpoint.Types                      hiding (panic, Error, Loc, Constant (..), Located (..)) import           Language.Haskell.Liquid.Misc import           Language.Haskell.Liquid.Types.PrettyPrint@@ -91,6 +91,7 @@ annotate :: Config -> [FilePath] -> Output Doc -> IO ACSS.AnnMap ------------------------------------------------------------------- annotate cfg srcFs out+  -- TODO(matt.walker): Make this obey json!   = do when showWarns  $ forM_ bots (printf "WARNING: Found false in %s\n" . showPpr)        when doAnnotate $ mapM_ (doGenerate cfg tplAnnMap typAnnMap annTyp) srcFs        return typAnnMap@@ -106,11 +107,12 @@  doGenerate :: Config -> ACSS.AnnMap -> ACSS.AnnMap -> AnnInfo Doc -> FilePath -> IO () doGenerate cfg tplAnnMap typAnnMap annTyp srcF-  = do generateHtml srcF tpHtmlF tplAnnMap-       generateHtml srcF tyHtmlF typAnnMap+  = do generateHtml pandocF srcF tpHtmlF tplAnnMap+       generateHtml pandocF srcF tyHtmlF typAnnMap        writeFile         vimF  $ vimAnnot cfg annTyp        B.writeFile       jsonF $ encode typAnnMap     where+       pandocF    = pandocHtml cfg        tyHtmlF    = extFileName Html                   srcF        tpHtmlF    = extFileName Html $ extFileName Cst srcF        _annF      = extFileName Annot srcF@@ -121,7 +123,7 @@ mkBots (AI m) = [ src | (src, (Just _, t) : _) <- sortBy (ordSrcSpan `on` fst) $ M.toList m                       , isFalse (rTypeReft t) ] --- | Like 'copyFile' from 'System.Directory', but ensure that the parent /temporary/ directory +-- | Like 'copyFile' from 'System.Directory', but ensure that the parent /temporary/ directory -- (i.e. \".liquid\") exists on disk, creating it if necessary. copyFileCreateParentDirIfMissing :: FilePath -> FilePath -> IO () copyFileCreateParentDirIfMissing src tgt = do@@ -131,14 +133,14 @@ writeFilesOrStrings :: FilePath -> [Either FilePath String] -> IO () writeFilesOrStrings tgtFile = mapM_ $ either (`copyFileCreateParentDirIfMissing` tgtFile) (tgtFile `appendFile`) -generateHtml :: FilePath -> FilePath -> ACSS.AnnMap -> IO ()-generateHtml srcF htmlF annm-  = do src     <- Misc.sayReadFile srcF-       let lhs  = isExtFile LHs srcF-       let body = {-# SCC "hsannot" #-} ACSS.hsannot False (Just tokAnnot) lhs (src, annm)-       cssFile <- getCssPath-       copyFileCreateParentDirIfMissing cssFile (dropFileName htmlF </> takeFileName cssFile)-       renderHtml lhs htmlF srcF (takeFileName cssFile) body+generateHtml :: Bool -> FilePath -> FilePath -> ACSS.AnnMap -> IO ()+generateHtml pandocF srcF htmlF annm = do+  src     <- Misc.sayReadFile srcF+  let lhs  = isExtFile LHs srcF+  let body      = {-# SCC "hsannot" #-} ACSS.hsannot False (Just tokAnnot) lhs (src, annm)+  cssFile <- getCssPath+  copyFileCreateParentDirIfMissing cssFile (dropFileName htmlF </> takeFileName cssFile)+  renderHtml (pandocF && lhs) htmlF srcF (takeFileName cssFile) body  renderHtml :: Bool -> FilePath -> String -> String -> String -> IO () renderHtml True  = renderPandoc@@ -163,7 +165,7 @@     cmd    = pandocCmd pandocPath mdFile htmlFile  checkExitCode :: Monad m => String -> ExitCode -> m ()-checkExitCode _   (ExitSuccess)   = return ()+checkExitCode _    ExitSuccess    = return () checkExitCode cmd (ExitFailure n) = panic Nothing $ "cmd: " ++ cmd ++ " failure code " ++ show n  pandocCmd :: FilePath -> FilePath -> FilePath -> String@@ -235,10 +237,10 @@ --   annotations.  mkAnnMap :: Config -> ErrorResult -> AnnInfo Doc -> ACSS.AnnMap-mkAnnMap cfg res ann     = ACSS.Ann -                             { ACSS.types   = mkAnnMapTyp cfg ann -                             , ACSS.errors  = mkAnnMapErr res -                             , ACSS.status  = mkStatus res +mkAnnMap cfg res ann     = ACSS.Ann+                             { ACSS.types   = mkAnnMapTyp cfg ann+                             , ACSS.errors  = mkAnnMapErr res+                             , ACSS.status  = mkStatus res                              , ACSS.sptypes = mkAnnMapBinders cfg ann                              } @@ -252,7 +254,7 @@ mkAnnMapErr :: PPrint (TError t)             => FixResult (TError t) -> [(Loc, Loc, String)] mkAnnMapErr (Unsafe _ ls) = mapMaybe cinfoErr ls-mkAnnMapErr (Crash ls _)  = mapMaybe cinfoErr ls+mkAnnMapErr (Crash ls _)  = mapMaybe (cinfoErr . fst) ls mkAnnMapErr _             = []  cinfoErr :: PPrint (TError t) => TError t -> Maybe (Loc, Loc, String)@@ -380,7 +382,7 @@ -- | JSON: Annotation Data Types --------------------------------------- ------------------------------------------------------------------------ -data Assoc k a    = Asc (M.HashMap k a)+newtype Assoc k a = Asc (M.HashMap k a) type AnnTypes     = Assoc Int (Assoc Int Annot1) newtype AnnErrors = AnnErrors [(Loc, Loc, String)] data Annot1       = A1  { ident :: String@@ -451,15 +453,15 @@   toJSON a = object [ "types"   .= toJSON (annTypes     a)                     , "errors"  .= toJSON (annErrors    a)                     , "status"  .= toJSON (ACSS.status  a)-                    , "sptypes" .= (toJ <$> ACSS.sptypes 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 -                               ] -                      +    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
src/Language/Haskell/Liquid/UX/CTags.hs view
@@ -28,7 +28,7 @@ import qualified Data.Graph             as G  import Language.Fixpoint.Types          (Tag)-import Language.Haskell.Liquid.GHC.API+import Liquid.GHC.API import Language.Haskell.Liquid.Types.Visitors (freeVars) import Language.Haskell.Liquid.Types.PrettyPrint () import Language.Fixpoint.Misc     (mapSnd)
src/Language/Haskell/Liquid/UX/CmdLine.hs view
@@ -3,11 +3,14 @@ {-# LANGUAGE ScopedTypeVariables       #-} {-# LANGUAGE TemplateHaskell           #-} {-# LANGUAGE TupleSections             #-}-{-# LANGUAGE TypeSynonymInstances      #-} {-# LANGUAGE NamedFieldPuns            #-}-{-# LANGUAGE MultiWayIf                #-} {-# LANGUAGE ViewPatterns              #-}++{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wwarn=deprecations #-} {-# OPTIONS_GHC -fno-cse #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# LANGUAGE FlexibleContexts #-}  -- | This module contains all the code needed to output the result which --   is either: `SAFE` or `WARNING` with some reasonable error message when@@ -47,10 +50,10 @@ import Control.Monad import Control.Monad.IO.Class import Data.Maybe+import Data.Functor ((<&>)) import Data.Aeson (encode) import qualified Data.ByteString.Lazy.Char8 as B import Development.GitRev (gitCommitCount)-import Options.Applicative.Simple (simpleVersion) import qualified Paths_liquidhaskell as Meta import System.Directory import System.Exit@@ -74,13 +77,14 @@ import Language.Fixpoint.Solver.Stats as Solver import Language.Haskell.Liquid.UX.Annotate import Language.Haskell.Liquid.UX.Config-import Language.Haskell.Liquid.GHC.Misc+import Language.Haskell.Liquid.UX.SimpleVersion (simpleVersion)+import Liquid.GHC.Misc import Language.Haskell.Liquid.Misc import Language.Haskell.Liquid.Types.PrettyPrint () import Language.Haskell.Liquid.Types       hiding (typ) import qualified Language.Haskell.Liquid.UX.ACSS as ACSS -import qualified Language.Haskell.Liquid.GHC.API as GHC+import qualified Liquid.GHC.API as GHC import           Language.Haskell.TH.Syntax.Compat (fromCode, toCode)  import Text.PrettyPrint.HughesPJ           hiding (Mode, (<>))@@ -158,6 +162,11 @@           &= help "Disable Termination Check"           &= name "no-termination-check" + , nopositivity+    = def+          &= help "Disable Data Type Positivity Check"+          &= name "no-positivity-check"+  , rankNTypes     = def &= help "Adds precise reasoning on presence of rankNTypes"           &= name "rankNTypes"@@ -181,7 +190,7 @@   , gdepth     = 1-    &= help ("Size of gradual conretizations, 1 by default")+    &= help "Size of gradual conretizations, 1 by default"     &= name "gradual-depth"   , ginteractive@@ -275,6 +284,14 @@     = def &= help "Do not generate ADT representations in refinement logic"           &= name "no-adt" + , expectErrorContaining+    = def &= help "Expect an error which containing the provided string from verification (can be provided more than once)"+          &= name "expect-error-containing"++ , expectAnyError+    = def &= help "Expect an error, no matter which kind or what it contains"+          &= name "expect-any-error"+  , scrapeImports     = False &= help "Scrape qualifiers from imported specifications"             &= name "scrape-imports"@@ -348,11 +365,22 @@         &= help "Enable Proof-by-Logical-Evaluation"         &= name "ple" +  , pleWithUndecidedGuards+    = def+        &= help "Unfold invocations with undecided guards in PLE"+        &= name "ple-with-undecided-guards"+        &= explicit+   , oldPLE     = def         &= help "Enable Proof-by-Logical-Evaluation"         &= name "oldple" +  , interpreter+    = def+        &= help "Use an interpreter to assist PLE in solving constraints"+        &= name "interpreter"+   , proofLogicEvalLocal     = def         &= help "Enable Proof-by-Logical-Evaluation locally, per function"@@ -409,10 +437,10 @@     rwTerminationCheck     = def         &= name "rw-termination-check"-        &= help (   "Enable the rewrite divergence checker. " +        &= help (   "Enable the rewrite divergence checker. "                  ++ "Can speed up verification if rewriting terminates, but can also cause divergence."                 )-  , +  ,     skipModule     = def         &= name "skip-module"@@ -422,9 +450,9 @@     = def         &= name "no-lazy-ple"         &= help "Don't use Lazy PLE"- -  , fuel -    = Nothing ++  , fuel+    = Nothing         &= help "Maximum fuel (per-function unfoldings) for PLE"    , environmentReduction@@ -446,6 +474,10 @@           , "Sometimes improves performance and sometimes worsens it."           , "Disabled by --no-environment-reduction"           ])+  , pandocHtml+    = False+      &= name "pandoc-html"+      &= help "Use pandoc to generate html."   } &= program "liquid"     &= help    "Refinement Types for Haskell"     &= summary copyright@@ -607,19 +639,27 @@ withPragmas :: MonadIO m => Config -> FilePath -> [Located String] -> (Config -> m a) -> m a -------------------------------------------------------------------------------- withPragmas cfg fp ps action-  = do cfg' <- liftIO $ foldM withPragma cfg ps >>= canonicalizePaths fp >>= (return . canonConfig)+  = do cfg' <- liftIO $ (processPragmas cfg ps >>= canonicalizePaths fp) <&> canonConfig        -- As the verbosity is set /globally/ via the cmdargs lib, re-set it.        liftIO $ setVerbosity (loggingVerbosity cfg')        res <- action cfg'        liftIO $ setVerbosity (loggingVerbosity cfg) -- restore the original verbosity.        pure res-+  where+    processPragmas :: Config -> [Located String] -> IO Config+    processPragmas c pragmas =+      withArgs (val <$> pragmas) $+        cmdArgsRun config { modeValue = (modeValue config) { cmdArgsValue = c } } +-- | Note that this function doesn't process list arguments properly, like+-- 'cFiles' or 'expectErrorContaining'+-- TODO: This is only used to parse the contents of the env var LIQUIDHASKELL_OPTS+-- so it should be able to parse multiple arguments instead. See issue #1990. withPragma :: Config -> Located String -> IO Config withPragma c s = withArgs [val s] $ cmdArgsRun-          config { modeValue = (modeValue config) { cmdArgsValue = c } }+                   config { modeValue = (modeValue config) { cmdArgsValue = c } } -parsePragma   :: Located String -> IO Config+parsePragma :: Located String -> IO Config parsePragma = withPragma defConfig  defConfig :: Config@@ -639,6 +679,7 @@   , nostructuralterm         = def   , noCheckUnknown           = def   , notermination            = False+  , nopositivity             = False   , rankNTypes               = False   , noclasscheck             = False   , gradual                  = False@@ -655,6 +696,8 @@   , pruneUnsorted            = def   , exactDC                  = def   , noADT                    = def+  , expectErrorContaining    = def+  , expectAnyError           = False   , cores                    = def   , minPartSize              = FC.defaultMinPartSize   , maxPartSize              = FC.defaultMaxPartSize@@ -682,7 +725,9 @@   , noslice                  = False   , noLiftedImport           = False   , proofLogicEval           = False+  , pleWithUndecidedGuards   = False   , oldPLE                   = False+  , interpreter              = False   , proofLogicEvalLocal      = False   , reflection               = False   , extensionality           = False@@ -702,11 +747,12 @@   , environmentReduction     = False   , noEnvironmentReduction   = False   , inlineANFBindings        = False+  , pandocHtml               = False   } ---- | Writes the annotations (i.e. the files in the \".liquid\" hidden folder) and report the result--- of the checking using a supplied function.+-- | Write the annotations (i.e. the files in the \".liquid\" hidden folder) and+-- report the result of the checking using a supplied function, or using an+-- implicit JSON function, if @json@ flag is set. reportResult :: MonadIO m              => (OutputResult -> m ())              -> Config@@ -716,8 +762,9 @@ reportResult logResultFull cfg targets out = do   annm <- {-# SCC "annotate" #-} liftIO $ annotate cfg targets out   liftIO $ whenNormal $ donePhase Loud "annotate"-  if | json cfg  -> liftIO $ reportResultJson annm-     | otherwise -> do+  if json cfg then+    liftIO $ reportResultJson annm+   else do          let r = o_result out          liftIO $ writeCheckVars $ o_vars out          cr <- liftIO $ resultWithContext r@@ -726,7 +773,6 @@          -- passed as input.          liftIO $ printHeader (colorResult r) (orHeader outputResult)          logResultFull outputResult-  pure ()   where     tidy :: F.Tidy     tidy = if shortErrors cfg then F.Lossy else F.Full@@ -734,11 +780,10 @@     printHeader :: Moods -> Doc -> IO ()     printHeader mood d = colorPhaseLn mood "" (render d) - ------------------------------------------------------------------------ exitWithResult :: Config -> [FilePath] -> Output Doc -> IO () -------------------------------------------------------------------------exitWithResult cfg = reportResult writeResultStdout cfg+exitWithResult cfg targets out = void $ reportResult writeResultStdout cfg targets out  reportResultJson :: ACSS.AnnMap -> IO () reportResultJson annm = do@@ -747,14 +792,20 @@  resultWithContext :: F.FixResult UserError -> IO (FixResult CError) resultWithContext (F.Unsafe s es)  = F.Unsafe s    <$> errorsWithContext es-resultWithContext (F.Crash  es s)  = (`F.Crash` s) <$> errorsWithContext es resultWithContext (F.Safe   stats) = return (F.Safe stats)+resultWithContext (F.Crash  es s)  = do+  let (errs, msgs) = unzip es+  errs' <- errorsWithContext errs+  return (F.Crash (zip errs' msgs) s) +++ instance Show (CtxError Doc) where   show = showpp  writeCheckVars :: Symbolic a => Maybe [a] -> IO ()-writeCheckVars Nothing     = return ()+writeCheckVars Nothing    = return () writeCheckVars (Just [])   = colorPhaseLn Loud "Checked Binders: None" "" writeCheckVars (Just ns)   = colorPhaseLn Loud "Checked Binders:" ""                           >> forM_ ns (putStrLn . symbolString . dropModuleNames . symbol)@@ -775,12 +826,12 @@   forM_ messages $ \(sSpan, doc) -> putStrLn (render $ mkErrorDoc sSpan doc {- pprint sSpan <> (text ": error: " <+> doc)-})  mkErrorDoc :: PPrint a => a -> Doc -> Doc-mkErrorDoc sSpan doc = +mkErrorDoc sSpan doc =   -- Gross on screen, nice for Ghcid   -- pprint sSpan <> (text ": error: " <+> doc)    -- Nice on screen, invisible in Ghcid ...-  (pprint sSpan <> text ": error: ") $+$ (nest 4 doc)+  (pprint sSpan <> text ": error: ") $+$ nest 4 doc   -- | Given a 'FixResult' parameterised over a 'CError', this function returns the \"header\" to show to@@ -791,9 +842,14 @@     orHeader   = text $ "LIQUID: SAFE (" <> show (Solver.numChck stats) <> " constraints checked)"   , orMessages = mempty   }+resDocs _k (F.Crash [] s)  =+  OutputResult {+    orHeader = text "LIQUID: ERROR"+  , orMessages = [(GHC.noSrcSpan, text s)]+  } resDocs k (F.Crash xs s)  =   OutputResult {-    orHeader = text "LIQUID: ERROR" <+> text s+    orHeader = text "LIQUID: ERROR:" <+> text s   , orMessages = map (cErrToSpanned k . errToFCrash) xs   } resDocs k (F.Unsafe _ xs)   =@@ -806,11 +862,15 @@ cErrToSpanned :: F.Tidy -> CError -> (GHC.SrcSpan, Doc) cErrToSpanned k CtxError{ctErr} = (pos ctErr, pprintTidy k ctErr) -errToFCrash :: CtxError a -> CtxError a-errToFCrash ce = ce { ctErr    = tx $ ctErr ce}+errToFCrash :: (CError, Maybe String) -> CError+errToFCrash (ce, Just msg) = ce { ctErr = ErrOther (pos (ctErr ce)) (fixMessageDoc msg) }+errToFCrash (ce, Nothing)  = ce { ctErr = tx $ ctErr ce}   where     tx (ErrSubType l m _ g t t') = ErrFCrash l m g t t'-    tx e                       = e+    tx e                         = F.notracepp "errToFCrash?" e++fixMessageDoc :: String -> Doc+fixMessageDoc msg = vcat (text <$> lines msg)  {-    TODO: Never used, do I need to exist?
src/Language/Haskell/Liquid/UX/Config.hs view
@@ -39,6 +39,7 @@   , checks                   :: [String]   -- ^ set of binders to check   , noCheckUnknown           :: Bool       -- ^ whether to complain about specifications for unexported and unused values   , notermination            :: Bool       -- ^ disable termination check+  , nopositivity             :: Bool       -- ^ disable positivity check   , rankNTypes               :: Bool       -- ^ Adds precise reasoning on presence of rankNTypes   , noclasscheck             :: Bool       -- ^ disable checking class instances   -- , structuralTerm        :: Bool       -- ^ use structural termination checker@@ -69,6 +70,8 @@   , port                     :: Int        -- ^ port at which lhi should listen   , exactDC                  :: Bool       -- ^ Automatically generate singleton types for data constructors   , noADT                    :: Bool       -- ^ Disable ADTs (only used with exactDC)+  , expectErrorContaining    :: [String]   -- ^ expect failure from Liquid with at least one of the following messages+  , expectAnyError           :: Bool       -- ^ expect failure from Liquid with any message   , scrapeImports            :: Bool       -- ^ scrape qualifiers from imported specifications   , scrapeInternals          :: Bool       -- ^ scrape qualifiers from auto specifications   , scrapeUsedImports        :: Bool       -- ^ scrape qualifiers from used, imported specifications@@ -84,7 +87,9 @@   , noslice                  :: Bool       -- ^ Disable non-concrete KVar slicing   , noLiftedImport           :: Bool       -- ^ Disable loading lifted specifications (for "legacy" libs)   , proofLogicEval           :: Bool       -- ^ Enable proof-by-logical-evaluation+  , pleWithUndecidedGuards   :: Bool       -- ^ Unfold invocations with undecided guards in PLE   , oldPLE                   :: Bool       -- ^ Enable proof-by-logical-evaluation+  , interpreter              :: Bool       -- ^ Use an interpreter to assist PLE   , proofLogicEvalLocal      :: Bool       -- ^ Enable proof-by-logical-evaluation locally, per function   , extensionality           :: Bool       -- ^ Enable extensional interpretation of function equality   , nopolyinfer              :: Bool       -- ^ No inference of polymorphic type application.@@ -105,6 +110,7 @@   , noEnvironmentReduction   :: Bool       -- ^ Don't perform environment reduction   , inlineANFBindings        :: Bool       -- ^ Inline ANF bindings.                                            -- Sometimes improves performance and sometimes worsens it.+  , pandocHtml               :: Bool       -- ^ Use pandoc to generate html   } deriving (Generic, Data, Typeable, Show, Eq)  allowPLE :: Config -> Bool@@ -153,11 +159,10 @@ terminationCheck = terminationCheck' . getConfig  totalityCheck' :: Config -> Bool-totalityCheck' cfg = (not (nototality cfg)) || totalHaskell cfg+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
@@ -7,6 +7,10 @@ {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# LANGUAGE TupleSections #-}+ module Language.Haskell.Liquid.UX.DiffCheck (     -- * Changed binders + Unchanged Errors@@ -47,10 +51,10 @@ import           Language.Fixpoint.Types                (atLoc, FixResult (..), SourcePos(..), safeSourcePos, unPos) -- import qualified Language.Fixpoint.Misc                 as Misc import           Language.Fixpoint.Utils.Files-import           Language.Fixpoint.Solver.Stats ()     +import           Language.Fixpoint.Solver.Stats () import           Language.Haskell.Liquid.Misc           (mkGraph)-import           Language.Haskell.Liquid.GHC.Misc-import           Language.Haskell.Liquid.GHC.API        as Ghc hiding ( Located+import           Liquid.GHC.Misc+import           Liquid.GHC.API        as Ghc hiding ( Located                                                                       , sourceName                                                                       , text                                                                       , panic@@ -58,7 +62,7 @@                                                                       ) import           Text.PrettyPrint.HughesPJ              (text, render, Doc) import qualified Data.ByteString                        as B-import qualified Data.ByteString.Lazy                   as LB                                               +import qualified Data.ByteString.Lazy                   as LB  import           Language.Haskell.Liquid.Types          hiding (Def, LMap) @@ -67,7 +71,7 @@ --------------------------------------------------------------------------------  -- | Main type of value returned for diff-check.-data DiffCheck = DC +data DiffCheck = DC   { newBinds  :: [CoreBind]   , oldOutput :: !(Output Doc)   , newSpec   :: !TargetSpec@@ -78,7 +82,7 @@   -- | Variable definitions-data Def  = D +data Def  = D   { start  :: Int -- ^ line at which binder definition starts   , end    :: Int -- ^ line at which binder definition ends   , binder :: Var -- ^ name of binder@@ -113,10 +117,10 @@ -------------------------------------------------------------------------------- slice :: FilePath -> [CoreBind] -> TargetSpec -> IO (Maybe DiffCheck) ---------------------------------------------------------------------------------slice target cbs sp = do +slice target cbs sp = do   ex <- doesFileExist savedFile-  if ex -    then doDiffCheck +  if ex+    then doDiffCheck     else return Nothing   where     savedFile       = extFileName Saved target@@ -148,7 +152,7 @@ assumeSpec :: M.HashMap Var LocSpecType -> TargetSpec -> TargetSpec assumeSpec sigm sp = sp { gsSig = gsig { gsAsmSigs = M.toList $ M.union sigm assm } }   where-    assm           = M.fromList (gsAsmSigs gsig) +    assm           = M.fromList (gsAsmSigs gsig)     gsig           = gsSig sp  diffVars :: [Int] -> [Def] -> [Var]@@ -208,7 +212,7 @@ thinWith sigs cbs xs = filterBinds cbs calls   where     calls    = txClosure cbDeps sigs (S.fromList xs)-    cbDeps   = coreDeps cbs +    cbDeps   = coreDeps cbs  coreDeps    :: [CoreBind] -> Deps coreDeps bs = mkGraph $ calls ++ calls'@@ -217,7 +221,7 @@     calls'  = [(y, x) | (x, y) <- calls]     deps b  = [(x, y) | x <- bindersOf b                       , y <- freeVars S.empty b-                      , S.member y defVars +                      , S.member y defVars               ]     defVars = S.fromList (letVars bs) @@ -265,8 +269,8 @@     sameFile   = (srcF ==) . file . snd  specSigs :: TargetSpec -> [(Var, LocSpecType)]-specSigs sp = gsTySigs  (gsSig  sp) -           ++ gsAsmSigs (gsSig  sp) +specSigs sp = gsTySigs  (gsSig  sp)+           ++ gsAsmSigs (gsSig  sp)            ++ gsCtors   (gsData sp)  instance PPrint Def where@@ -282,9 +286,9 @@     xm       = varBounds xes  coreExprDefs :: M.HashMap Var (Int, Int) -> [(Var, CoreExpr)]-> [Def]-coreExprDefs xm xes = -  L.sort -    [ D l l' x +coreExprDefs xm xes =+  L.sort+    [ D l l' x       | (x, e) <- xes       , (l, l') <- maybeToList $ coreExprDef xm (x, e)     ]@@ -299,43 +303,43 @@ coreVarExprs :: [CoreBind] -> [(Var, CoreExpr)] coreVarExprs = filter ok . concatMap varExprs   where-    ok       = isGoodSrcSpan . getSrcSpan . fst +    ok       = isGoodSrcSpan . getSrcSpan . fst  varExprs :: Bind a -> [(a, Expr a)] varExprs (NonRec x e) = [(x, e)] varExprs (Rec xes)    = xes --- | varBounds computes upper and lower bounds on where each top-level binder's +-- | varBounds computes upper and lower bounds on where each top-level binder's --   definition can be by using ONLY the lines where the binder is defined. varBounds :: [(Var, CoreExpr)] -> M.HashMap Var (Int, Int)-varBounds = M.fromList . defBounds . varDefs +varBounds = M.fromList . defBounds . varDefs  varDefs :: [(Var, CoreExpr)] -> [(Int, Var)]-varDefs xes = +varDefs xes =   L.sort [ (l, x) | (x,_) <- xes, let Just (l, _) = lineSpan x (getSrcSpan x) ]  defBounds :: [(Int, Var)] -> [(Var, (Int, Int) )] defBounds ((l, x) : lxs@((l', _) : _ )) = (x, (l, l' - 1)) : defBounds lxs defBounds _                             = [] -{- +{- -------------------------------------------------------------------------------- coreDefs     :: [CoreBind] -> [Def] ---------------------------------------------------------------------------------coreDefs cbs = tracepp "coreDefs" $ +coreDefs cbs = tracepp "coreDefs" $                L.sort [D l l' x | b <- cbs                                 , x <- bindersOf b                                 , isGoodSrcSpan (getSrcSpan x)                                 , (l, l') <- coreDef b]  coreDef :: CoreBind -> [(Int, Int)]-coreDef b +coreDef b   | True  = tracepp ("coreDef: " ++ showpp (vs, vSp)) $ maybeToList vSp   | False = tracepp ("coreDef: " ++ showpp (b, eSp, vSp)) $ meetSpans b eSp vSp   where     eSp   = lineSpan b $ catSpans b $ bindSpans b     vSp   = lineSpan b $ catSpans b $ getSrcSpan <$> vs-    vs    = bindersOf b +    vs    = bindersOf b  meetSpans :: Maybe (Int, Int) -> Maybe (Int, Int) -> Maybe (Int, Int) meetSpans Nothing       _@@ -475,7 +479,7 @@ -------------------------------------------------------------------------------- saveResult :: FilePath -> Output Doc -> IO () ---------------------------------------------------------------------------------saveResult target res = do +saveResult target res = do   copyFile target saveF   B.writeFile errF $ LB.toStrict $ encode res   where@@ -485,13 +489,13 @@ -------------------------------------------------------------------------------- loadResult   :: FilePath -> IO (Output Doc) ---------------------------------------------------------------------------------loadResult f = do +loadResult f = do   ex <- doesFileExist jsonF-  if ex +  if ex     then convert <$> B.readFile jsonF     else return mempty   where-    convert  = fromMaybe mempty . decode . LB.fromStrict +    convert  = fromMaybe mempty . decode . LB.fromStrict     jsonF    = extFileName Cache f  --------------------------------------------------------------------------------@@ -506,20 +510,18 @@                                               , Just sp' <- [adjustSrcSpan lm cm sp]]  adjustResult :: LMap -> ChkItv -> ErrorResult -> ErrorResult-adjustResult lm cm (Unsafe s es)  = errorsResult (Unsafe s)  $ adjustErrors lm cm es-adjustResult lm cm (Crash es z)   = errorsResult (`Crash` z) $ adjustErrors lm cm es+adjustResult lm cm (Unsafe s es)  = errorsResult (Unsafe s)  $ mapMaybe (adjustError  lm cm) es+adjustResult lm cm (Crash es z)   = errorsResult (`Crash` z) $ (, Nothing) <$>mapMaybe (adjustError lm cm . fst) es adjustResult _  _  r              = r  errorsResult :: ([a] -> FixResult b) -> [a] -> FixResult b errorsResult _ []                 = Safe mempty errorsResult f es                 = f es -adjustErrors :: (PPrint (TError a)) => LMap -> ChkItv -> [TError a] -> [TError a]-adjustErrors lm cm                = mapMaybe adjustError-  where-    adjustError e                = case adjustSrcSpan lm cm (pos e) of-                                     Just sp' -> Just (e {pos = sp'})-                                     Nothing  -> Nothing+adjustError :: (PPrint (TError a)) => LMap -> ChkItv -> TError a -> Maybe (TError a)+adjustError lm cm e = case adjustSrcSpan lm cm (pos e) of+  Just sp' -> Just (e {pos = sp'})+  Nothing  -> Nothing  -------------------------------------------------------------------------------- adjustSrcSpan :: LMap -> ChkItv -> SrcSpan -> Maybe SrcSpan
src/Language/Haskell/Liquid/UX/Errors.hs view
@@ -3,6 +3,8 @@ {-# LANGUAGE TupleSections     #-} {-# LANGUAGE BangPatterns      #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-}+ -- | This module contains the functions related to @Error@ type, -- in particular, to @tidyError@ using a solution, and @pprint@ errors. @@ -14,14 +16,14 @@ import qualified Data.List                           as L import           Data.Hashable import           Data.Maybe                          (maybeToList)-import qualified Language.Fixpoint.Types             as F +import qualified Language.Fixpoint.Types             as F import           Language.Haskell.Liquid.Types.RefType import           Language.Haskell.Liquid.Transforms.Simplify import           Language.Haskell.Liquid.UX.Tidy import           Language.Haskell.Liquid.Types-import qualified Language.Haskell.Liquid.GHC.Misc    as GM -import qualified Language.Haskell.Liquid.Misc        as Misc -import qualified Language.Fixpoint.Misc              as Misc +import qualified Liquid.GHC.Misc    as GM+import qualified Language.Haskell.Liquid.Misc        as Misc+import qualified Language.Fixpoint.Misc              as Misc  -- import Debug.Trace @@ -32,15 +34,15 @@ tidyError :: Config -> F.FixSolution -> Error -> Error ------------------------------------------------------------------------ tidyError cfg sol-  = fmap (tidySpecType tidy) +  = fmap (tidySpecType tidy)   . tidyErrContext tidy sol-  where -    tidy = configTidy cfg +  where+    tidy = configTidy cfg -configTidy :: Config -> F.Tidy -configTidy cfg -  | shortNames cfg = F.Lossy -  | otherwise      = F.Full +configTidy :: Config -> F.Tidy+configTidy cfg+  | shortNames cfg = F.Lossy+  | otherwise      = F.Full  tidyErrContext :: F.Tidy -> F.FixSolution -> Error -> Error tidyErrContext k _ e@(ErrSubType {})@@ -76,9 +78,9 @@ tidyCtx k xs m = (θ1 `mappend` θ2, M.fromList yts)   where     yts        = [tBind x (tidySpecType k t) | (x, t) <- xt2s]-    (θ2, xt2s) = tidyREnv xt1s -    (θ1, xt1s) = tidyTemps xts  -    xts        = sliceREnv xs m +    (θ2, xt2s) = tidyREnv xt1s+    (θ1, xt1s) = tidyTemps xts+    xts        = sliceREnv xs m     tBind x t  = (x', shiftVV t x') where x' = F.tidySymbol x  tidyCtxM       :: [F.Symbol] -> CtxM -> (F.Subst, CtxM)@@ -86,13 +88,13 @@   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' = F.tidySymbol x+    tBind x t = (x', fmap (`shiftVV` x') t) where x' = F.tidySymbol x  tidyREnv :: [(F.Symbol, SpecType)] -> (F.Subst, [(F.Symbol, SpecType)]) tidyREnv xts    = (θ, second (F.subst θ) <$> zts)-  where -    θ           = expandVarDefs yes -    (yes, zts)  = Misc.mapEither isInline xts +  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, @@ -100,30 +102,30 @@ --   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)+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] +      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) +       (yes, zes)  = L.partition (isDef xs . snd) xes+    isDef xs e     = not (any (`S.member` xs) (F.syms e)) -isInline :: (a, SpecType) -> Either (a, F.Expr) (a, SpecType) -isInline (x, t) = either (Left . (x,)) (Right . (x,)) (isInline' t) +isInline :: (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 +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 +                             Nothing -> Right (strengthen t' rr)+              where+                  (t', ro) = stripRType t  stripReft     :: SpecType -> SpecType stripReft t   = maybe t' (strengthen t') ro@@ -174,4 +176,4 @@   where     mkSymbol  = F.symbol . ('?' :)     xs        = Misc.single <$> ['a' .. 'z']-    ys        = ("a" ++) <$> [show n | n <- [0 ..]]+    ys        = ("a" ++) <$> [show n | n <- [(0::Int) ..]]
src/Language/Haskell/Liquid/UX/QuasiQuoter.hs view
@@ -1,11 +1,12 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor      #-}-{-# LANGUAGE TemplateHaskell    #-}-{-# LANGUAGE TupleSections      #-}-{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE TupleSections         #-}+{-# LANGUAGE OverloadedStrings     #-} -module Language.Haskell.Liquid.UX.QuasiQuoter +{-# OPTIONS_GHC -Wno-name-shadowing #-}++module Language.Haskell.Liquid.UX.QuasiQuoter -- ( --     -- * LiquidHaskell Specification QuasiQuoter --     lq@@ -27,8 +28,8 @@ import Language.Fixpoint.Types hiding (Error, Loc, SrcSpan) import qualified Language.Fixpoint.Types as F -import Language.Haskell.Liquid.GHC.Misc (fSrcSpan)-import Language.Haskell.Liquid.GHC.API  (SrcSpan)+import Liquid.GHC.Misc (fSrcSpan)+import Liquid.GHC.API  (SrcSpan) import Language.Haskell.Liquid.Parse import Language.Haskell.Liquid.Types @@ -87,16 +88,12 @@   (\t -> (`SigD` t) . symbolName <$> names)     <$> simplifyBareType (head names) (quantifyFreeRTy $ val ty) mkSpecDecs (Alias rta) =-  return . (TySynD name tvs) <$> simplifyBareType lsym (rtBody (val rta))+  return . TySynD name tvs <$> simplifyBareType lsym (rtBody (val rta))   where-    lsym = F.atLoc rta n -    name = symbolName n +    lsym = F.atLoc rta n+    name = symbolName n     n    = rtName (val rta)-#if MIN_VERSION_template_haskell(2,17,0)     tvs  = (\a -> PlainTV (symbolName a) ()) <$> rtTArgs (val rta)-#else-    tvs  = PlainTV . symbolName <$> rtTArgs (val rta)-#endif mkSpecDecs _ =   Right [] @@ -112,10 +109,10 @@   Simplified t' ->     Right t'   FoundExprArg l ->-    Left $ ErrTySpec l Nothing (pprint $ val s) (pprint t) $ +    Left $ ErrTySpec l Nothing (pprint $ val s) (pprint t)       "Found expression argument in bad location in type"   FoundHole ->-    Left $ ErrTySpec (fSrcSpan s) Nothing (pprint $ val s) (pprint t) $ +    Left $ ErrTySpec (fSrcSpan s) Nothing (pprint $ val s) (pprint t)       "Can't write LiquidHaskell type with hole in a quasiquoter"  simplifyBareType' :: BareType -> Simpl Type@@ -158,11 +155,7 @@   simplifyBareType'' (ty_var_value tv : tvs, cls) t  simplifyBareType'' (tvs, cls) t =-#if MIN_VERSION_template_haskell(2,17,0)   ForallT ((\t -> PlainTV (symbolName t) SpecifiedSpec) <$> reverse tvs)-#else-  ForallT (PlainTV . symbolName <$> reverse tvs)-#endif     <$> mapM simplifyBareType' (reverse cls)     <*> simplifyBareType' t @@ -207,7 +200,7 @@  locSourcePos :: Loc -> SourcePos locSourcePos loc =-  safeSourcePos (loc_filename loc) (fst $ loc_start loc) (snd $ loc_start loc)+  uncurry (safeSourcePos (loc_filename loc)) (loc_start loc)  dataToExpQ' :: Data a => a -> Q Exp dataToExpQ' = dataToExpQ (const Nothing `extQ` textToExpQ)
+ src/Language/Haskell/Liquid/UX/SimpleVersion.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE TemplateHaskell #-}++module Language.Haskell.Liquid.UX.SimpleVersion (simpleVersion) where++import Data.Version (Version, showVersion)+import GitHash (GitInfo, giDirty, giHash, tGitInfoCwdTry)+import Language.Haskell.TH (Exp, Q)+import qualified Language.Haskell.TH.Syntax as TH.Syntax+import qualified Language.Haskell.TH.Syntax.Compat as TH.Syntax.Compat++-- | Generate a string like @Version 1.2, Git revision 1234@.+--+-- @$(simpleVersion …)@ @::@ 'String'+-- Taken from <https://hackage.haskell.org/package/optparse-simple-0.1.1.4/docs/Options-Applicative-Simple.html#v:simpleVersion>+-- so we can drop the dependency on optparse-simple.+simpleVersion :: Version -> Q Exp+simpleVersion version =+  [|+    concat+      ( [ "Version ",+          $(TH.Syntax.lift $ showVersion version)+        ]+          ++ case $(TH.Syntax.Compat.unTypeSplice tGitInfoCwdTry) :: Either String GitInfo of+            Left _ -> []+            Right gi ->+              [ ", Git revision ",+                giHash gi,+                if giDirty gi then " (dirty)" else ""+              ]+      )+    |]
src/Language/Haskell/Liquid/UX/Tidy.hs view
@@ -1,8 +1,9 @@- {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-}+ --------------------------------------------------------------------- -- | This module contains functions for cleaning up types before --   they are rendered, e.g. in error messages or annoations,@@ -35,11 +36,11 @@ import qualified Data.List                                 as L import qualified Data.Text                                 as T import qualified Control.Exception                         as Ex-import qualified Language.Haskell.Liquid.GHC.Misc          as GM +import qualified Liquid.GHC.Misc          as GM -- (dropModuleNames, showPpr, stringTyVar) import           Language.Fixpoint.Types                   hiding (Result, SrcSpan, Error) import           Language.Haskell.Liquid.Types.Types-import           Language.Haskell.Liquid.Types.RefType     (rVar, subsTyVars_meet, FreeVar)+import           Language.Haskell.Liquid.Types.RefType     (rVar, subsTyVarsMeet, FreeVar) import           Language.Haskell.Liquid.Types.PrettyPrint import           Data.Generics                             (everywhere, mkT) import           Text.PrettyPrint.HughesPJ@@ -53,10 +54,10 @@   result :: a -> FixResult UserError  instance Result UserError where-  result e = Crash [e] ""+  result e = Crash [(e, Nothing)] ""  instance Result [Error] where-  result es = Crash (errorToUserError <$> es) ""+  result es = Crash ([ (errorToUserError e, Nothing) | e <- es]) ""  instance Result Error where   result e  = result [e] --  Crash [pprint e] ""@@ -70,16 +71,16 @@ -- TODO: move to Types.hs cinfoError :: Cinfo -> Error cinfoError (Ci _ (Just e) _) = e-cinfoError (Ci l _ _)        = ErrOther l (text $ "Cinfo:" ++ GM.showPpr l)+cinfoError (Ci l _ _)        = ErrOther l (text $ "Cinfo: " ++ GM.showPpr l)  ------------------------------------------------------------------------- tidySpecType :: Tidy -> SpecType -> SpecType --------------------------------------------------------------------------tidySpecType k -  = tidyEqual +tidySpecType k+  = tidyEqual   . tidyValueVars   . tidyDSymbols-  . tidySymbols k +  . tidySymbols k   . tidyInternalRefas   . tidyLocalRefas k   . tidyFunBinds@@ -104,9 +105,9 @@     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 +shortSymbol :: Tidy -> Symbol -> Symbol+shortSymbol Lossy = GM.dropModuleNames+shortSymbol _     = id  tidyLocalRefas   :: Tidy -> SpecType -> SpecType tidyLocalRefas k = mapReft (txReft' k)@@ -119,7 +120,7 @@  tidyEqual :: SpecType -> SpecType tidyEqual = mapReft txReft-  where +  where     txReft u                      = u { ur_reft = mapPredReft dropInternals $ ur_reft u }     dropInternals                 = pAnd . L.nub . conjuncts @@ -148,13 +149,13 @@     αβs  = zipWith (\α β -> (α, toRSort β, β)) αs βs     αs   = L.nub (tyVars t)     βs   = map (rVar . GM.stringTyVar) pool-    pool = [[c] | c <- ['a'..'z']] ++ [ "t" ++ show i | i <- [1..]]+    pool = [[c] | c <- ['a'..'z']] ++ [ "t" ++ show i | i <- [(1::Int)..]]   bindersTx :: [Symbol] -> Symbol -> Symbol bindersTx ds   = \y -> M.lookupDefault y y m   where-    m          = M.fromList $ zip ds $ var <$> [1..]+    m          = M.fromList $ zip ds $ var <$> [(1::Int)..]     var        = symbol . ('x' :) . show  @@ -185,7 +186,7 @@   where     abm            = M.fromList [(a, b) | (a, _, RVar b _) <- ats]     go (RAllT a t r) = RAllT (makeRTVar $ M.lookupDefault (ty_var_value a) (ty_var_value a) abm) (go t) r-    go t           = subsTyVars_meet ats t+    go t           = subsTyVarsMeet ats t   funBinds :: RType t t1 t2 -> [Symbol]@@ -229,7 +230,7 @@  instance PPrint Error where   pprintTidy k = ppError k empty . fmap ppSpecTypeErr- + ppSpecTypeErr :: SpecType -> Doc ppSpecTypeErr = ppSpecType Lossy
src/Language/Haskell/Liquid/WiredIn.hs view
@@ -26,19 +26,20 @@ import Prelude                                hiding (error)  -- import Language.Fixpoint.Misc           (mapSnd)-import Language.Haskell.Liquid.GHC.Misc-import qualified Language.Haskell.Liquid.GHC.API as Ghc-import Language.Haskell.Liquid.GHC.API (Var, Arity, TyVar, Bind(..), Boxity(..), Expr(..), ArgFlag(..))+import Liquid.GHC.Misc+import qualified Liquid.GHC.API as Ghc+import Liquid.GHC.API (Var, Arity, TyVar, Bind(..), Boxity(..), Expr(..), ArgFlag(..)) import Language.Haskell.Liquid.Types.Types import Language.Haskell.Liquid.Types.RefType import Language.Haskell.Liquid.Types.Variance import Language.Haskell.Liquid.Types.PredType+import Language.Haskell.Liquid.Types.Names (selfSymbol)  -- import Language.Fixpoint.Types hiding (panic) import qualified Language.Fixpoint.Types as F import qualified Data.HashSet as S  -import Language.Haskell.Liquid.GHC.TypeRep ()+import Liquid.GHC.TypeRep ()  -- | Horrible hack to support hardwired symbols like --      `head`, `tail`, `fst`, `snd`@@ -50,10 +51,10 @@ isWiredIn x = isWiredInLoc x  || isWiredInName (val x) || isWiredInShape x  isWiredInLoc :: F.LocSymbol -> Bool-isWiredInLoc x  = l == l' && l == F.safePos 1 && c == c' && c' == F.safePos 1+isWiredInLoc sym  = ln == ln' && ln == F.safePos 1 && c == c' && c' == F.safePos 1   where-    (l , c)  = spe (loc x)-    (l', c') = spe (locE x)+    (ln , c)  = spe (loc sym)+    (ln', c') = spe (locE sym)     spe l    = (x, y) where (_, x, y) = F.sourcePosElts l  isWiredInName :: F.Symbol -> Bool@@ -63,7 +64,7 @@ wiredInNames = S.fromList [ "head", "tail", "fst", "snd", "len"]  isWiredInShape :: F.LocSymbol -> Bool-isWiredInShape x = any (`F.isPrefixOfSym` (val x)) [F.anfPrefix, F.tempPrefix, dcPrefix]+isWiredInShape x = any (`F.isPrefixOfSym` val x) [F.anfPrefix, F.tempPrefix, dcPrefix]   -- where s        = val x         -- dcPrefix = "lqdc" @@ -71,8 +72,8 @@ dcPrefix = "lqdc"  wiredSortedSyms :: [(F.Symbol, F.Sort)]-wiredSortedSyms = [(pappSym n, pappSort n) | n <- [1..pappArity]]-+wiredSortedSyms = (selfSymbol,selfSort):[(pappSym n, pappSort n) | n <- [1..pappArity]]+  where selfSort = F.FAbs 1 (F.FVar 0) -------------------------------------------------------------------------------- -- | LH Primitive TyCons ------------------------------------------------------- --------------------------------------------------------------------------------@@ -126,9 +127,9 @@     lt = rApp c [] [] mempty      listTyDataCons :: ([TyConP] , [DataConP])-listTyDataCons   = ( [(TyConP l0 c [RTV tyv] [p] [Covariant] [Covariant] (Just fsize))]-                   , [(DataConP l0 Ghc.nilDataCon  [RTV tyv] [p] [] []    lt False wiredInName l0)-                     ,(DataConP l0 Ghc.consDataCon [RTV tyv] [p] [] cargs lt False wiredInName l0)])+listTyDataCons   = ( [TyConP l0 c [RTV tyv] [p] [Covariant] [Covariant] (Just fsize)]+                   , [DataConP l0 Ghc.nilDataCon  [RTV tyv] [p] [] []    lt False wiredInName l0+                   ,  DataConP l0 Ghc.consDataCon [RTV tyv] [p] [] cargs lt False wiredInName l0])     where       l0         = F.dummyPos "LH.Bare.listTyDataCons"       c          = Ghc.listTyCon@@ -149,8 +150,8 @@ wiredInName = "WiredIn"  tupleTyDataCons :: Int -> ([TyConP] , [DataConP])-tupleTyDataCons n = ( [(TyConP   l0 c  (RTV <$> tyvs) ps tyvarinfo pdvarinfo Nothing)]-                    , [(DataConP l0 dc (RTV <$> tyvs) ps []  cargs  lt False wiredInName l0)])+tupleTyDataCons n = ( [TyConP   l0 c  (RTV <$> tyvs) ps tyvarinfo pdvarinfo Nothing]+                    , [DataConP l0 dc (RTV <$> tyvs) ps []  cargs  lt False wiredInName l0])   where     tyvarinfo     = replicate n     Covariant     pdvarinfo     = replicate (n-1) Covariant
src/LiquidHaskell.hs view
@@ -1,20 +1,9 @@-{-# LANGUAGE CPP #-}- module LiquidHaskell (     -- * LiquidHaskell Specification QuasiQuoter     lq-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)     -- * LiquidHaskell as a compiler plugin   , plugin-#endif-#endif   ) where  import Language.Haskell.Liquid.UX.QuasiQuoter--#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) import Language.Haskell.Liquid.GHC.Plugin (plugin)-#endif-#endif
tests/Parser.hs view
@@ -364,8 +364,15 @@       , "  {a<q> <: a<r>} "       , "  Ord a => OList (a<p>) -> OList (a<q>) -> OList a<r> "])         @?==-          "assume (++) :: forall <p :: a -> Bool, q :: a -> Bool, r :: a -> Bool> .\n               (Ord a) =>\n               {x :: {VV : a<p> | true} |- {VV : a<q> | true} <: {v : a | x <= v}} =>\n               {|- {VV : a<p> | true} <: {VV : a<r> | true}} =>\n               {|- {VV : a<q> | true} <: {VV : a<r> | true}} =>\n               lq_tmp$db##13:(OList {VV : a<p> | true}) -> lq_tmp$db##15:(OList {VV : a<q> | true}) -> (OList {VV : a<r> | true})"-+          -- "assume (++) :: forall <p :: a -> Bool, q :: a -> Bool, r :: a -> Bool> .\n               (Ord a) =>\n               {x :: {VV : a<p> | true} |- {VV : a<q> | true} <: {v : a | x <= v}} =>\n               {|- {VV : a<p> | true} <: {VV : a<r> | true}} =>\n               {|- {VV : a<q> | true} <: {VV : a<r> | true}} =>\n               lq_tmp$db##13:(OList {VV : a<p> | true}) -> lq_tmp$db##15:(OList {VV : a<q> | true}) -> (OList {VV : a<r> | true})"+         (unlines +           [ "assume (++) :: forall <p##1##23 :: a -> Bool, q##1##23 :: a -> Bool, r##1##23 :: a -> Bool>."+           , "               (Ord a) =>"+           , "               {x :: {VV : a<p##1##23> | true} |- {VV : a<q##1##23> | true} <: {v : a | x <= v}} =>"+           , "               {|- {VV : a<p##1##23> | true} <: {VV : a<r##1##23> | true}} =>"+           , "               {|- {VV : a<q##1##23> | true} <: {VV : a<r##1##23> | true}} =>"+           , "               lq_tmp$db##13:(OList {VV : a<p##1##23> | true}) -> lq_tmp$db##15:(OList {VV : a<q##1##23> | true}) -> (OList {VV : a<r##1##23> | true})"+         ])     , testCase "type spec 9" $        parseSingleSpec (unlines $           [ "data AstF f <ix :: AstIndex -> Bool>"@@ -393,7 +400,13 @@           , "       {x::Int<q> |- {v:Int| v = x + 1} <: Int<q>}"           , "       (Int<p> -> ()) -> x:Int<q> -> ()" ])           @?==-            "app :: forall <p :: Int -> Bool, q :: Int -> Bool> .\n       {|- (Int <{VV : _<q> | true}>) <: (Int <{VV : _<p> | true}>)} =>\n       {x :: (Int <{VV : _<q> | true}>) |- {v : Int | v == x + 1} <: (Int <{VV : _<q> | true}>)} =>\n       lq_tmp$db##8:(lq_tmp$db##9:(Int <{VV : _<p> | true}>) -> ()) -> x:(Int <{VV : _<q> | true}>) -> ()"+ --            "app :: forall <p :: Int -> Bool, q :: Int -> Bool> .\n       {|- (Int <{VV : _<q> | true}>) <: (Int <{VV : _<p> | true}>)} =>\n       {x :: (Int <{VV : _<q> | true}>) |- {v : Int | v == x + 1} <: (Int <{VV : _<q> | true}>)} =>\n       lq_tmp$db##8:(lq_tmp$db##9:(Int <{VV : _<p> | true}>) -> ()) -> x:(Int <{VV : _<q> | true}>) -> ()"+            (unlines +              [ "app :: forall <p##1##15 :: Int -> Bool, q##1##15 :: Int -> Bool>."+              , "       {|- (Int <{VV : _<q##1##15> | true}>) <: (Int <{VV : _<p##1##15> | true}>)} =>"+              , "       {x :: (Int <{VV : _<q##1##15> | true}>) |- {v : Int | v == x + 1} <: (Int <{VV : _<q##1##15> | true}>)} =>"+              , "       lq_tmp$db##8:(lq_tmp$db##9:(Int <{VV : _<p##1##15> | true}>) -> ()) -> x:(Int <{VV : _<q##1##15> | true}>) -> ()"+            ])      , testCase "type spec 12" $        parseSingleSpec (unlines $@@ -402,8 +415,14 @@           , "         {x::a<p> |- {v:a | x <= v} <: a<q>}"           , "         xs:[{v:a<p> | 0 <= v}] -> {v:a<q> | len xs >= 0 && 0 <= v } "])           @?==-            "ssum :: forall <p :: a -> Bool, q :: a -> Bool> .\n        {|- {v : a | v == 0} <: {VV : a<q> | true}} =>\n        {x :: {VV : a<p> | true} |- {v : a | x <= v} <: {VV : a<q> | true}} =>\n        xs:[{v : a<p> | 0 <= v}] -> {v : a<q> | len xs >= 0\n                                                && 0 <= v}"-+            -- "ssum :: forall <p :: a -> Bool, q :: a -> Bool> .\n        {|- {v : a | v == 0} <: {VV : a<q> | true}} =>\n        {x :: {VV : a<p> | true} |- {v : a | x <= v} <: {VV : a<q> | true}} =>\n        xs:[{v : a<p> | 0 <= v}] -> {v : a<q> | len xs >= 0\n                                                && 0 <= v}"+           (unlines +              [ "ssum :: forall <p##1##16 :: a -> Bool, q##1##16 :: a -> Bool>."+              , "        {|- {v : a | v == 0} <: {VV : a<q##1##16> | true}} =>"+              , "        {x :: {VV : a<p##1##16> | true} |- {v : a | x <= v} <: {VV : a<q##1##16> | true}} =>"+              , "        xs:[{v : a<p##1##16> | 0 <= v}] -> {v : a<q##1##16> | len xs >= 0"+              , "                                                              && 0 <= v}"+           ])     , testCase "type spec 13" $        -- removing duplicate conjuncts also affects the order in which the        -- surviving conjuncts are returned@@ -450,8 +469,11 @@      , testCase "type spec 21" $        parseSingleSpec "newRGRef :: forall <p :: a -> Bool, r :: a -> a -> Bool >.\n   e:a<p> ->\n  e2:a<r e> ->\n  f:(x:a<p> -> y:a<r x> -> {v:a<p> | (v = y)}) ->\n IO (RGRef <p, r> a)" @?==-            "newRGRef :: forall <p :: a -> Bool, r :: a a -> Bool> .\n            e:{VV : a<p> | true} -> e2:{VV : a<r e> | true} -> f:(x:{VV : a<p> | true} -> y:{VV : a<r x> | true} -> {v : a<p> | v == y}) -> (IO (RGRef <{VV : _<p> | true}, {VV : _<r> | true}> a))"-+            -- "newRGRef :: forall <p :: a -> Bool, r :: a a -> Bool> .\n            e:{VV : a<p> | true} -> e2:{VV : a<r e> | true} -> f:(x:{VV : a<p> | true} -> y:{VV : a<r x> | true} -> {v : a<p> | v == y}) -> (IO (RGRef <{VV : _<p> | true}, {VV : _<r> | true}> a))"+            (unlines [ "newRGRef :: forall <p##1##20 :: a -> Bool, r##1##20 :: a a -> Bool>."+                     , "            e:{VV : a<p##1##20> | true} -> e2:{VV : a<r##1##20 e> | true} -> f:(x:{VV : a<p##1##20> | true} -> y:{VV : a<r##1##20 x> | true} -> {v : a<p##1##20> | v == y}) -> (IO (RGRef <{VV : _<p##1##20> | true}, {VV : _<r##1##20> | true}> a))"+                     ]+            )     , testCase "type spec 21" $        parseSingleSpec "cycle        :: {v: [a] | len(v) > 0 } -> [a]" @?==             "cycle :: v:{v : [a] | len v > 0} -> [a]"
tests/errors/AmbiguousInline.hs view
@@ -6,7 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module MatchIdxs where+module AmbiguousInline where  import qualified Data.ByteString as BS -- RJ import qualified Data.ByteString.Search as BS
tests/errors/AmbiguousReflect.hs view
@@ -1,6 +1,6 @@ {-@ LIQUID "--reflection"  @-} -module StringIndexing where+module AmbiguousReflect where  -- ISSUE: Uncomment the below to make this test pass --
tests/errors/BadAliasApp.hs view
@@ -1,4 +1,5 @@-module BadExprArg where+{-@ LIQUID "--expect-error-containing=Malformed application of type alias `ListN`" @-}+module BadAliasApp where  {-@ type ListN a N = {v:[a] | len v = N} @-}
tests/errors/BadAnnotation.hs view
@@ -1,4 +1,5 @@-module Zoo where+{-@ LIQUID "--expect-error-containing=Malformed annotation" @-}+module BadAnnotation where  {-@ incr :: x:Int -> {v:Int | x < v } -} incr :: Int -> Int
tests/errors/BadAnnotation1.hs view
@@ -1,4 +1,5 @@-module Zoo where+{-@ LIQUID "--expect-error-containing=Malformed annotation" @-}+module BadAnnotation1 where  {-@ incr :: x:Int           -> {v:Int | x < v }
tests/errors/BadData0.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-error-containing=Unknown type constructor `Zoog`" @-} module BadData0 where  data Zog = Z Int
tests/errors/BadData1.hs view
@@ -1,7 +1,10 @@+{-@ LIQUID "--expect-error-containing=Data constructors in refinement do not match original datatype for `EntityField`" @-} {-@ LIQUID "--no-adt"         @-} {-@ LIQUID "--exact-data-con" @-}  {-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-}++module BadData1 where  class PersistEntity record where     data EntityField record :: * -> *
tests/errors/BadData2.hs view
@@ -1,6 +1,7 @@+{-@ LIQUID "--expect-error-containing=Data constructors in refinement do not match original datatype for `Hog`" @-} {-@ LIQUID "--exact-data-cons" @-} -module Boo where+module BadData2 where  -- The reason this fails is because the constructor we use in the -- refinement for Hog is in fact a constructor of T.
tests/errors/BadDataCon2.hs view
@@ -1,4 +1,5 @@-module Boo where+{-@ LIQUID "--expect-error-containing=GHC and Liquid specifications have different numbers of fields for `BadDataCon2.Cuthb`" @-}+module BadDataCon2 where  {-@ data T = Cuthb { fldX :: Int, fldY :: Int } @-}
tests/errors/BadDataConType.hs view
@@ -1,4 +1,6 @@-module Boo where+{-@ LIQUID "--expect-error-containing=Illegal type specification for `BadDataConType.fldY`" @-}+{-@ LIQUID "--expect-error-containing=Specified type does not refine Haskell type for `BadDataConType.fldY`" @-}+module BadDataConType where  {-@ data T = C { fldX :: Int, fldY :: Bool } @-}
tests/errors/BadDataConType1.hs view
@@ -1,4 +1,5 @@-module Boo where+{-@ LIQUID "--expect-error-containing=Specified type does not refine Haskell type for `BadDataConType1.C`" @-}+module BadDataConType1 where  {-@ data T = C { fldX :: Int, fldY :: String } @-}
tests/errors/BadDataConType2.hs view
@@ -1,4 +1,5 @@-module Boo where+{-@ LIQUID "--expect-error-containing=different numbers of fields for `BadDataConType2.C`" @-}+module BadDataConType2 where  {-@ data T = C { fldX :: Int } @-}
tests/errors/BadDataDeclTyVars.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-error-containing=Mismatch in number of type variables for `L`" @-} -- | With ADTs, the below fails with a nasty 'elaborate' error, when --   the actual problem is a malformed refined data-declaration where --   the type variable 'a' has been left out.@@ -7,7 +8,7 @@ {-@ LIQUID "--reflection" @-} {-@ LIQUID "--ple"        @-}  -module MonoidList where+module BadDataDeclTyVars where  {-@ data L = Emp | Cons {x::a, xs:: (L a)} @-} --       ^ whoops, missing a tyvar!
tests/errors/BadGADT.hs view
@@ -1,6 +1,9 @@+{-@ LIQUID "--expect-error-containing=Specified type does not refine Haskell type for `BadGADT.Nil2`" @-} {-# LANGUAGE GADTs #-}  {-@ LIQUID "--no-termination" @-}++module BadGADT where  {-@ data List a where        Nil  :: List a
tests/errors/BadPragma0.hs view
@@ -1,6 +1,7 @@+{-@ LIQUID "--expect-error-containing=Illegal pragma" @-} {-@ LIQUID "--idirs=.." @-} -module Bad where +module BadPragma0 where  i :: Int i = 1
tests/errors/BadPragma1.hs view
@@ -1,6 +1,7 @@+{-@ LIQUID "--expect-error-containing=Illegal pragma" @-} {-@ LIQUID "--c-files=./wow.c" @-} -module Bad where +module BadPragma1 where  i :: Int i = 1
tests/errors/BadPragma2.hs view
@@ -1,6 +1,7 @@+{-@ LIQUID "--expect-error-containing=Illegal pragma" @-} {-@ LIQUID "--ghc-option=-O0" @-} -module Bad where +module BadPragma2 where  i :: Int i = 1
tests/errors/BadPredApp.hs view
@@ -1,4 +1,5 @@-module Boo where+{-@ LIQUID "--expect-error-containing=Malformed predicate application" @-}+module BadPredApp where  {-@ data X <q :: Int -> Int -> Bool> = X (x0 :: Int) (x1 :: Int<q x0>) @-}   data X = X Int Int
tests/errors/BadQualifier.hs view
@@ -1,4 +1,4 @@-module RG where+module BadQualifier where data RGRef a {-@ measure tv :: RGRef a -> a @-} {-@ qualif TERMINALVALUE(r:RGRef a): (tv r) @-}
tests/errors/BadSig0.hs view
@@ -1,4 +1,5 @@-module Zoo where+{-@ LIQUID "--expect-error-containing=Illegal type specification for `BadSig0.foo`" @-}+module BadSig0 where  {-@ measure prop :: a -> b @-} {-@ type Prop E = {v:_ | pro v = E} @-}
tests/errors/BadSig1.hs view
@@ -1,8 +1,9 @@+{-@ LIQUID "--expect-error-containing=Illegal type specification for `BadSig1.EZ`" @-} {-# LANGUAGE GADTs #-}  {-@ LIQUID "--exact-data-con" @-} -module Ev where+module BadSig1 where  data Peano where   Z :: Peano
tests/errors/BadSyn1.hs view
@@ -1,4 +1,5 @@-module Zoo where+{-@ LIQUID "--expect-error-containing=Malformed application of type alias `Fooz`" @-}+module BadSyn1 where  type Foo = Int
tests/errors/BadSyn2.hs view
@@ -1,4 +1,5 @@-module Zoo where+{-@ LIQUID "--expect-error-containing=Malformed application of type alias `BadSyn2.Foo`" @-}+module BadSyn2 where  type Foo = Int
tests/errors/BadSyn3.hs view
@@ -1,4 +1,5 @@-module Zoo where+{-@ LIQUID "--expect-error-containing=Malformed application of type alias `BadSyn3.Foo`" @-}+module BadSyn3 where  type Foo = Int
tests/errors/BadSyn4.hs view
@@ -1,4 +1,5 @@-module Foo where+{-@ LIQUID "--expect-error-containing=Malformed application of type alias `BadSyn4.Point`" @-}+module BadSyn4 where  type List a = [a] type Point  = List Double
tests/errors/CyclicExprAlias0.hs view
@@ -1,4 +1,5 @@-module Test0 () where+{-@ LIQUID "--expect-error-containing=Cyclic type alias definition" @-}+module CyclicExprAlias0 () where  {-@ expression CyclicA1 Q = CyclicA1 Q @-}
tests/errors/CyclicExprAlias1.hs view
@@ -1,4 +1,5 @@-module Test2 () where+{-@ LIQUID "--expect-error-containing=Cyclic type alias definition" @-}+module CyclicExprAlias1 () where  {-@ expression CyclicB1 Q = CyclicB2 Q @-} {-@ expression CyclicB2 Q = CyclicB1 Q @-}
tests/errors/CyclicExprAlias2.hs view
@@ -1,4 +1,5 @@-module Test3 () where+{-@ LIQUID "--expect-error-containing=Cyclic type alias definition" @-}+module CyclicExprAlias2 () where  {-@ expression CyclicC1 Q = (CyclicC2 Q) && (CyclicC3 Q) @-} {-@ expression CyclicC2 Q = CyclicC1 Q @-}
tests/errors/CyclicExprAlias3.hs view
@@ -1,4 +1,5 @@-module Test3 () where+{-@ LIQUID "--expect-error-containing=Cyclic type alias definition" @-}+module CyclicExprAlias3 () where  {-@ expression CyclicD1 Q = CyclicD2 Q @-} {-@ expression CyclicD2 Q = CyclicD3 Q @-}
tests/errors/CyclicPredAlias0.hs view
@@ -1,4 +1,5 @@-module Test0 () where+{-@ LIQUID "--expect-error-containing=Cyclic type alias definition for `CyclicA1`" @-}+module CyclicPredAlias0 () where  {-@ predicate CyclicA1 Q = CyclicA1 Q @-}
tests/errors/CyclicPredAlias1.hs view
@@ -1,4 +1,5 @@-module Test1 () where+{-@ LIQUID "--expect-error-containing=Cyclic type alias definition for `CyclicB1`" @-}+module CyclicPredAlias1 () where  {-@ predicate CyclicB1 Q = CyclicB2 Q @-} {-@ predicate CyclicB2 Q = CyclicB1 Q @-}
tests/errors/CyclicPredAlias2.hs view
@@ -1,4 +1,6 @@-module Test2 () where+{-@ LIQUID "--expect-error-containing=Cyclic type alias definition for `CyclicC1`" @-}++module CyclicPredAlias2 () where  {-@ predicate CyclicC1 Q = CyclicC2 Q && CyclicC3 Q @-} {-@ predicate CyclicC2 Q = CyclicC1 Q @-}
tests/errors/CyclicPredAlias3.hs view
@@ -1,4 +1,5 @@-module Test3 () where+{-@ LIQUID "--expect-error-containing=Cyclic type alias definition for `CyclicD1`" @-}+module CyclicPredAlias3 () where  {-@ predicate CyclicD1 Q = CyclicD2 Q @-} {-@ predicate CyclicD2 Q = CyclicD3 Q @-}
tests/errors/CyclicTypeAlias0.hs view
@@ -1,4 +1,5 @@-module Test0 () where+{-@ LIQUID "--expect-error-containing=Cyclic type alias definition for `CyclicA1`" @-}+module CyclicTypeAlias0 () where  {-@ type CyclicA1 = CyclicA2 @-} {-@ type CyclicA2 = CyclicA1 @-}
tests/errors/CyclicTypeAlias1.hs view
@@ -1,4 +1,5 @@-module Test1 () where+{-@ LIQUID "--expect-error-containing=Cyclic type alias definition for `CyclicB1`" @-}+module CyclicTypeAlias1 () where  {-@ type CyclicB1 = CyclicB2 @-} {-@ type CyclicB2 = CyclicB3 @-}
tests/errors/CyclicTypeAlias2.hs view
@@ -1,4 +1,5 @@-module Test2 () where+{-@ LIQUID "--expect-error-containing=Cyclic type alias definition for `CyclicC`" @-}+module CyclicTypeAlias2 () where  {-@ type CyclicC = [CyclicC] @-}
tests/errors/CyclicTypeAlias3.hs view
@@ -1,4 +1,5 @@-module Test3 () where+{-@ LIQUID "--expect-error-containing=Cyclic type alias definition for `CyclicD2" @-}+module CyclicTypeAlias3 () where  {-@ type CyclicD1 = CyclicD2 @-} {-@ type CyclicD2 = CyclicD3 @-}
tests/errors/DupAlias.hs view
@@ -1,4 +1,6 @@-module Goo () where+{-@ LIQUID "--expect-error-containing=Multiple definitions of Type Alias `BoundedNat`" @-}+{-@ LIQUID "--expect-error-containing=Multiple definitions of Pred Alias `Foo`" @-}+module DupAlias () where  import Language.Haskell.Liquid.Prelude
tests/errors/DupData.hs view
@@ -1,6 +1,7 @@+{-@ LIQUID "--expect-error-containing=Multiple specifications for `OVec`" @-} -- | See https://github.com/ucsd-progsys/liquidhaskell/issues/1175 -module BadVec where+module DupData where  data OVec a = ONil             | (:>>) {oHd :: a, oTl :: OVec a}
tests/errors/DupFunSigs.hs view
@@ -1,4 +1,7 @@+{-@ LIQUID "--expect-error-containing=Multiple specifications for `DupFunSigs.fromWeekDayNum`" @-} -- See https://github.com/ucsd-progsys/liquidhaskell/issues/1137++module DupFunSigs where  import Data.List
tests/errors/DupMeasure.hs view
@@ -1,4 +1,5 @@-module DuplicateMeasures where +{-@ LIQUID "--expect-error-containing=Multiple specifications for `lenA`" @-}+module DupMeasure where   {-@ measure lenA :: [a] -> Int
tests/errors/ElabLocation.hs view
@@ -1,13 +1,15 @@--- | This file tests that LH correctly localizes the elaboration error +-- | This file tests that LH correctly localizes the elaboration error --   to the '10 / x' term (where we get a sort-error as the 'Ratio Int' --   is compared against '0' which appears in the refinement for '/'.)---   You can fix this by `embed Ratio * as Int` +--   You can fix this by `embed Ratio * as Int` +{-@ LIQUID "--expect-error-containing=ElabLocation.hs:15:14" @-}+ module ElabLocation where -import Data.Ratio +import Data.Ratio  foo :: Ratio Int -> Bool-foo x = y == y -  where +foo x = y == y+  where     y = 10 / x
+ tests/errors/ElabLocation2.hs view
@@ -0,0 +1,18 @@+{-@ LIQUID "--expect-error-containing=ElabLocation2.hs:18:54-66" @-}+module ElabLocation2 where+type Range = (Int,Int)++{-@ measure start @-}+start :: Range -> Int+start (a,b) = a++{-@ measure end @-}+end :: Range -> Int+end (a,b) = b++{-@ using (Range) as {r:Range | start r <= end r} @-}++-- seemed to work earlier, now fails+{-@ intsToRanges :: Int -> Int -> Int -> Int -> Maybe (Range,Range) @-}+intsToRanges :: Int -> Int -> Int -> Int -> Maybe (Range,Range)+intsToRanges a b c d = if a <= b && c <= d then Just ((a,b),(c,d)) else Nothing
+ tests/errors/ElabLocation3.hs view
@@ -0,0 +1,210 @@+module ElabLocation3 where+{-@ LIQUID "--expect-error-containing=ElabLocation3.hs:174:1-5" @-}+{-@ LIQUID "--reflection" @-}++import Language.Haskell.Liquid.ProofCombinators+import Prelude hiding (id)++{-@ type Pos = {v:Int | 0 < v} @-}++{-@ incr :: Pos -> Pos @-}+incr :: Int -> Int+incr x = x + 2++++{-@+data Monkey =+  M { number :: Nat,+      items :: [Int],+      operation :: Int -> Int,+      testMod :: {n:Int | n > 0 },+      ifTrue :: Nat,+      ifFalse :: Nat,+      count :: Nat+    }+@-}+data Monkey =+  M { number :: Int,+      items :: [Int],+      operation :: Int -> Int,+      testMod :: Int,+      ifTrue :: Int,+      ifFalse :: Int,+      count :: Int }++{-@ myCount :: _ -> Nat @-}+myCount :: Monkey -> Int +myCount M { count = k}  = k +++showMonkey :: Monkey -> String+showMonkey (M n i o m ifT ifF count) =+  "#" ++ (show n) ++ " items " ++ (show i) ++ " examined " ++ (show count) ++ "\n"++instance Show Monkey where show = showMonkey++{-@ type MonkeyIR X = {m:Monkey | number m < X && ifTrue m < X && ifFalse m < X } @-}++-- fst = item+-- snd = destination+{-@ type MonkeyItem X = (Int, {n:Nat | n < X}) @-}++{-@ turn :: x:Int -> {worry:Int | worry /= 0 } -> {modulus:Int | modulus /= 0} -> m:MonkeyIR x -> {d:[MonkeyItem x] | len d = len (items m)} @-}+turn :: Int -> Int -> Int -> Monkey -> [(Int, Int)]+turn _ worry modulus (M _ oldItems op m dTrue dFalse _) =+  map toDestination oldItems where+  toDestination i = let newWorry = (( op i ) `div` worry) `mod` modulus in+    (newWorry, if newWorry `mod` m == 0 then dTrue else dFalse)++-- What I would like to do:+-- measure countOfItems :: [Monkey] -> Int+-- countOfItems [] = 0+-- countOfItems (m:ms) = len (items m) + countOfItems ms+--+--      -> {m2:[MonkeyIR x] | len m2 = len m && countOfItems m2 = countOfItems m + len mi} +--+-- But this measure gets applied to all lists, which doesn't work++{-@ data MonkeyList = Empty | MCons { headMonkey :: MonkeyIR 8, barrel :: MonkeyList } @-}+data MonkeyList =+  Empty |+  MCons Monkey MonkeyList++{-@ measure mLen :: MonkeyList -> Int+      mLen Empty = 0+      mLen (MCons m ms) = 1 + mLen  ms +  @-}++{-@ measure countOfItems :: MonkeyList -> Int+      countOfItems Empty = 0+      countOfItems (MCons m ms) = len (items m) + countOfItems ms @-}++{-+{-@ distribute2 :: m:MonkeyList -> {mi:[MonkeyItem 8] | len mi <= mLen m}+     -> {m2:MonkeyList | mLen m2 = mLen m && countOfItems m2 = countOfItems m + len mi} @-}+distribute2 :: MonkeyList -> [(Int,Int)] -> MonkeyList +distribute2 Empty [] = Empty+distribute2 Empty _ = error "Shouldn't happen"+distribute2 (MCons m ms) destinations =+  MCons (m {items = (items m) ++ newItems}) (distribute2 ms (filter (notP toMe) destinations)) where+  newItems = map fst (filter toMe destinations)+  toMe (_,d) = d == number m+-}++{-@ distribute :: x:Int -> m:[MonkeyIR x] -> mi:[MonkeyItem x]+     -> {m2:[MonkeyIR x] | len m2 = len m} @-}+distribute :: Int -> [Monkey] -> [(Int,Int)] -> [Monkey]+distribute _ [] _ = []+distribute x (m:ms) destinations =+  (m {items = (items m) ++ newItems}):(distribute x ms destinations) where+  newItems = map fst (filter toMe destinations)+  toMe (_,d) = d == number m++-- Monkey N's turn in the round+{-@ roundN :: x:Int -> +              {worry:Int | worry /= 0 } -> +	      {modulus:Int | modulus /= 0} -> +	      {before:[MonkeyIR x] | len before = x} -> +	      {n:Nat | n < x } -> +	      {after:[m:MonkeyIR x] | len after = x} @-}+roundN :: Int -> Int -> Int -> [Monkey] -> Int -> [Monkey]+roundN x worry modulus monkeys n =+  let m = (monkeys !! n)+      destinations = turn x worry modulus m+      newCount = (myCount m) + length (items m)+      afterRemoval = (take n monkeys) ++ [(m {items = [], count = newCount} )] ++ (drop (n+1) monkeys) in+    distribute x afterRemoval destinations++-- One round of all monkeys+-- Complicated by the need to prove termination.+{-@ round :: x:Int -> {worry:Int | worry /= 0} -> {modulus:Int | modulus /= 0 } -> +             {before:[MonkeyIR x] | len before = x} -> +	     {after:[MonkeyIR x] | len after = x} @-}+round :: Int -> Int -> Int -> [Monkey] -> [Monkey]+round x worry modulus monkeys = go 0 monkeys where+  {-@ go :: {n:Int | n >= 0 && n <= x} -> {m:[MonkeyIR x] | len m = x} -> {m2:[MonkeyIR x] | len m2 = x} / [ x - n ] @-}+  go n ms = if n == x then ms+    else go (n+1) (roundN x worry modulus ms n)+++{-@ m0 :: MonkeyIR 4 @-}+m0 = M { number=0, items=[79,98], operation=(\o -> o * 19), testMod=23, ifTrue=2, ifFalse=3, count=0 }+{-@ m1 :: MonkeyIR 4 @-}+m1 = M { number=1, items=[54,65,75,74], operation=(\o -> o + 6), testMod=19, ifTrue=2, ifFalse=0, count=0 }+{-@ m2 :: MonkeyIR 4 @-}+m2 = M { number=2, items=[79,60,97], operation=(\o -> o * o), testMod=13, ifTrue=1, ifFalse=3, count=0 }+{-@ m3 :: MonkeyIR 4 @-}+m3 = M { number=3, items=[74], operation=(\o -> o + 3), testMod=17, ifTrue=0, ifFalse=1, count=0 }+       +{-@ example :: {m:[MonkeyIR 4] | len m = 4} @-}+example :: [Monkey]+example = [ m0, m1, m2, m3 ]++{-@ i0 :: MonkeyIR 8 @-}+i0 = M { number=0, items=[59,74,65,86], operation=(\o -> o * 19), testMod=7, ifTrue=6, ifFalse=2, count=0 }+{-@ i1 :: MonkeyIR 8 @-}+i1 = M { number=1, items=[62,84,72,91,68,78,51], operation=(\o -> o + 1), testMod=2, ifTrue=2, ifFalse=0, count=0 }+{-@ i2 :: MonkeyIR 8 @-}+i2 = M { number=2, items=[78,84,96], operation=(\o -> o + 8), testMod=19, ifTrue=6, ifFalse=5, count=0 }+{-@ i3 :: MonkeyIR 8 @-}+i3 = M { number=3, items=[97,86], operation=(\o -> o * o), testMod=3, ifTrue=1, ifFalse=0, count=0 }+{-@ i4 :: MonkeyIR 8 @-}+i4 = M { number=4, items=[50], operation=(\o -> o + 6), testMod=13, ifTrue=3, ifFalse=1, count=0 }+{-@ i5 :: MonkeyIR 8 @-}+i5 = M { number=5, items=[73,65,69,65,51], operation=(\o -> o * 17), testMod=11, ifTrue=4, ifFalse=7, count=0 }+{-@ i6 :: MonkeyIR 8 @-}+i6 = M { number=6, items=[69, 82, 97, 93, 82, 84, 58, 63], operation=(\o -> o + 5), testMod=5, ifTrue=5, ifFalse=7, count=0 }+{-@ i7 :: MonkeyIR 8 @-}+i7 = M { number=7, items=[81, 78, 82, 76, 79, 80], operation=(\o -> o + 3), testMod=17, ifTrue=3, ifFalse=4, count=0 }+       +{-@ input :: {m:[MonkeyIR 8] | len m = 8} @-}+input :: [Monkey]+input = [ i0, i1, i2, i3, i4, i5, i6, i7 ]++{-@ assume iterate :: (a -> a) -> a -> {l:[a] | len l >= 1000000 } @-}++computeModulus :: [Monkey] -> Int+computeModulus ms = foldl1 (*) (map testMod ms)+++id z = z++part1 :: () -> IO ()+part1 _ = do+  putStrLn "Part 1"+  let m1 = computeModulus example in do+    putStrLn $ "Working mod " ++ show m1+    let allRounds = iterate {- (Main.round 4 3 m1) -} id example in+      print $ allRounds !! 20+    +  let m2 = computeModulus input in do+    putStrLn $ "Working mod " ++ show m2    +    let allRounds2 = iterate {- (Main.round 8 3 m2) -} id input in+      print $ allRounds2 !! 20++part2 :: () -> IO ()+part2 _ = do+  putStrLn "Part 2"+  let m1 = computeModulus example in do+    putStrLn $ "Working mod " ++ show m1+    let allRounds = iterate {- (Main.round 4 1 m1) -} id example in do+      print $ allRounds !! 1000+      print $ allRounds !! 2000+      print $ allRounds !! 3000+      print $ allRounds !! 4000+      print $ allRounds !! 5000+      print $ allRounds !! 6000+      print $ allRounds !! 7000+      print $ allRounds !! 8000+      print $ allRounds !! 9000+      print $ allRounds !! 10000+      +  let m2 = computeModulus input in do+    putStrLn $ "Working mod " ++ show m2    +    let allRounds2 = iterate {- (Main.round 8 1 m2) -} id input in+      print $ allRounds2 !! 10000++mymain :: IO ()+mymain = part1 () >> part2 ()+
tests/errors/EmptyData.hs view
@@ -1,6 +1,7 @@+{-@ LIQUID "--expect-error-containing=one or more fields in the data declaration for `A`" @-} -- | see: https://github.com/ucsd-progsys/liquidhaskell/issues/1169 -module Bar where+module EmptyData where  {-@ data A @-} data A = B
− tests/errors/EmptySig.hs 
@@ -1,6 +0,0 @@--module Blank where--{-@  :: foo -> x:Int -> {v:Int | v > x} @-}-foo :: Int -> Int -foo x = x - 1
tests/errors/ErrLocation.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-error-containing=ErrLocation.hs:10:13" @-}  module ErrLocation where
tests/errors/ErrLocation2.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-error-containing=ErrLocation2.hs:12:20" @-}  module ErrLocation2 where
tests/errors/ExportMeasure0.hs view
@@ -1,6 +1,6 @@ -- FIX: module ExportMeasure (llen) where     -module ExportMeasure () where+module ExportMeasure0 () where  {-@ data LL [llen] @-} data LL a = N | C a (LL a)
tests/errors/ExportReflect0.hs view
@@ -3,7 +3,7 @@ {-@ LIQUID "--exactdc"     @-} {-@ LIQUID "--higherorder" @-} -module Bug (foo, zogbert) where+module ExportReflect0 (foo, zogbert) where  import Language.Haskell.Liquid.ProofCombinators
tests/errors/Fractional.hs view
@@ -1,4 +1,6 @@-module Crash where+{-@ LIQUID "--expect-error-containing=Illegal type specification for `Fractional.f`" @-}+{-@ LIQUID "--expect-error-containing=Illegal type specification for `Fractional.g`" @-}+module Fractional where  {-@ f :: (Num a) => {v:a | v > 0.0} -> a @-} f :: (Num a) => a -> a
+ tests/errors/Frog.hs view
@@ -0,0 +1,9 @@+{-@ LIQUID "--expect-error-containing=Unbound symbol GHC.Err.undefined" @-}++module Frog where++{-@ LIQUID "--reflection" @-}++{-@ reflect frog @-}+frog :: () -> Bool+frog () = undefined
tests/errors/HigherOrderBinder.hs view
@@ -1,3 +1,6 @@+{-@ LIQUID "--expect-error-containing=Illegal type specification for `HigherOrderBinder.foo`" @-}+module HigherOrderBinder where+ {-@ foo :: a: Int -> f: (Int -> Int) -> {v : Int | v = 123 + (f a) } @-} foo :: Int -> (Int -> Int) -> Int foo a f = f a
tests/errors/HintMismatch.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-error-containing=HINT: Use the hole" @-}  {-# LANGUAGE DataKinds #-}
tests/errors/HoleCrash1.hs view
@@ -1,4 +1,6 @@-module ListDemo where+{-@ LIQUID "--expect-error-containing=Illegal type specification for `HoleCrash1.t`" @-}+{-@ LIQUID "--expect-error-containing=Illegal type specification for `HoleCrash1.C`" @-}+module HoleCrash1 where  data Poo a = C { t :: Poo a }
tests/errors/HoleCrash2.hs view
@@ -1,4 +1,5 @@-module ListDemo where+{-@ LIQUID "--expect-error-containing=Malformed application of type alias `Geq`" @-}+module HoleCrash2 where  data Poo a = C { t :: Poo a }
tests/errors/HoleCrash3.hs view
@@ -1,4 +1,5 @@-module ListDemo where+{-@ LIQUID "--expect-error-containing=Specified type does not refine Haskell type for `HoleCrash3.countUp`" @-}+module HoleCrash3 where  data List a = E | (:::) { h :: a, t :: List a }
tests/errors/Inconsistent0.hs view
@@ -1,8 +1,11 @@+{-@ LIQUID "--expect-error-containing=Specified type does not refine Haskell type for `Inconsistent0.id1`" @-} -- FAILING TEST: this test SHOULD FAIL BUT DOESN'T -- issue #519 +{-@ LIQUID "--no-positivity-check" @-}+ {-# LANGUAGE DeriveFunctor #-}-module Ast where+module Inconsistent0 where  data AstIndex = IxExpr | IxType
tests/errors/Inconsistent1.hs view
@@ -1,4 +1,5 @@-module Boo where+{-@ LIQUID "--expect-error-containing=Specified type does not refine Haskell type for `Inconsistent1.incr` (Checked)" @-}+module Inconsistent1 where  {-@ incr :: Int -> Bool @-} incr :: Int -> Int
tests/errors/Inconsistent2.hs view
@@ -1,4 +1,5 @@-module Mismatch where+{-@ LIQUID "--expect-error-containing=Specified type does not refine Haskell type for `Inconsistent2.foo` (Checked)" @-}+module Inconsistent2 where  {-@ foo :: Nat @-} foo :: Bool
tests/errors/InlineSubExp0.hs view
@@ -1,10 +1,11 @@+{-@ LIQUID "--expect-error-containing=== f B C" @-}  -- https://github.com/ucsd-progsys/liquidhaskell/issues/1258  {-@ LIQUID "--reflection"  @-} {-@ LIQUID "--short-names" @-}  -module T1258 where +module InlineSubExp0 where  import Language.Haskell.Liquid.ProofCombinators
tests/errors/InlineSubExp1.hs view
@@ -1,10 +1,11 @@+{-@ LIQUID "--expect-error-containing== f B (g A)" @-}  -- https://github.com/ucsd-progsys/liquidhaskell/issues/1258  {-@ LIQUID "--reflection"  @-} {-@ LIQUID "--short-names" @-} -module T1258 where +module InlineSubExp1 where  import Language.Haskell.Liquid.ProofCombinators
tests/errors/IrregularData.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-error-containing=is not a subtype of the required type" @-} {-@ LIQUID "--reflection" @-}  module IrregularData where
tests/errors/LiftMeasureCase.hs view
@@ -1,16 +1,17 @@-module Measures where+{-@ LIQUID "--expect-error-containing=Cannot create measure 'LiftMeasureCase.foo': Does not have a case-of at the top-level" @-}+module LiftMeasureCase where  llen :: [a] -> Int llen [] = 0 llen (x:xs) = 1 + llen xs  {-@ measure foo @-}-foo :: a -> a +foo :: a -> a foo x = x  {-@ measure lllen @-}  {-@ lllen :: xs:[a] -> {v:Int| (lllen xs) = v} @-}-lllen :: [a] -> Int	+lllen :: [a] -> Int lllen [] = 0 lllen (x:xs) = 1 + lllen xs
tests/errors/LocalHole.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-error-containing=Illegal type specification for `go`" @-} {-@ LIQUID "--no-termination" @-}  module LocalHole where
tests/errors/MissingAssume.hs view
@@ -1,4 +1,5 @@-module OverWrite where+{-@ LIQUID "--expect-error-containing=Unknown variable `goober`" @-}+module MissingAssume where  import qualified Data.Set
tests/errors/MissingField1.hs view
@@ -1,5 +1,7 @@ -- TODO-REBARE: LH _should_ (?) complain: "Unknown field `goober` in refined definition of `Foo`" +module MissingField1 where+ data Foo = F Int   {-@ data Foo = F { goober :: Int } @-}
tests/errors/MissingField2.hs view
@@ -1,6 +1,5 @@--- TODO-REBARE: LH _should_ (?) complain: "Unknown field `fxx` in refined definition of `F`"--module Invariant where+{-@ LIQUID "--expect-error-containing=Unbound symbol fxx"@-}+module MissingField2 where  data F a = F {fx :: a, fy :: a, fzz :: a} | G {fx :: a}
tests/errors/MissingReflect.hs view
@@ -1,5 +1,8 @@+{-@ LIQUID "--expect-error-containing=Illegal type specification for `MissingReflect.empty_foo`" @-} {-@ LIQUID "--reflection"                     @-} {-@ LIQUID "--ple"                                @-}++module MissingReflect where  import Language.Haskell.Liquid.ProofCombinators
tests/errors/MissingSizeFun.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-error-containing=Unknown variable `llen2`" @-} {-@ LIQUID "--nostruct" @-}  module MissingSizeFun where
tests/errors/MultiInstMeasures.hs view
@@ -1,4 +1,5 @@-module Blank where+{-@ LIQUID "--expect-error-containing=Multiple instance measures `sizeOf` for type `GHC.Ptr.Ptr`" @-}+module MultiInstMeasures where  import Data.Word import GHC.Ptr
tests/errors/MultiRecSels.hs view
@@ -1,5 +1,6 @@+{-@ LIQUID "--expect-error-containing=Duplicated definitions for field `left`" @-} {-@ LIQUID "--no-termination" @-}-module RedBlack  where+module MultiRecSels where  data RBTree a = Leaf               | Node Color a !(RBTree a) !(RBTree a)
− 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/Positivity1.hs view
@@ -0,0 +1,24 @@+{-@ LIQUID "--expect-error-containing=Negative occurence of Positivity1.Rec" @-}+module Positivity1 where++newtype Rec a = In { out :: Rec a -> a }++y :: (a -> a) -> a+y f = g (In g)+  where+    -- ghc would say: Simplifier ticks exhausted+    -- if we don't prevent this from inlining+    {-# NOINLINE g #-}+    g x = f (out x x)++{-@ foo :: n:Nat -> {v:Nat | v < n} @-}+foo :: Int -> Int+foo = y go+  where go f n = if n > 0 then n-1 else f n++prop = let x = 0 in+       assert ((\n -> 0==1) (foo 0))++{-@ assert :: b:{Bool | b} -> () @-} +assert :: Bool -> () +assert _ = ()
+ tests/errors/Positivity2.hs view
@@ -0,0 +1,15 @@+{-@ LIQUID "--expect-error-containing=Negative occurence of Positivity2.Evil in Positivity2.Very" @-}+module Positivity2 where++data Evil a = Very (Evil a -> a)++{-@ type Bot = {v: () | false} @-}++{-@ bad :: Evil Bot -> Bot @-}+{-# NOINLINE bad #-}+bad :: Evil () -> ()+bad (Very f) = f (Very f)++{-@ worse :: Bot @-}+worse :: ()+worse = bad (Very bad)
+ tests/errors/PositivityCheck.hs view
@@ -0,0 +1,16 @@+{-@ LIQUID "--expect-error-containing=Negative occurence of PositivityCheck.Bad1" @-}+{-@ LIQUID "--expect-error-containing=Negative occurence of PositivityCheck.Bad2" @-}+{-@ LIQUID "--expect-error-containing=Negative occurence of PositivityCheck.Bad3" @-}+{-@ LIQUID "--expect-error-containing=Negative occurence of PositivityCheck.Bad4" @-}+{-@ LIQUID "--expect-error-containing=Negative occurence of PositivityCheck.BadRec1" @-}+{-@ LIQUID "--expect-error-containing=Negative occurence of PositivityCheck.BadRec2" @-}+module PositivityCheck where++data Bad1 a = No11 (Bad1 a -> Int) | No12 (Bad1 a) +data Bad2 a = No2 (Int -> Bad2 a -> Int)+data Bad3 a = No3 (Bad3 Int -> Int)+data Bad4 a = Bar (Flip (Flip (Flip (Bad4 a))))+type Flip a = a -> Int ++data BadRec1 a = NoRec1 (BadRec2 a -> Int)+data BadRec2 a = NoRec2 (BadRec1 a)
tests/errors/ReWrite5.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-error-containing=parameter \"xs\" contains an inner refinement" @-} module ReWrite5 where  {-@ LIQUID "--reflection" @-}
tests/errors/ReWrite6.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-error-containing=Unable to use ReWrite6.bad as a rewrite because it does not prove an equality" @-} module ReWrite6 where  -- Reject non equalities
tests/errors/ReWrite7.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-error-containing=Could not generate any rewrites from equality" @-} module ReWrite7 where {-@ LIQUID "--reflection" @-} {-@ LIQUID "--ple" @-}
tests/errors/ReWrite8.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-error-containing=Could not generate any rewrites from equality" @-} module ReWrite8 where  {-@ LIQUID "--reflection" @-}
tests/errors/ReflectLam.hs view
@@ -1,7 +1,7 @@ {-@ LIQUID "--reflection" @-}  -module ReflectLam where +module ReflectLam where
tests/errors/ShadowFieldInline.hs view
@@ -1,6 +1,7 @@+{-@ LIQUID "--expect-error-containing=Multiple specifications for `pig`" @-} {-@ LIQUID "--exactdc" @-} -module Range where+module ShadowFieldInline where  -- LH should give an error message that the field selectors `pig` -- is shadowed and should be renamed.
tests/errors/ShadowFieldReflect.hs view
@@ -1,6 +1,7 @@+{-@ LIQUID "--expect-error-containing=Multiple specifications for `pig`" @-} {-@ LIQUID "--exactdc" @-} -module Range where+module ShadowFieldReflect where  -- LH should give an error message that the field selectors `pig` -- is shadowed and should be renamed.
tests/errors/ShadowMeasure.hs view
@@ -1,9 +1,10 @@+{-@ LIQUID "--expect-error-containing=Multiple specifications for `shadow`" @-}  -- ISSUE: Currently this doesn't CRASH because the two sorts for `shadow` are the -- same, but that is a happy coincidence. We should REJECT this program as the -- measure has the same name as another binder. -module Shadow where+module ShadowMeasure where  data Poo = Poo Int
tests/errors/ShadowMeasureVar.hs view
@@ -1,6 +1,6 @@ -- REJECT this program as the measure has the same name as another binder. -module Shadow where+module ShadowMeasureVar where  data Poo = Poo Int
tests/errors/SplitSubtype.hs view
@@ -1,4 +1,5 @@-module FocusSubtype where +{-@ LIQUID "--expect-error-containing=| VV > 5}" @-}+module SplitSubtype where  {-@ foo :: {v:Int | v > 0 && v > 5 && v < 10 } -> Int @-} foo :: Int -> Int
tests/errors/T1140.hs view
@@ -1,6 +1,7 @@+{-@ LIQUID "--expect-error-containing=Specified type does not refine Haskell type for `T1140.foo`" @-} -module Blank where -	+module T1140 where+ data Label = Label Int   type Proof = ()
tests/errors/T1498.hs view
@@ -1,4 +1,5 @@-module T1498 where +{-@ LIQUID "--expect-error-containing=Standalone class method refinement" @-}+module T1498 where  class A a where   f :: a -> Int
tests/errors/T1498A.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-error-containing=Bad Data Specification" @-} module T1498A where  class A a where
tests/errors/T1708.hs view
@@ -1,3 +1,6 @@+{-# OPTIONS_GHC -Wno-missing-methods #-}+{-@ LIQUID "--expect-error-containing=Unbound symbol T1708.bool1" @-}+{-@ LIQUID "--expect-error-containing=Unbound symbol T1708.bool2" @-} {-@ LIQUID "--reflection"  @-} {-@ LIQUID "--ple"         @-} {-@ LIQUID "--no-totality" @-}
tests/errors/T773.hs view
@@ -1,8 +1,9 @@+{-@ LIQUID "--expect-error-containing=Illegal type specification for `T773.incr`" @-} -- | Right now this gives a rather mysterious error,  --   cannot unify `int` with `(a b)` it would be nice  --   to actually point out the offending sub-expression, namely `len x`. -module LiquidR where+module T773 where  {-@ measure goober :: String -> Int @-}
tests/errors/T774.hs view
@@ -1,7 +1,8 @@+{-@ LIQUID "--expect-error-containing=Illegal type specification for `T774.incr`" @-}  -- | Why does this NOT fail?! Clearly there is a sort error?! -module LiquidR where+module T774 where  {-@ measure goober :: String -> Int @-}
tests/errors/TODOUnboundAbsRef.hs view
@@ -2,7 +2,7 @@ -- LH happily chugs along, and just says UNSAT at the end, instead of -- pointing out the bogus datatype definition. -module ListRange () where+module TODOUnboundAbsRef () where  import Language.Haskell.Liquid.Prelude
tests/errors/TODOVarInTypeAlias.hs view
@@ -3,7 +3,7 @@ {-@ LIQUID "--totality"       @-} {-@ LIQUID "--exactdc"        @-} -module RL1015 where+module TODOVarInTypeAlias where  import Language.Haskell.Liquid.ProofCombinators
tests/errors/TerminationExprNum.hs view
@@ -1,4 +1,5 @@-module TerminationExpr where+{-@ LIQUID "--expect-error-containing=Illegal termination specification for `TerminationExprNum.showSep`" @-}+module TerminationExprNum where  {-@ showSep :: _ -> xs:_ -> _ / [xs] @-} -- use xs as reducing param showSep :: String -> [String] -> String
tests/errors/TerminationExprSort.hs view
@@ -1,4 +1,5 @@-module TerminationExpr where+{-@ LIQUID "--expect-error-containing=Illegal termination specification for `TerminationExprSort.showSep`" @-}+module TerminationExprSort where  {-@ showSep :: _ -> xs:_ -> _ / [len ys] @-} -- use xs as reducing param showSep :: String -> [String] -> String
tests/errors/TerminationExprUnb.hs view
@@ -1,4 +1,5 @@-module LocalTermExpr where+{-@ LIQUID "--expect-error-containing=Illegal termination specification for `go`" @-}+module TerminationExprUnb where  {- assume (!!) :: xs:[a] -> {v:Nat | v < len xs} -> a @-}
tests/errors/UnboundAbsRef.hs view
@@ -1,10 +1,11 @@+{-@ LIQUID "--expect-error-containing=Cannot apply unbound abstract refinement `p`" @-}  -- ISSUE: this "crashes" without a decent source location -- You can fix this with the signature `ide :: forall <p :: a -> Prop>. a<p> -> a<p>` -- but it would be nice to have an error message that pinpoints the location. -- https://github.com/ucsd-progsys/liquidhaskell/issues/655 -module Ide where+module UnboundAbsRef where  {-@ ide :: a<p> -> a<p> @-} ide x = x
tests/errors/UnboundCheckVar.hs view
@@ -1,6 +1,6 @@ {-@ LIQUID "--checks=ink" @-} -module UnboundCheckVar where +module UnboundCheckVar where  inc :: Int -> Int  inc x = x + 1
tests/errors/UnboundFunInSpec.hs view
@@ -1,4 +1,5 @@-module Goo () where+{-@ LIQUID "--expect-error-containing=Illegal type specification for `UnboundFunInSpec.three`" @-}+module UnboundFunInSpec () where  cnt   :: Int -> Int cnt 0 = 0
tests/errors/UnboundFunInSpec1.hs view
@@ -1,4 +1,5 @@-module Goo where+{-@ LIQUID "--expect-error-containing=Illegal type specification for `UnboundFunInSpec1.foo`" @-}+module UnboundFunInSpec1 where  {-@ foo :: xs:_ -> {v:_ | this = rubbish } @-} foo _ _ = 0
tests/errors/UnboundFunInSpec2.hs view
@@ -1,4 +1,5 @@-module Goo where+{-@ LIQUID "--expect-error-containing=Illegal type specification for `UnboundFunInSpec2.foo`" @-}+module UnboundFunInSpec2 where  {-@ foo :: Num a => { z : (xs:t -> {v : (t -> a) | this = rubbish }) | wow = hi } @-} foo :: Num a => t -> t -> a
tests/errors/UnboundVarInAssume.hs view
@@ -1,4 +1,5 @@-module Assume where+{-@ LIQUID "--expect-error-containing=Illegal type specification for `UnboundVarInAssume.incr`" @-}+module UnboundVarInAssume where  {-@ assume incr :: Int -> {v : Int | v == x} @-} incr :: Int -> Int
tests/errors/UnboundVarInLocSig.hs view
@@ -1,4 +1,5 @@-module Local02 where +{-@ LIQUID "--expect-error-containing=Illegal type specification for `bar`" @-}+module UnboundVarInLocSig where  {-@ foo :: x:_ -> y:_ -> {v:Int | v = x + y} @-}  foo :: Int -> Int -> Int
tests/errors/UnboundVarInReflect.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-error-containing=Illegal type specification for `UnboundVarInReflect.frog`" @-} module UnboundVarInReflect where  -- see GH #1708
tests/errors/UnboundVarInSpec.hs view
@@ -1,4 +1,5 @@-module Fixme where+{-@ LIQUID "--expect-error-containing=Illegal type specification for `UnboundVarInSpec.foo`" @-}+module UnboundVarInSpec where   {-@ foo :: forall <p :: s -> s -> Bool>.
− tests/errors/frog.hs 
@@ -1,8 +0,0 @@--module Frog where--{-@ LIQUID "--reflection" @-}--{-@ reflect frog @-}-frog :: () -> Bool-frog () = undefined
+ tests/import/client/C.hs view
@@ -0,0 +1,9 @@+{-@ LIQUID "--reflection" @-}++module C where +import Language+import B++{-@ getVal :: {e:Expr l st r | isEFalse e } -> {v:Int | false} @-}+getVal :: Expr l st r -> Int+getVal (EFalse v) = v
tests/import/client/CliAliasGen00.hs view
@@ -1,4 +1,4 @@-module CliAliasGen00 where +module CliAliasGen00 where  import LibAliasGen00
tests/import/client/CliRedBlue.hs view
@@ -1,4 +1,4 @@-module CliRedBlue where +module CliRedBlue where  import           LibBlue  import qualified LibRedBlue as RB
tests/import/client/Client0.hs view
@@ -1,6 +1,6 @@-module Client0 where +module Client0 where -    import Client1 +    import Client1Lib          a :: Eq a => B a -> Bool      a (B x y) = x == y
− tests/import/client/Client1.hs 
@@ -1,8 +0,0 @@-module Client1 where --    import Client2-    -    data B a = B {b1 :: a, b2 :: a }-    {-@ data B a = B {b1 :: a, b2 :: {v:a | cProp b1 v } } @-}--
+ tests/import/client/Client1Lib.hs view
@@ -0,0 +1,8 @@+module Client1Lib where ++    import Client2Lib+    +    data B a = B {b1 :: a, b2 :: a }+    {-@ data B a = B {b1 :: a, b2 :: {v:a | cProp b1 v } } @-}++
− tests/import/client/Client2.hs 
@@ -1,8 +0,0 @@-module Client2 where --    {-@ reflect cProp @-}-    -    cProp :: Eq a => a -> a -> Bool -    cProp x y = x == y --
+ tests/import/client/Client2Lib.hs view
@@ -0,0 +1,8 @@+module Client2Lib where ++    {-@ reflect cProp @-}+    +    cProp :: Eq a => a -> a -> Bool +    cProp x y = x == y ++
tests/import/client/ExactGADT9.hs view
@@ -5,7 +5,7 @@  module ExactGADT9 where -import ExactGADT8+import ExactGADT8Lib  {-@ reflect bar @-} bar :: RefinedFilter Blob typ -> Bool
tests/import/client/FunClashLibLibClient.hs view
@@ -4,7 +4,7 @@ -- but SOMEHOW block this. [Current workaround: make sure you import-qualified `FunClashLibLib`  -- so that the name "attaches" properly. sigh. -module FunClashLibLibClient where  +module FunClashLibLibClient where  import FunClashLib
tests/import/client/LibRedBlue.hs view
@@ -1,4 +1,4 @@-module LibRedBlue where +module LibRedBlue where  import LibRed  import qualified LibBlue as Blue
tests/import/client/LiquidArrayInit.hs view
@@ -3,7 +3,7 @@ module LiquidArrayInit () where  import Language.Haskell.Liquid.Prelude-import LiquidArray+import LiquidArrayLib  {-@ zero ::       i: {v: Int | v >= 0} ->
tests/import/client/LiquidArrayNullTerm.hs view
@@ -4,7 +4,7 @@  import Language.Haskell.Liquid.Prelude -import LiquidArray+import LiquidArrayLib  upperCaseString' :: Int -> Int -> (Int -> Int) -> (Int -> Int) upperCaseString' n i s =
tests/import/client/NameClashClient.hs view
@@ -1,4 +1,4 @@-module NameClashClient where +module NameClashClient where  import qualified NameClashLib as Lib
tests/import/client/RC1015.hs view
@@ -3,7 +3,7 @@  module RC1015 where -import RL1015+import RL1015Lib  {-@ car :: f:Foo -> { v: a | fooFirst f 0 == 10 } -> Int @-} car :: Foo -> a -> Int
tests/import/client/ReExportClient.hs view
@@ -1,6 +1,6 @@-module ReExportClient where +module ReExportClient where -import ReExport +import ReExportLib  {-@ bar :: Foo -> {v:Int | 0 < v} @-}  bar :: Foo -> Int
tests/import/client/ReflectClient1.hs view
@@ -1,4 +1,4 @@-module ReflectClient0 where+module ReflectClient1 where  import ReflectLib1
tests/import/client/ReflectClient4.hs view
tests/import/client/T1096_Foo.hs view
@@ -1,6 +1,6 @@ module T1096_Foo where -import T1096_Types +import T1096_TypesLib  {-@ foo  :: f:Foo -> Foo / [size f] @-} foo  :: Foo -> Foo
tests/import/client/T1180.hs view
@@ -3,9 +3,9 @@ {-@ LIQUID "--exact-data-con" @-} {-@ LIQUID "--noadt" @-} -module Ev where+module T1180 where -import Peano +import PeanoLib  pInt :: Peano -> Int  pInt Z     = 0 
+ tests/import/lib/B.hs view
@@ -0,0 +1,8 @@+{-@ LIQUID "--reflection" @-}+module B  where +import Language++{-@ reflect subst @-}+subst :: Expr l st r -> Expr l st r +subst EUnit  = EUnit+subst e  = e 
− tests/import/lib/ExactGADT8.hs 
@@ -1,32 +0,0 @@-{-@ LIQUID "--reflection" @-}-{-@ LIQUID "--no-adt"     @-}--{-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-}-----------------------------------------------------------------------------------module ExactGADT8 where--class PersistEntity record where-    data EntityField record :: * -> *--{-@ data Blob  = Bingo { xVal :: Int, yVal :: Int } @-}-data Blob  = Bingo { xVal :: Int, yVal :: Int }--instance PersistEntity Blob where-  data EntityField Blob typ where-    BlobXVal :: EntityField Blob Int-    BlobYVal :: EntityField Blob Int--data RefinedFilter record typ = RefinedFilter-  { refinedFilterField  :: EntityField record typ-  }--evalQBlob :: RefinedFilter Blob typ -> Blob -> Bool-evalQBlob filter blob = case refinedFilterField filter of-  BlobXVal -> True-  BlobYVal -> True--{-@ reflect foo @-}-foo :: RefinedFilter Blob typ -> Blob -> Bool-foo (RefinedFilter BlobXVal) blob = True-foo (RefinedFilter BlobYVal) blob = True
+ tests/import/lib/ExactGADT8Lib.hs view
@@ -0,0 +1,32 @@+{-@ LIQUID "--reflection" @-}+{-@ LIQUID "--no-adt"     @-}++{-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-}++--------------------------------------------------------------------------------+module ExactGADT8Lib where++class PersistEntity record where+    data EntityField record :: * -> *++{-@ data Blob  = Bingo { xVal :: Int, yVal :: Int } @-}+data Blob  = Bingo { xVal :: Int, yVal :: Int }++instance PersistEntity Blob where+  data EntityField Blob typ where+    BlobXVal :: EntityField Blob Int+    BlobYVal :: EntityField Blob Int++data RefinedFilter record typ = RefinedFilter+  { refinedFilterField  :: EntityField record typ+  }++evalQBlob :: RefinedFilter Blob typ -> Blob -> Bool+evalQBlob filter blob = case refinedFilterField filter of+  BlobXVal -> True+  BlobYVal -> True++{-@ reflect foo @-}+foo :: RefinedFilter Blob typ -> Blob -> Bool+foo (RefinedFilter BlobXVal) blob = True+foo (RefinedFilter BlobYVal) blob = True
+ tests/import/lib/Language.hs view
@@ -0,0 +1,10 @@+module Language where++data Expr l st r = EUnit | EFalse Int +{-@ data Expr l st r = EUnit | EFalse { elb1 :: {xxx:Int | false}}  @-}+++{-@ measure isEFalse @-}+isEFalse :: Expr l st r -> Bool +isEFalse (EFalse _ ) = True +isEFalse _ = False 
− tests/import/lib/LiquidArray.hs 
@@ -1,20 +0,0 @@-module LiquidArray where--{-@ set :: forall a <p :: x0: Int -> x1: a -> Bool, r :: x0: Int -> Bool>.-      i: Int<r> ->-      x: a<p i> ->-      a: (j: {v: Int<r> | v != i} -> a<p j>) ->-      (k: Int<r> -> a<p k>) @-}-set :: Int -> a -> (Int -> a) -> (Int -> a)-set i x a = \k -> if k == i then x else a k--{-@ get :: forall a <p :: x0: Int -> x1: a -> Bool, r :: x0: Int -> Bool>.-             i: Int<r> ->-             a: (j: Int<r> -> a<p j>) ->-             a<p i> @-}-get :: Int -> (Int -> a) -> a-get i a = a i--{-@ empty :: i: {v: Int | 0 = 1} -> a @-}-empty :: Int -> a-empty = const undefined 
+ tests/import/lib/LiquidArrayLib.hs view
@@ -0,0 +1,20 @@+module LiquidArrayLib where++{-@ set :: forall a <p :: x0: Int -> x1: a -> Bool, r :: x0: Int -> Bool>.+      i: Int<r> ->+      x: a<p i> ->+      a: (j: {v: Int<r> | v != i} -> a<p j>) ->+      (k: Int<r> -> a<p k>) @-}+set :: Int -> a -> (Int -> a) -> (Int -> a)+set i x a = \k -> if k == i then x else a k++{-@ get :: forall a <p :: x0: Int -> x1: a -> Bool, r :: x0: Int -> Bool>.+             i: Int<r> ->+             a: (j: Int<r> -> a<p j>) ->+             a<p i> @-}+get :: Int -> (Int -> a) -> a+get i a = a i++{-@ empty :: i: {v: Int | 0 = 1} -> a @-}+empty :: Int -> a+empty = const undefined 
− tests/import/lib/Peano.hs 
@@ -1,33 +0,0 @@-{-# LANGUAGE GADTs #-}--{-@ LIQUID "--exact-data-con" @-}-{-@ LIQUID "--higherorder"    @-}-{-@ LIQUID "--ple"            @-}-{-@ LIQUID "--noadt"          @-}---module Peano where------------------------------------------------------------------------------------- | Peano Numbers ------------------------------------------------------------------------------------------------------------------------------------------------{-@ data Peano [toNat] @-}-data Peano where-  Z :: Peano-  S :: Peano -> Peano--{-@ measure toNat @-}-{-@ toNat :: Peano -> Nat @-}-toNat :: Peano -> Int-toNat Z     = 0-toNat (S n) = 1 + toNat n--{-@ reflect plus @-}-plus :: Peano -> Peano -> Peano-plus Z     n = n-plus (S m) n = S (plus m n)--{-@ reflect double @-}-double :: Peano -> Peano-double n = plus n n
+ tests/import/lib/PeanoLib.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE GADTs #-}++{-@ LIQUID "--exact-data-con" @-}+{-@ LIQUID "--higherorder"    @-}+{-@ LIQUID "--ple"            @-}+{-@ LIQUID "--noadt"          @-}+++module PeanoLib where++--------------------------------------------------------------------------------+-- | Peano Numbers -------------------------------------------------------------+--------------------------------------------------------------------------------++{-@ data Peano [toNat] @-}+data Peano where+  Z :: Peano+  S :: Peano -> Peano++{-@ measure toNat @-}+{-@ toNat :: Peano -> Nat @-}+toNat :: Peano -> Int+toNat Z     = 0+toNat (S n) = 1 + toNat n++{-@ reflect plus @-}+plus :: Peano -> Peano -> Peano+plus Z     n = n+plus (S m) n = S (plus m n)++{-@ reflect double @-}+double :: Peano -> Peano+double n = plus n n
− tests/import/lib/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/RL1015Lib.hs view
@@ -0,0 +1,18 @@+{-@ LIQUID "--exactdc" @-}+{-@ LIQUID "--higherorder" @-}++module RL1015Lib where++data Foo = Foo { fooFirst :: Int -> Int , fooSnd :: Int}++{-@ data Foo = Foo { fooFirst :: Int -> Int , fooSnd :: Nat } @-}++{-@ bar :: f:Foo -> { v: a | fooFirst f 0 == 10 } -> Int @-}+bar :: Foo -> a -> Int+bar f _ = 10++{-@ reflect bling @-}+bling :: Int -> Int+bling x = 10++bag = bar (Foo bling 10) (bling 0)
− tests/import/lib/ReExport.hs 
@@ -1,6 +0,0 @@-module ReExport ( module ReExport-  , module X-  ) where---import Spec as X
+ tests/import/lib/ReExportLib.hs view
@@ -0,0 +1,6 @@+module ReExportLib ( module ReExportLib+  , module X+  ) where+++import SpecLib as X
− tests/import/lib/Spec.hs 
@@ -1,9 +0,0 @@-module Spec where --data Foo = FooDC Int -{-@ data Foo = FooDC {unfoo :: {v:Int | 0 < v }} @-} --{-@ measure cfun @-}-{-@ cfun :: Foo -> {v:Int | 0 < v} @-} -cfun :: Foo -> Int -cfun (FooDC x) = x
+ tests/import/lib/SpecLib.hs view
@@ -0,0 +1,9 @@+module SpecLib where ++data Foo = FooDC Int +{-@ data Foo = FooDC {unfoo :: {v:Int | 0 < v }} @-} ++{-@ measure cfun @-}+{-@ cfun :: Foo -> {v:Int | 0 < v} @-} +cfun :: Foo -> Int +cfun (FooDC x) = x
− tests/import/lib/T1096_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/T1096_TypesLib.hs view
@@ -0,0 +1,13 @@+{-@ LIQUID "--no-termination" @-}++module T1096_TypesLib where++data Foo = A Foo | B ++size :: Foo -> Integer ++{-@ measure size @-}+{- invariant {t:Foo | 0 <= size t} @-}+{-@ size :: Foo -> {v:Integer |  0 <= v }  @-}+size (A x) = 1 + size x+size B     = 0 
tests/neg/AbsApp.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} -- FAILING TEST: This should be rejected if we wish to disallow applying -- concrete refinements to non-refined types (e.g. Int) where they are currently -- silently dropped.
tests/neg/AdtPeano0.hs view
@@ -1,7 +1,8 @@+{-@ LIQUID "--expect-any-error" @-} {-@ LIQUID "--exact-data-con" @-} {-@ LIQUID "--higherorder"    @-} -module Peano where+module AdtPeano0 where  data Influx = Silly Int 
tests/neg/AdtPeano1.hs view
@@ -1,7 +1,8 @@+{-@ LIQUID "--expect-any-error" @-} {-@ LIQUID "--exact-data-con"                      @-} {-@ LIQUID "--higherorder"                         @-} -module Peano where+module AdtPeano1 where  data Influx = Silly { goo :: Int } 
+ tests/neg/Alias00.hs view
@@ -0,0 +1,11 @@+{-@ LIQUID "--expect-any-error" @-}+module Alias00 () where++{-@ type NegInt = {v: Int | v <= 0} @-}+{-@ myabs :: Int -> NegInt @-}+myabs :: Int -> Int+myabs x = if (x > 0) then x else (0 - x)++{-@ type NNList a = {v: [a] | len(v) = 0} @-}+{-@ single :: a -> NNList a @-}+single x = [x] 
+ tests/neg/Ass0.hs view
@@ -0,0 +1,15 @@+{-@ LIQUID "--expect-any-error" @-}+module Ass0 (testError) where++-- import Language.Haskell.Liquid.Prelude (liquidAssert)++{-@ assert foo :: x:a -> {v: a | (v != x) } @-}+foo x = x ++testError :: Int -> Int +testError x = bar x +++{-@ bar :: Nat -> Nat @-} +bar :: Int -> Int +bar x = x
tests/neg/Ast.hs view
@@ -1,8 +1,10 @@+{-@ LIQUID "--expect-any-error" @-} -- FAILING TEST: this test SHOULD FAIL BUT DOESN'T -- issue #519 +{-@ LIQUID "--no-positivity-check" @-} {-# LANGUAGE DeriveFunctor #-}-module AST where+module Ast where  data AstIndex = IxExpr | IxType 
tests/neg/AutoSize.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} module AutoSize where  import GHC.Base
tests/neg/AutoTerm1.hs view
@@ -1,4 +1,5 @@-module Isort where+{-@ LIQUID "--expect-any-error" @-}+module AutoTerm1 where  data F = F | C Int F   
tests/neg/Automate.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} {-@ LIQUID "--ple-local" @-} module Automate where 
tests/neg/BadNats.hs view
@@ -1,4 +1,5 @@-module Nats where+{-@ LIQUID "--expect-any-error" @-}+module BadNats where  {-@ poo :: {v:Int | v == 0 } @-} poo :: Int 
+ tests/neg/Bag1.hs view
@@ -0,0 +1,21 @@+{-@ LIQUID "--expect-any-error" @-}+module Bag1 where++import qualified Data.Set as S+import Language.Haskell.Liquid.Bag as B++{-@ zorg :: {v:B.Bag Int | v = B.empty} @-}+zorg :: B.Bag Int+zorg = B.empty++{-@ measure elems @-}+elems :: (Ord a) => [a] -> B.Bag a+elems []     = B.empty+elems (x:xs) = B.put x (elems xs)++{-@ prop0 :: x:_ -> TT @-}+prop0 :: Int -> Bool+prop0 x = (B.get x b == 3) +  where+    a   = elems [x, x]+    b   = B.union a a 
tests/neg/Baz.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} {-@ LIQUID "--short-names" @-}  module Baz where
tests/neg/BigNum.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} module BigNum where  {-@ type Foo = { v : Integer | 0 <= v && v < 4611686018427387903 * 8 } @-}
tests/neg/BinarySearchOverflow.hs view
@@ -1,6 +1,7 @@+{-@ LIQUID "--expect-any-error" @-} {-@ LIQUID "--no-termination" @-} -module BinarySearch where+module BinarySearchOverflow where  import Prelude hiding (Num(..)) import CheckedNum 
tests/neg/Books.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} {-# LANGUAGE CPP #-}  #define DISCOUNT_PERCENTAGE   2
tests/neg/CastedTotality.hs view
@@ -1,4 +1,5 @@-module Fixme where+{-@ LIQUID "--expect-any-error" @-}+module CastedTotality where  import Language.Haskell.Liquid.Prelude 
tests/neg/CharLiterals.hs view
@@ -1,6 +1,7 @@+{-@ LIQUID "--expect-any-error" @-} -- see #1286 -module Example where+module CharLiterals where  {-@ fails :: {v:Bool | v} @-} fails =  'a' == 'b'
tests/neg/CheckedNum.hs view
@@ -1,30 +1,31 @@+{-@ LIQUID "--expect-any-error" @-} module CheckedNum where  -- Hiding numeric operations, because they get by default translated to SMT equivalent import Prelude hiding (Num(..)) -import qualified Prelude as Prelude +import qualified Prelude as Prelude -class CheckedNum a where -  (+) :: a -> a -> a -  (-) :: a -> a -> a +class CheckedNum a where+  (+) :: a -> a -> a+  (-) :: a -> a -> a  {-@ predicate BoundInt X = 0 < X + 10000 && X < 10000 @-}  instance CheckedNum Int where-{-@ instance CheckedNum Int where -      - :: x:Int -> y:{v:Int | BoundInt (x - v)} -> {v: Int | v == x - y} ;  -      + :: x:Int -> y:{v:Int | BoundInt (x + v)} -> {v: Int | v == x + y} +{-@ instance CheckedNum Int where+      - :: x:Int -> y:{v:Int | BoundInt (x - v)} -> {v: Int | v == x - y} ;+      + :: x:Int -> y:{v:Int | BoundInt (x + v)} -> {v: Int | v == x + y}   @-}-	x - y = (Prelude.-) x y  +    x - y = (Prelude.-) x y -	x + y = (Prelude.+) x y  +    x + y = (Prelude.+) x y  {-@ good :: {v:Int | v == 9999} @-}-good :: Int -good = 5000 + 4999 +good :: Int+good = 5000 + 4999  {-@ bad :: {v:Int | v == 10001} @-}-bad :: Int +bad :: Int bad = 5000 + 5001 
+ tests/neg/CheckedNumLib.hs view
@@ -0,0 +1,31 @@+{-@ LIQUID "--expect-any-error" @-}+module CheckedNumLib where++-- Hiding numeric operations, because they get by default translated to SMT equivalent+import Prelude hiding (Num(..))++import qualified Prelude as Prelude ++class CheckedNum a where +  (+) :: a -> a -> a +  (-) :: a -> a -> a ++{-@ predicate BoundInt X = 0 < X + 10000 && X < 10000 @-}++instance CheckedNum Int where+{-@ instance CheckedNum Int where +      - :: x:Int -> y:{v:Int | BoundInt (x - v)} -> {v: Int | v == x - y} ;  +      + :: x:Int -> y:{v:Int | BoundInt (x + v)} -> {v: Int | v == x + y} +  @-}+	x - y = (Prelude.-) x y  ++	x + y = (Prelude.+) x y  ++{-@ good :: {v:Int | v == 9999} @-}+good :: Int +good = 5000 + 4999 ++{-@ bad :: {v:Int | v == 10001} @-}+bad :: Int +bad = 5000 + 5001+
tests/neg/Class1.hs view
@@ -1,6 +1,7 @@+{-@ LIQUID "--expect-any-error" @-} {-# LANGUAGE ScopedTypeVariables #-} {-@ LIQUID "--no-termination" @-}-module Class () where+module Class1 () where  import Language.Haskell.Liquid.Prelude import Prelude hiding (sum, length, (!!), Functor(..))
tests/neg/Class2.hs view
@@ -1,6 +1,7 @@+{-@ LIQUID "--expect-any-error" @-} {-# LANGUAGE ScopedTypeVariables #-} {-@ LIQUID "--no-termination" @-}-module Class () where+module Class2 () where  import Language.Haskell.Liquid.Prelude 
tests/neg/Class3.hs view
@@ -1,6 +1,7 @@+{-@ LIQUID "--expect-any-error" @-} {-# LANGUAGE ScopedTypeVariables #-} {-@ LIQUID "--no-termination" @-}-module Class where+module Class3 where  import Language.Haskell.Liquid.Prelude import Prelude hiding (sum, length, (!!), Functor(..))
tests/neg/Class4.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} {-# LANGUAGE ScopedTypeVariables #-} {-@ LIQUID "--no-termination" @-} 
tests/neg/CompareConstraints.hs view
@@ -1,6 +1,7 @@+{-@ LIQUID "--expect-any-error" @-} {-@ LIQUID "--no-totality" @-} -module Foo where+module CompareConstraints where  import Language.Haskell.Liquid.Prelude 
+ tests/neg/Concat.hs view
@@ -0,0 +1,22 @@+{-@ LIQUID "--expect-any-error" @-}+module Concat () where++import Language.Haskell.Liquid.Prelude++foo :: [Int]+foo = [1..10]++concatmap f ls = concat $ map f ls++myconcatmap f []     = []+myconcatmap f (x:xs) = (f x) ++ (myconcatmap f xs) +++chooseList x = [choose x]+r :: Int+r = 5++prop x = liquidAssertB (x == r)++propMap  = map prop $ myconcatmap chooseList foo+propMap1 = map prop $ concatmap   chooseList foo
+ tests/neg/Concat1.hs view
@@ -0,0 +1,39 @@+{-@ LIQUID "--expect-any-error" @-}+module Concat1 () where++import Language.Haskell.Liquid.Prelude++------------------------------------------------------------+------------ Longer Version of neg/polypred.hs -------------+------------------------------------------------------------++foo :: [[Int]]+foo = [[choose 1], [choose 2]]++-- concatmap f ls = concat $ map f ls++myconcat []     = []+myconcat (x:xs) = x ++ (myconcat xs) +++myconcat1 :: a -> [[Int]] -> [Int]+myconcat1 _ []     = []+myconcat1 f (x:xs) = x ++ (myconcat1 f xs) ++concat1 f = concat+myconcat2 f = myconcat++r :: Int+r = 5++prop x = liquidAssertB (x == r)++-- ok +-- propC0 = map prop $ myconcat foo+-- this is safe+-- propC1 = map prop $ myconcat foo+-- propC2 = map prop $ concat foo+-- propC3 = map prop $ concat1 id foo++propC4 = map prop $ myconcat1 id foo+
+ tests/neg/Concat2.hs view
@@ -0,0 +1,21 @@+{-@ LIQUID "--expect-any-error" @-}+module Concat2 () where++import Language.Haskell.Liquid.Prelude++foo :: [Int]+foo = [choose 1, choose 2]++-- myconcat1 :: (a -> a) -> [[Int]] -> [Int] +-- :: a goes to False -> safe+myconcat1 :: (a -> [(k,v)]) -> [a] -> [(k, v)]+myconcat1 _ []     = []+myconcat1 f (x:xs) = (f x) ++ (myconcat1 f xs) ++r :: Int+r = 5++prop (x, y) = liquidAssertB (x > r)+--  where r = 5+-- this is safe+propC = map prop $ myconcat1 (\x->[(x, x)]) foo
tests/neg/Constraints.hs view
@@ -1,4 +1,5 @@-module Compose where+{-@ LIQUID "--expect-any-error" @-}+module Constraints where  {-@ cmp :: forall < pref :: b -> Bool, postf :: b -> c -> Bool
tests/neg/ConstraintsAppend.hs view
@@ -1,4 +1,5 @@-module ListSort () where+{-@ LIQUID "--expect-any-error" @-}+module ConstraintsAppend () where  {-@ LIQUID "--no-termination" @-} 
+ tests/neg/Contra0.hs view
@@ -0,0 +1,19 @@+{-@ LIQUID "--expect-any-error" @-}+{-@ LIQUID "--no-termination" @-}+{-@ LIQUID "--short-names"    @-}++module Contra0 () where++import Language.Haskell.Liquid.Prelude (liquidAssert)+import Data.IORef+++{-@ data variance IO bivariant @-}+{-@ data variance IORef bivariant @-}++job :: IO () +job = do+  p <- newIORef (0 :: Int)+  writeIORef p 10+  v <- readIORef p+  liquidAssert (v == 0) $ return ()
+ tests/neg/Coretologic.hs view
@@ -0,0 +1,23 @@+{-@ LIQUID "--expect-any-error" @-}+module Coretologic where++import Data.Set++-- ISSUE: can we please allow things like `empty` to also+-- appear in type and alias specifications, not just in+-- measures as in `goo` below?++{-@ type IsEmp a = {v:[a] | listElts v = Data.Set.empty } @-}++{-@ foo :: IsEmp Int @-}+foo :: [Int]+foo = []++{-@ bar :: IsEmp Int @-}+bar :: [Int]+bar = [1]++{-@ measure goo @-}+goo        :: (Ord a) => [a] -> Set a+goo []     = empty+goo (x:xs) = (singleton x) `union` (goo xs)  
+ tests/neg/Csv.hs view
@@ -0,0 +1,39 @@+{-@ LIQUID "--expect-any-error" @-}+module Csv () where++-- | Using LiquidHaskell for CSV lists+-- c.f. http://www.reddit.com/r/scala/comments/1nhzi2/using_shapelesss_sized_type_to_eliminate_real/++data CSV = Csv { headers :: [String]+               , rows    :: [[String]]+               }++{-@ data CSV = Csv { headers :: [String]+                   , rows    :: [{v:[String] | (len v) = (len headers)}]+                   }+  @-}++-- Eeks, we missed the column name.++csvBad1 = Csv ["Date"] +              [ ["Mon", "1"]+              , ["Tue", "2"]+              , ["Wed", "3"] +              ]++-- Eeks, we missed a column.++csvBad2 = Csv ["Name", "Age"] +              [ ["Alice", "32"]+              , ["Bob"        ]+              , ["Cris" , "29"] +              ]+                      +-- All is well! ++csvGood = Csv ["Id", "Name", "Days"]+              [ ["1", "Jan", "31"]+              , ["2", "Feb", "28"]+              , ["3", "Mar", "31"]+              , ["4", "Apr", "30"] +              ]
+ tests/neg/Datacon_eq.hs view
@@ -0,0 +1,12 @@+{-@ LIQUID "--expect-any-error" @-}+module Datacon_eq (foo) where++-- This is a blank file.++data G = A | B++{-@ foo :: Int -> {v:G | v = A} @-}+foo  :: Int -> G+foo _ = B++
tests/neg/DependentTypes.hs view
@@ -1,10 +1,11 @@+{-@ LIQUID "--expect-any-error" @-} {-# LANGUAGE KindSignatures      #-} {-# LANGUAGE DataKinds           #-} {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-} -module DependeTypes where+module DependentTypes where  import GHC.TypeLits 
+ tests/neg/Elim000.hs view
@@ -0,0 +1,16 @@+{-@ LIQUID "--expect-any-error" @-}+module Elim000 () where++{-@ prop2 :: Int -> Nat @-}+prop2 :: Int -> Int+prop2 x = numAbsList x++numAbsList = glap numAbs++{-@ glap :: (a -> b) -> a -> b @-}+glap :: (a -> b) -> a -> b+glap = undefined++-- Adding the below signature makes it flag an error...+-- numAbs :: Int -> Int+numAbs x = if x > 0 then x else x
+ tests/neg/Elim_ex_compose.hs view
@@ -0,0 +1,10 @@+{-@ LIQUID "--expect-any-error" @-}+module Elim_ex_compose (prop) where++{-@ prop :: x:Nat -> {v:Int | v = x + 5} @-}+prop :: Int -> Int+prop = incr . incr . incr . incr++{-@ incr :: dog:Int -> {v:Int | v == dog + 1} @-}+incr :: Int -> Int+incr cat = cat + 1
+ tests/neg/Elim_ex_let.hs view
@@ -0,0 +1,16 @@+{-@ LIQUID "--expect-any-error" @-}++{-# LANGUAGE QuasiQuotes #-}++module Elim_ex_let (prop) where++import LiquidHaskell++[lq| type Nat = {v:Int | 0 <= v} |]++[lq| prop :: a -> Nat |]+prop _ = let x _ = let y = 0 +                   in+                     y - 3+         in +           x () + 2
+ tests/neg/Elim_ex_list.hs view
@@ -0,0 +1,23 @@+{-@ LIQUID "--expect-any-error" @-}++{-# LANGUAGE QuasiQuotes #-}++module Elim_ex_list (prop) where++import LiquidHaskell+import Prelude hiding (head)++--------------------------------------------------------------------------+[lq| prop :: a -> Even |]+prop _ = (head ys) - 1+  where +    ys = Cons 1 (Cons 2 (Cons 5 Nil))+--------------------------------------------------------------------------++[lq| type Even = {v:Int | v mod 2 == 0 } |]++data List a = Nil | Cons a (List a)++head :: List a -> a +head (Cons x _) = x+
+ tests/neg/Elim_ex_map_1.hs view
@@ -0,0 +1,22 @@+{-@ LIQUID "--expect-any-error" @-}+{-@ LIQUID "--no-termination" @-}++{-# LANGUAGE QuasiQuotes #-}++module Elim_ex_map_1 (prop) where++import LiquidHaskell++import Prelude hiding (map)++--------------------------------------------------------------------------+[lq| prop :: List Even -> List Even |]+prop xs = map (+ 2) (map (+ 1) xs)+--------------------------------------------------------------------------++[lq| type Even = {v:Int | v mod 2 == 0 } |]++data List a = Nil | Cons a (List a)++map f Nil         = Nil+map f (Cons x xs) = Cons (f x) (map f xs)
+ tests/neg/Elim_ex_map_2.hs view
@@ -0,0 +1,22 @@+{-@ LIQUID "--expect-any-error" @-}+{-@ LIQUID "--no-termination" @-}++{-# LANGUAGE QuasiQuotes #-}++module Elim_ex_map_2 (prop) where++import LiquidHaskell++import Prelude hiding (map)++--------------------------------------------------------------------------+[lq| prop :: List Even -> List Even |]+prop = map (+ 2) . map (+ 1)+--------------------------------------------------------------------------++[lq| type Even = {v:Int | v mod 2 == 0 } |]++data List a = Nil | Cons a (List a)++map f Nil         = Nil+map f (Cons x xs) = Cons (f x) (map f xs)
+ tests/neg/Elim_ex_map_3.hs view
@@ -0,0 +1,22 @@+{-@ LIQUID "--expect-any-error" @-}+{-@ LIQUID "--no-termination" @-}++{-# LANGUAGE QuasiQuotes #-}++module Elim_ex_map_3 (prop) where++import LiquidHaskell++import Prelude hiding (map)++--------------------------------------------------------------------------+[lq| prop :: List Even -> List Even |]+prop = map ((+ 0) . (+ 1))+--------------------------------------------------------------------------++[lq| type Even = {v:Int | v mod 2 == 0 } |]++data List a = Nil | Cons a (List a)++map f Nil         = Nil+map f (Cons x xs) = Cons (f x) (map f xs)
+ tests/neg/Errmsg.hs view
@@ -0,0 +1,24 @@+{-@ LIQUID "--expect-any-error" @-}+{-@ LIQUID "--short-names" @-}++module Errmsg where++import Data.Set++{- the "error message" is garbled thanks to all the ill-formatted+   "Eq [Contravariant]" stuff. Can we remove it, or at least NOT show+   it when running in --short-names mode. -}++{-@ foo :: (Eq a) => x:a -> xs:[a] -> {v:Bool | v <=> (Data.Set.member x (Data.Set.fromList xs))} @-}+foo          :: (Eq a) => a -> [a] -> Bool+foo x (y:ys) = x == y || elem x ys+foo _ []     = False++{-@ measure elements @-}+elements  []    = empty+elements (x:xs) = singleton x `union` elements xs++{- append :: xs:_ -> ys:_ -> {v:_ | elements v = union (elements xs) (elements ys) }@-}+append :: [a] -> [a] -> [a]+append = undefined +
+ tests/neg/Errorloc.hs view
@@ -0,0 +1,12 @@+{-@ LIQUID "--expect-any-error" @-}+module Errorloc () where++import Language.Haskell.Liquid.Prelude (liquidAssert)++{-@ zoo :: {v: Int | v > 0} -> {v: Int | v > 0} -> Int @-}+zoo   :: Int -> Int -> Int +zoo x y = liquidAssert (x /= 0) $ x + y +++foo = zoo (-1) (-2)+
tests/neg/Eval.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} module Eval (eval) where  import Language.Haskell.Liquid.Prelude (liquidError)
tests/neg/EvalQuery.hs view
@@ -1,8 +1,9 @@+{-@ LIQUID "--expect-any-error" @-}  {-@ LIQUID "--reflection"     @-} {-@ LIQUID "--ple"            @-} -module Query where+module EvalQuery where  data Atom  = VarX            | VarY
+ tests/neg/Ex0_unsafe.hs view
@@ -0,0 +1,29 @@+{-@ LIQUID "--expect-any-error" @-}+{-@ LIQUID "--pruneunsorted" @-}+module Ex0_unsafe () where++-- Testing "existential-types"++{-@ foldN :: forall a <p :: x0000:Int -> x1111:a -> Bool>. +                (i:Int -> a<p i> -> a<p (i+1)>)+              -> n:{v: Int | v >= 0}+              -> a <p 0>+              -> a <p n>+  @-}++foldN :: (Int -> a -> a) -> Int -> a -> a+foldN f n = go 0+  where go i x | i < n     = go (i+1) (f i x)+               | otherwise = x+++fooBar :: (Int -> a -> a) -> Int -> a -> a+fooBar f n = go 0+  where go i x | i < n     = go (i+1) (f i x)+               | otherwise = x+++{-@ count :: m: {v: Int | v > 0 } -> {v: Int | v = 44 } @-}+count :: Int -> Int+count m = foldN (\_ n -> n + 1) m 0+-- count m = fooBar (\_ n -> n + 1) m 0
+ tests/neg/Ex1_unsafe.hs view
@@ -0,0 +1,66 @@+{-@ LIQUID "--expect-any-error" @-}+{-@ LIQUID "--pruneunsorted" @-}++-- | A somewhat fancier example demonstrating the use of Abstract Predicates and exist-types++module Ex1_unsafe () where++-------------------------------------------------------------------------+-- | Data types ---------------------------------------------------------+-------------------------------------------------------------------------++data Vec a = Nil | Cons a (Vec a)++-- | We can encode the notion of length as an inductive measure @llen@++{-@ measure llen     :: forall a. Vec a -> Int+      llen (Nil)       = 0+      llen (Cons x xs) = 1 + llen(xs)+  @-}+++-- | As a warmup, lets check that a /real/ length function indeed computes+-- the length of the list.++{-@ sizeOf :: xs:Vec a -> {v: Int | v = llen(xs)} @-}+sizeOf             :: Vec a -> Int+sizeOf Nil         = 0+sizeOf (Cons _ xs) = 1 + sizeOf xs++-------------------------------------------------------------------------+-- | Higher-order fold --------------------------------------------------+-------------------------------------------------------------------------++-- | Time to roll up the sleeves. Here's a a higher-order @foldr@ function+-- for our `Vec` type. Note that the `op` argument takes an extra /ghost/+-- parameter that will let us properly describe the type of `efoldr`++{-@ efoldr :: forall a b <p :: x0:Vec a -> x1:b -> Bool>. +                (xs:Vec a -> x:a -> b <p xs> -> b <p (Ex1_unsafe.Cons x xs)>)+              -> b <p Ex1_unsafe.Nil>+              -> ys: Vec a+              -> b <p ys>+  @-}+efoldr :: (Vec a -> a -> b -> b) -> b -> Vec a -> b+efoldr op b Nil         = b+efoldr op b (Cons x xs) = op xs x (efoldr op b xs)++-------------------------------------------------------------------------+-- | Clients of `efold` -------------------------------------------------+-------------------------------------------------------------------------++-- | Finally, lets write a few /client/ functions that use `efoldr` to+-- operate on the `Vec`s.++-- | First: Computing the length using `efoldr`+{-@ size :: xs:Vec a -> {v: Int | v = llen(xs)} @-}+size :: Vec a -> Int+size = efoldr (\_ _ n -> n + 1) 0++{-@ suc :: x:Int -> {v: Int | v = x + 1} @-}+suc :: Int -> Int+suc x = x + 1++-- | Second: Appending two lists using `efoldr`+{-@ app  :: xs: Vec a -> ys: Vec a -> {v: Vec a | llen(v) = 1 + llen(xs) + llen(ys) } @-}+app xs ys = efoldr (\_ z zs -> Cons z zs) ys xs
tests/neg/ExactADT6.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} {-@ LIQUID "--no-adt"         @-} {-@ LIQUID "--exact-data-con" @-} 
tests/neg/ExactGADT6.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} {-@ LIQUID "--no-adt"         @-} {-@ LIQUID "--exact-data-con" @-} 
tests/neg/ExactGADT7.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} @@ -5,7 +6,7 @@ {-@ LIQUID "--no-adt"         @-} {-@ LIQUID "--exact-data-con" @-} -module Blank where+module ExactGADT7 where  data Some a where   SomeBool  :: Bool -> Some Bool
tests/neg/Fail.hs view
@@ -1,4 +1,5 @@-module Fail where +{-@ LIQUID "--expect-any-error" @-}+module Fail where  {-@ fail incr @-} {-@ incr :: x:Int -> {v:Int |  x < v } @-}
tests/neg/Fail1.hs view
@@ -1,4 +1,5 @@-module Fail where +{-@ LIQUID "--expect-any-error" @-}+module Fail1 where  -- This should fail because the failing incr is SAFE  {-@ fail incr @-}
+ tests/neg/FancyTerm.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE GADTs #-}+module FancyTerm where ++import Language.Haskell.Liquid.This++data Tree a where +    Leaf :: a -> Tree a +    Node :: (Int -> (Tree a)) -> Tree a ++{-@ data size (Tree a) tsize @-}++{-@ measure tsize :: Tree a -> Nat @-}+{-@ data Tree a where +      Leaf :: a -> {t:Tree a  | tsize t == 0 } +      Node :: f:(Int -> Tree a) +           -> Tree a   @-}++{-@ ignore node @-}+{-@ node :: (Int -> {tin:Tree a |  0 <= tsize tin}) -> {t:Tree a | 0 <= tsize t} @-}+node :: (Int -> Tree a) -> Tree a +node = Node ++{-@ mapTr :: (a -> a) -> t:Tree a -> {o:Tree a | true} / [tsize t] @-}+mapTr :: (a -> a) -> Tree a -> Tree a +mapTr f (Leaf x) = Leaf $ f x +mapTr f (Node n) = mapTr f (Node n) 
+ tests/neg/FilterAbs.hs view
@@ -0,0 +1,44 @@+{-@ LIQUID "--expect-any-error" @-}+{-@ LIQUID "--no-termination" @-}+{-@ LIQUID "--short-names"    @-}++++module FilterAbs where++import Prelude hiding (filter)++{-@ filter :: forall <p :: a -> Bool, q :: a -> Bool -> Bool>.+                  {y::a, flag :: {v:Bool<q y> | v} |- {v:a | v = y} <: a<p>}+                  (x:a -> Bool<q x>) -> [a] -> [a<p>]+  @-}++filter f (x:xs)+  | f x       = x : filter f xs+  | otherwise = filter f xs+filter _ []   = []++{-@ isPos :: x:Int -> {v:Bool | v <=> x > 0} @-}+isPos :: Int -> Bool+isPos n = n > 0+++{-@ isNeg :: x:Int -> {v:Bool | v <=> x < 0} @-}+isNeg :: Int -> Bool+isNeg n = n < 0+++-- Now the below *should* work with+-- p := \v   -> 0 < v+-- q := \x v -> v <=> 0 < 0+++{-@ positives :: [Int] -> [{v:Int | v > 0}] @-}+positives xs = filter isPos xs++{-@ negatives :: [Int] -> [{v:Int | v < 0}] @-}+negatives xs = filter isNeg xs++{-@ positivesBAD :: [Int] -> [{v:Int | v < 0}] @-}+positivesBAD xs = filter isPos xs+
+ tests/neg/FoldN.hs view
@@ -0,0 +1,17 @@+{-@ LIQUID "--expect-any-error" @-}+{-@ LIQUID "--pruneunsorted" @-}+module FoldN () where++-- Testing "existential-types"++{-@ foldN :: forall a <p :: x0:Int -> x1:a -> Bool>. +                (i:Int -> a<p i> -> a<p (i+1)>)+              -> n:{v: Int | v >= 0}+              -> a <p 0>+              -> a <p 42>+  @-}++foldN :: (Int -> a -> a) -> Int -> a -> a+foldN f n = go 0+  where go i x | i < n     = go (i+1) (f i x)+               | otherwise = x
+ tests/neg/FoldN1.hs view
@@ -0,0 +1,15 @@+{-@ LIQUID "--expect-any-error" @-}+{-@ LIQUID "--pruneunsorted" @-}+module FoldN1 where++{-@ foldN :: forall a <p :: x0:Int -> x1:a -> Bool>. +                (i:Int -> a<p i> -> a<p (i+1)>)+              -> n:{v: Int | v >= 0}+              -> a <p 0>+              -> {v : a | 0=1}+  @-}++foldN :: (Int -> a -> a) -> Int -> a -> a+foldN f n = go 0+  where go i x | i < n     = go (i+1) (f i x)+               | otherwise = x
tests/neg/FunSoundness.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} module FunSoundness where  
tests/neg/FunctionRef.hs view
@@ -1,5 +1,6 @@+{-@ LIQUID "--expect-any-error" @-} {-@ LIQUID "--higherorder"     @-}-module HigherOrder where+module FunctionRef where  {-@ measure ackF :: Int -> Int -> Int  @-} 
tests/neg/GeneralizedTermination.hs view
@@ -1,5 +1,6 @@+{-@ LIQUID "--expect-any-error" @-} {-@ LIQUID "--no-totality" @-}-module GenTerm () where+module GeneralizedTermination () where  foo :: Int -> Int -> Int {-@ foo :: n:Nat -> m:Nat -> Nat /[n+m] @-}
+ tests/neg/Grty0.hs view
@@ -0,0 +1,14 @@+{-@ LIQUID "--expect-any-error" @-}+module Grty0 () where++{-@ stupid :: Int -> Int @-}+stupid :: Int -> Int+stupid x = 0++{-@ myId :: x:a -> {v:a | v = x } @-}+myId x = x ++{-@ assert single :: a -> {v: [a] | len(v) = 0} @-}+single x = [x] ++
+ tests/neg/Grty1.hs view
@@ -0,0 +1,13 @@+{-@ LIQUID "--expect-any-error" @-}+{-@ LIQUID "--no-totality" @-}+module Grty1 () where++moo = insert 4 [1, 2, 0]+++{-@ insert      :: (Ord a) => x:a -> xs: [a]<{\fld v -> (v >= fld)}> -> {v: [a]<{\fld v -> (v >= fld)}> | len(v) = (1 + len(xs)) } @-}+insert y []                   = [y]+insert y (x : xs) | y <= x    = y : x : xs +                  | otherwise = x : insert y xs++
+ tests/neg/Grty2.hs view
@@ -0,0 +1,10 @@+{-@ LIQUID "--expect-any-error" @-}+module Grty2 () where++moo = insert 4 [1, 2, 3]++{-@ insert      :: (Ord a) => x:a -> xs: [a]<{\fld v -> (v >= fld)}> -> {v: [a]<{\fld v -> (v >= fld)}> | len(v) = (1 + len(xs)) } @-}+insert y []                            = [y]+insert y (x : xs) | y > {- <= -} x     = y : x : xs +                  | otherwise          = x : insert y xs+
+ tests/neg/Grty3.hs view
@@ -0,0 +1,11 @@+{-@ LIQUID "--expect-any-error" @-}+module Grty3 () where+++{-@ choo :: [a] -> {v: Int | v > 0 } @-}+choo = poo+++poo :: [a] -> Int +poo (x:xs) = poo xs+poo []     = 0
tests/neg/HasElem.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} module HasElem where  {-@ LIQUID "--no-termination" @-}
tests/neg/Hex00.hs view
@@ -1,4 +1,5 @@-module Hex where +{-@ LIQUID "--expect-any-error" @-}+module Hex00 where  {-@ foo :: {x:Int | x = 0x7} -> {y:Int | y = 0x6} -> {v:Int | v = 0xF} @-} foo :: Int -> Int -> Int 
tests/neg/HigherOrder.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} {-@ LIQUID "--higherorder" @-} module HigherOrder where 
tests/neg/HolesTop.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} module HolesTop where  import Language.Haskell.Liquid.Prelude
+ tests/neg/Inc2.hs view
@@ -0,0 +1,12 @@+{-@ LIQUID "--expect-any-error" @-}+-- ISSUE #671+--+-- | ISSUE would be nice to have error reported at `x-1` and NOT the `inc`+--   note that the right place gets shown if you comment out the `inc 0 = 1`++module Inc2 where++{-@ inc :: x:Int -> {v:Int | v > x} @-}+inc :: Int -> Int+inc 0 = 1+inc x = x - 1
tests/neg/IntAbsRef.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-}  module IntAbsRef where 
tests/neg/LazyWhere.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} module LazyWhere () where  import Language.Haskell.Liquid.Prelude
tests/neg/LazyWhere1.hs view
@@ -1,4 +1,5 @@-module LazyWhere () where+{-@ LIQUID "--expect-any-error" @-}+module LazyWhere1 () where  import Language.Haskell.Liquid.Prelude 
tests/neg/LetRecStack.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} {-@ LIQUID "--eliminate=all" @-} -- | This test case is to check that LH properly accounts for the case where GHC Core  --   contains stuff like:@@ -18,7 +19,7 @@  {-@ LIQUID "--no-termination" @-} -module Foo (prop) where+module LetRecStack (prop) where  --data Peano a = Z a | S (Peano a) | P (Peano a) data Peano = Z | S (Peano ) | P (Peano)
+ tests/neg/List00.hs view
@@ -0,0 +1,11 @@+{-@ LIQUID "--expect-any-error" @-}+module List00 () where++import Language.Haskell.Liquid.Prelude -- hiding (copyList)++copyList zs = zs++xs    = [1] :: [Int]+ys    = copyList xs+jhala = head ys+prop0 = crash (0 == 1) 
tests/neg/ListConcat.hs view
@@ -1,6 +1,7 @@+{-@ LIQUID "--expect-any-error" @-} {-@ LIQUID "--pruneunsorted" @-} -module Foo () where+module ListConcat () where import Data.Set (Set(..))  import Prelude hiding (concat) 
tests/neg/ListElem.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} module ListElem (listElem) where  import Data.Set
tests/neg/ListKeys.hs view
@@ -1,6 +1,7 @@+{-@ LIQUID "--expect-any-error" @-} {-@ LIQUID "--pruneunsorted" @-} -module Foo () where+module ListKeys () where import Data.Set (Set(..))   {-@ measure listKeys :: [(k, v)] -> (Set k)
tests/neg/ListMSort.hs view
@@ -1,4 +1,5 @@-module ListSort () where+{-@ LIQUID "--expect-any-error" @-}+module ListMSort () where  import Language.Haskell.Liquid.Prelude @@ -13,7 +14,7 @@ merge (x:xs) (y:ys)   | x <= y   = x:(merge xs (y:ys))-  | otherwise +  | otherwise   = y:(merge (x:xs) ys)  {-@ mergesort :: (Ord a) => xs:[a] -> [a]<{\fld v -> (v < fld)}>  @-}@@ -23,10 +24,10 @@ mergesort xs = merge (mergesort xs1) (mergesort xs2) where (xs1, xs2) = split xs  chk [] = liquidAssertB True-chk (x1:xs) = case xs of +chk (x1:xs) = case xs of                []     -> liquidAssertB True                x2:xs2 -> liquidAssertB (x1 <= x2) && chk xs-																	+ rlist = map choose [1 .. 10]  bar = mergesort rlist
tests/neg/ListRange.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} module ListRange () where  import Language.Haskell.Liquid.Prelude
+ tests/neg/Listne.hs view
@@ -0,0 +1,9 @@+{-@ LIQUID "--expect-any-error" @-}+module Listne where++{-@ type ListNE a = {v:[a] | 0 < len v} @-}++{-@ junkProp :: ListNE Int @-}+junkProp :: [Int]+junkProp = []+
+ tests/neg/Lit.hs view
@@ -0,0 +1,5 @@+{-@ LIQUID "--expect-any-error" @-}+module Lit where++{-@ test :: {v:Int | v == 30} @-}+test = length "cat"
tests/neg/LocalSpec.hs view
@@ -1,4 +1,5 @@-module Foo () where+{-@ LIQUID "--expect-any-error" @-}+module LocalSpec () where  import Language.Haskell.Liquid.Prelude (choose) 
+ tests/neg/Mapreduce.hs view
@@ -0,0 +1,56 @@+{-@ LIQUID "--expect-any-error" @-}++-- RJ: Issues with TypeClasses? Ord?++module Mapreduce () where++import Language.Haskell.Liquid.Prelude+import qualified Data.Map as M+import Data.List (foldl')++----------------------------------------------------------------+--- Step 1: Map each element into key-value list (concatMap) ---+----------------------------------------------------------------++expand          :: (a -> [(k,v)]) -> [a] -> [(k, v)]+expand f []     = []+expand f (x:xs) = (f x) ++ (expand f xs)++----------------------------------------------------------------+--- Step 2: Group By Key ---------------------------------------+----------------------------------------------------------------++group :: (Ord k) => [(k, v)] -> M.Map k [v]+group = foldl' addKV  M.empty+  +addKV m (k, v) = M.insert k vs' m+  where vs' = v : (M.findWithDefault [] k m)++----------------------------------------------------------------+--- Step 3: Group By Key ---------------------------------------+----------------------------------------------------------------++collapse f = M.foldrWithKey reduceKV []+  where reduceKV k (v:vs) acc = if liquidAssertB False then (k, foldl' f v vs) : acc else acc+        reduceKV k []     _   = crash False --error $ show (liquidAssertB False)++----------------------------------------------------------------+--- Putting it All Together ------------------------------------+----------------------------------------------------------------++mapReduce fmap fred = collapse fred . group . expand fmap ++----------------------------------------------------------------+--- "Word Count" -----------------------------------------------+----------------------------------------------------------------++wordCount  = mapReduce fm plus +  where fm = \doc -> [ (w,1) | w <- words doc]++main = putStrLn $ show $ wordCount docs+  where docs = [ "this is the end"+               , "go to the end"+               , "the end is the beginning"]+ ++
+ tests/neg/Mapreduce_tiny.hs view
@@ -0,0 +1,31 @@+{-@ LIQUID "--expect-any-error" @-}++++module Mapreduce_tiny () where++import Language.Haskell.Liquid.Prelude++++prop1       = map choo [[True]] -- replace [[1]] with [[]] for UNSAT+choo (x:xs) = liquidAssertB False+-- choo []     = liquidAssertB False++-- import qualified Data.Map as M+-- import Data.List (foldl')++--keyvals :: [(Int, Int)]+--keyvals = [(1, 1), (2, 2), (3, 3)]+--+--group :: (Ord k) => [(k, v)] -> M.Map k [v]+--group = foldl' addKV  M.empty+--+--addKV m (k, v) = let boo = liquidAssertB False in M.insert k vs' m+--  where vs' = v : (M.findWithDefault [] k m)+--+--checkNN m = M.foldrWithKey reduceKV False m+--+--reduceKV _ _ acc = liquidAssertB False +--+--prop = checkNN (group keyvals)
+ tests/neg/Maps.hs view
@@ -0,0 +1,35 @@+{-@ LIQUID "--expect-any-error" @-}+module Maps where++{-@ prop1 :: x:_ -> y:{_ | y == x} -> TT @-}+prop1 x y = (z == 10)+  where+    m1    = put x 10 emp  +    m2    = put y 20 m1+    z     = get x m2++{-@ prop2 :: x:_ -> y:{_ | y == x} -> TT @-}+prop2 x y = (z == 10)+  where+    m1    = put x 10 emp +    m2    = put y 20 m1+    z     = get x m2++-----------------------------------------------------------------------++data Map k v = M++{-@ embed Map as Map_t @-}+{-@ measure Map_select :: Map k v -> k -> v @-}+{-@ measure Map_store  :: Map k v -> k -> v -> Map k v @-}++emp :: Map Int Int+emp = undefined   +     +{-@ get :: k:k -> m:Map k v -> {v:v | v = Map_select m k} @-}+get :: k -> Map k v -> v+get = undefined ++{-@ put :: k:k -> v:v -> m:Map k v -> {n:Map k v | n = Map_store m k v} @-}+put :: k -> v -> Map k v -> Map k v+put = undefined 
+ tests/neg/Maybe.hs view
@@ -0,0 +1,8 @@+{-@ LIQUID "--expect-any-error" @-}+module Maybe where++import Data.Maybe+++foo :: Maybe a -> a+foo x = fromJust x
tests/neg/MaybeMonad.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} -- TODO-REBARE: STRATA module MaybeMonad where 
+ tests/neg/Meas0.hs view
@@ -0,0 +1,14 @@+{-@ LIQUID "--expect-any-error" @-}+module Meas0 () where++import Control.Applicative+import Language.Haskell.Liquid.Prelude++goo x = []++poo (x:_) = True+poo ([])  = liquidAssertB False++xs = goo (choose 0)++prop1 = liquidAssertB (poo xs)
+ tests/neg/Meas2.hs view
@@ -0,0 +1,20 @@+{-@ LIQUID "--expect-any-error" @-}+module Meas2 () where++import Language.Haskell.Liquid.Prelude++goo :: a -> Int+goo _ = 1++bob :: [a] -> Int+--bob [] = 0+--bob (n:ns) = goo ns +bob ms = case ms of +           []     -> 0+           (n:ns) -> goo ns ++zs :: [Int]+zs = [1..100]++prop2 = liquidAssertB (n2 `eq` 0) +  where n2 = bob zs
+ tests/neg/Meas3.hs view
@@ -0,0 +1,25 @@+{-@ LIQUID "--expect-any-error" @-}+module Meas3 () where+++import Language.Haskell.Liquid.Prelude++--mylen []       = 0+--mylen (_:xs)   = 1 `plus` mylen xs++mylen xs = case xs of +             []     -> 0+             (_:ys) -> 1 `plus` mylen ys+++zs :: [Int]+zs = [1..100]++goo :: [dogbert] -> Int+goo _ = 1++bloo :: [Int] -> Int+bloo _ = 0++prop1 = liquidAssertB (n1 `eq` 0) +  where n1 = mylen zs
+ tests/neg/Meas5.hs view
@@ -0,0 +1,42 @@+{-@ LIQUID "--expect-any-error" @-}+module Meas5 () where++import Language.Haskell.Liquid.Prelude++{-@ include <len.hquals> @-}++mylen          :: [a] -> Int+mylen []       = 0+mylen (_:xs)   = 1 + mylen xs+++mymap f []     = []+mymap f (x:xs) = (f x) : (mymap f xs)++myreverse = go []+  where go acc (x:xs) = go (x:acc) xs+        go acc []     = acc+    +myapp [] ys     = ys+myapp (x:xs) ys = x:(myapp xs ys)++zs :: [Int]+zs = [1..100]++zs' :: [Int]+zs' = [500..1000]++prop2 = liquidAssertB (n1 == n2) +  where n1 = mylen zs+        n2 = mylen $ mymap (+ 1) zs ++prop3 = liquidAssertB (n1 == n2) +  where n1 = mylen zs+        n2 = mylen $ myreverse zs ++prop4 = liquidAssertB ((n1 + n2) == n3) +  where n1 = mylen zs+        n2 = mylen zs'+        n3 = mylen $ myapp zs zs' ++prop5 = zipWith (+) zs (0: myreverse zs)
+ tests/neg/Meas7.hs view
@@ -0,0 +1,18 @@+{-@ LIQUID "--expect-any-error" @-}++module Meas7 () where++-- some tests for the 'expandDefaultCase' trick to case-split +-- on the "missing" constructors.++mylen          :: [a] -> Int+mylen []       = 0+mylen (_:xs)   = 1 + mylen xs+++{-@ foo :: [a] -> {v: Int | v = 0} @-}+foo :: [a] -> Int+foo zs = case zs of+           [] -> 0+           _  -> mylen zs+
+ tests/neg/Meas9.hs view
@@ -0,0 +1,14 @@+{-@ LIQUID "--expect-any-error" @-}+module Meas9 () where++import Data.Set (Set(..))++{-@ myid :: xs:[a] -> {v:[a]| listElts(v) = listElts(xs)} @-}+myid []     = []+myid (x:xs) = x : myid xs++{-@ myapp :: xs:[a] -> ys:[a] -> {v:[a] | listElts(v) = Set_cup (listElts xs) (listElts xs) } @-}+myapp :: [a] -> [a] -> [a]+myapp []     ys = ys+myapp (x:xs) ys = x : myapp xs ys+
tests/neg/MeasureContains.hs view
@@ -1,4 +1,5 @@-module Fixme where+{-@ LIQUID "--expect-any-error" @-}+module MeasureContains where  import Language.Haskell.Liquid.Prelude 
tests/neg/MeasureDups.hs view
@@ -1,12 +1,13 @@-module Measures where+{-@ LIQUID "--expect-any-error" @-}+module MeasureDups where -import Data.Set +import Data.Set  {-@ LIQUID "--no-termination" @-} {-@ measure elements @-} {-@ measure dups @-} -data F a = F a |  C a (F a) | E +data F a = F a |  C a (F a) | E  dups :: Ord a => F a -> Set a dups E        = empty@@ -30,5 +31,5 @@  {-@ prop :: { v: Bool | v } @-} prop = dups s == empty-  where -  	s = C 1 (C 3 (F 1)) :: F Int+  where+    s = C 1 (C 3 (F 1)) :: F Int
tests/neg/MergeSort.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} ------------------------------------------------------------------------------ -- | An implementation of Merge Sort, where LH verifies: --   1. Termination (Totality) 
+ tests/neg/Monad3.hs view
@@ -0,0 +1,16 @@+{-@ LIQUID "--expect-any-error" @-}+module Monad3 () where++import Language.Haskell.Liquid.Prelude++-- gpp :: Monad m => m Int -> m Int+gpp z = do x <- z+           return $ liquidAssert (x >= 0) (x + 1)+++-- decrlist n = n : decrlist (n-1)++xs, ys, zs :: [Int]+xs = [0, -1]+ys = gpp xs+zs = gpp ys
+ tests/neg/Monad4.hs view
@@ -0,0 +1,16 @@+{-@ LIQUID "--expect-any-error" @-}+module Monad4 () where++import Language.Haskell.Liquid.Prelude++-- gpp :: Monad m => m Int -> m Int+gpp z = do x <- z+           return $ liquidAssert (x > 0) (x - 10)+++incrlist n = n : incrlist (n+1)++xs, ys, zs :: Maybe Int+xs = Just 9+ys = gpp xs+zs = gpp ys
+ tests/neg/Monad5.hs view
@@ -0,0 +1,19 @@+{-@ LIQUID "--expect-any-error" @-}+module Monad5 () where++import Language.Haskell.Liquid.Prelude++-- gpp :: Monad m => m Int -> m Int+gpp z = do x <- z+           return $ liquidAssert (x > 0) (x + 1)++myabs :: Int -> Int+myabs x | x >= 0     = x+        | otherwise  = 0-x++posM :: Monad m => m Int+posM = return $ myabs $ choose 0+++yM :: Monad m => m Int+yM = gpp posM
+ tests/neg/Monad6.hs view
@@ -0,0 +1,9 @@+{-@ LIQUID "--expect-any-error" @-}+module Monad6 where++import Language.Haskell.Liquid.Prelude ++{-@ gpp :: Monad m => m {v:Int|v>=0} -> m {v:Int|v>0} @-}+gpp :: Monad m => m Int -> m Int+gpp z = do x <- z+           return $ liquidAssert (x >= 0) (x)
+ tests/neg/Monad7.hs view
@@ -0,0 +1,23 @@+{-@ LIQUID "--expect-any-error" @-}+module Monad7 () where++import Language.Haskell.Liquid.Prelude ++{-@ type OList a = [a]<{\fld v -> (v >= fld)}> @-}+{-@ gpp :: (Ord a, Monad m) => [a] -> m (OList a) @-}+gpp :: (Ord a, Monad m) => [a] -> m [a]+gpp ls = return $ reverse $ insertSort ls++{-@ insertSort :: (Ord a) => xs:[a] -> OList a @-}+insertSort            :: (Ord a) => [a] -> [a]+insertSort []         = []+insertSort (x:xs)     = insert x (insertSort xs) ++insert y []                   = [y]+insert y (x : xs) | y <= x    = y : x : xs +                  | otherwise = x : insert y xs+++++
+ tests/neg/Mr00.hs view
@@ -0,0 +1,17 @@+{-@ LIQUID "--expect-any-error" @-}+module Mr00 () where++import Language.Haskell.Liquid.Prelude +import Data.Map hiding (filter, map, foldl)++baz (v:vs) _ = crash False +baz []     _ = crash False++mymap = Data.Map.fromList [('a', [1])]++-- Why is this safe+coll = Data.Map.foldr baz 0 +prop_safe = coll mymap ++-- Oddly, this is unsafe+-- prop_unsafe = Data.Map.foldr baz 0 mymap
tests/neg/MultiParamTypeClasses.hs view
@@ -1,5 +1,8 @@+{-@ LIQUID "--expect-any-error" @-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}++module MultiParamTypeClasses where  class Add a b where     rAdd :: [a] -> [b] -> [a]
+ tests/neg/Multi_pred_app_00.hs view
@@ -0,0 +1,6 @@+{-@ LIQUID "--expect-any-error" @-}+module Multi_pred_app_00 () where++{-@ bar :: forall < p :: Int -> Bool, q :: Int -> Bool>. Int<p> -> Int<p, q> @-}+bar :: Int -> Int+bar x = x
tests/neg/MultipleInvariants.hs view
@@ -1,4 +1,5 @@-module Blank where+{-@ LIQUID "--expect-any-error" @-}+module MultipleInvariants where  import Data.Word import GHC.Ptr
tests/neg/NameResolution.hs view
@@ -1,4 +1,5 @@-module Fixme where+{-@ LIQUID "--expect-any-error" @-}+module NameResolution where  import Prelude hiding ((==), (++)) import Language.Haskell.Liquid.Equational 
+ tests/neg/NestedRecursion.hs view
@@ -0,0 +1,7 @@+{-@ LIQUID "--expect-any-error" @-}+module NestedRecursion (radicals) where++radicals :: Int -> [a]+radicals n = [ foo (radicals n) i | i <- [1..]]++foo = undefined
tests/neg/NoExhaustiveGuardsError.hs view
@@ -1,4 +1,5 @@-module Foo where+{-@ LIQUID "--expect-any-error" @-}+module NoExhaustiveGuardsError where  bar :: Int -> Int -> Int bar x y | x >  y = 1
tests/neg/NoMethodBindingError.hs view
@@ -1,4 +1,6 @@-module Foo where+{-# OPTIONS_GHC -Wno-missing-methods #-}+{-@ LIQUID "--expect-any-error" @-}+module NoMethodBindingError where  class Foo a where   foo :: a -> a
+ tests/neg/Null.hs view
@@ -0,0 +1,5 @@+{-@ LIQUID "--expect-any-error" @-}+module Null where++foo :: [Int] -> Int+foo xs = if null xs then head xs else 0
+ tests/neg/Pair.hs view
@@ -0,0 +1,26 @@+{-@ LIQUID "--expect-any-error" @-}+module Pair () where++import Language.Haskell.Liquid.Prelude++{-@ data Pair a b <p :: a -> b -> Bool> = P { pX :: a, pY :: b<p pX> } @-} +data Pair a b = P a b++incr x = let p = P x ((x+1)) in p+chk (P x (y)) = liquidAssertB (x == y)+prop  = chk $ incr n+  where n = choose 0++incr2 x =+  let p1 = (P True (x+1)) in+  let p2 = P x p1 in+   p2+chk2 (P x w) =+   case w of (P z y) -> liquidAssertB (x == y)+prop2  = chk2 $ incr2 n+  where n = choose 0++incr3 x = P x (P True (P 0 (x+1)))+chk3 (P x (P _(P _ y))) = liquidAssertB (x == y)+prop3  = chk3 $ incr3 n+  where n = choose 0
+ tests/neg/Pair0.hs view
@@ -0,0 +1,22 @@+{-@ LIQUID "--expect-any-error" @-}+module Pair0 () where++import Language.Haskell.Liquid.Prelude ++data Pair a b = P a b+++incr x = (x, x-1)+chk (x, y) = liquidAssertB (x <y) +prop  = chk $ incr n+  where n = choose 0++incr2 x = (x, True, x-1)+chk2 (x, _, y) = liquidAssertB (x <y) +prop2  = chk2 $ incr2 n+  where n = choose 0++incr3 x = (x, (True, (0, x-1)))+chk3 (x, (_, (_, y))) = liquidAssertB (x <y) +prop3  = chk3 $ incr3 n+  where n = choose 0
tests/neg/PairMeasure.hs view
@@ -1,4 +1,5 @@-module Foo () where+{-@ LIQUID "--expect-any-error" @-}+module PairMeasure () where  {-@ LIQUID "--bscope" @-} 
+ tests/neg/Pargs.hs view
@@ -0,0 +1,10 @@+{-@ LIQUID "--expect-any-error" @-}+module Pargs () where++{-@ foo :: forall a <p :: x0:Int -> x1:a -> Bool>. +             (i:Int -> a<p i>) -> {v:Int| v=0}+              -> a <p 1>+  @-}++foo ::  (Int -> a) -> Int ->  a+foo f i = f i
+ tests/neg/Pargs1.hs view
@@ -0,0 +1,12 @@+{-@ LIQUID "--expect-any-error" @-}+{-@ LIQUID "--pruneunsorted" @-}+module Pargs1 () where++{-@ foo :: forall a <p :: x0:Int -> x1:a -> Bool>. +             (i:Int  -> j : Int-> a<p (i)>) ->+               ii:Int -> jj:Int+              -> a <p (ii+jj)>+  @-}++foo ::  (Int -> Int -> a) -> Int -> Int ->  a+foo f i j = f i j
+ tests/neg/Partial.hs view
@@ -0,0 +1,14 @@+{-@ LIQUID "--expect-any-error" @-}+module Partial () where++{-@ posPlus :: x:{v: Int | v >= 0} -> {v: Int | v >= x} @-}+posPlus :: Int -> Int+posPlus x = if (x > 0) +              then 2 + (posPlus (x - 1))+              else 0++goo = posPlus (-3)++{-@ poo :: x:Int -> {v: Int | v >= x } @-}+poo x = if x > 0 then posPlus x else x+
+ tests/neg/Poly0.hs view
@@ -0,0 +1,23 @@+{-@ LIQUID "--expect-any-error" @-}+module Poly0 () where++import Language.Haskell.Liquid.Prelude++myabs x    = if x `gt` 0 then x else 0 `minus` x++myid arg     = arg++----------------------------------------------------------++x = choose 0++prop_id1 = let x'  = myabs x in +           let x'' = myid x' in +           liquidAssertB (x'' `geq` 0)++prop_id2 = liquidAssertB (x'' `geq` 0)+  where x'  = myabs x +        x'' = myid x' ++prop_id3 = liquidAssertB (x' `geq` 20)+  where x' = myid $ myabs x 
+ tests/neg/Poly1.hs view
@@ -0,0 +1,20 @@+{-@ LIQUID "--expect-any-error" @-}+module Poly1 () where++import Language.Haskell.Liquid.Prelude++myabs x    = if x `gt` 0 then x else 0 `minus` x++myid2 a b  = a  ++----------------------------------------------------------++x =  choose 0++prop_id4 = let x'  = myabs x in +           let x'' = myid2 x' [] in +           liquidAssertB (x'' `geq` 10)++prop_id5 = liquidAssertB (x'' `geq` 0)+  where x'  = myabs x +        x'' = myid2 x' [] 
+ tests/neg/Poly2.hs view
@@ -0,0 +1,17 @@+{-@ LIQUID "--expect-any-error" @-}+module Poly2 () where++import Language.Haskell.Liquid.Prelude++myabs x    = if x `gt` 0 then x else 0 `minus` x++----------------------------------------------------------++myid3 x y  = y++x = choose 0++prop_id6 = liquidAssertB (x' `geq` 10)+  where x' = myid3 [] $ myabs x ++
+ tests/neg/Poly2_degenerate.hs view
@@ -0,0 +1,15 @@+{-@ LIQUID "--expect-any-error" @-}+module Poly2_degenerate () where++import Language.Haskell.Liquid.Prelude++myabs x    = if x `gt` 0 then x else 0 `minus` x++----------------------------------------------------------++myid3 x y  = y++prop_id6 = liquidAssertB (x' `geq` 10)+  where x' = myid3 [] $ myabs n +        n  = choose 0+
+ tests/neg/Polypred.hs view
@@ -0,0 +1,14 @@+{-@ LIQUID "--expect-any-error" @-}+module Polypred () where++import Language.Haskell.Liquid.Prelude++prop :: Int -> Bool+prop x = liquidAssertB (x == 0)++foo :: a -> Int+foo longVarName = choose 20 ++-- propUNSAFE = prop (foo "ker")+propSAFE = prop (foo id)+
+ tests/neg/Poslist.hs view
@@ -0,0 +1,17 @@+{-@ LIQUID "--expect-any-error" @-}+module Poslist () where++import Language.Haskell.Liquid.Prelude++myabs x    = if x `gt` 0 then x else 0 `minus` x++absList xs = map myabs xs++prop1 = map (liquidAssertB . (`geq` 0)) $ absList $ map choose [1..]+++numAbs x   = if x > 0 then x else (x)++numAbsList = map numAbs ++prop2      = map (liquidAssertB . (>= 0)) $ numAbsList $ map choose [1..]
+ tests/neg/Pred.hs view
@@ -0,0 +1,8 @@+{-@ LIQUID "--expect-any-error" @-}+module Pred () where++{-@ predicate Gt X Y = (X < Y) @-}++{-@ incr :: x:Int -> {v:Int | Gt v x} @-}+incr :: Int -> Int+incr x = x + 1
tests/neg/Propability.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} {-@ LIQUID "--prune-unsorted" @-}  module Propability where
tests/neg/Propability0.hs view
@@ -1,7 +1,8 @@+{-@ LIQUID "--expect-any-error" @-}  {-@ LIQUID "--prune-unsorted" @-} -module Propability where+module Propability0 where  {-@ type Propability = {v:Double | ((0.0 <= v) && (v <= 1.0)) } @-} 
+ tests/neg/Prune0.hs view
@@ -0,0 +1,53 @@+{-@ LIQUID "--expect-any-error" @-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Prune0 where++import Prelude hiding (read, length)+import Control.Monad.Primitive+import Data.Vector.Generic.Mutable++----------------------------------------------------------------------------+-- LIQUID Specifications ---------------------------------------------------+----------------------------------------------------------------------------++-- | Vector Size Measure++{-@ measure vsize :: forall a. a -> Int @-}++-- | Vector Type Aliases+{-@ type      OkIdx X     = {v:Nat | v < vsize X} @-}++-- | Assumed Types for Vector++{-@ assume unsafeRead  +      :: (PrimMonad m, MVector v a) +      => xorp:(v (PrimState m) a) +      -> (OkIdx xorp) +      -> m a       +  @-}++yuck xanadu i = if (i > 0) then unsafeRead xanadu i else undefined++++++++++++++++++++++
tests/neg/QQTySig.hs view
@@ -1,6 +1,7 @@+{-@ LIQUID "--expect-any-error" @-} {-# LANGUAGE QuasiQuotes #-} -module Nats where+module QQTySig where  import LiquidHaskell 
tests/neg/QQTySyn1.hs view
@@ -1,6 +1,7 @@+{-@ LIQUID "--expect-any-error" @-} {-# LANGUAGE QuasiQuotes #-} -module Nats where+module QQTySyn1 where  import LiquidHaskell 
tests/neg/QQTySyn2.hs view
@@ -1,6 +1,7 @@+{-@ LIQUID "--expect-any-error" @-} {-# LANGUAGE QuasiQuotes #-} -module Nats where+module QQTySyn2 where  import LiquidHaskell 
tests/neg/RG.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} module RG where  import Data.IORef as R
+ tests/neg/Range.hs view
@@ -0,0 +1,20 @@+{-@ LIQUID "--expect-any-error" @-}+module Range () where++import Language.Haskell.Liquid.Prelude++range :: Int -> Int -> [Int]+range i j  +  | i `lt` j  = i : (range (i `plus` 1) j)+  | otherwise = []  ++sumTo = foldl plus 0 . range 0++n = choose 0 +m = choose 1++prop_rng1 = map (liquidAssertB . (10 `leq`)) $ range 0 n+prop_rng2 = map (liquidAssertB . (n `leq`)) $ range n 100+prop_rng3 = map (liquidAssertB . (n `leq`)) $ range n m+prop_rng4 = map (liquidAssertB . (`leq` m)) $ range n m +prop_rng5 = liquidAssertB ((sumTo n) `geq` 10)
tests/neg/ReWrite.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} module ReWrite where  {-@ LIQUID "--reflection" @-}
tests/neg/ReWrite2.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} module ReWrite2 where  {-@ LIQUID "--reflection" @-}
tests/neg/ReWrite3.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} module ReWrite3 where  {-@ LIQUID "--reflection" @-}
tests/neg/ReWrite4.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wno-overlapping-patterns #-}+{-@ LIQUID "--expect-any-error" @-} module ReWrite4 where  {-@ LIQUID "--reflection" @-}
tests/neg/Rebind.hs view
@@ -1,6 +1,7 @@+{-@ LIQUID "--expect-any-error" @-} {-# LANGUAGE RebindableSyntax #-} -module Rebind () where +module Rebind () where  import Prelude hiding ((>>), (>>=), return) 
tests/neg/RecQSort.hs view
@@ -1,4 +1,5 @@-module GhcSort () where+{-@ LIQUID "--expect-any-error" @-}+module RecQSort () where  {-@ type OList a =  [a]<{\fld v -> (v >= fld)}>  @-} 
tests/neg/RecSelector.hs view
@@ -1,4 +1,5 @@-module Invariant where+{-@ LIQUID "--expect-any-error" @-}+module RecSelector where  data F a = F {fxx :: a, fy :: a, fzz :: a} | G {fxx :: a} 
+ tests/neg/Record0.hs view
@@ -0,0 +1,18 @@+{-@ LIQUID "--expect-any-error" @-}+module Record0 (clone, mk) where++{-@ data LL a = BXYZ { size  :: {v: Int | v > 0 }+                     , elems :: {v: [a] | (len v) = size }+                     }+  @-}++data LL a = BXYZ { size  :: Int+                 , elems :: [a]+                 }++{-@ mk :: a -> Int -> LL a @-}+mk x n = BXYZ n (clone x 0)++{-@ clone :: x:a -> n:Int -> {v:[a]| (len v) = n} @-}+clone :: a -> Int -> [a]+clone = undefined 
+ tests/neg/Revshape.hs view
@@ -0,0 +1,35 @@+{-@ LIQUID "--expect-any-error" @-}+{-@ LIQUID "--no-termination" @-}++module Revshape () where+ +-- https://gist.github.com/cartazio/6891549++data Shape = Nil | Cons !Int !Shape ++{-@ measure rank @-}+rank :: Shape -> Int+rank (Nil)       = 0+rank (Cons d ds) = 1 + (rank ds)++{-@ type DIM1 = {v:Shape | (rank v) = 1} @-}+{-@ type DIM2 = {v:Shape | (rank v) = 2} @-}++{-@ oneDim :: DIM1 @-}+oneDim = 12 `Cons` Nil++{-@ twoDim :: DIM2 @-}+twoDim = 2 `Cons` (17 `Cons` Nil)++-- clearly an error, is flagged by LiquidHaskell+{-@ twoDim' :: DIM2 @-}+twoDim' = 56 `Cons` (2 `Cons` (17 `Cons` Nil))++{-@ reverseShape :: sh:Shape -> {v:Shape | (rank v) = (rank sh)} @-}+reverseShape shs = go shs Nil +    where+        {-@ go ::  a:Shape -> b:Shape -> {v:Shape | (rank v) = (rank a) + (rank b)} @-}+        go Nil res            = res   +        go (Cons ix more) res = go more  (Cons ix res)+ +  
+ tests/neg/Risers.hs view
@@ -0,0 +1,13 @@+{-@ LIQUID "--expect-any-error" @-}+module Risers where++{-@ predicate NonNull X = ((len X) > 0) @-}++{- risers :: (Ord a) => zs:[a] -> {v: [[a]] | ((NonNull zs) => (NonNull v)) } @-} +risers []        +  = []+risers [x]       +  = [[x]]+risers (x:y:etc) +  = if x <= y then (x:s):ss else [x]:(s:ss)+    where (s:ss) = risers [] -- insert partiality (y:etc)
tests/neg/SafePartialFunctions.hs view
@@ -1,3 +1,4 @@+{-@ LIQUID "--expect-any-error" @-} module SafePartialFunctions (gotail, gohead) where  import Prelude hiding (fromJust, tail, head)
tests/neg/Solver.hs view
@@ -1,10 +1,11 @@+{-@ LIQUID "--expect-any-error" @-} {-@ LIQUID "--pruneunsorted"  @-} {-@ LIQUID "--no-termination" @-} {-@ LIQUID "--short-names"    @-} {-@ LIQUID "--reflection"     @-} {-@ LIQUID "--ple"            @-} -module MultiParams where+module Solver where   import Data.Tuple@@ -47,19 +48,19 @@ asgns :: Formula -> [Asgn] -- generates all possible T/F vectors asgns = go . vars   where-  	go [] = []-  	go (x:xs) = let ass = go xs in (inject (x, VTrue) ass) ++ (inject (x, VFalse) ass)+    go [] = []+    go (x:xs) = let ass = go xs in (inject (x, VTrue) ass) ++ (inject (x, VFalse) ass) -  	inject x xs = map (\y -> x:y) xs+    inject x xs = map (\y -> x:y) xs  vars :: Formula -> [Var] vars = nub . go   where-  	go [] = []-  	go (ls:xs) = map go' ls ++ go xs+    go [] = []+    go (ls:xs) = map go' ls ++ go xs -  	go' (Pos x) = x-  	go' (Neg x) = x+    go' (Pos x) = x+    go' (Neg x) = x  -- | Satisfaction 
+ tests/neg/Stacks.hs view
@@ -0,0 +1,36 @@+{-@ LIQUID "--expect-any-error" @-}+module Stacks () where+++{-@ type DList a = [a]<{\fld v -> (v != fld)}> @-}++{-@ data Stack a = St { focus  :: a    +                      , up     :: DList {v: a | v != focus}+                      , down   :: DList {v: a | v != focus}+                      } +  @-}++data Stack a = St { focus  :: !a    +                  , up     :: ![a] +                  , down   :: ![a]+                  } deriving (Show, Eq)++-- All of the below violate the invariant, get liquid to say so!++{-@ bad0 :: a -> Stack a @-}+bad0   :: a -> Stack a +bad0 x = St x [x] []+++{-@ bad1 :: a -> Stack a @-}+bad1   :: a -> Stack a +bad1 x = St x []  [x]++{-@ bad2 :: Int -> Stack Int @-}+bad2 :: Int -> Stack Int+bad2 x = St 0 [x] [x]++{-@ bad3 :: Int -> Stack Int @-}+bad3 :: Int -> Stack Int+bad3 x = St x [1] [1] +
+ tests/neg/State0.hs view
@@ -0,0 +1,13 @@+{-@ LIQUID "--expect-any-error" @-}+module State0 () where++type State = Int+data ST a = S (State -> (a, State))+{-@ data ST a <p1 :: State -> Bool,+               p2 :: State -> Bool> +     = S (x::(f:State<p1> -> (a, State<p2>)))+  @-}++{-@ fresh :: ST <{\v -> v>=0}, {\v -> v>=0}> Int @-}+fresh :: ST Int+fresh = S $ \n -> (n, n-1)
+ tests/neg/State00.hs view
@@ -0,0 +1,11 @@+{-@ LIQUID "--expect-any-error" @-}+module State00 () where++type State = Int+data ST a b = S (a -> (a, b)) | F a++{-@ fresh :: ST Int {v:Int|v>=0} @-}+fresh :: ST Int Int+fresh = S $ \n -> (n, n+1)++
tests/neg/StateConstraints.hs view
@@ -1,4 +1,5 @@-module Compose where+{-@ LIQUID "--expect-any-error" @-}+module StateConstraints where  data ST s = ST {runState :: s -> s} 
tests/neg/StateConstraints0.hs view
@@ -1,4 +1,5 @@-module Compose where+{-@ LIQUID "--expect-any-error" @-}+module StateConstraints0 where  import Prelude hiding (Monad(..)) 
tests/neg/StateConstraints00.hs view
@@ -1,4 +1,5 @@-module Compose where+{-@ LIQUID "--expect-any-error" @-}+module StateConstraints00 where  import Prelude hiding (Monad, return ) 
tests/neg/StrictPair0.hs view
@@ -1,6 +1,7 @@+{-@ LIQUID "--expect-any-error" @-} -- Compare with tests/neg/StrictPair1.hs -module SPair (poo) where+module StrictPair0 (poo) where  {-@ measure tsnd @-} tsnd :: (a, b) -> b 
tests/neg/StrictPair1.hs view
file too large to diff
+ tests/neg/String00.hs view
file too large to diff
tests/neg/Strings.hs view
file too large to diff
+ tests/neg/SumPoly.hs view
file too large to diff
+ tests/neg/Sumk.hs view
file too large to diff
tests/neg/T1095C.hs view
file too large to diff
tests/neg/T1126.hs view
file too large to diff
− tests/neg/T1198.3.hs 
file too large to diff
+ tests/neg/T1198_3.hs view
file too large to diff
tests/neg/T1267.hs view
file too large to diff
tests/neg/T1286.hs view
file too large to diff
tests/neg/T1288.hs view
file too large to diff
tests/neg/T1490.hs view
file too large to diff
tests/neg/T1490A.hs view
file too large to diff
tests/neg/T1498.hs view
file too large to diff
tests/neg/T1498A.hs view
file too large to diff
tests/neg/T1546.hs view
file too large to diff
tests/neg/T1553.hs view
file too large to diff
tests/neg/T1553A.hs view
file too large to diff
tests/neg/T1555.hs view
file too large to diff
tests/neg/T1577.hs view
file too large to diff
tests/neg/T1604.hs view
file too large to diff
tests/neg/T1613.hs view
file too large to diff
tests/neg/T1642A.hs view
file too large to diff
tests/neg/T1657.hs view
file too large to diff
tests/neg/T1657A.hs view
file too large to diff
tests/neg/T1659.hs view
file too large to diff
tests/neg/T1814.hs view
file too large to diff
+ tests/neg/T1907.hs view
file too large to diff
tests/neg/T602.hs view
file too large to diff
− tests/neg/T743-mini.hs 
file too large to diff
tests/neg/T743.hs view
file too large to diff
+ tests/neg/T743_mini.hs view
file too large to diff
tests/neg/TermReal.hs view
file too large to diff
tests/neg/TerminationNum.hs view
file too large to diff
tests/neg/TerminationNum0.hs view
file too large to diff
+ tests/neg/Test00.hs view
file too large to diff
+ tests/neg/Test00a.hs view
file too large to diff
+ tests/neg/Test00b.hs view
file too large to diff
+ tests/neg/Test00c.hs view
file too large to diff
+ tests/neg/Test1.hs view
file too large to diff
+ tests/neg/Test2.hs view
file too large to diff
tests/neg/TopLevel.hs view
file too large to diff
tests/neg/TotalHaskell.hs view
file too large to diff
+ tests/neg/Trans.hs view
file too large to diff
+ tests/neg/Truespec.hs view
file too large to diff
+ tests/neg/Tyclass0_unsafe.hs view
file too large to diff
tests/neg/TypeLitNat.hs view
file too large to diff
tests/neg/Variance.hs view
file too large to diff
tests/neg/Variance1.hs view
file too large to diff
+ tests/neg/Vector00.hs view
file too large to diff
+ tests/neg/Vector0a.hs view
file too large to diff
+ tests/neg/Vector1a.hs view
file too large to diff
+ tests/neg/Vector2.hs view
file too large to diff
tests/neg/VerifiedNum.hs view
file too large to diff
+ tests/neg/Wrap0.hs view
file too large to diff
+ tests/neg/Wrap1.hs view
file too large to diff
− tests/neg/alias00.hs 
file too large to diff
− tests/neg/ass0.hs 
file too large to diff
− tests/neg/bag1.hs 
file too large to diff
− tests/neg/concat.hs 
file too large to diff
− tests/neg/concat1.hs 
file too large to diff
− tests/neg/concat2.hs 
file too large to diff
− tests/neg/contra0.hs 
file too large to diff
− tests/neg/coretologic.hs 
file too large to diff
− tests/neg/csv.hs 
file too large to diff
− tests/neg/datacon-eq.hs 
file too large to diff
− tests/neg/elim-ex-compose.hs 
file too large to diff
− tests/neg/elim-ex-let.hs 
file too large to diff
− tests/neg/elim-ex-list.hs 
file too large to diff
− tests/neg/elim-ex-map-1.hs 
file too large to diff
− tests/neg/elim-ex-map-2.hs 
file too large to diff
− tests/neg/elim-ex-map-3.hs 
file too large to diff
− tests/neg/elim000.hs 
file too large to diff
− tests/neg/errmsg.hs 
file too large to diff
− tests/neg/errorloc.hs 
file too large to diff
− tests/neg/ex0-unsafe.hs 
file too large to diff
− tests/neg/ex1-unsafe.hs 
file too large to diff
− tests/neg/filterAbs.hs 
file too large to diff
− tests/neg/foldN.hs 
file too large to diff
− tests/neg/foldN1.hs 
file too large to diff
− tests/neg/grty0.hs 
file too large to diff
− tests/neg/grty1.hs 
file too large to diff
− tests/neg/grty2.hs 
file too large to diff
− tests/neg/grty3.hs 
file too large to diff
− tests/neg/inc2.hs 
file too large to diff
− tests/neg/list00.hs 
file too large to diff
− tests/neg/listne.hs 
file too large to diff
− tests/neg/lit.hs 
file too large to diff
− tests/neg/mapreduce-tiny.hs 
file too large to diff
− tests/neg/mapreduce.hs 
file too large to diff
− tests/neg/maps.hs 
file too large to diff
− tests/neg/maybe.hs 
file too large to diff
− tests/neg/meas0.hs 
file too large to diff
− tests/neg/meas2.hs 
file too large to diff
− tests/neg/meas3.hs 
file too large to diff
− tests/neg/meas5.hs 
file too large to diff
− tests/neg/meas7.hs 
file too large to diff
− tests/neg/meas9.hs 
file too large to diff
− tests/neg/monad3.hs 
file too large to diff
− tests/neg/monad4.hs 
file too large to diff
− tests/neg/monad5.hs 
file too large to diff
− tests/neg/monad6.hs 
file too large to diff
− tests/neg/monad7.hs 
file too large to diff
− tests/neg/mr00.hs 
file too large to diff
− tests/neg/multi-pred-app-00.hs 
file too large to diff
− tests/neg/nestedRecursion.hs 
file too large to diff
− tests/neg/null.hs 
file too large to diff
− tests/neg/pair.hs 
file too large to diff
− tests/neg/pair0.hs 
file too large to diff
− tests/neg/pargs.hs 
file too large to diff
− tests/neg/pargs1.hs 
file too large to diff
− tests/neg/partial.hs 
file too large to diff
− tests/neg/poly0.hs 
file too large to diff
− tests/neg/poly1.hs 
file too large to diff
− tests/neg/poly2-degenerate.hs 
file too large to diff
− tests/neg/poly2.hs 
file too large to diff
− tests/neg/polypred.hs 
file too large to diff
− tests/neg/poslist.hs 
file too large to diff
− tests/neg/pred.hs 
file too large to diff
− tests/neg/prune0.hs 
file too large to diff
− tests/neg/range.hs 
file too large to diff
− tests/neg/record0.hs 
file too large to diff
− tests/neg/revshape.hs 
file too large to diff
− tests/neg/risers.hs 
file too large to diff
− tests/neg/stacks.hs 
file too large to diff
− tests/neg/state0.hs 
file too large to diff
− tests/neg/state00.hs 
file too large to diff
− tests/neg/string00.hs 
file too large to diff
− tests/neg/sumPoly.hs 
file too large to diff
− tests/neg/sumk.hs 
file too large to diff
− tests/neg/test00.hs 
file too large to diff
− tests/neg/test00a.hs 
file too large to diff
− tests/neg/test00b.hs 
file too large to diff
− tests/neg/test00c.hs 
file too large to diff
− tests/neg/test1.hs 
file too large to diff
− tests/neg/test2.hs 
file too large to diff
− tests/neg/trans.hs 
file too large to diff
− tests/neg/truespec.hs 
file too large to diff
− tests/neg/tyclass0-unsafe.hs 
file too large to diff
− tests/neg/vector00.hs 
file too large to diff
− tests/neg/vector0a.hs 
file too large to diff
− tests/neg/vector1a.hs 
file too large to diff
− tests/neg/vector2.hs 
file too large to diff
− tests/neg/wrap0.hs 
file too large to diff
− tests/neg/wrap1.hs 
file too large to diff
tests/pos/AVLRJ.hs view
file too large to diff
+ tests/pos/Absref_crash.hs view
file too large to diff
+ tests/pos/Absref_crash0.hs view
file too large to diff
+ tests/pos/Adt0.hs view
file too large to diff
tests/pos/AdtList0.hs view
file too large to diff
tests/pos/AdtList1.hs view
file too large to diff
tests/pos/AdtList2.hs view
file too large to diff
tests/pos/AdtList3.hs view
file too large to diff
tests/pos/AdtList4.hs view
file too large to diff
tests/pos/AdtList5.hs view
file too large to diff
tests/pos/AdtPeano0.hs view
file too large to diff
tests/pos/AdtPeano1.hs view
file too large to diff
+ tests/pos/Alias00.hs view
file too large to diff
+ tests/pos/Alias01.hs view
file too large to diff
+ tests/pos/Alphaconvert_List.hs view
file too large to diff
+ tests/pos/Alphaconvert_Set.hs view
file too large to diff
tests/pos/AmortizedQueue.hs view
file too large to diff
+ tests/pos/Anfbug.hs view
file too large to diff
+ tests/pos/Anftest.hs view
file too large to diff
+ tests/pos/Anish1.hs view
file too large to diff
tests/pos/AssumedRecursive.hs view
file too large to diff
tests/pos/AutoTerm.hs view
file too large to diff
tests/pos/AutoTerm1.hs view
file too large to diff
tests/pos/BST000.hs view
file too large to diff
+ tests/pos/Bag1.hs view
file too large to diff
+ tests/pos/BangPatterns.hs view
file too large to diff
tests/pos/BinarySearchOverflow.hs view
file too large to diff
+ tests/pos/Bool0.hs view
file too large to diff
+ tests/pos/Bool1.hs view
file too large to diff
+ tests/pos/Bool2.hs view
file too large to diff
+ tests/pos/Bounds1.hs view
file too large to diff
+ tests/pos/Case_lambda_join.hs view
file too large to diff
tests/pos/CasesToLogic.hs view
file too large to diff
tests/pos/Cat.hs view
file too large to diff
tests/pos/CharLiterals.hs view
file too large to diff
tests/pos/CheckedNum.hs view
file too large to diff
+ tests/pos/CheckedNumLib.hs view
file too large to diff
tests/pos/Class2.hs view
file too large to diff
tests/pos/ClassReg.hs view
file too large to diff
tests/pos/ClojurVector.hs view
file too large to diff
+ tests/pos/Cmptag0.hs view
file too large to diff
tests/pos/Coercion.hs view
file too large to diff
+ tests/pos/Comma.hs view
file too large to diff
tests/pos/CommentedOut.hs view
file too large to diff
+ tests/pos/Compare.hs view
file too large to diff
+ tests/pos/Compare1.hs view
file too large to diff
+ tests/pos/Compare2.hs view
file too large to diff
tests/pos/CompareConstraints.hs view
file too large to diff
+ tests/pos/Comprehension.hs view
file too large to diff
+ tests/pos/ComprehensionTerm.hs view
file too large to diff
tests/pos/Constraints.hs view
file too large to diff
tests/pos/ConstraintsAppend.hs view
file too large to diff
+ tests/pos/Coretologic.hs view
file too large to diff
tests/pos/CountMonad.hs view
file too large to diff
+ tests/pos/Csgordon_issue_296.hs view
file too large to diff
+ tests/pos/Cut00.hs view
file too large to diff
tests/pos/DB00.hs view
file too large to diff
+ tests/pos/Data2.hs view
file too large to diff
+ tests/pos/DataConQuals.hs view
file too large to diff
+ tests/pos/Datacon0.hs view
file too large to diff
+ tests/pos/Datacon1.hs view
file too large to diff
+ tests/pos/Datacon_inv.hs view
file too large to diff
+ tests/pos/Deepmeas0.hs view
file too large to diff
tests/pos/DepTriples.hs view
file too large to diff
tests/pos/DependentPairs.hs view
file too large to diff
tests/pos/DependentPairsFun.hs view
file too large to diff
+ tests/pos/Deptup.hs view
file too large to diff
+ tests/pos/Deptup1.hs view
file too large to diff
+ tests/pos/Deptup3.hs view
file too large to diff
+ tests/pos/DeptupW.hs view
file too large to diff
+ tests/pos/Div000.hs view
file too large to diff
+ tests/pos/Dropwhile.hs view
file too large to diff
+ tests/pos/Duplicate_bind.hs view
file too large to diff
+ tests/pos/Elements.hs view
file too large to diff
+ tests/pos/Elems.hs view
file too large to diff
+ tests/pos/Elim00.hs view
file too large to diff
+ tests/pos/Elim01.hs view
file too large to diff
+ tests/pos/Elim_ex_compose.hs view
file too large to diff
+ tests/pos/Elim_ex_let.hs view
file too large to diff
+ tests/pos/Elim_ex_list.hs view
file too large to diff
+ tests/pos/Elim_ex_map_1.hs view
file too large to diff
+ tests/pos/Elim_ex_map_2.hs view
file too large to diff
+ tests/pos/Elim_ex_map_3.hs view
file too large to diff
+ tests/pos/Eq_poly_measure.hs view
file too large to diff
+ tests/pos/Eqelems.hs view
file too large to diff
tests/pos/EvalQuery.hs view
file too large to diff
tests/pos/Even.hs view
file too large to diff
tests/pos/Even0.hs view
file too large to diff
+ tests/pos/Ex0.hs view
file too large to diff
+ tests/pos/Ex01.hs view
file too large to diff
+ tests/pos/Ex1.hs view
file too large to diff
tests/pos/ExactGADT.hs view
file too large to diff
tests/pos/ExactGADT0.hs view
file too large to diff
tests/pos/ExactGADT1.hs view
file too large to diff
tests/pos/ExactGADT2.hs view
file too large to diff
+ tests/pos/Exp0.hs view
file too large to diff
+ tests/pos/Extype.hs view
file too large to diff
tests/pos/FFI.hs view
file too large to diff
tests/pos/Fail.hs view
file too large to diff
+ tests/pos/FailName.hs view
file too large to diff
+ tests/pos/FancyMutualTerm.hs view
file too large to diff
+ tests/pos/FancyTerm.hs view
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/FilterAbs.hs view
file too large to diff
tests/pos/FingerTree.hs view
file too large to diff
+ tests/pos/FoldN.hs view
file too large to diff
tests/pos/Foldl.hs view
file too large to diff
+ tests/pos/Foldr.hs view
file too large to diff
+ tests/pos/For.hs view
file too large to diff
+ tests/pos/Forloop.hs view
file too large to diff
tests/pos/Fractional.hs view
file too large to diff
tests/pos/FractionalInstance.hs view
file too large to diff
+ tests/pos/GadtEval.hs view
file too large to diff
tests/pos/GeneralizedTermination.hs view
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 
file too large to diff
tests/pos/GhcSort3.hs view
file too large to diff
+ tests/pos/GhcSort3_T.hs view
file too large to diff
+ tests/pos/Gimme.hs view
file too large to diff
+ tests/pos/Go.hs view
file too large to diff
+ tests/pos/Go_ugly_type.hs view
file too large to diff
tests/pos/GoodHMeas.hs view
file too large to diff
+ tests/pos/Grty0.hs view
file too large to diff
+ tests/pos/Grty1.hs view
file too large to diff
+ tests/pos/Grty2.hs view
file too large to diff
+ tests/pos/Grty3.hs view
file too large to diff
+ tests/pos/GuardedNegative.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/Hello.hs view
file too large to diff
tests/pos/Hex00.hs view
file too large to diff
tests/pos/HigherOrderRecFun.hs view
file too large to diff
+ tests/pos/Hole_app.hs view
file too large to diff
+ tests/pos/Hole_fun.hs view
file too large to diff
− tests/pos/Holes-Slicing.hs 
file too large to diff
+ tests/pos/Holes_Slicing.hs view
file too large to diff
+ tests/pos/IdNat.hs view
file too large to diff
+ tests/pos/IdNat0.hs view
file too large to diff
tests/pos/Ignores.hs view
file too large to diff
+ tests/pos/Imp0.hs view
file too large to diff
+ tests/pos/Implies.hs view
file too large to diff
+ tests/pos/Infix.hs view
file too large to diff
+ tests/pos/Inline.hs view
file too large to diff
+ tests/pos/Inline1.hs view
file too large to diff
+ tests/pos/Invlhs.hs view
file too large to diff
+ tests/pos/Ite.hs view
file too large to diff
+ tests/pos/Ite1.hs view
file too large to diff
+ tests/pos/Jeff.hs view
file too large to diff
tests/pos/Keys.hs view
file too large to diff
+ tests/pos/Kmp.hs view
file too large to diff
+ tests/pos/KmpIO.hs view
file too large to diff
+ tests/pos/KmpVec.hs view
file too large to diff
+ tests/pos/LNot.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/LazyWhere1.hs view
file too large to diff
+ tests/pos/Lets.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/ListConcat.hs view
file too large to diff
− tests/pos/ListISort-bag.hs 
file too large to diff
− tests/pos/ListISort-perm.hs 
file too large to diff
+ tests/pos/ListISort_bag.hs view
file too large to diff
+ tests/pos/ListISort_perm.hs view
file too large to diff
tests/pos/ListKeys.hs view
file too large to diff
− tests/pos/ListLen-LType.hs 
file too large to diff
tests/pos/ListLen.hs view
file too large to diff
+ tests/pos/ListLen_LType.hs view
file too large to diff
− tests/pos/ListMSort-LType.hs 
file too large to diff
tests/pos/ListMSort.hs view
file too large to diff
+ tests/pos/ListMSort_LType.hs view
file too large to diff
− tests/pos/ListQSort-LType.hs 
file too large to diff
+ tests/pos/ListQSort_LType.hs view
file too large to diff
− tests/pos/ListRange-LType.hs 
file too large to diff
tests/pos/ListRange.hs view
file too large to diff
+ tests/pos/ListRange_LType.hs view
file too large to diff
− tests/pos/ListReverse-LType.hs 
file too large to diff
+ tests/pos/ListReverse_LType.hs view
file too large to diff
+ tests/pos/ListSet.hs view
file too large to diff
+ tests/pos/ListSetDemo.hs view
file too large to diff
+ tests/pos/Listqual.hs view
file too large to diff
+ tests/pos/Lit.hs view
file too large to diff
+ tests/pos/Lit00.hs view
file too large to diff
+ tests/pos/Lit02.hs view
file too large to diff
tests/pos/LogicCurry1.hs view
file too large to diff
+ tests/pos/Malformed0.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/MapReduceVerified.hs view
file too large to diff
+ tests/pos/MapTvCrash.hs view
file too large to diff
+ tests/pos/Mapreduce_bare.hs view
file too large to diff
+ tests/pos/Maps.hs view
file too large to diff
+ tests/pos/Maps1.hs view
file too large to diff
tests/pos/MaskError.hs view
file too large to diff
+ tests/pos/Maybe.hs view
file too large to diff
+ tests/pos/Maybe0.hs view
file too large to diff
+ tests/pos/Maybe000.hs view
file too large to diff
+ tests/pos/Maybe1.hs view
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/Maybe4.hs view
file too large to diff
+ tests/pos/Maybe5.hs view
file too large to diff
+ tests/pos/Meas0.hs view
file too large to diff
+ tests/pos/Meas00.hs view
file too large to diff
+ tests/pos/Meas00a.hs view
file too large to diff
+ tests/pos/Meas0a.hs view
file too large to diff
+ tests/pos/Meas1.hs view
file too large to diff
+ tests/pos/Meas10.hs view
file too large to diff
+ tests/pos/Meas11.hs view
file too large to diff
+ tests/pos/Meas2.hs view
file too large to diff
+ tests/pos/Meas4.hs view
file too large to diff
+ tests/pos/Meas5.hs view
file too large to diff
+ tests/pos/Meas6.hs view
file too large to diff
+ tests/pos/Meas7.hs view
file too large to diff
+ tests/pos/Meas8.hs view
file too large to diff
+ tests/pos/Meas9.hs view
file too large to diff
tests/pos/MeasureContains.hs view
file too large to diff
tests/pos/MeasureDups.hs view
file too large to diff
tests/pos/MeasureSets.hs view
file too large to diff
tests/pos/Measures1.hs view
file too large to diff
− tests/pos/MergeSort-bag.hs 
file too large to diff
+ tests/pos/MergeSort_bag.hs view
file too large to diff
+ tests/pos/ModTest.hs view
file too large to diff
+ tests/pos/Monad2.hs view
file too large to diff
+ tests/pos/Monad5.hs view
file too large to diff
+ tests/pos/Monad6.hs view
file too large to diff
+ tests/pos/Multi_pred_app_00.hs view
file too large to diff
+ tests/pos/Mutrec.hs view
file too large to diff
tests/pos/MutuallyDependentADT.hs view
file too large to diff
+ tests/pos/Nats.hs view
file too large to diff
+ tests/pos/Niki.hs view
file too large to diff
+ tests/pos/Niki1.hs view
file too large to diff
tests/pos/NoExhaustiveGuardsError.hs view
file too large to diff
+ tests/pos/NoPositivityCheck.hs view
file too large to diff
+ tests/pos/Null.hs view
file too large to diff
+ tests/pos/Pair.hs view
file too large to diff
+ tests/pos/Pair0.hs view
file too large to diff
+ tests/pos/Pair00.hs view
file too large to diff
tests/pos/PairMeasure.hs view
file too large to diff
tests/pos/PairMeasure0.hs view
file too large to diff
+ tests/pos/Pargs.hs view
file too large to diff
+ tests/pos/Pargs1.hs view
file too large to diff
+ tests/pos/Partial_tycon.hs view
file too large to diff
+ tests/pos/Partialmeasure.hs view
file too large to diff
tests/pos/Permutation.hs view
file too large to diff
tests/pos/PersistentVector.hs view
file too large to diff
+ tests/pos/Ple1.hs view
file too large to diff
tests/pos/PointDist.hs view
file too large to diff
+ tests/pos/Poly0.hs view
file too large to diff
+ tests/pos/Poly1.hs view
file too large to diff
+ tests/pos/Poly2.hs view
file too large to diff
+ tests/pos/Poly2_degenerate.hs view
file too large to diff
+ tests/pos/Poly3.hs view
file too large to diff
+ tests/pos/Poly3a.hs view
file too large to diff
+ tests/pos/Poly4.hs view
file too large to diff
+ tests/pos/Polyfun.hs view
file too large to diff
+ tests/pos/Polyqual.hs view
file too large to diff
+ tests/pos/PositivityCheck.hs view
file too large to diff
+ tests/pos/Poslist.hs view
file too large to diff
+ tests/pos/Poslist_dc.hs view
file too large to diff
+ tests/pos/Pragma0.hs view
file too large to diff
+ tests/pos/Pred.hs view
file too large to diff
+ tests/pos/PrimInt0.hs view
file too large to diff
tests/pos/Product.hs view
file too large to diff
+ tests/pos/Profcrasher.hs view
file too large to diff
tests/pos/Propability.hs view
file too large to diff
+ tests/pos/Propmeasure.hs view
file too large to diff
+ tests/pos/Propmeasure1.hs view
file too large to diff
tests/pos/QQTySig.hs view
file too large to diff
tests/pos/QQTySigTyVars.hs view
file too large to diff
tests/pos/QQTySyn.hs view
file too large to diff
+ tests/pos/QualTest.hs view
file too large to diff
− tests/pos/RBTree-col-height.hs 
file too large to diff
− tests/pos/RBTree-color.hs 
file too large to diff
− tests/pos/RBTree-height.hs 
file too large to diff
− tests/pos/RBTree-ord.hs 
file too large to diff
tests/pos/RBTree.hs view
file too large to diff
+ tests/pos/RBTree_col_height.hs view
file too large to diff
+ tests/pos/RBTree_color.hs view
file too large to diff
+ tests/pos/RBTree_height.hs view
file too large to diff
+ tests/pos/RBTree_ord.hs view
file too large to diff
+ tests/pos/Range.hs view
file too large to diff
+ tests/pos/Range1.hs view
file too large to diff
+ tests/pos/RangeAdt.hs view
file too large to diff
tests/pos/ReWrite.hs view
file too large to diff
tests/pos/ReWrite10.hs view
file too large to diff
tests/pos/ReWrite3.hs view
file too large to diff
tests/pos/RealProps.hs view
file too large to diff
tests/pos/Rebind.hs view
file too large to diff
tests/pos/RecQSort.hs view
file too large to diff
tests/pos/RecQSort0.hs view
file too large to diff
tests/pos/RecSelector.hs view
file too large to diff
+ tests/pos/Rec_annot_go.hs view
file too large to diff
+ tests/pos/Record0.hs view
file too large to diff
+ tests/pos/Record1.hs view
file too large to diff
tests/pos/RecordSelectorError.hs view
file too large to diff
+ tests/pos/Recursion0.hs view
file too large to diff
tests/pos/Reduction.hs view
file too large to diff
+ tests/pos/Reflect0.hs view
file too large to diff
tests/pos/ReflectAlias.hs view
file too large to diff
tests/pos/ReflectBooleanFunctions.hs view
file too large to diff
tests/pos/ReflectMutual.hs view
file too large to diff
tests/pos/RelativeComplete.hs view
file too large to diff
tests/pos/Repeat.hs view
file too large to diff
+ tests/pos/RepeatHigherOrder.hs view
file too large to diff
tests/pos/ResolveA.hs view
file too large to diff
+ tests/pos/ResolveALib.hs view
file too large to diff
+ tests/pos/ResolveBLib.hs view
file too large to diff
+ tests/pos/Rest.hs view
file too large to diff
+ tests/pos/Risers.hs view
file too large to diff
+ tests/pos/Rta.hs view
file too large to diff
+ tests/pos/Scanr.hs view
file too large to diff
+ tests/pos/SelfList.hs view
file too large to diff
tests/pos/SimplifyTup00.hs view
file too large to diff
tests/pos/Solver.hs view
file too large to diff
+ tests/pos/Spec0.hs view
file too large to diff
tests/pos/StackClass.hs view
file too large to diff
+ tests/pos/Stacks0.hs view
file too large to diff
+ tests/pos/State00.hs view
file too large to diff
tests/pos/StateConstraints.hs view
file too large to diff
tests/pos/StateConstraints0.hs view
file too large to diff
tests/pos/StateConstraints00.hs view
file too large to diff
tests/pos/StateF00.hs view
file too large to diff
+ tests/pos/StateInvarint.hs view
file too large to diff
tests/pos/StateLib.hs view
file too large to diff
tests/pos/StrictPair0.hs view
file too large to diff
tests/pos/StrictPair1.hs view
file too large to diff
+ tests/pos/String00.hs view
file too large to diff
tests/pos/Strings.hs view
file too large to diff
tests/pos/StructRec.hs view
file too large to diff
tests/pos/Sum.hs view
file too large to diff
tests/pos/T1013.hs view
file too large to diff
tests/pos/T1013A.hs view
file too large to diff
tests/pos/T1024.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/T1034.hs view
file too large to diff
+ tests/pos/T1045aLib.hs view
file too large to diff
tests/pos/T1060.hs view
file too large to diff
tests/pos/T1074.hs view
file too large to diff
tests/pos/T1092.hs view
file too large to diff
tests/pos/T1095A.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/T1126.hs view
file too large to diff
tests/pos/T1126a.hs view
file too large to diff
− tests/pos/T1198.1.hs 
file too large to diff
− tests/pos/T1198.2.hs 
file too large to diff
− tests/pos/T1198.3.hs 
file too large to diff
− tests/pos/T1198.4.hs 
file too large to diff
+ tests/pos/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/T1220.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 
file too large to diff
− tests/pos/T1278.3.hs 
file too large to diff
tests/pos/T1278.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/T1286.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/T1543.hs view
file too large to diff
tests/pos/T1547.hs view
file too large to diff
tests/pos/T1548.hs view
file too large to diff
tests/pos/T1550.hs view
file too large to diff
tests/pos/T1555.hs view
file too large to diff
tests/pos/T1556.hs view
file too large to diff
tests/pos/T1560.hs view
file too large to diff
tests/pos/T1560B.hs view
file too large to diff
tests/pos/T1568.hs view
file too large to diff
tests/pos/T1571.hs view
file too large to diff
tests/pos/T1577.hs view
file too large to diff
tests/pos/T1633.hs view
file too large to diff
tests/pos/T1634.hs view
file too large to diff
tests/pos/T1636.hs view
file too large to diff
tests/pos/T1642.hs view
file too large to diff
tests/pos/T1642A.hs view
file too large to diff
tests/pos/T1647.hs view
file too large to diff
tests/pos/T1649MeasuresDef.hs view
file too large to diff
tests/pos/T1649WorkTypes.hs view
file too large to diff
tests/pos/T1660.hs view
file too large to diff
tests/pos/T1669.hs view
file too large to diff
tests/pos/T1670A.hs view
file too large to diff
tests/pos/T1670B.hs view
file too large to diff
tests/pos/T1697.hs view
file too large to diff
tests/pos/T1697A.hs view
file too large to diff
tests/pos/T1697C.hs view
file too large to diff
tests/pos/T1709.hs view
file too large to diff
tests/pos/T1749.hs view
file too large to diff
tests/pos/T1775.hs view
file too large to diff
tests/pos/T1812.hs view
file too large to diff
+ tests/pos/T2091.hs view
file too large to diff
+ tests/pos/T2093.hs view
file too large to diff
+ tests/pos/T2096.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/T716.hs view
file too large to diff
tests/pos/T819.hs view
file too large to diff
tests/pos/T820.hs view
file too large to diff
tests/pos/T866.hs view
file too large to diff
tests/pos/T914.hs view
file too large to diff
+ tests/pos/TagBinder.hs view
file too large to diff
+ tests/pos/Take.hs view
file too large to diff
+ tests/pos/Term0.hs view
file too large to diff
tests/pos/TerminationNum.hs view
file too large to diff
tests/pos/TerminationNum0.hs view
file too large to diff
+ tests/pos/Test0.hs view
file too large to diff
+ tests/pos/Test00.hs view
file too large to diff
+ tests/pos/Test000.hs view
file too large to diff
+ tests/pos/Test00_int.hs view
file too large to diff
+ tests/pos/Test00_old.hs view
file too large to diff
+ tests/pos/Test00b.hs view
file too large to diff
+ tests/pos/Test00c.hs view
file too large to diff
+ tests/pos/Test1.hs view
file too large to diff
+ tests/pos/Test2.hs view
file too large to diff
+ tests/pos/TestRec.hs view
file too large to diff
tests/pos/TokenType.hs view
file too large to diff
+ tests/pos/Top0.hs view
file too large to diff
tests/pos/ToyMVar.hs view
file too large to diff
+ tests/pos/Trans.hs view
file too large to diff
+ tests/pos/TransTAG.hs view
file too large to diff
+ tests/pos/Transpose.hs view
file too large to diff
+ tests/pos/Tup0.hs view
file too large to diff
+ tests/pos/Tupparse.hs view
file too large to diff
+ tests/pos/TyExpr.hs view
file too large to diff
+ tests/pos/Tyclass0.hs view
file too large to diff
+ tests/pos/Tyfam0.hs view
file too large to diff
tests/pos/TypeLitNat.hs view
file too large to diff
tests/pos/TypeLitString.hs view
file too large to diff
+ tests/pos/Tyvar.hs view
file too large to diff
tests/pos/UnboxedTuples.hs view
file too large to diff
tests/pos/UnboxedTuplesAndTH.hs view
file too large to diff
+ tests/pos/UndecidedGuards.hs view
file too large to diff
+ tests/pos/Unusedtyvars.hs view
file too large to diff
tests/pos/Variance2.hs view
file too large to diff
+ tests/pos/Vector00.hs view
file too large to diff
+ tests/pos/Vector1.hs view
file too large to diff
+ tests/pos/Vector1a.hs view
file too large to diff
+ tests/pos/Vector1b.hs view
file too large to diff
+ tests/pos/Vector2.hs view
file too large to diff
tests/pos/VerifiedNum.hs view
file too large to diff
tests/pos/WBL0.hs view
file too large to diff
+ tests/pos/WhyLH.hs view
file too large to diff
tests/pos/Words1.hs view
file too large to diff
+ tests/pos/Wrap0.hs view
file too large to diff
+ tests/pos/Wrap1.hs view
file too large to diff
tests/pos/WrapUnWrap.hs view
file too large to diff
+ tests/pos/ZipSO.hs view
file too large to diff
+ tests/pos/ZipW.hs view
file too large to diff
+ tests/pos/ZipW1.hs view
file too large to diff
+ tests/pos/ZipW2.hs view
file too large to diff
+ tests/pos/Zipper.hs view
file too large to diff
+ tests/pos/Zipper0.hs view
file too large to diff
+ tests/pos/Zipper000.hs view
file too large to diff
− tests/pos/absref-crash.hs 
file too large to diff
− tests/pos/absref-crash0.hs 
file too large to diff
− tests/pos/adt0.hs 
file too large to diff
− tests/pos/alias00.hs 
file too large to diff
− tests/pos/alias01.hs 
file too large to diff
− tests/pos/alphaconvert-List.hs 
file too large to diff
− tests/pos/alphaconvert-Set.hs 
file too large to diff
− tests/pos/anfbug.hs 
file too large to diff
− tests/pos/anftest.hs 
file too large to diff
− tests/pos/anish1.hs 
file too large to diff
− tests/pos/bag1.hs 
file too large to diff
− tests/pos/bangPatterns.hs 
file too large to diff
− tests/pos/bool0.hs 
file too large to diff
− tests/pos/bool1.hs 
file too large to diff
− tests/pos/bool2.hs 
file too large to diff
− tests/pos/bounds1.hs 
file too large to diff
− tests/pos/case-lambda-join.hs 
file too large to diff
− tests/pos/cmptag0.hs 
file too large to diff
− tests/pos/comma.hs 
file too large to diff
− tests/pos/compare.hs 
file too large to diff
− tests/pos/compare1.hs 
file too large to diff
− tests/pos/compare2.hs 
file too large to diff
− tests/pos/comprehension.hs 
file too large to diff
− tests/pos/comprehensionTerm.hs 
file too large to diff
− tests/pos/coretologic.hs 
file too large to diff
− tests/pos/csgordon_issue_296.hs 
file too large to diff
− tests/pos/cut00.hs 
file too large to diff
− tests/pos/data2.hs 
file too large to diff
− tests/pos/dataConQuals.hs 
file too large to diff
− tests/pos/datacon-inv.hs 
file too large to diff
− tests/pos/datacon0.hs 
file too large to diff
− tests/pos/datacon1.hs 
file too large to diff
− tests/pos/deepmeas0.hs 
file too large to diff
− tests/pos/deptup.hs 
file too large to diff
− tests/pos/deptup1.hs 
file too large to diff
− tests/pos/deptup3.hs 
file too large to diff
− tests/pos/deptupW.hs 
file too large to diff
− tests/pos/div000.hs 
file too large to diff
− tests/pos/dropwhile.hs 
file too large to diff
− tests/pos/duplicate-bind.hs 
file too large to diff
− tests/pos/elements.hs 
file too large to diff
− tests/pos/elems.hs 
file too large to diff
− tests/pos/elim-ex-compose.hs 
file too large to diff
− tests/pos/elim-ex-let.hs 
file too large to diff
− tests/pos/elim-ex-list.hs 
file too large to diff
− tests/pos/elim-ex-map-1.hs 
file too large to diff
− tests/pos/elim-ex-map-2.hs 
file too large to diff
− tests/pos/elim-ex-map-3.hs 
file too large to diff
− tests/pos/elim00.hs 
file too large to diff
− tests/pos/elim01.hs 
file too large to diff
− tests/pos/eq-poly-measure.hs 
file too large to diff
− tests/pos/eqelems.hs 
file too large to diff
− tests/pos/ex0.hs 
file too large to diff
− tests/pos/ex01.hs 
file too large to diff
− tests/pos/ex1.hs 
file too large to diff
− tests/pos/exp0.hs 
file too large to diff
− tests/pos/extype.hs 
file too large to diff
− tests/pos/failName.hs 
file too large to diff
− tests/pos/filterAbs.hs 
file too large to diff
− tests/pos/foldN.hs 
file too large to diff
− tests/pos/foldr.hs 
file too large to diff
− tests/pos/for.hs 
file too large to diff
− tests/pos/forloop.hs 
file too large to diff
− tests/pos/gadtEval.hs 
file too large to diff
− tests/pos/gimme.hs 
file too large to diff
− tests/pos/go.hs 
file too large to diff
− tests/pos/go_ugly_type.hs 
file too large to diff
− tests/pos/grty0.hs 
file too large to diff
− tests/pos/grty1.hs 
file too large to diff
− tests/pos/grty2.hs 
file too large to diff
− tests/pos/grty3.hs 
file too large to diff
− tests/pos/hello.hs 
file too large to diff
− tests/pos/hole-app.hs 
file too large to diff
− tests/pos/hole-fun.hs 
file too large to diff
− tests/pos/idNat.hs 
file too large to diff
− tests/pos/idNat0.hs 
file too large to diff
− tests/pos/imp0.hs 
file too large to diff
− tests/pos/implies.hs 
file too large to diff
− tests/pos/infix.hs 
file too large to diff
− tests/pos/inline.hs 
file too large to diff
− tests/pos/inline1.hs 
file too large to diff
− tests/pos/invlhs.hs 
file too large to diff
+ tests/pos/isort_erase.hs view
file too large to diff
− tests/pos/ite.hs 
file too large to diff
− tests/pos/ite1.hs 
file too large to diff
− tests/pos/jeff.hs 
file too large to diff
− tests/pos/kmp.hs 
file too large to diff
− tests/pos/kmpIO.hs 
file too large to diff
− tests/pos/kmpVec.hs 
file too large to diff
− tests/pos/lets.hs 
file too large to diff
− tests/pos/lex.hs 
file too large to diff
− tests/pos/listAnf.hs 
file too large to diff
− tests/pos/listSet.hs 
file too large to diff
− tests/pos/listSetDemo.hs 
file too large to diff
− tests/pos/listqual.hs 
file too large to diff
− tests/pos/lit.hs 
file too large to diff
− tests/pos/lit00.hs 
file too large to diff
− tests/pos/lit02.hs 
file too large to diff
− tests/pos/malformed0.hs 
file too large to diff
− tests/pos/mapTvCrash.hs 
file too large to diff
− tests/pos/mapreduce-bare.hs 
file too large to diff
− tests/pos/maps.hs 
file too large to diff
− tests/pos/maps1.hs 
file too large to diff
− tests/pos/maybe.hs 
file too large to diff
− tests/pos/maybe0.hs 
file too large to diff
− tests/pos/maybe000.hs 
file too large to diff
− tests/pos/maybe1.hs 
file too large to diff
− tests/pos/maybe2.hs 
file too large to diff
− tests/pos/maybe3.hs 
file too large to diff
− tests/pos/maybe4.hs 
file too large to diff
− tests/pos/maybe5.hs 
file too large to diff
− tests/pos/meas0.hs 
file too large to diff
− tests/pos/meas00.hs 
file too large to diff
− tests/pos/meas00a.hs 
file too large to diff
− tests/pos/meas0a.hs 
file too large to diff
− tests/pos/meas1.hs 
file too large to diff
− tests/pos/meas10.hs 
file too large to diff
− tests/pos/meas11.hs 
file too large to diff
− tests/pos/meas2.hs 
file too large to diff
− tests/pos/meas4.hs 
file too large to diff
− tests/pos/meas5.hs 
file too large to diff
− tests/pos/meas6.hs 
file too large to diff
− tests/pos/meas7.hs 
file too large to diff
− tests/pos/meas8.hs 
file too large to diff
− tests/pos/meas9.hs 
file too large to diff
− tests/pos/modTest.hs 
file too large to diff
− tests/pos/monad2.hs 
file too large to diff
− tests/pos/monad5.hs 
file too large to diff
− tests/pos/monad6.hs 
file too large to diff
− tests/pos/multi-pred-app-00.hs 
file too large to diff
− tests/pos/mutrec.hs 
file too large to diff
− tests/pos/nats.hs 
file too large to diff
− tests/pos/niki.hs 
file too large to diff
− tests/pos/niki1.hs 
file too large to diff
− tests/pos/null.hs 
file too large to diff
− tests/pos/pair.hs 
file too large to diff
− tests/pos/pair0.hs 
file too large to diff
− tests/pos/pair00.hs 
file too large to diff
− tests/pos/pargs.hs 
file too large to diff
− tests/pos/pargs1.hs 
file too large to diff
− tests/pos/partial-tycon.hs 
file too large to diff
− tests/pos/partialmeasure.hs 
file too large to diff
− tests/pos/ple1.hs 
file too large to diff
− tests/pos/poly0.hs 
file too large to diff
− tests/pos/poly1.hs 
file too large to diff
− tests/pos/poly2-degenerate.hs 
file too large to diff
− tests/pos/poly2.hs 
file too large to diff
− tests/pos/poly3.hs 
file too large to diff
− tests/pos/poly3a.hs 
file too large to diff
− tests/pos/poly4.hs 
file too large to diff
− tests/pos/polyfun.hs 
file too large to diff
− tests/pos/polyqual.hs 
file too large to diff
− tests/pos/poslist.hs 
file too large to diff
− tests/pos/poslist_dc.hs 
file too large to diff
− tests/pos/pragma0.hs 
file too large to diff
− tests/pos/pred.hs 
file too large to diff
− tests/pos/primInt0.hs 
file too large to diff
− tests/pos/profcrasher.hs 
file too large to diff
− tests/pos/propmeasure.hs 
file too large to diff
− tests/pos/propmeasure1.hs 
file too large to diff
− tests/pos/qualTest.hs 
file too large to diff
− tests/pos/range.hs 
file too large to diff
− tests/pos/range1.hs 
file too large to diff
− tests/pos/rangeAdt.hs 
file too large to diff
− tests/pos/rec_annot_go.hs 
file too large to diff
− tests/pos/record0.hs 
file too large to diff
− tests/pos/record1.hs 
file too large to diff
− tests/pos/recursion0.hs 
file too large to diff
− tests/pos/reflect0.hs 
file too large to diff
− tests/pos/repeatHigherOrder.hs 
file too large to diff
− tests/pos/risers.hs 
file too large to diff
− tests/pos/rta.hs 
file too large to diff
− tests/pos/scanr.hs 
file too large to diff
− tests/pos/selfList.hs 
file too large to diff
− tests/pos/spec0.hs 
file too large to diff
− tests/pos/stacks0.hs 
file too large to diff
− tests/pos/state00.hs 
file too large to diff
− tests/pos/stateInvarint.hs 
file too large to diff
− tests/pos/string00.hs 
file too large to diff
− tests/pos/tagBinder.hs 
file too large to diff
− tests/pos/take.hs 
file too large to diff
− tests/pos/term0.hs 
file too large to diff
− tests/pos/test0.hs 
file too large to diff
− tests/pos/test00-int.hs 
file too large to diff
− tests/pos/test00.hs 
file too large to diff
− tests/pos/test00.old.hs 
file too large to diff
− tests/pos/test000.hs 
file too large to diff
− tests/pos/test00b.hs 
file too large to diff
− tests/pos/test00c.hs 
file too large to diff
− tests/pos/test1.hs 
file too large to diff
− tests/pos/test2.hs 
file too large to diff
− tests/pos/testRec.hs 
file too large to diff
− tests/pos/top0.hs 
file too large to diff
− tests/pos/trans.hs 
file too large to diff
− tests/pos/transTAG.hs 
file too large to diff
− tests/pos/transpose.hs 
file too large to diff
− tests/pos/tup0.hs 
file too large to diff
− tests/pos/tupparse.hs 
file too large to diff
− tests/pos/tyExpr.hs 
file too large to diff
− tests/pos/tyclass0.hs 
file too large to diff
− tests/pos/tyfam0.hs 
file too large to diff
− tests/pos/tyvar.hs 
file too large to diff
− tests/pos/unusedtyvars.hs 
file too large to diff
− tests/pos/vector00.hs 
file too large to diff
− tests/pos/vector1.hs 
file too large to diff
− tests/pos/vector1a.hs 
file too large to diff
− tests/pos/vector1b.hs 
file too large to diff
− tests/pos/vector2.hs 
file too large to diff
− tests/pos/wrap0.hs 
file too large to diff
− tests/pos/wrap1.hs 
file too large to diff
− tests/pos/zipSO.hs 
file too large to diff
− tests/pos/zipW.hs 
file too large to diff
− tests/pos/zipW1.hs 
file too large to diff
− tests/pos/zipW2.hs 
file too large to diff
− tests/pos/zipper.hs 
file too large to diff
− tests/pos/zipper0.hs 
file too large to diff
− tests/pos/zipper000.hs 
file too large to diff
− tests/test.hs 
file too large to diff