packages feed

liquidhaskell 0.5.0.1 → 0.6.0.0

raw patch · 233 files changed

+16744/−25269 lines, 233 filesdep +cerealdep +daemonsdep +located-basedep −ansi-terminaldep −filemanipdep −interndep ~Diffdep ~aesondep ~arraysetup-changednew-component:exe:lhi

Dependencies added: cereal, daemons, located-base, network, tasty-ant-xml, temporary, unix

Dependencies removed: ansi-terminal, filemanip, intern

Dependency ranges changed: Diff, aeson, array, base, bifunctors, bytestring, cmdargs, containers, cpphs, data-default, deepseq, directory, filepath, fingertree, ghc, ghc-paths, hashable, hpc, hscolour, liquid-fixpoint, mtl, optparse-applicative, parsec, pretty, process, stm, syb, tagged, template-haskell, text, time, transformers, unordered-containers, vector

Files

− Liquid.hs 
@@ -1,113 +0,0 @@-{-# LANGUAGE TupleSections  #-}-{-# LANGUAGE CPP #-}--{-@ LIQUID "--cabaldir" @-}-{-@ LIQUID "--diff"     @-}--#if __GLASGOW_HASKELL__ < 710-import           Data.Monoid      (mconcat, mempty)-import           Control.Applicative ((<$>))-#endif--import           Data.Maybe-import           System.Exit-import           Control.DeepSeq-import           Text.PrettyPrint.HughesPJ-import           CoreSyn-import           Var-import           System.Console.CmdArgs.Verbosity (whenLoud)-import           System.Console.CmdArgs.Default--import qualified Language.Fixpoint.Config as FC-import qualified Language.Haskell.Liquid.DiffCheck as DC-import           Language.Fixpoint.Misc-import           Language.Fixpoint.Interface-import           Language.Fixpoint.Types (sinfo, Result (..))-import           Language.Haskell.Liquid.Types-import           Language.Haskell.Liquid.Errors-import           Language.Haskell.Liquid.CmdLine-import           Language.Haskell.Liquid.GhcInterface-import           Language.Haskell.Liquid.Constraint.Generate-import           Language.Haskell.Liquid.Constraint.ToFixpoint-import           Language.Haskell.Liquid.Constraint.Types-import           Language.Haskell.Liquid.TransformRec-import           Language.Haskell.Liquid.Annotate (mkOutput)----main :: IO b-main = do cfg0     <- getOpts-          res      <- mconcat <$> mapM (checkOne cfg0) (files cfg0)-          let ecode = resultExit $  {- traceShow "RESULT" $ -} o_result res-          -- putStrLn  $ "ExitCode: " ++ show ecode-          exitWith ecode--checkOne :: Config -> FilePath -> IO (Output Doc)-checkOne cfg0 t = getGhcInfo cfg0 t >>= either errOut (liquidOne t)-  where-    errOut r    = exitWithResult cfg0 t $ mempty { o_result = r}--liquidOne :: FilePath -> GhcInfo -> IO (Output Doc)-liquidOne target info =-  do donePhase Loud "Extracted Core using GHC"-     let cfg   = config $ spec info-     whenLoud  $ do putStrLn "**** Config **************************************************"-                    print cfg-     whenLoud  $ do putStrLn $ showpp info-                    putStrLn "*************** Original CoreBinds ***************************"-                    putStrLn $ showpp (cbs info)-     let cbs' = transformScope (cbs info)-     whenLoud  $ do donePhase Loud "transformRecExpr"-                    putStrLn "*************** Transform Rec Expr CoreBinds *****************"-                    putStrLn $ showpp cbs'-                    putStrLn "*************** Slicing Out Unchanged CoreBinds *****************"-     dc <- prune cfg cbs' target info-     let cbs'' = maybe cbs' DC.newBinds dc-     let info' = maybe info (\z -> info {spec = DC.newSpec z}) dc-     let cgi   = {-# SCC "generateConstraints" #-} generateConstraints $! info' {cbs = cbs''}-     cgi `deepseq` donePhase Loud "generateConstraints"-     out      <- solveCs cfg target cgi info' dc-     donePhase Loud "solve"-     let out'  = mconcat [maybe mempty DC.oldOutput dc, out]-     DC.saveResult target out'-     exitWithResult cfg target out'--checkedNames ::  Maybe DC.DiffCheck -> Maybe [String]-checkedNames dc          = concatMap names . DC.newBinds <$> dc-   where-     names (NonRec v _ ) = [showpp $ shvar v]-     names (Rec xs)      = map (shvar . fst) xs-     shvar               = showpp . varName--prune :: Config -> [CoreBind] -> FilePath -> GhcInfo -> IO (Maybe DC.DiffCheck)-prune cfg cbinds target info-  | not (null vs) = return . Just $ DC.DC (DC.thin cbinds vs) mempty sp-  | diffcheck cfg = DC.slice target cbinds sp-  | otherwise     = return Nothing-  where-    vs            = tgtVars sp-    sp            = spec info--solveCs :: Config -> FilePath -> CGInfo -> GhcInfo -> Maybe DC.DiffCheck -> IO (Output Doc)-solveCs cfg target cgi info dc-  = do finfo    <- cgInfoFInfo info cgi-       Result r sol <- solve fx finfo-       let names = checkedNames dc-       let warns = logErrors cgi-       let annm  = annotMap cgi-       let res   = ferr sol r-       let out0  = mkOutput cfg res sol annm-       return    $ out0 { o_vars = names } { o_errors  = warns} { o_result = res }-    where-       fx        = def { FC.solver  = fromJust (smtsolver cfg)-                       , FC.real    = real   cfg-                       , FC.native  = native cfg-                       , FC.srcFile = target-                       -- , FC.stats   = True-                       }-       ferr s r  = fmap (tidyError s) $ result $ sinfo <$> r----- writeCGI tgt cgi = {-# SCC "ConsWrite" #-} writeFile (extFileName Cgi tgt) str---   where---     str          = {-# SCC "PPcgi" #-} showpp cgi
Setup.hs view
@@ -1,5 +1,6 @@ import Distribution.Simple + main = defaultMain  -- main = defaultMainWithHooks fixpointHooks
− include/708/Control/Monad.spec 
@@ -1,3 +0,0 @@-module spec Control.Monad where--Control.Monad.sequence :: GHC.Base.Monad m => xs:[m a] -> m {v:[a] | (len v) = (len xs)}
include/CoreToLogic.lg view
@@ -3,6 +3,7 @@ define Data.Set.Base.intersection x y = (Set_cap x y) define Data.Set.Base.difference x y   = (Set_dif x y) define Data.Set.Base.empty            = (Set_empty 0)+define Data.Set.Base.null x           = (Set_emp x) define Data.Set.Base.member x xs      = (Set_mem x xs) define Data.Set.Base.isSubsetOf x y   = (Set_sub x y) define Data.Set.Base.elems xs         = (listElts xs)
include/Data/Set.spec view
@@ -37,6 +37,7 @@  isSubsetOf    :: (GHC.Classes.Ord a) => x:(Data.Set.Set a) -> y:(Data.Set.Set a) -> {v:Bool | ((Prop v) <=> (Set_sub x y))} member        :: (GHC.Classes.Ord a) => x:a -> xs:(Data.Set.Set a) -> {v:Bool | ((Prop v) <=> (Set_mem x xs))}+null          :: (GHC.Classes.Ord a) => xs:(Data.Set.Set a) -> {v:Bool | ((Prop v) <=> (Set_emp xs))}  empty         :: {v:(Data.Set.Set a) | (Set_emp v)} singleton     :: x:a -> {v:(Data.Set.Set a) | v = (Set_sng x)}
include/Data/Vector.spec view
@@ -2,6 +2,9 @@  import GHC.Base +data variance Vector covariant++ measure vlen    :: forall a. (Data.Vector.Vector a) -> Int  invariant       {v: Data.Vector.Vector a | 0 <= vlen v } @@ -13,3 +16,5 @@ assume length    :: forall a. x:(Data.Vector.Vector a) -> {v : Nat | v = vlen x }  assume replicate :: n:Nat -> a -> {v:Data.Vector.Vector a | vlen v = n} ++assume imap :: (Nat -> a -> b) -> x:(Data.Vector.Vector a) -> {y:Data.Vector.Vector b | vlen y = vlen x }
include/GHC/Real.spec view
@@ -8,8 +8,10 @@   GHC.Real.fromRational :: GHC.Real.Rational -> a  class (GHC.Real.Real a, GHC.Enum.Enum a) => GHC.Real.Integral a where-  GHC.Real.quot :: a -> {v:a | v /= 0} -> a-  GHC.Real.rem :: a -> {v:a | v /= 0} -> a+  GHC.Real.quot :: x:a -> y:{v:a | v /= 0} -> {v:a | (v = (x / y)) &&+                                                     ((x >= 0 && y >= 0) => v >= 0) &&+                                                     ((x >= 0 && y >= 1) => v <= x) }+  GHC.Real.rem :: x:a -> y:{v:a | v /= 0} -> {v:a | ((v >= 0) && (v < y))}   GHC.Real.mod :: x:a -> y:{v:a | v /= 0} -> {v:a | v = x mod y && ((0 <= x && 0 < y) => (0 <= v && v < y))}   GHC.Real.div :: x:a -> y:{v:a | v /= 0} -> {v:a | (v = (x / y)) &&                                                     ((x >= 0 && y >= 0) => v >= 0) &&@@ -18,7 +20,11 @@                                                           ((x >= 0 && y >= 0) => v >= 0) &&                                                           ((x >= 0 && y >= 1) => v <= x)}                                                  , {v:a | ((v >= 0) && (v < y))})-  GHC.Real.divMod :: a -> {v:a | v /= 0} -> (a, a)+  GHC.Real.divMod :: x:a -> y:{v:a | v /= 0} -> ( {v:a | (v = (x / y)) &&+                                                         ((x >= 0 && y >= 0) => v >= 0) &&+                                                         ((x >= 0 && y >= 1) => v <= x) }+                                                , {v:a | v = x mod y && ((0 <= x && 0 < y) => (0 <= v && v < y))}+                                                )   GHC.Real.toInteger :: x:a -> {v:GHC.Integer.Type.Integer | v = x}  // fixpoint can't handle (x mod y), only (x mod c) so we need to be more clever here
include/GHC/Types.spec view
@@ -18,6 +18,7 @@ GHC.Types.isTrue#  :: n:_ -> {v:GHC.Types.Bool | ((n = 1) <=> (Prop(v)))}  +GHC.Types.W# :: w:_ -> {v:GHC.Types.Word | v == w }
include/Language/Haskell/Liquid/Foreign.hs view
@@ -11,7 +11,7 @@ import GHC.Base  -- TODO: shouldn't have to re-import these (tests/pos/imp0.hs)-{- import Foreign.C.Types    -}    +{- import Foreign.C.Types    -} {- import Foreign.Ptr        -} {- import Foreign.ForeignPtr -} {- import GHC.Base           -}@@ -23,17 +23,17 @@ {-# NOINLINE intCSize #-} {-@ assume intCSize :: x:Int -> {v: CSize | v = x } @-} intCSize :: Int -> CSize-intCSize = fromIntegral +intCSize = fromIntegral  {-# NOINLINE cSizeInt #-} {-@ assume cSizeInt :: x:CSize -> {v: Int | v = x } @-} cSizeInt :: CSize -> Int-cSizeInt = fromIntegral +cSizeInt = fromIntegral   {-@ assume mkPtr :: x:GHC.Prim.Addr# -> {v: (Ptr b) | ((plen v) = (addrLen x) && ((plen v) >= 0)) } @-} mkPtr   :: Addr# -> Ptr b-mkPtr = undefined -- Ptr x +mkPtr = undefined -- Ptr x   {-@ isNullPtr :: p:(Ptr a) -> {v:Bool | ((Prop v) <=> (isNullPtr p)) } @-}
include/Language/Haskell/Liquid/List.hs view
@@ -4,5 +4,3 @@ transpose _ []             = [] transpose n ([]   : xss)   = transpose n xss transpose n ((x:xs) : xss) = (x : [h | (h:_) <- xss]) : transpose (n - 1) (xs : [ t | (_:t) <- xss])--
include/Prelude.hquals view
@@ -32,11 +32,11 @@ qualif False1(v:GHC.Types.Bool)  : (~ Prop(v))  -qualif Papp(v:a,p:Pred a) : (papp1(p, v)) constant papp1 : func(1, [Pred @(0); @(0); bool])+qualif Papp(v:a,p:Pred a) : (papp1(p, v)) -qualif Papp2(v:a,x:b,p:Pred a b) : (papp2(p, v, x)) constant papp2 : func(4, [Pred @(0) @(1); @(2); @(3); bool])+qualif Papp2(v:a,x:b,p:Pred a b) : (papp2(p, v, x))  qualif Papp3(v:a,x:b, y:c, p:Pred a b c) : (papp3(p, v, x, y)) constant papp3 : func(6, [Pred @(0) @(1) @(2); @(3); @(4); @(5); bool])@@ -46,3 +46,7 @@   constant Prop : func(0, [GHC.Types.Bool; bool])+constant runFun : func(2, [Arrow @(0) @(1); @(0); @(1)])+++
liquidhaskell.cabal view
@@ -1,8 +1,8 @@ Name:                liquidhaskell-Version:             0.5.0.1+Version:             0.6.0.0 Copyright:           2010-15 Ranjit Jhala, University of California, San Diego. build-type:          Simple-Synopsis:            Liquid Types for Haskell +Synopsis:            Liquid Types for Haskell Description:         Liquid Types for Haskell. Homepage:            http://goto.ucsd.edu/liquidhaskell License:             BSD3@@ -13,6 +13,7 @@ Build-Type:          Simple Cabal-version:       >=1.18 + data-files: include/*.hquals           , include/*.hs           , include/*.spec@@ -32,7 +33,6 @@           , include/Language/Haskell/Liquid/*.hs           , include/Language/Haskell/Liquid/*.pred           , include/System/*.spec-          , include/708/Control/*.spec           , include/710/Data/*.spec           , syntax/liquid.css @@ -47,6 +47,11 @@   Type:        git   Location:    https://github.com/ucsd-progsys/liquidhaskell/ +Flag devel+  Description: turn on stricter error reporting for development+  Default:     False+  Manual:      True+ Flag include   Description: use in-tree include directory   Default:     False@@ -55,199 +60,171 @@   default-language: Haskell98   Build-Depends: base >= 4 && < 5                , ghc-               , ansi-terminal-               , template-haskell-               , time-               , array-               , hpc-               , bifunctors                , cmdargs-               , containers-               , cpphs-               , data-default                , deepseq-               , directory-               , Diff-               , filemanip-               , filepath-               , ghc-paths-               , hscolour-               , mtl-               , parsec                , pretty                , process-               , syb-               , text-               , vector                , liquid-fixpoint-               , hashable-               , unordered-containers-               , aeson-               , bytestring-               , fingertree+               , located-base+               -- , prover                , liquidhaskell -  Main-is: Liquid.hs-  ghc-options: -W  -fno-warn-unused-imports -fno-warn-dodgy-imports -fno-warn-deprecated-flags -fno-warn-deprecations+  Main-is: src/Liquid.hs+  ghc-options: -W -threaded+  if flag(devel)+    ghc-options: -Werror   Default-Extensions: PatternGuards --- Executable liquid-count-binders---   Build-Depends: base >= 4 && < 5---                , ghc==7.6.3---                , ansi-terminal---                , bifunctors---                , cmdargs---                , containers---                , cpphs---                , deepseq---                , directory---                , Diff---                , filemanip---                , filepath---                , ghc-paths---                , hscolour---                , mtl---                , parsec---                , pretty---                , process---                , syb---                , text---                , vector---                , liquid-fixpoint---                , hashable---                , unordered-containers---                , aeson---                , bytestring---                , fingertree---                , liquidhaskell---                ---   Main-is: CountBinders.hs---   --ghc-options: -O -W---   Extensions: PatternGuards-+Executable lhi+  default-language: Haskell98+  Build-Depends: base >= 4 && < 5+               , ghc+               , cmdargs+               , deepseq+               , pretty+               , liquid-fixpoint+               , located-base+               -- , prover+               , liquidhaskell+               , network+               , directory+               , unix+               , daemons+               , bytestring+               , data-default+               , unordered-containers+               , cereal+               , process+  Main-is: src/LHi.hs+  ghc-options: -W -threaded+  if flag(devel)+    ghc-options: -Werror+  Default-Extensions: PatternGuards  Library    Default-Language: Haskell98-   Build-Depends: base-                , ghc == 7.8.3 || == 7.8.4 || == 7.10.2-                , ansi-terminal-                , template-haskell-                , time-                , array-                , hpc-                , bifunctors-                , cmdargs-                , containers-                , cpphs-                , data-default-                , deepseq-                , directory-                , Diff-                , filemanip-                , filepath-                , ghc-paths-                , hscolour-                , mtl-                , parsec-                , pretty+   Build-Depends: base >= 4 && < 5+                , ghc >= 7.10.2 && < 7.11+                , template-haskell >= 2.9+                , time >= 1.4+                , array >= 0.5+                , hpc >= 0.6+                , cmdargs >= 0.10+                , containers >= 0.5+                , cpphs >= 1.19+                , data-default >= 0.5+                , deepseq >= 1.3+                , directory >= 1.2+                , Diff >= 0.3+                , filepath >= 1.3+                , ghc-paths >= 0.1+                , hscolour >= 1.22+                , mtl >= 2.1+                , parsec >= 3.1+                , pretty >= 1.1                 , process >= 1.2-                , syb-                , text-                , intern-                , vector-                , hashable-                , unordered-containers-                , liquid-fixpoint >= 0.4-                , aeson-                , bytestring-                , fingertree+                , syb >= 0.4.4+                , text >= 1.2+                , vector >= 0.10+                , hashable >= 1.2+                , unordered-containers >= 0.2+                , liquid-fixpoint >= 0.5 && < 0.6+                , located-base+                -- , prover+                , aeson >= 0.10+                , bytestring >= 0.10+                , fingertree >= 0.1                 , Cabal >= 1.18- +                , bifunctors >= 5.1+                , cereal+                , temporary >= 1.2+    hs-source-dirs:  src, include- +    Exposed-Modules: Language.Haskell.Liquid.Prelude,-                    Language.Haskell.Liquid.Foreign, -                    Language.Haskell.Liquid.List, -                    Language.Haskell.Liquid.PrettyPrint, +                    Language.Haskell.Liquid.Foreign,+                    Language.Haskell.Liquid.List,                     Language.Haskell.Liquid.Bare,-                    Language.Haskell.Liquid.Constraint.Constraint, -                    Language.Haskell.Liquid.Constraint.Types, -                    Language.Haskell.Liquid.Constraint.Generate, -                    Language.Haskell.Liquid.Constraint.ToFixpoint, -                    Language.Haskell.Liquid.Measure, -                    Language.Haskell.Liquid.Parse, -                    Language.Haskell.Liquid.GhcInterface, -                    Language.Haskell.Liquid.World, -                    Language.Haskell.Liquid.RefType, -                    Language.Haskell.Liquid.RefSplit, -                    Language.Haskell.Liquid.Errors, -                    Language.Haskell.Liquid.PredType, -                    Language.Haskell.Liquid.ACSS, -                    Language.Haskell.Liquid.DiffCheck, -                    Language.Haskell.Liquid.ANFTransform, -                    Language.Haskell.Liquid.Annotate, -                    Language.Haskell.Liquid.CTags,-                    Language.Haskell.Liquid.CmdLine, -                    Language.Haskell.Liquid.Cabal, -                    Language.Haskell.Liquid.GhcMisc, -                    Language.Haskell.Liquid.GhcPlay, -                    Language.Haskell.Liquid.Misc, -                    Language.Haskell.Liquid.CoreToLogic,-                    Language.Haskell.Liquid.Variance,-                    Language.Haskell.Liquid.Bounds,-                    Language.Haskell.Liquid.Dictionaries,-                    Language.Haskell.Liquid.Qualifier, -                    Language.Haskell.Liquid.TransformRec, -                    Language.Haskell.Liquid.Tidy, +                    Language.Haskell.Liquid.Constraint.Constraint,+                    Language.Haskell.Liquid.Constraint.Monad,+                    Language.Haskell.Liquid.Constraint.Env,+                    Language.Haskell.Liquid.Constraint.Types,+                    Language.Haskell.Liquid.Constraint.Split,+                    Language.Haskell.Liquid.Constraint.Axioms,+                    Language.Haskell.Liquid.Constraint.ProofToCore,+                    Language.Haskell.Liquid.Constraint.Generate,+                    Language.Haskell.Liquid.Constraint.ToFixpoint,+                    Language.Haskell.Liquid.Measure,+                    Language.Haskell.Liquid.Parse,+                    Language.Haskell.Liquid.GHC.Interface,+                    Language.Haskell.Liquid.GHC.SpanStack,+                    Language.Haskell.Liquid.Types.RefType,+                    Language.Haskell.Liquid.Types.Errors,+                    Language.Haskell.Liquid.Types.PrettyPrint,+                    Language.Haskell.Liquid.Types.Specifications,+                    Language.Haskell.Liquid.Types.PredType,+                    Language.Haskell.Liquid.Types.Meet,+                    Language.Haskell.Liquid.UX.ACSS,+                    Language.Haskell.Liquid.UX.DiffCheck,+                    Language.Haskell.Liquid.Transforms.ANF,+                    Language.Haskell.Liquid.Transforms.RefSplit,+                    Language.Haskell.Liquid.Transforms.CoreToLogic,+                    Language.Haskell.Liquid.Transforms.Rec,+                    Language.Haskell.Liquid.Transforms.Simplify,+                    Language.Haskell.Liquid.UX.Errors,+                    Language.Haskell.Liquid.UX.Annotate,+                    Language.Haskell.Liquid.UX.CTags,+                    Language.Haskell.Liquid.UX.Config,+                    Language.Haskell.Liquid.UX.CmdLine,+                    Language.Haskell.Liquid.GHC.Misc,+                    Language.Haskell.Liquid.GHC.Play,+                    Language.Haskell.Liquid.Misc,+                    Language.Haskell.Liquid.Types.Variance,+                    Language.Haskell.Liquid.Types.Bounds,+                    Language.Haskell.Liquid.Types.Dictionaries,+                    Language.Haskell.Liquid.Constraint.Qualifier,+                    Language.Haskell.Liquid.UX.Tidy,                     Language.Haskell.Liquid.Types,-                    Language.Haskell.Liquid.Simplify,-                    Language.Haskell.Liquid.Literals,-                    Language.Haskell.Liquid.Strata,-                    Language.Haskell.Liquid.Fresh,-                    Language.Haskell.Liquid.Visitors,+                    Language.Haskell.Liquid.Types.Literals,+                    Language.Haskell.Liquid.Types.Strata,+                    Language.Haskell.Liquid.Constraint.Fresh,+                    Language.Haskell.Liquid.Types.Visitors,                     Language.Haskell.Liquid.WiredIn,-                    Language.Haskell.Liquid.Names,+                    Language.Haskell.Liquid.Types.Names,+                    Language.Haskell.Liquid.Liquid,                     Paths_liquidhaskell,                      -- FIXME: These shouldn't really be exposed, but the linker complains otherwise...-                    Language.Haskell.Liquid.Bare.RefToLogic-                    Language.Haskell.Liquid.Bare.Check-                    Language.Haskell.Liquid.Bare.DataType-                    Language.Haskell.Liquid.Bare.Env-                    Language.Haskell.Liquid.Bare.Expand-                    Language.Haskell.Liquid.Bare.Existential-                    Language.Haskell.Liquid.Bare.GhcSpec-                    Language.Haskell.Liquid.Bare.Lookup-                    Language.Haskell.Liquid.Bare.Measure-                    Language.Haskell.Liquid.Bare.Misc-                    Language.Haskell.Liquid.Bare.OfType-                    Language.Haskell.Liquid.Bare.Plugged-                    Language.Haskell.Liquid.Bare.Resolve-                    Language.Haskell.Liquid.Bare.RTEnv-                    Language.Haskell.Liquid.Bare.SymSort-                    Language.Haskell.Liquid.Bare.Spec+                    Language.Haskell.Liquid.Bare.RefToLogic,+                    Language.Haskell.Liquid.Bare.Check,+                    Language.Haskell.Liquid.Bare.DataType,+                    Language.Haskell.Liquid.Bare.Env,+                    Language.Haskell.Liquid.Bare.Expand,+                    Language.Haskell.Liquid.Bare.Existential,+                    Language.Haskell.Liquid.Bare.GhcSpec,+                    Language.Haskell.Liquid.Bare.Lookup,+                    Language.Haskell.Liquid.Bare.Axiom,+                    Language.Haskell.Liquid.Bare.Measure,+                    Language.Haskell.Liquid.Bare.Misc,+                    Language.Haskell.Liquid.Bare.OfType,+                    Language.Haskell.Liquid.Bare.Plugged,+                    Language.Haskell.Liquid.Bare.Resolve,+                    Language.Haskell.Liquid.Bare.RTEnv,+                    Language.Haskell.Liquid.Bare.SymSort,+                    Language.Haskell.Liquid.Bare.Spec,+                    Language.Haskell.Liquid.Interactive.Types,+                    Language.Haskell.Liquid.Interactive.Handler, -   if impl(ghc < 7.10)-     exposed-modules:-                    --NOTE: these need to be exposed so GHC generates .dyn_o files for them..-                    Language.Haskell.Liquid.Desugar.Check,-                    Language.Haskell.Liquid.Desugar.Coverage,-                    Language.Haskell.Liquid.Desugar.Desugar,-                    Language.Haskell.Liquid.Desugar.DsArrows,-                    Language.Haskell.Liquid.Desugar.DsBinds,-                    Language.Haskell.Liquid.Desugar.DsExpr,-                    Language.Haskell.Liquid.Desugar.DsForeign,-                    Language.Haskell.Liquid.Desugar.DsGRHSs,-                    Language.Haskell.Liquid.Desugar.DsListComp,-                    Language.Haskell.Liquid.Desugar.DsMeta,-                    Language.Haskell.Liquid.Desugar.DsUtils,-                    Language.Haskell.Liquid.Desugar.HscMain,-                    Language.Haskell.Liquid.Desugar.Match,-                    Language.Haskell.Liquid.Desugar.MatchCon,-                    Language.Haskell.Liquid.Desugar.MatchLit-   else-     exposed-modules:-                    --NOTE: these need to be exposed so GHC generates .dyn_o files for them..+                    Language.Haskell.Liquid.Prover.Constants,+                    Language.Haskell.Liquid.Prover.Misc,+                    Language.Haskell.Liquid.Prover.Parser,+                    Language.Haskell.Liquid.Prover.Pretty,+                    Language.Haskell.Liquid.Prover.SMTInterface,+                    Language.Haskell.Liquid.Prover.Solve,+                    Language.Haskell.Liquid.Prover.Types,+                    Language.Haskell.Liquid.Prover.Names,++                    -- NOTE: these need to be exposed so GHC generates .dyn_o files for them..                     Language.Haskell.Liquid.Desugar710.Check,                     Language.Haskell.Liquid.Desugar710.Coverage,                     Language.Haskell.Liquid.Desugar710.Desugar,@@ -264,28 +241,33 @@                     Language.Haskell.Liquid.Desugar710.Match,                     Language.Haskell.Liquid.Desugar710.MatchCon,                     Language.Haskell.Liquid.Desugar710.MatchLit-   ghc-options: -W -fno-warn-unused-imports -fno-warn-dodgy-imports -fno-warn-deprecated-flags -fno-warn-deprecations+   ghc-options: -W    if flag(include)      hs-source-dirs: devel+   if flag(devel)+     ghc-options: -Werror+     ghc-prof-options: -fprof-auto    Default-Extensions: PatternGuards  test-suite test   default-language: Haskell98   type:              exitcode-stdio-1.0   hs-source-dirs:    tests-  ghc-options:       -O2 -threaded+  ghc-options:       -W -threaded+  if flag(devel)+    ghc-options: -Werror   main-is:           test.hs-  build-depends:     base,-                     liquidhaskell,-                     containers,-                     directory,-                     filepath,-                     mtl,-                     process,-                     optparse-applicative == 0.11.*,-                     stm,-                     tagged,-                     tasty >= 0.10,-                     tasty-hunit >= 0.9,-                     tasty-rerun >= 1.1,-                     transformers+  build-depends:     base  >= 4 && < 5+               ,     containers >= 0.5+               ,     directory >= 1.2+               ,     filepath >= 1.3+               ,     mtl >= 2.1+               ,     process >= 1.2+               ,     optparse-applicative >= 0.11+               ,     stm >= 2.4+               ,     tagged >= 0.7.3+               ,     tasty >= 0.10+               ,     tasty-ant-xml+               ,     tasty-hunit >= 0.9+               ,     tasty-rerun >= 1.1+               ,     transformers >= 0.3
+ src/LHi.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++import           System.Environment      (getArgs)+import           System.Daemon+import           Control.Concurrent.MVar ( newMVar )+import           Data.Default ( def )+import           Language.Haskell.Liquid.Interactive.Types+import qualified Language.Haskell.Liquid.Interactive.Handler as H+import           Language.Haskell.Liquid.UX.CmdLine (getOpts)+import           Language.Haskell.Liquid.UX.Config  (port)++daemonName :: String+daemonName = "lhi0"++main :: IO ()+main = do+  st  <- newMVar H.initial+  cmd <- command+  ensureDaemonRunning daemonName (options cmd) (H.handler st)+  res <- client cmd+  print res++options :: Command -> DaemonOptions+options cmd = def { daemonPort = port cmd }++client :: Command -> IO (Maybe Response)+client cmd = runClient "localhost" (port cmd) cmd++---------------------------------------------------------------------------------+-- | Parsing Command Line -------------------------------------------------------+---------------------------------------------------------------------------------+command :: IO Command+-------------------------------------------------------------------------------+command = getOpts =<< getArgs
− src/Language/Haskell/Liquid/ACSS.hs 
@@ -1,264 +0,0 @@--- | Formats Haskell source code as HTML with CSS and Mouseover Type Annotations-module Language.Haskell.Liquid.ACSS (-    hscolour-  , hsannot-  , AnnMap (..)-  , breakS-  , srcModuleName-  , Status (..)-  ) where--import Language.Haskell.HsColour.Anchors-import Language.Haskell.HsColour.Classify as Classify-import Language.Haskell.HsColour.HTML (renderAnchors, escape)-import qualified Language.Haskell.HsColour.CSS as CSS--import Data.Either (partitionEithers)-import Data.Maybe  (fromMaybe)-import qualified Data.HashMap.Strict as M-import Data.List   (find, isPrefixOf, findIndex, elemIndices, intercalate)-import Data.Char   (isSpace)-import Text.Printf-import Language.Haskell.Liquid.GhcMisc--data AnnMap  = Ann {-    types  :: M.HashMap Loc (String, String) -- ^ Loc -> (Var, Type)-  , errors :: [(Loc, Loc, String)]           -- ^ List of error intervals-  , status :: !Status-  }--data Status = Safe | Unsafe | Error | Crash-              deriving (Eq, Ord, Show)--data Annotation = A {-    typ :: Maybe String         -- ^ type  string-  , err :: Maybe String         -- ^ error string-  , lin :: Maybe (Int, Int)     -- ^ line number, total width of lines i.e. max (length (show lineNum))-  } deriving (Show)----- | Formats Haskell source code using HTML and mouse-over annotations-hscolour :: Bool     -- ^ Whether to include anchors.-         -> Bool     -- ^ Whether input document is literate haskell or not-         -> String   -- ^ Haskell source code, Annotations as comments at end-         -> String   -- ^ Coloured Haskell source code.--hscolour anchor lhs = hsannot anchor Nothing lhs . splitSrcAndAnns--type CommentTransform = Maybe (String -> [(TokenType, String)])---- | Formats Haskell source code using HTML and mouse-over annotations-hsannot  :: Bool             -- ^ Whether to include anchors.-         -> CommentTransform -- ^ Function to refine comment tokens-         -> Bool             -- ^ Whether input document is literate haskell or not-         -> (String, AnnMap) -- ^ Haskell Source, Annotations-         -> String           -- ^ Coloured Haskell source code.--hsannot anchor tx False z     = hsannot' Nothing anchor tx z-hsannot anchor tx True (s, m) = concatMap chunk $ litSpans $ joinL $ classify $ inlines s-  where chunk (Code c, l)     = hsannot' (Just l) anchor tx (c, m)-        chunk (Lit c , _)     = c--litSpans :: [Lit] -> [(Lit, Loc)]-litSpans lits = zip lits $ spans lits-  where spans = tokenSpans Nothing . map unL--hsannot' baseLoc anchor tx =-    CSS.pre-    . (if anchor then concatMap (renderAnchors renderAnnotToken)-                      . insertAnnotAnchors-                 else concatMap renderAnnotToken)-    . annotTokenise baseLoc tx---- | annotTokenise is absurdly slow: O(#tokens x #errors)--annotTokenise :: Maybe Loc -> CommentTransform -> (String, AnnMap) -> [(TokenType, String, Annotation)]-annotTokenise baseLoc tx (src, annm) = zipWith (\(x,y) z -> (x,y,z)) toks annots-  where-    toks       = tokeniseWithCommentTransform tx src-    spans      = tokenSpans baseLoc $ map snd toks-    annots     = fmap (spanAnnot linWidth annm) spans-    linWidth   = length $ show $ length $ lines src--spanAnnot 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]-    b = spanLine w span--spanLine w (L (l, c))-  | c == 1    = Just (l, w)-  | otherwise = Nothing--inRange (L (l0, c0)) (L (l, c), L (l', c'))-  = l <= l0 && c <= c0 && l0 <= l' && c0 < c'--tokeniseWithCommentTransform :: Maybe (String -> [(TokenType, String)]) -> String -> [(TokenType, String)]-tokeniseWithCommentTransform Nothing  = tokenise-tokeniseWithCommentTransform (Just f) = concatMap (expand f) . tokenise-  where expand f (Comment, s) = f s-        expand _ z            = [z]--tokenSpans :: Maybe Loc -> [String] -> [Loc]-tokenSpans = scanl plusLoc . fromMaybe (L (1, 1))--plusLoc :: Loc -> String -> Loc-plusLoc (L (l, c)) s-  = case '\n' `elemIndices` s of-      [] -> L (l, (c + n))-      is -> L ((l + length is), (n - maximum is))-    where n = length s--renderAnnotToken :: (TokenType, String, Annotation) -> String-renderAnnotToken (x, y, a)  = renderLinAnnot (lin a)-                            $ renderErrAnnot (err a)-                            $ renderTypAnnot (typ a)-                            $ CSS.renderToken (x, y)----renderTypAnnot (Just ann) s = printf "<a class=annot href=\"#\"><span class=annottext>%s</span>%s</a>" (escape ann) s-renderTypAnnot Nothing    s = s--renderErrAnnot (Just _) s   = printf "<span class=hs-error>%s</span>" s-renderErrAnnot Nothing  s   = s--renderLinAnnot (Just d) s   = printf "<span class=hs-linenum>%s: </span>%s" (lineString d) s-renderLinAnnot Nothing  s   = s--lineString (i, w) = (replicate (w - (length is)) ' ') ++ is-  where is        = show i--{- Example Annotation:-<a class=annot href="#"><span class=annottext>x#agV:Int -&gt; {VV_int:Int | (0 &lt;= VV_int),(x#agV &lt;= VV_int)}</span>-<span class='hs-definition'>NOWTRYTHIS</span></a>--}---insertAnnotAnchors :: [(TokenType, String, a)] -> [Either String (TokenType, String, a)]-insertAnnotAnchors toks-  = stitch (zip toks' toks) $ insertAnchors toks'-  where toks' = [(x,y) | (x,y,_) <- toks]--stitch ::  Eq b => [(b, c)] -> [Either a b] -> [Either a c]-stitch xys ((Left a) : rest)-  = (Left a) : stitch xys rest-stitch ((x,y):xys) ((Right x'):rest)-  | x == x'-  = (Right y) : stitch xys rest-  | otherwise-  = error "stitch"-stitch _ []-  = []-stitch _ _-  = error "stitch: cannot happen"--splitSrcAndAnns ::  String -> (String, AnnMap)-splitSrcAndAnns s =-  let ls = lines s in-  case findIndex (breakS ==) ls of-    Nothing -> (s, Ann M.empty [] Safe)-    Just i  -> (src, ann)-               where (codes, _:mname:annots) = splitAt i ls-                     ann   = annotParse mname $ dropWhile isSpace $ unlines annots-                     src   = unlines codes--srcModuleName :: String -> String-srcModuleName = fromMaybe "Main" . tokenModule . tokenise--tokenModule toks-  = do i <- findIndex ((Keyword, "module") ==) toks-       let (_, toks')  = splitAt (i+2) toks-       j <- findIndex ((Space ==) . fst) toks'-       let (toks'', _) = splitAt j toks'-       return $ concatMap snd toks''--breakS = "MOUSEOVER ANNOTATIONS"--annotParse :: String -> String -> AnnMap-annotParse mname s = Ann (M.fromList ts) [(x,y,"") | (x,y) <- es] Safe-  where-    (ts, es)       = partitionEithers $ parseLines mname 0 $ lines s---parseLines _ _ []-  = []--parseLines mname i ("":ls)-  = parseLines mname (i+1) ls--parseLines mname i (_:_:l:c:"0":l':c':rest')-  = Right (L (line, col), L (line', col')) : parseLines mname (i + 7) rest'-    where line  = (read l)  :: Int-          col   = (read c)  :: Int-          line' = (read l') :: Int-          col'  = (read c') :: Int--parseLines mname i (x:f:l:c:n:rest)-  | f /= mname-  = parseLines mname (i + 5 + num) rest'-  | otherwise-  = Left (L (line, col), (x, anns)) : parseLines mname (i + 5 + num) rest'-    where line  = (read l) :: Int-          col   = (read c) :: Int-          num   = (read n) :: Int-          anns  = intercalate "\n" $ take num rest-          rest' = drop num rest--parseLines _ i _-  = error $ "Error Parsing Annot Input on Line: " ++ show i--instance Show AnnMap where-  show (Ann ts es _ ) =  "\n\n" ++ (concatMap ppAnnotTyp $ M.toList ts)-                                ++ (concatMap ppAnnotErr [(x,y) | (x,y,_) <- es])--ppAnnotTyp (L (l, c), (x, s))     = printf "%s\n%d\n%d\n%d\n%s\n\n\n" x l c (length $ lines s) s-ppAnnotErr (L (l, c), L (l', c')) = printf " \n%d\n%d\n0\n%d\n%d\n\n\n\n" l c l' c'----------------------------------------------------------------------------------------- Code for Dealing With LHS, stolen from Language.Haskell.HsColour.HsColour ---------------------------------------------------------------------------------------- | Separating literate files into code\/comment chunks.-data Lit = Code {unL :: String} | Lit {unL :: String} deriving (Show)---- Re-implementation of 'lines', for better efficiency (but decreased laziness).--- Also, importantly, accepts non-standard DOS and Mac line ending characters.--- And retains the trailing '\n' character in each resultant string.-inlines :: String -> [String]-inlines s = lines' s id-  where-  lines' []             acc = [acc []]-  lines' ('\^M':'\n':s) acc = acc ['\n'] : lines' s id  -- DOS-  lines' ('\n':s)       acc = acc ['\n'] : lines' s id  -- Unix-  lines' (c:s)          acc = lines' s (acc . (c:))----- | The code for classify is largely stolen from Language.Preprocessor.Unlit.-classify ::  [String] -> [Lit]-classify []             = []-classify (x:xs) | "\\begin{code}"`isPrefixOf`x-                        = Lit x: allProg "code" xs-classify (x:xs) | "\\begin{spec}"`isPrefixOf`x-                        = Lit x: allProg "spec" xs-classify (('>':x):xs)   = Code ('>':x) : classify xs-classify (x:xs)         = Lit x: classify xs---allProg name  = go-  where-    end       = "\\end{" ++ name ++ "}"-    go []     = []  -- Should give an error message,-                    -- but I have no good position information.-    go (x:xs) | end `isPrefixOf `x-              = Lit x: classify xs-    go (x:xs) = Code x: go xs----- | Join up chunks of code\/comment that are next to each other.-joinL :: [Lit] -> [Lit]-joinL []                  = []-joinL (Code c:Code c2:xs) = joinL (Code (c++c2):xs)-joinL (Lit c :Lit c2 :xs) = joinL (Lit  (c++c2):xs)-joinL (any:xs)            = any: joinL xs
− src/Language/Haskell/Liquid/ANFTransform.hs 
@@ -1,265 +0,0 @@-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE NoMonomorphismRestriction  #-}-{-# LANGUAGE TupleSections              #-}-{-# LANGUAGE TypeSynonymInstances       #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}---------------------------------------------------------------------------------------------------- Code to convert Core to Administrative Normal Form -------------------------------------------------------------------------------------------------------------module Language.Haskell.Liquid.ANFTransform (anormalize) where-import           CoreSyn-import           CoreUtils                        (exprType)-import qualified DsMonad-import           DsMonad                          (initDs)-import           GHC                              hiding (exprType)-import           HscTypes-import           Id                               (mkSysLocalM)-import           Literal-import           MkCore                           (mkCoreLets)-import           Outputable                       (trace)-import           Var                              (varType, setVarType)-import           TypeRep-import           Type                             (mkForAllTys, substTy, mkForAllTys, mkTopTvSubst, isTyVar)-import           TyCon                            (tyConDataCons_maybe)-import           DataCon                          (dataConInstArgTys)-import           FamInstEnv                       (emptyFamInstEnv)-import           VarEnv                           (VarEnv, emptyVarEnv, extendVarEnv, lookupWithDefaultVarEnv)-import           Control.Monad.State.Lazy-import           UniqSupply                       (MonadUnique)-import           Language.Fixpoint.Types (anfPrefix)-import           Language.Haskell.Liquid.GhcMisc  (MGIModGuts(..), showPpr, symbolFastString)-import           Language.Haskell.Liquid.TransformRec-import           Language.Fixpoint.Misc     (fst3, errorstar)-import           Data.Maybe                       (fromMaybe)-import           Data.List                        (sortBy, (\\))-import           Control.Applicative--anormalize :: Bool -> HscEnv -> MGIModGuts -> IO [CoreBind]-anormalize expandFlag hscEnv modGuts-  = do -- putStrLn "***************************** GHC CoreBinds ***************************" -       -- putStrLn $ showPpr orig_cbs-       liftM (fromMaybe err . snd) $ initDs hscEnv m grEnv tEnv emptyFamInstEnv act-    where m        = mgi_module modGuts-          grEnv    = mgi_rdr_env modGuts-          tEnv     = modGutsTypeEnv modGuts-          act      = liftM concat $ mapM (normalizeTopBind expandFlag emptyVarEnv) orig_cbs-          orig_cbs = transformRecExpr $ mgi_binds modGuts-          err      = errorstar "anormalize fails!"--modGutsTypeEnv mg = typeEnvFromEntities ids tcs fis-  where ids = bindersOfBinds (mgi_binds mg)-        tcs = mgi_tcs mg-        fis = mgi_fam_insts mg-------------------------------------------------------------------------------------- Actual Normalizing Functions ------------------------------------------------------------------------------------------ Can't make the below default for normalizeBind as it --- fails tests/pos/lets.hs due to GHCs odd let-bindings--normalizeTopBind :: Bool -> VarEnv Id -> Bind CoreBndr -> DsMonad.DsM [CoreBind]-normalizeTopBind expandFlag γ (NonRec x e)-  = do e' <- runDsM $ evalStateT (stitch γ e) (DsST expandFlag  [])-       return [normalizeTyVars $ NonRec x e']--normalizeTopBind expandFlag γ (Rec xes)-  = do xes' <- runDsM $ execStateT (normalizeBind γ (Rec xes)) (DsST expandFlag [])-       return $ map normalizeTyVars (st_binds xes')--normalizeTyVars (NonRec x e) = NonRec (setVarType x t') $ normalizeForAllTys e-  where t'       = subst msg as as' bt-        msg      = "WARNING unable to renameVars on " ++ showPpr x-        as'      = fst $ splitForAllTys $ exprType e-        (as, bt) = splitForAllTys (varType x)-normalizeTyVars (Rec xes)    = Rec xes'-  where nrec = normalizeTyVars <$> ((\(x, e) -> NonRec x e) <$> xes)-        xes' = (\(NonRec x e) -> (x, e)) <$> nrec--subst msg as as' bt-  | length as == length as'-  = mkForAllTys as' $ substTy su bt-  | otherwise-  = trace msg $ mkForAllTys as bt-  where su = mkTopTvSubst $ zip as (mkTyVarTys as')---- | eta-expand CoreBinds with quantified types-normalizeForAllTys :: CoreExpr -> CoreExpr-normalizeForAllTys e = case e of-  Lam b _ | isTyVar b-    -> e-  _ -> mkLams tvs (mkTyApps e (map mkTyVarTy tvs))-  where-  (tvs, _) = splitForAllTys (exprType e)---newtype DsM a = DsM {runDsM :: DsMonad.DsM a}-   deriving (Functor, Monad, MonadUnique, Applicative)--data DsST = DsST { st_expandflag :: Bool-                 , st_binds      :: [CoreBind]-                 }--type DsMW = StateT DsST DsM---------------------------------------------------------------------normalizeBind :: VarEnv Id -> CoreBind -> DsMW ()---------------------------------------------------------------------normalizeBind γ (NonRec x e)-   = do e' <- normalize γ e-        add [NonRec x e']--normalizeBind γ (Rec xes)-  = do es' <- mapM (stitch γ) es-       add [Rec (zip xs es')]-    where (xs, es) = unzip xes-----------------------------------------------------------------------normalizeName :: VarEnv Id -> CoreExpr -> DsMW CoreExpr------------------------------------------------------------------------- normalizeNameDebug γ e ---   = liftM (tracePpr ("normalizeName" ++ showPpr e)) $ normalizeName γ e--normalizeName _ e@(Lit l)-  | shouldNormalize l-  = normalizeLiteral e-  | otherwise-  = return e--normalizeName γ (Var x)-  = return $ Var (lookupWithDefaultVarEnv γ x x)--normalizeName _ e@(Type _)-  = return e--normalizeName _ e@(Coercion _)-  = do x     <- lift $ freshNormalVar $ exprType e-       add  [NonRec x e]-       return $ Var x--normalizeName γ (Tick n e)-  = do e'    <- normalizeName γ e-       return $ Tick n e'--normalizeName γ e-  = do e'   <- normalize γ e-       x    <- lift $ freshNormalVar $ exprType e-       add [NonRec x e']-       return $ Var x--shouldNormalize l = case l of-  LitInteger _ _ -> True-  MachStr _ -> True-  _ -> False--add :: [CoreBind] -> DsMW ()-add w = modify $ \s -> s{st_binds = st_binds s++w}------------------------------------------------------------------------normalizeLiteral :: CoreExpr -> DsMW CoreExpr------------------------------------------------------------------------normalizeLiteral e =-  do x <- lift $ freshNormalVar (exprType e)-     add [NonRec x e]-     return $ Var x--freshNormalVar :: Type -> DsM Id-freshNormalVar = mkSysLocalM (symbolFastString anfPrefix)------------------------------------------------------------------------normalize :: VarEnv Id -> CoreExpr -> DsMW CoreExpr------------------------------------------------------------------------normalize γ (Lam x e)-  = do e' <- stitch γ e-       return $ Lam x e'--normalize γ (Let b e)-  = do normalizeBind γ b-       normalize γ e-       -- Need to float bindings all the way up to the top -       -- Due to GHCs odd let-bindings (see tests/pos/lets.hs) --normalize γ (Case e x t as)-  = do n     <- normalizeName γ e-       x'    <- lift $ freshNormalVar τx -- rename "wild" to avoid shadowing-       let γ' = extendVarEnv γ x x'-       as'   <- forM as $ \(c, xs, e') -> liftM (c, xs,) (stitch γ' e')-       flag  <- st_expandflag <$> get-       as''  <- lift $ expandDefaultCase flag τx as' -       return $ Case n x' t as''-    where τx = varType x--normalize γ (Var x)-  = return $ Var (lookupWithDefaultVarEnv γ x x)--normalize _ e@(Lit _)-  = return e--normalize _ e@(Type _)-  = return e--normalize γ (Cast e τ)-  = do e'    <- normalizeName γ e-       return $ Cast e' τ--normalize γ (App e1 e2)-  = do e1' <- normalize γ e1-       n2  <- normalizeName γ e2-       return $ App e1' n2--normalize γ (Tick n e)-  = do e' <- normalize γ e-       return $ Tick n e'--normalize _ (Coercion c) -  = return $ Coercion c--stitch :: VarEnv Id -> CoreExpr -> DsMW CoreExpr -stitch γ e-  = do bs'   <- get-       modify $ \s -> s {st_binds = []}-       e'    <- normalize γ e-       bs    <- st_binds <$> get-       put bs'-       return $ mkCoreLets bs e'-------------------------------------------------------------------------------------expandDefaultCase :: Bool -> Type -> [(AltCon, [Id], CoreExpr)] -> DsM [(AltCon, [Id], CoreExpr)]-------------------------------------------------------------------------------------expandDefaultCase flag tyapp zs@((DEFAULT, _ ,_) : _) | flag-  = expandDefaultCase' tyapp zs--expandDefaultCase _    tyapp@(TyConApp tc _) z@((DEFAULT, _ ,_):dcs)-  = case tyConDataCons_maybe tc of-       Just ds -> do let ds' = ds \\ [ d | (DataAlt d, _ , _) <- dcs] -                     if (length ds') == 1 -                      then expandDefaultCase' tyapp z -                      else return z-       Nothing -> return z ----expandDefaultCase _ _ z-   = return z--expandDefaultCase' (TyConApp tc argτs) z@((DEFAULT, _ ,e) : dcs)-  = case tyConDataCons_maybe tc of-       Just ds -> do let ds' = ds \\ [ d | (DataAlt d, _ , _) <- dcs] -                     dcs'   <- forM ds' $ cloneCase argτs e-                     return $ sortCases $ dcs' ++ dcs-       Nothing -> return z ---expandDefaultCase' _ z-   = return z--cloneCase argτs e d -  = do xs  <- mapM freshNormalVar $ dataConInstArgTys d argτs-       return (DataAlt d, xs, e)--sortCases = sortBy (\x y -> cmpAltCon (fst3 x) (fst3 y))-
− src/Language/Haskell/Liquid/Annotate.hs 
@@ -1,425 +0,0 @@-{-# LANGUAGE FlexibleContexts         #-}-{-# LANGUAGE TupleSections              #-}-{-# LANGUAGE NoMonomorphismRestriction  #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE TypeSynonymInstances       #-}-{-# LANGUAGE FlexibleInstances          #-}-------------------------------------------------------------------------------- | This module contains the code that uses the inferred types to generate--- 1. HTMLized source with Inferred Types in mouseover annotations.--- 2. Annotations files (e.g. for vim/emacs)--- 3. JSON files for the web-demo etc.------------------------------------------------------------------------------module Language.Haskell.Liquid.Annotate (mkOutput, annotate) where--import           GHC                      ( SrcSpan (..)-                                          , srcSpanStartCol-                                          , srcSpanEndCol-                                          , srcSpanStartLine-                                          , srcSpanEndLine)-import           Text.PrettyPrint.HughesPJ hiding (first)-import           GHC.Exts                 (groupWith, sortWith)--import           Data.Char                (isSpace)-import           Data.Function            (on)-import           Data.List                (sortBy)-import           Data.Maybe               (mapMaybe)--import           Data.Aeson-import           Control.Arrow            hiding ((<+>))-import           Control.Applicative      ((<$>))-import           Control.Monad            (when, forM_)--import           System.FilePath          (takeFileName, dropFileName, (</>))-import           System.Directory         (findExecutable, copyFile)-import           Text.Printf              (printf)-import qualified Data.List              as L-import qualified Data.Vector            as V-import qualified Data.ByteString.Lazy   as B-import qualified Data.Text              as T-import qualified Data.HashMap.Strict    as M-import qualified Language.Haskell.Liquid.ACSS as ACSS-import           Language.Haskell.HsColour.Classify-import           Language.Fixpoint.Files-import           Language.Fixpoint.Names hiding (encode)-import           Language.Fixpoint.Misc-import           Language.Haskell.Liquid.GhcMisc-import           Language.Fixpoint.Types hiding (Def (..), Constant (..), Located (..))-import           Language.Haskell.Liquid.Misc-import           Language.Haskell.Liquid.PrettyPrint-import           Language.Haskell.Liquid.RefType-import           Language.Haskell.Liquid.Errors ()-import           Language.Haskell.Liquid.Tidy-import           Language.Haskell.Liquid.Types hiding (Located(..), Def(..))---- | @output@ creates the pretty printed output----------------------------------------------------------------------------------------------mkOutput :: Config -> FixResult Error -> FixSolution -> AnnInfo (Annot SpecType) -> Output Doc----------------------------------------------------------------------------------------------mkOutput cfg res sol anna-  = O { o_vars   = Nothing-      , o_errors = []-      , o_types  = toDoc <$> annTy-      , o_templs = toDoc <$> annTmpl-      , o_bots   = mkBots    annTy-      , o_result = res-      }-  where-    annTmpl      = closeAnnots anna-    annTy        = tidySpecType Lossy <$> applySolution sol annTmpl-    toDoc        = rtypeDoc tidy-    tidy         = if shortNames cfg then Lossy else Full---- | @annotate@ actually renders the output to files---------------------------------------------------------------------annotate :: Config -> FilePath -> Output Doc -> IO ()---------------------------------------------------------------------annotate cfg srcF out-  = do generateHtml srcF tpHtmlF tplAnnMap-       generateHtml srcF tyHtmlF typAnnMap-       writeFile         vimF  $ vimAnnot cfg annTyp-       B.writeFile       jsonF $ encode typAnnMap-       when showWarns $ forM_ bots (printf "WARNING: Found false in %s\n" . showPpr)-    where-       tplAnnMap  = mkAnnMap cfg result annTpl-       typAnnMap  = mkAnnMap cfg result annTyp-       annTpl     = o_templs out-       annTyp     = o_types  out-       result     = o_result out-       bots       = o_bots   out-       tyHtmlF    = extFileName Html                   srcF-       tpHtmlF    = extFileName Html $ extFileName Cst srcF-       _annF      = extFileName Annot srcF-       jsonF      = extFileName Json  srcF-       vimF       = extFileName Vim   srcF-       showWarns  = not $ nowarnings cfg--mkBots (AI m) = [ src | (src, (Just _, t) : _) <- sortBy (compare `on` fst) $ M.toList m-                      , isFalse (rTypeReft t) ]--writeFilesOrStrings :: FilePath -> [Either FilePath String] -> IO ()-writeFilesOrStrings tgtFile = mapM_ $ either (`copyFile` tgtFile) (tgtFile `appendFile`)--generateHtml srcF htmlF annm-  = do src     <- readFile srcF-       let lhs  = isExtFile LHs srcF-       let body = {-# SCC "hsannot" #-} ACSS.hsannot False (Just tokAnnot) lhs (src, annm)-       cssFile <- getCssPath-       copyFile cssFile (dropFileName htmlF </> takeFileName cssFile)-       renderHtml lhs htmlF srcF (takeFileName cssFile) body--renderHtml True  = renderPandoc-renderHtml False = renderDirect------------------------------------------------------------------------------ | Pandoc HTML Rendering (for lhs + markdown source) ----------------------------------------------------------------------------------------------renderPandoc htmlFile srcFile css body-  = do renderFn <- maybe renderDirect renderPandoc' <$> findExecutable "pandoc"-       renderFn htmlFile srcFile css body--renderPandoc' pandocPath htmlFile srcFile css body-  = do _  <- writeFile mdFile $ pandocPreProc body-       ec <- executeShellCommand "pandoc" cmd-       writeFilesOrStrings htmlFile [Right (cssHTML css)]-       checkExitCode cmd ec-    where mdFile = extFileName Mkdn srcFile-          cmd    = pandocCmd pandocPath mdFile htmlFile--pandocCmd pandocPath mdFile htmlFile-  = printf "%s -f markdown -t html %s > %s" pandocPath mdFile htmlFile--pandocPreProc  = T.unpack-               . strip beg code-               . strip end code-               . strip beg spec-               . strip end spec-               . T.pack-  where-    beg, end, code, spec :: String-    beg        = "begin"-    end        = "end"-    code       = "code"-    spec       = "spec"-    strip x y  = T.replace (T.pack $ printf "\\%s{%s}" x y) T.empty-    -- stripBcode = T.replace (T.pack "\\begin{code}") T.empty-    -- stripEcode = T.replace (T.pack "\\end{code}")   T.empty-    -- stripBspec = T.replace (T.pack "\\begin{code}") T.empty-    -- stripEspec = T.replace (T.pack "\\end{code}")   T.empty--------------------------------------------------------------------------------- | Direct HTML Rendering (for non-lhs/markdown source) ---------------------------------------------------------------------------------------------- More or less taken from hscolour--renderDirect htmlFile srcFile css body-  = writeFile htmlFile $! (top'n'tail full srcFile css $! body)-    where full = True -- False  -- TODO: command-line-option---- | @top'n'tail True@ is used for standalone HTML,---   @top'n'tail False@ for embedded HTML--top'n'tail True  title css = (htmlHeader title css ++) . (++ htmlClose)-top'n'tail False _    _    = id---- Use this for standalone HTML--htmlHeader title css = unlines-  [ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">"-  , "<html>"-  , "<head>"-  , "<title>" ++ title ++ "</title>"-  , "</head>"-  , cssHTML css-  , "<body>"-  , "<hr>"-  , "Put mouse over identifiers to see inferred types"-  ]--htmlClose  = "\n</body>\n</html>"--cssHTML css = unlines-  [ "<head>"-  , "<link type='text/css' rel='stylesheet' href='"++ css ++ "' />"-  , "</head>"-  ]----------------------------------------------------------------------------------- | Building Annotation Maps ----------------------------------------------------------------------------------------------------------------------------------- | This function converts our annotation information into that which---   is required by `Language.Haskell.Liquid.ACSS` to generate mouseover---   annotations.--mkAnnMap :: Config -> FixResult Error -> AnnInfo Doc -> ACSS.AnnMap-mkAnnMap cfg res ann     = ACSS.Ann (mkAnnMapTyp cfg ann) (mkAnnMapErr res) (mkStatus res)--mkStatus (Safe)          = ACSS.Safe-mkStatus (Unsafe _)      = ACSS.Unsafe-mkStatus (Crash _ _)     = ACSS.Error-mkStatus _               = ACSS.Crash--mkAnnMapErr (Unsafe ls)  = mapMaybe cinfoErr ls-mkAnnMapErr (Crash ls _) = mapMaybe cinfoErr ls-mkAnnMapErr _            = []--cinfoErr e = case pos e of-               RealSrcSpan l -> Just (srcSpanStartLoc l, srcSpanEndLoc l, showpp e)-               _             -> Nothing---- cinfoErr (Ci (RealSrcSpan l) e) =--- cinfoErr _                      = Nothing----- mkAnnMapTyp :: (RefTypable a c tv r, RefTypable a c tv (), PPrint tv, PPrint a) =>Config-> AnnInfo (RType a c tv r) -> M.HashMap Loc (String, String)-mkAnnMapTyp cfg z = M.fromList $ map (first srcSpanStartLoc) $ mkAnnMapBinders cfg z--mkAnnMapBinders cfg (AI m)-  = map (second bindStr . head . sortWith (srcSpanEndCol . fst))-  $ groupWith (lineCol . fst)-    [ (l, x) | (RealSrcSpan l, x:_) <- M.toList m, oneLine l]-  where-    bindStr (x, v) = (maybe "_" (symbolString . shorten . symbol) x, render v)-    shorten        = if shortNames cfg then dropModuleNames else id--closeAnnots :: AnnInfo (Annot SpecType) -> AnnInfo SpecType-closeAnnots = closeA . filterA . collapseA--closeA a@(AI m)   = cf <$> a-  where-    cf (AnnLoc l)  = case m `mlookup` l of-                      [(_, AnnUse t)] -> t-                      [(_, AnnDef t)] -> t-                      [(_, AnnRDf t)] -> t-                      _               -> errorstar $ "malformed AnnInfo: " ++ showPpr l-    cf (AnnUse t) = t-    cf (AnnDef t) = t-    cf (AnnRDf t) = t--filterA (AI m) = AI (M.filter ff m)-  where-    ff [(_, AnnLoc l)] = l `M.member` m-    ff _               = True--collapseA (AI m) = AI (fmap pickOneA m)--pickOneA xas = case (rs, ds, ls, us) of-                 (x:_, _, _, _) -> [x]-                 (_, x:_, _, _) -> [x]-                 (_, _, x:_, _) -> [x]-                 (_, _, _, x:_) -> [x]-                 (_, _, _, _  ) -> [ ]-  where-    rs = [x | x@(_, AnnRDf _) <- xas]-    ds = [x | x@(_, AnnDef _) <- xas]-    ls = [x | x@(_, AnnLoc _) <- xas]-    us = [x | x@(_, AnnUse _) <- xas]----------------------------------------------------------------------------------- | Tokenizing Refinement Type Annotations in @-blocks --------------------------------------------------------------------------------------------------------- | The token used for refinement symbols inside the highlighted types in @-blocks.-refToken = Keyword---- | The top-level function for tokenizing @-block annotations. Used to--- tokenize comments by ACSS.-tokAnnot s-  = case trimLiquidAnnot s of-      Just (l, body, r) -> [(refToken, l)] ++ tokBody body ++ [(refToken, r)]-      Nothing           -> [(Comment, s)]--trimLiquidAnnot ('{':'-':'@':ss)-  | drop (length ss - 3) ss == "@-}"-  = Just (liquidBegin, take (length ss - 3) ss, liquidEnd)-trimLiquidAnnot _-  = Nothing--tokBody s-  | isData s  = tokenise s-  | isType s  = tokenise s-  | isIncl s  = tokenise s-  | isMeas s  = tokenise s-  | otherwise = tokeniseSpec s--isMeas = spacePrefix "measure"-isData = spacePrefix "data"-isType = spacePrefix "type"-isIncl = spacePrefix "include"--spacePrefix str s@(c:cs)-  | isSpace c   = spacePrefix str cs-  | otherwise   = take (length str) s == str-spacePrefix _ _ = False---tokeniseSpec       ::  String -> [(TokenType, String)]-tokeniseSpec str   = {- traceShow ("tokeniseSpec: " ++ str) $ -} tokeniseSpec' str--tokeniseSpec'      = tokAlt . chopAltDBG -- [('{', ':'), ('|', '}')]-  where-    tokAlt (s:ss)  = tokenise s ++ tokAlt' ss-    tokAlt _       = []-    tokAlt' (s:ss) = (refToken, s) : tokAlt ss-    tokAlt' _      = []--chopAltDBG y = {- traceShow ("chopAlts: " ++ y) $ -}-  filter (/= "") $ concatMap (chopAlts [("{", ":"), ("|", "}")])-  $ chopAlts [("<{", "}>"), ("{", "}")] y-------------------------------------------------------------------------------- | JSON: Annotation Data Types ------------------------------------------------------------------------------------------------------------------data Assoc k a = Asc (M.HashMap k a)-type AnnTypes  = Assoc Int (Assoc Int Annot1)-type AnnErrors = [(Loc, Loc, String)]-data Annot1    = A1  { ident :: String-                     , ann   :: String-                     , row   :: Int-                     , col   :: Int-                     }----------------------------------------------------------------------------- | Creating Vim Annotations ---------------------------------------------------------------------------------------------------------------------vimAnnot     :: Config -> AnnInfo Doc -> String-vimAnnot cfg = L.intercalate "\n" . map vimBind . mkAnnMapBinders cfg--vimBind (sp, (v, ann)) = printf "%d:%d-%d:%d::%s" l1 c1 l2 c2 (v ++ " :: " ++ show ann)-  where-    l1  = srcSpanStartLine sp-    c1  = srcSpanStartCol  sp-    l2  = srcSpanEndLine   sp-    c2  = srcSpanEndCol    sp----------------------------------------------------------------------------- | JSON Instances -------------------------------------------------------------------------------------------------------------------------------instance ToJSON ACSS.Status where-  toJSON ACSS.Safe   = "safe"-  toJSON ACSS.Unsafe = "unsafe"-  toJSON ACSS.Error  = "error"-  toJSON ACSS.Crash  = "crash"--instance ToJSON Annot1 where-  toJSON (A1 i a r c) = object [ "ident" .= i-                               , "ann"   .= a-                               , "row"   .= r-                               , "col"   .= c-                               ]--instance ToJSON Loc where-  toJSON (L (l, c)) = object [ "line"     .= toJSON l-                             , "column"   .= toJSON c ]--instance ToJSON AnnErrors where-  toJSON errs      = Array $ V.fromList $ fmap toJ errs-    where-      toJ (l,l',s) = object [ "start"   .= toJSON l-                            , "stop"    .= toJSON l'-                            , "message" .= toJSON s  ]--instance (Show k, ToJSON a) => ToJSON (Assoc k a) where-  toJSON (Asc kas) = object [ tshow k .= toJSON a | (k, a) <- M.toList kas ]-    where-      tshow        = T.pack . show--instance ToJSON ACSS.AnnMap where-  toJSON a = object [ "types"  .= toJSON (annTypes    a)-                    , "errors" .= toJSON (ACSS.errors a)-                    , "status" .= toJSON (ACSS.status a)-                    ]--annTypes         :: ACSS.AnnMap -> AnnTypes-annTypes a       = grp [(l, c, ann1 l c x s) | (l, c, x, s) <- binders]-  where-    ann1 l c x s = A1 x s l c-    grp          = L.foldl' (\m (r,c,x) -> ins r c x m) (Asc M.empty)-    binders      = [(l, c, x, s) | (L (l, c), (x, s)) <- M.toList $ ACSS.types a]--ins r c x (Asc m)  = Asc (M.insert r (Asc (M.insert c x rm)) m)-  where-    Asc rm         = M.lookupDefault (Asc M.empty) r m--------------------------------------------------------------------------------------- | A Little Unit Test -------------------------------------------------------------------------------------------------------------------------------------------_anns :: AnnTypes-_anns = i [(5,   i [( 14, A1 { ident = "foo"-                            , ann   = "int -> int"-                            , row   = 5-                            , col   = 14-                            })-                  ]-          )-         ,(9,   i [( 22, A1 { ident = "map"-                            , ann   = "(a -> b) -> [a] -> [b]"-                            , row   = 9-                            , col   = 22-                            })-                  ,( 28, A1 { ident = "xs"-                            , ann   = "[b]"-                            , row   = 9-                            , col   = 28-                            })-                  ])-         ]--i = Asc . M.fromList
src/Language/Haskell/Liquid/Bare.hs view
@@ -1,4 +1,4 @@--- | This module contains the functions that convert /from/ descriptions of +-- | This module contains the functions that convert /from/ descriptions of -- symbols, names and types (over freshly parsed /bare/ Strings), -- /to/ representations connected to GHC vars, names, and types. -- The actual /representations/ of bare and real (refinement) types are all@@ -10,4 +10,3 @@   ) where  import Language.Haskell.Liquid.Bare.GhcSpec-
+ src/Language/Haskell/Liquid/Bare/Axiom.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances    #-}++module Language.Haskell.Liquid.Bare.Axiom (makeAxiom) where++import Prelude hiding (error)+import CoreSyn+import TyCon+import Id+import Name+import Type hiding (isFunTy)+import Var++import TypeRep++import Prelude hiding (mapM)+++import Control.Monad hiding (forM, mapM)+import Control.Monad.Except hiding (forM, mapM)+import Control.Monad.State hiding (forM, mapM)+import Data.Bifunctor+++++import Text.PrettyPrint.HughesPJ (text)+++import qualified Data.List as L+++import Language.Fixpoint.Misc+import Language.Fixpoint.Types (Symbol, symbol, symbolString)++import qualified Language.Fixpoint.Types as F+import Language.Haskell.Liquid.Types.RefType+import Language.Haskell.Liquid.Transforms.CoreToLogic++import Language.Haskell.Liquid.GHC.Misc (showPpr, sourcePosSrcSpan, dropModuleNames)+-- import Language.Haskell.Liquid.Types.RefType (generalize, ofType, uRType, typeSort)++import Language.Haskell.Liquid.Types hiding (binders)+++import qualified Language.Haskell.Liquid.Measure as Ms++import Language.Haskell.Liquid.Bare.Env++++++++++++makeAxiom :: F.TCEmb TyCon -> LogicMap -> [CoreBind] -> GhcSpec -> Ms.BareSpec -> LocSymbol+          -> BareM ((Symbol, Located SpecType), [(Var, Located SpecType)], [HAxiom])+makeAxiom tce lmap cbs _ _ x+  = case filter ((val x `elem`) . map (dropModuleNames . simplesymbol) . binders) cbs of+        (NonRec v def:_)   -> do vts <- zipWithM (makeAxiomType tce lmap x) (reverse $ findAxiomNames x cbs) (defAxioms v def)+                                 insertAxiom v (val x)+                                 updateLMap lmap x x v+                                 updateLMap lmap (x{val = (symbol . showPpr . getName) v}) x v+                                 return ((val x, makeType v),+                                         (v, makeAssumeType v):vts, defAxioms v def)+        (Rec [(v, def)]:_) -> do vts <- zipWithM (makeAxiomType tce lmap x) (reverse $ findAxiomNames x cbs) (defAxioms v def)+                                 insertAxiom v (val x)+                                 updateLMap lmap x x v -- (reverse $ findAxiomNames x cbs) (defAxioms v def)+                                 updateLMap lmap (x{val = (symbol . showPpr . getName) v}) x v+                                 return ((val x, makeType v),+                                         ((v, makeAssumeType v): vts),+                                         defAxioms v def)+        _                  -> throwError $ mkError "Cannot extract measure from haskell function"+  where++    --coreToDef' x v def = case runToLogic lmap mkError $ coreToDef x v def of+    --                        Left l  -> l :: [Def (RRType ()) DataCon] -- return     l+    --                        Right _ -> error $ "ERROR" -- throwError e++    mkError :: String -> Error+    mkError str = ErrHMeas (sourcePosSrcSpan $ loc x) (pprint $ val x) (text str)++    makeType v       = x{val = ufType    $ varType v}+    makeAssumeType v = x{val = axiomType x $ varType v}++++binders (NonRec x _) = [x]+binders (Rec xes)    = fst <$> xes++updateLMap :: LogicMap -> LocSymbol -> LocSymbol -> Var -> BareM ()+updateLMap _ _ _ v | not (isFun $ varType v)+  = return ()+  where+    isFun (FunTy _ _)    = True+    isFun (ForAllTy _ t) = isFun t+    isFun  _             = False++updateLMap _ x y vv -- v axm@(Axiom (vv, _) xs _ lhs rhs)+  = insertLogicEnv (val x) ys (F.eApps (F.EVar $ val y) (F.EVar <$> ys))+  where+    nargs = dropWhile isClassType $ ty_args $ toRTypeRep $ ((ofType $ varType vv) :: RRType ())++    ys = zipWith (\i _ -> symbol (("x" ++ show i) :: String)) [1..] nargs++makeAxiomType :: F.TCEmb TyCon -> LogicMap -> LocSymbol -> Var -> HAxiom -> BareM (Var, Located SpecType)+makeAxiomType tce lmap x v (Axiom _ xs _ lhs rhs)+  = do foldM (\lm x -> (updateLMap lm (dummyLoc $ F.symbol x) (dummyLoc $ F.symbol x) x >> (logicEnv <$> get))) lmap xs+       return (v, x{val = t})+  where+    t   = fromRTypeRep $  tr{ty_res = res, ty_binds = symbol <$> xs}+    tt  = ofType $ varType v+    tr  = toRTypeRep tt+    res = ty_res tr `strengthen` MkUReft ref mempty mempty++    llhs = case runToLogic tce lmap' mkErr (coreToLogic lhs) of+       Left e -> e+       Right e -> panic Nothing $ show e+    lrhs = case runToLogic tce lmap' mkErr (coreToLogic rhs) of+       Left e -> e+       Right e -> panic Nothing $ show e+    ref = F.Reft (F.vv_, F.PAtom F.Eq llhs lrhs)++    -- nargs = dropWhile isClassType $ ty_args $ toRTypeRep $ ((ofType $ varType vv) :: RRType ())+++    lmap' = lmap -- M.insert v' (LMap v' ys runFun) lmap++    mkErr s = ErrHMeas (sourcePosSrcSpan $ loc x) (pprint $ val x) (text s)++    --mkBinds (_:xs) (v:vs) = v:mkBinds xs vs+    --mkBinds _ _ = []++    -- v' = val x -- symbol $ showPpr $ getName vv+++++findAxiomNames x (NonRec v _ :cbs) | isAxiomName x v = v:findAxiomNames x cbs+findAxiomNames x (Rec [(v,_)]:cbs) | isAxiomName x v = v:findAxiomNames x cbs+findAxiomNames x (_:cbs) = findAxiomNames x cbs+findAxiomNames _ [] = []++isAxiomName x v =+  (("axiom_" ++ symbolString (val x)) `L.isPrefixOf`) (symbolString $ dropModuleNames $ simplesymbol v)++defAxioms :: Var -> CoreExpr -> [Axiom Var Kind (Expr Var)]+defAxioms v e = go [] $ simplify e+  where+     go bs (Tick _ e) = go bs e+     go bs (Lam x e) | isTyVar x               = go bs e+     go bs (Lam x e) | isClassPred (varType x) = go bs e+     go bs (Lam x e) = go (bs++[x]) e+     go bs (Case  (Var x) _ _ alts)  = goalt x bs  <$> alts+     go bs e          = [Axiom (v, Nothing) bs (varType <$> bs) (foldl App (Var v) (Var <$> bs)) e]++     goalt x bs (DataAlt c, ys, e) = let vs = [b | b<- bs , b /= x] ++ ys in+        Axiom (v, Just c) vs (varType <$> vs) (mkApp bs x c ys) $ simplify e+     goalt _ _  (LitAlt _,  _,  _) = todo Nothing "defAxioms: goalt Lit"+     goalt _ _  (DEFAULT,   _,  _) = todo Nothing "defAxioms: goalt Def"++     mkApp bs x c ys = foldl App (Var v) ((\y -> if y == x then (mkConApp c (Var <$> ys)) else Var y)<$> bs)+++class Simplifiable a where+   simplify :: a -> a++instance Simplifiable CoreExpr where+  simplify (Tick _ e) = simplify e+  simplify (Lam x e) | isTyVar x = simplify e+  simplify (Lam x e) | isClassPred (varType x) = simplify e+  simplify (Lam x e) = Lam x $ simplify e+  simplify (Let b e) = unANF (simplify b) (simplify e)+  simplify (Case e v t alts) = Case e v t alts+  simplify (Cast e _) = simplify e+  simplify (App e (Type _)) = simplify e+  simplify (App e (Var x)) | isClassPred (varType x) = simplify e+  simplify (App f e) = App (simplify f) (simplify e)+  simplify e@(Var _) = e+  simplify e = todo Nothing ("simplify" ++ showPpr e)++unANF (NonRec x ex) e | L.isPrefixOf "lq_anf" (show x)+  = subst (x, ex) e+unANF b e = Let b e++instance Simplifiable CoreBind where+  simplify (NonRec x e) = NonRec x $ simplify e+  simplify (Rec xes)    = Rec (second simplify <$> xes)+++class Subable a where+  subst :: (Var, CoreExpr) -> a -> a++instance Subable CoreExpr where+  subst (x, ex) (Var y) | x == y    = ex+                        | otherwise = Var y+  subst su (App f e) = App (subst su f) (subst su e)+  subst su (Lam x e) = Lam x (subst su e)+  subst _ _          = todo Nothing "Subable"++-- | Specification for Haskell function+axiomType :: LocSymbol -> Type -> SpecType+axiomType s τ = fromRTypeRep $ t{ty_res = res, ty_binds = xs}+  where+    t  = toRTypeRep $ ofType τ+    ys = dropWhile isClassType $ ty_args t+    xs = (\i -> symbol ("x" ++ show i)) <$> [1..(length ys)]+    x  = F.vv_++    res = ty_res t `strengthen` MkUReft ref mempty mempty++    ref = F.Reft (x, F.PAtom F.Eq (F.EVar x) (mkApp xs))++    mkApp = F.mkEApp s . map F.EVar+++-- | Type for uninterpreted function that approximated Haskell function into logic+ufType :: (F.Reftable r) => Type -> RRType r+ufType τ = fromRTypeRep $ t{ty_args = args, ty_binds = xs, ty_refts = rs}+  where+    t          = toRTypeRep $ ofType τ+    (args, xs, rs) = unzip3 $ dropWhile (isClassType . fst3) $ zip3 (ty_args t) (ty_binds t) (ty_refts t)+++simplesymbol :: CoreBndr -> Symbol+simplesymbol = symbol . getName
src/Language/Haskell/Liquid/Bare/Check.hs view
@@ -11,31 +11,38 @@  import Debug.Trace ++import Prelude hiding (error) import DataCon import Name (getSrcSpan) import TyCon+import Id import Var -import Control.Applicative ((<$>), (<|>))+import Control.Applicative ((<|>)) import Control.Arrow ((&&&))-import Control.Monad.Writer+ import Data.Maybe+import Data.Function (on) import Text.PrettyPrint.HughesPJ  import qualified Data.List           as L import qualified Data.HashMap.Strict as M -import Language.Fixpoint.Misc (applyNonNull, group, mapSnd, errorstar, safeHead)-import Language.Fixpoint.Sort (checkSorted, checkSortedReftFull, checkSortFull)-import Language.Fixpoint.Types hiding (R)+import Language.Fixpoint.Misc (applyNonNull, group, safeHead)+import Language.Fixpoint.SortCheck  (checkSorted, checkSortedReftFull, checkSortFull)+import Language.Fixpoint.Types      hiding (Error, R) -import Language.Haskell.Liquid.GhcMisc (realTcArity, showPpr, sourcePosSrcSpan)-import Language.Haskell.Liquid.Misc (firstDuplicate, snd4)-import Language.Haskell.Liquid.PredType (pvarRType, wiredSortedSyms)-import Language.Haskell.Liquid.PrettyPrint (pprintSymbol)-import Language.Haskell.Liquid.RefType (classBinds, ofType, rTypeSort, rTypeSortedReft, subsTyVars_meet, toType)+import Language.Haskell.Liquid.GHC.Misc (realTcArity, showPpr, fSrcSpan, sourcePosSrcSpan)+import Language.Haskell.Liquid.Misc (snd4, mapSnd)+import Language.Haskell.Liquid.Types.PredType (pvarRType)+import Language.Haskell.Liquid.Types.PrettyPrint (pprintSymbol)+import Language.Haskell.Liquid.Types.RefType (classBinds, ofType, rTypeSort, rTypeSortedReft, subsTyVars_meet, toType) import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.WiredIn ++ import qualified Language.Haskell.Liquid.Measure as Ms  import Language.Haskell.Liquid.Bare.DataType (dataConSpec)@@ -53,33 +60,47 @@  checkGhcSpec specs env sp =  applyNonNull (Right sp) Left errors   where-    errors           =  mapMaybe (checkBind "constructor" emb tcEnv env) (dcons      sp)-                     ++ mapMaybe (checkBind "measure"     emb tcEnv env) (meas       sp)+    errors           =  mapMaybe (checkBind "constructor"  emb tcEnv env) (dcons      sp)+                     ++ mapMaybe (checkBind "measure"      emb tcEnv env) (meas       sp)+                     ++ mapMaybe (checkBind "assumed type" emb tcEnv env) (asmSigs    sp)+                     ++ mapMaybe (checkBind "class method" emb tcEnv env) (clsSigs    sp)                      ++ mapMaybe (checkInv  emb tcEnv env)               (invariants sp)-                     ++ (checkIAl  emb tcEnv env) (ialiases   sp)+                     ++ checkIAl  emb tcEnv env (ialiases   sp)                      ++ checkMeasures emb env ms+                     ++ checkClassMeasures (measures sp)                      ++ mapMaybe checkMismatch                     sigs                      ++ checkDuplicate                             (tySigs sp)+                     ++ checkQualifiers env                        (qualifiers sp)                      ++ checkDuplicate                             (asmSigs sp)                      ++ checkDupIntersect                          (tySigs sp) (asmSigs sp)                      ++ checkRTAliases "Type Alias" env            tAliases-                     ++ checkRTAliases "Pred Alias" env            pAliases+                     ++ checkRTAliases "Pred Alias" env            eAliases                      ++ checkDuplicateFieldNames                   (dconsP sp)                      ++ checkRefinedClasses                        (concatMap (Ms.classes . snd) specs) (concatMap (Ms.rinstance . snd) specs)       tAliases         =  concat [Ms.aliases sp  | (_, sp) <- specs]-    pAliases         =  concat [Ms.paliases sp | (_, sp) <- specs]-    dcons spec       =  [(v, Loc l l' t) | (v,t)   <- dataConSpec (dconsP spec)-                                         | (_,dcp) <- dconsP spec-                                         , let l    = dc_loc  dcp-                                         , let l'   = dc_locE dcp+    eAliases         =  concat [Ms.ealiases sp | (_, sp) <- specs]+    dcons spec       =  [(v, Loc l l' t) | (v, t)   <- dataConSpec (dconsP spec)+                                         | (_, dcp) <- dconsP spec+                                         , let l     = dc_loc  dcp+                                         , let l'    = dc_locE dcp                                          ]     emb              =  tcEmbeds sp     tcEnv            =  tyconEnv sp     ms               =  measures sp+    clsSigs sp       =  [ (v, t) | (v, t) <- tySigs sp, isJust (isClassOpId_maybe v) ]     sigs             =  tySigs sp ++ asmSigs sp ++checkQualifiers :: SEnv SortedReft -> [Qualifier] -> [Error]+checkQualifiers = mapMaybe . checkQualifier++checkQualifier       :: SEnv SortedReft -> Qualifier -> Maybe Error+checkQualifier env q =  mkE <$> checkSortFull γ boolSort  (q_body q)+  where γ   = foldl (\e (x, s) -> insertSEnv x (RR s mempty) e) env (q_params q ++ wiredSortedSyms)+        mkE = ErrBadQual (sourcePosSrcSpan $ q_pos q) (pprint $ q_name q)+ checkRefinedClasses :: [RClass BareType] -> [RInstance BareType] -> [Error] checkRefinedClasses definitions instances   = mkError <$> duplicates@@ -101,17 +122,24 @@       = sourcePosSrcSpan . loc . riclass &&& pprint . ritype  checkDuplicateFieldNames :: [(DataCon, DataConP)]  -> [Error]-checkDuplicateFieldNames = catMaybes . map go+checkDuplicateFieldNames = mapMaybe go   where-    go (d, dts)        = checkNoDups (dc_loc dts) d (fst <$> tyArgs dts)-    checkNoDups l d xs = mkErr l d <$> firstDuplicate xs+    go (d, dts)          = checkNoDups (dc_loc dts) d (fst <$> tyArgs dts)+    checkNoDups l d xs   = mkErr l d <$> firstDuplicate xs      mkErr l d x = ErrBadData (sourcePosSrcSpan l)                              (pprint d)                              (text "Multiple declarations of record selector" <+> pprintSymbol x) +firstDuplicate :: Ord a => [a] -> Maybe a+firstDuplicate = go . L.sort+  where+    go (y:x:xs) | x == y    = Just x+                | otherwise = go (x:xs)+    go _                    = Nothing+ checkInv :: TCEmb TyCon -> TCEnv -> SEnv SortedReft -> Located SpecType -> Maybe Error-checkInv emb tcEnv env t   = checkTy err emb tcEnv env (val t)+checkInv emb tcEnv env t   = checkTy err emb tcEnv env t   where     err              = ErrInvt (sourcePosSrcSpan $ loc t) (val t) @@ -120,13 +148,13 @@  checkIAlOne emb tcEnv env (t1, t2) = checkEq : (tcheck <$> [t1, t2])   where-    tcheck t = checkTy (err t) emb tcEnv env (val t)+    tcheck t = checkTy (err t) emb tcEnv env t     err    t = ErrIAl (sourcePosSrcSpan $ loc t) (val t)     t1'      :: RSort     t1'      = toRSort $ val t1     t2'      :: RSort     t2'      = toRSort $ val t2-    checkEq  = if (t1' == t2') then Nothing else Just errmis+    checkEq  = if t1' == t2' then Nothing else Just errmis     errmis   = ErrIAlMis (sourcePosSrcSpan $ loc t1) (val t1) (val t2) emsg     emsg     = pprint t1 <+> text "does not match with" <+> pprint t2 @@ -137,9 +165,9 @@     err1s                  = checkDuplicateRTAlias msg as  checkBind :: (PPrint v) => String -> TCEmb TyCon -> TCEnv -> SEnv SortedReft -> (v, Located SpecType) -> Maybe Error-checkBind s emb tcEnv env (v, Loc l _ t) = checkTy msg emb tcEnv env' t+checkBind s emb tcEnv env (v, t) = checkTy msg emb tcEnv env' t   where-    msg                      = ErrTySpec (sourcePosSrcSpan l) (text s <+> pprint v) t+    msg                      = ErrTySpec (fSrcSpan t) (text s <+> pprint v) (val t)     env'                     = foldl (\e (x, s) -> insertSEnv x (RR s mempty) e) env wiredSortedSyms  checkTerminationExpr :: (Eq v, PPrint v) => TCEmb TyCon -> SEnv SortedReft -> (v, Located SpecType, [Expr])-> Maybe Error@@ -154,20 +182,20 @@     xts     = concatMap mkClass $ zip (ty_binds trep) (ty_args trep)     trep    = toRTypeRep t -    mkClass (_, (RApp c ts _ _)) | isClass c = classBinds (rRCls c ts)-    mkClass (x, t)                           = [(x, rSort t)]+    mkClass (_, RApp c ts _ _) | isClass c = classBinds (rRCls c ts)+    mkClass (x, t)                         = [(x, rSort t)]      rSort   = rTypeSortedReft emb     cmpZero = PAtom Le $ expr (0 :: Int) -- zero -checkTy :: (Doc -> Error) -> TCEmb TyCon -> TCEnv -> SEnv SortedReft -> SpecType -> Maybe Error-checkTy mkE emb tcEnv env t = mkE <$> checkRType emb env (txRefSort tcEnv emb t)+checkTy :: (Doc -> Error) -> TCEmb TyCon -> TCEnv -> SEnv SortedReft -> Located SpecType -> Maybe Error+checkTy mkE emb tcEnv env t = mkE <$> checkRType emb env (val $ txRefSort tcEnv emb t)  checkDupIntersect     :: [(Var, Located SpecType)] -> [(Var, Located SpecType)] -> [Error] checkDupIntersect xts mxts = concatMap mkWrn dups   where     mkWrn (x, t)     = pprWrn x (sourcePosSrcSpan $ loc t)-    dups             = L.intersectBy (\x y -> (fst x == fst y)) mxts xts+    dups             = L.intersectBy ((==) `on` fst) mxts xts     pprWrn v l       = trace ("WARNING: Assume Overwrites Specifications for "++ show v ++ " : " ++ showPpr l) []  checkDuplicate        :: [(Var, Located SpecType)] -> [Error]@@ -183,9 +211,8 @@                                           (text s)                                           (pprint $ rtName x)                                           (sourcePosSrcSpan . rtPos <$> xs)-    mkErr []                = error "mkError: called on empty list"-    dups                    = [z | z@(_:_:_) <- L.groupBy (\x y -> rtName x == rtName y) tas]-+    mkErr []                = panic Nothing "mkError: called on empty list"+    dups                    = [z | z@(_:_:_) <- L.groupBy ((==) `on` rtName) tas]   checkMismatch        :: (Var, Located SpecType) -> Maybe Error@@ -200,7 +227,12 @@     rhs :: RSort     = ofType $ varType x  errTypeMismatch     :: Var -> Located SpecType -> Error-errTypeMismatch x t = ErrMismatch (sourcePosSrcSpan $ loc t) (pprint x) (varType x) (toType $ val t)+errTypeMismatch x t = ErrMismatch lqSp (pprint x) d1 d2 hsSp+  where+    d1              = pprint $ varType x+    d2              = pprint $ toType $ val t+    lqSp            = sourcePosSrcSpan $ loc t+    hsSp            = getSrcSpan x  ------------------------------------------------------------------------------------------------ -- | @checkRType@ determines if a type is malformed in a given environment ---------------------@@ -208,15 +240,16 @@ checkRType :: (PPrint r, Reftable r) => TCEmb TyCon -> SEnv SortedReft -> RRType (UReft r) -> Maybe Doc ------------------------------------------------------------------------------------------------ -checkRType emb env t         = checkAppTys t <|> checkFunRefs t <|> checkAbstractRefs t <|> efoldReft cb (rTypeSortedReft emb) f insertPEnv env Nothing t+checkRType emb env t   =  checkAppTys t+                      <|> checkAbstractRefs t+                      <|> efoldReft cb (rTypeSortedReft emb) f insertPEnv env Nothing t   where-    cb c ts                  = classBinds (rRCls c ts)-    f env me r err           = err <|> checkReft env emb me r-    insertPEnv p γ           = insertsSEnv γ (mapSnd (rTypeSortedReft emb) <$> pbinds p)-    pbinds p                 = (pname p, pvarRType p :: RSort)-                              : [(x, t) | (t, x, _) <- pargs p]+    cb c ts            = classBinds (rRCls c ts)+    f env me r err     = err <|> checkReft env emb me r+    insertPEnv p γ     = insertsSEnv γ (mapSnd (rTypeSortedReft emb) <$> pbinds p)+    pbinds p           = (pname p, pvarRType p :: RSort) : [(x, tx) | (tx, x, _) <- pargs p] -checkAppTys t = go t+checkAppTys = go   where     go (RAllT _ t)      = go t     go (RAllP _ t)      = go t@@ -241,9 +274,10 @@         <+> text "arguments"   | otherwise     = Nothing-  where expectedArity = realTcArity tc-+  where+    expectedArity = realTcArity tc +{-  checkFunRefs t = go t   where     go (RAllT _ t)      = go t@@ -258,10 +292,9 @@     go (RExprArg _)     = Nothing     go (RHole _)        = Nothing     go (RFun _ t1 t2 r)-      | isTauto r-        = go t1 <|> go t2-      | otherwise-        = Just $ text "Function types cannot have refinements:" <+> (pprint r)+      | isTauto r       = go t1 <|> go t2+      | otherwise       = Just $ text "Function types cannot have refinements:" <+> (pprint r)+-}   checkAbstractRefs t = go t   where@@ -282,27 +315,27 @@      go' c rs = foldl (\acc (x, y) -> acc <|> checkOne' x y) Nothing (zip rs (rTyConPVs c)) -    checkOne' (RProp xs t) p-      | pvType p /= toRSort t-      = Just $ text "Unexpected Sort in" <+> pprint p+    checkOne' (RProp xs (RHole _)) p       | or [s1 /= s2 | ((_, s1), (s2, _, _)) <- zip xs (pargs p)]       = Just $ text "Wrong Arguments in" <+> pprint p       | length xs /= length (pargs p)       = Just $ text "Wrong Number of Arguments in" <+> pprint p       | otherwise-      = go t-    checkOne' (RPropP xs _) p+      = Nothing+    checkOne' (RProp xs t) p+      | pvType p /= toRSort t+      = Just $ text "Unexpected Sort in" <+> pprint p       | or [s1 /= s2 | ((_, s1), (s2, _, _)) <- zip xs (pargs p)]       = Just $ text "Wrong Arguments in" <+> pprint p       | length xs /= length (pargs p)       = Just $ text "Wrong Number of Arguments in" <+> pprint p       | otherwise-      = Nothing-    checkOne' _ _ = errorstar "This cannot happen"+      = go t +     efold f = foldl (\acc x -> acc <|> f x) Nothing -    check s (U _ (Pr ps) _) = foldl (\acc pp -> acc <|> checkOne s pp) Nothing ps+    check s (MkUReft _ (Pr ps) _) = foldl (\acc pp -> acc <|> checkOne s pp) Nothing ps      checkOne s p | pvType' p /= s                  = Just $ text "Incorrect Sort:\n\t"@@ -355,15 +388,15 @@ checkMeasure emb γ (M name@(Loc src _ n) sort body)   = [txerror e | Just e <- checkMBody γ emb name sort <$> body]   where-    txerror = ErrMeas (sourcePosSrcSpan src) n+    txerror = ErrMeas (sourcePosSrcSpan src) (pprint n)  checkMBody γ emb _ sort (Def _ as c _ bs body) = checkMBody' emb sort γ' body-  where +  where     γ'   = L.foldl' (\γ (x, t) -> insertSEnv x t γ) γ (ats ++ xts)     ats  = (mapSnd (rTypeSortedReft emb) <$> as)     xts  = zip (fst <$> bs) $ rTypeSortedReft emb . subsTyVars_meet su <$> ty_args trep     trep = toRTypeRep ct-    su   = checkMBodyUnify (ty_res trep) (last txs) +    su   = checkMBodyUnify (ty_res trep) (last txs)     txs  = snd4 $ bkArrowDeep sort     ct   = ofType $ dataConUserType c :: SpecType @@ -375,9 +408,24 @@  checkMBody' emb sort γ body = case body of     E e   -> checkSortFull γ (rTypeSort emb sort') e-    P p   -> checkSortFull γ propSort  p-    R s p -> checkSortFull (insertSEnv s sty γ) propSort p+    P p   -> checkSortFull γ boolSort  p+    R s p -> checkSortFull (insertSEnv s sty γ) boolSort p   where     -- psort = FApp propFTyCon []     sty   = rTypeSortedReft emb sort'     sort' = ty_res $ toRTypeRep sort++checkClassMeasures :: [Measure SpecType DataCon] -> [Error]+checkClassMeasures ms = mapMaybe checkOne byTyCon+  where+  byName = L.groupBy ((==) `on` (val.name)) ms++  byTyCon = concatMap (L.groupBy ((==) `on` (dataConTyCon . ctor . head . eqns)))+                      byName++  checkOne []     = impossible Nothing "checkClassMeasures.checkOne on empty measure group"+  checkOne [_]    = Nothing+  checkOne (m:ms) = Just (ErrDupMeas (sourcePosSrcSpan (loc (name m)))+                                     (pprint (val (name m)))+                                     (pprint ((dataConTyCon . ctor . head . eqns) m))+                                     (map (sourcePosSrcSpan.loc.name) (m:ms)))
src/Language/Haskell/Liquid/Bare/DataType.hs view
@@ -1,33 +1,37 @@-{-# LANGUAGE FlexibleContexts         #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-}  module Language.Haskell.Liquid.Bare.DataType (     makeConTypes   , makeTyConEmbeds-+  , makeRecordSelectorSigs   , dataConSpec   , meetDataConSpec   ) where +import Prelude hiding (error) import DataCon import TyCon import Var+import SrcLoc (SrcSpan)+import Name (getSrcSpan) -import Control.Applicative ((<$>)) import Data.Maybe-import Data.Monoid + import qualified Data.List           as L import qualified Data.HashMap.Strict as M -import Language.Fixpoint.Misc (errorstar, mapSnd)-import Language.Fixpoint.Types (Symbol, TCEmb, meet)+import Language.Fixpoint.Types (Symbol, TCEmb, mkSubst, Expr(..), Brel(..), subst) -import Language.Haskell.Liquid.GhcMisc (symbolTyVar)-import Language.Haskell.Liquid.PredType (dataConPSpecType)-import Language.Haskell.Liquid.RefType (mkDataConIdsTy, ofType, rApp, rVar, uPVar)+import Language.Haskell.Liquid.GHC.Misc (sourcePos2SrcSpan, symbolTyVar)+import Language.Haskell.Liquid.Types.PredType (dataConPSpecType)+import Language.Haskell.Liquid.Types.RefType (mkDataConIdsTy, ofType, rApp, rVar, strengthen, uPVar, uReft) import Language.Haskell.Liquid.Types-import Language.Haskell.Liquid.Variance+import Language.Haskell.Liquid.Types.Meet+import Language.Haskell.Liquid.Misc (mapSnd)+import Language.Haskell.Liquid.Types.Variance import Language.Haskell.Liquid.WiredIn  import qualified Language.Haskell.Liquid.Measure as Ms@@ -36,6 +40,8 @@ import Language.Haskell.Liquid.Bare.Lookup import Language.Haskell.Liquid.Bare.OfType +-- import Debug.Trace+ ----------------------------------------------------------------------- -- Bare Predicate: DataCon Definitions -------------------------------- -----------------------------------------------------------------------@@ -54,17 +60,29 @@         merge []     vs  = ((Nothing,) . Just) <$> vs         merge ds     []  = ((,Nothing) . Just) <$> ds -+dataConSpec :: [(DataCon, DataConP)] -> [(Var, SpecType)]+dataConSpec x = [ (v, t) | (v, (_, t)) <- dataConSpec' x ] -dataConSpec :: [(DataCon, DataConP)]-> [(Var, (RType RTyCon RTyVar RReft))]-dataConSpec dcs = concatMap mkDataConIdsTy [(dc, dataConPSpecType dc t) | (dc, t) <- dcs]+dataConSpec' :: [(DataCon, DataConP)] -> [(Var, (SrcSpan, SpecType))]+dataConSpec' dcs = concatMap tx dcs+  where+    tx (a, b)    = [ (x, (sspan b, t)) | (x, t) <- mkDataConIdsTy (a, dataConPSpecType a b) ]+    sspan z      = sourcePos2SrcSpan (dc_loc z) (dc_locE z) -meetDataConSpec xts dcs  = M.toList $ L.foldl' upd dcm xts+meetDataConSpec :: [(Var, SpecType)] -> [(DataCon, DataConP)] -> [(Var, SpecType)]+meetDataConSpec xts dcs  = M.toList $ snd <$> L.foldl' upd dcm0 xts   where-    dcm                  = M.fromList $ dataConSpec dcs-    upd dcm (x, t)       = M.insert x (maybe t (meet t) (M.lookup x dcm)) dcm+    dcm0                 = M.fromList $ dataConSpec' dcs+    meetX x t (sp', t')  = meetVarTypes (pprint x) (getSrcSpan x, t) (sp', t')+    upd dcm (x, t)       = M.insert x (getSrcSpan x, tx') dcm+                             where+                               tx' = maybe t (meetX x t) (M.lookup x dcm) -ofBDataDecl :: Maybe DataDecl  -> (Maybe (LocSymbol, [Variance])) -> BareM ((TyCon, TyConP), [(DataCon, Located DataConP)])++-- FIXME: ES: why the maybes?+ofBDataDecl :: Maybe DataDecl+            -> (Maybe (LocSymbol, [Variance]))+            -> BareM ((TyCon, TyConP), [(DataCon, Located DataConP)]) ofBDataDecl (Just (D tc as ps ls cts _ sfun)) maybe_invariance_info   = do πs         <- mapM ofBPVar ps        tc'        <- lookupGhcTyCon tc@@ -97,7 +115,7 @@     (tcov, tcontr) = (is, [])  ofBDataDecl Nothing Nothing-  = errorstar $ "Bare.DataType.ofBDataDecl called on invalid inputs"+  = panic Nothing "Bare.DataType.ofBDataDecl called on invalid inputs"  getPsSig m pos (RAllT _ t)   = getPsSig m pos t@@ -113,21 +131,20 @@ getPsSig m pos (RHole r)   = addps m pos r getPsSig _ _ z-  = error $ "getPsSig" ++ show z+  = panic Nothing $ "getPsSig" ++ show z -getPsSigPs m pos (RPropP _ r) = addps m pos r-getPsSigPs m pos (RProp  _ t) = getPsSig m pos t-getPsSigPs _ _   (RHProp _ _) = errorstar "TODO:EFFECTS:getPsSigPs"+getPsSigPs m pos (RProp _ (RHole r)) = addps m pos r+getPsSigPs m pos (RProp _ t) = getPsSig m pos t -addps m pos (U _ ps _) = (flip (,)) pos . f  <$> pvars ps-  where f = fromMaybe (error "Bare.addPs: notfound") . (`L.lookup` m) . uPVar+addps m pos (MkUReft _ ps _) = (flip (,)) pos . f  <$> pvars ps+  where f = fromMaybe (panic Nothing "Bare.addPs: notfound") . (`L.lookup` m) . uPVar  -- TODO:EFFECTS:ofBDataCon ofBDataCon l l' tc αs ps ls πs (c, xts)   = do c'      <- lookupGhcDataCon c        ts'     <- mapM (mkSpecType' l ps) ts        let cs   = map ofType (dataConStupidTheta c')-       let t0   = rApp tc rs (RPropP [] . pdVarReft <$> πs) mempty+       let t0   = rApp tc rs (rPropP [] . pdVarReft <$> πs) mempty        return   $ (c', DataConP l αs πs ls cs (reverse (zip xs ts')) t0 l')     where        (xs, ts) = unzip xts@@ -141,3 +158,34 @@ makeTyConEmbeds' z = M.fromList <$> mapM tx (M.toList z)   where     tx (c, y) = (, y) <$> lookupGhcTyCon c++makeRecordSelectorSigs :: [(DataCon, Located DataConP)] -> BareM [(Var, Located SpecType)]+makeRecordSelectorSigs dcs = concat <$> mapM makeOne dcs+  where+  makeOne (dc, Loc l l' dcp)+    | null (dataConFieldLabels dc)+    = return []+    | otherwise = do+        fs <- mapM lookupGhcVar (dataConFieldLabels dc)+        return (fs `zip` ts)+    where+    ts   = [ Loc l l' (mkArrow (freeTyVars dcp) [] (freeLabels dcp)+                               [(z, res, mempty)]+                               (dropPreds (subst su t `strengthen` mt)))+           | (x, t) <- reverse args -- NOTE: the reverse here is correct+           , not (isFunTy t) -- NOTE: we only have measures for non-function fields+           , let vv = rTypeValueVar t+             -- the measure singleton refinement, eg `v = getBar foo`+           , let mt = uReft (vv, PAtom Eq (EVar vv) (EApp (EVar x) (EVar z)))+           ]++    su   = mkSubst $ [ (x, EApp (EVar x) (EVar z)) | x <- xs ]+    args = tyArgs dcp+    xs   = map fst args+    z    = "lq$recSel"+    res  = dropPreds (tyRes dcp)++    -- FIXME: this is clearly imprecise, but the preds in the DataConP seem+    -- to be malformed. If we leave them in, tests/pos/kmp.hs fails with+    -- a malformed predicate application. Niki, help!!+    dropPreds = fmap (\(MkUReft r _ps ss) -> MkUReft r mempty ss)
src/Language/Haskell/Liquid/Bare/Env.hs view
@@ -13,28 +13,32 @@   , withVArgs    , setRTAlias-  , setRPAlias   , setREAlias    , execBare++  , insertLogicEnv+  , insertAxiom   ) where +import Prelude hiding (error) import HscTypes import TyCon import Var -import Control.Monad.Error hiding (Error)+import Control.Monad.Except import Control.Monad.State import Control.Monad.Writer  import qualified Control.Exception   as Ex import qualified Data.HashMap.Strict as M -import Language.Fixpoint.Types (Expr(..), Symbol, symbol, Pred) -import Language.Haskell.Liquid.Errors ()+import Language.Fixpoint.Types (Expr(..), Symbol, symbol)++import Language.Haskell.Liquid.UX.Errors () import Language.Haskell.Liquid.Types-import Language.Haskell.Liquid.Bounds+import Language.Haskell.Liquid.Types.Bounds   -----------------------------------------------------------------------------------@@ -42,7 +46,7 @@ -----------------------------------------------------------------------------------  -- FIXME: don't use WriterT [], very slow-type BareM = WriterT [Warn] (ErrorT Error (StateT BareEnv IO))+type BareM = WriterT [Warn] (ExceptT Error (StateT BareEnv IO))  type Warn  = String @@ -51,7 +55,7 @@ type InlnEnv = M.HashMap Symbol TInline  data TInline = TI { tiargs :: [Symbol]-                  , tibody :: Either Pred Expr+                  , tibody :: Expr                   } deriving (Show)  @@ -68,7 +72,12 @@   +insertLogicEnv x ys e+  = modify $ \be -> be {logicEnv = (logicEnv be) {logic_map = M.insert x (LMap x ys e) $ logic_map $ logicEnv be}} +insertAxiom x s+  = modify $ \be -> be {logicEnv = (logicEnv be){axiom_map = M.insert x s $ axiom_map $ logicEnv be}}+ setModule m b = b { modName = m }  inModule m act = do@@ -91,8 +100,6 @@ setRTAlias s a =   modify $ \b -> b { rtEnv = mapRT (M.insert s a) $ rtEnv b } -setRPAlias s a =-  modify $ \b -> b { rtEnv = mapRP (M.insert s a) $ rtEnv b }  setREAlias s a =   modify $ \b -> b { rtEnv = mapRE (M.insert s a) $ rtEnv b }@@ -101,7 +108,7 @@ execBare :: BareM a -> BareEnv -> IO (Either Error a) ------------------------------------------------------------------ execBare act benv =-   do z <- evalStateT (runErrorT (runWriterT act)) benv `Ex.catch` (return . Left)+   do z <- evalStateT (runExceptT (runWriterT act)) benv `Ex.catch` (return . Left)       case z of         Left s        -> return $ Left s         Right (x, ws) -> do forM_ ws $ putStrLn . ("WARNING: " ++)
src/Language/Haskell/Liquid/Bare/Existential.hs view
@@ -2,17 +2,17 @@     txExpToBind   ) where -import Control.Applicative ((<$>)) import Control.Monad.State import Data.Char  import qualified Data.HashMap.Strict as M -import Language.Fixpoint.Misc (errorstar, fst3)-import Language.Fixpoint.Names (headSym)+import Prelude hiding (error)+import Language.Fixpoint.Misc (fst3)+import Language.Fixpoint.Types.Names (headSym) import Language.Fixpoint.Types (Expr(..), Symbol, symbol, exprReft) -import Language.Haskell.Liquid.RefType (strengthen, uTop)+import Language.Haskell.Liquid.Types.RefType (strengthen, uTop) import Language.Haskell.Liquid.Types  -------------------------------------------------------------------------------@@ -63,10 +63,10 @@   = return t  expToBindReft              :: SpecProp -> State ExSt SpecProp+expToBindReft (RProp s (RHole r)) = rPropP s <$> expToBindRef r expToBindReft (RProp s t)  = RProp s  <$> expToBindT t-expToBindReft (RPropP s r) = RPropP s <$> expToBindRef r-expToBindReft (RHProp _ _) = errorstar "TODO:EFFECTS:expToBindReft" + getBinds :: State ExSt (M.HashMap Symbol (RSort, Expr)) getBinds   = do bds <- emap <$> get@@ -77,11 +77,11 @@  addExist t x (tx, e) = REx x t' t   where t' = (ofRSort tx) `strengthen` uTop r-        r  = exprReft e +        r  = exprReft e  expToBindRef :: UReft r -> State ExSt (UReft r)-expToBindRef (U r (Pr p) l)-  = mapM expToBind p >>= return . (\p -> U r p l). Pr+expToBindRef (MkUReft r (Pr p) l)+  = mapM expToBind p >>= return . (\p -> MkUReft r p l). Pr  expToBind :: UsedPVar -> State ExSt UsedPVar expToBind p
src/Language/Haskell/Liquid/Bare/Expand.hs view
@@ -2,21 +2,21 @@  module Language.Haskell.Liquid.Bare.Expand (     expandReft-  , expandPred   , expandExpr   ) where -import Control.Applicative ((<$>), (<*>))-import Control.Monad.Reader hiding (forM)+import Prelude hiding (error)+ import Control.Monad.State hiding (forM)  import qualified Data.HashMap.Strict as M -import Language.Fixpoint.Types (Expr(..), Pred(..), Refa(..), Reft(..), mkSubst, subst)+import Language.Fixpoint.Types (Expr(..), Reft(..), mkSubst, subst, eApps, splitEApp)  import Language.Haskell.Liquid.Misc (safeZipWithError) import Language.Haskell.Liquid.Types + import Language.Haskell.Liquid.Bare.Env  --------------------------------------------------------------------------------@@ -24,107 +24,91 @@ --------------------------------------------------------------------------------  expandReft :: RReft -> BareM RReft-expandReft = txPredReft expandPred expandExpr--txPredReft :: (Pred -> BareM Pred) -> (Expr -> BareM Expr) -> RReft -> BareM RReft-txPredReft f fe u = (\r -> u {ur_reft = r}) <$> txPredReft' (ur_reft u)-  where-    txPredReft' (Reft (v, ra)) = Reft . (v,) <$> txPredRefa ra-    txPredRefa  (Refa p)       = Refa        <$> (f <=< mapPredM fe) p+expandReft = txPredReft expandExpr -mapPredM :: (Expr -> BareM Expr) -> Pred -> BareM Pred-mapPredM f = go+txPredReft :: (Expr -> BareM Expr) -> RReft -> BareM RReft+txPredReft f u = (\r -> u {ur_reft = r}) <$> txPredReft' (ur_reft u)   where-    go PTrue           = return PTrue-    go PFalse          = return PFalse-    go p@(PKVar _ _)   = return p-    go (PAnd ps)       = PAnd <$> mapM go ps-    go (POr ps)        = POr  <$> mapM go ps-    go (PNot p)        = PNot <$> go p-    go (PImp p q)      = PImp <$> go p <*> go q-    go (PIff p q)      = PIff <$> go p <*> go q-    go (PBexp e)       = PBexp <$> f e-    go (PAtom b e1 e2) = PAtom b <$> f e1 <*> f e2-    go (PAll xs p)     = PAll xs <$> go p-    -- go (PExist xs p)   = PExist xs <$> go p-    go PTop            = return PTop+    txPredReft' (Reft (v, ra)) = Reft . (v,) <$> f ra   ----------------------------------------------------------------------------------- Expand Preds ----------------------------------------------------------------+-- Expand Exprs ---------------------------------------------------------------- -------------------------------------------------------------------------------- -expandPred :: Pred -> BareM Pred -expandPred p@(PBexp (EApp (Loc l _ f') es))-  = do env <- gets (predAliases.rtEnv)-       return $-         case M.lookup f' env of-           Just rp ->-             expandApp l rp es-           Nothing ->-             p-expandPred p@(PBexp _)-  = return p-expandPred (PAnd ps)-  = PAnd <$> mapM expandPred ps-expandPred (POr ps)-  = POr <$> mapM expandPred ps-expandPred (PNot p)-  = PNot <$> expandPred p-expandPred (PImp p q)-  = PImp <$> expandPred p <*> expandPred q-expandPred (PIff p q)-  = PIff <$> expandPred p <*> expandPred q-expandPred (PAll xs p)-  = PAll xs <$> expandPred p--- expandPred (PExist xs p)---   = PExist xs <$> expandPred p-expandPred p-  = return p ------------------------------------------------------------------------------------ Expand Exprs -------------------------------------------------------------------------------------------------------------------------------------------------- expandExpr :: Expr -> BareM Expr -expandExpr (EApp f@(Loc l _ f') es)-  = do env <- gets (exprAliases.rtEnv)-       case M.lookup f' env of-         Just re ->-           expandApp l re <$> mapM expandExpr es-         Nothing ->-           EApp f <$> mapM expandExpr es+expandExpr e@(EApp _ _)+  = expandEApp $ splitEApp e   expandExpr (ENeg e)   = ENeg <$> expandExpr e expandExpr (EBin op e1 e2)   = EBin op <$> expandExpr e1 <*> expandExpr e2 expandExpr (EIte p e1 e2)-  = EIte p <$> expandExpr e1 <*> expandExpr e2+  = EIte <$> expandExpr p <*> expandExpr e1 <*> expandExpr e2 expandExpr (ECst e s)   = (`ECst` s) <$> expandExpr e +expandExpr e@(EVar _)+  = return e expandExpr e@(ESym _)   = return e expandExpr e@(ECon _)   = return e-expandExpr e@(EVar _)-  = return e-expandExpr e@(ELit _ _)-  = return e -expandExpr EBot-  = return EBot+expandExpr (PAnd ps)+  = PAnd <$> mapM expandExpr ps+expandExpr (POr ps)+  = POr <$> mapM expandExpr ps+expandExpr (PNot p)+  = PNot <$> expandExpr p+expandExpr (PImp p q)+  = PImp <$> expandExpr p <*> expandExpr q+expandExpr (PIff p q)+  = PIff <$> expandExpr p <*> expandExpr q+expandExpr (PAll xs p)+  = PAll xs <$> expandExpr p+expandExpr (ELam xt e)+  = ELam xt <$> expandExpr e +expandExpr (ETApp e s)+  = (`ETApp` s) <$> expandExpr e +expandExpr (ETAbs e s)+  = (`ETAbs` s) <$> expandExpr e ++expandExpr (PAtom b e1 e2)+  = PAtom b <$> expandExpr e1 <*> expandExpr e2 ++expandExpr (PKVar k s)+  = return $ PKVar k s ++expandExpr PGrad+  = return PGrad++expandExpr (PExist s e)+  = PExist s <$> expandExpr e +++expandEApp (EVar f, es)+  = do env <- gets (exprAliases.rtEnv)+       case M.lookup f env of+         Just re ->+           expandApp re <$> mapM expandExpr es +         Nothing ->+           eApps (EVar f) <$> mapM expandExpr es +expandEApp (f, es)+  = return $ eApps f es + -------------------------------------------------------------------------------- -- Expand Alias Application ---------------------------------------------------- -------------------------------------------------------------------------------- -expandApp l re es+expandApp re es   = subst su $ rtBody re   where su  = mkSubst $ safeZipWithError msg (rtVArgs re) es-        msg = "Malformed alias application at " ++ show l ++ "\n\t"+        msg = "Malformed alias application" ++ "\n\t"                ++ show (rtName re)                ++ " defined at " ++ show (rtPos re)                ++ "\n\texpects " ++ show (length $ rtVArgs re)
src/Language/Haskell/Liquid/Bare/GhcSpec.hs view
@@ -8,39 +8,47 @@   , makeGhcSpec   ) where +-- import Debug.Trace (trace)+import Prelude hiding (error) import CoreSyn hiding (Expr) import HscTypes import Id import NameSet+import Name import TyCon import Var import TysWiredIn -import Control.Applicative ((<$>))+import DataCon (DataCon)+ import Control.Monad.Reader import Control.Monad.State import Data.Bifunctor import Data.Maybe-import Data.Monoid ++import Control.Monad.Except (catchError)+import TypeRep (Type(TyConApp))+ import qualified Control.Exception   as Ex import qualified Data.List           as L import qualified Data.HashMap.Strict as M import qualified Data.HashSet        as S -import Language.Fixpoint.Misc-import Language.Fixpoint.Names (takeWhileSym, nilName, consName)-import Language.Fixpoint.Types+import Language.Fixpoint.Misc (thd3) -import Language.Haskell.Liquid.Dictionaries-import Language.Haskell.Liquid.GhcMisc (getSourcePosE, getSourcePos, sourcePosSrcSpan)-import Language.Haskell.Liquid.PredType (makeTyConInfo)-import Language.Haskell.Liquid.RefType+import Language.Fixpoint.Types hiding (Error)++import Language.Haskell.Liquid.Types.Dictionaries+import Language.Haskell.Liquid.GHC.Misc (showPpr, getSourcePosE, getSourcePos, sourcePosSrcSpan, isDataConId)+import Language.Haskell.Liquid.Types.PredType (makeTyConInfo)+import Language.Haskell.Liquid.Types.RefType import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.Misc (mapSnd) import Language.Haskell.Liquid.WiredIn-import Language.Haskell.Liquid.Visitors-import Language.Haskell.Liquid.CoreToLogic ++ import qualified Language.Haskell.Liquid.Measure as Ms  import Language.Haskell.Liquid.Bare.Check@@ -48,6 +56,7 @@ import Language.Haskell.Liquid.Bare.Env import Language.Haskell.Liquid.Bare.Existential import Language.Haskell.Liquid.Bare.Measure+import Language.Haskell.Liquid.Bare.Axiom import Language.Haskell.Liquid.Bare.Misc (makeSymbols, mkVarExpr) import Language.Haskell.Liquid.Bare.Plugged import Language.Haskell.Liquid.Bare.RTEnv@@ -56,18 +65,23 @@ import Language.Haskell.Liquid.Bare.RefToLogic import Language.Haskell.Liquid.Bare.Lookup (lookupGhcTyCon) ------------------------------------------------------------------------------ Top Level Output -----------------------------------------------------------------------------------------------------------makeGhcSpec :: Config -> ModName -> [CoreBind] -> [Var] -> [Var] -> NameSet -> HscEnv -> Either Error LogicMap+--------------------------------------------------------------------------------+makeGhcSpec :: Config+            -> ModName+            -> [CoreBind]+            -> [Var]+            -> [Var]+            -> NameSet+            -> HscEnv+            -> Either Error LogicMap             -> [(ModName,Ms.BareSpec)]             -> IO GhcSpec+-------------------------------------------------------------------------------- makeGhcSpec cfg name cbs vars defVars exports env lmap specs    = do sp <- throwLeft =<< execBare act initEnv-       let renv = ghcSpecEnv sp cbs-       throwLeft $ checkGhcSpec specs renv $ postProcess cbs renv sp+       let renv = ghcSpecEnv sp+       throwLeft . checkGhcSpec specs renv $ postProcess cbs renv sp   where     act       = makeGhcSpec' cfg cbs vars defVars exports specs     throwLeft = either Ex.throw return@@ -80,58 +94,114 @@   where     x  = symbol "x"     xs = symbol "xs"-    hNil    = EApp (dummyLoc $ symbol nilDataCon ) []-    hCons   = EApp (dummyLoc $ symbol consDataCon) +    hNil    = mkEApp (dummyLoc $ symbol nilDataCon ) []+    hCons   = mkEApp (dummyLoc $ symbol consDataCon)  postProcess :: [CoreBind] -> SEnv SortedReft -> GhcSpec -> GhcSpec-postProcess cbs specEnv sp@(SP {..}) = sp { tySigs = tySigs', texprs = ts, asmSigs = asmSigs', dicts = dicts' }-  -- HEREHEREHEREHERE (addTyConInfo stuff)+postProcess cbs specEnv sp@(SP {..})+  = sp { tySigs = tySigs', texprs = ts, asmSigs = asmSigs', dicts = dicts', invariants = invs', meas = meas', inSigs = inSigs' }   where-    (sigs, ts) = replaceLocalBinds tcEmbeds tyconEnv tySigs texprs specEnv cbs-    tySigs'  = mapSnd (addTyConInfo tcEmbeds tyconEnv <$>) <$> sigs-    asmSigs' = mapSnd (addTyConInfo tcEmbeds tyconEnv <$>) <$> asmSigs-    dicts'   = dmapty (addTyConInfo tcEmbeds tyconEnv) dicts+    (sigs, ts')   = replaceLocalBinds tcEmbeds tyconEnv tySigs texprs specEnv cbs+    (assms, ts'') = replaceLocalBinds tcEmbeds tyconEnv asmSigs ts'   specEnv cbs+    (insigs, ts)  = replaceLocalBinds tcEmbeds tyconEnv inSigs  ts''  specEnv cbs+    tySigs'     = mapSnd (addTyConInfo tcEmbeds tyconEnv <$>) <$> sigs+    asmSigs'    = mapSnd (addTyConInfo tcEmbeds tyconEnv <$>) <$> assms+    inSigs'     = mapSnd (addTyConInfo tcEmbeds tyconEnv <$>) <$> insigs+    dicts'      = dmapty (addTyConInfo tcEmbeds tyconEnv) dicts+    invs'       = (addTyConInfo tcEmbeds tyconEnv <$>) <$> invariants+    meas'       = mapSnd (fmap (addTyConInfo tcEmbeds tyconEnv) . txRefSort tyconEnv tcEmbeds) <$> meas -ghcSpecEnv sp cbs    = fromListSEnv binds+ghcSpecEnv :: GhcSpec -> SEnv SortedReft+ghcSpecEnv sp        = fromListSEnv binds   where     emb              = tcEmbeds sp     binds            =  [(x,        rSort t) | (x, Loc _ _ t) <- meas sp]                      ++ [(symbol v, rSort t) | (v, Loc _ _ t) <- ctors sp]                      ++ [(x,        vSort v) | (x, v) <- freeSyms sp, isConLikeId v]-                     ++ [(val x   , rSort stringrSort) | Just (ELit x s) <- mkLit <$> lconsts, isString s]+                     -- ++ [(val x   , rSort stringrSort) | Just (ELit x s) <- mkLit <$> lconsts, isString s]     rSort            = rTypeSortedReft emb     vSort            = rSort . varRSort     varRSort         :: Var -> RSort     varRSort         = ofType . varType-    lconsts          = literals cbs-    stringrSort      :: RSort-    stringrSort      = ofType stringTy-    isString s       = rTypeSort emb stringrSort == s+    --lconsts          = literals cbs+    --stringrSort      :: RSort+    --stringrSort      = ofType stringTy+    --isString s       = rTypeSort emb stringrSort == s  ------------------------------------------------------------------------------------------------ makeGhcSpec' :: Config -> [CoreBind] -> [Var] -> [Var] -> NameSet -> [(ModName, Ms.BareSpec)] -> BareM GhcSpec ------------------------------------------------------------------------------------------------ makeGhcSpec' cfg cbs vars defVars exports specs   = do name          <- modName <$> get-       makeBounds name defVars cbs specs        makeRTEnv  specs-       (tycons, datacons, dcSs, tyi, embs)     <- makeGhcSpecCHOP1 specs+       (tycons, datacons, dcSs, recSs, tyi, embs) <- makeGhcSpecCHOP1 specs+       makeBounds embs name defVars cbs specs        modify                                   $ \be -> be { tcEnv = tyi }        (cls, mts)                              <- second mconcat . unzip . mconcat <$> mapM (makeClasses name cfg vars) specs        (measures, cms', ms', cs', xs')         <- makeGhcSpecCHOP2 cbs specs dcSs datacons cls embs        (invs, ialias, sigs, asms)              <- makeGhcSpecCHOP3 cfg vars defVars specs name mts embs-       syms                                    <- makeSymbols (vars ++ map fst cs') xs' (sigs ++ asms ++ cs') ms' (invs ++ (snd <$> ialias))+       syms                                    <- makeSymbols (varInModule name) (vars ++ map fst cs') xs' (sigs ++ asms ++ cs') ms' (invs ++ (snd <$> ialias))        let su  = mkSubst [ (x, mkVarExpr v) | (x, v) <- syms]-       return (emptySpec cfg)-         >>= makeGhcSpec0 cfg defVars exports name-         >>= makeGhcSpec1 vars embs tyi exports name sigs asms cs' ms' cms' su+       makeGhcSpec0 cfg defVars exports name (emptySpec cfg)+         >>= makeGhcSpec1 vars defVars embs tyi exports name sigs (recSs ++ asms) cs' ms' cms' su          >>= makeGhcSpec2 invs ialias measures su-         >>= makeGhcSpec3 datacons tycons embs syms-         >>= makeGhcSpec4 defVars specs name su+         >>= makeGhcSpec3 (datacons ++ cls) tycons embs syms          >>= makeSpecDictionaries embs vars specs+         >>= makeGhcAxioms embs cbs name specs+         >>= makeExactDataCons name (exactDC cfg) (snd <$> syms)+         -- This step need the updated logic map, ie should happen after makeGhcAxioms+         >>= makeGhcSpec4 defVars specs name su+         >>= addProofType ++addProofType :: GhcSpec -> BareM GhcSpec+addProofType spec+  = do tycon <- (Just <$> (lookupGhcTyCon $ dummyLoc proofTyConName)) `catchError` (\_ -> return Nothing)+       return $ spec {proofType = (`TyConApp` []) <$> tycon}+++makeExactDataCons :: ModName -> Bool -> [Var] -> GhcSpec -> BareM GhcSpec+makeExactDataCons n flag vs spec+  | flag      = return $ spec {tySigs = (tySigs spec) ++ xts}+  | otherwise = return spec+  where+    xts = makeExact <$> (filter isDataConId $ filter (varInModule n) vs)++varInModule n v = L.isPrefixOf (show n) $ show v++makeExact :: Var -> (Var, Located SpecType)+makeExact x = (x, dummyLoc . fromRTypeRep $ trep{ty_res = res, ty_binds = xs})+  where+    t    :: SpecType+    t    = ofType $ varType x+    trep = toRTypeRep t+    xs   = zipWith (\_ i -> (symbol ("x" ++ show i))) (ty_args trep) [1..]++    res  = ty_res trep `strengthen` MkUReft ref mempty mempty+    vv   = vv_+    x'   = symbol x --  simpleSymbolVar x+    ref  = Reft (vv, PAtom Eq (EVar vv) eq)+    eq   | null (ty_vars trep) && null xs = EVar x'+         | otherwise = mkEApp (dummyLoc x') (EVar <$> xs)+++makeGhcAxioms :: TCEmb TyCon -> [CoreBind] -> ModName -> [(ModName, Ms.BareSpec)] -> GhcSpec -> BareM GhcSpec+makeGhcAxioms tce cbs name bspecs sp = makeAxioms tce cbs sp spec+  where+    spec = fromMaybe mempty $ lookup name bspecs++makeAxioms :: TCEmb TyCon -> [CoreBind] -> GhcSpec -> Ms.BareSpec -> BareM GhcSpec+makeAxioms tce cbs spec sp+  = do lmap          <- logicEnv <$> get+       (ms, tys, as) <- unzip3 <$> mapM (makeAxiom tce lmap cbs spec sp) (S.toList $ Ms.axioms sp)+       lmap'         <- logicEnv <$> get+       return $ spec { meas     = ms         ++  meas   spec+                     , asmSigs  = concat tys ++ asmSigs spec+                     , axioms   = concat as  ++ axioms spec+                     , logicMap = lmap' }+ emptySpec     :: Config -> GhcSpec-emptySpec cfg = SP [] [] [] [] [] [] [] [] [] mempty [] [] [] [] mempty mempty mempty cfg mempty [] mempty mempty+emptySpec cfg = SP [] [] [] [] [] [] [] [] [] [] mempty [] [] [] [] mempty mempty mempty cfg mempty [] mempty mempty [] mempty Nothing   makeGhcSpec0 cfg defVars exports name sp@@ -140,20 +210,21 @@                         , exports = exports                         , tgtVars = targetVars } -makeGhcSpec1 vars embs tyi exports name sigs asms cs' ms' cms' su sp+makeGhcSpec1 vars defVars embs tyi exports name sigs asms cs' ms' cms' su sp   = do tySigs      <- makePluggedSigs name embs tyi exports $ tx sigs        asmSigs     <- makePluggedAsmSigs embs tyi $ tx asms        ctors       <- makePluggedAsmSigs embs tyi $ tx cs'        lmap        <- logicEnv <$> get        inlmap      <- inlines  <$> get        let ctors'   = [ (x, txRefToLogic lmap inlmap <$> t) | (x, t) <- ctors ]-       return $ sp { tySigs     = tySigs-                   , asmSigs    = asmSigs-                   , ctors      = ctors'+       return $ sp { tySigs     = filter (\(v,_) -> v `elem` vs) tySigs+                   , asmSigs    = filter (\(v,_) -> v `elem` vs) asmSigs+                   , ctors      = filter (\(v,_) -> v `elem` vs) ctors'                    , meas       = tx' $ tx $ ms' ++ varMeasures vars ++ cms' }     where       tx   = fmap . mapSnd . subst $ su       tx'  = fmap (mapSnd $ fmap uRType)+      vs   = vars ++ defVars  makeGhcSpec2 invs ialias measures su sp   = return $ sp { invariants = subst su invs@@ -163,8 +234,9 @@                                   ++ Ms.imeas measures                 } +makeGhcSpec3 :: [(DataCon, DataConP)] -> [(TyCon, TyConP)] -> TCEmb TyCon -> [(t, Var)] -> GhcSpec -> BareM GhcSpec makeGhcSpec3 datacons tycons embs syms sp-  = do tcEnv       <- gets tcEnv+  = do tcEnv       <- tcEnv    <$> get         lmap        <- logicEnv <$> get        inlmap      <- inlines  <$> get        let dcons'   = mapSnd (txRefToLogic lmap inlmap) <$> datacons@@ -179,10 +251,10 @@        texprs' <- mconcat <$> mapM (makeTExpr defVars . snd) specs        lazies  <- mkThing makeLazy        lvars'  <- mkThing makeLVar-       asize'  <- S.fromList <$> makeASize  +       asize'  <- S.fromList <$> makeASize        hmeas   <- mkThing makeHIMeas        quals   <- mconcat <$> mapM makeQualifiers specs-       let sigs = strengthenHaskellMeasures hmeas ++ tySigs sp+       let msgs = strengthenHaskellMeasures hmeas        lmap    <- logicEnv <$> get        inlmap  <- inlines  <$> get        let tx   = mapSnd (fmap $ txRefToLogic lmap inlmap)@@ -193,9 +265,10 @@                      , lvars      = lvars'                      , autosize   = asize'                      , lazy       = lazies-                     , tySigs     = tx  <$> sigs-                     , asmSigs    = tx  <$> (asmSigs sp)-                     , measures   = mtx <$> (measures sp)+                     , tySigs     = tx  <$> tySigs  sp +                     , asmSigs    = tx  <$> asmSigs sp+                     , measures   = mtx <$> measures sp+                     , inSigs     = tx  <$> msgs                       }     where        mkThing mk = S.fromList . mconcat <$> sequence [ mk defVars s | (m, s) <- specs, m == name ]@@ -207,8 +280,9 @@        let tyi          = makeTyConInfo tycons        embs            <- mconcat <$> mapM makeTyConEmbeds specs        datacons        <- makePluggedDataCons embs tyi (concat dcs ++ wiredDataCons)-       let dcSelectors  = concat $ map makeMeasureSelectors datacons-       return           $ (tycons, second val <$> datacons, dcSelectors, tyi, embs)+       let dcSelectors  = concatMap makeMeasureSelectors datacons+       recSels         <- makeRecordSelectorSigs datacons+       return             (tycons, second val <$> datacons, dcSelectors, recSels, tyi, embs)  makeGhcSpecCHOP3 cfg vars defVars specs name mts embs   = do sigs'   <- mconcat <$> mapM (makeAssertSpec name cfg vars defVars) specs@@ -217,26 +291,30 @@        ialias  <- mconcat <$> mapM makeIAliases   specs        let dms  = makeDefaultMethods vars mts        tyi     <- gets tcEnv-       let sigs = [ (x, txRefSort tyi embs . txExpToBind <$> t) | (_, x, t) <- sigs' ++ mts ++ dms ]-       let asms = [ (x, txRefSort tyi embs . txExpToBind <$> t) | (_, x, t) <- asms' ]+       let sigs = [ (x, txRefSort tyi embs $ fmap txExpToBind t) | (_, x, t) <- sigs' ++ mts ++ dms ]+       let asms = [ (x, txRefSort tyi embs $ fmap txExpToBind t) | (_, x, t) <- asms' ]        return     (invs, ialias, sigs, asms) + makeGhcSpecCHOP2 cbs specs dcSelectors datacons cls embs-  = do measures'       <- mconcat <$> mapM makeMeasureSpec specs-       tyi             <- gets tcEnv-       name            <- gets modName-       mapM_ (makeHaskellInlines  cbs name) specs-       hmeans          <- mapM (makeHaskellMeasures cbs name) specs-       let measures     = mconcat (Ms.wiredInMeasures:measures':Ms.mkMSpec' dcSelectors:hmeans)-       let (cs, ms)     = makeMeasureSpec' measures-       let cms          = makeClassMeasureSpec measures-       let cms'         = [ (x, Loc l l' $ cSort t) | (Loc l l' x, t) <- cms ]-       let ms'          = [ (x, Loc l l' t) | (Loc l l' x, t) <- ms, isNothing $ lookup x cms' ]-       let cs'          = [ (v, Loc (getSourcePos v) (getSourcePosE v) (txRefSort tyi embs t)) | (v, t) <- meetDataConSpec cs (datacons ++ cls)]-       let xs'          = val . fst <$> ms+  = do measures'   <- mconcat <$> mapM makeMeasureSpec specs+       tyi         <- gets tcEnv+       name        <- gets modName+       mapM_ (makeHaskellInlines embs cbs name) specs+       hmeans      <- mapM (makeHaskellMeasures embs cbs name) specs+       let measures = mconcat (Ms.wiredInMeasures:measures':Ms.mkMSpec' dcSelectors:hmeans)+       let (cs, ms) = makeMeasureSpec' measures+       let cms      = makeClassMeasureSpec measures+       let cms'     = [ (x, Loc l l' $ cSort t) | (Loc l l' x, t) <- cms ]+       let ms'      = [ (x, Loc l l' t) | (Loc l l' x, t) <- ms, isNothing $ lookup x cms' ]+       let cs'      = [ (v, txRefSort' v tyi embs t) | (v, t) <- meetDataConSpec cs (datacons ++ cls)]+       let xs'      = val . fst <$> ms        return (measures, cms', ms', cs', xs') +txRefSort' v tyi embs t = txRefSort tyi embs (atLoc' v t) +atLoc' v = Loc (getSourcePos v) (getSourcePosE v)+ data ReplaceEnv = RE { _re_env  :: M.HashMap Symbol Symbol                      , _re_fenv :: SEnv SortedReft                      , _re_emb  :: TCEmb TyCon@@ -282,14 +360,19 @@   mapM_ traverseExprs (rhssOfBind b)   k +-- RJ: this function is incomprehensible, what does it do?! withExtendedEnv vs k   = do RE env' fenv' emb tyi <- ask-       let env  = L.foldl' (\m v -> M.insert (takeWhileSym (/='#') $ symbol v) (symbol v) m) env' vs+       let env  = L.foldl' (\m v -> M.insert (varShortSymbol v) (symbol v) m) env' vs            fenv = L.foldl' (\m v -> insertSEnv (symbol v) (rTypeSortedReft emb (ofType $ varType v :: RSort)) m) fenv' vs        withReaderT (const (RE env fenv emb tyi)) $ do          mapM_ replaceLocalBindsOne vs          k +varShortSymbol :: Var -> Symbol+varShortSymbol = symbol . takeWhile (/= '#') . showPpr . getName++-- RJ: this function is incomprehensible replaceLocalBindsOne :: Var -> ReplaceM () replaceLocalBindsOne v   = do mt <- gets (M.lookup v . fst)@@ -298,12 +381,12 @@          Just (Loc l l' (toRTypeRep -> t@(RTypeRep {..}))) -> do            (RE env' fenv emb tyi) <- ask            let f m k = M.lookupDefault k k m-           let (env,args) = L.mapAccumL (\e (v,t) -> (M.insert v v e, substa (f e) t))+           let (env,args) = L.mapAccumL (\e (v, t) -> (M.insert v v e, substa (f e) t))                              env' (zip ty_binds ty_args)            let res  = substa (f env) ty_res            let t'   = fromRTypeRep $ t { ty_args = args, ty_res = res }            let msg  = ErrTySpec (sourcePosSrcSpan l) (pprint v) t'-           case checkTy msg emb tyi fenv t' of+           case checkTy msg emb tyi fenv (Loc l l' t') of              Just err -> Ex.throw err              Nothing -> modify (first $ M.insert v (Loc l l' t'))            mes <- gets (M.lookup v . snd)
src/Language/Haskell/Liquid/Bare/Lookup.hs view
@@ -12,6 +12,7 @@   , lookupGhcDataCon   ) where +import Prelude hiding (error) import BasicTypes import ConLike import DataCon@@ -27,7 +28,7 @@ import TysWiredIn import Var -import Control.Monad.Error (catchError, throwError)+import Control.Monad.Except (catchError, throwError) import Control.Monad.State import Data.Maybe import Text.PrettyPrint.HughesPJ (text)@@ -35,10 +36,10 @@ import qualified Data.List           as L import qualified Data.HashMap.Strict as M -import Language.Fixpoint.Names (hpropConName, isPrefixOfSym, lengthSym, propConName, symbolString)+import Language.Fixpoint.Types.Names (hpropConName, isPrefixOfSym, lengthSym, propConName, symbolString) import Language.Fixpoint.Types (Symbol, Symbolic(..)) -import Language.Haskell.Liquid.GhcMisc (lookupRdrName, sourcePosSrcSpan, tcRnLookupRdrName)+import Language.Haskell.Liquid.GHC.Misc (lookupRdrName, sourcePosSrcSpan, tcRnLookupRdrName) import Language.Haskell.Liquid.Types import Language.Haskell.Liquid.WiredIn @@ -61,6 +62,7 @@   srcSpan        = nameSrcSpan  + -- lookupGhcThing :: (GhcLookup a) => String -> (TyThing -> Maybe b) -> a -> BareM b lookupGhcThing name f x   = do zs <- lookupGhcThing' name f x@@ -87,7 +89,7 @@   = symbolLookupEnv env mod k  wiredIn      :: M.HashMap Symbol Name-wiredIn      = M.fromList $ special ++ wiredIns +wiredIn      = M.fromList $ special ++ wiredIns   where     wiredIns = [ (symbol n, n) | thing <- wiredInThings, let n = getName thing ]     special  = [ ("GHC.Integer.smallInteger", smallIntegerName)@@ -131,11 +133,11 @@ lookupGhcTyCon       ::  GhcLookup a => a -> BareM TyCon lookupGhcTyCon s     = (lookupGhcThing "type constructor or class" ftc s)                        `catchError` (tryPropTyCon s)-  where +  where     ftc (ATyCon x)   = Just x     ftc _            = Nothing -tryPropTyCon s e   +tryPropTyCon s e   | sx == propConName  = return propTyCon   | sx == hpropConName = return hpropTyCon   | otherwise          = throwError e@@ -159,7 +161,6 @@   = Nothing  lookupGhcDataCon'    = lookupGhcThing "data constructor" fdc-  where +  where     fdc (AConLike (RealDataCon x)) = Just x     fdc _            = Nothing-
src/Language/Haskell/Liquid/Bare/Measure.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts         #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} @@ -6,34 +6,31 @@     makeHaskellMeasures   , makeHaskellInlines   , makeHaskellBounds-   , makeMeasureSpec   , makeMeasureSpec'-   , makeClassMeasureSpec   , makeMeasureSelectors-   , strengthenHaskellMeasures-   , varMeasures   ) where  import CoreSyn import DataCon+import TyCon import Id import Name import Type hiding (isFunTy) import Var -import Prelude hiding (mapM)-import Control.Applicative ((<$>), (<*>))+import Prelude hiding (mapM, error)+import Control.Arrow ((&&&)) import Control.Monad hiding (forM, mapM)-import Control.Monad.Error hiding (Error, forM, mapM)+import Control.Monad.Except hiding (forM, mapM) import Control.Monad.State hiding (forM, mapM) import Data.Bifunctor import Data.Maybe import Data.Char (toUpper)-import Data.Monoid+ import Data.Traversable (forM, mapM) import Text.PrettyPrint.HughesPJ (text) import Text.Parsec.Pos (SourcePos)@@ -43,17 +40,18 @@ import qualified Data.HashMap.Strict as M import qualified Data.HashSet        as S -import Language.Fixpoint.Misc-import Language.Fixpoint.Names-import Language.Fixpoint.Types (Expr(..))+import Language.Fixpoint.Misc (mlookup, sortNub)+import Language.Fixpoint.Types (Symbol, dummySymbol, symbolString, symbol, Expr(..))+import Language.Fixpoint.SortCheck (isFirstOrder)+ import qualified Language.Fixpoint.Types as F -import Language.Haskell.Liquid.CoreToLogic-import Language.Haskell.Liquid.Misc    (mapSndM)-import Language.Haskell.Liquid.GhcMisc (getSourcePos, getSourcePosE, sourcePosSrcSpan, isDataConId)-import Language.Haskell.Liquid.RefType (dataConSymbol, generalize, ofType, uRType)+import Language.Haskell.Liquid.Transforms.CoreToLogic+import Language.Haskell.Liquid.Misc+import Language.Haskell.Liquid.GHC.Misc (dropModuleNames, getSourcePos, getSourcePosE, sourcePosSrcSpan, isDataConId)+import Language.Haskell.Liquid.Types.RefType (generalize, ofType, uRType, typeSort) import Language.Haskell.Liquid.Types-import Language.Haskell.Liquid.Bounds+import Language.Haskell.Liquid.Types.Bounds  import qualified Language.Haskell.Liquid.Measure as Ms @@ -65,88 +63,91 @@ import Language.Haskell.Liquid.Bare.Resolve import Language.Haskell.Liquid.Bare.RefToLogic -makeHaskellMeasures :: [CoreBind] -> ModName -> (ModName, Ms.BareSpec) -> BareM (Ms.MSpec SpecType DataCon)-makeHaskellMeasures _   name' (name, _   ) | name /= name'+makeHaskellMeasures :: F.TCEmb TyCon -> [CoreBind] -> ModName -> (ModName, Ms.BareSpec) -> BareM (Ms.MSpec SpecType DataCon)+makeHaskellMeasures _   _   name' (name, _   ) | name /= name'   = return mempty-makeHaskellMeasures cbs _     (_   , spec)+makeHaskellMeasures tce cbs _     (_   , spec)   = do lmap <- gets logicEnv-       Ms.mkMSpec' <$> mapM (makeMeasureDefinition lmap cbs') (S.toList $ Ms.hmeas spec)+       Ms.mkMSpec' <$> mapM (makeMeasureDefinition tce lmap cbs') (S.toList $ Ms.hmeas spec)   where     cbs'                  = concatMap unrec cbs     unrec cb@(NonRec _ _) = [cb]     unrec (Rec xes)       = [NonRec x e | (x, e) <- xes] --makeHaskellInlines :: [CoreBind] -> ModName -> (ModName, Ms.BareSpec) -> BareM ()-makeHaskellInlines _   name' (name, _   ) | name /= name'+makeHaskellInlines :: F.TCEmb TyCon -> [CoreBind] -> ModName -> (ModName, Ms.BareSpec) -> BareM ()+makeHaskellInlines _   _   name' (name, _   ) | name /= name'   = return mempty-makeHaskellInlines cbs _     (_   , spec)+makeHaskellInlines tce cbs _     (_   , spec)   = do lmap <- gets logicEnv-       mapM_ (makeMeasureInline lmap cbs') (S.toList $ Ms.inlines spec)+       mapM_ (makeMeasureInline tce lmap cbs') (S.toList $ Ms.inlines spec)   where     cbs'                  = concatMap unrec cbs     unrec cb@(NonRec _ _) = [cb]     unrec (Rec xes)       = [NonRec x e | (x, e) <- xes] --makeMeasureInline :: LogicMap -> [CoreBind] ->  LocSymbol -> BareM ()-makeMeasureInline lmap cbs  x-  = case (filter ((val x `elem`) . (map (dropModuleNames . simplesymbol)) . binders) cbs) of-    (NonRec v def:_)   -> do {e <- coreToFun' x v def; updateInlines x e}-    (Rec [(v, def)]:_) -> do {e <- coreToFun' x v def; updateInlines x e}+makeMeasureInline :: F.TCEmb TyCon -> LogicMap -> [CoreBind] ->  LocSymbol -> BareM ()+makeMeasureInline tce lmap cbs  x+  = case filter ((val x `elem`) . map (dropModuleNames . simplesymbol) . binders) cbs of+    (NonRec v def:_)   -> do {e <- coreToFun' tce x v def; updateInlines x e}+    (Rec [(v, def)]:_) -> do {e <- coreToFun' tce x v def; updateInlines x e}     _                  -> throwError $ mkError "Cannot inline haskell function"   where-    binders (NonRec x _) = [x]+    binders (NonRec z _) = [z]     binders (Rec xes)    = fst <$> xes -    coreToFun' x v def = case (runToLogic lmap mkError $ coreToFun x v def) of-                           Left (xs, e)  -> return (TI (symbol <$> xs) e)+    coreToFun' tce x v def = case runToLogic tce lmap mkError $ coreToFun x v def of+                           Left (xs, e)  -> return (TI (symbol <$> xs) (fromLR e))                            Right e -> throwError e -    mkError :: String -> Error-    mkError str = ErrHMeas (sourcePosSrcSpan $ loc x) (val x) (text str)+    fromLR (Left l)  = l +    fromLR (Right r) = r +    mkError :: String -> Error+    mkError str = ErrHMeas (sourcePosSrcSpan $ loc x) (pprint $ val x) (text str)   updateInlines x v = modify $ \s -> let iold  = M.insert (val x) v (inlines s) in                                    s{inlines = M.map (f iold) iold }-  where f imap = txRefToLogic mempty imap-+  where+    f             = txRefToLogic mempty -makeMeasureDefinition :: LogicMap -> [CoreBind] -> LocSymbol -> BareM (Measure SpecType DataCon)-makeMeasureDefinition lmap cbs x-  = case (filter ((val x `elem`) . (map (dropModuleNames . simplesymbol)) . binders) cbs) of-    (NonRec v def:_)   -> (Ms.mkM x (logicType $ varType v)) <$> coreToDef' x v def-    (Rec [(v, def)]:_) -> (Ms.mkM x (logicType $ varType v)) <$> coreToDef' x v def+makeMeasureDefinition :: F.TCEmb TyCon -> LogicMap -> [CoreBind] -> LocSymbol -> BareM (Measure SpecType DataCon)+makeMeasureDefinition tce lmap cbs x+  = case filter ((val x `elem`) . map (dropModuleNames . simplesymbol) . binders) cbs of+    (NonRec v def:_)   -> Ms.mkM x (logicType $ varType v) <$> coreToDef' x v def+    (Rec [(v, def)]:_) -> Ms.mkM x (logicType $ varType v) <$> coreToDef' x v def     _                  -> throwError $ mkError "Cannot extract measure from haskell function"   where     binders (NonRec x _) = [x]     binders (Rec xes)    = fst <$> xes -    coreToDef' x v def = case (runToLogic lmap mkError $ coreToDef x v def) of+    coreToDef' x v def = case runToLogic tce lmap mkError $ coreToDef x v def of                            Left l  -> return     l                            Right e -> throwError e      mkError :: String -> Error-    mkError str = ErrHMeas (sourcePosSrcSpan $ loc x) (val x) (text str)+    mkError str = ErrHMeas (sourcePosSrcSpan $ loc x) (pprint $ val x) (text str) +simplesymbol :: CoreBndr -> Symbol simplesymbol = symbol . getName  strengthenHaskellMeasures :: S.HashSet (Located Var) -> [(Var, Located SpecType)]-strengthenHaskellMeasures hmeas = (\v -> (val v, fmap strengthenResult v)) <$> (S.toList hmeas)+strengthenHaskellMeasures hmeas+  = (val &&& fmap strengthenResult) <$> S.toList hmeas  makeMeasureSelectors :: (DataCon, Located DataConP) -> [Measure SpecType DataCon]-makeMeasureSelectors (dc, (Loc l l' (DataConP _ vs _ _ _ xts r _))) = catMaybes (go <$> zip (reverse xts) [1..])+makeMeasureSelectors (dc, Loc l l' (DataConP _ vs _ _ _ xts r _))+  = catMaybes (go <$> zip (reverse xts) [1..])   where     go ((x,t), i)       | isFunTy t = Nothing-      | True      = Just $ makeMeasureSelector (Loc l l' x) (dty t) dc n i+      | otherwise = Just $ makeMeasureSelector (Loc l l' x) (dty t) dc n i      dty t         = foldr RAllT  (RFun dummySymbol r (fmap mempty t) mempty) vs     n             = length xts  makeMeasureSelector x s dc n i = M {name = x, sort = s, eqns = [eqn]}-  where eqn   = Def x [] dc Nothing (((, Nothing) . mkx) <$> [1 .. n]) (E (EVar $ mkx i)) +  where eqn   = Def x [] dc Nothing (((, Nothing) . mkx) <$> [1 .. n]) (E (EVar $ mkx i))         mkx j = symbol ("xx" ++ show j)  @@ -154,9 +155,9 @@ makeMeasureSpec (mod,spec) = inModule mod mkSpec   where     mkSpec = mkMeasureDCon =<< mkMeasureSort =<< m-    m      = Ms.mkMSpec <$> (mapM expandMeasure $ Ms.measures spec)+    m      = Ms.mkMSpec <$> mapM expandMeasure (Ms.measures spec)                         <*> return (Ms.cmeasures spec)-                        <*> (mapM expandMeasure $ Ms.imeasures spec)+                        <*> mapM expandMeasure (Ms.imeasures spec)  makeMeasureSpec' = mapFst (mapSnd uRType <$>) . Ms.dataConTypes . first (mapReft ur_reft) @@ -167,16 +168,16 @@   mkMeasureDCon :: Ms.MSpec t LocSymbol -> BareM (Ms.MSpec t DataCon)-mkMeasureDCon m = (forM (measureCtors m) $ \n -> (val n,) <$> lookupGhcDataCon n)-                  >>= (return . mkMeasureDCon_ m)+mkMeasureDCon m+  = mkMeasureDCon_ m <$> forM (measureCtors m)+                           (\n -> (val n,) <$> lookupGhcDataCon n)  mkMeasureDCon_ :: Ms.MSpec t LocSymbol -> [(Symbol, DataCon)] -> Ms.MSpec t DataCon mkMeasureDCon_ m ndcs = m' {Ms.ctorMap = cm'}   where     m'  = fmap (tx.val) m-    cm' = hashMapMapKeys (tx' . tx) $ Ms.ctorMap m'+    cm' = hashMapMapKeys (symbol . tx) $ Ms.ctorMap m'     tx  = mlookup (M.fromList ndcs)-    tx' = dataConSymbol  measureCtors ::  Ms.MSpec t LocSymbol -> [LocSymbol] measureCtors = sortNub . fmap ctor . concat . M.elems . Ms.ctorMap@@ -186,51 +187,58 @@   = Ms.MSpec <$> forM c (mapM txDef) <*> forM mm tx <*> forM cm tx <*> forM im tx     where       tx :: Measure BareType ctor -> BareM (Measure SpecType ctor)-      tx (M n s eqs) = M n <$> (ofMeaSort s) <*> (mapM txDef eqs)+      tx (M n s eqs) = M n <$> ofMeaSort s <*> mapM txDef eqs        txDef :: Def BareType ctor -> BareM (Def SpecType ctor)-      txDef def = liftM3 (\xs t bds-> def{ dparams = xs, dsort = t, binds = bds}) +      txDef def = liftM3 (\xs t bds-> def{ dparams = xs, dsort = t, binds = bds})                   (mapM (mapSndM ofMeaSort) (dparams def))                   (mapM ofMeaSort $ dsort def)                   (mapM (mapSndM $ mapM ofMeaSort) (binds def))  -varMeasures vars = [ (symbol v, varSpecType v)  | v <- vars, isDataConId v, isSimpleType $ varType v ]+varMeasures :: (Monoid r) => [Var] -> [(Symbol, Located (RRType r))]+varMeasures vars = [ (symbol v, varSpecType v)  | v <- vars+                                                , isDataConId v+                                                , isSimpleType $ varType v ] -isSimpleType t   = null tvs && isNothing (splitFunTy_maybe tb)-  where-    (tvs, tb)    = splitForAllTys t+isSimpleType :: Type -> Bool+isSimpleType = isFirstOrder . typeSort M.empty +-- OLD isSimpleType t   = null tvs && isNothing (splitFunTy_maybe tb)+-- OLD  where+-- OLD    (tvs, tb)    = splitForAllTys t++varSpecType :: (Monoid r) => Var -> Located (RRType r) varSpecType v    = Loc l l' (ofType $ varType v)   where     l            = getSourcePos  v     l'           = getSourcePosE v  -makeHaskellBounds :: CoreProgram -> S.HashSet (Var, LocSymbol) -> BareM RBEnv-makeHaskellBounds cbs xs+makeHaskellBounds :: F.TCEmb TyCon -> CoreProgram -> S.HashSet (Var, LocSymbol) -> BareM RBEnv+makeHaskellBounds tce cbs xs   = do lmap <- gets logicEnv-       M.fromList <$> mapM (makeHaskellBound lmap cbs) (S.toList xs)+       M.fromList <$> mapM (makeHaskellBound tce lmap cbs) (S.toList xs)  -makeHaskellBound lmap  cbs (v, x) = case filter ((v  `elem`) . binders) cbs of-    (NonRec v def:_)   -> do {e <- coreToFun' x v def; return $ toBound v x e}-    (Rec [(v, def)]:_) -> do {e <- coreToFun' x v def; return $ toBound v x e}+makeHaskellBound tce lmap  cbs (v, x) = case filter ((v  `elem`) . binders) cbs of+    (NonRec v def:_)   -> do {e <- coreToFun' tce x v def; return $ toBound v x e}+    (Rec [(v, def)]:_) -> do {e <- coreToFun' tce x v def; return $ toBound v x e}     _                  -> throwError $ mkError "Cannot make bound of haskell function"    where     binders (NonRec x _) = [x]     binders (Rec xes)    = fst <$> xes -    coreToFun' x v def = case (runToLogic lmap mkError $ coreToFun x v def) of+    coreToFun' tce x v def = case runToLogic tce lmap mkError $ coreToFun x v def of                            Left (xs, e) -> return (xs, e)                            Right e      -> throwError e      mkError :: String -> Error-    mkError str = ErrHMeas (sourcePosSrcSpan $ loc x) (val x) (text str)+    mkError str = ErrHMeas (sourcePosSrcSpan $ loc x) (pprint $ val x) (text str)  -toBound :: Var -> LocSymbol -> ([Var], Either F.Pred F.Expr) -> (LocSymbol, RBound)+toBound :: Var -> LocSymbol -> ([Var], Either F.Expr F.Expr) -> (LocSymbol, RBound) toBound v x (vs, Left p) = (x', Bound x' fvs ps xs p)   where     x'         = capitalizeBound x@@ -238,9 +246,9 @@     (ps , xs)  = (txp <$> ps', txx <$> xs')     txp v      = (dummyLoc $ simpleSymbolVar v, ofType $ varType v)     txx v      = (dummyLoc $ symbol v,          ofType $ varType v)-    fvs        = (((`RVar` mempty) . RTV) <$> (fst $ splitForAllTys $ varType v)) :: [RSort]+    fvs        = (((`RVar` mempty) . RTV) <$> fst (splitForAllTys $ varType v)) :: [RSort] -toBound v x (vs, Right e) = toBound v x (vs, Left $ F.PBexp e)+toBound v x (vs, Right e) = toBound v x (vs, Left e)  capitalizeBound = fmap (symbol . toUpperHead . symbolString)   where@@ -248,11 +256,11 @@     toUpperHead (x:xs) = toUpper x:xs  ----------------------------------------------------------------------------------- Expand Measures -------------------------------------------------------------+-- | Expand Measures ----------------------------------------------------------- --------------------------------------------------------------------------------  expandMeasure m-  = do eqns <- sequence $ expandMeasureDef <$> (eqns m)+  = do eqns <- sequence $ expandMeasureDef <$> eqns m        return $ m { sort = generalize (sort m)                   , eqns = eqns } @@ -262,6 +270,6 @@        return $ d { body = body }  expandMeasureBody :: SourcePos -> Body -> BareM Body-expandMeasureBody l (P p)   = P   <$> (resolve l =<< expandPred p)-expandMeasureBody l (R x p) = R x <$> (resolve l =<< expandPred p)+expandMeasureBody l (P p)   = P   <$> (resolve l =<< expandExpr p)+expandMeasureBody l (R x p) = R x <$> (resolve l =<< expandExpr p) expandMeasureBody l (E e)   = E   <$> resolve l e
src/Language/Haskell/Liquid/Bare/Misc.hs view
@@ -17,7 +17,7 @@   , hasBoolResult   ) where -+import Prelude hiding (error) import TysWiredIn import Name @@ -26,47 +26,53 @@ import TypeRep import Var -import Control.Applicative ((<$>))-import Control.Monad.Error (throwError)+import Control.Monad.Except (throwError) import Control.Monad.State import Data.Maybe (isNothing)  import qualified Data.List as L -import Language.Fixpoint.Names (dropModuleNames)-import Language.Fixpoint.Misc  (sortDiff, sortNub)-import Language.Fixpoint.Types (Symbol, Expr(..), Reft(..), Reftable(..), emptySEnv, memberSEnv, symbol, syms, toReft)+import Language.Fixpoint.Misc  (sortNub)+import Language.Fixpoint.Types (Symbol, Expr(..), Reft(..), Reftable(..), mkEApp, emptySEnv, memberSEnv, symbol, syms, toReft) -import Language.Haskell.Liquid.GhcMisc-import Language.Haskell.Liquid.RefType+import Language.Haskell.Liquid.GHC.Misc+import Language.Haskell.Liquid.Types.RefType import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.Misc (sortDiff)  import Language.Haskell.Liquid.Bare.Env + -- TODO: This is where unsorted stuff is for now. Find proper places for what follows.  -- WTF does this function do?-makeSymbols vs xs' xts yts ivs+makeSymbols f vs xs' xts yts ivs   = do svs <- gets varEnv-       return [ (x,v') | (x,v) <- svs, x `elem` xs, let (v',_,_) = joinVar vs (v,x,x)]+       return $ L.nub ([ (x,v') | (x,v) <- svs, x `elem` xs, let (v',_,_) = joinVar vs (v,x,x)]+                       ++  [ (symbol v, v) | v <- vs, f v, isDataConId v, hasBasicArgs $ varType v ])     where       xs    = sortNub $ zs ++ zs' ++ zs''       zs    = concatMap freeSymbols (snd <$> xts) `sortDiff` xs'       zs'   = concatMap freeSymbols (snd <$> yts) `sortDiff` xs'       zs''  = concatMap freeSymbols ivs           `sortDiff` xs'-      -freeSymbols ty = sortNub $ concat $ efoldReft (\_ _ -> []) (\ _ -> ()) f (\_ -> id) emptySEnv [] (val ty)-  where -    f γ _ r xs = let Reft (v, _) = toReft r in -                 [ x | x <- syms r, x /= v, not (x `memberSEnv` γ)] : xs +      -- arguments should be basic so that autogenerated singleton types are well formed+      hasBasicArgs (ForAllTy _ t) = hasBasicArgs t+      hasBasicArgs (FunTy tx t)   = isBaseTy tx && hasBasicArgs t+      hasBasicArgs _              = True ++freeSymbols ty = sortNub $ concat $ efoldReft (\_ _ -> []) (const ()) f (const id) emptySEnv [] (val ty)+  where+    f γ _ r xs = let Reft (v, _) = toReft r in+                 [ x | x <- syms r, x /= v, not (x `memberSEnv` γ)] : xs+ ------------------------------------------------------------------------------- -- Renaming Type Variables in Haskell Signatures ------------------------------ -------------------------------------------------------------------------------  data MapTyVarST = MTVST { vmap   :: [(Var, RTyVar)]-                        , errmsg :: Error +                        , errmsg :: Error                         }  initMapSt = MTVST []@@ -74,36 +80,36 @@ -- TODO: Maybe don't expose this; instead, roll this in with mapTyVar and export a --       single "clean" function as the API. runMapTyVars :: StateT MapTyVarST (Either Error) () -> MapTyVarST -> Either Error MapTyVarST-runMapTyVars x s = execStateT x s+runMapTyVars = execStateT  mapTyVars :: (PPrint r, Reftable r) => Type -> RRType r -> StateT MapTyVarST (Either Error) ()-mapTyVars τ (RAllT _ t)   +mapTyVars τ (RAllT _ t)   = mapTyVars τ t-mapTyVars (ForAllTy _ τ) t +mapTyVars (ForAllTy _ τ) t   = mapTyVars τ t-mapTyVars (FunTy τ τ') (RFun _ t t' _) +mapTyVars (FunTy τ τ') (RFun _ t t' _)    = mapTyVars τ t  >> mapTyVars τ' t'-mapTyVars (TyConApp _ τs) (RApp _ ts _ _) +mapTyVars (TyConApp _ τs) (RApp _ ts _ _)    = zipWithM_ mapTyVars τs ts-mapTyVars (TyVarTy α) (RVar a _)      +mapTyVars (TyVarTy α) (RVar a _)    = do s  <- get         s' <- mapTyRVar α a s         put s'-mapTyVars τ (RAllP _ t)   -  = mapTyVars τ t -mapTyVars τ (RAllS _ t)   -  = mapTyVars τ t -mapTyVars τ (RAllE _ _ t)   -  = mapTyVars τ t +mapTyVars τ (RAllP _ t)+  = mapTyVars τ t+mapTyVars τ (RAllS _ t)+  = mapTyVars τ t+mapTyVars τ (RAllE _ _ t)+  = mapTyVars τ t mapTyVars τ (RRTy _ _ _ t)   = mapTyVars τ t mapTyVars τ (REx _ _ t)-  = mapTyVars τ t +  = mapTyVars τ t mapTyVars _ (RExprArg _)   = return ()-mapTyVars (AppTy τ τ') (RAppTy t t' _) -  = do  mapTyVars τ t -        mapTyVars τ' t' +mapTyVars (AppTy τ τ') (RAppTy t t' _)+  = do  mapTyVars τ t+        mapTyVars τ' t' mapTyVars _ (RHole _)   = return () mapTyVars _ _@@ -118,15 +124,15 @@   -mkVarExpr v -  | isFunVar v = EApp (varFunSymbol v) []+mkVarExpr v+  | isFunVar v = mkEApp (varFunSymbol v) []   | otherwise  = EVar (symbol v) -varFunSymbol = dummyLoc . dataConSymbol . idDataCon +varFunSymbol = dummyLoc . symbol . idDataCon  isFunVar v   = isDataConId v && not (null αs) && isNothing tf   where-    (αs, t)  = splitForAllTys $ varType v +    (αs, t)  = splitForAllTys $ varType v     tf       = splitFunTy_maybe t  -- the Vars we lookup in GHC don't always have the same tyvars as the Vars@@ -142,7 +148,6 @@ simpleSymbolVar  = dropModuleNames . symbol . showPpr . getName  hasBoolResult (ForAllTy _ t) = hasBoolResult t-hasBoolResult (FunTy _ t)    | eqType boolTy t = True +hasBoolResult (FunTy _ t)    | eqType boolTy t = True hasBoolResult (FunTy _ t)    = hasBoolResult t hasBoolResult _              = False-
src/Language/Haskell/Liquid/Bare/OfType.hs view
@@ -12,17 +12,18 @@   , mkSpecType'   ) where +import Prelude hiding (error) import BasicTypes import Name import TyCon hiding (synTyConRhs_maybe) import Type (expandTypeSynonyms) import TysWiredIn -import Control.Applicative+ import Control.Monad.Reader hiding (forM) import Control.Monad.State hiding (forM) import Data.Maybe (fromMaybe)-import Data.Monoid+ import Data.Traversable (forM) import Text.Parsec.Pos import Text.Printf@@ -30,14 +31,13 @@ import qualified Control.Exception as Ex import qualified Data.HashMap.Strict as M -import Language.Fixpoint.Misc (errorstar)-import Language.Fixpoint.Types (Expr(..), Reftable, Symbol, meet, mkSubst, subst, symbol)+import Language.Fixpoint.Types (Expr(..), Reftable, Symbol, meet, mkSubst, subst, symbol, mkEApp) -import Language.Haskell.Liquid.GhcMisc +import Language.Haskell.Liquid.GHC.Misc import Language.Haskell.Liquid.Misc (secondM)-import Language.Haskell.Liquid.RefType+import Language.Haskell.Liquid.Types.RefType import Language.Haskell.Liquid.Types-import Language.Haskell.Liquid.Bounds+import Language.Haskell.Liquid.Types.Bounds  import Language.Haskell.Liquid.Bare.Env import Language.Haskell.Liquid.Bare.Expand@@ -63,10 +63,10 @@  ofBPVar :: BPVar -> BareM RPVar ofBPVar-  = mapM_pvar ofBSort+  = mapMPvar ofBSort -mapM_pvar :: (Monad m) => (a -> m b) -> PVar a -> m (PVar b)-mapM_pvar f (PV x t v txys)+mapMPvar :: (Monad m) => (a -> m b) -> PVar a -> m (PVar b)+mapMPvar f (PV x t v txys)   = do t'    <- forM t f        txys' <- mapM (\(t, x, y) -> liftM (, x, y) (f t)) txys        return $ PV x t' v txys'@@ -82,16 +82,16 @@   = ofBRType expandRTAliasApp resolveReft t   where     resolveReft-      = (resolve l <=< expandReft) . txParam subvUReft (uPVar <$> πs) t+      = (resolve l <=< expandReft) . txParam l subvUReft (uPVar <$> πs) t  -txParam f πs t = f (txPvar (predMap πs t))+txParam l f πs t = f (txPvar l (predMap πs t)) -txPvar :: M.HashMap Symbol UsedPVar -> UsedPVar -> UsedPVar-txPvar m π = π { pargs = args' }+txPvar :: SourcePos -> M.HashMap Symbol UsedPVar -> UsedPVar -> UsedPVar+txPvar l m π = π { pargs = args' }   where args' | not (null (pargs π)) = zipWith (\(_,x ,_) (t,_,y) -> (t, x, y)) (pargs π') (pargs π)               | otherwise            = pargs π'-        π'    = fromMaybe (errorstar err) $ M.lookup (pname π) m+        π'    = fromMaybe (panic (Just $ sourcePosSrcSpan l) err) $ M.lookup (pname π) m         err   = "Bare.replaceParams Unbound Predicate Variable: " ++ show π  predMap πs t = M.fromList [(pname π, π) | π <- πs ++ rtypePredBinds t]@@ -135,13 +135,12 @@     go (RExprArg (Loc l l' e))       = RExprArg . Loc l l' <$> resolve l e -    go_ref (RPropP ss r)-      = RPropP <$> mapM go_syms ss <*> resolveReft r+    go_ref (RProp ss (RHole r))+      = rPropP <$> mapM go_syms ss <*> resolveReft r     go_ref (RProp ss t)       = RProp <$> mapM go_syms ss <*> go t-    go_ref (RHProp _ _)-      = errorstar "TODO:EFFECTS:ofBRType" +     go_syms       = secondM ofBSort @@ -161,7 +160,7 @@             rs' <- mapM go_ref rs             ts' <- mapM go ts             bareTCApp r' lc' rs' ts'-    goRApp _ _ = errorstar "This cannot happen"+    goRApp _ _ = impossible Nothing "goRApp failed through to final case"   matchTyCon :: LocSymbol -> Int -> BareM TyCon@@ -186,18 +185,16 @@ expandRTAliasApp :: SourcePos -> RTAlias RTyVar SpecType -> [BareType] -> RReft -> BareM SpecType expandRTAliasApp l rta args r   | length args == length αs + length εs-    = do args' <- mapM (ofBareType l) args-         let ts  = take (length αs) args'-             αts = zipWith (\α t -> (α, toRSort t, t)) αs ts-         return $ subst su . (`strengthen` r) . subsTyVars_meet αts $ rtBody rta+    = do ts <- mapM (ofBareType l)                   $ take (length αs) args+         es <- mapM (resolve l . exprArg (show err)) $ drop (length αs) args+         let tsu = zipWith (\α t -> (α, toRSort t, t)) αs ts+         let esu = mkSubst $ zip (symbol <$> εs) es+         return $ subst esu . (`strengthen` r) . subsTyVars_meet tsu $ rtBody rta   | otherwise     = Ex.throw err   where-    su        = mkSubst $ zip (symbol <$> εs) es     αs        = rtTArgs rta     εs        = rtVArgs rta-    es_       = drop (length αs) args-    es        = map (exprArg $ show err) es_     err       :: Error     err       = ErrAliasApp (sourcePosSrcSpan l) (length args) (pprint $ rtName rta) (sourcePosSrcSpan $ rtPos rta) (length αs + length εs) @@ -212,11 +209,11 @@ exprArg _   (RApp x [] [] _)   = EVar (symbol x) exprArg msg (RApp f ts [] _)-  = EApp (symbol <$> f) (exprArg msg <$> ts)+  = mkEApp (symbol <$> f) (exprArg msg <$> ts) exprArg msg (RAppTy (RVar f _) t _)-  = EApp (dummyLoc $ symbol f) [exprArg msg t]+  = mkEApp (dummyLoc $ symbol f) [exprArg msg t] exprArg msg z-  = errorstar $ printf "Unexpected expression parameter: %s in %s" (show z) msg+  = panic Nothing $ printf "Unexpected expression parameter: %s in %s" (show z) msg  -------------------------------------------------------------------------------- @@ -241,7 +238,7 @@  tyApp (RApp c ts rs r) ts' rs' r' = RApp c (ts ++ ts') (rs ++ rs') (r `meet` r') tyApp t                []  []  r  = t `strengthen` r-tyApp _                 _  _   _  = errorstar $ "Bare.Type.tyApp on invalid inputs"+tyApp _                 _  _   _  = panic Nothing $ "Bare.Type.tyApp on invalid inputs"  expandRTypeSynonyms :: (PPrint r, Reftable r) => RRType r -> RRType r expandRTypeSynonyms = ofType . expandTypeSynonyms . toType
src/Language/Haskell/Liquid/Bare/Plugged.hs view
@@ -7,6 +7,7 @@   , makePluggedDataCons   ) where +import Prelude hiding (error) import DataCon import Module import Name@@ -15,23 +16,25 @@ import Type (expandTypeSynonyms) import Var -import Control.Applicative ((<$>), (<*>))+ import Control.Monad-import Control.Monad.Error+import Control.Monad.Except import Data.Generics.Aliases (mkT) import Data.Generics.Schemes (everywhere)-import Data.Monoid + import qualified Data.HashMap.Strict as M -import Language.Fixpoint.Names (dummySymbol)-import Language.Fixpoint.Types (mapPredReft, pAnd, conjuncts, Refa (..), TCEmb)+import Language.Fixpoint.Types.Names (dummySymbol)+import Language.Fixpoint.Types (mapPredReft, pAnd, conjuncts, TCEmb) -- import Language.Fixpoint.Types (traceFix, showFix) -import Language.Haskell.Liquid.GhcMisc (sourcePosSrcSpan)-import Language.Haskell.Liquid.RefType (addTyConInfo, ofType, rVar, rTyVar, subts, toType, uReft)+import Language.Haskell.Liquid.GHC.Misc (sourcePos2SrcSpan)+import Language.Haskell.Liquid.Types.RefType (addTyConInfo, ofType, rVar, rTyVar, subts, toType, uReft) import Language.Haskell.Liquid.Types +import Language.Haskell.Liquid.Misc (zipWithDefM)+ import Language.Haskell.Liquid.Bare.Env import Language.Haskell.Liquid.Bare.Misc @@ -44,22 +47,21 @@ makePluggedAsmSigs embs tcEnv sigs   = forM sigs $ \(x,t) -> do       let τ = expandTypeSynonyms $ varType x-      let r = killHoles+      let r = const killHoles       (x,) <$> plugHoles embs tcEnv x r τ t  makePluggedDataCons embs tcEnv dcs   = forM dcs $ \(dc, Loc l l' dcp) -> do        let (das, _, dts, dt) = dataConSig dc        tyArgs <- zipWithM (\t1 (x,t2) ->-                   (x,) . val <$> plugHoles embs tcEnv (dataConName dc) killHoles t1 (Loc l l' t2))+                   (x,) . val <$> plugHoles embs tcEnv (dataConName dc) (const killHoles) t1 (Loc l l' t2))                  dts (reverse $ tyArgs dcp)-       tyRes <- val <$> plugHoles embs tcEnv (dataConName dc) killHoles dt (Loc l l' (tyRes dcp))+       tyRes <- val <$> plugHoles embs tcEnv (dataConName dc) (const killHoles) dt (Loc l l' (tyRes dcp))        return (dc, Loc l l' dcp { freeTyVars = map rTyVar das                                 , freePred   = map (subts (zip (freeTyVars dcp) (map (rVar :: TyVar -> RSort) das))) (freePred dcp)                                 , tyArgs     = reverse tyArgs                                 , tyRes      = tyRes}) - plugHoles tce tyi x f t (Loc l l' st)   = do tyvsmap <- case runMapTyVars (mapTyVars (toType rt') st'') initvmap of                     Left e -> throwError e@@ -76,13 +78,21 @@     (_, ps, ls2, st') = bkUniv st     (_, st'')         = bkClass st'     cs'               = [(dummySymbol, RApp c t [] mempty) | (c,t) <- cs]-    initvmap          = initMapSt $ ErrMismatch (sourcePosSrcSpan l) (pprint x) t (toType st)+    initvmap          = initMapSt $ ErrMismatch lqSp (pprint x) (pprint t) (pprint $ toType st) hsSp+    hsSp              = getSrcSpan x+    lqSp              = sourcePos2SrcSpan l l'      go :: SpecType -> SpecType -> BareM SpecType-    go t                (RHole r)          = return $ (addHoles t') { rt_reft = f r }+    go t                (RHole r)          = return $ (addHoles t') { rt_reft = f t r }       where         t'       = everywhere (mkT $ addRefs tce tyi) t-        addHoles = fmap (const $ f $ uReft ("v", Refa hole))+        addHoles = everywhere (mkT $ addHole)+        -- NOTE: make sure we only add holes to RVar and RApp (NOT RFun)+        addHole :: SpecType -> SpecType+        addHole t@(RVar v _)       = RVar v (f t (uReft ("v", hole)))+        addHole t@(RApp c ts ps _) = RApp c ts ps (f t (uReft ("v", hole)))+        addHole t                  = t+     go (RVar _ _)       v@(RVar _ _)       = return v     go (RFun _ i o _)   (RFun x i' o' r)   = RFun x <$> go i i' <*> go o o' <*> return r     go (RAllT _ t)      (RAllT a t')       = RAllT a <$> go t t'@@ -93,7 +103,9 @@     go t                (REx b x t')       = REx b x <$> go t t'     go t                (RRTy e r o t')    = RRTy e r o <$> go t t'     go (RAppTy t1 t2 _) (RAppTy t1' t2' r) = RAppTy <$> go t1 t1' <*> go t2 t2' <*> return r-    go (RApp _ t _ _)   (RApp c t' p r)    = RApp c <$> (zipWithM go t t') <*> return p <*> return 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)   = RApp c <$> (zipWithDefM go ts ts') <*> return p <*> return r     -- If we reach the default case, there's probably an error, but we defer     -- throwing it as checkGhcSpec does a much better job of reporting the     -- problem to the user.@@ -111,9 +123,9 @@ addRefs _ _ t  = t  -maybeTrue :: NamedThing a => a -> ModName -> NameSet -> RReft -> RReft-maybeTrue x target exports r-  | isInternalName name || inTarget && notExported+maybeTrue :: NamedThing a => a -> ModName -> NameSet -> SpecType -> RReft -> RReft+maybeTrue x target exports t r+  | not (isFunTy t) && (isInternalName name || inTarget && notExported)   = r   | otherwise   = killHoles r@@ -128,5 +140,3 @@   where     tx r = {- traceFix ("killholes: r = " ++ showFix r) $ -} mapPredReft dropHoles r     dropHoles    = pAnd . filter (not . isHole) . conjuncts--
src/Language/Haskell/Liquid/Bare/RTEnv.hs view
@@ -4,21 +4,23 @@     makeRTEnv   ) where -import Control.Applicative ((<$>))+import Prelude hiding (error)+ import Data.Graph hiding (Graph) import Data.Maybe  import qualified Control.Exception   as Ex import qualified Data.HashMap.Strict as M+import qualified Data.List           as L -import Language.Fixpoint.Misc (errorstar, fst3)-import Language.Fixpoint.Types (Expr(..), Pred(..), Symbol)+import Language.Fixpoint.Misc (fst3)+import Language.Fixpoint.Types (Expr(..), Symbol) -import Language.Haskell.Liquid.GhcMisc (sourcePosSrcSpan)-import Language.Haskell.Liquid.Misc (ordNub)-import Language.Haskell.Liquid.RefType (symbolRTyVar)+import Language.Haskell.Liquid.GHC.Misc (sourcePosSrcSpan)+import Language.Haskell.Liquid.Types.RefType (symbolRTyVar) import Language.Haskell.Liquid.Types + import qualified Language.Haskell.Liquid.Measure as Ms  import Language.Haskell.Liquid.Bare.Env@@ -30,11 +32,9 @@  makeRTEnv specs   = do makeREAliases ets-       makeRPAliases pts        makeRTAliases rts     where        rts = (concat [(m,) <$> Ms.aliases  s | (m, s) <- specs])-       pts = (concat [(m,) <$> Ms.paliases s | (m, s) <- specs])        ets = (concat [(m,) <$> Ms.ealiases s | (m, s) <- specs])  @@ -48,16 +48,6 @@              body  <- withVArgs l l' (rtVArgs xt) $ ofBareType l $ rtBody xt              setRTAlias (rtName xt) $ mapRTAVars symbolRTyVar $ xt { rtBody = body} -makeRPAliases-  = graphExpand buildPredEdges expBody-  where-    expBody (mod, xt)-      = inModule mod $-          do let l  = rtPos  xt-             let l' = rtPosE xt-             body  <- withVArgs l l' (rtVArgs xt) $ resolve l =<< (expandPred $ rtBody xt)-             setRPAlias (rtName xt) $ xt { rtBody = body }- makeREAliases   = graphExpand buildExprEdges expBody   where@@ -88,7 +78,7 @@ fromAliasSymbol table sym   = fromMaybe err $ M.lookup sym table   where-    err = errorstar $ "fromAliasSymbol: Dangling alias symbol: " ++ show sym+    err = panic Nothing $ "fromAliasSymbol: Dangling alias symbol: " ++ show sym   type Graph t = [Node t]@@ -122,7 +112,7 @@                       , acycle = map locate scc                       }     err []-      = errorstar "Bare.RTEnv.checkCyclicAliases: No type aliases in reported cycle"+      = panic Nothing "Bare.RTEnv.checkCyclicAliases: No type aliases in reported cycle"      locate sym       = ( sourcePosSrcSpan $ rtPos $ snd $ fromAliasSymbol table sym@@ -141,6 +131,9 @@  -------------------------------------------------------------------------------- +ordNub :: Ord a => [a] -> [a]+ordNub = map head . L.group . L.sort+ buildTypeEdges :: AliasTable BareType -> BareType -> [Symbol] buildTypeEdges table = ordNub . go   where@@ -162,46 +155,37 @@     --                         Just _  -> [c]     --                         Nothing -> [ ] -    go_ref (RPropP _ _) = Nothing+    go_ref (RProp _ (RHole _)) = Nothing     go_ref (RProp  _ t) = Just t-    go_ref (RHProp _ _) = errorstar "TODO:EFFECTS:buildTypeEdges" -buildPredEdges :: AliasTable Pred -> Pred -> [Symbol]-buildPredEdges table = ordNub . go-  where-    go :: Pred -> [Symbol]-    go (PBexp (EApp lf _)) = [ f | let f = val lf, M.member f table]-    go (PAnd ps)           = concatMap go ps-    go (POr ps)            = concatMap go ps-    go (PNot p)            = go p-    go (PImp p q)          = go p ++ go q-    go (PIff p q)          = go p ++ go q-    go (PAll _ p)          = go p-    go _                   = [] -    -- go (PBexp _)           = []-    -- go (PAtom _ _ _)       = []-    -- go PTrue               = []-    -- go PFalse              = []-    -- go PTop                = []- buildExprEdges table  = ordNub . go   where     go :: Expr -> [Symbol]-    go (EApp lf es)   = go_alias (val lf) ++ concatMap go es+    go (EApp e1 e2)   = go e1 ++ go e2     go (ENeg e)       = go e     go (EBin _ e1 e2) = go e1 ++ go e2     go (EIte _ e1 e2) = go e1 ++ go e2     go (ECst e _)     = go e-    go _              = [] -    -- go (ELit _ _)     = []-    -- go (ESym _)       = []-    -- go (ECon _)       = []-    -- go (EVar _)       = []-    -- go EBot           = []+    go (ESym _)       = []+    go (ECon _)       = []+    go (EVar v)       = go_alias v  +    go (PAnd ps)           = concatMap go ps+    go (POr ps)            = concatMap go ps+    go (PNot p)            = go p+    go (PImp p q)          = go p ++ go q+    go (PIff p q)          = go p ++ go q+    go (PAll _ p)          = go p+    go (ELam _ e)          = go e ++    go (PAtom _ e1 e2)     = go e1 ++ go e2 ++    go (ETApp e _)         = go e +    go (ETAbs e _)         = go e +    go (PKVar _ _)         = []+    go (PExist _ e)        = go e +    go PGrad               = [] +     go_alias f           = [f | M.member f table ]-    --   = case M.lookup f table of-    --       Just _  -> [f]-    --       Nothing -> [ ]
src/Language/Haskell/Liquid/Bare/RefToLogic.hs view
@@ -7,27 +7,33 @@    ) where +import Prelude hiding (error)+ import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.Misc (mapSnd) import Language.Haskell.Liquid.Bare.Env -import Language.Fixpoint.Types hiding (Def, R)-import Language.Fixpoint.Misc-import Language.Fixpoint.Names+import Language.Fixpoint.Types hiding (R) ++import Language.Haskell.Liquid.GHC.Misc (dropModuleUnique)+++ import qualified Data.HashMap.Strict as M -import Control.Applicative                      ((<$>)) + txRefToLogic :: (Transformable r) => LogicMap -> InlnEnv -> r -> r txRefToLogic = tx'  class Transformable a where-  tx  :: Symbol -> (Either LMap TInline) -> a -> a+  tx  :: Symbol -> Either LMap TInline -> a -> a    tx' :: LogicMap -> InlnEnv -> a -> a   tx' lmap imap x = M.foldrWithKey tx x limap     where-      limap       = M.fromList ((mapSnd Left <$> M.toList lmap) ++ (mapSnd Right <$> M.toList imap))+      limap       = M.fromList ((mapSnd Left <$> (M.toList $ logic_map lmap)) ++ (mapSnd Right <$> M.toList imap))   instance (Transformable a) => (Transformable [a]) where@@ -35,7 +41,7 @@  instance Transformable DataConP where   tx s m x = x { tyConsts = tx s m (tyConsts x)-               , tyArgs   = mapSnd (tx s m) <$> (tyArgs x)+               , tyArgs   = mapSnd (tx s m) <$> tyArgs x                , tyRes    = tx s m (tyRes x)                } @@ -49,9 +55,9 @@   tx s m = fmap (tx s m)  instance Transformable Reft where-  tx s m (Reft (v, Refa p)) = if v == s-                              then errorstar "Transformable: this should not happen"-                              else Reft(v, Refa $ tx s m p)+  tx s m (Reft (v, p)) = if v == s+                         then impossible Nothing "Transformable: v != s"+                         else Reft(v, tx s m p)  -- OLD instance Transformable Refa where -- OLD   tx s m (RConc p)     = RConc $ tx s m p@@ -61,41 +67,44 @@   tx s m (Left  x) = Left  (tx s m x)   tx s m (Right x) = Right (tx s m x) -instance Transformable Pred where-  tx _ _ PTrue           = PTrue-  tx _ _ PFalse          = PFalse-  tx _ _ PTop            = PTop-  tx s m (PAnd ps)       = PAnd (tx s m <$> ps)-  tx s m (POr ps)        = POr (tx s m <$> ps)-  tx s m (PNot p)        = PNot (tx s m p)-  tx s m (PImp p1 p2)    = PImp (tx s m p1) (tx s m p2)-  tx s m (PIff p1 p2)    = PIff (tx s m p1) (tx s m p2)-  tx s m (PBexp (EApp f es)) = txPApp (s, m) f (tx s m <$> es)-  tx s m (PBexp e)       = PBexp (tx s m e)-  tx s m (PAtom r e1 e2) = PAtom r (tx s m e1) (tx s m e2)-  tx s m (PAll xss p)    = PAll xss $ txQuant xss s m p- --  tx s m (PExist xss p)  = PExist xss $ txQuant xss s m p-  tx _ _ p@(PKVar _ _)   = p  txQuant xss s m p-  | s `elem` (fst <$> xss) = errorstar "Transformable.tx on Pred: this should not happen"+  | s `elem` (fst <$> xss) = impossible Nothing "Transformable.tx on Pred"   | otherwise              = tx s m p   instance Transformable Expr where   tx s m (EVar s')-    | cmpSymbol s s'    = mexpr m+    | cmpSymbol s s'    = mexpr s' m     | otherwise         = EVar s'-  tx s m (EApp f es)    = txEApp (s, m) f (tx s m <$> es)+  tx s m e@(EApp _ _)   = txEApp (s, m) e -- f (tx s m es)   tx _ _ (ESym c)       = ESym c   tx _ _ (ECon c)       = ECon c-  tx _ _ (ELit l s')    = ELit l s'+  --tx _ _ (ELit l s')    = ELit l s'   tx s m (ENeg e)       = ENeg (tx s m e)   tx s m (EBin o e1 e2) = EBin o (tx s m e1) (tx s m e2)   tx s m (EIte p e1 e2) = EIte (tx s m p) (tx s m e1) (tx s m e2)   tx s m (ECst e s')    = ECst (tx s m e) s'   tx _ _ EBot           = EBot+  tx _ _ PTrue           = PTrue+  tx _ _ PFalse          = PFalse+  tx _ _ PTop            = PTop+  tx s m (PAnd ps)       = PAnd (tx s m <$> ps)+  tx s m (POr ps)        = POr (tx s m <$> ps)+  tx s m (PNot p)        = PNot (tx s m p)+  tx s m (PImp p1 p2)    = PImp (tx s m p1) (tx s m p2)+  tx s m (PIff p1 p2)    = PIff (tx s m p1) (tx s m p2)+  tx s m (PAtom r e1 e2) = PAtom r (tx s m e1) (tx s m e2)+  tx s m (ELam (x,t) e)  = ELam (x,t) $ txQuant [(x,t)] s m e+  tx s m (PAll xss p)    = PAll xss   $ txQuant xss s m p+  tx _ _ (PExist _ _)    = panic Nothing "tx: PExist is for fixpoint internals only"+ --  tx s m (PExist xss p)  = PExist xss $ txQuant xss s m p+  tx _ _ p@(PKVar _ _)   = p+  tx _ _ p@(ETApp _ _)   = p+  tx _ _ p@(ETAbs _ _)   = p+  tx _ _ p@PGrad         = p + instance Transformable (Measure t c) where   tx s m x = x{eqns = tx s m <$> (eqns x)} @@ -107,40 +116,42 @@   tx s m (P p)   = P $ tx s m p   tx s m (R v p) = R v $ tx s m p -mexpr (Left  (LMap _ _ e)) = e-mexpr (Right (TI _ (Right e))) = e-mexpr _ = errorstar "mexpr"+mexpr _ (Left  (LMap _ [] e)) = e+mexpr s (Left  (LMap _ _  _)) = EVar s+mexpr _ (Right (TI _ e)) = e+-- mexpr s s' = panic Nothing ("mexpr on " ++ show s ++ "\t" ++ show s') -txEApp (s, (Left (LMap _ xs e))) f es-  | cmpSymbol s (val f)-  = subst (mkSubst $ zip xs es) e-  | otherwise-  = EApp f es+txEApp (s,m) e = go f+  where+    (f, es) = splitEApp e +    go (EVar x) = txEApp' (s,m) x  (tx s m <$> es) +    go f        = eApps (tx s m f) (tx s m <$> es) -txEApp (s, (Right (TI xs (Right e)))) f es-  | cmpSymbol s (val f)+txEApp' (s, (Left (LMap _ xs e))) f es+  | cmpSymbol s f && length xs == length es      = subst (mkSubst $ zip xs es) e   | otherwise-  = EApp f es-+  = mkEApp (dummyLoc f) es -txEApp (s, (Right (TI _ (Left _)))) f es-  | cmpSymbol s (val f)-  = errorstar "txEApp: deep internal error"+txEApp' (s, (Right (TI xs e))) f es+  | cmpSymbol s f && length xs == length es+  = subst (mkSubst $ zip xs es) e   | otherwise-  = EApp f es+  = mkEApp (dummyLoc f) es  -txPApp (s, (Right (TI xs (Left e)))) f es+{-+txPApp (s, (Right (TI xs e))) f es   | cmpSymbol s (val f)   = subst (mkSubst $ zip xs es) e   | otherwise-  = PBexp $ EApp f es+  = EApp f es -txPApp (s, m) f es = PBexp $ txEApp (s, m) f es+txPApp (s, m) f es = txEApp (s, m) f es+-}  cmpSymbol s1 {- symbol in Core -} s2 {- logical Symbol-}-  = (dropModuleNamesAndUnique s1) == (dropModuleNamesAndUnique s2)+  = dropModuleNamesAndUnique s1 == dropModuleNamesAndUnique s2   dropModuleNamesAndUnique = dropModuleUnique {- . dropModuleNames -}
src/Language/Haskell/Liquid/Bare/Resolve.hs view
@@ -7,17 +7,26 @@     Resolvable(..)   ) where -import Control.Applicative ((<$>), (<*>))++import Prelude hiding (error)+ import Control.Monad.State import Data.Char (isUpper) import Text.Parsec.Pos  import qualified Data.List           as L-import qualified Data.Text           as T+ import qualified Data.HashMap.Strict as M -import Language.Fixpoint.Names (prims)-import Language.Fixpoint.Types (Expr(..), Pred(..), Qualifier(..), Refa(..), Reft(..), Sort(..), Symbol, fTyconSymbol, symbol, symbolFTycon, symbolText)+import Language.Fixpoint.Types.Names (prims, unconsSym)+import Language.Fixpoint.Types (Expr(..),+                                Qualifier(..),+                                Reft(..),+                                Sort(..),+                                Symbol,+                                fTyconSymbol,+                                symbol,+                                symbolFTycon)  import Language.Haskell.Liquid.Misc (secondM, third3M) import Language.Haskell.Liquid.Types@@ -34,26 +43,29 @@ instance Resolvable Qualifier where   resolve _ (Q n ps b l) = Q n <$> mapM (secondM (resolve l)) ps <*> resolve l b <*> return l -instance Resolvable Pred where++instance Resolvable Expr where+  resolve l (EVar s)        = EVar   <$> resolve l s+  resolve l (EApp s es)     = EApp   <$> resolve l s  <*> resolve l es+  resolve l (ENeg e)        = ENeg   <$> resolve l e+  resolve l (EBin o e1 e2)  = EBin o <$> resolve l e1 <*> resolve l e2+  resolve l (EIte p e1 e2)  = EIte   <$> resolve l p  <*> resolve l e1 <*> resolve l e2+  resolve l (ECst x s)      = ECst   <$> resolve l x  <*> resolve l s   resolve l (PAnd ps)       = PAnd    <$> resolve l ps   resolve l (POr  ps)       = POr     <$> resolve l ps   resolve l (PNot p)        = PNot    <$> resolve l p   resolve l (PImp p q)      = PImp    <$> resolve l p  <*> resolve l q   resolve l (PIff p q)      = PIff    <$> resolve l p  <*> resolve l q-  resolve l (PBexp b)       = PBexp   <$> resolve l b   resolve l (PAtom r e1 e2) = PAtom r <$> resolve l e1 <*> resolve l e2+  resolve l (ELam (x,t) e)  = ELam    <$> ((,) <$> resolve l x <*> resolve l t) <*> resolve l e   resolve l (PAll vs p)     = PAll    <$> mapM (secondM (resolve l)) vs <*> resolve l p-  -- resolve l (PExist vs p)   = PExist  <$> mapM (secondM (resolve l)) vs <*> resolve l p-  resolve _ p               = return p--instance Resolvable Expr where-  resolve l (EVar s)       = EVar   <$> resolve l s-  resolve l (EApp s es)    = EApp   <$> resolve l s  <*> resolve l es-  resolve l (ENeg e)       = ENeg   <$> resolve l e-  resolve l (EBin o e1 e2) = EBin o <$> resolve l e1 <*> resolve l e2-  resolve l (EIte p e1 e2) = EIte   <$> resolve l p  <*> resolve l e1 <*> resolve l e2-  resolve l (ECst x s)     = ECst   <$> resolve l x  <*> resolve l s-  resolve _ x              = return x+  resolve l (ETApp e s)     = ETApp   <$> resolve l e <*> resolve l s +  resolve l (ETAbs e s)     = ETAbs   <$> resolve l e <*> resolve l s +  resolve _ (PKVar k s)     = return $ PKVar k s +  resolve l (PExist ss e)   = PExist ss <$> resolve l e+  resolve _ (ESym s)        = return $ ESym s +  resolve _ (ECon c)        = return $ ECon c +  resolve _ PGrad           = return PGrad   instance Resolvable LocSymbol where   resolve _ ls@(Loc l l' s)@@ -68,37 +80,36 @@                                    return $ Loc l l' qs            _                 -> return ls -addSym x = modify $ \be -> be { varEnv = (varEnv be) `L.union` [x] }+addSym x = modify $ \be -> be { varEnv = varEnv be `L.union` [x] } -isCon c-  | Just (c,_) <- T.uncons $ symbolText c = isUpper c-  | otherwise                             = False+isCon s+  | Just (c,_) <- unconsSym s = isUpper c+  | otherwise                 = False  instance Resolvable Symbol where   resolve l x = fmap val $ resolve l $ Loc l l x  instance Resolvable Sort where-  resolve _ FInt         = return FInt-  resolve _ FReal        = return FReal-  resolve _ FNum         = return FNum-  resolve _ FFrac        = return FFrac-  resolve _ s@(FObj _)   = return s --FObj . S <$> lookupName env m s-  resolve _ s@(FVar _)   = return s-  resolve l (FFunc i ss) = FFunc i <$> resolve l ss-  resolve _ (FApp tc ss)-    | tcs' `elem` prims  = FApp tc <$> ss'-    | otherwise          = FApp <$> (symbolFTycon . Loc l l' . symbol <$> lookupGhcTyCon tcs) <*> ss'-      where-        tcs@(Loc l l' tcs') = fTyconSymbol tc-        ss'                 = resolve l ss+  resolve _ FInt          = return FInt+  resolve _ FReal         = return FReal+  resolve _ FNum          = return FNum+  resolve _ FFrac         = return FFrac+  resolve _ s@(FObj _)    = return s --FObj . S <$> lookupName env m s+  resolve _ s@(FVar _)    = return s+  resolve l (FAbs i  s)   = FAbs i <$> (resolve l s)+  resolve l (FFunc s1 s2) = FFunc <$> (resolve l s1) <*> (resolve l s2)+  resolve _ (FTC c)+    | tcs' `elem` prims   = FTC <$> return c+    | otherwise           = FTC <$> (symbolFTycon . Loc l l' . symbol <$> lookupGhcTyCon tcs)+    where+      tcs@(Loc l l' tcs') = fTyconSymbol c+  resolve l (FApp t1 t2) = FApp <$> resolve l t1 <*> resolve l t2  instance Resolvable (UReft Reft) where-  resolve l (U r p s) = U <$> resolve l r <*> resolve l p <*> return s+  resolve l (MkUReft r p s) = MkUReft <$> resolve l r <*> resolve l p <*> return s  instance Resolvable Reft where-  resolve l (Reft (s, ra)) = Reft . (s,) <$> resolveRefa ra-    where-      resolveRefa (Refa p) = Refa <$> resolve l p+  resolve l (Reft (s, ra)) = Reft . (s,) <$> resolve l ra  instance Resolvable Predicate where   resolve l (Pr pvs) = Pr <$> resolve l pvs
src/Language/Haskell/Liquid/Bare/Spec.hs view
@@ -22,30 +22,30 @@   , makeHBounds   ) where +import Prelude hiding (error) import MonadUtils (mapMaybeM) import TyCon import Var -import Control.Applicative ((<$>))-import Control.Monad.Error++import Control.Monad.Except import Control.Monad.State import Data.Maybe-import Data.Monoid + import qualified Data.List           as L import qualified Data.HashSet        as S import qualified Data.HashMap.Strict as M -import Language.Fixpoint.Misc (concatMapM, group, mapFst, snd3)-import Language.Fixpoint.Names (dropModuleNames, dropSym, isPrefixOfSym, qualifySymbol, symbolString, takeModuleNames)-import Language.Fixpoint.Types (Qualifier(..), symbol)--import Language.Haskell.Liquid.Dictionaries-import Language.Haskell.Liquid.GhcMisc (getSourcePos, showPpr, symbolTyVar)-import Language.Haskell.Liquid.Misc (addFst3, fourth4)-import Language.Haskell.Liquid.RefType (generalize, rVar, symbolRTyVar)+import Language.Fixpoint.Misc (group, snd3)+import Language.Fixpoint.Types.Names (dropSym, isPrefixOfSym,  symbolString)+import Language.Fixpoint.Types (Qualifier(..), symbol, atLoc)+import Language.Haskell.Liquid.Types.Dictionaries+import Language.Haskell.Liquid.GHC.Misc ( dropModuleNames, qualifySymbol, takeModuleNames, getSourcePos, showPpr, symbolTyVar)+import Language.Haskell.Liquid.Misc (addFst3, fourth4, mapFst, concatMapM)+import Language.Haskell.Liquid.Types.RefType (generalize, rVar, symbolRTyVar) import Language.Haskell.Liquid.Types-import Language.Haskell.Liquid.Bounds+import Language.Haskell.Liquid.Types.Bounds  import qualified Language.Haskell.Liquid.Measure as Ms @@ -147,12 +147,12 @@   makeDefaultMethods :: [Var] -> [(ModName,Var,Located SpecType)]-                   -> [(ModName,Var,Located SpecType)]+                   -> [(ModName, Var ,Located SpecType)] makeDefaultMethods defVs sigs   = [ (m,dmv,t)     | dmv <- defVs     , let dm = symbol $ showPpr dmv-    , "$dm" `isPrefixOfSym` (dropModuleNames dm)+    , "$dm" `isPrefixOfSym` dropModuleNames dm     , let mod = takeModuleNames dm     , let method = qualifySymbol mod $ dropSym 3 (dropModuleNames dm)     , let mb = L.find ((method `isPrefixOfSym`) . symbol . snd3) sigs@@ -205,18 +205,18 @@   = inModule mod $ makeIAliases' $ Ms.ialiases spec  makeIAliases' :: [(Located BareType, Located BareType)] -> BareM [(Located SpecType, Located SpecType)]-makeIAliases' ts = mapM mkIA ts+makeIAliases' = mapM mkIA   where-    mkIA (t1, t2)      = liftM2 (,) (mkI t1) (mkI t2)-    mkI (Loc l l' t)   = (Loc l l') . generalize <$> mkSpecType l t+    mkIA (t1, t2)      = (,) <$> mkI t1 <*> mkI t2+    mkI (Loc l l' t)   = Loc l l' . generalize <$> mkSpecType l t  makeInvariants (mod,spec)   = inModule mod $ makeInvariants' $ Ms.invariants spec  makeInvariants' :: [Located BareType] -> BareM [Located SpecType]-makeInvariants' ts = mapM mkI ts+makeInvariants' = mapM mkI   where-    mkI (Loc l l' t)  = (Loc l l') . generalize <$> mkSpecType l t+    mkI (Loc l l' t)  = Loc l l' . generalize <$> mkSpecType l t   makeSpecDictionaries embs vars specs sp@@ -229,26 +229,26 @@ makeSpecDictionaryOne embs vars (RI x t xts)   = do t'  <-  mkTy t        tyi <- gets tcEnv-       ts' <- (map (txRefSort tyi embs . txExpToBind)) <$> mapM mkTy' ts-       let (d, dts) = makeDictionary $ RI x t' $ zip xs ts'+       ts' <- map (val . txRefSort tyi embs . fmap txExpToBind) <$> mapM mkTy' ts+       let (d, dts) = makeDictionary $ RI x (val t') $ zip xs ts'        let v = lookupName d        return ((, dts) <$> v)   where-    mkTy  t  = mkSpecType (loc x) t-    mkTy' t  = generalize  <$> mkTy t+    mkTy  t  = atLoc x         <$> mkSpecType (loc x) t+    mkTy' t  = fmap generalize <$> mkTy t     (xs, ts) = unzip xts     lookupName x              = case filter ((==x) . fst) ((\x -> (dropModuleNames $ symbol $ show x, x)) <$> vars) of                 [(_, x)] -> Just x                 _        -> Nothing -makeBounds name defVars cbs specs+makeBounds tce name defVars cbs specs   = do bnames  <- mkThing makeHBounds-       hbounds <- makeHaskellBounds cbs bnames-       bnds    <- M.fromList <$> (mapM go (concatMap (M.toList . Ms.bounds . snd ) specs))+       hbounds <- makeHaskellBounds tce cbs bnames+       bnds    <- M.fromList <$> mapM go (concatMap (M.toList . Ms.bounds . snd ) specs)        modify   $ \env -> env{ bounds = hbounds `mappend` bnds }   where-    go (x,bound) = (x,) <$> (mkBound bound)+    go (x,bound) = (x,) <$> mkBound bound     mkThing mk   = S.fromList . mconcat <$> sequence [ mk defVars s | (m, s) <- specs, m == name]
src/Language/Haskell/Liquid/Bare/SymSort.hs view
@@ -1,70 +1,78 @@+{-# LANGUAGE FlexibleContexts #-}+ module Language.Haskell.Liquid.Bare.SymSort (     txRefSort   ) where -import Control.Applicative ((<$>))+import Prelude hiding (error)  import qualified Data.List as L--import Language.Fixpoint.Misc (errorstar, safeZip, fst3, snd3)-import Language.Fixpoint.Types (meet)+import Data.Maybe              (fromMaybe)+import TyCon            (TyCon)+import Language.Fixpoint.Misc  (fst3, snd3)+import Language.Fixpoint.Types (atLoc, meet, TCEmb) -import Language.Haskell.Liquid.RefType (appRTyCon, strengthen)+import Language.Haskell.Liquid.Types.RefType (appRTyCon, strengthen) import Language.Haskell.Liquid.Types-import Language.Haskell.Liquid.Misc (safeZipWithError, intToString)+import Language.Haskell.Liquid.GHC.Misc (fSrcSpan)+import Language.Haskell.Liquid.Misc (safeZipWithError)+import Language.Haskell.Liquid.Bare.Env --- TODO: Rename, "Sort" isn't a good name for this module  -- EFFECTS: TODO is this the SAME as addTyConInfo? No. `txRefSort` -- (1) adds the _real_ sorts to RProp, -- (2) gathers _extra_ RProp at turnst them into refinements, --     e.g. tests/pos/multi-pred-app-00.hs-txRefSort tyi tce = mapBot (addSymSort tce tyi) -addSymSort tce tyi (RApp rc@(RTyCon _ _ _) ts rs r) -  = RApp rc ts (zipWith3 (addSymSortRef rc) pvs rargs [1..]) r'+txRefSort :: TCEnv -> TCEmb TyCon -> Located SpecType -> Located SpecType+txRefSort tyi tce t = atLoc t $ mapBot (addSymSort (fSrcSpan t) tce tyi) (val t)++addSymSort sp tce tyi (RApp rc@(RTyCon _ _ _) ts rs r)+  = RApp rc ts (zipWith3 (addSymSortRef sp rc) pvs rargs [1..]) r'   where     rc'                = appRTyCon tce tyi rc ts-    pvs                = rTyConPVs rc' +    pvs                = rTyConPVs rc'     (rargs, rrest)     = splitAt (length pvs) rs     r'                 = L.foldl' go r rrest-    go r (RPropP _ r') = r' `meet` r-    go r (RProp  _ _ ) = r -- is this correct?-    go _ (RHProp _ _ ) = errorstar "TODO:EFFECTS:addSymSort"+    go r (RProp _ (RHole r')) = r' `meet` r+    go r (RProp  _ t' )       = let r' = fromMaybe mempty (stripRTypeBase t') in r `meet` r' -addSymSort _ _ t +addSymSort _ _ _ t   = t -addSymSortRef _  _ (RHProp _ _) _   = errorstar "TODO:EFFECTS:addSymSortRef"-addSymSortRef rc p r i | isPropPV p = addSymSortRef' rc i p r -                       | otherwise  = errorstar "addSymSortRef: malformed ref application"-+addSymSortRef sp rc p r i+  | isPropPV p+  = addSymSortRef' sp rc i p r+  | otherwise+  = panic Nothing "addSymSortRef: malformed ref application" -addSymSortRef' _ _ p (RProp s (RVar v r)) | isDummy v+addSymSortRef' _ _ _ p (RProp s (RVar v r)) | isDummy v   = RProp xs t     where       t  = ofRSort (pvType p) `strengthen` r       xs = spliceArgs "addSymSortRef 1" s p -addSymSortRef' _ _ p (RProp s t) -  = RProp xs t-    where-      xs = spliceArgs "addSymSortRef 2" s p--addSymSortRef' rc i p (RPropP _ r@(U _ (Pr [up]) _)) -  = RPropP xts r -- (ofRSort (pvType p) `strengthen` r)+addSymSortRef' sp rc i p (RProp _ (RHole r@(MkUReft _ (Pr [up]) _)))+  | length xs == length ts+  = RProp xts (RHole r)+  | otherwise+  = uError $ ErrPartPred sp (pprint rc) (pprint $ pname up) i (length xs) (length ts)     where-      xts = safeZipWithError msg xs ts+      xts = safeZipWithError "addSymSortRef'" xs ts       xs  = snd3 <$> pargs up       ts  = fst3 <$> pargs p-      msg = intToString i ++ " argument of " ++ show rc ++ " is " ++ show (pname up) -            ++ " that expects " ++ show (length ts) ++ " arguments, but it has " ++ show (length xs) -addSymSortRef' _ _ _ (RPropP s r)-  = RPropP s r -- (ofRSort (pvType p) `strengthen` r)--addSymSortRef' _ _ _ _-  = errorstar "TODO:EFFECTS:addSymSortRef'"+addSymSortRef' _ _ _ _ (RProp s (RHole r))+  = RProp s (RHole r) -spliceArgs msg s p = safeZip msg (fst <$> s) (fst3 <$> pargs p) +addSymSortRef' _ _ _ p (RProp s t)+  = RProp xs t+    where+      xs = spliceArgs "addSymSortRef 2" s p +spliceArgs msg s p = go (fst <$> s) (pargs p)+  where+    go []     []           = []+    go []     ((s,x,_):as) = (x, s):go [] as+    go (x:xs) ((s,_,_):as) = (x,s):go xs as+    go xs     []           = panic Nothing $ "spliceArgs: " ++ msg ++ "on XS=" ++ show xs
− src/Language/Haskell/Liquid/Bounds.hs 
@@ -1,161 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TupleSections #-}--module Language.Haskell.Liquid.Bounds (--    Bound(..),--    RBound, RRBound,--    RBEnv, RRBEnv,--    makeBound,-    envToSub--        ) where--import Text.PrettyPrint.HughesPJ--import Data.List (partition)-import Data.Maybe-import Data.Hashable-import Data.Monoid-import Data.Bifunctor--import qualified Data.HashMap.Strict as M-import Control.Applicative           ((<$>))--import Language.Fixpoint.Types-import Language.Fixpoint.Misc--import Language.Haskell.Liquid.Types-import Language.Haskell.Liquid.RefType---data Bound t e-  = Bound { bname   :: LocSymbol         -- ^ The name of the bound-          , tyvars  :: [t]               -- ^ Type variables that appear in the bounds-          , bparams :: [(LocSymbol, t)]  -- ^ These are abstract refinements, for now-          , bargs   :: [(LocSymbol, t)]  -- ^ These are value variables-          , bbody   :: e                 -- ^ The body of the bound-          }--type RBound        = RRBound RSort-type RRBound tv    = Bound tv Pred--type RBEnv         = M.HashMap LocSymbol RBound-type RRBEnv tv     = M.HashMap LocSymbol (RRBound tv)---instance Hashable (Bound t e) where-        hashWithSalt i = hashWithSalt i . bname--instance Eq (Bound t e) where-  b1 == b2 = (bname b1) == (bname b2)--instance (PPrint e, PPrint t) => (Show (Bound t e)) where-        show = showpp---instance (PPrint e, PPrint t) => (PPrint (Bound t e)) where-        pprint (Bound s vs ps xs e) =   text "bound" <+> pprint s <+>-                                        text "forall" <+> pprint vs <+> text "." <+>-                                        pprint (fst <$> ps) <+> text "=" <+>-                                        pprint_bsyms (fst <$> xs) <+> pprint e--pprint_bsyms [] = text ""-pprint_bsyms xs = text "\\" <+> pprint xs <+> text "->"--instance Bifunctor Bound where-        first  f (Bound s vs ps xs e) = Bound s (f <$> vs) (mapSnd f <$> ps) (mapSnd f <$> xs) e-        second f (Bound s vs ps xs e) = Bound s vs ps xs (f e)---makeBound :: (PPrint r, UReftable r)-          => RRBound RSort -> [RRType r] -> [Symbol] -> (RRType r) -> (RRType r)-makeBound (Bound _  vs ps xs p) ts qs t-  = RRTy cts mempty OCons t-  where-    cts  = (\(x, t) -> (x, foldr subsTyVar_meet t su)) <$> cts'--    cts' = makeBoundType penv rs xs--    penv = zip (val . fst <$> ps) qs-    rs   = bkImp [] p--    bkImp acc (PImp p q) = bkImp (p:acc) q-    bkImp acc p          = p:acc--    su  = [(α, toRSort t, t) | (RVar α _, t) <-  zip vs ts ]--makeBoundType :: (PPrint r, UReftable r)-              => [(Symbol, Symbol)]-              -> [Pred]-              -> [(LocSymbol, RSort)]-              -> [(Symbol, RRType r)]-makeBoundType penv (q:qs) xts = go xts-  where-    -- NV TODO: Turn this into a proper error-    go [] = errorstar "Bound with empty symbols"--    go [(x, t)]      = [(dummySymbol, tp t x), (dummySymbol, tq t x)]-    go ((x, t):xtss) = (val x, mkt t x):(go xtss)--    mkt t x = ofRSort t `strengthen` ofUReft (U (Reft (val x, mempty))-                                                (Pr $ M.lookupDefault [] (val x) ps) mempty)-    tp t x  = ofRSort t `strengthen` ofUReft (U (Reft (val x, refa rs))-                                                (Pr $ M.lookupDefault [] (val x) ps) mempty)-    tq t x  = ofRSort t `strengthen` makeRef penv x q--    (ps, rs) = partitionPs penv qs----- NV TODO: Turn this into a proper error-makeBoundType _ _ _           = errorstar "Bound with empty predicates"---partitionPs :: [(Symbol, Symbol)] -> [Pred] -> (M.HashMap Symbol [UsedPVar], [Pred])-partitionPs penv qs = mapFst makeAR $ partition (isPApp penv) qs-  where-    makeAR ps       = M.fromListWith (++) $ map (toUsedPVars penv) ps--isPApp penv (PBexp (EApp p _))  = isJust $ lookup (val p) penv-isPApp _    _                   = False--toUsedPVars penv q@(PBexp (EApp _ es)) = (x, [toUsedPVar penv q])-  where-    -- NV : TODO make this a better error-    x = (\(EVar x) -> x) $ last es-toUsedPVars _ _ = error "This cannot happen"--toUsedPVar penv (PBexp (EApp p es))-  = PV q (PVProp ()) e (((), dummySymbol,) <$> es')-   where-     EVar e = last es-     es'    = init es-     Just q = lookup (val p) penv--toUsedPVar _ _ = error "This cannot happen"--envToSub = go []-  where-    go _   []              = error "This cannot happen: envToSub on 0 elems"-    go _   [(_,_)]         = error "This cannot happen: envToSub on 1 elem"-    go ack [(_,l), (_, r)] = (reverse ack, l, r)-    go ack (x:xs)          = go (x:ack) xs---- `makeRef` is used to make the refinement of the last implication,--- thus it can contain both concrete and abstract refinements--makeRef :: (UReftable r) => [(Symbol, Symbol)] -> LocSymbol -> Pred -> r-makeRef penv v (PAnd rs) = ofUReft (U (Reft (val v, refa rrs)) r mempty)-  where-    r                    = Pr  (toUsedPVar penv <$> pps)-    (pps, rrs)           = partition (isPApp penv) rs--makeRef penv v rr-  | isPApp penv rr       = ofUReft (U (Reft(val v, mempty)) r mempty)-  where-    r                    = Pr [toUsedPVar penv rr]--makeRef _    v p         = ofReft (Reft(val v, Refa p))
− src/Language/Haskell/Liquid/CTags.hs 
@@ -1,74 +0,0 @@-{-# LANGUAGE TupleSections #-}--- | This module contains the code for generating "tags" for constraints--- based on their source, i.e. the top-level binders under which the--- constraint was generated. These tags are used by fixpoint to --- prioritize constraints by the "source-level" function.--module Language.Haskell.Liquid.CTags (-    -- * Type for constraint tags-    TagKey, TagEnv- -    -- * Default tag value-  , defaultTag-   -    -- * Constructing @TagEnv@-  , makeTagEnv-  -    -- * Accessing @TagEnv@-  , getTag, memTagEnv--) where--import Var-import CoreSyn--import qualified Data.HashSet           as S-import qualified Data.HashMap.Strict    as M-import qualified Data.Graph             as G--import Language.Fixpoint.Misc         (mapSnd)-import Language.Fixpoint.Types     (Tag)-import Language.Haskell.Liquid.Visitors (freeVars)---- | The @TagKey@ is the top-level binder, and @Tag@ is a singleton Int list--type TagKey = Var-type TagEnv = M.HashMap TagKey Tag---- TODO: use the "callgraph" SCC to do this numbering.--defaultTag :: Tag-defaultTag = [0]--memTagEnv :: TagKey -> TagEnv -> Bool-memTagEnv = M.member--makeTagEnv :: [CoreBind] -> TagEnv -makeTagEnv = M.map (:[]) . callGraphRanks . makeCallGraph ---- makeTagEnv = M.fromList . (`zip` (map (:[]) [1..])). L.sort . map fst . concatMap bindEqns--getTag :: TagKey -> TagEnv -> Tag-getTag = M.lookupDefault defaultTag----------------------------------------------------------------------------------------------------------type CallGraph = [(Var, [Var])] -- caller-callee pairs--callGraphRanks :: CallGraph -> M.HashMap Var Int--- callGraphRanks cg = traceShow ("CallGraph Ranks: " ++ show cg) $ callGraphRanks' cg--callGraphRanks  = M.fromList . concat . index . mkScc-  where mkScc cg = G.stronglyConnComp [(u, u, vs) | (u, vs) <- cg]-        index    = zipWith (\i -> map (, i) . G.flattenSCC) [1..] --makeCallGraph :: [CoreBind] -> CallGraph-makeCallGraph cbs = mapSnd calls `fmap` xes -  where xes       = concatMap bindEqns cbs-        xs        = S.fromList $ map fst xes-        calls     = filter (`S.member` xs) . freeVars S.empty--bindEqns (NonRec x e) = [(x, e)]-bindEqns (Rec xes)    = xes --
− src/Language/Haskell/Liquid/Cabal.hs 
@@ -1,254 +0,0 @@--- | This module contains a single function that extracts the cabal information about a target file, if any.---   This information can be used to extend the source-directories that are searched to find modules that are---   imported by the target file.--{-@ LIQUID "--no-termination" @-}-{-@ LIQUID "--diff"           @-}-{-@ LIQUID "--short-names"    @-}-{-@ LIQUID "--cabaldir"       @-}--{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE OverloadedStrings    #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE CPP                  #-}--module Language.Haskell.Liquid.Cabal (cabalInfo, Info(..)) where--import Control.Applicative ((<$>))-import Data.Bits                              ( shiftL, shiftR, xor )-import Data.Char                              ( ord )-import Data.List-import Data.Maybe-import qualified Data.Text as T-import qualified Data.Text.IO as TIO-import Data.Word ( Word32 )-import Distribution.Compiler-import Distribution.Package-import Distribution.PackageDescription-import Distribution.PackageDescription.Configuration-import Distribution.PackageDescription.Parse-import Distribution.Simple.BuildPaths-import Distribution.System-import Distribution.Verbosity-import Language.Haskell.Extension-import Numeric ( showHex )-import System.Console.CmdArgs-import System.Environment-import System.Exit-import System.FilePath-import System.Directory-import System.Info-import Language.Haskell.Liquid.Errors---- To use in ghci:---   exitWithPanic = undefined--------------------------------------------------------------------------------------------------cabalInfo :: FilePath -> IO (Maybe Info)-------------------------------------------------------------------------------------------------cabalInfo f = do-  f  <- canonicalizePath f-  cf <- findCabalFile f-  case cf of-    Just f  -> Just  <$> processCabalFile f-    Nothing -> return Nothing--processCabalFile :: FilePath -> IO Info-processCabalFile f = do-  let sandboxDir = sandboxBuildDir (takeDirectory f </> ".cabal-sandbox")-  b <- doesDirectoryExist sandboxDir-  let distDir = if b then sandboxDir else "dist"-  i <- cabalConfiguration f distDir <$> readPackageDescription silent f-  i <- addPackageDbs =<< canonicalizePaths i-  whenLoud $ putStrLn $ "Cabal Info: " ++ show i-  return i--------------------------------------------------------------------------------------------------findCabalFile :: FilePath -> IO (Maybe FilePath)-------------------------------------------------------------------------------------------------findCabalFile = fmap listToMaybe . findInPath isCabal-  where-    isCabal   = (".cabal" ==) . takeExtension--findInPath :: (FilePath -> Bool) -> FilePath -> IO [FilePath]-findInPath p f = concat <$> mapM (findInDir p) (ancestorDirs f)--ancestorDirs :: FilePath -> [FilePath]-ancestorDirs = go . takeDirectory-  where-    go f-      | f == f'   = [f]-      | otherwise = f : go f'-      where-        f'        = takeDirectory f--findInDir :: (FilePath -> Bool) -> FilePath -> IO [FilePath]-findInDir p dir = do-  files <- getDirectoryContents dir-  return [ dir </> f | f <- files, p f ]------------------------------------------------------------------------------------------------------ INVARIANT: all FilePaths must be absolute-data Info = Info { cabalFile    :: FilePath-                 , buildDirs    :: [FilePath]-                 , sourceDirs   :: [FilePath]-                 , exts         :: [Extension]-                 , otherOptions :: [String]-                 , packageDbs   :: [String]-                 , packageDeps  :: [String]-                 , macroPath    :: FilePath-                 } deriving (Show)---addPackageDbs :: Info -> IO Info-addPackageDbs i = maybe i addDB <$> getSandboxDB i-  where-    addDB db    = i { packageDbs = T.unpack db : packageDbs i}--getSandboxDB :: Info -> IO (Maybe T.Text)-getSandboxDB i = do-  tM <- maybeReadFile $ sandBoxFile i-  case tM of-   Just t  -> return $ Just $ parsePackageDb t-   Nothing -> return Nothing-   -- fmap <$> maybeReadFile (sandBoxFile i)--parsePackageDb :: T.Text -> T.Text-parsePackageDb t = case dbs of-                    [db] -> T.strip db-                    _    -> exitWithPanic $ "Malformed package-db in sandbox: " ++ show dbs-                   where-                     dbs = mapMaybe (T.stripPrefix pfx) $ T.lines t-                     pfx = "package-db:"-    -- /Users/rjhala/research/liquid/liquidhaskell/.cabal-sandbox/x86_64-osx-ghc-7.8.3-packages.conf.d--maybeReadFile :: FilePath -> IO (Maybe T.Text)-maybeReadFile f = do-  b <- doesFileExist f-  if b then Just <$> TIO.readFile f-       else return Nothing----sandBoxFile :: Info -> FilePath-sandBoxFile i = dir </> "cabal.sandbox.config"-  where-    dir       = takeDirectory $ cabalFile i---dumpPackageDescription :: PackageDescription -> FilePath -> FilePath -> Info-dumpPackageDescription pkgDesc file distDir = Info {-    cabalFile    = file-  , buildDirs    = nub (map normalise buildDirs)-  , sourceDirs   = nub (normalise <$> getSourceDirectories buildInfo dir)-  , exts         = nub (concatMap usedExtensions buildInfo)-  , otherOptions = nub (filter isAllowedOption (concatMap (hcOptions GHC) buildInfo))-  , packageDbs   = []-  , packageDeps  = nub [ unPackName n | Dependency n _ <- buildDepends pkgDesc, n /= thisPackage ]-  , macroPath    = macroPath-  }-  where-    (buildDirs, macroPath) = getBuildDirectories pkgDesc distDir-    buildInfo    = allBuildInfo pkgDesc-    dir          = dropFileName file-    thisPackage  = (pkgName . package) pkgDesc--unPackName :: PackageName -> String-unPackName (PackageName s) = s---getSourceDirectories :: [BuildInfo] -> FilePath -> [String]-getSourceDirectories buildInfo cabalDir = map (cabalDir </>) (concatMap hsSourceDirs buildInfo)--allowedOptions :: [String]-allowedOptions =-  ["-W"-  ,"-w"-  ,"-Wall"-  ,"-fglasgow-exts"-  ,"-fpackage-trust"-  ,"-fhelpful-errors"-  ,"-F"-  ,"-cpp"]--allowedOptionPrefixes :: [String]-allowedOptionPrefixes =-  ["-fwarn-"-  ,"-fno-warn-"-  ,"-fcontext-stack="-  ,"-firrefutable-tuples"-  ,"-D"-  ,"-U"-  ,"-I"-  ,"-fplugin="-  ,"-fplugin-opt="-  ,"-pgm"-  ,"-opt"]---getBuildDirectories :: PackageDescription -> FilePath -> ([String], FilePath)-getBuildDirectories pkgDesc distDir =-  (case library pkgDesc of-    Just _ -> buildDir : buildDirs-    Nothing -> buildDirs-  ,autogenDir </> cppHeaderName)-  where-    buildDir       = distDir </> "build"-    autogenDir     = buildDir </> "autogen"-    execBuildDir e = buildDir </> exeName e </> (exeName e ++ "-tmp")-    buildDirs      = autogenDir : map execBuildDir (executables pkgDesc)----- See https://github.com/haskell/cabal/blob/master/cabal-install/Distribution/Client/Sandbox.hs#L137-L158-sandboxBuildDir :: FilePath -> FilePath-sandboxBuildDir sandboxDir = "dist/dist-sandbox-" ++ showHex sandboxDirHash ""-  where-    sandboxDirHash = jenkins sandboxDir--    -- See http://en.wikipedia.org/wiki/Jenkins_hash_function-    jenkins :: String -> Word32-    jenkins str = loop_finish $ foldl' loop 0 str-      where-        loop :: Word32 -> Char -> Word32-        loop hash key_i' = hash'''-          where-            key_i   = toEnum . ord $ key_i'-            hash'   = hash + key_i-            hash''  = hash' + (shiftL hash' 10)-            hash''' = hash'' `xor` (shiftR hash'' 6)--        loop_finish :: Word32 -> Word32-        loop_finish hash = hash'''-          where-            hash'   = hash + (shiftL hash 3)-            hash''  = hash' `xor` (shiftR hash' 11)-            hash''' = hash'' + (shiftL hash'' 15)--isAllowedOption :: String -> Bool-isAllowedOption opt = elem opt allowedOptions || any (`isPrefixOf` opt) allowedOptionPrefixes--buildCompiler :: CompilerId-buildCompiler = CompilerId buildCompilerFlavor compilerVersion--cabalConfiguration :: FilePath -> FilePath -> GenericPackageDescription -> Info-cabalConfiguration cabalFile distDir desc =-  case finalizePackageDescription []-                                  (const True)-                                  buildPlatform-#if MIN_VERSION_Cabal(1,22,0)-                                  (unknownCompilerInfo buildCompiler NoAbiTag)-#else-                                  buildCompiler-#endif-                                  []-                                  desc of-       Right (pkgDesc,_) -> dumpPackageDescription pkgDesc cabalFile distDir-       Left e -> exitWithPanic $ "Issue with package configuration\n" ++ show e--canonicalizePaths :: Info -> IO Info-canonicalizePaths i = do-  buildDirs <- mapM canonicalizePath (buildDirs i)-  macroPath <- canonicalizePath (macroPath i)-  return (i { buildDirs = buildDirs, macroPath = macroPath })
− src/Language/Haskell/Liquid/CmdLine.hs 
@@ -1,370 +0,0 @@-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE TypeSynonymInstances      #-}-{-# OPTIONS_GHC -fno-cse #-}--{-@ LIQUID "--cabaldir" @-}-{-@ LIQUID "--diff"     @-}---- | This module contains all the code needed to output the result which---   is either: `SAFE` or `WARNING` with some reasonable error message when---   something goes wrong. All forms of errors/exceptions should go through---   here. The idea should be to report the error, the source position that---   causes it, generate a suitable .json file and then exit.---module Language.Haskell.Liquid.CmdLine (-   -- * Get Command Line Configuration-     getOpts, mkOpts--   -- * Update Configuration With Pragma-   , withPragmas-   , withCabal--   -- * Exit Function-   , exitWithResult--   -- * Diff check mode-   , diffcheck-) where--import Control.Applicative                 ((<$>))-import Control.Monad-import Data.Maybe-import System.Directory-import System.Exit-import System.Environment--import System.Console.CmdArgs.Explicit-import System.Console.CmdArgs.Implicit     hiding (Loud)-import System.Console.CmdArgs.Text--import Data.List                           (intercalate, nub)-import Data.Monoid--import           System.FilePath                     (dropFileName, isAbsolute,-                                                      takeDirectory, (</>))--import Language.Fixpoint.Config            hiding (Config, real, native, getOpts)-import Language.Fixpoint.Files-import Language.Fixpoint.Misc-import Language.Fixpoint.Names             (dropModuleNames)-import Language.Fixpoint.Types             hiding (Result)-import Language.Haskell.Liquid.Annotate-import Language.Haskell.Liquid.GhcMisc-import Language.Haskell.Liquid.Misc-import Language.Haskell.Liquid.PrettyPrint-import Language.Haskell.Liquid.Types       hiding (config, name, typ)-import Language.Haskell.Liquid.Errors-import Language.Haskell.Liquid.Cabal--import Text.Parsec.Pos                     (newPos)-import Text.PrettyPrint.HughesPJ           hiding (Mode)--------------------------------------------------------------------------------------- Parsing Command Line----------------------------------------------------------------------------------------------------------------------------------------------config = cmdArgsMode $ Config {-   files-    = def &= typ "TARGET"-          &= args-          &= typFile-- , idirs-    = def &= typDir-          &= help "Paths to Spec Include Directory "-- , fullcheck-     = def-           &= help "Full Checking: check all binders (DEFAULT)"-- , diffcheck-    = def-          &= help "Incremental Checking: only check changed binders"-- , real-    = def-          &= help "Supports real number arithmetic"- , native-    = def &= help "Use native (Haskell) fixpoint constraint solver"-- , binders-    = def &= help "Check a specific set of binders"-- , noPrune-    = def &= help "Disable prunning unsorted Predicates"-          &= name "no-prune-unsorted"-- , notermination-    = def &= help "Disable Termination Check"-          &= name "no-termination-check"-- , nowarnings-    = def &= help "Don't display warnings, only show errors"-          &= name "no-warnings"-- , trustinternals-    = def &= help "Trust all ghc auto generated code"-          &= name "trust-interals"-- , nocaseexpand-    = def &= help "Disable Termination Check"-          &= name "no-case-expand"- , strata-    = def &= help "Enable Strata Analysis"-- , notruetypes-    = def &= help "Disable Trueing Top Level Types"-          &= name "no-true-types"-- , totality-    = def &= help "Check totality"-- , smtsolver-    = def &= help "Name of SMT-Solver"-- , noCheckUnknown-    = def &= explicit-          &= name "no-check-unknown"-          &= help "Don't complain about specifications for unexported and unused values "-- , maxParams-    = 2   &= help "Restrict qualifier mining to those taking at most `m' parameters (2 by default)"-- , shortNames-    = def &= name "short-names"-          &= help "Print shortened names, i.e. drop all module qualifiers."-- , shortErrors-    = def &= name "short-errors"-          &= help "Don't show long error messages, just line numbers."-- , cabalDir-    = def &= name "cabal-dir"-          &= help "Find and use .cabal to add paths to sources for imported files"-- , ghcOptions-    = def &= name "ghc-option"-          &= typ "OPTION"-          &= help "Pass this option to GHC"-- , cFiles-    = def &= name "c-files"-          &= typ "OPTION"-          &= help "Tell GHC to compile and link against these files"-- } &= verbosity-   &= program "liquid"-   &= help    "Refinement Types for Haskell"-   &= summary copyright-   &= details [ "LiquidHaskell is a Refinement Type based verifier for Haskell"-              , ""-              , "To check a Haskell file foo.hs, type:"-              , "  liquid foo.hs "-              ]--getOpts :: IO Config-getOpts = do-  cfg0    <- envCfg-  cfg1    <- mkOpts =<< cmdArgsRun' config-  cfg     <- fixConfig $ mconcat [cfg0, cfg1]-  whenNormal $ putStrLn copyright-  case smtsolver cfg of-    Just _  -> return cfg-    Nothing -> do smts <- mapM findSmtSolver [Z3, Cvc4, Mathsat]-                  case catMaybes smts of-                    (s:_) -> return (cfg {smtsolver = Just s})-                    _     -> exitWithPanic noSmtError-  where-    noSmtError = "LiquidHaskell requires an SMT Solver, i.e. z3, cvc4, or mathsat to be installed."--cmdArgsRun' :: Mode (CmdArgs a) -> IO a-cmdArgsRun' mode-  = do parseResult <- process mode <$> getArgs-       case parseResult of-         Left err ->-           putStrLn (help err) >> exitFailure-         Right args ->-           cmdArgsApply args-    where-      help err = showText defaultWrap $ helpText [err] HelpFormatDefault mode--findSmtSolver :: SMTSolver -> IO (Maybe SMTSolver)-findSmtSolver smt = maybe Nothing (const $ Just smt) <$> findExecutable (show smt)--fixConfig :: Config -> IO Config-fixConfig cfg = do-  pwd <- getCurrentDirectory-  cfg <- canonicalizePaths pwd cfg-  -- cfg <- withCabal cfg-  return $ fixDiffCheck cfg---- | Attempt to canonicalize all `FilePath's in the `Config' so we don't have---   to worry about relative paths.-canonicalizePaths :: FilePath -> Config -> IO Config-canonicalizePaths pwd cfg = do-  tgt   <- canonicalizePath pwd-  isdir <- doesDirectoryExist tgt-  is    <- mapM (canonicalize tgt isdir) $ idirs cfg-  cs    <- mapM (canonicalize tgt isdir) $ cFiles cfg-  return $ cfg { idirs = is, cFiles = cs }--canonicalize :: FilePath -> Bool -> FilePath -> IO FilePath-canonicalize tgt isdir f-  | isAbsolute f = return f-  | isdir        = canonicalizePath (tgt </> f)-  | otherwise    = canonicalizePath (takeDirectory tgt </> f)--fixDiffCheck :: Config -> Config-fixDiffCheck cfg = cfg { diffcheck = diffcheck cfg && not (fullcheck cfg) }--envCfg = do so <- lookupEnv "LIQUIDHASKELL_OPTS"-            case so of-              Nothing -> return mempty-              Just s  -> parsePragma $ envLoc s-         where-            envLoc  = Loc l l-            l       = newPos "ENVIRONMENT" 0 0--copyright = "LiquidHaskell Copyright 2009-15 Regents of the University of California. All Rights Reserved.\n"--mkOpts :: Config -> IO Config-mkOpts cfg-  = do let files' = sortNub $ files cfg-       id0 <- getIncludeDir-       return  $ cfg { files = files' }-                     { idirs = (dropFileName <$> files') ++ [id0 </> gHC_VERSION, id0] ++ idirs cfg }-                              -- tests fail if you flip order of idirs'-------------------------------------------------------------------------------------------- | Updating options----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------withPragmas :: Config -> FilePath -> [Located String] -> IO Config-----------------------------------------------------------------------------------------withPragmas cfg fp ps = foldM withPragma cfg ps >>= canonicalizePaths fp--withPragma :: Config -> Located String -> IO Config-withPragma c s = (c `mappend`) <$> parsePragma s--parsePragma   :: Located String -> IO Config-parsePragma s = withArgs [val s] $ cmdArgsRun config------------------------------------------------------------------------------------------withCabal :: Config -> IO Config-----------------------------------------------------------------------------------------withCabal cfg-  | cabalDir cfg = withCabal' cfg-  | otherwise    = return cfg--withCabal' cfg = do-  whenLoud $ putStrLn $ "addCabalDirs: " ++ tgt-  io <- cabalInfo tgt-  case io of-    Just i  -> return $ fixCabalDirs' cfg i-    Nothing -> exitWithPanic "Cannot find .cabal information!"-  where-    tgt = case files cfg of-            f:_ -> f-            _   -> exitWithPanic "Please provide a target file to verify."---fixCabalDirs' :: Config -> Info -> Config-fixCabalDirs' cfg i = cfg { idirs      = nub $ idirs cfg ++ sourceDirs i ++ buildDirs i }-                          { ghcOptions = ghcOptions cfg ++ dbOpts ++ pkOpts-                                      ++ ["-optP-include", "-optP" ++ macroPath i]}-   where-     dbOpts         = ["-package-db " ++ db | db <- packageDbs  i]-     pkOpts         = ["-package "    ++ n  | n  <- packageDeps i] -- SPEED HIT for smaller benchmarks---------------------------------------------------------------------------------------------- | Monoid instances for updating options-------------------------------------------------------------------------------------------instance Monoid Config where-  mempty        = Config def def def def def def def def def def def def def def def def 2 def def def def def def-  mappend c1 c2 = Config { files          = sortNub $ files c1   ++     files          c2-                         , idirs          = sortNub $ idirs c1   ++     idirs          c2-                         , fullcheck      = fullcheck c1         ||     fullcheck      c2-                         , real           = real      c1         ||     real           c2-                         , diffcheck      = diffcheck c1         ||     diffcheck      c2-                         , native         = native    c1         ||     native         c2-                         , binders        = sortNub $ binders c1 ++     binders        c2-                         , noCheckUnknown = noCheckUnknown c1    ||     noCheckUnknown c2-                         , notermination  = notermination  c1    ||     notermination  c2-                         , nowarnings     = nowarnings     c1    ||     nowarnings     c2-                         , trustinternals = trustinternals c1    ||     trustinternals c2-                         , nocaseexpand   = nocaseexpand   c1    ||     nocaseexpand   c2-                         , strata         = strata         c1    ||     strata         c2-                         , notruetypes    = notruetypes    c1    ||     notruetypes    c2-                         , totality       = totality       c1    ||     totality       c2-                         , noPrune        = noPrune        c1    ||     noPrune        c2-                         , maxParams      = maxParams      c1   `max`   maxParams      c2-                         , smtsolver      = smtsolver c1      `mappend` smtsolver      c2-                         , shortNames     = shortNames c1        ||     shortNames     c2-                         , shortErrors    = shortErrors c1       ||     shortErrors    c2-                         , cabalDir       = cabalDir    c1       ||     cabalDir       c2-                         , ghcOptions     = ghcOptions c1        ++     ghcOptions     c2-                         , cFiles         = cFiles c1            ++     cFiles         c2-                         }--instance Monoid SMTSolver where-  mempty        = def-  mappend s1 s2-    | s1 == s2  = s1-    | s2 == def = s1-    | otherwise = s2------------------------------------------------------------------------------ | Exit Function ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------exitWithResult :: Config -> FilePath -> Output Doc -> IO (Output Doc)--------------------------------------------------------------------------exitWithResult cfg target out-  = do {-# SCC "annotate" #-} annotate cfg target out-       donePhase Loud "annotate"-       writeCheckVars $ o_vars  out-       writeResult cfg (colorResult r) r-       writeFile   (extFileName Result target) (showFix r)-       return $ out { o_result = r }-    where-       r         = o_result out `addErrors` o_errors out---writeCheckVars Nothing     = return ()-writeCheckVars (Just [])   = colorPhaseLn Loud "Checked Binders: None" ""-writeCheckVars (Just ns)   = colorPhaseLn Loud "Checked Binders:" "" >> forM_ ns (putStrLn . symbolString . dropModuleNames . symbol)--writeResult cfg c          = mapM_ (writeDoc c) . zip [0..] . resDocs tidy-  where-    tidy                   = if shortErrors cfg then Lossy else Full-    writeDoc c (i, d)      = writeBlock c i $ lines $ render d-    writeBlock _ _ []      = return ()-    writeBlock c 0 ss      = forM_ ss (colorPhaseLn c "")-    writeBlock _  _ ss     = forM_ ("\n" : ss) putStrLn--resDocs _ Safe             = [text "SAFE"]-resDocs k (Crash xs s)     = text ("ERROR: " ++ s) : pprManyOrdered k "" (errToFCrash <$> xs)-resDocs k (Unsafe xs)      = text "UNSAFE" : pprManyOrdered k "" (nub xs)-resDocs _ (UnknownError d) = [text $ "PANIC: Unexpected Error: " ++ d, reportUrl]--reportUrl              = text "Please submit a bug report at: https://github.com/ucsd-progsys/liquidhaskell"---addErrors r []             = r-addErrors Safe errs        = Unsafe errs-addErrors (Unsafe xs) errs = Unsafe (xs ++ errs)-addErrors r  _             = r-instance Fixpoint (FixResult Error) where-  toFix = vcat . resDocs Full
+ src/Language/Haskell/Liquid/Constraint/Axioms.hs view
@@ -0,0 +1,569 @@+{-# LANGUAGE DeriveFoldable            #-}+{-# LANGUAGE DeriveTraversable         #-}+{-# 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 #-}++module Language.Haskell.Liquid.Constraint.Axioms (++    expandProofs++    -- * Combining proofs+  , makeCombineType+  , makeCombineVar++  ) where+++import Prelude hiding (error)++import Literal++import Coercion+import DataCon+import CoreSyn+import Type+import TyCon+import TypeRep+import Var+import Name+import NameSet++import Text.PrettyPrint.HughesPJ hiding (first, sep)+import Control.Monad.State+import qualified Data.List           as L+import qualified Data.HashMap.Strict as M+import Data.Maybe               (fromJust)+import Language.Fixpoint.Types.Names+import Language.Fixpoint.Utils.Files++import qualified Language.Fixpoint.Types            as F++import Language.Haskell.Liquid.UX.Tidy (panicError)+import Language.Haskell.Liquid.Types.Visitors (freeVars)+import Language.Haskell.Liquid.Types            hiding (binds, Loc, loc, freeTyVars, Def, HAxiom)+import qualified Language.Haskell.Liquid.Types as T+import Language.Haskell.Liquid.WiredIn+import Language.Haskell.Liquid.Types.RefType+import Language.Haskell.Liquid.Types.Visitors         hiding (freeVars)+import Language.Haskell.Liquid.GHC.Misc+import Language.Haskell.Liquid.GHC.SpanStack                 (showSpan)+import Language.Fixpoint.Misc                         hiding (errorstar)+import Language.Haskell.Liquid.Constraint.ProofToCore+import Language.Haskell.Liquid.Transforms.CoreToLogic+import Language.Haskell.Liquid.Constraint.Types++import System.IO.Unsafe++import Language.Haskell.Liquid.Prover.Types (Axiom(..), Query(..))+import qualified Language.Haskell.Liquid.Prover.Types as P+import Language.Haskell.Liquid.Prover.Solve (solve)+++import qualified Data.HashSet        as S++++class Provable a where++  expandProofs :: GhcInfo -> [(F.Symbol, SpecType)] -> a -> CG a+  expandProofs info sigs x =+    do (x, s) <- runState (expProofs x) <$> initAEEnv info sigs+       modify $ \st -> st {freshIndex = ae_index s}+       return x++  expProofs :: a -> Pr a+  expProofs = return+++instance Provable CoreBind where+  -- expProofs (NonRec x e) | returnsProof x =  (\e -> Rec [(traceShow ("\n\nMake it Rec\n\n" ++ show (F.symbol x)) x,e)]) <$> (addRec (x,e) >> expProofs e)+  expProofs (NonRec x e) =+     do e' <- addRec (x,e) >> expProofs e+        if x `elem` freeVars S.empty e'+          then return $ Rec [(x, e')]+          else return $ NonRec x e'+  expProofs (Rec xes)    = Rec      <$> (addRecs xes  >> mapSndM expProofs xes)+++instance Provable CoreExpr where+  expProofs ee@(App (App (Tick _ (Var f)) i) e) | isAuto f = grapInt i >>= expandAutoProof ee e+  expProofs ee@(App (App (Var f) i) e)          | isAuto f = grapInt i >>= expandAutoProof ee e+  expProofs ee@(App (Tick _ (App (Tick _ (Var f)) i)) e) | isAuto f = grapInt i >>= expandAutoProof ee e+  expProofs ee@(App (Tick _ (App (Var f) i)) e)          | isAuto f = grapInt i >>= expandAutoProof ee e+++  expProofs ee@(App (App (Tick _ (Var f)) i) e) | isCases f = grapInt i >>= expandCasesProof ee e+  expProofs ee@(App (App (Var f) i) e)          | isCases f = grapInt i >>= expandCasesProof ee e+  expProofs ee@(App (Tick _ (App (Tick _ (Var f)) i)) e) | isCases f = grapInt i >>= expandCasesProof ee e+  expProofs ee@(App (Tick _ (App (Var f) i)) e)          | isCases f = grapInt i >>= expandCasesProof ee e++  expProofs (App e1 e2) = liftM2 App (expProofs e1) (expProofs e2)+  expProofs (Lam x e)   = addVar x >> liftM  (Lam x) (expProofs e)+  expProofs (Let b e)   = do b' <- expProofs b+                             addBind b'+                             liftM (Let b') (expProofs e)+  expProofs (Case e v t alts) = liftM2 (\e -> Case e v t) (expProofs e) (mapM (expProofsCase e) alts)+  expProofs (Cast e c)   = liftM (`Cast` c) (expProofs e)+  expProofs (Tick t e)   = liftM (Tick t) (expProofs e)++  expProofs (Var v)      = return $ Var v+  expProofs (Lit l)      = return $ Lit l+  expProofs (Type t)     = return $ Type t+  expProofs (Coercion c) = return $ Coercion c++++expProofsCase :: CoreExpr -> CoreAlt -> Pr CoreAlt+expProofsCase (Var x) (DataAlt c, xs, e)+  = do addVars xs+       t <- L.lookup (symbol c) . ae_sigs <$> get+       addAssert $ makeRefinement t (x:xs)+       res <- liftM (DataAlt c,xs,) (expProofs e)+       rmAssert+       return res++expProofsCase _ (c, xs, e)+  = addVars xs >> liftM (c,xs,) (expProofs e)+++instance Provable CoreAlt where+  expProofs (c, xs, e) = addVars xs >> liftM (c,xs,) (expProofs e)++expandCasesProof :: CoreExpr -> CoreExpr -> Integer -> Pr CoreExpr+expandCasesProof inite e it+  = do vs <-  reverse . ae_vars <$> get+       case L.find (isAlgType . varType) vs of+          Nothing -> return inite+          Just v  -> makeCases v inite e it++makeDataCons v = data_cons $ algTyConRhs tc+  where+    t  = varType v+    tc = fst $ splitTyConApp t++makeCases v inite e it = Case (Var v) v (varType v) <$> (mapM go $ makeDataCons v)+  where+    go c = do xs <- makeDataConArgs v c+              addVars xs+              t <- L.lookup (symbol c) . ae_sigs <$> get+              addAssert $ makeRefinement t (v:xs)+              proof <- expandAutoProof inite (e) it+              rmAssert+              return (DataAlt c, xs, proof)++makeDataConArgs v dc = mapM freshVar ts+  where+    ts = dataConInstOrigArgTys dc ats+    ats = snd $ splitTyConApp $ varType v+++expandAutoProof :: CoreExpr -> CoreExpr -> Integer -> Pr CoreExpr+expandAutoProof inite e it+  =  do ams  <- ae_axioms  <$> get+        vs'  <- ae_vars    <$> get+        cts  <- ae_consts  <$> get+        ds   <- ae_assert  <$> get+        cmb  <- ae_cmb     <$> get+        lmap <- ae_lmap    <$> get+        isHO <- ae_isHO    <$> get +        e'   <- unANFExpr e++        foldM (\lm x -> (updateLMap lm (dummyLoc $ F.symbol x) x >> (ae_lmap <$> get))) lmap vs'++        let (vs, vlits)  = L.partition (`elem` readVars e') $ nub' vs'+        let allvs        = nub'  ((fst . aname <$> ams) ++ cts  ++ vs')+        let (cts', vcts) = L.partition (isFunctionType . varType) allvs+        let usedVs = nub' (vs++vcts)++        env    <- makeEnvironment ((L.\\) allvs usedVs) ((L.\\) vlits usedVs)+        ctors  <- mapM makeCtor cts'+        pvs    <- mapM makeVar usedVs+        le     <- makeGoalPredicate e'+        fn     <- freshFilePath+        axioms <- makeAxioms+        let sol = unsafePerformIO (solve $ makeQuery fn it isHO le axioms ctors ds env pvs)+        return $ {-+          traceShow (+            "\n\nTo prove\n" ++ show (showpp le) +++            "\n\nWe need \n" ++ show sol         +++            "\n\nExpr =  \n" ++ show (toCore cmb inite sol)         +++            "\n\n"+           ) $ -}+          traceShow "\nexpandedExpr\n" $ toCore cmb inite sol++nub' = L.nubBy (\v1 v2 -> F.symbol v1 == F.symbol v2)++-- TODO: merge this with the Bare.Axiom.hs+updateLMap :: LogicMap  -> LocSymbol -> Var -> Pr ()+updateLMap _ _ v | not (isFun $ varType v)+  = return ()+  where+    isFun (FunTy _ _)    = True+    isFun (ForAllTy _ t) = isFun t+    isFun  _             = False++updateLMap _ x vv+  = insertLogicEnv x' ys (F.eApps (F.EVar $ val x) (F.EVar <$> ys))+  where+    nargs = dropWhile isClassType $ ty_args $ toRTypeRep $ ((ofType $ varType vv) :: RRType ())++    ys = zipWith (\i _ -> symbol (("x" ++ show i) :: String)) [1..] nargs+    x' = simpleSymbolVar vv++insertLogicEnv x ys e+  = modify $ \be -> be {ae_lmap = (ae_lmap be) {logic_map = M.insert x (LMap x ys e) $ logic_map $ ae_lmap be}}++simpleSymbolVar  x = dropModuleNames $ symbol $ showPpr $ getName x++-------------------------------------------------------------------------------+----------------   From Haskell to Prover  ------------------------------------+-------------------------------------------------------------------------------++++++makeEnvironment :: [Var] -> [Var] -> Pr [P.LVar]+makeEnvironment avs vs+  = do lits <- ae_lits <$> get+       let lts'  = filter (\(x,_) -> not (x `elem` (F.symbol <$> avs))) (normalize lits)+       let lts1  = [P.Var x s () | (x, s) <- lts']+       lts2  <- mapM makeLVar vs+       return (lts1 ++ lts2)++++makeQuery :: FilePath -> Integer -> Bool -> F.Expr -> [HAxiom] -> [HVarCtor] -> [F.Expr] -> [P.LVar] ->  [HVar] -> HQuery+makeQuery fn i isHO p axioms cts ds env vs + = Query   { q_depth  = fromInteger i+           , q_goal   = P.Pred p++           , q_vars   = checkVar  <$> vs      -- local variables+           , q_ctors  = cts                   -- constructors: globals with function type+           , q_env    = checkEnv  <$> env     -- environment: anything else that can appear in the logic++           , q_fname  = fn+           , q_axioms = axioms+           , q_decls  = (P.Pred <$> ds)+           , q_isHO   = isHO +           }++checkEnv pv@(P.Var x s _)+  | isBaseSort s = pv+  | otherwise    = panic Nothing ("\nEnv:\nNon Basic " ++ show x ++ "  ::  " ++ show s)++checkVar pv@(P.Var x s _)+  | isBaseSort s = pv+  | otherwise    = panic Nothing ("\nVar:\nNon Basic " ++ show x ++ "  ::  " ++ show s)++makeAxioms =+  do recs <- ae_recs    <$> get+     tce  <- ae_emb     <$> get+     sigs <- ae_sigs    <$> get+     gs   <- ae_globals <$> get+     let (rgs, gs') = L.partition (`elem` (fst <$> recs)) $ filter returnsProof gs+     let as1 = varToPAxiom tce sigs <$> gs'+     let as2 = varToPAxiomWithGuard tce sigs recs <$> rgs+     return (as1 ++ as2)++unANFExpr e = (foldl (flip Let) e . ae_binds) <$> get++makeGoalPredicate e =+  do lm   <- ae_lmap    <$> get+     tce  <- ae_emb     <$> get+     case runToLogic tce lm (ErrOther (showSpan "makeGoalPredicate") . text) (coreToPred e) of+       Left p    -> return p+       Right err -> panicError err++makeRefinement :: Maybe SpecType -> [Var] -> F.Expr+makeRefinement Nothing  _ = F.PTrue+makeRefinement (Just t) xs = rr+  where trep = toRTypeRep t+        ys   = [x | (x, t') <- zip (ty_binds trep) (ty_args trep), not (isClassType t')]+        rr   = case stripRTypeBase $ ty_res trep of+                 Nothing  -> F.PTrue+                 Just ref -> let F.Reft(v, r) = F.toReft ref+                                 su = F.mkSubst $ zip (v:ys) (F.EVar . F.symbol <$> xs)+                             in F.subst su r++++makeCtor :: Var -> Pr HVarCtor+makeCtor c+  = do tce  <- ae_emb     <$> get+       sigs <- ae_sigs    <$> get+       lmap <- ae_lmap    <$> get+       lvs  <- ae_vars    <$> get+       return $ makeCtor' tce lmap sigs (c `elem` lvs) c++makeCtor' :: F.TCEmb TyCon -> LogicMap -> [(F.Symbol, SpecType)] -> Bool -> Var -> HVarCtor+makeCtor' tce _ _ islocal  v | islocal+  = P.VarCtor (P.Var (F.symbol v) (typeSort tce $ varType v) v) [] (P.Pred F.PTrue)++makeCtor' tce lmap sigs _  v+  = case M.lookup v (axiom_map lmap) of+    Nothing -> P.VarCtor (P.Var (F.symbol v) (typeSort tce $ varType v)      v) vs r+    Just x  -> P.VarCtor (P.Var x            (typeSort tce $ varType v) v) [] (P.Pred F.PTrue)++  where+    x    = F.symbol v+    (vs, r) = case L.lookup x sigs of+                Nothing -> ([], P.Pred F.PTrue)+                Just t  -> let trep = toRTypeRep t+                           in case stripRTypeBase $ ty_res trep of+                               Nothing -> ([], P.Pred F.PTrue)+                               Just r  -> let (F.Reft(v, p)) = F.toReft r+                                              xts = [(x,t) | (x, t) <- zip (ty_binds trep) (ty_args trep), not $ isClassType t]+                                              e  = F.mkEApp (dummyLoc x) (F.EVar . fst  <$> xts)+                                          in ([P.Var x (rTypeSort tce t) ()  | (x, t) <- xts], P.Pred $ F.subst1 p (v, e))++makeVar :: Var -> Pr HVar+makeVar v = do {tce <- ae_emb <$> get; return $ makeVar' tce v}++makeVar'  tce v = P.Var (F.symbol v) (typeSort tce $ varType v) v++makeLVar :: Var -> Pr P.LVar+makeLVar v = do {tce <- ae_emb <$> get; return $ makeLVar' tce v}++makeLVar' tce v = P.Var (F.symbol v) (typeSort tce $ varType v) ()++++varToPAxiomWithGuard :: F.TCEmb TyCon -> [(Symbol, SpecType)] -> [(Var, [Var])] -> Var -> HAxiom+varToPAxiomWithGuard tce sigs recs v+  = P.Axiom { axiom_name = makeVar' tce v+            , axiom_vars = vs+            , axiom_body = P.Pred $ F.PImp q bd+            }+  where+    q = makeGuard $ zip (symbol <$> args) xts+    args = fromJust $ L.lookup v recs+    x = F.symbol v+    (vs, xts, bd) = case L.lookup x sigs of+                     Nothing -> panic Nothing ("haxiomToPAxiom: " ++ show x ++ " not found")+                     Just t -> let trep = toRTypeRep t+                                   bd'  = case stripRTypeBase $ ty_res trep of+                                            Nothing -> F.PTrue+                                            Just r  -> let (F.Reft(_, p)) = F.toReft r in p+                                   xts   = filter (not . isClassType . snd) $ zip (ty_binds trep) (ty_args trep)+                                   vs'   = [P.Var x (rTypeSort tce t) () | (x, t) <- xts]+                               in  (vs', xts, bd')++makeGuard :: [(F.Symbol, (F.Symbol, SpecType))] -> F.Expr+makeGuard xs = F.POr $ go [] xs+  where+    go _ []+      = []+    go acc ((x, (x', RApp c _ _ _)):xxs)+     | Just f <- sizeFunction $ rtc_info c+     = (F.PAnd (F.PAtom F.Lt (f x') (f x):acc)) : go (F.PAtom F.Le (f x') (f x):acc) xxs+    go acc (_:xxs)+     = go acc xxs+++varToPAxiom :: F.TCEmb TyCon -> [(Symbol, SpecType)] -> Var -> HAxiom+varToPAxiom tce sigs v+  = P.Axiom { axiom_name = makeVar' tce v+            , axiom_vars = vs+            , axiom_body = P.Pred bd+            }+  where+    x = F.symbol v+    (vs, bd) = case L.lookup x sigs of+                Nothing -> panic Nothing ("haxiomToPAxiom: " ++ show x ++ " not found")+                Just t -> let trep = toRTypeRep t+                              bd'  = case stripRTypeBase $ ty_res trep of+                                       Nothing -> F.PTrue+                                       Just r  -> let (F.Reft(_, p)) = F.toReft r in p+                              vs'   = [P.Var x (rTypeSort tce t) () | (x, t) <- zip (ty_binds trep) (ty_args trep), not $ isClassType t]+                          in  (vs', bd')+++-------------------------------------------------------------------------------+-------------  Proof State Environment ----------------------------------------+-------------------------------------------------------------------------------++type Pr = State AEnv++data AEnv = AE { ae_axioms  :: [T.HAxiom]            -- axiomatized functions+               , ae_binds   :: [CoreBind]            -- local bindings, tracked st they are expanded in logic+               , ae_lmap    :: LogicMap              -- logical mapping+               , ae_consts  :: [Var]                 -- Data constructors and imported variables+               , ae_globals :: [Var]                 -- Global definitions, like axioms+               , ae_vars    :: [Var]                 -- local variables in scope+               , ae_emb     :: F.TCEmb TyCon         -- type constructor information+               , ae_lits    :: [(Symbol, F.Sort)]    -- literals+               , ae_index   :: Integer               -- unique integer+               , ae_sigs    :: [(Symbol, SpecType)]  -- Refined type signatures+               , ae_target  :: FilePath              -- file name of target source coude+               , ae_recs    :: [(Var, [Var])]        -- axioms that are used recursively:+                                                     -- these axioms are guarded to used only with "smaller" arguments+               , ae_assert  :: [F.Expr]              --+               , ae_cmb     :: CoreExpr -> CoreExpr -> CoreExpr  -- how to combine proofs+               , ae_isHO    :: Bool                  -- allow higher order binders +               }+++initAEEnv info sigs+    = do tce    <- tyConEmbed  <$> get+         lts    <- lits        <$> get+         i      <- freshIndex  <$> get+         modify $ \s -> s{freshIndex = i + 1}+         return $ AE { ae_axioms  = axioms spc+                     , ae_binds   = []+                     , ae_lmap    = logicMap spc+                     , ae_consts  = L.nub vs+                     , ae_globals = L.nub tp+                     , ae_vars    = []+                     , ae_emb     = tce+                     , ae_lits    = wiredSortedSyms ++ lts+                     , ae_index   = i+                     , ae_sigs    = sigs+                     , ae_target  = target info+                     , ae_recs    = []+                     , ae_assert  = []+                     , ae_cmb     = \x y -> (App (App (Var by) x) y)+                     , ae_isHO    = higherorder $ config spc +                     }+    where+      spc        = spec info+      vs         = filter validVar (snd <$> freeSyms spc)+      tp         = filter validExp (defVars info)++      isExported = flip elemNameSet (exports $ spec info) . getName+      validVar   = not . canIgnore+      validExp x = validVar x && isExported x+      by         = makeCombineVar $ makeCombineType τProof+      τProof     = proofType $ spec info+++++addBind b     = modify $ \ae -> ae{ae_binds = b:ae_binds ae}+addAssert p   = modify $ \ae -> ae{ae_assert = p:ae_assert  ae}+rmAssert      = modify $ \ae -> ae{ae_assert = tail $ ae_assert ae}+addRec  (x,e) = modify $ \ae -> ae{ae_recs  = (x, grapArgs e):ae_recs  ae}+addRecs xes   = modify $ \ae -> ae{ae_recs  = [(x, grapArgs e) | (x, e) <- xes] ++ ae_recs  ae}++addVar  x | canIgnore x = return ()+          | otherwise   = modify $ \ae -> ae{ae_vars  = x:ae_vars  ae}+++addVars x = modify $ \ae -> ae{ae_vars  = x' ++ ae_vars  ae}+  where+    x' = filter (not . canIgnore) x++getUniq :: Pr Integer+getUniq+  = do modify (\s -> s{ae_index = 1 + (ae_index s)})+       ae_index <$> get+++freshVar :: Type -> Pr Var+freshVar t =+  do n <- getUniq+     return $ stringVar ("x" ++ show n) t++freshFilePath :: Pr FilePath+freshFilePath =+  do fn <- ae_target <$> get+     n  <- getUniq+     return $ (extFileName (Auto $ fromInteger n) fn)+++-------------------------------------------------------------------------------+--------------  Playing with Fixpoint  ----------------------------------------+-------------------------------------------------------------------------------+++isBaseSort _ = True ++++-------------------------------------------------------------------------------+--------------  Playing with GHC Core  ----------------------------------------+-------------------------------------------------------------------------------++-- hasBaseType = isBaseTy . varType++isFunctionType (FunTy _ _)    = True+isFunctionType (ForAllTy _ t) = isFunctionType t+isFunctionType _              = False+++resultType (ForAllTy _ t) = resultType t+resultType (FunTy _ t)    = resultType t+resultType  t             = t+++grapArgs (Lam x e) | isTyVar x  = grapArgs e+grapArgs (Lam x e) | isClassPred $ varType x = grapArgs e+grapArgs (Lam x e) = x : grapArgs e+grapArgs (Let _ e) = grapArgs e+grapArgs _         = []++++grapInt (Var v)+  = do bs <- ae_binds <$> get+       let (e:_) = [ex | NonRec x ex <- bs, x == v]+       return $ go e+  where+    go (Tick _ e) = go e+    go (App _ l)  = go l+    go (Lit l)    = litToInt l+    go e          = panic Nothing $ ("grapInt called with wrong argument " ++ showPpr e)++    litToInt (MachInt i) = i+    litToInt (MachInt64 i) = i+    litToInt _             = panic Nothing "litToInt: non integer literal"++grapInt (Tick _ e) = grapInt e+grapInt _          = return 2+++-------------------------------------------------------------------------------+--------------------  Combine Proofs  ----------------------------------------+-------------------------------------------------------------------------------++makeCombineType Nothing+  = panic Nothing "proofType not found"+makeCombineType (Just τ)+  = FunTy τ (FunTy τ τ)+++makeCombineVar τ =  stringVar combineProofsName τ+-------------------------------------------------------------------------------+-------------------  Helper Functions  ----------------------------------------+-------------------------------------------------------------------------------++canIgnore v = isInternal v || isTyVar v+isAuto    v = isPrefixOfSym "auto"  $ dropModuleNames $ F.symbol v+isCases   v = isPrefixOfSym "cases" $ dropModuleNames $ F.symbol v+isProof   v = isPrefixOfSym "Proof" $ dropModuleNames $ F.symbol v+++returnsProof :: Var -> Bool+returnsProof = isProof' . resultType . varType+  where+    isProof' (TyConApp tc _) = isProof tc+    isProof' _               = False+++normalize xts = filter hasBaseSort $ L.nub xts+  where+    hasBaseSort = isBaseSort . snd+++mapSndM act xys = mapM (\(x, y) -> (x,) <$> act y) xys
src/Language/Haskell/Liquid/Constraint/Constraint.hs view
@@ -1,49 +1,54 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances    #-} -module Language.Haskell.Liquid.Constraint.Constraint  where+-- TODO: what exactly is the purpose of this module? What do these functions do? -import Data.Monoid-import Data.Maybe-import Control.Applicative+module Language.Haskell.Liquid.Constraint.Constraint (+  constraintToLogic+, addConstraints+) where +import Prelude hiding (error)+import Data.Maybe import Language.Haskell.Liquid.Types import Language.Haskell.Liquid.Constraint.Types-+import Language.Haskell.Liquid.Constraint.Env import Language.Fixpoint.Types -instance Monoid LConstraint where-        mempty  = LC []-        mappend (LC cs1) (LC cs2) = LC (cs1 ++ cs2)--typeToConstraint t = LC [t]--addConstraints t γ = γ {lcs = mappend (typeToConstraint t) (lcs γ)}+--------------------------------------------------------------------------------+addConstraints :: CGEnv -> [(Symbol, SpecType)] -> CGEnv+--------------------------------------------------------------------------------+addConstraints γ t = γ {lcs = mappend (t2c t) (lcs γ)}+  where+    t2c z          = LC [z] -constraintToLogic γ (LC ts) = pAnd (constraintToLogicOne γ  <$> ts)+--------------------------------------------------------------------------------+constraintToLogic :: REnv -> LConstraint -> Expr+--------------------------------------------------------------------------------+constraintToLogic γ (LC ts) = pAnd (constraintToLogicOne γ <$> ts) -constraintToLogicOne γ env-  =  pAnd [subConstraintToLogicOne-            (zip xs xts)-            (last xs,-            (last $ (fst <$> xts), r))+-- RJ: The code below is atrocious. Please fix it!+constraintToLogicOne :: (Reftable r) => REnv -> [(Symbol, RRType r)] -> Expr+constraintToLogicOne γ binds+  = pAnd [subConstraintToLogicOne+          (zip xs xts)+          (last xs,+          (last (fst <$> xts), r))           | xts <- xss]   where-   xts      = init env+   xts      = init binds    (xs, ts) = unzip xts-   r        = snd $ last env-   xss      = combinations ((\t -> [(x, t) | x <- grapBindsWithType t γ]) <$> ts)+   r        = snd $ last binds+   xss      = combinations ((\t -> [(x, t) | x <- localBindsOfType t γ]) <$> ts)  subConstraintToLogicOne xts (x', (x, t)) = PImp (pAnd rs) r   where         (rs , su) = foldl go ([], []) xts         ([r], _ ) = go ([], su) (x', (x, t))-        go (acc, su) (x', (x, t)) = let (Reft(v, Refa p)) = toReft (fromMaybe mempty (stripRTypeBase t))-                                        su'               = (x', EVar x):(v, EVar x) : su+        go (acc, su) (x', (x, t)) = let (Reft(v, p)) = toReft (fromMaybe mempty (stripRTypeBase t))+                                        su'          = (x', EVar x):(v, EVar x) : su                                     in                                      (subst (mkSubst su') p : acc, su')--  combinations :: [[a]] -> [[a]] combinations []           = [[]]
+ src/Language/Haskell/Liquid/Constraint/Env.hs view
@@ -0,0 +1,286 @@++{-# 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     #-}++-- | This module defines the representation for Environments needed+--   during constraint generation.++module Language.Haskell.Liquid.Constraint.Env (++  -- * Insert+    (+++=)+  , (++=)+  , (+=)+  , extendEnvWithVV+  , addBinders+  , addSEnv+  , (-=)+  , globalize++  -- * Construction+  , fromListREnv+  , toListREnv+  , insertREnv -- TODO: remove this ASAP+    +  -- * Query+  , localBindsOfType+  , lookupREnv+  , (?=)++  -- * Pruning refinements (TODO: move!)+ , rTypeSortedReft'++  -- * Extend CGEnv+ , setLocation, setBind, setRecs, setTRec++  -- * Lookup CGEnv+ , getLocation++) where+++-- import Name (getSrcSpan)+import Prelude hiding (error)+import CoreSyn (CoreExpr)+import SrcLoc+import Var+-- import Outputable+-- import FastString (fsLit)+import Control.Monad.State++-- import           GHC.Err.Located hiding (error)+import           GHC.Stack++import           Control.Arrow           (first)+import           Data.Maybe              -- (fromMaybe)+import qualified Data.List               as L+import qualified Data.HashSet            as S+import qualified Data.HashMap.Strict     as M+import qualified Language.Fixpoint.Types as F+++import           Language.Fixpoint.SortCheck (pruneUnsortedReft)++++import           Language.Haskell.Liquid.Types.RefType+import qualified Language.Haskell.Liquid.GHC.SpanStack as Sp+import           Language.Haskell.Liquid.Types            hiding (binds, Loc, loc, freeTyVars, Def)+import           Language.Haskell.Liquid.Constraint.Types+import           Language.Haskell.Liquid.Constraint.Fresh+import           Language.Haskell.Liquid.Transforms.RefSplit+import qualified Language.Haskell.Liquid.UX.CTags       as Tg++-- import Debug.Trace (trace)++instance Freshable CG Integer where+  fresh = do s <- get+             let n = freshIndex s+             put $ s { freshIndex = n + 1 }+             return n++--------------------------------------------------------------------------------+-- | Refinement Type Environments ----------------------------------------------+--------------------------------------------------------------------------------++-- updREnvLocal :: REnv -> (_ -> _) -> REnv+updREnvLocal rE f      = rE { reLocal = f (reLocal rE) }++-- RJ: REnv-Split-Bug?+filterREnv :: (SpecType -> Bool) -> REnv -> REnv+filterREnv f rE        = rE `updREnvLocal` (M.filter f)++fromListREnv :: [(F.Symbol, SpecType)] -> [(F.Symbol, SpecType)] -> REnv+fromListREnv gXts lXts = REnv+  { reGlobal = M.fromList gXts+  , reLocal  = M.fromList lXts+  }++-- RJ: REnv-Split-Bug?+deleteREnv :: F.Symbol -> REnv -> REnv+deleteREnv x rE = rE `updREnvLocal` (M.delete x)++insertREnv :: F.Symbol -> SpecType -> REnv -> REnv+insertREnv x y rE = {- trace ("insertREnv: " ++ show x) $ -} rE `updREnvLocal` (M.insert x y)++lookupREnv :: F.Symbol -> REnv -> Maybe SpecType+lookupREnv x rE = msum $ M.lookup x <$> renvMaps rE++memberREnv :: F.Symbol -> REnv -> Bool+memberREnv x rE = or   $ M.member x <$> renvMaps rE++globalREnv :: REnv -> REnv+globalREnv (REnv gM lM) = REnv gM' M.empty+  where+    gM'  = M.unionWith (\_ t -> t) gM lM++renvMaps rE = [reLocal rE, reGlobal rE]++--------------------------------------------------------------------------------+localBindsOfType :: RRType r  -> REnv -> [F.Symbol]+--------------------------------------------------------------------------------+localBindsOfType tx γ = fst <$> localsREnv (filterREnv ((== toRSort tx) . toRSort) γ)++-- RJ: REnv-Split-Bug?+localsREnv :: REnv -> [(F.Symbol, SpecType)]+localsREnv = M.toList . reLocal++globalsREnv :: REnv -> [(F.Symbol, SpecType)]+globalsREnv = M.toList . reGlobal++toListREnv :: REnv -> [(F.Symbol, SpecType)]+toListREnv re = globalsREnv re ++ localsREnv re++--------------------------------------------------------------------------------+extendEnvWithVV :: CGEnv -> SpecType -> CG CGEnv+--------------------------------------------------------------------------------+extendEnvWithVV γ t+  | F.isNontrivialVV vv && not (vv `memberREnv` (renv γ))+  = (γ, "extVV") += (vv, t)+  | otherwise+  = return γ+  where+    vv = rTypeValueVar t++addBinders :: CGEnv -> F.Symbol -> [(F.Symbol, SpecType)] -> CG CGEnv+addBinders γ0 x' cbs   = foldM (++=) (γ0 -= x') [("addBinders", x, t) | (x, t) <- cbs]++addBind :: SrcSpan -> F.Symbol -> F.SortedReft -> CG ((F.Symbol, F.Sort), F.BindId)+addBind l x r = do+  st          <- get+  let (i, bs') = F.insertBindEnv x r (binds st)+  put          $ st { binds = bs' } { bindSpans = M.insert i l (bindSpans st) }+  return ((x, F.sr_sort r), i) -- traceShow ("addBind: " ++ showpp x) i++addClassBind :: SrcSpan -> SpecType -> CG [((F.Symbol, F.Sort), F.BindId)]+addClassBind l = mapM (uncurry (addBind l)) . classBinds++{- see tests/pos/polyfun for why you need everything in fixenv -}+addCGEnv :: (SpecType -> SpecType) -> CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv+addCGEnv tx γ (eMsg, x, REx y tyy tyx)+  = do y' <- fresh+       γ' <- addCGEnv tx γ (eMsg, y', tyy)+       addCGEnv tx γ' (eMsg, x, tyx `F.subst1` (y, F.EVar y'))++addCGEnv tx γ (eMsg, x, RAllE yy tyy tyx)+  = addCGEnv tx γ (eMsg, x, t)+  where+    xs            = localBindsOfType tyy (renv γ)+    t             = L.foldl' F.meet ttrue [ tyx' `F.subst1` (yy, F.EVar x) | x <- xs]+    (tyx', ttrue) = splitXRelatedRefs yy tyx++addCGEnv tx γ (_, x, t') = do+  idx   <- fresh+  allowHOBinders <- allowHO <$> get +  let t  = tx $ normalize idx t'+  let l  = getLocation γ+  let γ' = γ { renv = insertREnv x t (renv γ) }+  pflag <- pruneRefs <$> get+  is    <- if allowHOBinders || isBase t +            then (:) <$> addBind l x (rTypeSortedReft' pflag γ' t) <*> addClassBind l t    +            else return []+  return $ γ' { fenv = insertsFEnv (fenv γ) is }++rTypeSortedReft' pflag γ+  | pflag     = pruneUnsortedReft (feEnv $ fenv γ) . f+  | otherwise = f+  where+    f         = rTypeSortedReft (emb γ)++normalize idx = normalizeVV idx . normalizePds++normalizeVV idx t@(RApp _ _ _ _)+  | not (F.isNontrivialVV (rTypeValueVar t))+  = shiftVV t (F.vv $ Just idx)++normalizeVV _ t+  = t+++--------------------------------------------------------------------------------+(+=) :: (CGEnv, String) -> (F.Symbol, SpecType) -> CG CGEnv+--------------------------------------------------------------------------------+(γ, eMsg) += (x, r)+  | x == F.dummySymbol+  = return γ+  | x `memberREnv` (renv γ)+  = err+  | otherwise+  =  γ ++= (eMsg, x, r)+  where err = panic Nothing $ eMsg ++ " Duplicate binding for "+                                  ++ F.symbolString x+                                  ++ "\n New: " ++ showpp r+                                  ++ "\n Old: " ++ showpp (x `lookupREnv` (renv γ))+++--------------------------------------------------------------------------------+globalize :: CGEnv -> CGEnv+--------------------------------------------------------------------------------+globalize γ = γ {renv = globalREnv (renv γ)}+++--------------------------------------------------------------------------------+(++=) :: CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv+--------------------------------------------------------------------------------+(++=) γ (eMsg, x, t)+  = -- trace ("++= " ++ show x) $+    addCGEnv (addRTyConInv (M.unionWith mappend (invs γ) (ial γ))) γ (eMsg, x, t)++--------------------------------------------------------------------------------+addSEnv :: CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv+--------------------------------------------------------------------------------+addSEnv γ = addCGEnv (addRTyConInv (invs γ)) γ++(+++=) :: (CGEnv, String) -> (F.Symbol, CoreExpr, SpecType) -> CG CGEnv+(γ, _) +++= (x, e, t) = (γ {lcb = M.insert x e (lcb γ) }, "+++=") += (x, t)++γ -= x =  γ {renv = deleteREnv x (renv γ), lcb  = M.delete x (lcb γ)}++(?=) :: (?callStack :: CallStack) => CGEnv -> F.Symbol -> Maybe SpecType+γ ?= x  = lookupREnv x (renv γ)++------------------------------------------------------------------------+setLocation :: CGEnv -> Sp.Span -> CGEnv+------------------------------------------------------------------------+setLocation γ p = γ { cgLoc = Sp.push p $ cgLoc γ }++------------------------------------------------------------------------+setBind :: CGEnv -> Var -> CGEnv+------------------------------------------------------------------------+setBind γ x = γ `setLocation` Sp.Var x `setBind'` x++setBind' :: CGEnv -> Tg.TagKey -> CGEnv+setBind' γ k+  | Tg.memTagEnv k (tgEnv γ) = γ { tgKey = Just k }+  | otherwise                = γ++------------------------------------------------------------------------+setRecs :: CGEnv -> [Var] -> CGEnv+------------------------------------------------------------------------+setRecs γ xs   = γ { recs = L.foldl' (flip S.insert) (recs γ) xs }++------------------------------------------------------------------------+setTRec :: CGEnv -> [(Var, SpecType)] -> CGEnv+------------------------------------------------------------------------+setTRec γ xts  = γ' {trec = Just $ M.fromList xts' `M.union` trec'}+  where+    γ'         = γ `setRecs` (fst <$> xts)+    trec'      = fromMaybe M.empty $ trec γ+    xts'       = first F.symbol <$> xts++------------------------------------------------------------------------+getLocation :: CGEnv -> SrcSpan+------------------------------------------------------------------------+getLocation = Sp.srcSpan . cgLoc
+ src/Language/Haskell/Liquid/Constraint/Fresh.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TupleSections         #-}+{-# LANGUAGE TypeSynonymInstances  #-}+{-# LANGUAGE UndecidableInstances  #-}++module Language.Haskell.Liquid.Constraint.Fresh (Freshable(..)) where++import           Prelude                hiding (error)+++import           Language.Fixpoint.Types+import           Language.Haskell.Liquid.Misc  (single)+import           Language.Haskell.Liquid.Types++class (Applicative m, Monad m) => Freshable m a where+  fresh   :: m a+  true    :: a -> m a+  true    = return . id+  refresh :: a -> m a+  refresh = return . id++instance Freshable m Integer => Freshable m Symbol where+  fresh = tempSymbol "x" <$> fresh++instance Freshable m Integer => Freshable m Expr where+  fresh  = kv <$> fresh+    where+      kv = (`PKVar` mempty) . intKvar++instance Freshable m Integer => Freshable m [Expr] where+  fresh = single <$> fresh++instance Freshable m Integer => Freshable m Reft where+  fresh                = panic Nothing "fresh Reft"+  true    (Reft (v,_)) = return $ Reft (v, mempty)+  refresh (Reft (_,_)) = (Reft .) . (,) <$> freshVV <*> fresh+    where+      freshVV          = vv . Just <$> fresh++instance Freshable m Integer => Freshable m RReft where+  fresh             = panic Nothing "fresh RReft"+  true (MkUReft r _ s)    = MkUReft <$> true r    <*> return mempty <*> true s+  refresh (MkUReft r _ s) = MkUReft <$> refresh r <*> return mempty <*> refresh s++instance Freshable m Integer => Freshable m Strata where+  fresh      = (:[]) . SVar <$> fresh+  true []    = fresh+  true s     = return s+  refresh [] = fresh+  refresh s  = return s++instance (Freshable m Integer, Freshable m r, Reftable r, RefTypable RTyCon RTyVar r) => Freshable m (RRType r) where+  fresh   = panic Nothing "fresh RefType"+  refresh = refreshRefType+  true    = trueRefType++-----------------------------------------------------------------------------------------------+trueRefType :: (Freshable m Integer, Freshable m r, Reftable r, RefTypable RTyCon RTyVar r) => RRType r -> m (RRType r)+-----------------------------------------------------------------------------------------------+trueRefType (RAllT α t)+  = RAllT α <$> true t++trueRefType (RAllP π t)+  = RAllP π <$> true t++trueRefType (RFun _ t t' _)+  = rFun <$> fresh <*> true t <*> true t'++trueRefType (RApp c ts _  _) | isClass c+  = rRCls c <$> mapM true ts++trueRefType (RApp c ts rs r)+  = RApp c <$> mapM true ts <*> mapM trueRef rs <*> true r++trueRefType (RAppTy t t' _)+  = RAppTy <$> true t <*> true t' <*> return mempty++trueRefType (RVar a r)+  = RVar a <$> true r++trueRefType (RAllE y ty tx)+  = do y'  <- fresh+       ty' <- true ty+       tx' <- true tx+       return $ RAllE y' ty' (tx' `subst1` (y, EVar y'))++trueRefType (RRTy e o r t)+  = RRTy e o r <$> trueRefType t++trueRefType t+  = return t++trueRef (RProp _ (RHole _)) = panic Nothing "trueRef: unexpected RProp _ (RHole _))"+trueRef (RProp s t) = RProp s <$> trueRefType t++++-----------------------------------------------------------------------------------------------+refreshRefType :: (Freshable m Integer, Freshable m r, Reftable r, RefTypable RTyCon RTyVar r) => RRType r -> m (RRType r)+-----------------------------------------------------------------------------------------------+refreshRefType (RAllT α t)+  = RAllT α <$> refresh t++refreshRefType (RAllP π t)+  = RAllP π <$> refresh t++refreshRefType (RFun b t t' _)+  | b == dummySymbol = rFun <$> fresh <*> refresh t <*> refresh t'+  | otherwise        = rFun     b     <$> refresh t <*> refresh t'++refreshRefType (RApp rc ts _ _) | isClass rc+  = return $ rRCls rc ts++refreshRefType (RApp rc ts rs r)+  = RApp rc <$> mapM refresh ts <*> mapM refreshRef rs <*> refresh r++refreshRefType (RVar a r)+  = RVar a <$> refresh r++refreshRefType (RAppTy t t' r)+  = RAppTy <$> refresh t <*> refresh t' <*> refresh r++refreshRefType (RAllE y ty tx)+  = do y'  <- fresh+       ty' <- refresh ty+       tx' <- refresh tx+       return $ RAllE y' ty' (tx' `subst1` (y, EVar y'))++refreshRefType (RRTy e o r t)+  = RRTy e o r <$> refreshRefType t++refreshRefType t+  = return t++refreshRef (RProp _ (RHole _)) = panic Nothing "refreshRef: unexpected (RProp _ (RHole _))"+refreshRef (RProp s t) = RProp <$> mapM freshSym s <*> refreshRefType t++freshSym (_, t)        = (, t) <$> fresh
src/Language/Haskell/Liquid/Constraint/Generate.hs view
@@ -12,1927 +12,1395 @@ {-# LANGUAGE DeriveFunctor             #-} {-# LANGUAGE MultiParamTypeClasses     #-} {-# LANGUAGE OverloadedStrings         #-}---- | This module defines the representation of Subtyping and WF Constraints, and--- the code for syntax-directed constraint generation.--module Language.Haskell.Liquid.Constraint.Generate (--   generateConstraints--  ) where--import CoreUtils     (exprType)-import MkCore-import Coercion-import DataCon-import Pair-import CoreSyn-import SrcLoc-import Type-import TyCon-import PrelNames-import TypeRep-import Class            (Class, className)-import Var-import Id-import IdInfo-import Name-import NameSet-import Text.PrettyPrint.HughesPJ hiding (first)--import Control.Monad.State--import Control.Applicative      ((<$>), (<*>))--import Data.Monoid              (mconcat, mempty, mappend)-import Data.Maybe               (fromMaybe, catMaybes, fromJust, isJust)-import qualified Data.HashMap.Strict as M-import qualified Data.HashSet        as S-import qualified Data.List           as L-import qualified Data.Text           as T-import Data.Bifunctor-import Data.List (foldl')-import qualified Data.Foldable    as F-import qualified Data.Traversable as T--import Text.Printf--import qualified Language.Haskell.Liquid.CTags      as Tg-import Language.Fixpoint.Sort (pruneUnsortedReft)-import Language.Fixpoint.Visitor--import Language.Haskell.Liquid.Fresh--import qualified Language.Fixpoint.Types            as F--import Language.Haskell.Liquid.Names-import Language.Haskell.Liquid.Dictionaries-import Language.Haskell.Liquid.Variance-import Language.Haskell.Liquid.Types            hiding (binds, Loc, loc, freeTyVars, Def)-import Language.Haskell.Liquid.Strata-import Language.Haskell.Liquid.Bounds-import Language.Haskell.Liquid.RefType-import Language.Haskell.Liquid.Visitors-import Language.Haskell.Liquid.PredType         hiding (freeTyVars)-import Language.Haskell.Liquid.GhcMisc          ( isInternal, collectArguments, tickSrcSpan-                                                , hasBaseTypeVar, showPpr, isDataConId)-import Language.Haskell.Liquid.Misc-import Language.Fixpoint.Misc-import Language.Haskell.Liquid.Literals-import Language.Haskell.Liquid.RefSplit-import Control.DeepSeq--import Language.Haskell.Liquid.Constraint.Types-import Language.Haskell.Liquid.Constraint.Constraint---- import Debug.Trace (trace)--------------------------------------------------------------------------------------- Constraint Generation: Toplevel ---------------------------------------------------------------------------------------------------generateConstraints      :: GhcInfo -> CGInfo-generateConstraints info = {-# SCC "ConsGen" #-} execState act $ initCGI cfg info-  where-    act                  = consAct info-    cfg                  = config $ spec info---consAct info-  = do γ     <- initEnv info-       sflag <- scheck <$> get-       tflag <- trustghc <$> get-       let trustBinding x = tflag && (x `elem` derVars info || isInternal x)-       foldM_ (consCBTop trustBinding) γ (cbs info)-       hcs <- hsCs  <$> get-       hws <- hsWfs <$> get-       scss <- sCs <$> get-       annot <- annotMap <$> get-       scs <- if sflag then concat <$> mapM splitS (hcs ++ scss)-                       else return []-       let smap = if sflag then solveStrata scs else []-       let hcs' = if sflag then subsS smap hcs else hcs-       fcs <- concat <$> mapM splitC (subsS smap hcs')-       fws <- concat <$> mapM splitW hws-       let annot' = if sflag then subsS smap <$> annot else annot-       modify $ \st -> st { fixCs = fcs } { fixWfs = fws } {annotMap = annot'}---------------------------------------------------------------------------------------initEnv :: GhcInfo -> CG CGEnv--------------------------------------------------------------------------------------initEnv info-  = do let tce   = tcEmbeds sp-       let fVars = impVars info-       let dcs   = filter isConLikeId ((snd <$> freeSyms sp))-       let dcs'   = filter isConLikeId fVars-       defaults <- forM fVars $ \x -> liftM (x,) (trueTy $ varType x)-       dcsty    <- forM dcs   $ \x -> liftM (x,) (trueTy $ varType x)-       dcsty'   <- forM dcs'  $ \x -> liftM (x,) (trueTy $ varType x)-       (hs,f0)  <- refreshHoles $ grty info                  -- asserted refinements     (for defined vars)-       f0''     <- refreshArgs' =<< grtyTop info             -- default TOP reftype      (for exported vars without spec)-       let f0'   = if notruetypes $ config sp then [] else f0''-       f1       <- refreshArgs'   defaults                   -- default TOP reftype      (for all vars)-       f1'      <- refreshArgs' $ makedcs dcsty-       f2       <- refreshArgs' $ assm info                  -- assumed refinements      (for imported vars)-       f3       <- refreshArgs' $ vals asmSigs sp            -- assumed refinedments     (with `assume`)-       f40      <- refreshArgs' $ vals ctors sp    -- constructor refinements  (for measures)-       (invs1, f41) <- mapSndM refreshArgs' $ makeAutoDecrDataCons dcsty  (autosize sp) dcs-       (invs2, f42) <- mapSndM refreshArgs' $ makeAutoDecrDataCons dcsty' (autosize sp) dcs'-       let f4    = mergeDataConTypes f40 (f41 ++ f42)-       sflag    <- scheck <$> get-       let senv  = if sflag then f2 else []-       let tx    = mapFst F.symbol . addRInv ialias . strataUnify senv . predsUnify sp-       let bs    = (tx <$> ) <$> [f0 ++ f0', f1 ++ f1', f2, f3, f4]-       lts      <- lits <$> get-       let tcb   = mapSnd (rTypeSort tce) <$> concat bs-       let γ0    = measEnv sp (head bs) (cbs info) (tcb ++ lts) (bs!!3) hs (invs1 ++ invs2)-       foldM (++=) γ0 [("initEnv", x, y) | (x, y) <- concat $ tail bs]-  where-    sp           = spec info-    ialias       = mkRTyConIAl $ ialiases sp-    vals f       = map (mapSnd val) . f-    mapSndM f (x,y) = (x,) <$> f y-    makedcs      = map strengthenDataConType--makeAutoDecrDataCons dcts specenv dcs-  = (simplify invs, tys)-  where-    (invs, tys) = unzip $ concatMap go tycons-    tycons      = L.nub $ catMaybes $ map idTyCon dcs--    go tycon-      | S.member tycon specenv =  zipWith (makeSizedDataCons dcts) (tyConDataCons tycon) [0..]-    go _-      = []-    idTyCon x = dataConTyCon <$> case idDetails x of {DataConWorkId d -> Just d; DataConWrapId d -> Just d; _ -> Nothing}--    simplify invs = dummyLoc . (`strengthen` invariant) .  fmap (\_ -> mempty) <$> L.nub invs-    invariant = U (F.Reft (F.vv_, F.Refa $ F.PAtom F.Ge (lenOf F.vv_) (F.ECon $ F.I 0)) ) mempty mempty--lenOf x = F.EApp lenLocSymbol [F.EVar x]--makeSizedDataCons dcts x' n = (toRSort $ ty_res trep, (x, fromRTypeRep trep{ty_res = tres}))-    where-      x      = dataConWorkId x'-      t      = fromMaybe (errorstar "makeSizedDataCons: this should never happen") $ L.lookup x dcts-      trep   = toRTypeRep t-      tres   = ty_res trep `strengthen` U (F.Reft (F.vv_, F.Refa-                              $ F.PAtom F.Eq (lenOf F.vv_) computelen)) mempty mempty--      recarguments = filter (\(t,_) -> (toRSort t == toRSort tres)) (zip (ty_args trep) (ty_binds trep))-      computelen   = foldr (F.EBin F.Plus) (F.ECon $ F.I n) (lenOf .  snd <$> recarguments)---mergeDataConTypes xts yts = merge (L.sortBy f xts) (L.sortBy f yts)-  where-    f (x,_) (y,_) = compare x y-    merge [] ys = ys-    merge xs [] = xs-    merge (xt@(x, tx):xs) (yt@(y, ty):ys)-      | x == y    = (x, tx `F.meet` ty):merge xs ys-      | x <  y    = xt:merge xs (yt:ys)-      | otherwise = yt:merge (xt:xs) ys--refreshHoles vts = first catMaybes . unzip . map extract <$> mapM refreshHoles' vts-refreshHoles' (x,t)-  | noHoles t = return (Nothing,x,t)-  | otherwise = (Just $ F.symbol x,x,) <$> mapReftM tx t-  where-    tx r | hasHole r = refresh r-         | otherwise = return r-extract (a,b,c) = (a,(b,c))--refreshArgs' = mapM (mapSndM refreshArgs)--strataUnify :: [(Var, SpecType)] -> (Var, SpecType) -> (Var, SpecType)-strataUnify senv (x, t) = (x, maybe t (mappend t) pt)-  where-    pt                  = fmap (\(U _ _ l) -> U mempty mempty l) <$> L.lookup x senv----- | TODO: All this *should* happen inside @Bare@ but appears---   to happen after certain are signatures are @fresh@-ed,---   which is why they are here.---- NV : still some sigs do not get TyConInfo--predsUnify :: GhcSpec -> (Var, RRType RReft) -> (Var, RRType RReft)-predsUnify sp = second (addTyConInfo tce tyi) -- needed to eliminate some @RPropH@--  where-    tce            = tcEmbeds sp-    tyi            = tyconEnv sp-- ---------------------------------------------------------------------------------------- ---------------------------------------------------------------------------------------- -----------------------------------------------------------------------------------------measEnv sp xts cbs lts asms hs autosizes-  = CGE { loc   = noSrcSpan-        , renv  = fromListREnv $ second val <$> meas sp-        , syenv = F.fromListSEnv $ freeSyms sp-        , fenv  = initFEnv $ lts ++ (second (rTypeSort tce . val) <$> meas sp)-        , denv  = dicts sp-        , recs  = S.empty-        , invs  = mkRTyConInv    $ (invariants sp ++ autosizes)-        , ial   = mkRTyConIAl    $ ialiases   sp-        , grtys = fromListREnv xts-        , assms = fromListREnv asms-        , emb   = tce-        , tgEnv = Tg.makeTagEnv cbs-        , tgKey = Nothing-        , trec  = Nothing-        , lcb   = M.empty-        , holes = fromListHEnv hs-        , lcs   = mempty-        }-    where-      tce = tcEmbeds sp--assm = assmGrty impVars-grty = assmGrty defVars--assmGrty f info = [ (x, val t) | (x, t) <- sigs, x `S.member` xs ]-  where-    xs          = S.fromList $ f info-    sigs        = tySigs     $ spec info--grtyTop info     = forM topVs $ \v -> (v,) <$> trueTy (varType v)-  where-    topVs        = filter isTop $ defVars info-    isTop v      = isExportedId v && not (v `S.member` sigVs)-    isExportedId = flip elemNameSet (exports $ spec info) . getName-    sigVs        = S.fromList [v | (v,_) <- tySigs (spec info) ++ asmSigs (spec info)]------------------------------------------------------------------------------ | Helpers: Reading/Extending Environment Bindings ------------------------------------------------------------------------------------------------getTag :: CGEnv -> F.Tag-getTag γ = maybe Tg.defaultTag (`Tg.getTag` tgEnv γ) (tgKey γ)--setLoc :: CGEnv -> SrcSpan -> CGEnv-γ `setLoc` src-  | isGoodSrcSpan src = γ { loc = src }-  | otherwise         = γ--withRecs :: CGEnv -> [Var] -> CGEnv-withRecs γ xs  = γ { recs = foldl' (flip S.insert) (recs γ) xs }--withTRec γ xts = γ' {trec = Just $ M.fromList xts' `M.union` trec'}-  where γ'    = γ `withRecs` (fst <$> xts)-        trec' = fromMaybe M.empty $ trec γ-        xts'  = mapFst F.symbol <$> xts--setBind :: CGEnv -> Tg.TagKey -> CGEnv-setBind γ k-  | Tg.memTagEnv k (tgEnv γ) = γ { tgKey = Just k }-  | otherwise                = γ---isGeneric :: RTyVar -> SpecType -> Bool-isGeneric α t =  all (\(c, α') -> (α'/=α) || isOrd c || isEq c ) (classConstrs t)-  where classConstrs t = [(c, α') | (c, ts) <- tyClasses t-                                  , t'      <- ts-                                  , α'      <- freeTyVars t']-        isOrd          = (ordClassName ==) . className-        isEq           = (eqClassName ==) . className----------------------------------------------------------------------------------- Constraint Splitting ----------------------------------------------------------------------------------splitW ::  WfC -> CG [FixWfC]--splitW (WfC γ t@(RFun x t1 t2 _))-  =  do ws   <- bsplitW γ t-        ws'  <- splitW (WfC γ t1)-        γ'   <- (γ, "splitW") += (x, t1)-        ws'' <- splitW (WfC γ' t2)-        return $ ws ++ ws' ++ ws''--splitW (WfC γ t@(RAppTy t1 t2 _))-  =  do ws   <- bsplitW γ t-        ws'  <- splitW (WfC γ t1)-        ws'' <- splitW (WfC γ t2)-        return $ ws ++ ws' ++ ws''--splitW (WfC γ (RAllT _ r))-  = splitW (WfC γ r)--splitW (WfC γ (RAllP _ r))-  = splitW (WfC γ r)--splitW (WfC γ t@(RVar _ _))-  = bsplitW γ t--splitW (WfC γ t@(RApp _ ts rs _))-  =  do ws    <- bsplitW γ t-        γ'    <- γ `extendEnvWithVV` t-        ws'   <- concat <$> mapM (splitW . WfC γ') ts-        ws''  <- concat <$> mapM (rsplitW γ)       rs-        return $ ws ++ ws' ++ ws''--splitW (WfC γ (RAllE x tx t))-  = do  ws  <- splitW (WfC γ tx)-        γ'  <- (γ, "splitW") += (x, tx)-        ws' <- splitW (WfC γ' t)-        return $ ws ++ ws'--splitW (WfC γ (REx x tx t))-  = do  ws  <- splitW (WfC γ tx)-        γ'  <- (γ, "splitW") += (x, tx)-        ws' <- splitW (WfC γ' t)-        return $ ws ++ ws'--splitW (WfC _ t)-  = errorstar $ "splitW cannot handle: " ++ showpp t--rsplitW _ (RPropP _ _)-  = errorstar "Constrains: rsplitW for RPropP"-rsplitW γ (RProp ss t0)-  = do γ' <- foldM (++=) γ [("rsplitC", x, ofRSort s) | (x, s) <- ss]-       splitW $ WfC γ' t0-rsplitW _ (RHProp _ _)-  = errorstar "TODO: EFFECTS"--bsplitW :: CGEnv -> SpecType -> CG [FixWfC]-bsplitW γ t = bsplitW' γ t . pruneRefs <$> get--bsplitW' γ t pflag-  | F.isNonTrivial r' = [F.wfC (fe_binds $ fenv γ) r' Nothing ci]-  | otherwise         = []-  where-    r'                = rTypeSortedReft' pflag γ t-    ci                = Ci (loc γ) Nothing---------------------------------------------------------------splitS  :: SubC -> CG [([Stratum], [Stratum])]-bsplitS :: SpecType -> SpecType -> CG [([Stratum], [Stratum])]---------------------------------------------------------------splitS (SubC γ (REx x _ t1) (REx x2 _ t2)) | x == x2-  = splitS (SubC γ t1 t2)--splitS (SubC γ t1 (REx _ _ t2))-  = splitS (SubC γ t1 t2)--splitS (SubC γ (REx _ _ t1) t2)-  = splitS (SubC γ t1 t2)--splitS (SubC γ (RAllE x _ t1) (RAllE x2 _ t2)) | x == x2-  = splitS (SubC γ t1 t2)--splitS (SubC γ (RAllE _ _ t1) t2)-  = splitS (SubC γ t1 t2)--splitS (SubC γ t1 (RAllE _ _ t2))-  = splitS (SubC γ t1 t2)--splitS (SubC γ (RRTy _ _ _ t1) t2)-  = splitS (SubC γ t1 t2)--splitS (SubC γ t1 (RRTy _ _ _ t2))-  = splitS (SubC γ t1 t2)--splitS (SubC γ t1@(RFun x1 r1 r1' _) t2@(RFun x2 r2 r2' _))-  =  do cs       <- bsplitS t1 t2-        cs'      <- splitS  (SubC γ r2 r1)-        γ'       <- (γ, "splitC") += (x2, r2)-        let r1x2' = r1' `F.subst1` (x1, F.EVar x2)-        cs''     <- splitS  (SubC γ' r1x2' r2')-        return    $ cs ++ cs' ++ cs''--splitS (SubC γ t1@(RAppTy r1 r1' _) t2@(RAppTy r2 r2' _))-  =  do cs    <- bsplitS t1 t2-        cs'   <- splitS  (SubC γ r1 r2)-        cs''  <- splitS  (SubC γ r1' r2')-        cs''' <- splitS  (SubC γ r2' r1')-        return $ cs ++ cs' ++ cs'' ++ cs'''--splitS (SubC γ t1 (RAllP p t))-  = splitS $ SubC γ t1 t'-  where-    t' = fmap (replacePredsWithRefs su) t-    su = (uPVar p, pVartoRConc p)--splitS (SubC _ t1@(RAllP _ _) t2)-  = errorstar $ "Predicate in lhs of constrain:" ++ showpp t1 ++ "\n<:\n" ++ showpp t2--splitS (SubC γ (RAllT α1 t1) (RAllT α2 t2))-  |  α1 ==  α2-  = splitS $ SubC γ t1 t2-  | otherwise-  = splitS $ SubC γ t1 t2'-  where t2' = subsTyVar_meet' (α2, RVar α1 mempty) t2--splitS (SubC _ (RApp c1 _ _ _) (RApp c2 _ _ _)) | isClass c1 && c1 == c2-  = return []---splitS (SubC γ t1@(RApp {}) t2@(RApp {}))-  = do (t1',t2') <- unifyVV t1 t2-       cs    <- bsplitS t1' t2'-       γ'    <- γ `extendEnvWithVV` t1'-       let RApp c t1s r1s _ = t1'-       let RApp _ t2s r2s _ = t2'-       let isapplied = tyConArity (rtc_tc c) == length t1s-       let tyInfo = rtc_info c-       csvar  <-  splitsSWithVariance           γ' t1s t2s $ varianceTyArgs tyInfo-       csvar' <- rsplitsSWithVariance isapplied γ' r1s r2s $ variancePsArgs tyInfo-       return $ cs ++ csvar ++ csvar'--splitS (SubC _ t1@(RVar a1 _) t2@(RVar a2 _))-  | a1 == a2-  = bsplitS t1 t2--splitS (SubC _ t1 t2)-  = errorstar $ "(Another Broken Test1!!!) splitS unexpected: " ++ showpp t1 ++ "\n\n" ++ showpp t2--splitS (SubR _ _ _)-  = return []--splitsSWithVariance γ t1s t2s variants-  = concatMapM (\(t1, t2, v) -> splitfWithVariance (\s1 s2 -> splitS (SubC γ s1 s2)) t1 t2 v) (zip3 t1s t2s variants)--rsplitsSWithVariance False _ _ _ _ -  = return [] --rsplitsSWithVariance _ γ t1s t2s variants-  = concatMapM (\(t1, t2, v) -> splitfWithVariance (rsplitS γ) t1 t2 v) (zip3 t1s t2s variants)--bsplitS t1 t2-  = return $ [(s1, s2)]-  where [s1, s2]   = getStrata <$> [t1, t2]--rsplitS γ (RProp s1 r1) (RProp s2 r2)-  = splitS (SubC γ (F.subst su r1) r2)-  where su = F.mkSubst [(x, F.EVar y) | ((x,_), (y,_)) <- zip s1 s2]--rsplitS _ _ _-  = errorstar "rspliS Rpoly - RPropP"----splitfWithVariance f t1 t2 Invariant     = liftM2 (++) (f t1 t2) (f t2 t1) -- return []-splitfWithVariance f t1 t2 Bivariant     = liftM2 (++) (f t1 t2) (f t2 t1)-splitfWithVariance f t1 t2 Covariant     = f t1 t2-splitfWithVariance f t1 t2 Contravariant = f t2 t1----------------------------------------------------------------splitC :: SubC -> CG [FixSubC]---------------------------------------------------------------splitC (SubC γ (REx x tx t1) (REx x2 _ t2)) | x == x2-  = do γ' <- (γ, "addExBind 0") += (x, forallExprRefType γ tx)-       splitC (SubC γ' t1 t2)--splitC (SubC γ t1 (REx x tx t2))-  = do y <- fresh -       γ' <- (γ, "addExBind 1") += (y, forallExprRefType γ tx)-       splitC (SubC γ' t1 (F.subst1 t2 (x, F.EVar y)))---- existential at the left hand side is treated like forall-splitC (SubC γ (REx x tx t1) t2)-  = do -- let tx' = traceShow ("splitC: " ++ showpp z) tx-       y <- fresh -       γ' <- (γ, "addExBind 2") += (y, forallExprRefType γ tx)-       splitC (SubC γ' (F.subst1 t1 (x, F.EVar y)) t2)--splitC (SubC γ (RAllE x tx t1) (RAllE x2 _ t2)) | x == x2-  = do γ' <- (γ, "addAllBind 0") += (x, forallExprRefType γ tx)-       splitC (SubC γ' t1 t2)--splitC (SubC γ (RAllE x tx t1) t2)-  = do y  <- fresh -       γ' <- (γ, "addAABind 1") += (y, forallExprRefType γ tx)-       splitC (SubC γ' (t1 `F.subst1` (x, F.EVar y)) t2)--splitC (SubC γ t1 (RAllE x tx t2))-  = do y  <- fresh -       γ' <- (γ, "addAllBind 2") += (y, forallExprRefType γ tx)-       splitC (SubC γ' t1 (F.subst1 t2 (x, F.EVar y)))--splitC (SubC γ (RRTy env _ OCons t1) t2)-  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ xts-       c1 <- splitC (SubC γ' t1' t2')-       c2 <- splitC (SubC γ  t1  t2 )-       return $ c1 ++ c2-  where-    (xts, t1', t2') = envToSub env--splitC (SubC γ (RRTy e r o t1) t2)-  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ e-       c1 <- splitC (SubR γ' o  r )-       c2 <- splitC (SubC γ t1 t2)-       return $ c1 ++ c2--splitC (SubC γ t1@(RFun x1 r1 r1' _) t2@(RFun x2 r2 r2' _))-  =  do cs       <- bsplitC γ t1 t2-        cs'      <- splitC  (SubC γ r2 r1)-        γ'       <- (γ, "splitC") += (x2, r2)-        let r1x2' = r1' `F.subst1` (x1, F.EVar x2)-        cs''     <- splitC  (SubC γ' r1x2' r2')-        return    $ cs ++ cs' ++ cs''--splitC (SubC γ t1@(RAppTy r1 r1' _) t2@(RAppTy r2 r2' _))-  =  do cs    <- bsplitC γ t1 t2-        cs'   <- splitC  (SubC γ r1 r2)-        cs''  <- splitC  (SubC γ r1' r2')-        cs''' <- splitC  (SubC γ r2' r1')-        return $ cs ++ cs' ++ cs'' ++ cs'''--splitC (SubC γ t1 (RAllP p t))-  = splitC $ SubC γ t1 t'-  where-    t' = fmap (replacePredsWithRefs su) t-    su = (uPVar p, pVartoRConc p)--splitC (SubC _ t1@(RAllP _ _) t2)-  = errorstar $ "Predicate in lhs of constraint:" ++ showpp t1 ++ "\n<:\n" ++ showpp t2--splitC (SubC γ (RAllT α1 t1) (RAllT α2 t2))-  |  α1 ==  α2-  = splitC $ SubC γ t1 t2-  | otherwise-  = splitC $ SubC γ t1 t2'-  where t2' = subsTyVar_meet' (α2, RVar α1 mempty) t2---splitC (SubC _ (RApp c1 _ _ _) (RApp c2 _ _ _)) | isClass c1 && c1 == c2-  = return []--splitC (SubC γ t1@(RApp _ _ _ _) t2@(RApp _ _ _ _))-  = do (t1',t2') <- unifyVV t1 t2-       cs    <- bsplitC γ t1' t2'-       γ'    <- γ `extendEnvWithVV` t1'-       let RApp c t1s r1s _ = t1'-       let RApp _ t2s r2s _ = t2'-       let isapplied = tyConArity (rtc_tc c) == length t1s-       let tyInfo = rtc_info c-       csvar  <-  splitsCWithVariance           γ' t1s t2s $ varianceTyArgs tyInfo-       csvar' <- rsplitsCWithVariance isapplied γ' r1s r2s $ variancePsArgs tyInfo-       return $ cs ++ csvar ++ csvar'--splitC (SubC γ t1@(RVar a1 _) t2@(RVar a2 _))-  | a1 == a2-  = bsplitC γ t1 t2--splitC (SubC _ t1 t2)-  = errorstar $ "(Another Broken Test!!!) splitc unexpected:\n" ++ showpp t1 ++ "\n\n" ++ showpp t2--splitC (SubR γ o r)-  = do fg     <- pruneRefs <$> get-       let r1' = if fg then pruneUnsortedReft γ'' r1 else r1-       return $ F.subC γ' F.PTrue r1' r2 Nothing tag ci-  where-    γ'' = fe_env $ fenv γ-    γ'  = fe_binds $ fenv γ-    r1  = F.RR F.boolSort $ F.toReft r-    r2  = F.RR F.boolSort $ F.Reft (vv, F.Refa $ F.PBexp $ F.EVar vv)-    vv  = "vvRec"-    -- s   = boolSort -- F.FApp F.boolFTyCon []-    ci  = Ci src err-    err = Just $ ErrAssType src o (text $ show o ++ "type error") r-    tag = getTag γ-    src = loc γ---splitsCWithVariance γ t1s t2s variants-  = concatMapM (\(t1, t2, v) -> splitfWithVariance (\s1 s2 -> (splitC (SubC γ s1 s2))) t1 t2 v) (zip3 t1s t2s variants)--rsplitsCWithVariance False _ _ _ _ -  = return [] --rsplitsCWithVariance _ γ t1s t2s variants-  = concatMapM (\(t1, t2, v) -> splitfWithVariance (rsplitC γ) t1 t2 v) (zip3 t1s t2s variants)----bsplitC γ t1 t2-  = do checkStratum γ t1 t2-       pflag <- pruneRefs <$> get-       γ' <- γ ++= ("bsplitC", v, t1)-       let r = (mempty :: UReft F.Reft){ur_reft = F.Reft (F.dummySymbol,  F.Refa $ constraintToLogic γ' (lcs γ'))}-       let t1' = addRTyConInv (invs γ')  t1 `strengthen` r-       return $ bsplitC' γ' t1' t2 pflag-  where-    F.Reft(v, _) = ur_reft (fromMaybe mempty (stripRTypeBase t1))--checkStratum γ t1 t2-  | s1 <:= s2 = return ()-  | otherwise = addWarning wrn-  where-    [s1, s2]  = getStrata <$> [t1, t2]-    wrn       =  ErrOther (loc γ) (text $ "Stratum Error : " ++ show s1 ++ " > " ++ show s2)--bsplitC' γ t1 t2 pflag-  | F.isFunctionSortedReft r1' && F.isNonTrivial r2'-  = F.subC γ' grd (r1' {F.sr_reft = mempty}) r2' Nothing tag ci-  | F.isNonTrivial r2'-  = F.subC γ' grd r1'  r2' Nothing tag ci-  | otherwise-  = []-  where-    γ'     = fe_binds $ fenv γ-    r1'    = rTypeSortedReft' pflag γ t1-    r2'    = rTypeSortedReft' pflag γ t2-    ci     = Ci src err-    tag    = getTag γ-    err    = Just $ ErrSubType src (text "subtype") g t1 t2-    src    = loc γ-    REnv g = renv γ-    grd    = F.PTrue----unifyVV t1@(RApp _ _ _ _) t2@(RApp _ _ _ _)-  = do vv     <- (F.vv . Just) <$> fresh-       return  $ (shiftVV t1 vv,  (shiftVV t2 vv) ) -- {rt_pargs = r2s'})--unifyVV _ _-  = errorstar $ "Constraint.Generate.unifyVV called on invalid inputs"--rsplitC _ (RPropP _ _) (RPropP _ _)-  = errorstar "RefTypes.rsplitC on RPropP"--rsplitC γ (RProp s1 r1) (RProp s2 r2)-  = do γ'  <-  foldM (++=) γ [("rsplitC1", x, ofRSort s) | (x, s) <- s2]-       splitC (SubC γ' (F.subst su r1) r2)-  where su = F.mkSubst [(x, F.EVar y) | ((x,_), (y,_)) <- zip s1 s2]--rsplitC _ _ _-  = errorstar "rsplit Rpoly - RPropP"---type CG = State CGInfo--initCGI cfg info = CGInfo {-    hsCs       = []-  , sCs        = []-  , hsWfs      = []-  , fixCs      = []-  , isBind     = []-  , fixWfs     = []-  , freshIndex = 0-  , binds      = F.emptyBindEnv-  , annotMap   = AI M.empty-  , tyConInfo  = tyi-  , tyConEmbed = tce-  , kuts       = F.ksEmpty-  , lits       = coreBindLits tce info-  , termExprs  = M.fromList $ texprs spc-  , specDecr   = decr spc-  , specLVars  = lvars spc-  , specLazy   = lazy spc-  , tcheck     = not $ notermination cfg-  , scheck     = strata cfg-  , trustghc   = trustinternals cfg-  , pruneRefs  = not $ noPrune cfg-  , logErrors  = []-  , kvProf     = emptyKVProf-  , recCount   = 0-  , bindSpans  = M.empty-  , autoSize   = autosize spc-  }-  where-    tce        = tcEmbeds spc-    spc        = spec info-    tyi        = tyconEnv spc -- EFFECTS HEREHEREHERE makeTyConInfo (tconsP spc)--coreBindLits tce info-  = sortNub      $ [ (val x, so) | (_, Just (F.ELit x so)) <- lconsts ]-                ++ [(F.symbol x, F.strSort) | (_, Just (F.ESym x)) <- lconsts ]-                ++ [ (dconToSym dc, dconToSort dc) | dc <- dcons ]-  where-    lconsts      = literalConst tce <$> literals (cbs info)-    dcons        = filter isDCon $ impVars info ++ (snd <$> freeSyms (spec info))-    dconToSort   = typeSort tce . expandTypeSynonyms . varType-    dconToSym    = dataConSymbol . idDataCon-    isDCon x     = isDataConId x && not (hasBaseTypeVar x)--extendEnvWithVV γ t-  | F.isNontrivialVV vv-  = (γ, "extVV") += (vv, t)-  | otherwise-  = return γ-  where vv = rTypeValueVar t--{- see tests/pos/polyfun for why you need everything in fixenv -}-addCGEnv :: (SpecType -> SpecType) -> CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv-addCGEnv tx γ (msg, x, REx y tyy tyx)-  = do y' <- fresh-       γ' <- addCGEnv tx γ (msg, y', tyy)-       addCGEnv tx γ' (msg, x, tyx `F.subst1` (y, F.EVar y'))--addCGEnv tx γ (msg, x, RAllE yy tyy tyx)-  = addCGEnv tx γ (msg, x, t)-  where-    xs    = grapBindsWithType tyy γ-    t     = foldl F.meet ttrue [ tyx' `F.subst1` (yy, F.EVar x) | x <- xs]--    (tyx', ttrue) = splitXRelatedRefs yy tyx--addCGEnv tx γ (_, x, t')-  = do idx   <- fresh-       let t  = tx $ normalize {-x-} idx t'-       let l  = loc γ-       let γ' = γ { renv = insertREnv x t (renv γ) }-       pflag <- pruneRefs <$> get-       is    <- if isBase t-                  then (:) <$> addBind l x (rTypeSortedReft' pflag γ' t) <*> addClassBind l t-                  else return []-       return $ γ' { fenv = insertsFEnv (fenv γ) is }--(++=) :: CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv-(++=) γ = addCGEnv (addRTyConInv (M.unionWith mappend (invs γ) (ial γ))) γ--addSEnv :: CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv-addSEnv γ = addCGEnv (addRTyConInv (invs γ)) γ--rTypeSortedReft' pflag γ-  | pflag-  = pruneUnsortedReft (fe_env $ fenv γ) . f-  | otherwise-  = f-  where-    f = rTypeSortedReft (emb γ)--(+++=) :: (CGEnv, String) -> (F.Symbol, CoreExpr, SpecType) -> CG CGEnv--(γ, _) +++= (x, e, t) = (γ{lcb = M.insert x e (lcb γ)}, "+++=") += (x, t)--(+=) :: (CGEnv, String) -> (F.Symbol, SpecType) -> CG CGEnv-(γ, msg) += (x, r)-  | x == F.dummySymbol-  = return γ-  | x `memberREnv` (renv γ)-  = err-  | otherwise-  =  γ ++= (msg, x, r)-  where err = errorstar $ msg ++ " Duplicate binding for "-                              ++ F.symbolString x-                              ++ "\n New: " ++ showpp r-                              ++ "\n Old: " ++ showpp (x `lookupREnv` (renv γ))--γ -= x =  γ {renv = deleteREnv x (renv γ), lcb  = M.delete x (lcb γ)}--(??=) :: CGEnv -> F.Symbol -> CG SpecType-γ ??= x-  = case M.lookup x (lcb γ) of-    Just e  -> consE (γ-=x) e-    Nothing -> refreshTy $ γ ?= x--(?=) ::  CGEnv -> F.Symbol -> SpecType-γ ?= x = fromMaybe err $ lookupREnv x (renv γ)-         where err = errorstar $ "EnvLookup: unknown "-                               ++ showpp x-                               ++ " in renv\n"-                               ++ showpp (renv γ)--normalize idx-  = normalizeVV idx-  . normalizePds--normalizeVV idx t@(RApp _ _ _ _)-  | not (F.isNontrivialVV (rTypeValueVar t))-  = shiftVV t (F.vv $ Just idx)--normalizeVV _ t-  = t---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)-       put          $ st { binds = bs' } { bindSpans = M.insert i l (bindSpans st) }-       return ((x, F.sr_sort r), i) -- traceShow ("addBind: " ++ showpp x) i--addClassBind :: SrcSpan -> SpecType -> CG [((F.Symbol, F.Sort), F.BindId)]-addClassBind l = mapM (uncurry (addBind l)) . classBinds---- RJ: What is this `isBind` business?-pushConsBind act-  = do modify $ \s -> s { isBind = False : isBind s }-       z <- act-       modify $ \s -> s { isBind = tail (isBind s) }-       return z--addC :: SubC -> String -> CG ()-addC !c@(SubC γ t1 t2) _msg-  = do -- trace ("addC at " ++ show (loc γ) ++ _msg++ showpp t1 ++ "\n <: \n" ++ showpp t2 ) $-       modify $ \s -> s { hsCs  = c : (hsCs s) }-       bflag <- headDefault True . isBind <$> get-       sflag <- scheck                 <$> get-       if bflag && sflag-         then modify $ \s -> s {sCs = (SubC γ t2 t1) : (sCs s) }-         else return ()-  where-    headDefault a []    = a-    headDefault _ (x:_) = x---addC !c _msg-  = modify $ \s -> s { hsCs  = c : (hsCs s) }--addPost γ (RRTy e r OInv t)-  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("addPost", x,t)) γ e-       addC (SubR γ' OInv r) "precondition" >> return t--addPost γ (RRTy e r OTerm t)-  = do γ' <- foldM (\γ (x, t) -> γ ++= ("addPost", x,t)) γ e-       addC (SubR γ' OTerm r) "precondition" >> return t--addPost _ (RRTy _ _ OCons t)-  = return t--addPost _ t-  = return t--addW   :: WfC -> CG ()-addW !w = modify $ \s -> s { hsWfs = w : (hsWfs s) }--addWarning   :: TError SpecType -> CG ()-addWarning w = modify $ \s -> s { logErrors = w : (logErrors s) }---- | Used for annotation binders (i.e. at binder sites)--addIdA            :: Var -> Annot SpecType -> CG ()-addIdA !x !t      = modify $ \s -> s { annotMap = upd $ annotMap s }-  where-    loc           = getSrcSpan x-    upd m@(AI _)  = if boundRecVar loc m then m else addA loc (Just x) t m--boundRecVar l (AI m) = not $ null [t | (_, AnnRDf t) <- M.lookupDefault [] l m]----- | Used for annotating reads (i.e. at Var x sites)--addLocA :: Maybe Var -> SrcSpan -> Annot SpecType -> CG ()-addLocA !xo !l !t-  = modify $ \s -> s { annotMap = addA l xo t $ annotMap s }---- | Used to update annotations for a location, due to (ghost) predicate applications--updateLocA (_:_)  (Just l) t = addLocA Nothing l (AnnUse t)-updateLocA _      _        _ = return ()--addA !l xo@(Just _) !t (AI m)-  | isGoodSrcSpan l-  = AI $ inserts l (T.pack . showPpr <$> xo, t) m-addA !l xo@Nothing  !t (AI m)-  | l `M.member` m                  -- only spans known to be variables-  = AI $ inserts l (T.pack . showPpr <$> xo, t) m-addA _ _ _ !a-  = a---------------------------------------------------------------------------------------------- Generation: Freshness -------------------------------------------------------------------------------------------- | Right now, we generate NO new pvars. Rather than clutter code---   with `uRType` calls, put it in one place where the above---   invariant is /obviously/ enforced.---   Constraint generation should ONLY use @freshTy_type@ and @freshTy_expr@--freshTy_type        :: KVKind -> CoreExpr -> Type -> CG SpecType-freshTy_type k _ τ  = freshTy_reftype k $ ofType τ--freshTy_expr        :: KVKind -> CoreExpr -> Type -> CG SpecType-freshTy_expr k e _  = freshTy_reftype k $ exprRefType e--freshTy_reftype     :: KVKind -> SpecType -> CG SpecType--- freshTy_reftype k t = do t <- refresh =<< fixTy t---                          addKVars k t---                          return t--freshTy_reftype k t = (fixTy t >>= refresh) =>> addKVars k---- | 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 when (True)    $ modify $ \s -> s { kvProf = updKVProf k kvars (kvProf s) }-                     when (isKut k) $ modify $ \s -> s { kuts   = F.ksUnion kvars   (kuts s)   }-  where-     kvars      = sortNub $ specTypeKVars t--isKut          :: KVKind -> Bool-isKut RecBindE = True-isKut _        = False--specTypeKVars :: SpecType -> [F.KVar]-specTypeKVars = foldReft ((++) . (kvars . ur_reft)) []--trueTy  :: Type -> CG SpecType-trueTy = ofType' >=> true--ofType' :: Type -> CG SpecType-ofType' = fixTy . ofType--fixTy :: SpecType -> CG SpecType-fixTy t = do tyi   <- tyConInfo  <$> get-             tce   <- tyConEmbed <$> get-             return $ addTyConInfo tce tyi t--refreshArgsTop :: (Var, SpecType) -> CG SpecType-refreshArgsTop (x, t)-  = do (t', su) <- refreshArgsSub t-       modify $ \s -> s {termExprs = M.adjust (F.subst su <$>) x $ termExprs s}-       return t'--refreshArgs :: SpecType -> CG SpecType-refreshArgs t-  = fst <$> refreshArgsSub t----- NV TODO: this does not refreshes args if they are wrapped in an RRTy-refreshArgsSub :: SpecType -> CG (SpecType, F.Subst)-refreshArgsSub t-  = do ts     <- mapM refreshArgs ts_u-       xs'    <- mapM (\_ -> fresh) xs-       let sus = F.mkSubst <$> (L.inits $ zip xs (F.EVar <$> xs'))-       let su  = last sus-       let ts' = zipWith F.subst sus ts-       let t'  = fromRTypeRep $ trep {ty_binds = xs', ty_args = ts', ty_res = F.subst su tbd}-       return (t', su)-    where-       trep    = toRTypeRep t-       xs      = ty_binds trep-       ts_u    = ty_args  trep-       tbd     = ty_res   trep--instance Freshable CG Integer where-  fresh = do s <- get-             let n = freshIndex s-             put $ s { freshIndex = n + 1 }-             return n---------------------------------------------------------------------------------------------------------- TERMINATION TYPE ------------------------------------------------------------------------------------------------------------------------makeDecrIndex :: (Var, Template SpecType)-> CG [Int]-makeDecrIndex (x, Assumed t)-  = do dindex <- makeDecrIndexTy x t-       case dindex of-         Left _  -> return []-         Right i -> return i-makeDecrIndex (x, Asserted t)-  = do dindex <- makeDecrIndexTy x t-       case dindex of-         Left msg -> addWarning msg >> return []-         Right i  -> return i-makeDecrIndex _ = return []--makeDecrIndexTy x t-  = do spDecr <- specDecr <$> get-       autosz <- autoSize <$> get-       hint   <- checkHint' autosz (L.lookup x $ spDecr)-       case dindex autosz of-         Nothing -> return $ Left msg -- addWarning msg >> return []-         Just i  -> return $ Right $ fromMaybe [i] hint-    where-       ts         = ty_args trep-       checkHint' = \autosz -> checkHint x ts (isDecreasing autosz cenv)-       dindex     = \autosz -> L.findIndex    (isDecreasing autosz cenv) ts-       msg        = ErrTermin [x] (getSrcSpan x) (text "No decreasing parameter")-       cenv       = makeNumEnv ts-       trep       = toRTypeRep $ unOCons t---recType _ ((_, []), (_, [], t))-  = t--recType autoenv ((vs, indexc), (_, index, t))-  = makeRecType autoenv t v dxt index-  where v    = (vs !!)  <$> indexc-        dxt  = (xts !!) <$> index-        xts  = zip (ty_binds trep) (ty_args trep)-        trep = toRTypeRep $ unOCons t--checkIndex (x, vs, t, index)-  = do mapM_ (safeLogIndex msg' vs) index-       mapM  (safeLogIndex msg  ts) index-    where-       loc   = getSrcSpan x-       ts    = ty_args $ toRTypeRep $ unOCons $ unTemplate t-       msg'  = ErrTermin [x] loc (text $ "No decreasing " ++ show index ++ "-th argument on " ++ (showPpr x) ++ " with " ++ (showPpr vs))-       msg   = ErrTermin [x] loc (text "No decreasing parameter")--makeRecType autoenv t vs dxs is-  = mergecondition t $ fromRTypeRep $ trep {ty_binds = xs', ty_args = ts'}-  where-    (xs', ts') = unzip $ replaceN (last is) (makeDecrType autoenv vdxs) xts-    vdxs       = zip vs dxs-    xts        = zip (ty_binds trep) (ty_args trep)-    trep       = toRTypeRep $ unOCons t--unOCons (RAllT v t)        = RAllT v $ unOCons t-unOCons (RAllP p t)        = RAllP p $ unOCons t-unOCons (RFun x tx t r)    = RFun x (unOCons tx) (unOCons t) r-unOCons (RRTy _ _ OCons t) = unOCons t-unOCons t                  = t---mergecondition (RAllT _ t1) (RAllT v t2)-  = RAllT v $ mergecondition t1 t2-mergecondition (RAllP _ t1) (RAllP p t2)-  = RAllP p $ mergecondition t1 t2-mergecondition (RRTy xts r OCons t1) t2-  = RRTy xts r OCons (mergecondition t1 t2)-mergecondition (RFun _ t11 t12 _) (RFun x2 t21 t22 r2)-  = RFun x2 (mergecondition t11 t21) (mergecondition t12 t22) r2-mergecondition _ t-  = t--safeLogIndex err ls n-  | n >= length ls = addWarning err >> return Nothing-  | otherwise      = return $ Just $ ls !! n--checkHint _ _ _ Nothing-  = return Nothing--checkHint x _ _ (Just ns) | L.sort ns /= ns-  = addWarning (ErrTermin [x] loc (text "The hints should be increasing")) >> return Nothing-  where loc = getSrcSpan x--checkHint x ts f (Just ns)-  = (mapM (checkValidHint x ts f) ns) >>= (return . Just . catMaybes)--checkValidHint x ts f n-  | n < 0 || n >= length ts = addWarning err >> return Nothing-  | f (ts L.!! n)           = return $ Just n-  | otherwise               = addWarning err >> return Nothing-  where err = ErrTermin [x] loc (text $ "Invalid Hint " ++ show (n+1) ++ " for " ++ (showPpr x) ++  "\nin\n" ++ show (ts))-        loc = getSrcSpan x------------------------------------------------------------------------------------------ Generation: Corebind ----------------------------------------------------------------------------------------------consCBTop :: (Var -> Bool) -> CGEnv -> CoreBind -> CG CGEnv-consCBLet :: CGEnv -> CoreBind -> CG CGEnv----------------------------------------------------------------------consCBLet γ cb-  = do oldtcheck <- tcheck <$> get-       strict    <- specLazy <$> get-       let tflag  = oldtcheck-       let isStr  = tcond cb strict-       modify $ \s -> s{tcheck = tflag && isStr}-       γ' <- consCB (tflag && isStr) isStr γ cb-       modify $ \s -> s{tcheck = oldtcheck}-       return γ'--consCBTop trustBinding γ cb | all trustBinding xs-  = do ts <- mapM trueTy (varType <$> xs)-       foldM (\γ xt -> (γ, "derived") += xt) γ (zip xs' ts)-  where xs             = bindersOf cb-        xs'            = F.symbol <$> xs--consCBTop _ γ cb-  = do oldtcheck <- tcheck <$> get-       strict    <- specLazy <$> get-       let tflag  = oldtcheck-       let isStr  = tcond cb strict-       modify $ \s -> s{tcheck = tflag && isStr}-       γ' <- consCB (tflag && isStr) isStr γ cb-       modify $ \s -> s{tcheck = oldtcheck}-       return γ'--tcond cb strict-  = not $ any (\x -> S.member x strict || isInternal x) (binds cb)-  where binds (NonRec x _) = [x]-        binds (Rec xes)    = fst $ unzip xes----------------------------------------------------------------------consCB :: Bool -> Bool -> CGEnv -> CoreBind -> CG CGEnv----------------------------------------------------------------------consCBSizedTys γ xes-  = do xets''    <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))-       sflag     <- scheck <$> get-       autoenv   <- autoSize <$> get-       let cmakeFinType = if sflag then makeFinType else id-       let cmakeFinTy   = if sflag then makeFinTy   else snd-       let xets = mapThd3 (fmap cmakeFinType) <$> xets''-       ts'      <- mapM (T.mapM refreshArgs) $ (thd3 <$> xets)-       let vs    = zipWith collectArgs ts' es-       is       <- mapM makeDecrIndex (zip xs ts') >>= checkSameLens-       let ts = cmakeFinTy  <$> zip is ts'-       let xeets = (\vis -> [(vis, x) | x <- zip3 xs is $ map unTemplate ts]) <$> (zip vs is)-       (L.transpose <$> mapM checkIndex (zip4 xs vs ts is)) >>= checkEqTypes-       let rts   = (recType autoenv <$>) <$> xeets-       let xts   = zip xs ts-       γ'       <- foldM extender γ xts-       let γs    = [γ' `withTRec` (zip xs rts') | rts' <- rts]-       let xets' = zip3 xs es ts-       mapM_ (uncurry $ consBind True) (zip γs xets')-       return γ'-  where-       (xs, es) = unzip xes-       collectArgs    = collectArguments . length . ty_binds . toRTypeRep . unOCons . unTemplate-       checkEqTypes :: [[Maybe SpecType]] -> CG [[SpecType]]-       checkEqTypes x = mapM (checkAll err1 toRSort) (catMaybes <$> x)-       checkSameLens  = checkAll err2 length-       err1           = ErrTermin xs loc $ text "The decreasing parameters should be of same type"-       err2           = ErrTermin xs loc $ text "All Recursive functions should have the same number of decreasing parameters"-       loc            = getSrcSpan (head xs)--       checkAll _   _ []            = return []-       checkAll err f (x:xs)-         | all (==(f x)) (f <$> xs) = return (x:xs)-         | otherwise                = addWarning err >> return []--consCBWithExprs γ xes-  = do xets'     <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))-       texprs <- termExprs <$> get-       let xtes = catMaybes $ (`lookup` texprs) <$> xs-       sflag     <- scheck <$> get-       let cmakeFinType = if sflag then makeFinType else id-       let xets  = mapThd3 (fmap cmakeFinType) <$> xets'-       let ts    = safeFromAsserted err . thd3 <$> xets-       ts'      <- mapM refreshArgs ts-       let xts   = zip xs (Asserted <$> ts')-       γ'       <- foldM extender γ xts-       let γs    = makeTermEnvs γ' xtes xes ts ts'-       let xets' = zip3 xs es (Asserted <$> ts')-       mapM_ (uncurry $ consBind True) (zip γs xets')-       return γ'-  where (xs, es) = unzip xes-        lookup k m | Just x <- M.lookup k m = Just (k, x)-                   | otherwise              = Nothing-        err      = "Constant: consCBWithExprs"--makeFinTy (ns, t) = fmap go t-  where-    go t = fromRTypeRep $ trep {ty_args = args'}-      where-        trep = toRTypeRep t-        args' = mapNs ns makeFinType $ ty_args trep---makeTermEnvs γ xtes xes ts ts' = withTRec γ . zip xs <$> rts-  where-    vs   = zipWith collectArgs ts es-    ys   = (fst4 . bkArrowDeep) <$> ts-    ys'  = (fst4 . bkArrowDeep) <$> ts'-    sus' = zipWith mkSub ys ys'-    sus  = zipWith mkSub ys ((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 addTermCond ts' <$> rss-    (xs, es)     = unzip xes-    mkSub ys ys' = F.mkSubst [(x, F.EVar y) | (x, y) <- zip ys ys']-    collectArgs  = collectArguments . length . ty_binds . toRTypeRep-    err x        = "Constant: makeTermEnvs: no terminating expression for " ++ showPpr x--consCB tflag _ γ (Rec xes) | tflag-  = do texprs <- termExprs <$> get-       modify $ \i -> i { recCount = recCount i + length xes }-       let xxes = catMaybes $ (`lookup` texprs) <$> xs-       if null xxes-         then consCBSizedTys γ xes-         else check xxes <$> consCBWithExprs γ xes-  where xs = fst $ unzip xes-        check ys r | length ys == length xs = r-                   | otherwise              = errorstar err-        err = printf "%s: Termination expressions should be provided for ALL mutual recursive functions" loc-        loc = showPpr $ getSrcSpan (head xs)-        lookup k m | Just x <- M.lookup k m = Just (k, x)-                   | otherwise              = Nothing--consCB _ str γ (Rec xes) | not str-  = do xets'   <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))-       sflag     <- scheck <$> get-       let cmakeDivType = if sflag then makeDivType else id-       let xets = mapThd3 (fmap cmakeDivType) <$> xets'-       modify $ \i -> i { recCount = recCount i + length xes }-       let xts = [(x, to) | (x, _, to) <- xets]-       γ'     <- foldM extender (γ `withRecs` (fst <$> xts)) xts-       mapM_ (consBind True γ') xets-       return γ'--consCB _ _ γ (Rec xes)-  = do xets   <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))-       modify $ \i -> i { recCount = recCount i + length xes }-       let xts = [(x, to) | (x, _, to) <- xets]-       γ'     <- foldM extender (γ `withRecs` (fst <$> xts)) xts-       mapM_ (consBind True γ') xets-       return γ'---- | NV: Dictionaries are not checked, because--- | class methods' preconditions are not satisfied-consCB _ _ γ (NonRec x _) | isDictionary x-  = do t  <- trueTy (varType x)-       extender γ (x, Assumed t)-  where-    isDictionary = isJust . dlookup (denv γ)---consCB _ _ γ (NonRec x (App (Var w) (Type τ))) | isDictionary w-  = do t      <- trueTy τ-       addW    $ WfC γ t-       let xts = dmap (f t) $ safeFromJust (show w ++ "Not a dictionary"  ) $ dlookup (denv γ) w-       let  γ' = γ{denv = dinsert (denv γ) x xts }-       t      <- trueTy (varType x)-       extender γ' (x, Assumed t)-  where f t' (RAllT α te) = subsTyVar_meet' (α, t') te-        f _ _ = error "consCB on Dictionary: this should not happen"-        isDictionary = isJust . dlookup (denv γ)----consCB _ _ γ (NonRec x e)-  = do to  <- varTemplate γ (x, Nothing)-       to' <- consBind False γ (x, e, to) >>= (addPostTemplate γ)-       extender γ (x, to')--consBind isRec γ (x, e, Asserted spect)-  = do let γ'         = (γ `setLoc` getSrcSpan x) `setBind` x-           (_,πs,_,_) = bkUniv spect-       γπ    <- foldM addPToEnv γ' πs-       cconsE γπ e spect-       when (F.symbol x `elemHEnv` holes γ) $-         -- have to add the wf constraint here for HOLEs so we have the proper env-         addW $ WfC γπ $ fmap killSubst spect-       addIdA x (defAnn isRec spect)-       return $ Asserted spect -- Nothing--consBind isRec γ (x, e, Assumed spect)-  = do let γ' = (γ `setLoc` getSrcSpan x) `setBind` x-       γπ    <- foldM addPToEnv γ' πs-       cconsE γπ e =<< true spect-       addIdA x (defAnn isRec spect)-       return $ Asserted spect -- Nothing-  where πs   = ty_preds $ toRTypeRep spect--consBind isRec γ (x, e, Unknown)-  = do t     <- consE (γ `setBind` x) e-       addIdA x (defAnn isRec t)-       return $ Asserted t--noHoles = and . foldReft (\r bs -> not (hasHole r) : bs) []--killSubst :: RReft -> RReft-killSubst = fmap killSubstReft--killSubstReft :: F.Reft -> F.Reft-killSubstReft = trans kv () ()-  where-    kv    = defaultVisitor { txPred = ks }-    ks _ (F.PKVar k _) = F.PKVar k mempty-    ks _ p             = p--    -- tx (F.Reft (s, rs)) = F.Reft (s, map f rs)-    -- f (F.RKvar k _)     = F.RKvar k mempty-    -- f (F.RConc p)       = F.RConc p--defAnn True  = AnnRDf-defAnn False = AnnDef--addPToEnv γ π-  = do γπ <- γ ++= ("addSpec1", pname π, pvarRType π)-       foldM (++=) γπ [("addSpec2", x, ofRSort t) | (t, x, _) <- pargs π]--extender γ (x, Asserted t) = γ ++= ("extender", F.symbol x, t)-extender γ (x, Assumed t)  = γ ++= ("extender", F.symbol x, t)-extender γ _               = return γ--addBinders γ0 x' cbs   = foldM (++=) (γ0 -= x') [("addBinders", x, t) | (x, t) <- cbs]--data Template a = Asserted a | Assumed a | Unknown deriving (Functor, F.Foldable, T.Traversable)--deriving instance (Show a) => (Show (Template a))--unTemplate (Asserted t) = t-unTemplate (Assumed t) = t-unTemplate _ = errorstar "Constraint.Generate.unTemplate called on `Unknown`"--addPostTemplate γ (Asserted t) = Asserted <$> addPost γ t-addPostTemplate γ (Assumed  t) = Assumed  <$> addPost γ t-addPostTemplate _ Unknown      = return Unknown--safeFromAsserted _ (Asserted t) = t-safeFromAsserted msg _ = errorstar $ "safeFromAsserted:" ++ msg---- | @varTemplate@ is only called with a `Just e` argument when the `e`--- corresponds to the body of a @Rec@ binder.-varTemplate :: CGEnv -> (Var, Maybe CoreExpr) -> CG (Template SpecType)-varTemplate γ (x, eo)-  = case (eo, lookupREnv (F.symbol x) (grtys γ), lookupREnv (F.symbol x) (assms γ)) of-      (_, Just t, _) -> Asserted <$> refreshArgsTop (x, t)-      (_, _, Just t) -> Assumed  <$> refreshArgsTop (x, t)-      (Just e, _, _) -> do t  <- freshTy_expr RecBindE e (exprType e)-                           addW (WfC γ t)-                           Asserted <$> refreshArgsTop (x, t)-      (_,      _, _) -> return Unknown------------------------------------------------------------------------------------------ Generation: Expression -------------------------------------------------------------------------------------------------------------------- Type Checking ------------------------------cconsE :: CGEnv -> Expr Var -> SpecType -> CG ()---------------------------------------------------------------------cconsE γ e@(Let b@(NonRec x _) ee) t-  = do sp <- specLVars <$> get-       if (x `S.member` sp) || isDefLazyVar x-        then cconsLazyLet γ e t-        else do γ'  <- consCBLet γ b-                cconsE γ' ee t-  where-       isDefLazyVar = L.isPrefixOf "fail" . showPpr--cconsE γ e (RAllP p t)-  = cconsE γ' e t''-  where-    t'         = replacePredsWithRefs su <$> t-    su         = (uPVar p, pVartoRConc p)-    (css, t'') = splitConstraints t'-    γ'         = foldl (flip addConstraints) γ css--cconsE γ (Let b e) t-  = do γ'  <- consCBLet γ b-       cconsE γ' e t--cconsE γ (Case e x _ cases) t-  = do γ'  <- consCBLet γ (NonRec x e)-       forM_ cases $ cconsCase γ' x t nonDefAlts-    where-       nonDefAlts = [a | (a, _, _) <- cases, a /= DEFAULT]--cconsE γ (Lam α e) (RAllT α' t) | isTyVar α-  = cconsE γ e $ subsTyVar_meet' (α', rVar α) t--cconsE γ (Lam x e) (RFun y ty t _)-  | not (isTyVar x)-  = do γ' <- (γ, "cconsE") += (F.symbol x, ty)-       cconsE γ' e (t `F.subst1` (y, F.EVar $ F.symbol x))-       addIdA x (AnnDef ty)--cconsE γ (Tick tt e) t-  = cconsE (γ `setLoc` tickSrcSpan tt) e t---- GHC 7.10 encodes type classes with a single method as newtypes and--- `cast`s between the method and class type instead of applying the--- class constructor. Just rewrite the core to what we're used to--- seeing..-cconsE γ (Cast e co) t-  | Pair _t1 t2 <- coercionKind co-  , isClassPred t2-  , (tc,ts) <- splitTyConApp t2-  , [dc]   <- tyConDataCons tc-  = cconsE γ (mkCoreConApps dc $ map Type ts ++ [e]) t--cconsE γ e@(Cast e' _) t-  = do t' <- castTy γ (exprType e) e'-       addC (SubC γ t' t) ("cconsE Cast" ++ showPpr e)--cconsE γ e t-  = do te  <- consE γ e-       te' <- instantiatePreds γ e te >>= addPost γ-       addC (SubC γ te' t) ("cconsE" ++ showPpr e)---splitConstraints (RRTy cs _ OCons t)-  = let (css, t') = splitConstraints t in (cs:css, t')-splitConstraints (RFun x tx@(RApp c _ _ _) t r) | isClass c-  = let (css, t') = splitConstraints t in (css, RFun x tx t' r)-splitConstraints t-  = ([], t)----------------------------------------------------------------------- | @instantiatePreds@ peels away the universally quantified @PVars@---   of a @RType@, generates fresh @Ref@ for them and substitutes them---   in the body.--instantiatePreds γ e (RAllP π t)-  = do r     <- freshPredRef γ e π-       instantiatePreds γ e $ replacePreds "consE" t [(π, r)]--instantiatePreds _ _ t0-  = return t0------------------------------------------------------------------------ | @instantiateStrata@ generates fresh @Strata@ vars and substitutes---   them inside the body of the type.--instantiateStrata ls t = substStrata t ls <$> mapM (\_ -> fresh) ls--substStrata t ls ls'   = F.substa f t-  where-    f x                = fromMaybe x $ L.lookup x su-    su                 = zip ls ls'-----------------------------------------------------------------------cconsLazyLet γ (Let (NonRec x ex) e) t-  = do tx <- trueTy (varType x)-       γ' <- (γ, "Let NonRec") +++= (x', ex, tx)-       cconsE γ' e t-    where-       x' = F.symbol x--cconsLazyLet _ _ _-  = errorstar "Constraint.Generate.cconsLazyLet called on invalid inputs"------------------------------------------------------------------------ | Type Synthesis --------------------------------------------------------------------------------------------------------------------consE :: CGEnv -> Expr Var -> CG SpecType----------------------------------------------------------------------consE γ (Var x)-  = do t <- varRefType γ x-       addLocA (Just x) (loc γ) (varAnn γ x t)-       return t--consE _ (Lit c)-  = refreshVV $ uRType $ literalFRefType c--consE γ e'@(App e (Type τ))-  = do RAllT α te <- checkAll ("Non-all TyApp with expr", e) <$> consE γ e-       t          <- if isGeneric α te then freshTy_type TypeInstE e τ else trueTy τ-       addW        $ WfC γ t-       t'         <- refreshVV t-       instantiatePreds γ e' $ subsTyVar_meet' (α, t') te--consE γ e'@(App e a) | isDictionary a-  = if isJust tt-      then return $ fromJust tt-      else do ([], πs, ls, te) <- bkUniv <$> consE γ e-              te0              <- instantiatePreds γ e' $ foldr RAllP te πs-              te'              <- instantiateStrata ls te0-              (γ', te''')      <- dropExists γ te'-              te''             <- dropConstraints γ te'''-              updateLocA πs (exprLoc e) te''-              let RFun x tx t _ = checkFun ("Non-fun App with caller ", e') te''-              pushConsBind      $ cconsE γ' a tx-              addPost γ'        $ maybe (checkUnbound γ' e' x t a) (F.subst1 t . (x,)) (argExpr γ a)-  where-    grepfunname (App x (Type _)) = grepfunname x-    grepfunname (Var x)          = x-    grepfunname e                = errorstar $ "grepfunname on \t" ++ showPpr e-    mdict w                      = case w of-                                     Var x    -> case dlookup (denv γ) x of {Just _ -> Just x; Nothing -> Nothing}-                                     Tick _ e -> mdict e-                                     _        -> Nothing-    isDictionary _               = isJust (mdict a)-    d = fromJust (mdict a)-    dinfo = dlookup (denv γ) d-    tt = dhasinfo dinfo $ grepfunname e--consE γ e'@(App e a)-  = do ([], πs, ls, te) <- bkUniv <$> consE γ e-       te0              <- instantiatePreds γ e' $ foldr RAllP te πs-       te'              <- instantiateStrata ls te0-       (γ', te''')      <- dropExists γ te'-       te''             <- dropConstraints γ te'''-       updateLocA πs (exprLoc e) te''-       let RFun x tx t _ = checkFun ("Non-fun App with caller ", e') te''-       pushConsBind      $ cconsE γ' a tx-       addPost γ'        $ maybe (checkUnbound γ' e' x t a) (F.subst1 t . (x,)) (argExpr γ a)--consE γ (Lam α e) | isTyVar α-  = liftM (RAllT (rTyVar α)) (consE γ e)--consE γ  e@(Lam x e1)-  = do tx      <- freshTy_type LamE (Var x) τx-       γ'      <- ((γ, "consE") += (F.symbol x, tx))-       t1      <- consE γ' e1-       addIdA x $ AnnDef tx-       addW     $ WfC γ tx-       return   $ rFun (F.symbol x) tx t1-    where-      FunTy τx _ = exprType e---- EXISTS-BASED CONSTRAINTS HEREHEREHEREHERE--- Currently suppressed because they break all sorts of invariants,--- e.g. for `unfoldR`...--- consE γ e@(Let b@(NonRec x _) e')---   = do γ'    <- consCBLet γ b---        consElimE γ' [F.symbol x] e'------ consE γ (Case e x _ [(ac, ys, ce)])---   = do γ'  <- consCBLet γ (NonRec x e)---        γ'' <- caseEnv γ' x [] ac ys---        consElimE γ'' (F.symbol <$> (x:ys)) ce--consE γ e@(Let _ _)-  = cconsFreshE LetE γ e--consE γ e@(Case _ _ _ _)-  = cconsFreshE CaseE γ e--consE γ (Tick tt e)-  = do t <- consE (γ `setLoc` l) e-       addLocA Nothing l (AnnUse t)-       return t-    where l = tickSrcSpan tt---- GHC 7.10 encodes type classes with a single method as newtypes and--- `cast`s between the method and class type instead of applying the--- class constructor. Just rewrite the core to what we're used to--- seeing..-consE γ (Cast e co)-  | Pair _t1 t2 <- coercionKind co-  , isClassPred t2-  , (tc,ts) <- splitTyConApp t2-  , [dc]   <- tyConDataCons tc-  = consE γ (mkCoreConApps dc $ map Type ts ++ [e])--consE γ e@(Cast e' _)-  = castTy γ (exprType e) e'--consE _ e@(Coercion _)-   = trueTy $ exprType e--consE _ e@(Type t)-  = errorstar $ "consE cannot handle type " ++ showPpr (e, t)--castTy _ τ (Var x)-  = do t <- trueTy τ-       return $  t `strengthen` (uTop $ F.uexprReft $ F.expr x)--castTy g t (Tick _ e)-  = castTy g t e--castTy _ _ e-  = errorstar $ "castTy cannot handle expr " ++ showPpr e---- castTy γ τ e---   = do t <- trueTy (exprType e)---        cconsE γ e t---        trueTy τ--singletonReft = uTop . F.symbolReft . F.symbol---- | @consElimE@ is used to *synthesize* types by **existential elimination**---   instead of *checking* via a fresh template. That is, assuming---      γ |- e1 ~> t1---   we have---      γ |- let x = e1 in e2 ~> Ex x t1 t2---   where---      γ, x:t1 |- e2 ~> t2---   instead of the earlier case where we generate a fresh template `t` and check---      γ, x:t1 |- e <~ t---- consElimE γ xs e---   = do t     <- consE γ e---        xts   <- forM xs $ \x -> (x,) <$> (γ ??= x)---        return $ rEx xts t---- | @consFreshE@ is used to *synthesize* types with a **fresh template** when---   the above existential elimination is not easy (e.g. at joins, recursive binders)--cconsFreshE kvkind γ e-  = do t   <- freshTy_type kvkind e $ exprType e-       addW $ WfC γ t-       cconsE γ e t-       return t--checkUnbound γ e x t a-  | x `notElem` (F.syms t)-  = t-  | otherwise-  = errorstar $ "checkUnbound: " ++ show x ++ " is elem of syms of " ++ show t-                 ++ "\nIn\t"  ++ showPpr e ++ " at " ++ showPpr (loc γ) ++ "\nArg = \n" ++ show a--dropExists γ (REx x tx t) = liftM (, t) $ (γ, "dropExists") += (x, tx)-dropExists γ t            = return (γ, t)--dropConstraints :: CGEnv -> SpecType -> CG SpecType-dropConstraints γ (RFun x tx@(RApp c _ _ _) t r) | isClass c-  = (flip (RFun x tx)) r <$> dropConstraints γ t-dropConstraints γ (RRTy cts _ OCons t)-  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ xts-       addC (SubC  γ' t1 t2)  "dropConstraints"-       dropConstraints γ t-  where-    (xts, t1, t2) = envToSub cts--dropConstraints _ t = return t----------------------------------------------------------------------------------------cconsCase :: CGEnv -> Var -> SpecType -> [AltCon] -> (AltCon, [Var], CoreExpr) -> CG ()---------------------------------------------------------------------------------------cconsCase γ x t acs (ac, ys, ce)-  = do cγ <- caseEnv γ x acs ac ys-       cconsE cγ ce t--refreshTy t = refreshVV t >>= refreshArgs--refreshVV (RAllT a t) = liftM (RAllT a) (refreshVV t)-refreshVV (RAllP p t) = liftM (RAllP p) (refreshVV t)--refreshVV (REx x t1 t2)-  = do [t1', t2'] <- mapM refreshVV [t1, t2]-       liftM (shiftVV (REx x t1' t2')) fresh--refreshVV (RFun x t1 t2 r)-  = do [t1', t2'] <- mapM refreshVV [t1, t2]-       liftM (shiftVV (RFun x t1' t2' r)) fresh--refreshVV (RAppTy t1 t2 r)-  = do [t1', t2'] <- mapM refreshVV [t1, t2]-       liftM (shiftVV (RAppTy t1' t2' r)) fresh--refreshVV (RApp c ts rs r)-  = do ts' <- mapM refreshVV ts-       rs' <- mapM refreshVVRef rs-       liftM (shiftVV (RApp c ts' rs' r)) fresh--refreshVV t-  = return t---refreshVVRef (RProp ss t)-  = do xs    <- mapM (\_ -> fresh) (fst <$> ss)-       let su = F.mkSubst $ zip (fst <$> ss) (F.EVar <$> xs)-       liftM (RProp (zip xs (snd <$> ss)) . F.subst su) (refreshVV t)--refreshVVRef (RPropP ss r)-  = return $ RPropP ss r--refreshVVRef (RHProp _ _)-  = errorstar "TODO: EFFECTS refreshVVRef"-----------------------------------------------------------------------------------------caseEnv   :: CGEnv -> Var -> [AltCon] -> AltCon -> [Var] -> CG CGEnv---------------------------------------------------------------------------------------caseEnv γ x _   (DataAlt c) ys-  = do let (x' : ys')    = F.symbol <$> (x:ys)-       xt0              <- checkTyCon ("checkTycon cconsCase", x) <$> γ ??= x'-       tdc              <- γ ??= (dataConSymbol c) >>= refreshVV-       let (rtd, yts, _) = unfoldR tdc (shiftVV xt0 x') ys-       let r1            = dataConReft   c   ys'-       let r2            = dataConMsReft rtd ys'-       let xt            = (xt0 `F.meet` rtd) `strengthen` (uTop (r1 `F.meet` r2))-       let cbs           = safeZip "cconsCase" (x':ys') (xt0:yts)-       cγ'              <- addBinders γ x' cbs-       cγ               <- addBinders cγ' x' [(x', xt)]-       return cγ--caseEnv γ x acs a _-  = do let x'  = F.symbol x-       xt'    <- (`strengthen` uTop (altReft γ acs a)) <$> (γ ??= x')-       cγ     <- addBinders γ x' [(x', xt')]-       return cγ--altReft _ _ (LitAlt l)   = literalFReft l-altReft γ acs DEFAULT    = mconcat [notLiteralReft l | LitAlt l <- acs]-  where notLiteralReft   = maybe mempty F.notExprReft . snd . literalConst (emb γ)-altReft _ _ _            = error "Constraint : altReft"--unfoldR td (RApp _ ts rs _) ys = (t3, tvys ++ yts, ignoreOblig rt)-  where-        tbody              = instantiatePvs (instantiateTys td ts) $ reverse rs-        (ys0, yts', _, rt) = safeBkArrow $ instantiateTys tbody tvs'-        yts''              = zipWith F.subst sus (yts'++[rt])-        (t3,yts)           = (last yts'', init yts'')-        sus                = F.mkSubst <$> (L.inits [(x, F.EVar y) | (x, y) <- zip ys0 ys'])-        (αs, ys')          = mapSnd (F.symbol <$>) $ L.partition isTyVar ys-        tvs'               = rVar <$> αs-        tvys               = ofType . varType <$> αs--unfoldR _  _                _  = error "Constraint.hs : unfoldR"--instantiateTys = foldl' go-  where go (RAllT α tbody) t = subsTyVar_meet' (α, t) tbody-        go _ _               = errorstar "Constraint.instanctiateTy"--instantiatePvs = foldl' go-  where go (RAllP p tbody) r = replacePreds "instantiatePv" tbody [(p, r)]-        go _ _               = errorstar "Constraint.instanctiatePv"--checkTyCon _ t@(RApp _ _ _ _) = t-checkTyCon x t                = checkErr x t --errorstar $ showPpr x ++ "type: " ++ showPpr t--checkFun _ t@(RFun _ _ _ _)   = t-checkFun x t                  = checkErr x t--checkAll _ t@(RAllT _ _)      = t-checkAll x t                  = checkErr x t--checkErr (msg, e) t          = errorstar $ msg ++ showPpr e ++ ", type: " ++ showpp t--varAnn γ x t-  | x `S.member` recs γ-  = AnnLoc (getSrcSpan' x)-  | otherwise-  = AnnUse t--getSrcSpan' x-  | loc == noSrcSpan-  = loc-  | otherwise-  = loc-  where loc = getSrcSpan x---------------------------------------------------------------------------- | Helpers: Creating Fresh Refinement ---------------------------------------------------------------------------------------------------------freshPredRef :: CGEnv -> CoreExpr -> PVar RSort -> CG SpecProp-freshPredRef γ e (PV _ (PVProp τ) _ as)-  = do t    <- freshTy_type PredInstE e (toType τ)-       args <- mapM (\_ -> fresh) as-       let targs = [(x, s) | (x, (s, y, z)) <- zip args as, (F.EVar y) == z ]-       γ' <- foldM (++=) γ [("freshPredRef", x, ofRSort τ) | (x, τ) <- targs]-       addW $ WfC γ' t-       return $ RProp targs t--freshPredRef _ _ (PV _ PVHProp _ _)-  = errorstar "TODO:EFFECTS:freshPredRef"------------------------------------------------------------------------------------ Helpers: Creating Refinement Types For Various Things --------------------------------------------------------------------------------argExpr :: CGEnv -> CoreExpr -> Maybe F.Expr-argExpr _ (Var vy)    = Just $ F.eVar vy-argExpr γ (Lit c)     = snd  $ literalConst (emb γ) c-argExpr γ (Tick _ e)  = argExpr γ e-argExpr _ e           = errorstar $ "argExpr: " ++ showPpr e--varRefType :: CGEnv -> Var -> CG SpecType-varRefType γ x = varRefType' γ x <$> (γ ??= F.symbol x)--varRefType' :: CGEnv -> Var -> SpecType -> SpecType-varRefType' γ x t'-  | Just tys <- trec γ, Just tr  <- M.lookup x' tys-  = tr `strengthenS` xr-  | otherwise-  = t' `strengthenS` xr-  where-    xr = singletonReft x-    x' = F.symbol x----- | RJ: `nomeet` replaces `strengthenS` for `strengthen` in the definition---   of `varRefType`. Why does `tests/neg/strata.hs` fail EVEN if I just replace---   the `otherwise` case? The fq file holds no answers, both are sat.-strengthenS :: (F.Reftable r) => RType c tv r -> r -> RType c tv r-strengthenS (RApp c ts rs r) r'  = RApp c ts rs $ topMeet r r'-strengthenS (RVar a r) r'        = RVar a       $ topMeet r r'-strengthenS (RFun b t1 t2 r) r'  = RFun b t1 t2 $ topMeet r r'-strengthenS (RAppTy t1 t2 r) r'  = RAppTy t1 t2 $ topMeet r r'-strengthenS t _                  = t-topMeet r r' = F.top r `F.meet` r'---- TODO: should only expose/use subt. Not subsTyVar_meet-subsTyVar_meet' (α, t) = subsTyVar_meet (α, toRSort t, t)----------------------------------------------------------------------------------------- Forcing Strictness --------------------------------------------------------------------------------------------------------------instance NFData CGEnv where-  rnf (CGE x1 x2 x3 _ x5 x6 x7 x8 x9 _ _ x10 _ _ _ _ _)-    = x1 `seq` rnf x2 `seq` seq x3 `seq` rnf x5 `seq`-      rnf x6  `seq` x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10--instance NFData FEnv where-  rnf (FE x1 _) = rnf x1--instance NFData SubC where-  rnf (SubC x1 x2 x3)-    = rnf x1 `seq` rnf x2 `seq` rnf x3-  rnf (SubR x1 _ x2)-    = rnf x1 `seq` rnf x2--instance NFData Class where-  rnf _ = ()--instance NFData RTyCon where-  rnf _ = ()--instance NFData Type where-  rnf _ = ()--instance NFData WfC where-  rnf (WfC x1 x2)-    = rnf x1 `seq` rnf x2--instance NFData CGInfo where-  rnf x = ({-# SCC "CGIrnf1" #-}  rnf (hsCs x))       `seq`-          ({-# SCC "CGIrnf2" #-}  rnf (hsWfs x))      `seq`-          ({-# SCC "CGIrnf3" #-}  rnf (fixCs x))      `seq`-          ({-# SCC "CGIrnf4" #-}  rnf (fixWfs x))     `seq`-          ({-# SCC "CGIrnf6" #-}  rnf (freshIndex x)) `seq`-          ({-# SCC "CGIrnf7" #-}  rnf (binds x))      `seq`-          ({-# SCC "CGIrnf8" #-}  rnf (annotMap x))   `seq`-          ({-# SCC "CGIrnf10" #-} rnf (kuts x))       `seq`-          ({-# SCC "CGIrnf10" #-} rnf (lits x))       `seq`-          ({-# SCC "CGIrnf10" #-} rnf (kvProf x))------------------------------------------------------------------------------------------------------- Reftypes from F.Fixpoint Expressions --------------------------------------------------------------------------------------------------------forallExprRefType     :: CGEnv -> SpecType -> SpecType-forallExprRefType γ t = t `strengthen` (uTop r')-  where-    r'                = fromMaybe mempty $ forallExprReft γ r-    r                 = F.sr_reft $ rTypeSortedReft (emb γ) t--forallExprReft :: CGEnv -> F.Reft -> Maybe F.Reft-forallExprReft γ r = F.isSingletonReft r >>= forallExprReft_ γ----   = do e  <- F.isSingletonReft r---        r' <- forallExprReft_ γ e---        return r'--forallExprReft_ :: CGEnv -> F.Expr -> Maybe F.Reft-forallExprReft_ γ (F.EApp f es)-  = case forallExprReftLookup γ (val f) of-      Just (xs,_,_,t) -> let su = F.mkSubst $ safeZip "fExprRefType" xs es in-                       Just $ F.subst su $ F.sr_reft $ rTypeSortedReft (emb γ) t-      Nothing       -> Nothing -- F.exprReft e--forallExprReft_ γ (F.EVar x)-  = case forallExprReftLookup γ x of-      Just (_,_,_,t)  -> Just $ F.sr_reft $ rTypeSortedReft (emb γ) t-      Nothing       -> Nothing -- F.exprReft e--forallExprReft_ _ _ = Nothing -- F.exprReft e--forallExprReftLookup γ x = snap <$> F.lookupSEnv x (syenv γ)-  where-    snap                 = mapFourth4 ignoreOblig . bkArrow . fourth4 . bkUniv . (γ ?=) . F.symbol--{--splitExistsCases z xs tx-  = fmap $ fmap (exrefAddEq z xs tx)--exrefAddEq z xs t (F.Reft (s, F.Refa rs))-  = F.Reft(s, F.Refa (F.POr [ pand x | x <- xs]))-  where-    tref      = fromMaybe mempty $ stripRTypeBase t-    pand x    = substzx x rs `mappend` exrefToPred x tref-    substzx x = F.subst (F.mkSubst [(z, F.EVar x)])--exrefToPred x u             = F.subst (F.mkSubst [(v, F.EVar x)]) p-  where-    F.Reft (v, F.Refa p)    = ur_reft u--}------------------------------------------------------------------------------------------------------ Cleaner Signatures For Rec-bindings --------------------------------------------------------------------------------------------------------exprLoc                         :: CoreExpr -> Maybe SrcSpan--exprLoc (Tick tt _)             = Just $ tickSrcSpan tt-exprLoc (App e a) | isType a    = exprLoc e-exprLoc _                       = Nothing--isType (Type _)                 = True-isType a                        = eqType (exprType a) predType---exprRefType :: CoreExpr -> SpecType-exprRefType = exprRefType_ M.empty--exprRefType_ :: M.HashMap Var SpecType -> CoreExpr -> SpecType-exprRefType_ γ (Let b e)-  = exprRefType_ (bindRefType_ γ b) e--exprRefType_ γ (Lam α e) | isTyVar α-  = RAllT (rTyVar α) (exprRefType_ γ e)--exprRefType_ γ (Lam x e)-  = rFun (F.symbol x) (ofType $ varType x) (exprRefType_ γ e)--exprRefType_ γ (Tick _ e)-  = exprRefType_ γ e--exprRefType_ γ (Var x)-  = M.lookupDefault (ofType $ varType x) x γ--exprRefType_ _ e-  = ofType $ exprType e--bindRefType_ γ (Rec xes)-  = extendγ γ [(x, exprRefType_ γ e) | (x,e) <- xes]--bindRefType_ γ (NonRec x e)-  = extendγ γ [(x, exprRefType_ γ e)]--extendγ γ xts-  = foldr (\(x,t) m -> M.insert x t m) γ xts---instance NFData REnv where-  rnf (REnv _) = () -- rnf m+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImplicitParams            #-}++-- | This module defines the representation of Subtyping and WF Constraints, and+-- the code for syntax-directed constraint generation.++module Language.Haskell.Liquid.Constraint.Generate ( generateConstraints ) where++import Prelude hiding (error, undefined)++import GHC.Stack+import CoreUtils     (exprType)+import MkCore+import Coercion+import DataCon+import Pair+import CoreSyn+import SrcLoc+import Type+import TyCon+import PrelNames+import TypeRep+import Class            (className)+import Var+import Kind+import Id+import IdInfo+import Name+import NameSet+import Unify+import VarSet+-- import Unique+++import Text.PrettyPrint.HughesPJ hiding (first)+import Control.Monad.State+-- import Control.Applicative      ((<$>), (<*>), Applicative)+-- import Data.Monoid              (mconcat, mempty, mappend)+import Data.Maybe               (fromMaybe, catMaybes, fromJust, isJust)+import qualified Data.HashMap.Strict as M+import qualified Data.HashSet        as S+import qualified Data.List           as L++import Data.Bifunctor+import qualified Data.Foldable    as F+import qualified Data.Traversable as T++++++import qualified Language.Haskell.Liquid.UX.CTags       as Tg++++import Language.Fixpoint.Types.Visitor++import Language.Haskell.Liquid.Constraint.Fresh+import Language.Haskell.Liquid.Constraint.Env+import Language.Haskell.Liquid.Constraint.Monad+import Language.Haskell.Liquid.Constraint.Split++import qualified Language.Fixpoint.Types            as F++import Language.Haskell.Liquid.WiredIn          (dictionaryVar)+import Language.Haskell.Liquid.Types.Dictionaries++import qualified Language.Haskell.Liquid.GHC.SpanStack as Sp+import Language.Haskell.Liquid.Types            hiding (binds, Loc, loc, freeTyVars, Def)+import Language.Haskell.Liquid.Types.Strata+import Language.Haskell.Liquid.Types.Names++import Language.Haskell.Liquid.Types.RefType+import Language.Haskell.Liquid.Types.Visitors         hiding (freeVars)+import Language.Haskell.Liquid.Types.PredType         hiding (freeTyVars)+import Language.Haskell.Liquid.Types.Meet+import Language.Haskell.Liquid.GHC.Misc          ( isInternal, collectArguments, tickSrcSpan+                                                 , hasBaseTypeVar, showPpr, isDataConId)+import Language.Haskell.Liquid.Misc+import Language.Fixpoint.Misc+import Language.Haskell.Liquid.Types.Literals++import Language.Haskell.Liquid.Constraint.Axioms+import Language.Haskell.Liquid.Constraint.Types+import Language.Haskell.Liquid.Constraint.Constraint++-- import Debug.Trace (trace)++-----------------------------------------------------------------------+------------- Constraint Generation: Toplevel -------------------------+-----------------------------------------------------------------------++generateConstraints      :: GhcInfo -> CGInfo+generateConstraints info = {-# SCC "ConsGen" #-} execState act $ initCGI cfg info+  where+    act                  = consAct info+    cfg                  = config $ spec info++consAct :: GhcInfo -> CG ()+consAct info+  = do γ'    <- initEnv      info+       sflag <- scheck   <$> get+       tflag <- trustghc <$> get+       γ     <- if expandProofsMode then addCombine τProof γ' else return γ'+       cbs'  <- if expandProofsMode then mapM (expandProofs info (mkSigs γ)) $ cbs info else return $ cbs info+       let trustBinding x = tflag && (x `elem` derVars info || isInternal x)+       foldM_ (consCBTop trustBinding) γ cbs'+       hcs   <- hsCs  <$> get+       hws   <- hsWfs <$> get+       scss  <- sCs   <$> get+       annot <- annotMap <$> get+       scs   <- if sflag then concat <$> mapM splitS (hcs ++ scss)+                         else return []+       let smap = if sflag then solveStrata scs else []+       let hcs' = if sflag then subsS smap hcs else hcs+       fcs <- concat <$> mapM splitC (subsS smap hcs')+       fws <- concat <$> mapM splitW hws+       let annot' = if sflag then subsS smap <$> annot else annot+       modify $ \st -> st { fEnv = fixEnv γ, fixCs = fcs , fixWfs = fws , annotMap = annot'}+  where+    expandProofsMode = autoproofs $ config $ spec info+    τProof           = proofType $ spec info+    fixEnv           = feEnv . fenv+    mkSigs γ         = toListREnv (renv  γ) +++                       toListREnv (assms γ) +++                       toListREnv (intys γ) +++                       toListREnv (grtys γ)++addCombine τ γ+  = do t <- trueTy combineType+       γ ++= ("combineProofs", combineSymbol, t)+  where+    combineType   = makeCombineType τ+    combineVar    = makeCombineVar  combineType+    combineSymbol = F.symbol combineVar++------------------------------------------------------------------------------------+initEnv :: GhcInfo -> CG CGEnv+------------------------------------------------------------------------------------+initEnv info+  = do let tce   = tcEmbeds sp+       let fVars = impVars info+       let dcs   = filter isConLikeId ((snd <$> freeSyms sp))+       let dcs'  = filter isConLikeId fVars+       defaults <- forM fVars $ \x -> liftM (x,) (trueTy $ varType x)+       dcsty    <- forM dcs   $ makeDataConTypes+       dcsty'   <- forM dcs'  $ makeDataConTypes+       (hs,f0)  <- refreshHoles $ grty info                  -- asserted refinements     (for defined vars)+       f0''     <- refreshArgs' =<< grtyTop info             -- default TOP reftype      (for exported vars without spec)+       let f0'   = if notruetypes $ config sp then [] else f0''+       f1       <- refreshArgs'   defaults                   -- default TOP reftype      (for all vars)+       f1'      <- refreshArgs' $ makedcs dcsty+       f2       <- refreshArgs' $ assm info                  -- assumed refinements      (for imported vars)+       f3       <- refreshArgs' $ vals asmSigs sp            -- assumed refinedments     (with `assume`)+       f40      <- refreshArgs' $ vals ctors sp              -- constructor refinements  (for measures)+       f5       <- refreshArgs' $ vals inSigs sp             -- internal refinements     (from Haskell measures)+       (invs1, f41) <- mapSndM refreshArgs' $ makeAutoDecrDataCons dcsty  (autosize sp) dcs+       (invs2, f42) <- mapSndM refreshArgs' $ makeAutoDecrDataCons dcsty' (autosize sp) dcs'+       let f4    = mergeDataConTypes (mergeDataConTypes f40 (f41 ++ f42)) (filter (isDataConId . fst) f2)+       sflag    <- scheck <$> get+       let senv  = if sflag then f2 else []+       let tx    = mapFst F.symbol . addRInv ialias . strataUnify senv . predsUnify sp+       let bs    = (tx <$> ) <$> [f0 ++ f0', f1 ++ f1', f2, f3, f4, f5]+       lts      <- lits <$> get+       let tcb   = mapSnd (rTypeSort tce) <$> concat bs+       let γ0    = measEnv sp (head bs) (cbs info) (tcb ++ lts) (bs!!3) (bs!!5) hs (invs1 ++ invs2)+       globalize <$> foldM (++=) γ0 [("initEnv", x, y) | (x, y) <- concat $ tail bs]+  where+    sp           = spec info+    ialias       = mkRTyConIAl $ ialiases sp+    vals f       = map (mapSnd val) . f+    mapSndM f (x,y) = (x,) <$> f y+    makedcs      = map strengthenDataConType++makeDataConTypes x = (x,) <$> (trueTy $ varType x)++makeAutoDecrDataCons dcts specenv dcs+  = (simplify invs, tys)+  where+    (invs, tys) = unzip $ concatMap go tycons+    tycons      = L.nub $ catMaybes $ map idTyCon dcs++    go tycon+      | S.member tycon specenv =  zipWith (makeSizedDataCons dcts) (tyConDataCons tycon) [0..]+    go _+      = []+    idTyCon x = dataConTyCon <$> case idDetails x of {DataConWorkId d -> Just d; DataConWrapId d -> Just d; _ -> Nothing}++    simplify invs = dummyLoc . (`strengthen` invariant) .  fmap (\_ -> mempty) <$> L.nub invs+    invariant = MkUReft (F.Reft (F.vv_, F.PAtom F.Ge (lenOf F.vv_) (F.ECon $ F.I 0)) ) mempty mempty++lenOf x = F.mkEApp lenLocSymbol [F.EVar x]++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+      tres   = ty_res trep `strengthen` MkUReft (F.Reft (F.vv_, F.PAtom F.Eq (lenOf F.vv_) computelen)) mempty mempty++      recarguments = filter (\(t,_) -> (toRSort t == toRSort tres)) (zip (ty_args trep) (ty_binds trep))+      computelen   = foldr (F.EBin F.Plus) (F.ECon $ F.I n) (lenOf .  snd <$> recarguments)++mergeDataConTypes ::  [(Var, SpecType)] -> [(Var, SpecType)] -> [(Var, SpecType)]+mergeDataConTypes xts yts = merge (L.sortBy f xts) (L.sortBy f yts)+  where+    f (x,_) (y,_) = compare x y+    merge [] ys = ys+    merge xs [] = xs+    merge (xt@(x, tx):xs) (yt@(y, ty):ys)+      | x == y    = (x, mXY x tx y ty) : merge xs ys+      | x <  y    = xt : merge xs (yt : ys)+      | otherwise = yt : merge (xt : xs) ys+    mXY x tx y ty = meetVarTypes (pprint x) (getSrcSpan x, tx) (getSrcSpan y, ty)++refreshHoles vts = first catMaybes . unzip . map extract <$> mapM refreshHoles' vts+refreshHoles' (x,t)+  | noHoles t = return (Nothing, x, t)+  | otherwise = (Just $ F.symbol x,x,) <$> mapReftM tx t+  where+    tx r | hasHole r = refresh r+         | otherwise = return r+extract (a,b,c) = (a,(b,c))++refreshArgs' = mapM (mapSndM refreshArgs)++strataUnify :: [(Var, SpecType)] -> (Var, SpecType) -> (Var, SpecType)+strataUnify senv (x, t) = (x, maybe t (mappend t) pt)+  where+    pt                  = fmap (\(MkUReft _ _ l) -> MkUReft mempty mempty l) <$> L.lookup x senv+++-- | TODO: All this *should* happen inside @Bare@ but appears+--   to happen after certain are signatures are @fresh@-ed,+--   which is why they are here.++-- NV : still some sigs do not get TyConInfo++predsUnify :: GhcSpec -> (Var, RRType RReft) -> (Var, RRType RReft)+predsUnify sp = second (addTyConInfo tce tyi) -- needed to eliminate some @RPropH@+  where+    tce            = tcEmbeds sp+    tyi            = tyconEnv sp++-------------------------------------------------------------------------------+-------------------------------------------------------------------------------+-------------------------------------------------------------------------------++measEnv sp xts cbs lts asms itys hs autosizes+  = CGE { cgLoc = Sp.empty+        , renv  = fromListREnv (second val <$> meas sp) []+        , syenv = F.fromListSEnv $ freeSyms sp+        , fenv  = initFEnv $ lts ++ (second (rTypeSort tce . val) <$> meas sp)+        , denv  = dicts sp+        , recs  = S.empty+        , invs  = mkRTyConInv    $ (invariants sp ++ autosizes)+        , ial   = mkRTyConIAl    $ ialiases   sp+        , grtys = fromListREnv xts  []+        , assms = fromListREnv asms []+        , intys = fromListREnv itys []+        , emb   = tce+        , tgEnv = Tg.makeTagEnv cbs+        , tgKey = Nothing+        , trec  = Nothing+        , lcb   = M.empty+        , holes = fromListHEnv hs+        , lcs   = mempty+        , aenv  = axiom_map $ logicMap sp+        , cerr  = Nothing +        }+    where+      tce = tcEmbeds sp++assm = assmGrty impVars+grty = assmGrty defVars++assmGrty f info = [ (x, val t) | (x, t) <- sigs, x `S.member` xs ]+  where+    xs          = S.fromList $ f info+    sigs        = tySigs     $ spec info++grtyTop info     = forM topVs $ \v -> (v,) <$> trueTy (varType v)+  where+    topVs        = filter isTop $ defVars info+    isTop v      = isExportedId v && not (v `S.member` sigVs)+    isExportedId = flip elemNameSet (exports $ spec info) . getName+    sigVs        = S.fromList [v | (v,_) <- tySigs (spec info) ++ asmSigs (spec info) ++ inSigs (spec info)]++initCGI cfg info = CGInfo {+    fEnv       = F.emptySEnv+  , hsCs       = []+  , sCs        = []+  , hsWfs      = []+  , fixCs      = []+  , isBind     = []+  , fixWfs     = []+  , freshIndex = 0+  , binds      = F.emptyBindEnv+  , annotMap   = AI M.empty+  , tyConInfo  = tyi+  , tyConEmbed = tce+  , kuts       = mempty -- F.ksEmpty+  , lits       = coreBindLits tce info ++  (map (mapSnd F.sr_sort) $ map mkSort $ meas spc)+  , termExprs  = M.fromList $ texprs spc+  , specDecr   = decr spc+  , specLVars  = lvars spc+  , specLazy   = dictionaryVar `S.insert` lazy spc+  , tcheck     = not $ notermination cfg+  , scheck     = strata cfg+  , trustghc   = trustinternals cfg+  , pruneRefs  = not $ noPrune cfg+  , logErrors  = []+  , kvProf     = emptyKVProf+  , recCount   = 0+  , bindSpans  = M.empty+  , autoSize   = autosize spc+  , allowHO    = higherorder cfg   +  }+  where+    tce        = tcEmbeds spc+    spc        = spec info+    tyi        = tyconEnv spc+    mkSort = mapSnd (rTypeSortedReft tce . val)++coreBindLits :: F.TCEmb TyCon -> GhcInfo -> [(F.Symbol, F.Sort)]+coreBindLits tce info+  = sortNub      $ [ (F.symbol x, F.strSort) | (_, Just (F.ESym x)) <- lconsts ]    -- strings+                ++ [ (dconToSym dc, dconToSort dc) | dc <- dcons ]                  -- data constructors+  where+    lconsts      = literalConst tce <$> literals (cbs info)+    dcons        = filter isDCon freeVs+    freeVs       = impVars info ++ (snd <$> freeSyms (spec info))+    dconToSort   = typeSort tce . expandTypeSynonyms . varType+    dconToSym    = F.symbol . idDataCon+    isDCon x     = isDataConId x && not (hasBaseTypeVar x)++-------------------------------------------------------------------+-- | Generation: Freshness ---------------------------------------+-------------------------------------------------------------------++-- | Right now, we generate NO new pvars. Rather than clutter code+--   with `uRType` calls, put it in one place where the above+--   invariant is /obviously/ enforced.+--   Constraint generation should ONLY use @freshTy_type@ and @freshTy_expr@++freshTy_type        :: KVKind -> CoreExpr -> Type -> CG SpecType+freshTy_type k _ τ  = freshTy_reftype k $ ofType τ++freshTy_expr        :: KVKind -> CoreExpr -> Type -> CG SpecType+freshTy_expr k e _  = freshTy_reftype k $ exprRefType e++freshTy_reftype     :: KVKind -> SpecType -> CG SpecType+freshTy_reftype k t = (fixTy t >>= refresh) =>> addKVars k++-- | 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 when (True)    $ modify $ \s -> s { kvProf = updKVProf k kvars (kvProf s) }+                     when (isKut k) $ modify $ \s -> s { kuts   = mappend   kvars   (kuts s)   }+  where+     kvars      = F.KS $ S.fromList $ specTypeKVars t++isKut          :: KVKind -> Bool+isKut RecBindE = True+isKut _        = False++specTypeKVars :: SpecType -> [F.KVar]+specTypeKVars = foldReft (\ _ r ks -> (kvars $ ur_reft r) ++ ks) []++trueTy  :: Type -> CG SpecType+trueTy = ofType' >=> true++ofType' :: Type -> CG SpecType+ofType' = fixTy . ofType++fixTy :: SpecType -> CG SpecType+fixTy t = do tyi   <- tyConInfo  <$> get+             tce   <- tyConEmbed <$> get+             return $ addTyConInfo tce tyi t++refreshArgsTop :: (Var, SpecType) -> CG SpecType+refreshArgsTop (x, t)+  = do (t', su) <- refreshArgsSub t+       modify $ \s -> s {termExprs = M.adjust (F.subst su <$>) x $ termExprs s}+       return t'++refreshArgs :: SpecType -> CG SpecType+refreshArgs t+  = fst <$> refreshArgsSub t+++-- NV TODO: this does not refresh args if they are wrapped in an RRTy+refreshArgsSub :: SpecType -> CG (SpecType, F.Subst)+refreshArgsSub t+  = do ts     <- mapM refreshArgs ts_u+       xs'    <- mapM (\_ -> fresh) xs+       let sus = F.mkSubst <$> (L.inits $ zip xs (F.EVar <$> xs'))+       let su  = last sus+       let ts' = zipWith F.subst sus ts+       let t'  = fromRTypeRep $ trep {ty_binds = xs', ty_args = ts', ty_res = F.subst su tbd}+       return (t', su)+    where+       trep    = toRTypeRep t+       xs      = ty_binds trep+       ts_u    = ty_args  trep+       tbd     = ty_res   trep++-------------------------------------------------------------------------------+-- | TERMINATION TYPE --------------------------------------+-------------------------------------------------------------------------------++makeDecrIndex :: (Var, Template SpecType)-> CG [Int]+makeDecrIndex (x, Assumed t)+  = do dindex <- makeDecrIndexTy x t+       case dindex of+         Left _  -> return []+         Right i -> return i+makeDecrIndex (x, Asserted t)+  = do dindex <- makeDecrIndexTy x t+       case dindex of+         Left msg -> addWarning msg >> return []+         Right i  -> return i+makeDecrIndex _ = return []++makeDecrIndexTy x t+  = do spDecr <- specDecr <$> get+       autosz <- autoSize <$> get+       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+       checkHint' = \autosz -> checkHint x ts (isDecreasing autosz cenv)+       dindex     = \autosz -> L.findIndex    (isDecreasing autosz cenv) ts+       msg        = ErrTermin (getSrcSpan x) [pprint x] (text "No decreasing parameter")+       cenv       = makeNumEnv ts+       trep       = toRTypeRep $ unOCons t+++recType _ ((_, []), (_, [], t))+  = t++recType autoenv ((vs, indexc), (_, index, t))+  = makeRecType autoenv t v dxt index+  where v    = (vs !!)  <$> indexc+        dxt  = (xts !!) <$> index+        xts  = zip (ty_binds trep) (ty_args trep)+        trep = toRTypeRep $ unOCons t++-- checkIndex :: (Var, _, _ , _) -> _+checkIndex (x, vs, t, index)+  = do mapM_ (safeLogIndex msg1 vs) index+       mapM  (safeLogIndex msg2 ts) index+    where+       loc   = getSrcSpan x+       ts    = ty_args $ toRTypeRep $ unOCons $ unTemplate t+       msg1  = ErrTermin loc [xd] ("No decreasing" <+>  pprint index <> "-th argument on" <+> xd <+> "with" <+> (pprint vs))+       msg2  = ErrTermin loc [xd] "No decreasing parameter"+       xd    = pprint x++makeRecType autoenv t vs dxs is+  = mergecondition t $ fromRTypeRep $ trep {ty_binds = xs', ty_args = ts'}+  where+    (xs', ts') = unzip $ replaceN (last is) (makeDecrType autoenv vdxs) xts+    vdxs       = zip vs dxs+    xts        = zip (ty_binds trep) (ty_args trep)+    trep       = toRTypeRep $ unOCons t++unOCons (RAllT v t)        = RAllT v $ unOCons t+unOCons (RAllP p t)        = RAllP p $ unOCons t+unOCons (RFun x tx t r)    = RFun x (unOCons tx) (unOCons t) r+unOCons (RRTy _ _ OCons t) = unOCons t+unOCons t                  = t+++mergecondition (RAllT _ t1) (RAllT v t2)+  = RAllT v $ mergecondition t1 t2+mergecondition (RAllP _ t1) (RAllP p t2)+  = RAllP p $ mergecondition t1 t2+mergecondition (RRTy xts r OCons t1) t2+  = RRTy xts r OCons (mergecondition t1 t2)+mergecondition (RFun _ t11 t12 _) (RFun x2 t21 t22 r2)+  = RFun x2 (mergecondition t11 t21) (mergecondition t12 t22) r2+mergecondition _ t+  = t++safeLogIndex err ls n+  | n >= length ls = addWarning err >> return Nothing+  | otherwise      = return $ Just $ ls !! n++checkHint _ _ _ Nothing+  = return Nothing++checkHint x _ _ (Just ns) | L.sort ns /= ns+  = addWarning (ErrTermin loc [dx] (text "The hints should be increasing")) >> return Nothing+  where+    loc = getSrcSpan x+    dx  = pprint x++checkHint x ts f (Just ns)+  = (mapM (checkValidHint x ts f) ns) >>= (return . Just . catMaybes)++checkValidHint x ts f n+  | n < 0 || n >= length ts = addWarning err >> return Nothing+  | f (ts L.!! n)           = return $ Just n+  | otherwise               = addWarning err >> return Nothing+  where+    err = ErrTermin loc [xd] (vcat [ "Invalid Hint" <+> pprint (n+1) <+> "for" <+> xd+                                   , "in"+                                   , pprint ts ])+    loc = getSrcSpan x+    xd  = pprint x++--------------------------------------------------------------------------------+consCBLet :: CGEnv -> CoreBind -> CG CGEnv+--------------------------------------------------------------------------------+consCBLet γ cb+  = do oldtcheck <- tcheck <$> get+       strict    <- specLazy <$> get+       let tflag  = oldtcheck+       let isStr  = tcond cb strict+       -- TODO: yuck.+       modify $ \s -> s { tcheck = tflag && isStr }+       γ' <- consCB (tflag && isStr) isStr γ cb+       modify $ \s -> s{tcheck = oldtcheck}+       return γ'++--------------------------------------------------------------------------------+-- | Constraint Generation: Corebind -------------------------------------------+--------------------------------------------------------------------------------+consCBTop :: (Var -> Bool) -> CGEnv -> CoreBind -> CG CGEnv+--------------------------------------------------------------------------------+consCBTop trustBinding γ cb | all trustBinding xs+  = do ts <- mapM trueTy (varType <$> xs)+       foldM (\γ xt -> (γ, "derived") += xt) γ (zip xs' ts)+    where+       xs  = bindersOf cb+       xs' = F.symbol <$> xs++consCBTop _ γ cb+  = do oldtcheck <- tcheck <$> get+       strict    <- specLazy <$> get+       let tflag  = oldtcheck+       let isStr  = tcond cb strict+       modify $ \s -> s { tcheck = tflag && isStr}+       γ' <- consCB (tflag && isStr) isStr γ cb+       modify $ \s -> s { tcheck = oldtcheck}+       return γ'++tcond cb strict+  = not $ any (\x -> S.member x strict || isInternal x) (binds cb)+  where+    binds (NonRec x _) = [x]+    binds (Rec xes)    = fst $ unzip xes++--------------------------------------------------------------------------------+consCB :: Bool -> Bool -> CGEnv -> CoreBind -> CG CGEnv+--------------------------------------------------------------------------------++-- RJ: AAAAAAARGHHH!!!!!! THIS CODE IS HORRIBLE!!!!!!!!!+consCBSizedTys γ xes+  = do xets''    <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))+       sflag     <- scheck <$> get+       autoenv   <- autoSize <$> get+       let cmakeFinType = if sflag then makeFinType else id+       let cmakeFinTy   = if sflag then makeFinTy   else snd+       let xets = mapThd3 (fmap cmakeFinType) <$> xets''+       ts'      <- mapM (T.mapM refreshArgs) $ (thd3 <$> xets)+       let vs    = zipWith collectArgs ts' es+       is       <- mapM makeDecrIndex (zip xs ts') >>= checkSameLens+       let ts = cmakeFinTy  <$> zip is ts'+       let xeets = (\vis -> [(vis, x) | x <- zip3 xs is $ map unTemplate ts]) <$> (zip vs is)+       (L.transpose <$> mapM checkIndex (zip4 xs vs ts is)) >>= checkEqTypes+       let rts   = (recType autoenv <$>) <$> xeets+       let xts   = zip xs ts+       γ'       <- foldM extender γ xts+       let γs    = [γ' `setTRec` (zip xs rts') | rts' <- rts]+       let xets' = zip3 xs es ts+       mapM_ (uncurry $ consBind True) (zip γs xets')+       return γ'+  where+       (xs, es)       = unzip xes+       dxs            = pprint <$> xs+       collectArgs    = collectArguments . length . ty_binds . toRTypeRep . unOCons . unTemplate+       checkEqTypes :: [[Maybe SpecType]] -> CG [[SpecType]]+       checkEqTypes x = mapM (checkAll err1 toRSort) (catMaybes <$> x)+       checkSameLens  = checkAll err2 length+       err1           = ErrTermin loc dxs $ text "The decreasing parameters should be of same type"+       err2           = ErrTermin loc dxs $ text "All Recursive functions should have the same number of decreasing parameters"+       loc            = getSrcSpan (head xs)++       checkAll _   _ []            = return []+       checkAll err f (x:xs)+         | all (==(f x)) (f <$> xs) = return (x:xs)+         | otherwise                = addWarning err >> return []++consCBWithExprs γ xes+  = do xets'     <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))+       texprs <- termExprs <$> get+       let xtes = catMaybes $ (`lookup` texprs) <$> xs+       sflag     <- scheck <$> get+       let cmakeFinType = if sflag then makeFinType else id+       let xets  = mapThd3 (fmap cmakeFinType) <$> xets'+       let ts    = safeFromAsserted err . thd3 <$> xets+       ts'      <- mapM refreshArgs ts+       let xts   = zip xs (Asserted <$> ts')+       γ'       <- foldM extender γ xts+       let γs    = makeTermEnvs γ' xtes xes ts ts'+       let xets' = zip3 xs es (Asserted <$> ts')+       mapM_ (uncurry $ consBind True) (zip γs xets')+       return γ'+  where (xs, es) = unzip xes+        lookup k m | Just x <- M.lookup k m = Just (k, x)+                   | otherwise              = Nothing+        err      = "Constant: consCBWithExprs"++makeFinTy (ns, t) = fmap go t+  where+    go t = fromRTypeRep $ trep {ty_args = args'}+      where+        trep = toRTypeRep t+        args' = mapNs ns makeFinType $ ty_args trep++makeTermEnvs γ xtes xes ts ts' = setTRec γ . zip xs <$> rts+  where+    vs   = zipWith collectArgs ts es+    ys   = (fst4 . bkArrowDeep) <$> ts+    ys'  = (fst4 . bkArrowDeep) <$> ts'+    sus' = zipWith mkSub ys ys'+    sus  = zipWith mkSub ys ((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+    mkSub ys ys' = F.mkSubst [(x, F.EVar y) | (x, y) <- zip ys ys']+    collectArgs  = collectArguments . length . ty_binds . toRTypeRep+    err x        = "Constant: makeTermEnvs: no terminating expression for " ++ showPpr x++addObligation :: Oblig -> SpecType -> RReft -> SpecType+addObligation o t r  = mkArrow αs πs ls xts $ RRTy [] r o t2+  where+    (αs, πs, ls, t1) = bkUniv t+    (xs, ts, rs, t2) = bkArrow t1+    xts              = zip3 xs ts rs+++consCB tflag _ γ (Rec xes) | tflag+  = do texprs <- termExprs <$> get+       modify $ \i -> i { recCount = recCount i + length xes }+       let xxes = catMaybes $ (`lookup` texprs) <$> xs+       if null xxes+         then consCBSizedTys γ xes+         else check xxes <$> consCBWithExprs γ xes+    where+      xs = fst $ unzip xes+      check ys r | length ys == length xs = r+                 | otherwise              = panic (Just loc) $ msg+      msg        = "Termination expressions must be provided for all mutually recursive binders"+      loc        = getSrcSpan (head xs)+      lookup k m = (k,) <$> M.lookup k m++consCB _ str γ (Rec xes) | not str+  = do xets'   <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))+       sflag     <- scheck <$> get+       let cmakeDivType = if sflag then makeDivType else id+       let xets = mapThd3 (fmap cmakeDivType) <$> xets'+       modify $ \i -> i { recCount = recCount i + length xes }+       let xts = [(x, to) | (x, _, to) <- xets]+       γ'     <- foldM extender (γ `setRecs` (fst <$> xts)) xts+       mapM_ (consBind True γ') xets+       return γ'++consCB _ _ γ (Rec xes)+  = do xets   <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))+       modify $ \i -> i { recCount = recCount i + length xes }+       let xts = [(x, to) | (x, _, to) <- xets]+       γ'     <- foldM extender (γ `setRecs` (fst <$> xts)) xts+       mapM_ (consBind True γ') xets+       return γ'++-- | NV: Dictionaries are not checked, because+-- | class methods' preconditions are not satisfied+consCB _ _ γ (NonRec x _) | isDictionary x+  = do t  <- trueTy (varType x)+       extender γ (x, Assumed t)+  where+    isDictionary = isJust . dlookup (denv γ)+++consCB _ _ γ (NonRec x (App (Var w) (Type τ)))+  | Just d <- dlookup (denv γ) w+  = do t      <- trueTy τ+       addW    $ WfC γ t+       let xts = dmap (f t) d+       let  γ' = γ{denv = dinsert (denv γ) x xts }+       t      <- trueTy (varType x)+       extender γ' (x, Assumed t)+   where+       f t' (RAllT α te) = subsTyVar_meet' (α, t') te+       f _ _ = impossible Nothing "consCB on Dictionary: this should not happen"++consCB _ _ γ (NonRec x e)+  = do to  <- varTemplate γ (x, Nothing)+       to' <- consBind False γ (x, e, to) >>= (addPostTemplate γ)+       extender γ (x, to')++--------------------------------------------------------------------------------+consBind :: Bool+         -> CGEnv+         -> (Var, CoreExpr ,Template SpecType)+         -> CG (Template SpecType)+--------------------------------------------------------------------------------+consBind _ _ (x, _, t)+  | RecSelId {} <- idDetails x -- don't check record selectors+  = return t++consBind isRec γ (x, e, Asserted spect)+  = do let γ'         = γ `setBind` x+           (_,πs,_,_) = bkUniv spect+       γπ    <- foldM addPToEnv γ' πs+       cconsE γπ e spect+       when (F.symbol x `elemHEnv` holes γ) $+         -- have to add the wf constraint here for HOLEs so we have the proper env+         addW $ WfC γπ $ fmap killSubst spect+       addIdA x (defAnn isRec spect)+       return $ Asserted spect -- Nothing++consBind isRec γ (x, e, Internal spect)+  = do let γ'         = γ `setBind` x+           (_,πs,_,_) = bkUniv spect+       γπ    <- foldM addPToEnv γ' πs+       let γπ' = γπ {cerr = Just $ ErrHMeas (getLocation γπ) (pprint x) (text explanation)}+       cconsE γπ' e spect+       when (F.symbol x `elemHEnv` holes γ) $+         -- have to add the wf constraint here for HOLEs so we have the proper env+         addW $ WfC γπ $ fmap killSubst spect+       addIdA x (defAnn isRec spect)+       return $ Internal spect -- Nothing+  where+    explanation = "Cannot give singleton type to the function definition."+++consBind isRec γ (x, e, Assumed spect)+  = do let γ' = γ `setBind` x+       γπ    <- foldM addPToEnv γ' πs+       cconsE γπ e =<< true spect+       addIdA x (defAnn isRec spect)+       return $ Asserted spect -- Nothing+  where πs   = ty_preds $ toRTypeRep spect++consBind isRec γ (x, e, Unknown)+  = do t     <- consE (γ `setBind` x) e+       addIdA x (defAnn isRec t)+       return $ Asserted t+++noHoles = and . foldReft (\_ r bs -> not (hasHole r) : bs) []++killSubst :: RReft -> RReft+killSubst = fmap killSubstReft++killSubstReft :: F.Reft -> F.Reft+killSubstReft = trans kv () ()+  where+    kv    = defaultVisitor { txExpr = ks }+    ks _ (F.PKVar k _) = F.PKVar k mempty+    ks _ p             = p++    -- tx (F.Reft (s, rs)) = F.Reft (s, map f rs)+    -- f (F.RKvar k _)     = F.RKvar k mempty+    -- f (F.RConc p)       = F.RConc p++defAnn True  = AnnRDf+defAnn False = AnnDef++addPToEnv γ π+  = do γπ <- γ ++= ("addSpec1", pname π, pvarRType π)+       foldM (++=) γπ [("addSpec2", x, ofRSort t) | (t, x, _) <- pargs π]++extender γ (x, Asserted t) = γ ++= ("extender", F.symbol x, t)+extender γ (x, Assumed t)  = γ ++= ("extender", F.symbol x, t)+extender γ _               = return γ+++data Template a = Asserted a | Assumed a | Internal a | Unknown deriving (Functor, F.Foldable, T.Traversable)++deriving instance (Show a) => (Show (Template a))++unTemplate (Asserted t) = t+unTemplate (Assumed t)  = t+unTemplate (Internal t) = t +unTemplate _ = panic Nothing "Constraint.Generate.unTemplate called on `Unknown`"++addPostTemplate γ (Asserted t) = Asserted <$> addPost γ t+addPostTemplate γ (Assumed  t) = Assumed  <$> addPost γ t+addPostTemplate γ (Internal t) = Internal  <$> addPost γ t+addPostTemplate _ Unknown      = return Unknown++safeFromAsserted _ (Asserted t) = t+safeFromAsserted msg _ = panic Nothing $ "safeFromAsserted:" ++ msg++-- | @varTemplate@ is only called with a `Just e` argument when the `e`+-- corresponds to the body of a @Rec@ binder.+varTemplate :: CGEnv -> (Var, Maybe CoreExpr) -> CG (Template SpecType)+varTemplate γ (x, eo)+  = case (eo, lookupREnv (F.symbol x) (grtys γ), lookupREnv (F.symbol x) (assms γ), lookupREnv (F.symbol x) (intys γ)) of+      (_, Just t, _, _) -> Asserted <$> refreshArgsTop (x, t)+      (_, _, _, Just t) -> Internal <$> refreshArgsTop (x, t)+      (_, _, Just t, _) -> Assumed  <$> refreshArgsTop (x, t)+      (Just e, _, _, _) -> do t  <- freshTy_expr RecBindE e (exprType e)+                              addW (WfC γ t)+                              Asserted <$> refreshArgsTop (x, t)+      (_,      _, _, _) -> return Unknown++--------------------------------------------------------------------------------+-- | Constraint Generation: Checking -------------------------------------------+--------------------------------------------------------------------------------+cconsE :: CGEnv -> Expr Var -> SpecType -> CG ()+--------------------------------------------------------------------------------+cconsE g e t = do+  -- Note: tracing goes here+  -- traceM $ printf "cconsE:\n  expr = %s\n  exprType = %s\n  lqType = %s\n" (showPpr e) (showPpr (exprType e)) (showpp t)+  cconsE' g e t++cconsE' :: CGEnv -> Expr Var -> SpecType -> CG ()+cconsE' γ e@(Let b@(NonRec x _) ee) t+  = do sp <- specLVars <$> get+       if (x `S.member` sp) || isDefLazyVar x+        then cconsLazyLet γ e t+        else do γ'  <- consCBLet γ b+                cconsE γ' ee t+  where+       isDefLazyVar = L.isPrefixOf "fail" . showPpr++cconsE' γ e (RAllP p t)+  = cconsE γ' e t''+  where+    t'         = replacePredsWithRefs su <$> t+    su         = (uPVar p, pVartoRConc p)+    (css, t'') = splitConstraints t'+    γ'         = L.foldl' addConstraints γ css++cconsE' γ (Let b e) t+  = do γ'  <- consCBLet γ b+       cconsE γ' e t++cconsE' γ (Case e x _ cases) t+  = do γ'  <- consCBLet γ (NonRec x e)+       forM_ cases $ cconsCase γ' x t nonDefAlts+    where+       nonDefAlts = [a | (a, _, _) <- cases, a /= DEFAULT]++cconsE' γ (Lam α e) (RAllT _ t) | isKindVar α+  = cconsE γ e t++cconsE' γ (Lam α e) (RAllT α' t) | isTyVar α+  = cconsE γ e $ subsTyVar_meet' (α', rVar α) t++cconsE' γ (Lam x e) (RFun y ty t _)+  | not (isTyVar x)+  = do γ' <- (γ, "cconsE") += (F.symbol x, ty)+       cconsE γ' e (t `F.subst1` (y, F.EVar $ F.symbol x))+       addIdA x (AnnDef ty)++cconsE' γ (Tick tt e) t+  = cconsE (γ `setLocation` (Sp.Tick tt)) e t++cconsE' γ (Cast e co) t+  -- See Note [Type classes with a single method]+  | Just f <- isClassConCo co+  = cconsE γ (f e) t++cconsE' γ e@(Cast e' _) t+  = do t' <- castTy γ (exprType e) e'+       addC (SubC γ t' t) ("cconsE Cast: " ++ showPpr e)++cconsE' γ e t+  = do te  <- consE γ e+       te' <- instantiatePreds γ e te >>= addPost γ+       addC (SubC γ te' t) ("cconsE: " ++ showPpr e)+++splitConstraints (RRTy cs _ OCons t)+  = let (css, t') = splitConstraints t in (cs:css, t')+splitConstraints (RFun x tx@(RApp c _ _ _) t r) | isClass c+  = let (css, t') = splitConstraints t in (css, RFun x tx t' r)+splitConstraints t+  = ([], t)++-------------------------------------------------------------------+-- | @instantiatePreds@ peels away the universally quantified @PVars@+--   of a @RType@, generates fresh @Ref@ for them and substitutes them+--   in the body.+-------------------------------------------------------------------+instantiatePreds γ e (RAllP π t)+  = do r     <- freshPredRef γ e π+       instantiatePreds γ e $ replacePreds "consE" t [(π, r)]++instantiatePreds _ _ t0+  = return t0++-------------------------------------------------------------------+-- | @instantiateStrata@ generates fresh @Strata@ vars and substitutes+--   them inside the body of the type.+-------------------------------------------------------------------++instantiateStrata ls t = substStrata t ls <$> mapM (\_ -> fresh) ls++substStrata t ls ls'   = F.substa f t+  where+    f x                = fromMaybe x $ L.lookup x su+    su                 = zip ls ls'++-------------------------------------------------------------------+cconsLazyLet γ (Let (NonRec x ex) e) t+  = do tx <- trueTy (varType x)+       γ' <- (γ, "Let NonRec") +++= (x', ex, tx)+       cconsE γ' e t+    where+       x' = F.symbol x++cconsLazyLet _ _ _+  = panic Nothing "Constraint.Generate.cconsLazyLet called on invalid inputs"++--------------------------------------------------------------------------------+-- | Type Synthesis ------------------------------------------------------------+--------------------------------------------------------------------------------+consE :: CGEnv -> Expr Var -> CG SpecType+--------------------------------------------------------------------------------++-- NV this is a hack to type polymorphic axiomatized functions+-- no need to check this code with flag, the axioms environment withh +-- be empty if there is no axiomatization++consE γ e'@(App e@(Var x) (Type τ)) | (M.member x $ aenv γ)+  = do RAllT α te <- checkAll ("Non-all TyApp with expr", e) <$> consE γ e+       t          <- if isGeneric α te then freshTy_type TypeInstE e τ else trueTy τ+       addW        $ WfC γ t+       t'         <- refreshVV t+       tt <- instantiatePreds γ e' $ subsTyVar_meet' (α, t') te+       return $ strengthenS tt (singletonReft (M.lookup x $ aenv γ) x)++{-+consE γ (Lam β (e'@(App e@(Var x) (Type τ)))) | (M.member x $ aenv γ) && isTyVar β +  = do RAllT α te <- checkAll ("Non-all TyApp with expr", e) <$> consE γ e+       t          <- if isGeneric α te then freshTy_type TypeInstE e τ else trueTy τ+       addW        $ WfC γ t+       t'         <- refreshVV t+       tt  <- instantiatePreds γ e' $ subsTyVar_meet' (α, t') te+       return $ RAllT (rTyVar β) +                  $ strengthenS tt (singletonReft (M.lookup x $ aenv γ) x)+-}+-- NV END HACK ++consE γ (Var x)+  = do t <- varRefType γ x+       addLocA (Just x) (getLocation γ) (varAnn γ x t)+       return t++consE _ (Lit c)+  = refreshVV $ uRType $ literalFRefType c++consE γ (App e (Type τ)) | isKind τ+  = consE γ e+++consE γ e'@(App e (Type τ))+  = do RAllT α te <- checkAll ("Non-all TyApp with expr", e) <$> consE γ e+       t          <- if isGeneric α te then freshTy_type TypeInstE e τ else trueTy τ+       addW        $ WfC γ t+       t'         <- refreshVV t+       instantiatePreds γ e' $ subsTyVar_meet' (α, t') te++-- RJ: The snippet below is *too long*. Please pull stuff from the where-clause+-- out to the top-level.+consE γ e'@(App e a) | isDictionary a+  = if isJust tt+      then return $ fromJust tt+      else do ([], πs, ls, te) <- bkUniv <$> consE γ e+              te0              <- instantiatePreds γ e' $ foldr RAllP te πs+              te'              <- instantiateStrata ls te0+              (γ', te''')      <- dropExists γ te'+              te''             <- dropConstraints γ te'''+              updateLocA {- πs -}  (exprLoc e) te''+              let RFun x tx t _ = checkFun ("Non-fun App with caller ", e') te''+              pushConsBind      $ cconsE γ' a tx+              addPost γ'        $ maybe (checkUnbound γ' e' x t a) (F.subst1 t . (x,)) (argExpr γ a)+  where+    grepfunname (App x (Type _)) = grepfunname x+    grepfunname (Var x)          = x+    grepfunname e                = panic Nothing $ "grepfunname on \t" ++ showPpr e+    mdict w                      = case w of+                                     Var x    -> case dlookup (denv γ) x of {Just _ -> Just x; Nothing -> Nothing}+                                     Tick _ e -> mdict e+                                     _        -> Nothing+    isDictionary _               = isJust (mdict a)+    d = fromJust (mdict a)+    dinfo = dlookup (denv γ) d+    tt = dhasinfo dinfo $ grepfunname e++consE γ e'@(App e a)+  = do ([], πs, ls, te) <- bkUniv <$> consE γ e+       te0              <- instantiatePreds γ e' $ foldr RAllP te πs+       te'              <- instantiateStrata ls te0+       (γ', te''')      <- dropExists γ te'+       te''             <- dropConstraints γ te'''+       updateLocA {- πs -}  (exprLoc e) te''+       let RFun x tx t _ = checkFun ("Non-fun App with caller ", e') te''+       pushConsBind      $ cconsE γ' a tx+       addPost γ'        $ maybe (checkUnbound γ' e' x t a) (F.subst1 t . (x,)) (argExpr γ a)+       {- +       tt <- addPost γ'        $ maybe (checkUnbound γ' e' x t a) (F.subst1 t . (x,)) (argExpr γ a)+       let rr = case (argExpr γ e, argExpr γ a) of +                 (Just e', Just a') -> uTop $ F.Reft (F.vv_, F.PAtom F.Eq (F.EVar F.vv_) (F.EApp e' a'))+                 _                  -> mempty+       return $ tt `strengthen` rr +       -}+++consE γ (Lam α e) | isTyVar α+  = liftM (RAllT (rTyVar α)) (consE γ e)++consE γ  e@(Lam x e1)+  = do tx      <- freshTy_type LamE (Var x) τx+       γ'      <- ((γ, "consE") += (F.symbol x, tx))+       t1      <- consE γ' e1+       addIdA x $ AnnDef tx+       addW     $ WfC γ tx+       return   $ rFun (F.symbol x) tx t1+    where+      FunTy τx _ = exprType e++consE γ e@(Let _ _)+  = cconsFreshE LetE γ e++consE γ e@(Case _ _ _ _)+  = cconsFreshE CaseE γ e++consE γ (Tick tt e)+  = do t <- consE (setLocation γ (Sp.Tick tt)) e+       addLocA Nothing (tickSrcSpan tt) (AnnUse t)+       return t++consE γ (Cast e co)+  -- See Note [Type classes with a single method]+  | Just f <- isClassConCo co+  = consE γ (f e)++consE γ e@(Cast e' _)+  = castTy γ (exprType e) e'++consE _ e@(Coercion _)+   = trueTy $ exprType e++consE _ e@(Type t)+  = panic Nothing $ "consE cannot handle type " ++ showPpr (e, t)++castTy _ τ (Var x)+  = do t <- trueTy τ+       return $  t `strengthen` (uTop $ F.uexprReft $ F.expr x)++castTy g t (Tick _ e)+  = castTy g t e++castTy _ _ e+  = panic Nothing $ "castTy cannot handle expr " ++ showPpr e++isClassConCo :: Coercion -> Maybe (Expr Var -> Expr Var)+-- See Note [Type classes with a single method]+isClassConCo co+  --- | trace ("isClassConCo: " ++ showPpr (coercionKind co)) False+  --- = undefined++  | Pair t1 t2 <- coercionKind co+  , isClassPred t2+  , (tc,ts) <- splitTyConApp t2+  , [dc]    <- tyConDataCons tc+  , [tm]    <- dataConOrigArgTys dc+               -- tcMatchTy because we have to instantiate the class tyvars+  , Just _  <- tcMatchTy (mkVarSet $ tyConTyVars tc) tm t1+  = Just (\e -> mkCoreConApps dc $ map Type ts ++ [e])++  | otherwise+  = Nothing++----------------------------------------------------------------------+-- Note [Type classes with a single method]+----------------------------------------------------------------------+-- GHC 7.10 encodes type classes with a single method as newtypes and+-- `cast`s between the method and class type instead of applying the+-- class constructor. Just rewrite the core to what we're used to+-- seeing..+--+-- specifically, we want to rewrite+--+--   e `cast` ((a -> b) ~ C)+--+-- to+--+--   D:C e+--+-- but only when+--+--   D:C :: (a -> b) -> C++-- | @consElimE@ is used to *synthesize* types by **existential elimination**+--   instead of *checking* via a fresh template. That is, assuming+--      γ |- e1 ~> t1+--   we have+--      γ |- let x = e1 in e2 ~> Ex x t1 t2+--   where+--      γ, x:t1 |- e2 ~> t2+--   instead of the earlier case where we generate a fresh template `t` and check+--      γ, x:t1 |- e <~ t++-- consElimE γ xs e+--   = do t     <- consE γ e+--        xts   <- forM xs $ \x -> (x,) <$> (γ ??= x)+--        return $ rEx xts t++-- | @consFreshE@ is used to *synthesize* types with a **fresh template** when+--   the above existential elimination is not easy (e.g. at joins, recursive binders)++cconsFreshE kvkind γ e+  = do t   <- freshTy_type kvkind e $ exprType e+       addW $ WfC γ t+       cconsE γ e t+       return t++checkUnbound γ e x t a+  | x `notElem` (F.syms t) = t+  | otherwise              = panic (Just $ getLocation γ) msg+  where+    msg = unlines [ "checkUnbound: " ++ show x ++ " is elem of syms of " ++ show t+                         , "In", showPpr e, "Arg = " , show a ]+++dropExists γ (REx x tx t) = liftM (, t) $ (γ, "dropExists") += (x, tx)+dropExists γ t            = return (γ, t)++dropConstraints :: CGEnv -> SpecType -> CG SpecType+dropConstraints γ (RFun x tx@(RApp c _ _ _) t r) | isClass c+  = (flip (RFun x tx)) r <$> dropConstraints γ t+dropConstraints γ (RRTy cts _ OCons t)+  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ xts+       addC (SubC  γ' t1 t2)  "dropConstraints"+       dropConstraints γ t+  where+    (xts, t1, t2) = envToSub cts++dropConstraints _ t = return t++-------------------------------------------------------------------------------------+cconsCase :: CGEnv -> Var -> SpecType -> [AltCon] -> (AltCon, [Var], CoreExpr) -> CG ()+-------------------------------------------------------------------------------------+cconsCase γ x t acs (ac, ys, ce)+  = do cγ <- caseEnv γ x acs ac ys+       cconsE cγ ce t++--------------------------------------------------------------------------------+refreshTy :: SpecType -> CG SpecType+--------------------------------------------------------------------------------+refreshTy t = refreshVV t >>= refreshArgs++refreshVV (RAllT a t) = liftM (RAllT a) (refreshVV t)+refreshVV (RAllP p t) = liftM (RAllP p) (refreshVV t)++refreshVV (REx x t1 t2)+  = do [t1', t2'] <- mapM refreshVV [t1, t2]+       liftM (shiftVV (REx x t1' t2')) fresh++refreshVV (RFun x t1 t2 r)+  = do [t1', t2'] <- mapM refreshVV [t1, t2]+       liftM (shiftVV (RFun x t1' t2' r)) fresh++refreshVV (RAppTy t1 t2 r)+  = do [t1', t2'] <- mapM refreshVV [t1, t2]+       liftM (shiftVV (RAppTy t1' t2' r)) fresh++refreshVV (RApp c ts rs r)+  = do ts' <- mapM refreshVV ts+       rs' <- mapM refreshVVRef rs+       liftM (shiftVV (RApp c ts' rs' r)) fresh++refreshVV t+  = return t++refreshVVRef (RProp ss (RHole r))+  = return $ RProp ss (RHole r)++refreshVVRef (RProp ss t)+  = do xs    <- mapM (\_ -> fresh) (fst <$> ss)+       let su = F.mkSubst $ zip (fst <$> ss) (F.EVar <$> xs)+       liftM (RProp (zip xs (snd <$> ss)) . F.subst su) (refreshVV t)+++++-------------------------------------------------------------------------------------+caseEnv   :: CGEnv -> Var -> [AltCon] -> AltCon -> [Var] -> CG CGEnv+-------------------------------------------------------------------------------------+caseEnv γ x _   (DataAlt c) ys+  = do let (x' : ys')    = F.symbol <$> (x:ys)+       xt0              <- checkTyCon ("checkTycon cconsCase", x) <$> γ ??= x+       let xt            = shiftVV xt0 x'+       tdc              <- γ ??= ({- F.symbol -} dataConWorkId c) >>= refreshVV+       let (rtd, yts, _) = unfoldR tdc xt ys+       let r1            = dataConReft   c   ys'+       let r2            = dataConMsReft rtd ys'+       let xt            = (xt0 `F.meet` rtd) `strengthen` (uTop (r1 `F.meet` r2))+       let cbs           = safeZip "cconsCase" (x':ys') (xt0:yts)+       cγ'              <- addBinders γ x' cbs+       cγ               <- addBinders cγ' x' [(x', xt)]+       return cγ++caseEnv γ x acs a _+  = do let x'  = F.symbol x+       xt'    <- (`strengthen` uTop (altReft γ acs a)) <$> (γ ??= x)+       cγ     <- addBinders γ x' [(x', xt')]+       return cγ++altReft _ _ (LitAlt l)   = literalFReft l+altReft γ acs DEFAULT    = mconcat [notLiteralReft l | LitAlt l <- acs]+  where notLiteralReft   = maybe mempty F.notExprReft . snd . literalConst (emb γ)+altReft _ _ _            = panic Nothing "Constraint : altReft"++unfoldR td (RApp _ ts rs _) ys = (t3, tvys ++ yts, ignoreOblig rt)+  where+        tbody              = instantiatePvs (instantiateTys td ts) $ reverse rs+        (ys0, yts', _, rt) = safeBkArrow $ instantiateTys tbody tvs'+        yts''              = zipWith F.subst sus (yts'++[rt])+        (t3,yts)           = (last yts'', init yts'')+        sus                = F.mkSubst <$> (L.inits [(x, F.EVar y) | (x, y) <- zip ys0 ys'])+        (αs, ys')          = mapSnd (F.symbol <$>) $ L.partition isTyVar ys+        tvs'               = rVar <$> αs+        tvys               = ofType . varType <$> αs++unfoldR _  _                _  = panic Nothing "Constraint.hs : unfoldR"++instantiateTys = L.foldl' go+  where go (RAllT α tbody) t = subsTyVar_meet' (α, t) tbody+        go _ _               = panic Nothing "Constraint.instanctiateTy"++instantiatePvs = L.foldl' go+  where go (RAllP p tbody) r = replacePreds "instantiatePv" tbody [(p, r)]+        go _ _               = panic Nothing "Constraint.instanctiatePv"++checkTyCon _ t@(RApp _ _ _ _) = t+checkTyCon x t                = checkErr x t++checkFun _ t@(RFun _ _ _ _)   = t+checkFun x t                  = checkErr x t++checkAll _ t@(RAllT _ _)      = t+checkAll x t                  = checkErr x t++checkErr (msg, e) t          = panic Nothing $ msg ++ showPpr e ++ ", type: " ++ showpp t++varAnn γ x t+  | x `S.member` recs γ      = AnnLoc (getSrcSpan x)+  | otherwise                = AnnUse t++-----------------------------------------------------------------------+-- | Helpers: Creating Fresh Refinement -------------------------------+-----------------------------------------------------------------------++freshPredRef :: CGEnv -> CoreExpr -> PVar RSort -> CG SpecProp+freshPredRef γ e (PV _ (PVProp τ) _ as)+  = do t    <- freshTy_type PredInstE e (toType τ)+       args <- mapM (\_ -> fresh) as+       let targs = [(x, s) | (x, (s, y, z)) <- zip args as, (F.EVar y) == z ]+       γ' <- foldM (++=) γ [("freshPredRef", x, ofRSort τ) | (x, τ) <- targs]+       addW $ WfC γ' t+       return $ RProp targs t++freshPredRef _ _ (PV _ PVHProp _ _)+  = todo Nothing "EFFECTS:freshPredRef"++--------------------------------------------------------------------------------+-- | Helpers: Creating Refinement Types For Various Things ---------------------+--------------------------------------------------------------------------------++argExpr :: CGEnv -> CoreExpr -> Maybe F.Expr+argExpr _ (Var vy)    = Just $ F.eVar vy+argExpr γ (Lit c)     = snd  $ literalConst (emb γ) c+argExpr γ (Tick _ e)  = argExpr γ e+argExpr _ _           = Nothing+++--------------------------------------------------------------------------------+(??=) :: (?callStack :: CallStack) => CGEnv -> Var -> CG SpecType+--------------------------------------------------------------------------------+γ ??= x = case M.lookup x' (lcb γ) of+            Just e  -> consE (γ -= x') e+            Nothing -> refreshTy tx+          where+            x' = F.symbol x+            tx = fromMaybe tt (γ ?= x')+            tt = ofType $ varType x+++--------------------------------------------------------------------------------+varRefType :: (?callStack :: CallStack) => CGEnv -> Var -> CG SpecType+--------------------------------------------------------------------------------+varRefType γ x = do+  xt <- varRefType' γ x <$> (γ ??= x)+  return xt -- 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+  = tr `strengthenS` xr+  | otherwise+  = t' `strengthenS` xr+  where+    xr = singletonReft (M.lookup x $ aenv γ) x+    x' = F.symbol x++singletonReft (Just x) _ = uTop $ F.symbolReft x+singletonReft Nothing  v = uTop $ F.symbolReft $ F.symbol v++-- | RJ: `nomeet` replaces `strengthenS` for `strengthen` in the definition+--   of `varRefType`. Why does `tests/neg/strata.hs` fail EVEN if I just replace+--   the `otherwise` case? The fq file holds no answers, both are sat.+strengthenS :: (PPrint r, F.Reftable r) => RType c tv r -> r -> RType c tv r+strengthenS (RApp c ts rs r) r'  = RApp c ts rs $ topMeet r r'+strengthenS (RVar a r) r'        = RVar a       $ topMeet r r'+strengthenS (RFun b t1 t2 r) r'  = RFun b t1 t2 $ topMeet r r'+strengthenS (RAppTy t1 t2 r) r'  = RAppTy t1 t2 $ topMeet r r'+strengthenS t _                  = t++topMeet :: (PPrint r, F.Reftable r) => r -> r -> r+topMeet r r' = {- F.tracepp msg $ -} F.top r `F.meet` r'+  -- where+    -- msg = printf "topMeet r = [%s] r' = [%s]" (showpp r) (showpp r')++  -- traceM $ printf "cconsE:\n  expr = %s\n  exprType = %s\n  lqType = %s\n" (showPpr e) (showPpr (exprType e)) (showpp t)+--------------------------------------------------------------------------------+-- | Cleaner Signatures For Rec-bindings ---------------------------------------+--------------------------------------------------------------------------------++exprLoc                         :: CoreExpr -> Maybe SrcSpan++exprLoc (Tick tt _)             = Just $ tickSrcSpan tt+exprLoc (App e a) | isType a    = exprLoc e+exprLoc _                       = Nothing++isType (Type _)                 = True+isType a                        = eqType (exprType a) predType+++exprRefType :: CoreExpr -> SpecType+exprRefType = exprRefType_ M.empty++exprRefType_ :: M.HashMap Var SpecType -> CoreExpr -> SpecType+exprRefType_ γ (Let b e)+  = exprRefType_ (bindRefType_ γ b) e++exprRefType_ γ (Lam α e) | isTyVar α+  = RAllT (rTyVar α) (exprRefType_ γ e)++exprRefType_ γ (Lam x e)+  = rFun (F.symbol x) (ofType $ varType x) (exprRefType_ γ e)++exprRefType_ γ (Tick _ e)+  = exprRefType_ γ e++exprRefType_ γ (Var x)+  = M.lookupDefault (ofType $ varType x) x γ++exprRefType_ _ e+  = ofType $ exprType e++bindRefType_ γ (Rec xes)+  = extendγ γ [(x, exprRefType_ γ e) | (x,e) <- xes]++bindRefType_ γ (NonRec x e)+  = extendγ γ [(x, exprRefType_ γ e)]++extendγ γ xts+  = foldr (\(x,t) m -> M.insert x t m) γ xts++isGeneric :: RTyVar -> SpecType -> Bool+isGeneric α t =  all (\(c, α') -> (α'/=α) || isOrd c || isEq c ) (classConstrs t)+  where classConstrs t = [(c, α') | (c, ts) <- tyClasses t+                                  , t'      <- ts+                                  , α'      <- freeTyVars t']+        isOrd          = (ordClassName ==) . className+        isEq           = (eqClassName ==) . className
+ src/Language/Haskell/Liquid/Constraint/Monad.hs view
@@ -0,0 +1,154 @@+-- | 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+++-- import           Text.PrettyPrint.HughesPJ hiding (first)+import           Prelude hiding (error)+-- import qualified TyCon  as TC+import           Var+import           Name (getSrcSpan)+import           SrcLoc -- (SrcSpan)+import           Outputable hiding (showPpr, panic) -- (SrcSpan)++++import qualified Data.HashMap.Strict as M+-- import qualified Data.HashSet        as S+import qualified Data.Text           as T+-- import qualified Data.List           as L++-- import           Data.Maybe          (fromMaybe) -- catMaybes, fromJust, isJust)+import           Control.Monad+import           Control.Monad.State (get, modify)+-- import qualified Language.Fixpoint.Types            as F+import           Language.Haskell.Liquid.Types hiding (loc)+-- import           Language.Haskell.Liquid.Types.Variance++-- import           Language.Haskell.Liquid.Types.Strata+import           Language.Haskell.Liquid.Constraint.Types+import           Language.Haskell.Liquid.Constraint.Env+-- import           Language.Haskell.Liquid.Constraint.Fresh+-- import           Language.Haskell.Liquid.Types.PredType         hiding (freeTyVars)+-- import           Language.Haskell.Liquid.Types.RefType+import           Language.Fixpoint.Misc hiding (errorstar)+-- import           Language.Haskell.Liquid.Misc -- (concatMapM)+import           Language.Haskell.Liquid.GHC.Misc -- (concatMapM)+import           Language.Haskell.Liquid.Types.RefType++++++--------------------------------------------------------------------------------+-- RJ: What is this `isBind` business?+--------------------------------------------------------------------------------+pushConsBind :: CG a -> CG a+--------------------------------------------------------------------------------+pushConsBind act+  = do modify $ \s -> s { isBind = False : isBind s }+       z <- act+       modify $ \s -> s { isBind = tail (isBind s) }+       return z++--------------------------------------------------------------------------------+-- | `addC` adds a subtyping constraint into the global pool.+--------------------------------------------------------------------------------+addC :: SubC -> String -> CG ()+--------------------------------------------------------------------------------+addC c@(SubC γ t1 t2) _msg+  | toType t1 /= toType t2+  = panic Nothing $ "addC: malformed constraint:\n" ++ showpp t1 ++ "\n <: \n" ++ showpp t2+  | otherwise+  = do modify $ \s -> s { hsCs  = c : (hsCs s) }+       bflag <- headDefault True . isBind <$> get+       sflag <- scheck                 <$> get+       if bflag && sflag+         then modify $ \s -> s {sCs = (SubC γ t2 t1) : (sCs s) }+         else return ()+  where+    headDefault a []    = a+    headDefault _ (x:_) = x++addC c _msg+  = modify $ \s -> s { hsCs  = c : hsCs s }+++--------------------------------------------------------------------------------+-- | addPost: RJ: what DOES this function do?+--------------------------------------------------------------------------------+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" >> return t++addPost γ (RRTy e r OTerm t)+  = do γ' <- foldM (\γ (x, t) -> γ ++= ("addPost", x,t)) γ e+       addC (SubR γ' OTerm r) "precondition" >> return t++addPost _ (RRTy _ _ OCons t)+  = return t++addPost _ t+  = return t++--------------------------------------------------------------------------------+-- | Add Well formedness Constraint+--------------------------------------------------------------------------------+addW   :: WfC -> CG ()+--------------------------------------------------------------------------------+addW !w = modify $ \s -> s { hsWfs = w : (hsWfs s) }++--------------------------------------------------------------------------------+-- | Add a warning+--------------------------------------------------------------------------------+addWarning   :: Error -> CG ()+--------------------------------------------------------------------------------+addWarning w = modify $ \s -> s { logErrors = w : logErrors s }++-- | Add Identifier Annotations, used for annotation binders (i.e. at binder sites)+addIdA            :: Var -> Annot SpecType -> CG ()+addIdA !x !t      = modify $ \s -> s { annotMap = upd $ annotMap s }+  where+    l             = getSrcSpan x+    upd m@(AI _)  = if boundRecVar l m then m else addA l (Just x) t m++boundRecVar :: SrcSpan -> AnnInfo (Annot a) -> Bool+boundRecVar l (AI m) = not $ null [t | (_, AnnRDf t) <- M.lookupDefault [] l m]+++-- | Used for annotating reads (i.e. at Var x sites)++addLocA :: Maybe Var -> SrcSpan -> Annot SpecType -> CG ()+addLocA !xo !l !t+  = modify $ \s -> s { annotMap = addA l xo t $ annotMap s }+++--------------------------------------------------------------------------------+-- | Update annotations for a location, due to (ghost) predicate applications+--------------------------------------------------------------------------------+updateLocA :: Maybe SrcSpan -> SpecType -> CG ()+--------------------------------------------------------------------------------+updateLocA (Just l) t = addLocA Nothing l (AnnUse t)+updateLocA _        _ = return ()+--------------------------------------------------------------------------------++--------------------------------------------------------------------------------+addA :: (Outputable a) => SrcSpan -> Maybe a -> b -> AnnInfo b -> AnnInfo b+--------------------------------------------------------------------------------+addA !l xo@(Just _) !t (AI m)+  | isGoodSrcSpan l+  = AI $ inserts l (T.pack . showPpr <$> xo, t) m+addA !l xo@Nothing  !t (AI m)+  | l `M.member` m                  -- only spans known to be variables+  = AI $ inserts l (T.pack . showPpr <$> xo, t) m+addA _ _ _ !a+  = a
+ src/Language/Haskell/Liquid/Constraint/ProofToCore.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE FlexibleContexts     #-}++module Language.Haskell.Liquid.Constraint.ProofToCore where++import Prelude hiding (error)+import CoreSyn hiding (Expr, Var)+import qualified CoreSyn as H+import Language.Haskell.Liquid.Types.Errors++import Var hiding (Var)++import CoreUtils++import Type hiding (Var)+import TypeRep++import Language.Haskell.Liquid.GHC.Misc+import Language.Haskell.Liquid.WiredIn++++import Language.Haskell.Liquid.Prover.Types+import Language.Haskell.Liquid.Transforms.CoreToLogic ()+import qualified Data.List as L+import Data.Maybe (fromMaybe)++type HId       = Id+type HVar      = Var      HId+type HAxiom    = Axiom    HId+type HCtor     = Ctor     HId+type HVarCtor  = VarCtor     HId+type HQuery    = Query    HId+type HInstance = Instance HId+type HProof    = Proof    HId+type HExpr     = Expr     HId++type CmbExpr = CoreExpr -> CoreExpr -> CoreExpr++class ToCore a where+  toCore :: CmbExpr -> CoreExpr -> a -> CoreExpr++instance ToCore HInstance where+  toCore c e i = makeApp (toCore c e $ inst_axiom i) (toCore c e <$> inst_args i)++instance ToCore HProof where+  toCore _ e Invalid = e+  toCore c e p       = combineProofs c e $ (toCore c e <$> p_evidence p)++instance ToCore HAxiom where+  toCore c e a = toCore c e $ axiom_name a++instance ToCore HExpr  where+  toCore c e (EVar v)    = toCore c e v+  toCore c' e (EApp c es) = makeApp (toCore c' e c) (toCore c' e <$> es)++instance ToCore HCtor where+  toCore c' e c =  toCore c' e $ ctor_expr c++instance ToCore HVar where+  toCore _ _ v = H.Var $ var_info v+++-------------------------------------------------------------------------------+----------------  Combining Proofs --------------------------------------------+-------------------------------------------------------------------------------++-- | combineProofs :: combinator -> default expressions -> list of proofs+-- |               -> combined result++combineProofs :: CmbExpr -> CoreExpr -> [CoreExpr] -> CoreExpr+combineProofs _ e []  =  e+combineProofs c _ es = foldl (flip Let) (combine [1..] c (H.Var v) (H.Var <$> vs)) (bs ++ [dictionaryBind])+    where+      (v:vs, bs) = unzip [let v = (varANF i (exprType e)) in (v, NonRec v e)+                              | (e, i) <- zip es [1..] ]++combine _ _ e []             = e+combine _ c e' [e]           = c e' e+combine (i:uniq) c e' (e:es) = Let (NonRec v (c e' e)) (combine uniq c (H.Var v) es)+  where+     v = varCombine i (exprType $ c e' e)+combine _ _ _ _              = impossible Nothing err -- TODO: Does this case have a+   where                                              -- sane implementation?+     err = "Language.Haskell.Liquid.Constraint.ProofToCore.combine called with"+           ++ " empty first argument and non-empty fourth argument. This should"+           ++ " never happen!"+++-------------------------------------------------------------------------------+----------------  make Application --------------------------------------------+-------------------------------------------------------------------------------++++-- | To make application we need to instantiate expressions irrelevant to logic+-- | type application and dictionaries.+-- | Then, ANF the final expression++makeApp :: CoreExpr -> [CoreExpr] -> CoreExpr+makeApp f es = foldl (flip Let) (foldl App f' (reverse es')) (reverse  bs)+  where+   vts      = resolveVs as $ zip (dropWhile isClassPred ts) (exprType <$> es)+   (as, ts) = bkArrow (exprType f)+   f'       = instantiateVars vts f+   ds       = makeDictionaries dictionaryVar f'+   (bs, es', _) = foldl anf ([], [], [1..]) (ds ++ (instantiateVars vts <$> es))+++instance Show Type where+  show (TyVarTy v) = show $ tvId v+  show t           = showPpr t++-- | ANF+anf :: ([CoreBind], [CoreExpr], [Int]) -> CoreExpr -> ([CoreBind], [CoreExpr], [Int])+anf (bs, es, i:uniq) (App f e) = ((NonRec v (App f e')):(bs++bs'), H.Var v:es, uniq')+  where v = varANFPr i (exprType $ App f e)+        (bs', [e'], uniq') = anf ([], [], uniq) e++anf (bs, es, uniq) e = (bs, e:es, uniq)++-- | Filling up dictionaries+makeDictionaries dname e = go (exprType e)+  where+    go (ForAllTy _ t) = go t+    go (FunTy tx t  ) | isClassPred tx = (makeDictionary dname tx):go t+    go _              = []++makeDictionary dname t = App (H.Var dname) (Type t)++-- | Filling up types+instantiateVars vts e = go e (exprType e)+  where+    go e (ForAllTy a t) = go (App e (Type $ fromMaybe (TyVarTy a) $ L.lookup a vts)) t+    go e _              = e++resolveVs :: [Id] -> [(Type, Type)] -> [(Id, Type)]+resolveVs as  ts = go as ts+  where+    go _   []                                     = []+    go fvs ((ForAllTy v t1, t2):ts)               = go (v:fvs) ((t1, t2):ts)+    go fvs ((t1, ForAllTy v t2):ts)               = go (v:fvs) ((t1, t2):ts)+    go fvs ((FunTy t1 t2, FunTy t1' t2'):ts)      = go fvs ((t1, t1'):(t2, t2'):ts)+    go fvs ((AppTy t1 t2, AppTy t1' t2'):ts)      = go fvs ((t1, t1'):(t2, t2'):ts)+    go fvs ((TyVarTy a, TyVarTy a'):ts) | a == a' = go fvs ts+    go fvs ((TyVarTy a, t):ts) | a `elem` fvs     = let vts = (go fvs (substTyV (a, t) <$> ts)) in (a, resolveVar a t vts) : vts+    go fvs ((t, TyVarTy a):ts) | a `elem` fvs     = let vts = (go fvs (substTyV (a, t) <$> ts)) in (a, resolveVar a t vts) : vts+    go fvs ((TyConApp _ cts,TyConApp _ cts'):ts)  = go fvs (zip cts cts' ++ ts)+    go fvs ((LitTy _, LitTy _):ts)                = go fvs ts+    go _   (tt:_)                                 = panic Nothing $ ("cannot resolve " ++ show tt ++ (" for ") ++ show ts)++resolveVar _ t [] = t+resolveVar a t ((a', t'):ats)+  | a == a'           = resolveVar a' t' ats+  | TyVarTy a'' <- t' = resolveVar a'' t' ats+  | otherwise         = resolveVar a t ats+++substTyV :: (Id, Type) -> (Type, Type) -> (Type, Type)+substTyV (a, at) (t1, t2) = (go t1, go t2)+  where+    go (ForAllTy a' t) | a == a'   = ForAllTy a' t+                       | otherwise = ForAllTy a' (go t)+    go (FunTy t1 t2)   = FunTy (go t1) (go t2)+    go (AppTy t1 t2)   = AppTy (go t1) (go t2)+    go (TyConApp c ts) = TyConApp c (go <$> ts)+    go (LitTy l)       = LitTy l+    go (TyVarTy v)     | v == a    = at+                       | otherwise = TyVarTy v+++-------------------------------------------------------------------------------+-------------------------  HELPERS --------------------------------------------+-------------------------------------------------------------------------------++varCombine i = stringVar ("proof_anf_cmb"  ++ show i)+varANF     i = stringVar ("proof_anf_bind" ++ show i)+varANFPr   i = stringVar ("proof_anf_bind_pr" ++ show i)++bkArrow = go [] []+  where+    go vs ts (ForAllTy v t) = go (v:vs) ts t+    go vs ts (FunTy tx t)   = go vs (tx:ts) t+    go vs ts _              = (reverse vs, reverse ts)
+ src/Language/Haskell/Liquid/Constraint/Qualifier.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ViewPatterns          #-}+{-# LANGUAGE PartialTypeSignatures #-}++module Language.Haskell.Liquid.Constraint.Qualifier (+  specificationQualifiers+  ) where++import TyCon++import Prelude hiding (error)++import Language.Haskell.Liquid.Bare+import Language.Haskell.Liquid.Types.RefType+import Language.Haskell.Liquid.GHC.Misc  (getSourcePos)+import Language.Haskell.Liquid.Types.PredType+import Language.Haskell.Liquid.Types+import Language.Fixpoint.Types++++-- import Control.Applicative      ((<$>))+import Data.List                (delete, nub)+import Data.Maybe               (catMaybes, fromMaybe)+import qualified Data.HashSet as S+-- import Data.Bifunctor           (second)+import Debug.Trace++-----------------------------------------------------------------------------------+specificationQualifiers :: Int -> GhcInfo -> SEnv Sort -> [Qualifier]+-----------------------------------------------------------------------------------+specificationQualifiers k info lEnv+  = [ q | (x, t) <- (tySigs $ spec info) ++ (asmSigs $ spec info) ++ (inSigs $ spec info) ++ (ctors $ spec info)+        , x `S.member` (S.fromList $ defVars 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`+                                     if info `hasOpt` scrapeUsedImports+                                     then useVars info+                                     else if info `hasOpt` scrapeImports+                                     then impVars info+                                     else [])+        , q <- refTypeQuals lEnv (getSourcePos x) (tcEmbeds $ spec info) (val t)+        -- NOTE: large qualifiers are VERY expensive, so we only mine+        -- qualifiers up to a given size, controlled with --max-params+        , length (q_params q) <= k + 1+    ]+    -- where lEnv = trace ("Literals: " ++ show lEnv') lEnv'++-- GRAVEYARD: scraping quals from imports kills the system with too much crap+-- specificationQualifiers info = {- filter okQual -} qs+--   where+--     qs                       = concatMap refTypeQualifiers ts+--     refTypeQualifiers        = refTypeQuals $ tcEmbeds spc+--     ts                       = val <$> t1s ++ t2s+--     t1s                      = [t | (x, t) <- tySigs spc, x `S.member` definedVars]+--     t2s                      = [] -- [t | (_, t) <- ctor spc                            ]+--     definedVars              = S.fromList $ defVars info+--     spc                      = spec info+--+-- okQual                       = not . any isPred . map snd . q_params+--   where+--     isPred (FApp tc _)       = tc == stringFTycon "Pred"+--     isPred _                 = False+++-- TODO: rewrite using foldReft'+-- refTypeQuals :: SpecType -> [Qualifier]+refTypeQuals :: SEnv Sort -> SourcePos -> TCEmb TyCon -> SpecType -> [Qualifier]+refTypeQuals lEnv l tce t0    = go emptySEnv t0+  where+    scrape                    = refTopQuals lEnv l tce t0+    add x t γ                 = insertSEnv x (rTypeSort tce t) γ+    goBind x t γ t'           = go (add x t γ) t'+    go γ t@(RVar _ _)         = scrape γ t+    go γ (RAllT _ t)          = go γ t+    go γ (RAllP p t)          = go (insertSEnv (pname p) (rTypeSort tce $ (pvarRType p :: RSort)) γ) t+    go γ t@(RAppTy t1 t2 _)   = go γ t1 ++ go γ t2 ++ scrape γ t+    go γ (RFun x t t' _)      = go γ t ++ goBind x t γ t'+    go γ t@(RApp c ts rs _)   = scrape γ t ++ concatMap (go γ') ts ++ goRefs c γ' rs+                                where γ' = add (rTypeValueVar t) t γ+    go γ (RAllE x t t')       = go γ t ++ goBind x t γ t'+    go γ (REx x t t')         = go γ t ++ goBind x t γ t'+    go _ _                    = []+    goRefs c g rs             = concat $ zipWith (goRef g) rs (rTyConPVs c)+    goRef _ (RProp _ (RHole _)) _ = []+    goRef g (RProp s t)  _    = go (insertsSEnv g s) t+    insertsSEnv               = foldr (\(x, t) γ -> insertSEnv x (rTypeSort tce t) γ)++refTopQuals lEnv l tce t0 γ t+  = [ mkQ v so pa  | let (RR so (Reft (v, ra))) = rTypeSortedReft tce t+                                  , pa                        <- conjuncts ra+                                  , not $ isHole pa+    ]+    +++    [ mkP s e | let (MkUReft _ (Pr ps) _) = fromMaybe (msg t) $ stripRTypeBase t+                             , p <- findPVar (ty_preds $ toRTypeRep t0) <$> ps+                             , (s, _, e) <- pargs p+    ]+    where+      mkQ   = mkQual  lEnv l     t0 γ+      mkP   = mkPQual lEnv l tce t0 γ+      msg t = panic Nothing $ "Qualifier.refTopQuals: no typebase" ++ showpp t++mkPQual lEnv l tce t0 γ t e = mkQual lEnv l t0 γ' v so pa+  where+    v                  = "vv"+    so                 = rTypeSort tce t+    γ'                 = insertSEnv v so γ+    pa                 = PAtom Eq (EVar v) e++mkQual = mkQualNEW++mkQualNEW lEnv l _ γ v so p   = Q "Auto" ((v, so) : xts) p l+  where+    xs   = delete v $ nub $ syms p+    xts = catMaybes $ zipWith (envSort l lEnv γ) xs [0..]+    -- xts  = Language.Fixpoint.Misc.traceShow msg $ xts'+    -- msg  = "Free Vars in: " ++ showFix p ++ " in " ++ show t0++-- OLD+{-+  TODO: If it's so OLD, do we need to keep it? Never called, etc...+mkQualOLD lEnv l t0 γ v so p   = Q "Auto" ((v, so) : yts) p' l+  where+    yts                = [(y, lookupSort l γ i x) | (x, i, y) <- xys ]+    p'                 = subst su p+    su                 = mkSubst [(x, EVar y) | (x, _, y) <- xys]+    xys                = zipWith (\x i -> (x, i, symbol ("~A" ++ show i))) xs [0..]+    -- xs                 = delete v $ orderedFreeVars γ p+    xs                 = {- Language.Fixpoint.Misc.traceShow msg $ -} delete v $ orderedFreeVarsOLD γ p+    msg                = "Free Vars in: " ++ showFix p ++ " in " ++ show t0++orderedFreeVarsOLD :: SEnv Sort -> Pred -> [Symbol]+orderedFreeVarsOLD γ = nub . filter (`memberSEnv` γ) . syms+-}++{-+   TODO: Never used, do I need to exist?+orderedFreeVars :: SEnv Sort -> Pred -> [Symbol]+orderedFreeVars lEnv = nub . filter (not . (`memberSEnv` lEnv)) . syms+-}++envSort :: SourcePos -> SEnv Sort -> SEnv Sort -> Symbol -> Integer -> Maybe (Symbol, Sort)+envSort l lEnv tEnv x i+  | Just t <- lookupSEnv x tEnv = Just (x, t)+  | Just _ <- lookupSEnv x lEnv = Nothing+  | otherwise                   = Just (x, ai)+  where+    ai             = trace msg $ fObj $ Loc l l $ tempSymbol "LHTV" i+    msg            = "unknown symbol in qualifier: " ++ show x++{-+   TODO: Never used, do I need to exist?+lookupSort l γ i x = fromMaybe ai $ lookupSEnv x γ+  where+    ai             = trace msg $ fObj $ Loc l l $ tempSymbol "LHTV" i+    msg            = "unknown symbol in qualifier: " ++ show x+-}
+ src/Language/Haskell/Liquid/Constraint/Split.hs view
@@ -0,0 +1,496 @@+{-# LANGUAGE ImplicitParams        #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}++--------------------------------------------------------------------------------+-- | Constraint Splitting ------------------------------------------------------+--------------------------------------------------------------------------------++module Language.Haskell.Liquid.Constraint.Split (++  -- * Split Subtyping Constraints+    splitC++  -- * Split Well-formedness Constraints+  , splitW++  -- * Split Strata Constraints+  , splitS++  -- * ???+  , envToSub++  -- * Panic+  , panicUnbound+  ) where++import           Prelude hiding (error)++++import           Text.PrettyPrint.HughesPJ hiding (first)+import qualified TyCon  as TC++import           Data.Maybe          (fromMaybe) -- catMaybes, fromJust, isJust)+import           Control.Monad+import           Control.Monad.State (get)+import qualified Control.Exception as Ex++import qualified Language.Fixpoint.Types            as F+import           Language.Fixpoint.Misc hiding (errorstar)+import           Language.Fixpoint.SortCheck (pruneUnsortedReft)++import           Language.Haskell.Liquid.Misc -- (concatMapM)+import qualified Language.Haskell.Liquid.UX.CTags       as Tg+import           Language.Haskell.Liquid.UX.Errors () -- CTags       as Tg+import           Language.Haskell.Liquid.Types hiding (loc)++import           Language.Haskell.Liquid.Types.Variance+import           Language.Haskell.Liquid.Types.Strata+import           Language.Haskell.Liquid.Types.PredType         hiding (freeTyVars)+import           Language.Haskell.Liquid.Types.RefType++import           Language.Haskell.Liquid.Constraint.Types+import           Language.Haskell.Liquid.Constraint.Env+import           Language.Haskell.Liquid.Constraint.Fresh+import           Language.Haskell.Liquid.Constraint.Monad+import           Language.Haskell.Liquid.Constraint.Constraint++--------------------------------------------------------------------------------+splitW ::  WfC -> CG [FixWfC]+--------------------------------------------------------------------------------+splitW (WfC γ t@(RFun x t1 t2 _))+  =  do ws   <- bsplitW γ t+        ws'  <- splitW (WfC γ t1)+        γ'   <- (γ, "splitW") += (x, t1)+        ws'' <- splitW (WfC γ' t2)+        return $ ws ++ ws' ++ ws''++splitW (WfC γ t@(RAppTy t1 t2 _))+  =  do ws   <- bsplitW γ t+        ws'  <- splitW (WfC γ t1)+        ws'' <- splitW (WfC γ t2)+        return $ ws ++ ws' ++ ws''++splitW (WfC γ (RAllT _ r))+  = splitW (WfC γ r)++splitW (WfC γ (RAllP _ r))+  = splitW (WfC γ r)++splitW (WfC γ t@(RVar _ _))+  = bsplitW γ t++splitW (WfC γ t@(RApp _ ts rs _))+  =  do ws    <- bsplitW γ t+        γ'    <- γ `extendEnvWithVV` t+        ws'   <- concat <$> mapM (splitW . WfC γ') ts+        ws''  <- concat <$> mapM (rsplitW γ)       rs+        return $ ws ++ ws' ++ ws''++splitW (WfC γ (RAllE x tx t))+  = do  ws  <- splitW (WfC γ tx)+        γ'  <- (γ, "splitW") += (x, tx)+        ws' <- splitW (WfC γ' t)+        return $ ws ++ ws'++splitW (WfC γ (REx x tx t))+  = do  ws  <- splitW (WfC γ tx)+        γ'  <- (γ, "splitW") += (x, tx)+        ws' <- splitW (WfC γ' t)+        return $ ws ++ ws'++splitW (WfC _ t)+  = panic Nothing $ "splitW cannot handle: " ++ showpp t++rsplitW _ (RProp _ (RHole _))+  = panic Nothing "Constrains: rsplitW for RProp _ (RHole _)"+rsplitW γ (RProp ss t0)+  = do γ' <- foldM (++=) γ [("rsplitW", x, ofRSort s) | (x, s) <- ss]+       splitW $ WfC γ' t0++bsplitW :: CGEnv -> SpecType -> CG [FixWfC]+bsplitW γ t =+  do pflag <- pruneRefs <$> get+     isHO  <- allowHO   <$> get+     return $ bsplitW' γ t pflag isHO++bsplitW' γ t pflag isHO+  | isHO || F.isNonTrivial r'+  = F.wfC (feBinds $ fenv γ) r' ci+  | otherwise+  = []+  where+    r'                = rTypeSortedReft' pflag γ t+    ci                = Ci (getLocation γ) Nothing++--------------------------------------------------------------------------------+splitS  :: SubC -> CG [([Stratum], [Stratum])]+bsplitS :: SpecType -> SpecType -> CG [([Stratum], [Stratum])]+--------------------------------------------------------------------------------+splitS (SubC γ (REx x _ t1) (REx x2 _ t2)) | x == x2+  = splitS (SubC γ t1 t2)++splitS (SubC γ t1 (REx _ _ t2))+  = splitS (SubC γ t1 t2)++splitS (SubC γ (REx _ _ t1) t2)+  = splitS (SubC γ t1 t2)++splitS (SubC γ (RAllE x _ t1) (RAllE x2 _ t2)) | x == x2+  = splitS (SubC γ t1 t2)++splitS (SubC γ (RAllE _ _ t1) t2)+  = splitS (SubC γ t1 t2)++splitS (SubC γ t1 (RAllE _ _ t2))+  = splitS (SubC γ t1 t2)++splitS (SubC γ (RRTy _ _ _ t1) t2)+  = splitS (SubC γ t1 t2)++splitS (SubC γ t1 (RRTy _ _ _ t2))+  = splitS (SubC γ t1 t2)++splitS (SubC γ t1@(RFun x1 r1 r1' _) t2@(RFun x2 r2 r2' _))+  =  do cs       <- bsplitS t1 t2+        cs'      <- splitS  (SubC γ r2 r1)+        γ'       <- (γ, "splitS") += (x2, r2)+        let r1x2' = r1' `F.subst1` (x1, F.EVar x2)+        cs''     <- splitS  (SubC γ' r1x2' r2')+        return    $ cs ++ cs' ++ cs''++splitS (SubC γ t1@(RAppTy r1 r1' _) t2@(RAppTy r2 r2' _))+  =  do cs    <- bsplitS t1 t2+        cs'   <- splitS  (SubC γ r1 r2)+        cs''  <- splitS  (SubC γ r1' r2')+        cs''' <- splitS  (SubC γ r2' r1')+        return $ cs ++ cs' ++ cs'' ++ cs'''++splitS (SubC γ t1 (RAllP p t))+  = splitS $ SubC γ t1 t'+  where+    t' = fmap (replacePredsWithRefs su) t+    su = (uPVar p, pVartoRConc p)++splitS (SubC _ t1@(RAllP _ _) t2)+  = panic Nothing $ "Predicate in lhs of constrain:" ++ showpp t1 ++ "\n<:\n" ++ showpp t2++splitS (SubC γ (RAllT α1 t1) (RAllT α2 t2))+  |  α1 ==  α2+  = splitS $ SubC γ t1 t2+  | otherwise+  = splitS $ SubC γ t1 t2'+  where t2' = subsTyVar_meet' (α2, RVar α1 mempty) t2++splitS (SubC _ (RApp c1 _ _ _) (RApp c2 _ _ _)) | isClass c1 && c1 == c2+  = return []+++splitS (SubC γ t1@(RApp {}) t2@(RApp {}))+  = do (t1',t2') <- unifyVV t1 t2+       cs    <- bsplitS t1' t2'+       γ'    <- γ `extendEnvWithVV` t1'+       let RApp c t1s r1s _ = t1'+       let RApp _ t2s r2s _ = t2'+       let isapplied = TC.tyConArity (rtc_tc c) == length t1s+       let tyInfo = rtc_info c+       csvar  <-  splitsSWithVariance           γ' t1s t2s $ varianceTyArgs tyInfo+       csvar' <- rsplitsSWithVariance isapplied γ' r1s r2s $ variancePsArgs tyInfo+       return $ cs ++ csvar ++ csvar'++splitS (SubC _ t1@(RVar a1 _) t2@(RVar a2 _))+  | a1 == a2+  = bsplitS t1 t2++splitS (SubC _ t1 t2)+  = panic Nothing $ "(Another Broken Test1!!!) splitS unexpected: " ++ showpp t1 ++ "\n\n" ++ showpp t2++splitS (SubR _ _ _)+  = return []++splitsSWithVariance γ t1s t2s variants+  = concatMapM (\(t1, t2, v) -> splitfWithVariance (\s1 s2 -> splitS (SubC γ s1 s2)) t1 t2 v) (zip3 t1s t2s variants)++rsplitsSWithVariance False _ _ _ _+  = return []++rsplitsSWithVariance _ γ t1s t2s variants+  = concatMapM (\(t1, t2, v) -> splitfWithVariance (rsplitS γ) t1 t2 v) (zip3 t1s t2s variants)++bsplitS t1 t2+  = return $ [(s1, s2)]+  where [s1, s2]   = getStrata <$> [t1, t2]++rsplitS _ (RProp _ (RHole _)) _+   = panic Nothing "rsplitS RProp _ (RHole _)"++rsplitS _ _ (RProp _ (RHole _))+   = panic Nothing "rsplitS RProp _ (RHole _)"++rsplitS γ (RProp s1 r1) (RProp s2 r2)+  = splitS (SubC γ (F.subst su r1) r2)+  where su = F.mkSubst [(x, F.EVar y) | ((x,_), (y,_)) <- zip s1 s2]++splitfWithVariance f t1 t2 Invariant     = (++) <$> f t1 t2 <*> f t2 t1+splitfWithVariance f t1 t2 Bivariant     = (++) <$> f t1 t2 <*> f t2 t1+splitfWithVariance f t1 t2 Covariant     = f t1 t2+splitfWithVariance f t1 t2 Contravariant = f t2 t1+++------------------------------------------------------------+splitC :: SubC -> CG [FixSubC]+------------------------------------------------------------++splitC (SubC γ (REx x tx t1) (REx x2 _ t2)) | x == x2+  = do γ' <- (γ, "addExBind 0") += (x, forallExprRefType γ tx)+       splitC (SubC γ' t1 t2)++splitC (SubC γ t1 (REx x tx t2))+  = do y <- fresh+       γ' <- (γ, "addExBind 1") += (y, forallExprRefType γ tx)+       splitC (SubC γ' t1 (F.subst1 t2 (x, F.EVar y)))++-- existential at the left hand side is treated like forall+splitC (SubC γ (REx x tx t1) t2)+  = do -- let tx' = traceShow ("splitC: " ++ showpp z) tx+       y <- fresh+       γ' <- (γ, "addExBind 2") += (y, forallExprRefType γ tx)+       splitC (SubC γ' (F.subst1 t1 (x, F.EVar y)) t2)++splitC (SubC γ (RAllE x tx t1) (RAllE x2 _ t2)) | x == x2+  = do γ' <- (γ, "addAllBind 0") += (x, forallExprRefType γ tx)+       splitC (SubC γ' t1 t2)++splitC (SubC γ (RAllE x tx t1) t2)+  = do y  <- fresh+       γ' <- (γ, "addAABind 1") += (y, forallExprRefType γ tx)+       splitC (SubC γ' (t1 `F.subst1` (x, F.EVar y)) t2)++splitC (SubC γ t1 (RAllE x tx t2))+  = do y  <- fresh+       γ' <- (γ, "addAllBind 2") += (y, forallExprRefType γ tx)+       splitC (SubC γ' t1 (F.subst1 t2 (x, F.EVar y)))++splitC (SubC γ (RRTy env _ OCons t1) t2)+  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ xts+       c1 <- splitC (SubC γ' t1' t2')+       c2 <- splitC (SubC γ  t1  t2 )+       return $ c1 ++ c2+  where+    (xts, t1', t2') = envToSub env++splitC (SubC γ (RRTy e r o t1) t2)+  = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ e+       c1 <- splitC (SubR γ' o  r)+       c2 <- splitC (SubC γ t1 t2)+       return $ c1 ++ c2++splitC (SubC γ t1@(RFun x1 r1 r1' _) t2@(RFun x2 r2 r2' _))+  =  do cs       <- bsplitC γ t1 t2+        cs'      <- splitC  (SubC γ r2 r1)+        γ'       <- (γ, "splitC") += (x2, r2)+        let r1x2' = r1' `F.subst1` (x1, F.EVar x2)+        cs''     <- splitC  (SubC γ' r1x2' r2')+        return    $ cs ++ cs' ++ cs''++splitC (SubC γ t1@(RAppTy r1 r1' _) t2@(RAppTy r2 r2' _))+  =  do cs    <- bsplitC γ t1 t2+        cs'   <- splitC  (SubC γ r1 r2)+        cs''  <- splitC  (SubC γ r1' r2')+        cs''' <- splitC  (SubC γ r2' r1')+        return $ cs ++ cs' ++ cs'' ++ cs'''++splitC (SubC γ t1 (RAllP p t))+  = splitC $ SubC γ t1 t'+  where+    t' = fmap (replacePredsWithRefs su) t+    su = (uPVar p, pVartoRConc p)++splitC (SubC γ t1@(RAllP _ _) t2)+  = panic (Just $ getLocation γ) $ "Predicate in lhs of constraint:" ++ showpp t1 ++ "\n<:\n" ++ showpp t2++splitC (SubC γ (RAllT α1 t1) (RAllT α2 t2))+  |  α1 ==  α2+  = splitC $ SubC γ t1 t2+  | otherwise+  = splitC $ SubC γ t1 t2'+  where t2' = subsTyVar_meet' (α2, RVar α1 mempty) t2+++splitC (SubC _ (RApp c1 _ _ _) (RApp c2 _ _ _)) | isClass c1 && c1 == c2+  = return []++splitC (SubC γ t1@(RApp _ _ _ _) t2@(RApp _ _ _ _))+  = do (t1',t2') <- unifyVV t1 t2+       cs    <- bsplitC γ t1' t2'+       γ'    <- γ `extendEnvWithVV` t1'+       let RApp c t1s r1s _ = t1'+       let RApp _ t2s r2s _ = t2'+       let isapplied = True -- TC.tyConArity (rtc_tc c) == length t1s+       let tyInfo = rtc_info c+       csvar  <-  splitsCWithVariance           γ' t1s t2s $ varianceTyArgs tyInfo+       csvar' <- rsplitsCWithVariance isapplied γ' r1s r2s $ variancePsArgs tyInfo+       return $ cs ++ csvar ++ csvar'++splitC (SubC γ t1@(RVar a1 _) t2@(RVar a2 _))+  | a1 == a2+  = bsplitC γ t1 t2++splitC (SubC _ t1 t2)+  = panic Nothing $ "(Another Broken Test!!!) splitc unexpected:\n" ++ showpp t1 ++ "\n  <:\n" ++ showpp t2++splitC (SubR γ o r)+  = do fg     <- pruneRefs <$> get+       let r1' = if fg then pruneUnsortedReft γ'' r1 else r1+       return $ F.subC γ' r1' r2 Nothing tag ci+  where+    γ'' = feEnv $ fenv γ+    γ'  = feBinds $ fenv γ+    r1  = F.RR F.boolSort rr+    r2  = F.RR F.boolSort $ F.Reft (vv, F.EVar vv)+    vv  = "vvRec"+    ci  = Ci src err+    err = Just $ ErrAssType src o (text $ show o ++ "type error") g (rHole rr)+    rr  = F.toReft r+    tag = getTag γ+    src = getLocation γ+    g   = reLocal $ renv γ++rHole :: F.Reft -> SpecType+rHole = RHole . uTop+++splitsCWithVariance γ t1s t2s variants+  = concatMapM (\(t1, t2, v) -> splitfWithVariance (\s1 s2 -> (splitC (SubC γ s1 s2))) t1 t2 v) (zip3 t1s t2s variants)++rsplitsCWithVariance False _ _ _ _+  = return []++rsplitsCWithVariance _ γ t1s t2s variants+  = concatMapM (\(t1, t2, v) -> splitfWithVariance (rsplitC γ) t1 t2 v) (zip3 t1s t2s variants)++bsplitC γ t1 t2 = do+  checkStratum γ t1 t2+  pflag  <- pruneRefs <$> get+  isHO   <- allowHO   <$> get+  let t1' = addLhsInv γ t1+  return  $ bsplitC' γ t1' t2 pflag isHO++addLhsInv :: CGEnv -> SpecType -> SpecType+addLhsInv γ t = addRTyConInv (invs γ) t `strengthen` r+  where+    r         = (mempty :: UReft F.Reft) { ur_reft = F.Reft (F.dummySymbol, p) }+    p         = constraintToLogic rE' (lcs γ)+    rE'       = insertREnv v t (renv γ)+    v         = rTypeValueVar t++     -- γ'     <- γ ++= ("bsplitC", v, t1)+       -- let r   = (mempty :: UReft F.Reft){ur_reft = F.Reft (F.dummySymbol, constraintToLogic γ' (lcs γ'))}+       -- let t1' = addRTyConInv (invs γ')  t1 `strengthen` r+       -- let F.Reft(v, _) = ur_reft (fromMaybe mempty (stripRTypeBase t1))++checkStratum γ t1 t2+  | s1 <:= s2 = return ()+  | otherwise = addWarning wrn+  where+    [s1, s2]  = getStrata <$> [t1, t2]+    wrn       =  ErrOther (getLocation γ) (text $ "Stratum Error : " ++ show s1 ++ " > " ++ show s2)++bsplitC' γ t1 t2 pflag isHO+ | isHO+ = F.subC γ' r1'  r2' Nothing tag ci+ | F.isFunctionSortedReft r1' && F.isNonTrivial r2'+ = F.subC γ' (r1' {F.sr_reft = mempty}) r2' Nothing tag ci+ | F.isNonTrivial r2'+ = F.subC γ' r1'  r2' Nothing tag ci+ | otherwise+ = []+  where+    γ'  = feBinds $ fenv γ+    r1' = rTypeSortedReft' pflag γ t1+    r2' = rTypeSortedReft' pflag γ t2+    ci  = Ci src err+    tag = getTag γ+    err = Just $ fromMaybe (ErrSubType src (text "subtype") g t1 t2) (cerr γ)+    src = getLocation γ+    g   = reLocal $ renv γ++unifyVV :: SpecType -> SpecType -> CG (SpecType, SpecType)+unifyVV t1@(RApp _ _ _ _) t2@(RApp _ _ _ _)+  = do vv     <- (F.vv . Just) <$> fresh+       return  $ (shiftVV t1 vv,  (shiftVV t2 vv) )++unifyVV _ _+  = panic Nothing $ "Constraint.Generate.unifyVV called on invalid inputs"++rsplitC _ _ (RProp _ (RHole _))+  = panic Nothing "RefTypes.rsplitC on RProp _ (RHole _)"++rsplitC _ (RProp _ (RHole _)) _+  = panic Nothing "RefTypes.rsplitC on RProp _ (RHole _)"++rsplitC γ (RProp s1 r1) (RProp s2 r2)+  = do γ'  <-  foldM (++=) γ [("rsplitC1", x, ofRSort s) | (x, s) <- s2]+       splitC (SubC γ' (F.subst su r1) r2)+  where su = F.mkSubst [(x, F.EVar y) | ((x,_), (y,_)) <- zip s1 s2]+++--------------------------------------------------------------------------------+-- | Reftypes from F.Fixpoint Expressions --------------------------------------+--------------------------------------------------------------------------------+forallExprRefType     :: CGEnv -> SpecType -> SpecType+forallExprRefType γ t = t `strengthen` (uTop r')+  where+    r'                = fromMaybe mempty $ forallExprReft γ r+    r                 = F.sr_reft $ rTypeSortedReft (emb γ) t++forallExprReft :: CGEnv -> F.Reft -> Maybe F.Reft+forallExprReft γ r =+  do e <- F.isSingletonReft r+     forallExprReft_ γ $ F.splitEApp e++forallExprReft_ :: CGEnv -> (F.Expr, [F.Expr]) -> Maybe F.Reft+forallExprReft_ γ (F.EVar x, [])+  = case forallExprReftLookup γ x of+      Just (_,_,_,t)  -> Just $ F.sr_reft $ rTypeSortedReft (emb γ) t+      Nothing         -> Nothing++forallExprReft_ γ (F.EVar f, es)+  = case forallExprReftLookup γ f of+      Just (xs,_,_,t) -> let su = F.mkSubst $ safeZip "fExprRefType" xs es in+                       Just $ F.subst su $ F.sr_reft $ rTypeSortedReft (emb γ) t+      Nothing       -> Nothing++forallExprReft_ _ _+  = Nothing++-- forallExprReftLookup :: CGEnv -> F.Symbol -> Int+forallExprReftLookup γ x = snap <$> F.lookupSEnv x (syenv γ)+  where+    snap     = mapFourth4 ignoreOblig . bkArrow . fourth4 . bkUniv . lookup+    lookup z = fromMaybe (panicUnbound γ z) (γ ?= F.symbol z)+++--------------------------------------------------------------------------------+getTag :: CGEnv -> F.Tag+--------------------------------------------------------------------------------+getTag γ = maybe Tg.defaultTag (`Tg.getTag` tgEnv γ) (tgKey γ)+++--------------------------------------------------------------------------------+{-@ envToSub :: {v:[(a, b)] | 2 <= len v} -> ([(a, b)], b, b) @-}+envToSub :: [(a, b)] -> ([(a, b)], b, b)+--------------------------------------------------------------------------------+envToSub = go []+  where+    go _   []              = impossible Nothing "This cannot happen: envToSub on 0 elems"+    go _   [(_,_)]         = impossible Nothing "This cannot happen: envToSub on 1 elem"+    go ack [(_,l), (_, r)] = (reverse ack, l, r)+    go ack (x:xs)          = go (x:ack) xs++--------------------------------------------------------------------------------+-- | Constraint Generation Panic -----------------------------------------------+--------------------------------------------------------------------------------+panicUnbound :: (PPrint x) => CGEnv -> x -> a+panicUnbound γ x = Ex.throw $ (ErrUnbound (getLocation γ) (pprint x) :: Error)
src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs view
@@ -3,48 +3,44 @@         cgInfoFInfo          ) where-+import Prelude hiding (error) import qualified Language.Fixpoint.Types        as F import Language.Haskell.Liquid.Constraint.Types  import Language.Haskell.Liquid.Types hiding     ( binds )-import Language.Fixpoint.Misc                   ( mapSnd )-import Language.Fixpoint.Interface              ( parseFInfo ) -import           Control.Applicative ((<$>))-import qualified Data.HashMap.Strict            as M+import Language.Fixpoint.Solver                 ( parseFInfo )+++ import           Data.Monoid -import Language.Haskell.Liquid.Qualifier-import Language.Haskell.Liquid.RefType          ( rTypeSortedReft )+import Language.Haskell.Liquid.Constraint.Qualifier -cgInfoFInfo :: GhcInfo -> CGInfo -> IO (F.FInfo Cinfo)-cgInfoFInfo info cgi = do-  let tgtFI = targetFInfo info cgi++cgInfoFInfo :: GhcInfo -> CGInfo -> FilePath  -> IO (F.FInfo Cinfo)+cgInfoFInfo info cgi fi = do+  let tgtFI = targetFInfo info cgi fi   impFI    <- parseFInfo $ hqFiles info   return    $ tgtFI <> impFI -targetFInfo :: GhcInfo -> CGInfo -> F.FInfo Cinfo-targetFInfo info cgi-  = F.FI { F.cm       = M.fromList $ F.addIds $ fixCs cgi-         , F.ws       = fixWfs cgi-         , F.bs       = binds cgi-         , F.gs       = F.fromListSEnv . map mkSort $ meas spc-         , F.lits     = lits cgi-         , F.kuts     = kuts cgi-         , F.quals    = targetQuals info-         , F.bindInfo = (`Ci` Nothing) <$> bindSpans cgi-         -- , F.fileName = error "FIX THIS" :: FilePath-         }-   where-    spc    = spec info-    tce    = tcEmbeds spc-    mkSort = mapSnd (rTypeSortedReft tce . val)+targetFInfo :: GhcInfo -> CGInfo -> FilePath -> F.FInfo Cinfo+targetFInfo info cgi fn = F.fi cs ws bs ls ks qs bi fn aHO +  where+   cs     = fixCs  cgi+   ws     = fixWfs cgi+   bs     = binds  cgi+   ls     = fEnv cgi+   ks     = kuts cgi+   qs     = targetQuals info cgi+   bi     = (`Ci` Nothing) <$> bindSpans cgi+   aHO    = allowHO cgi  -targetQuals :: GhcInfo -> [F.Qualifier]-targetQuals info = spcQs ++ genQs+targetQuals :: GhcInfo -> CGInfo -> [F.Qualifier]+targetQuals info cgi = spcQs ++ genQs   where     spcQs     = qualifiers spc-    genQs     = specificationQualifiers n info+    genQs     = specificationQualifiers n info (fEnv cgi)     n         = maxParams $ config spc     spc       = spec info+    -- lEnv      = F.fromListSEnv $ lits cgi
src/Language/Haskell/Liquid/Constraint/Types.hs view
@@ -1,5 +1,50 @@-module Language.Haskell.Liquid.Constraint.Types  where +{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.Haskell.Liquid.Constraint.Types+  ( -- * Constraint Generation Monad+    CG++    -- * Constraint information+  , CGInfo (..)++    -- * Constraint Generation Environment+  , CGEnv (..)++    -- * Logical constraints (FIXME: related to bounds?)+  , LConstraint (..)++    -- * Fixpoint environment+  , FEnv (..)+  , initFEnv+  , insertsFEnv++   -- * Hole Environment+  , HEnv+  , fromListHEnv+  , elemHEnv++   -- * Subtyping Constraints+  , SubC (..)+  , FixSubC++   -- * Well-formedness Constraints+  , WfC (..)+  , FixWfC++   -- * Invariants+  , RTyConInv+  , mkRTyConInv+  , addRTyConInv+  , addRInv++  -- * Aliases?+  , RTyConIAl+  , mkRTyConIAl+  ) where++import Prelude hiding (error) import CoreSyn import SrcLoc @@ -13,60 +58,76 @@ import qualified Data.HashSet        as S import qualified Data.List           as L -import Control.Applicative      ((<$>))-import Data.Monoid              (mconcat)+import Control.DeepSeq+-- import Data.Monoid              (mconcat) import Data.Maybe               (catMaybes)+import Control.Monad.State + import Var -import Language.Haskell.Liquid.Types-import Language.Haskell.Liquid.Strata-import Language.Haskell.Liquid.Misc     (fourth4)-import Language.Haskell.Liquid.RefType  (shiftVV)-import Language.Haskell.Liquid.PredType (wiredSortedSyms)+++++import Language.Haskell.Liquid.GHC.SpanStack+import Language.Haskell.Liquid.Types hiding   (binds)+import Language.Haskell.Liquid.Types.Strata+import Language.Haskell.Liquid.Misc           (fourth4)+import Language.Haskell.Liquid.Types.RefType  (shiftVV)+import Language.Haskell.Liquid.WiredIn        (wiredSortedSyms) import qualified Language.Fixpoint.Types            as F  import Language.Fixpoint.Misc -import qualified Language.Haskell.Liquid.CTags      as Tg+import qualified Language.Haskell.Liquid.UX.CTags      as Tg +type CG = State CGInfo+ data CGEnv-  = CGE { loc    :: !SrcSpan           -- ^ Location in original source file-        , renv   :: !REnv              -- ^ SpecTypes for Bindings in scope-        , syenv  :: !(F.SEnv Var)      -- ^ Map from free Symbols (e.g. datacons) to Var-        -- , penv   :: !(F.SEnv PrType)   -- ^ PrTypes for top-level bindings (merge with renv)-        , denv   :: !RDEnv             -- ^ Dictionary Environment-        , fenv   :: !FEnv              -- ^ Fixpoint Environment-        , recs   :: !(S.HashSet Var)   -- ^ recursive defs being processed (for annotations)-        , invs   :: !RTyConInv         -- ^ Datatype invariants-        , ial    :: !RTyConIAl         -- ^ Datatype checkable invariants-        , grtys  :: !REnv              -- ^ Top-level variables with (assert)-guarantees to verify-        , assms  :: !REnv              -- ^ Top-level variables with assumed types-        , emb    :: F.TCEmb TC.TyCon   -- ^ How to embed GHC Tycons into fixpoint sorts+  = CGE { cgLoc :: !SpanStack         -- ^ Location in original source file+        , renv  :: !REnv              -- ^ SpecTypes for Bindings in scope+        , syenv :: !(F.SEnv Var)      -- ^ Map from free Symbols (e.g. datacons) to Var+        , denv  :: !RDEnv             -- ^ Dictionary Environment+        , fenv  :: !FEnv              -- ^ Fixpoint Environment+        , recs  :: !(S.HashSet Var)   -- ^ recursive defs being processed (for annotations)+        , invs  :: !RTyConInv         -- ^ Datatype invariants+        , ial   :: !RTyConIAl         -- ^ Datatype checkable invariants+        , grtys :: !REnv              -- ^ Top-level variables with (assert)-guarantees to verify+        , assms :: !REnv              -- ^ Top-level variables with assumed types+        , intys :: !REnv              -- ^ Top-level variables with auto generated internal types+        , emb   :: F.TCEmb TC.TyCon   -- ^ How to embed GHC Tycons into fixpoint sorts         , tgEnv :: !Tg.TagEnv          -- ^ Map from top-level binders to fixpoint tag-        , tgKey :: !(Maybe Tg.TagKey)  -- ^ Current top-level binder+        , 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-        , holes :: !HEnv               -- ^ Types with holes, will need refreshing-        , lcs   :: !LConstraint  -- ^ Logical Constraints+        , lcb   :: !(M.HashMap F.Symbol CoreExpr)         -- ^ Let binding that have not been checked (c.f. LAZYVARs)+        , holes :: !HEnv                                  -- ^ Types with holes, will need refreshing+        , lcs   :: !LConstraint                           -- ^ Logical Constraints+        , aenv  :: !(M.HashMap Var F.Symbol)              -- ^ axiom environment maps axiomatized Haskell functions to the logical functions+        , cerr  :: !(Maybe (TError SpecType))             -- ^ error that should be reported at the user          } -- deriving (Data, Typeable) - data LConstraint = LC [[(F.Symbol, SpecType)]] +instance Monoid LConstraint where+  mempty  = LC []+  mappend (LC cs1) (LC cs2) = LC (cs1 ++ cs2) + instance PPrint CGEnv where-  pprint = pprint . renv+  pprintTidy k = pprintTidy k . renv  instance Show CGEnv where   show = showpp   -------------------------------------------------------------------------------------- Constraints: Types --------------------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- | Subtyping Constraints -----------------------------------------------------+-------------------------------------------------------------------------------- +-- RJ: what is the difference between these two?+ data SubC     = SubC { senv  :: !CGEnv                      , lhs   :: !SpecType                      , rhs   :: !SpecType@@ -83,55 +144,63 @@ type FixWfC   = F.WfC Cinfo  instance PPrint SubC where-  pprint c = pprint (senv c)-             $+$ (text " |- " <+> (pprint (lhs c) $+$-                                   text "<:"      $+$-                                   pprint (rhs c)))+  -- pprint c = pprint (senv c)+  --           $+$ (text " |- " <+> (pprint (lhs c) $+$+  --                                 text "<:"      $+$+  --                                 pprint (rhs c)))+  pprintTidy k c@(SubC {}) = pprintTidy k (senv c)+                       $+$ ("||-" <+> vcat [ pprintTidy k (lhs c)+                                           , "<:"+                                           , pprintTidy k (rhs c) ] )+  pprintTidy k c@(SubR {}) = pprintTidy k (senv c)+                       $+$ ("||-" <+> vcat [ pprintTidy k (ref c)+                                           , parens (pprintTidy k (oblig c))]) + instance PPrint WfC where-  pprint (WfC w r) = pprint w <> text " |- " <> pprint r+  pprintTidy k (WfC _ r) = {- pprintTidy k w <> text -} "<...> |-" <+> pprintTidy k r  instance SubStratum SubC where   subS su (SubC γ t1 t2) = SubC γ (subS su t1) (subS su t2)   subS _  c              = c ------------------------------------------------------------------------------------ Generation: Types --------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- | Generation: Types ---------------------------------------------------------+-------------------------------------------------------------------------------- -data CGInfo = CGInfo { hsCs       :: ![SubC]                      -- ^ subtyping constraints over RType-                     , hsWfs      :: ![WfC]                       -- ^ wellformedness constraints over RType-                     , sCs        :: ![SubC]                      -- ^ additional stratum constrains for let bindings-                     , fixCs      :: ![FixSubC]                   -- ^ subtyping over Sort (post-splitting)-                     , isBind     :: ![Bool]                      -- ^ tracks constraints that come from let-bindings-                     , fixWfs     :: ![FixWfC]                    -- ^ wellformedness constraints over Sort (post-splitting)-                     , freshIndex :: !Integer                     -- ^ counter for generating fresh KVars-                     , binds      :: !F.BindEnv                   -- ^ set of environment binders-                     , annotMap   :: !(AnnInfo (Annot SpecType))  -- ^ source-position annotation map-                     , tyConInfo  :: !(M.HashMap TC.TyCon RTyCon) -- ^ information about type-constructors-                     , specDecr   :: ![(Var, [Int])]              -- ^ ? FIX THIS-                     , termExprs  :: !(M.HashMap Var [F.Expr])    -- ^ Terminating Metrics for Recursive functions-                     , specLVars  :: !(S.HashSet Var)             -- ^ Set of variables to ignore for termination checking-                     , specLazy   :: !(S.HashSet Var)             -- ^ ? FIX THIS-                     , autoSize   :: !(S.HashSet TC.TyCon)        -- ^ ? FIX THIS-                     , tyConEmbed :: !(F.TCEmb TC.TyCon)          -- ^ primitive Sorts into which TyCons should be embedded-                     , kuts       :: !(F.Kuts)                    -- ^ Fixpoint Kut variables (denoting "back-edges"/recursive KVars)-                     , lits       :: ![(F.Symbol, F.Sort)]        -- ^ ? FIX THIS-                     , tcheck     :: !Bool                        -- ^ Check Termination (?)-                     , scheck     :: !Bool                        -- ^ Check Strata (?)-                     , trustghc   :: !Bool                        -- ^ Trust ghc auto generated bindings-                     , pruneRefs  :: !Bool                        -- ^ prune unsorted refinements-                     , logErrors  :: ![TError SpecType]           -- ^ Errors during constraint generation-                     , kvProf     :: !KVProf                      -- ^ Profiling distribution of KVars-                     , recCount   :: !Int                         -- ^ number of recursive functions seen (for benchmarks)-                     , bindSpans  :: M.HashMap F.BindId SrcSpan   -- ^ Source Span associated with Fixpoint Binder-                     }+data CGInfo = CGInfo {+    fEnv       :: !(F.SEnv F.Sort)             -- ^ top-level fixpoint env+  , hsCs       :: ![SubC]                      -- ^ subtyping constraints over RType+  , hsWfs      :: ![WfC]                       -- ^ wellformedness constraints over RType+  , sCs        :: ![SubC]                      -- ^ additional stratum constrains for let bindings+  , fixCs      :: ![FixSubC]                   -- ^ subtyping over Sort (post-splitting)+  , isBind     :: ![Bool]                      -- ^ tracks constraints that come from let-bindings+  , fixWfs     :: ![FixWfC]                    -- ^ wellformedness constraints over Sort (post-splitting)+  , freshIndex :: !Integer                     -- ^ counter for generating fresh KVars+  , binds      :: !F.BindEnv                   -- ^ set of environment binders+  , annotMap   :: !(AnnInfo (Annot SpecType))  -- ^ source-position annotation map+  , tyConInfo  :: !(M.HashMap TC.TyCon RTyCon) -- ^ information about type-constructors+  , specDecr   :: ![(Var, [Int])]              -- ^ ? FIX THIS+  , termExprs  :: !(M.HashMap Var [F.Expr])    -- ^ Terminating Metrics for Recursive functions+  , specLVars  :: !(S.HashSet Var)             -- ^ Set of variables to ignore for termination checking+  , specLazy   :: !(S.HashSet Var)             -- ^ ? FIX THIS+  , autoSize   :: !(S.HashSet TC.TyCon)        -- ^ ? FIX THIS+  , tyConEmbed :: !(F.TCEmb TC.TyCon)          -- ^ primitive Sorts into which TyCons should be embedded+  , kuts       :: !F.Kuts                      -- ^ Fixpoint Kut variables (denoting "back-edges"/recursive KVars)+  , lits       :: ![(F.Symbol, F.Sort)]        -- ^ ? FIX THIS+  , tcheck     :: !Bool                        -- ^ Check Termination (?)+  , scheck     :: !Bool                        -- ^ Check Strata (?)+  , trustghc   :: !Bool                        -- ^ Trust ghc auto generated bindings+  , pruneRefs  :: !Bool                        -- ^ prune unsorted refinements+  , logErrors  :: ![Error]                     -- ^ Errors during constraint generation+  , kvProf     :: !KVProf                      -- ^ Profiling distribution of KVars+  , recCount   :: !Int                         -- ^ number of recursive functions seen (for benchmarks)+  , bindSpans  :: M.HashMap F.BindId SrcSpan   -- ^ Source Span associated with Fixpoint Binder+  , allowHO    :: !Bool  +  }  instance PPrint CGInfo where-  pprint cgi =  {-# SCC "ppr_CGI" #-} pprCGInfo cgi+  pprintTidy _ cgi =  {-# SCC "ppr_CGI" #-} pprCGInfo cgi  pprCGInfo _cgi   =  text "*********** Constraint Information ***********"@@ -152,30 +221,25 @@   -- -$$ (text "Recursive binders:" <+> pprint (recCount cgi))  -------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- Helper Types: HEnv --------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- | Helper Types: HEnv --------------------------------------------------------+--------------------------------------------------------------------------------  newtype HEnv = HEnv (S.HashSet F.Symbol)  fromListHEnv = HEnv . S.fromList elemHEnv x (HEnv s) = x `S.member` s ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------ Helper Types: Invariants -----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- | Helper Types: Invariants --------------------------------------------------+--------------------------------------------------------------------------------  type RTyConInv = M.HashMap RTyCon [SpecType] type RTyConIAl = M.HashMap RTyCon [SpecType] +-------------------------------------------------------------------------------- mkRTyConInv    :: [F.Located SpecType] -> RTyConInv+-------------------------------------------------------------------------------- mkRTyConInv ts = group [ (c, t) | t@(RApp c _ _ _) <- strip <$> ts]   where     strip      = fourth4 . bkUniv . val@@ -218,42 +282,52 @@ conjoinInvariant t _   = t ---grapBindsWithType tx γ-  = fst <$> toListREnv (filterREnv ((== toRSort tx) . toRSort) (renv γ))----------------------------------------------------------------------- Refinement Type Environments ---------------------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- | Fixpoint Environment ------------------------------------------------------+-------------------------------------------------------------------------------- +data FEnv = FE { feBinds :: !F.IBindEnv      -- ^ Integer Keys for Fixpoint Environment+               , feEnv   :: !(F.SEnv F.Sort) -- ^ Fixpoint Environment+               } -toListREnv (REnv env)     = M.toList env-filterREnv f (REnv env)   = REnv $ M.filter f env-fromListREnv              = REnv . M.fromList-deleteREnv x (REnv env)   = REnv (M.delete x env)-insertREnv x y (REnv env) = REnv (M.insert x y env)-lookupREnv x (REnv env)   = M.lookup x env-memberREnv x (REnv env)   = M.member x env+insertFEnv (FE benv env) ((x, t), i)+  = FE (F.insertsIBindEnv [i] benv) (F.insertSEnv x t env) +insertsFEnv :: FEnv -> [((F.Symbol, F.Sort), F.BindId)] -> FEnv+insertsFEnv = L.foldl' insertFEnv +initFEnv xts = FE F.emptyIBindEnv $ F.fromListSEnv (wiredSortedSyms ++ xts) --------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- Fixpoint Environment ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- | Forcing Strictness --------------------------------------------------------+-------------------------------------------------------------------------------- +instance NFData CGEnv where+  rnf (CGE x1 _ x3 _ x5 x6 x7 x8 x9 _ _ _ x10 _ _ _ _ _ _ _)+    = x1 `seq` {- rnf x2 `seq` -} seq x3 `seq` rnf x5 `seq`+      rnf x6  `seq` x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 -data FEnv = FE { fe_binds :: !F.IBindEnv      -- ^ Integer Keys for Fixpoint Environment-               , fe_env   :: !(F.SEnv F.Sort) -- ^ Fixpoint Environment-               }+instance NFData FEnv where+  rnf (FE x1 _) = rnf x1 -insertFEnv (FE benv env) ((x, t), i)-  = FE (F.insertsIBindEnv [i] benv) (F.insertSEnv x t env)+instance NFData SubC where+  rnf (SubC x1 x2 x3)+    = rnf x1 `seq` rnf x2 `seq` rnf x3+  rnf (SubR x1 _ x2)+    = rnf x1 `seq` rnf x2 -insertsFEnv :: FEnv -> [((F.Symbol, F.Sort), F.BindId)] -> FEnv-insertsFEnv = L.foldl' insertFEnv+instance NFData WfC where+  rnf (WfC x1 x2)+    = rnf x1 `seq` rnf x2 -initFEnv init = FE F.emptyIBindEnv $ F.fromListSEnv (wiredSortedSyms ++ init)+instance NFData CGInfo where+  rnf x = ({-# SCC "CGIrnf1" #-}  rnf (hsCs x))       `seq`+          ({-# SCC "CGIrnf2" #-}  rnf (hsWfs x))      `seq`+          ({-# SCC "CGIrnf3" #-}  rnf (fixCs x))      `seq`+          ({-# SCC "CGIrnf4" #-}  rnf (fixWfs x))     `seq`+          ({-# SCC "CGIrnf6" #-}  rnf (freshIndex x)) `seq`+          ({-# SCC "CGIrnf7" #-}  rnf (binds x))      `seq`+          ({-# SCC "CGIrnf8" #-}  rnf (annotMap x))   `seq`+          ({-# SCC "CGIrnf10" #-} rnf (kuts x))       `seq`+          ({-# SCC "CGIrnf10" #-} rnf (lits x))       `seq`+          ({-# SCC "CGIrnf10" #-} rnf (kvProf x))
− src/Language/Haskell/Liquid/CoreToLogic.hs 
@@ -1,409 +0,0 @@-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FlexibleContexts       #-} -{-# LANGUAGE UndecidableInstances   #-}-{-# LANGUAGE OverloadedStrings      #-}-{-# LANGUAGE TupleSections          #-}-{-# LANGUAGE EmptyDataDecls         #-}--module Language.Haskell.Liquid.CoreToLogic ( --  coreToDef , coreToFun-  , mkLit, runToLogic,-  logicType, -  strengthenResult--  ) where--import GHC hiding (Located)-import Var -import Type --import qualified CoreSyn   as C-import Literal-import IdInfo--import Data.Text.Encoding--import TysWiredIn --import Control.Applicative --import Language.Fixpoint.Misc-import Language.Fixpoint.Names (dropModuleNames, propConName, isPrefixOfSym)-import Language.Fixpoint.Types hiding (Def, R, simplify)-import qualified Language.Fixpoint.Types as F-import Language.Haskell.Liquid.GhcMisc-import Language.Haskell.Liquid.GhcPlay-import Language.Haskell.Liquid.Types    hiding (GhcInfo(..), GhcSpec (..))-import Language.Haskell.Liquid.WiredIn-import Language.Haskell.Liquid.RefType---import qualified Data.HashMap.Strict as M--import Data.Monoid---logicType :: (Reftable r) => Type -> RRType r-logicType τ = fromRTypeRep $ t{ty_res = res, ty_binds = binds, ty_args = args, ty_refts = refts}-  where -    t   = toRTypeRep $ ofType τ -    res = mkResType $ ty_res t-    (binds, args, refts) = unzip3 $ dropWhile (isClassType.snd3) $ zip3 (ty_binds t) (ty_args t) (ty_refts t)-    --    mkResType t -     | isBool t   = propType-     | otherwise  = t--isBool (RApp (RTyCon{rtc_tc = c}) _ _ _) = c == boolTyCon-isBool _ = False--{- strengthenResult type: the refinement depends on whether the result type is a Bool or not:--CASE1: measure f@logic :: X -> Prop <=> f@haskell :: x:X -> {v:Bool | (Prop v) <=> (f@logic x)} --CASE2: measure f@logic :: X -> Y    <=> f@haskell :: x:X -> {v:Y    | v = (f@logic x)} --}--strengthenResult :: Var -> SpecType-strengthenResult v-  | isBool res-  = -- traceShow ("Type for " ++ showPpr v ++ "\t OF \t" ++ show (ty_binds rep)) $  -    fromRTypeRep $ rep{ty_res = res `strengthen` r, ty_binds = xs}-  | otherwise-  = -- traceShow ("Type for " ++ showPpr v ++ "\t OF \t" ++ show (ty_binds rep)) $ -    fromRTypeRep $ rep{ty_res = res `strengthen` r', ty_binds = xs}-  where rep = toRTypeRep t-        res = ty_res rep-        xs  = intSymbol (symbol ("x" :: String)) <$> [1..length $ ty_binds rep]-        r'  = U (exprReft (EApp f (mkA <$> vxs)))         mempty mempty-        r   = U (propReft (PBexp $ EApp f (mkA <$> vxs))) mempty mempty-        vxs = dropWhile (isClassType.snd) $ zip xs (ty_args rep)-        f   = dummyLoc $ dropModuleNames $ simplesymbol v-        t   = (ofType $ varType v) :: SpecType-        mkA = \(x, _) -> EVar x -- if isBool t then EApp (dummyLoc propConName) [(EVar x)] else EVar x---simplesymbol = symbol . getName--newtype LogicM a = LM {runM :: LState -> Either a Error}--data LState = LState { symbolMap :: LogicMap -                     , mkError   :: String -> Error-                     }---instance Monad LogicM where-  return = LM . const . Left-  (LM m) >>= f -    = LM $ \s -> case m s of -                (Left x) -> (runM (f x)) s -                (Right x) -> Right x--instance Functor LogicM where-  fmap f (LM m) = LM $ \s -> case m s of -                              (Left  x) -> Left $ f x-                              (Right x) -> Right x--instance Applicative LogicM where-  pure = LM . const . Left-  (LM f) <*> (LM m) -    = LM $ \s -> case (f s, m s) of -                  (Left f , Left x ) -> Left $ f x-                  (Right f, Left _ ) -> Right f-                  (Left _ , Right x) -> Right x-                  (Right _, Right x) -> Right x--throw :: String -> LogicM a-throw str = LM $ \s -> Right $ (mkError s) str--getState :: LogicM LState-getState = LM $ Left --runToLogic lmap ferror (LM m) -  = m $ LState {symbolMap = lmap, mkError = ferror}--coreToDef :: Reftable r => LocSymbol -> Var -> C.CoreExpr ->  LogicM [Def (RRType r) DataCon]-coreToDef x _ e = go [] $ inline_preds $ simplify e-  where-    go args (C.Lam  x e) = go (x:args) e-    go args (C.Tick _ e) = go args e-    go args (C.Case _ _ t alts) -      | eqType t boolTy  = mapM (goalt_prop (reverse $ tail args) (head args)) alts-      | otherwise        = mapM (goalt      (reverse $ tail args) (head args)) alts-    go _ _               = throw "Measure Functions should have a case at top level"--    goalt args dx ((C.DataAlt d), xs, e)      -      = ((Def x (toArgs id args) d (Just $ ofType $ varType dx) (toArgs Just xs)) . E) -        <$> coreToLogic e-    goalt _ _ alt-       = throw $ "Bad alternative" ++ showPpr alt--    goalt_prop args dx ((C.DataAlt d), xs, e) -      = ((Def x (toArgs id args) d (Just $ ofType $ varType dx) (toArgs Just xs)) . P) -        <$> coreToPred  e-    goalt_prop _ _ alt -      = throw $ "Bad alternative" ++ showPpr alt--    toArgs f args = [(symbol x, f $ ofType $ varType x) | x <- args]--    inline_preds = inline (eqType boolTy . varType)--coreToFun :: LocSymbol -> Var -> C.CoreExpr ->  LogicM ([Var], Either Pred Expr)-coreToFun _ v e = go [] $ inline_preds $ simplify e-  where-    go acc (C.Lam x e)  | isTyVar    x = go acc e-    go acc (C.Lam x e)  | isErasable x = go acc e-    go acc (C.Lam x e)  = go (x:acc) e-    go acc (C.Tick _ e) = go acc e-    go acc e            | eqType rty boolTy -                        = (reverse acc,) . Left  <$> coreToPred e  -                        | otherwise       -                        = (reverse acc,) . Right <$> coreToLogic e--    inline_preds = inline (eqType boolTy . varType)--    rty = snd $ splitFunTys $ snd $ splitForAllTys $ varType v--instance Show C.CoreExpr where-  show = showPpr--coreToPred :: C.CoreExpr -> LogicM Pred-coreToPred (C.Let b p)  = subst1 <$> coreToPred p <*>  makesub b-coreToPred (C.Tick _ p) = coreToPred p-coreToPred (C.App (C.Var v) e) | ignoreVar v = coreToPred e-coreToPred (C.Var x)-  | x == falseDataConId-  = return PFalse-  | x == trueDataConId-  = return PTrue-  | eqType boolTy (varType x)-  = return $ PBexp $ EApp (dummyLoc propConName) [(EVar $ symbol x)]-coreToPred p@(C.App _ _) = toPredApp p  -coreToPred e-  = PBexp <$> coreToLogic e  --- coreToPred e                  ---  = throw ("Cannot transform to Logical Predicate:\t" ++ showPpr e)---coreToLogic :: C.CoreExpr -> LogicM Expr-coreToLogic (C.Let b e)  = subst1 <$> coreToLogic e <*>  makesub b-coreToLogic (C.Tick _ e) = coreToLogic e-coreToLogic (C.App (C.Var v) e) | ignoreVar v = coreToLogic e-coreToLogic (C.Lit l)            -  = case mkLit l of -     Nothing -> throw $ "Bad Literal in measure definition" ++ showPpr l-     Just i -> return i-coreToLogic (C.Var x)           = (symbolMap <$> getState) >>= eVarWithMap x-coreToLogic e@(C.App _ _)       = toLogicApp e -coreToLogic (C.Case e b _ alts) | eqType (varType b) boolTy-  = checkBoolAlts alts >>= coreToIte e -coreToLogic e                   = throw ("Cannot transform to Logic:\t" ++ showPpr e)--checkBoolAlts :: [C.CoreAlt] -> LogicM (C.CoreExpr, C.CoreExpr)-checkBoolAlts [(C.DataAlt false, [], efalse), (C.DataAlt true, [], etrue)]-  | false == falseDataCon, true == trueDataCon-  = return (efalse, etrue)-checkBoolAlts [(C.DataAlt true, [], etrue), (C.DataAlt false, [], efalse)]-  | false == falseDataCon, true == trueDataCon-  = return (efalse, etrue)-checkBoolAlts alts-  = throw ("checkBoolAlts failed on " ++ showPpr alts)  --coreToIte e (efalse, etrue)-  = do p  <- coreToPred e-       e1 <- coreToLogic efalse -       e2 <- coreToLogic etrue-       return $ EIte p e2 e1--toPredApp :: C.CoreExpr -> LogicM Pred-toPredApp p -  = do let (f, es) = splitArgs p-       f'         <- tosymbol f-       go f' es-  where-    go f [e1, e2]-      | Just rel <- M.lookup (val f) brels -      = PAtom rel <$> (coreToLogic e1) <*> (coreToLogic e2)-    go f [e]-      | val f == symbol ("not" :: String)-      = PNot <$>  coreToPred e-    go f [e1, e2]-      | val f == symbol ("||" :: String)-      = POr <$> mapM coreToPred [e1, e2]-      | val f == symbol ("&&" :: String)-      = PAnd <$> mapM coreToPred [e1, e2]-      | val f == symbol ("==>" :: String)-      = PImp <$> coreToPred e1 <*> coreToPred e2-    go f es-      | val f == symbol ("or" :: String)-      = POr <$> mapM coreToPred es-      | val f == symbol ("and" :: String)-      = PAnd <$> mapM coreToPred es-      | otherwise-      = PBexp <$> toLogicApp p--toLogicApp :: C.CoreExpr -> LogicM Expr-toLogicApp e   -  =  do let (f, es) = splitArgs e-        args       <- mapM coreToLogic es-        lmap       <- symbolMap <$> getState-        def         <- (`EApp` args) <$> tosymbol f-        (\x -> makeApp def lmap x args) <$> tosymbol' f--makeApp :: Expr -> LogicMap -> Located Symbol-> [Expr] -> Expr-makeApp _ _ f [e] | val f == symbol ("GHC.Num.negate" :: String)-  = ENeg e--makeApp _ _ f [e1, e2] | Just op <- M.lookup (val f) bops-  = EBin op e1 e2--makeApp def lmap f es -  = eAppWithMap lmap f es def--eVarWithMap :: Id -> LogicMap -> LogicM Expr-eVarWithMap x lmap -  = do f' <- tosymbol' (C.Var x :: C.CoreExpr)-       return $ eAppWithMap lmap f' [] (EVar $ symbol x)--brels :: M.HashMap Symbol Brel-brels = M.fromList [ (symbol ("==" :: String), Eq)-                   , (symbol ("/=" :: String), Ne)-                   , (symbol (">=" :: String), Ge)-                   , (symbol (">" :: String) , Gt)-                   , (symbol ("<=" :: String), Le)-                   , (symbol ("<" :: String) , Lt)-                   ]--bops :: M.HashMap Symbol Bop-bops = M.fromList [ (numSymbol "+", Plus)-                  , (numSymbol "-", Minus)-                  , (numSymbol "*", Times)-                  , (numSymbol "/", Div)-                  , (numSymbol "%", Mod)-                  ] -  where-    numSymbol :: String -> Symbol-    numSymbol =  symbol . (++) "GHC.Num."--splitArgs e = (f, reverse es)- where-    (f, es) = go e--    go (C.App (C.Var i) e) | ignoreVar i       = go e-    go (C.App f (C.Var v)) | isErasable v    = go f-    go (C.App f e) = (f', e:es) where (f', es) = go f-    go f           = (f, [])--tosymbol (C.Var c) | isDataConId  c = return $ dummyLoc $ symbol c -tosymbol (C.Var x) = return $ dummyLoc $ simpleSymbolVar x-tosymbol  e        = throw ("Bad Measure Definition:\n" ++ showPpr e ++ "\t cannot be applied")--tosymbol' (C.Var x) = return $ dummyLoc $ simpleSymbolVar' x-tosymbol'  e        = throw ("Bad Measure Definition:\n" ++ showPpr e ++ "\t cannot be applied")--makesub (C.NonRec x e) =  (symbol x,) <$> coreToLogic e-makesub  _             = throw "Cannot make Logical Substitution of Recursive Definitions"--mkLit :: Literal -> Maybe Expr-mkLit (MachInt    n)   = mkI n-mkLit (MachInt64  n)   = mkI n-mkLit (MachWord   n)   = mkI n-mkLit (MachWord64 n)   = mkI n-mkLit (MachFloat  n)   = mkR n-mkLit (MachDouble n)   = mkR n-mkLit (LitInteger n _) = mkI n-mkLit (MachStr s)      = mkS s -mkLit _                = Nothing -- ELit sym sort--mkI                    = Just . ECon . I  -mkR                    = Just . ECon . F.R . fromRational-mkS                    = Just . ESym . SL  . decodeUtf8--ignoreVar i = simpleSymbolVar i `elem` ["I#"]---simpleSymbolVar  = dropModuleNames . symbol . showPpr . getName-simpleSymbolVar' = symbol . showPpr . getName--isErasable v = isPrefixOfSym (symbol ("$" :: String)) (simpleSymbolVar v)--isDead     = isDeadOcc . occInfo . idInfo--class Simplify a where-  simplify :: a -> a -  inline   :: (Id -> Bool) -> a -> a--instance Simplify C.CoreExpr where-  simplify e@(C.Var _) -    = e-  simplify e@(C.Lit _) -    = e-  simplify (C.App e (C.Type _))                        -    = simplify e-  simplify (C.App e (C.Var dict))  | isErasable dict -    = simplify e-  simplify (C.App (C.Lam x e) _)   | isDead x          -    = simplify e-  simplify (C.App e1 e2) -    = C.App (simplify e1) (simplify e2)-  simplify (C.Lam x e) | isTyVar x -    = simplify e-  simplify (C.Lam x e) | isErasable x -    = simplify e-  simplify (C.Lam x e) -    = C.Lam x (simplify e)-  simplify (C.Let (C.NonRec x _) e) | isErasable x-    = simplify e -  simplify (C.Let (C.Rec xes) e)    | all (isErasable . fst) xes-    = simplify e -  simplify (C.Let xes e) -    = C.Let (simplify xes) (simplify e)-  simplify (C.Case e x t alts) -    = C.Case (simplify e) x t (filter (not . isUndefined) (simplify <$> alts))-  simplify (C.Cast e _)    -    = simplify e-  simplify (C.Tick _ e) -    = simplify e-  simplify (C.Coercion c)-    = C.Coercion c-  simplify (C.Type t)-    = C.Type t  --  inline p (C.Let (C.NonRec x ex) e) | p x-                               = sub (M.singleton x (inline p ex)) (inline p e)-  inline p (C.Let xes e)       = C.Let (inline p xes) (inline p e)  -  inline p (C.App e1 e2)       = C.App (inline p e1) (inline p e2)-  inline p (C.Lam x e)         = C.Lam x (inline p e)-  inline p (C.Case e x t alts) = C.Case (inline p e) x t (inline p <$> alts)-  inline p (C.Cast e c)        = C.Cast (inline p e) c-  inline p (C.Tick t e)        = C.Tick t (inline p e)-  inline _ (C.Var x)           = C.Var x-  inline _ (C.Lit l)           = C.Lit l-  inline _ (C.Coercion c)      = C.Coercion c-  inline _ (C.Type t)          = C.Type t--isUndefined (_, _, e) = isUndefinedExpr e-  where -   -- auto generated undefined case: (\_ -> (patError @type "error message")) void-   isUndefinedExpr (C.App (C.Var x) _) | (show x) `elem` perrors = True-   isUndefinedExpr (C.Let _ e) = isUndefinedExpr e-   -- otherwise -   isUndefinedExpr _ = False --   perrors = ["Control.Exception.Base.patError"]---instance Simplify C.CoreBind where-  simplify (C.NonRec x e) = C.NonRec x (simplify e)-  simplify (C.Rec xes)    = C.Rec (mapSnd simplify <$> xes )--  inline p (C.NonRec x e) = C.NonRec x (inline p e)-  inline p (C.Rec xes)    = C.Rec (mapSnd (inline p) <$> xes)--instance Simplify C.CoreAlt where-  simplify (c, xs, e) = (c, xs, simplify e) --  inline p (c, xs, e) = (c, xs, inline p e)-
− src/Language/Haskell/Liquid/Desugar/Check.lhs 
@@ -1,765 +0,0 @@-%-% (c) The University of Glasgow 2006-% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998-%-% Author: Juan J. Quintela    <quintela@krilin.dc.fi.udc.es>--\begin{code}-module Language.Haskell.Liquid.Desugar.Check ( check , ExhaustivePat ) where---- #include "HsVersions.h"--import HsSyn-import TcHsSyn-import Language.Haskell.Liquid.Desugar.DsUtils-import Language.Haskell.Liquid.Desugar.MatchLit-import Id-import ConLike-import DataCon-import PatSyn-import Name-import TysWiredIn-import PrelNames-import TyCon-import SrcLoc-import UniqSet-import Util-import BasicTypes-import Outputable-import FastString-\end{code}--This module performs checks about if one list of equations are:-\begin{itemize}-\item Overlapped-\item Non exhaustive-\end{itemize}-To discover that we go through the list of equations in a tree-like fashion.--If you like theory, a similar algorithm is described in:-\begin{quotation}-        {\em Two Techniques for Compiling Lazy Pattern Matching},-        Luc Maranguet,-        INRIA Rocquencourt (RR-2385, 1994)-\end{quotation}-The algorithm is based on the first technique, but there are some differences:-\begin{itemize}-\item We don't generate code-\item We have constructors and literals (not only literals as in the-          article)-\item We don't use directions, we must select the columns from-          left-to-right-\end{itemize}-(By the way the second technique is really similar to the one used in- @Match.lhs@ to generate code)--This function takes the equations of a pattern and returns:-\begin{itemize}-\item The patterns that are not recognized-\item The equations that are not overlapped-\end{itemize}-It simplify the patterns and then call @check'@ (the same semantics), and it-needs to reconstruct the patterns again ....--The problem appear with things like:-\begin{verbatim}-  f [x,y]   = ....-  f (x:xs)  = .....-\end{verbatim}-We want to put the two patterns with the same syntax, (prefix form) and-then all the constructors are equal:-\begin{verbatim}-  f (: x (: y []))   = ....-  f (: x xs)         = .....-\end{verbatim}-(more about that in @tidy_eqns@)--We would prefer to have a @WarningPat@ of type @String@, but Strings and the-Pretty Printer are not friends.--We use @InPat@ in @WarningPat@ instead of @OutPat@-because we need to print the-warning messages in the same way they are introduced, i.e. if the user-wrote:-\begin{verbatim}-        f [x,y] = ..-\end{verbatim}-He don't want a warning message written:-\begin{verbatim}-        f (: x (: y [])) ........-\end{verbatim}-Then we need to use InPats.-\begin{quotation}-     Juan Quintela 5 JUL 1998\\-          User-friendliness and compiler writers are no friends.-\end{quotation}--\begin{code}-type WarningPat = InPat Name-type ExhaustivePat = ([WarningPat], [(Name, [HsLit])])-type EqnNo  = Int-type EqnSet = UniqSet EqnNo---check :: [EquationInfo] -> ([ExhaustivePat], [EquationInfo])-  -- Second result is the shadowed equations-  -- if there are view patterns, just give up - don't know what the function is-check qs = (untidy_warns, shadowed_eqns)-      where-        tidy_qs = map tidy_eqn qs-        (warns, used_nos) = check' ([1..] `zip` tidy_qs)-        untidy_warns = map untidy_exhaustive warns-        shadowed_eqns = [eqn | (eqn,i) <- qs `zip` [1..],-                                not (i `elementOfUniqSet` used_nos)]--untidy_exhaustive :: ExhaustivePat -> ExhaustivePat-untidy_exhaustive ([pat], messages) =-                  ([untidy_no_pars pat], map untidy_message messages)-untidy_exhaustive (pats, messages) =-                  (map untidy_pars pats, map untidy_message messages)--untidy_message :: (Name, [HsLit]) -> (Name, [HsLit])-untidy_message (string, lits) = (string, map untidy_lit lits)-\end{code}--The function @untidy@ does the reverse work of the @tidy_pat@ funcion.--\begin{code}--type NeedPars = Bool--untidy_no_pars :: WarningPat -> WarningPat-untidy_no_pars p = untidy False p--untidy_pars :: WarningPat -> WarningPat-untidy_pars p = untidy True p--untidy :: NeedPars -> WarningPat -> WarningPat-untidy b (L loc p) = L loc (untidy' b p)-  where-    untidy' _ p@(WildPat _)          = p-    untidy' _ p@(VarPat _)           = p-    untidy' _ (LitPat lit)           = LitPat (untidy_lit lit)-    untidy' _ p@(ConPatIn _ (PrefixCon [])) = p-    untidy' b (ConPatIn name ps)     = pars b (L loc (ConPatIn name (untidy_con ps)))-    untidy' _ (ListPat pats ty Nothing)     = ListPat (map untidy_no_pars pats) ty Nothing   -    untidy' _ (TuplePat pats box tys) = TuplePat (map untidy_no_pars pats) box tys-    untidy' _ (ListPat _ _ (Just _)) = panic "Check.untidy: Overloaded ListPat"    -    untidy' _ (PArrPat _ _)          = panic "Check.untidy: Shouldn't get a parallel array here!"-    untidy' _ (SigPatIn _ _)         = panic "Check.untidy: SigPat"-    untidy' _ (LazyPat {})           = panic "Check.untidy: LazyPat"-    untidy' _ (AsPat {})             = panic "Check.untidy: AsPat"-    untidy' _ (ParPat {})            = panic "Check.untidy: ParPat"-    untidy' _ (BangPat {})           = panic "Check.untidy: BangPat"-    untidy' _ (ConPatOut {})         = panic "Check.untidy: ConPatOut"-    untidy' _ (ViewPat {})           = panic "Check.untidy: ViewPat"-    untidy' _ (SplicePat {})         = panic "Check.untidy: SplicePat"-    untidy' _ (QuasiQuotePat {})     = panic "Check.untidy: QuasiQuotePat"-    untidy' _ (NPat {})              = panic "Check.untidy: NPat"-    untidy' _ (NPlusKPat {})         = panic "Check.untidy: NPlusKPat"-    untidy' _ (SigPatOut {})         = panic "Check.untidy: SigPatOut"-    untidy' _ (CoPat {})             = panic "Check.untidy: CoPat"--untidy_con :: HsConPatDetails Name -> HsConPatDetails Name-untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats)-untidy_con (InfixCon p1 p2) = InfixCon  (untidy_pars p1) (untidy_pars p2)-untidy_con (RecCon (HsRecFields flds dd))-  = RecCon (HsRecFields [ fld { hsRecFieldArg = untidy_pars (hsRecFieldArg fld) }-                        | fld <- flds ] dd)--pars :: NeedPars -> WarningPat -> Pat Name-pars True p = ParPat p-pars _    p = unLoc p--untidy_lit :: HsLit -> HsLit-untidy_lit (HsCharPrim c) = HsChar c-untidy_lit lit            = lit-\end{code}--This equation is the same that check, the only difference is that the-boring work is done, that work needs to be done only once, this is-the reason top have two functions, check is the external interface,-@check'@ is called recursively.--There are several cases:--\begin{itemize}-\item There are no equations: Everything is OK.-\item There are only one equation, that can fail, and all the patterns are-      variables. Then that equation is used and the same equation is-      non-exhaustive.-\item All the patterns are variables, and the match can fail, there are-      more equations then the results is the result of the rest of equations-      and this equation is used also.--\item The general case, if all the patterns are variables (here the match-      can't fail) then the result is that this equation is used and this-      equation doesn't generate non-exhaustive cases.--\item In the general case, there can exist literals ,constructors or only-      vars in the first column, we actuate in consequence.--\end{itemize}---\begin{code}--check' :: [(EqnNo, EquationInfo)]-        -> ([ExhaustivePat],    -- Pattern scheme that might not be matched at all-            EqnSet)             -- Eqns that are used (others are overlapped)--check' [] = ([],emptyUniqSet)-  -- Was    ([([],[])], emptyUniqSet)-  -- But that (a) seems weird, and (b) triggered Trac #7669 -  -- So now I'm just doing the simple obvious thing--check' ((n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult can_fail _ }) : rs)-   | first_eqn_all_vars && case can_fail of { CantFail -> True; CanFail -> False }-   = ([], unitUniqSet n)        -- One eqn, which can't fail--   | first_eqn_all_vars && null rs      -- One eqn, but it can fail-   = ([(takeList ps (repeat nlWildPat),[])], unitUniqSet n)--   | first_eqn_all_vars         -- Several eqns, first can fail-   = (pats, addOneToUniqSet indexs n)-  where-    first_eqn_all_vars = all_vars ps-    (pats,indexs) = check' rs--check' qs-   | some_literals     = split_by_literals qs-   | some_constructors = split_by_constructor qs-   | only_vars         = first_column_only_vars qs-   | otherwise = pprPanic "Check.check': Not implemented :-(" (ppr first_pats)-                 -- Shouldn't happen-  where-     -- Note: RecPats will have been simplified to ConPats-     --       at this stage.-    first_pats        = {- ASSERT2( okGroup qs, pprGroup qs ) -} map firstPatN qs-    some_constructors = any is_con first_pats-    some_literals     = any is_lit first_pats-    only_vars         = all is_var first_pats-\end{code}--Here begins the code to deal with literals, we need to split the matrix-in different matrix beginning by each literal and a last matrix with the-rest of values.--\begin{code}-split_by_literals :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)-split_by_literals qs = process_literals used_lits qs-           where-             used_lits = get_used_lits qs-\end{code}--@process_explicit_literals@ is a function that process each literal that appears-in the column of the matrix.--\begin{code}-process_explicit_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)-process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs)-    where-      pats_indexs   = map (\x -> construct_literal_matrix x qs) lits-      (pats,indexs) = unzip pats_indexs-\end{code}---@process_literals@ calls @process_explicit_literals@ to deal with the literals-that appears in the matrix and deal also with the rest of the cases. It-must be one Variable to be complete.--\begin{code}--process_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)-process_literals used_lits qs-  | null default_eqns  = {- ASSERT( not (null qs) ) -} ([make_row_vars used_lits (head qs)] ++ pats,indexs)-  | otherwise          = (pats_default,indexs_default)-     where-       (pats,indexs)   = process_explicit_literals used_lits qs-       default_eqns    = -- ASSERT2( okGroup qs, pprGroup qs )-                         [remove_var q | q <- qs, is_var (firstPatN q)]-       (pats',indexs') = check' default_eqns-       pats_default    = [(nlWildPat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats-       indexs_default  = unionUniqSets indexs' indexs-\end{code}--Here we have selected the literal and we will select all the equations that-begins for that literal and create a new matrix.--\begin{code}-construct_literal_matrix :: HsLit -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)-construct_literal_matrix lit qs =-    (map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs)-  where-    (pats,indexs) = (check' (remove_first_column_lit lit qs))-    new_lit = nlLitPat lit--remove_first_column_lit :: HsLit-                        -> [(EqnNo, EquationInfo)]-                        -> [(EqnNo, EquationInfo)]-remove_first_column_lit lit qs-  = -- ASSERT2( okGroup qs, pprGroup qs )-    [(n, shift_pat eqn) | q@(n,eqn) <- qs, is_var_lit lit (firstPatN q)]-  where-     shift_pat eqn@(EqnInfo { eqn_pats = _:ps}) = eqn { eqn_pats = ps }-     shift_pat _                                = panic "Check.shift_var: no patterns"-\end{code}--This function splits the equations @qs@ in groups that deal with the-same constructor.--\begin{code}-split_by_constructor :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)-split_by_constructor qs-  | null used_cons      = ([], mkUniqSet $ map fst qs)-  | notNull unused_cons = need_default_case used_cons unused_cons qs-  | otherwise           = no_need_default_case used_cons qs-                       where-                          used_cons   = get_used_cons qs-                          unused_cons = get_unused_cons used_cons-\end{code}--The first column of the patterns matrix only have vars, then there is-nothing to do.--\begin{code}-first_column_only_vars :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)-first_column_only_vars qs = (map (\ (xs,ys) -> (nlWildPat:xs,ys)) pats,indexs)-                          where-                            (pats, indexs) = check' (map remove_var qs)-\end{code}--This equation takes a matrix of patterns and split the equations by-constructor, using all the constructors that appears in the first column-of the pattern matching.--We can need a default clause or not ...., it depends if we used all the-constructors or not explicitly. The reasoning is similar to @process_literals@,-the difference is that here the default case is not always needed.--\begin{code}-no_need_default_case :: [Pat Id] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)-no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs)-    where-      pats_indexs   = map (\x -> construct_matrix x qs) cons-      (pats,indexs) = unzip pats_indexs--need_default_case :: [Pat Id] -> [DataCon] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)-need_default_case used_cons unused_cons qs-  | null default_eqns  = (pats_default_no_eqns,indexs)-  | otherwise          = (pats_default,indexs_default)-     where-       (pats,indexs)   = no_need_default_case used_cons qs-       default_eqns    = -- ASSERT2( okGroup qs, pprGroup qs )-                         [remove_var q | q <- qs, is_var (firstPatN q)]-       (pats',indexs') = check' default_eqns-       pats_default    = [(make_whole_con c:ps,constraints) |-                          c <- unused_cons, (ps,constraints) <- pats'] ++ pats-       new_wilds       = {- ASSERT( not (null qs) ) -} make_row_vars_for_constructor (head qs)-       pats_default_no_eqns =  [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats-       indexs_default  = unionUniqSets indexs' indexs--construct_matrix :: Pat Id -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)-construct_matrix con qs =-    (map (make_con con) pats,indexs)-  where-    (pats,indexs) = (check' (remove_first_column con qs))-\end{code}--Here remove first column is more difficult that with literals due to the fact-that constructors can have arguments.--For instance, the matrix-\begin{verbatim}- (: x xs) y- z        y-\end{verbatim}-is transformed in:-\begin{verbatim}- x xs y- _ _  y-\end{verbatim}--\begin{code}-remove_first_column :: Pat Id                -- Constructor-                    -> [(EqnNo, EquationInfo)]-                    -> [(EqnNo, EquationInfo)]-remove_first_column (ConPatOut{ pat_con = L _ con, pat_args = PrefixCon con_pats }) qs-  = --  ASSERT2( okGroup qs, pprGroup qs )-    [(n, shift_var eqn) | q@(n, eqn) <- qs, is_var_con con (firstPatN q)]-  where-     new_wilds = [WildPat (hsLPatType arg_pat) | arg_pat <- con_pats]-     shift_var eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_args = PrefixCon ps' } : ps})-        = eqn { eqn_pats = map unLoc ps' ++ ps }-     shift_var eqn@(EqnInfo { eqn_pats = WildPat _ : ps })-        = eqn { eqn_pats = new_wilds ++ ps }-     shift_var _ = panic "Check.Shift_var:No done"-remove_first_column _ _ = panic "Check.remove_first_column: Not ConPatOut"--make_row_vars :: [HsLit] -> (EqnNo, EquationInfo) -> ExhaustivePat-make_row_vars used_lits (_, EqnInfo { eqn_pats = pats})-   = (nlVarPat new_var:takeList (tail pats) (repeat nlWildPat),[(new_var,used_lits)])-  where-     new_var = hash_x--hash_x :: Name-hash_x = mkInternalName unboundKey {- doesn't matter much -}-                     (mkVarOccFS (fsLit "#x"))-                     noSrcSpan--make_row_vars_for_constructor :: (EqnNo, EquationInfo) -> [WarningPat]-make_row_vars_for_constructor (_, EqnInfo { eqn_pats = pats})-  = takeList (tail pats) (repeat nlWildPat)--compare_cons :: Pat Id -> Pat Id -> Bool-compare_cons (ConPatOut{ pat_con = L _ con1 }) (ConPatOut{ pat_con = L _ con2 })-  = case (con1, con2) of-    (RealDataCon id1, RealDataCon id2) -> id1 == id2-    _ -> False-compare_cons _ _ = panic "Check.compare_cons: Not ConPatOut with RealDataCon"--remove_dups :: [Pat Id] -> [Pat Id]-remove_dups []     = []-remove_dups (x:xs) | or (map (\y -> compare_cons x y) xs) = remove_dups  xs-                   | otherwise                            = x : remove_dups xs--get_used_cons :: [(EqnNo, EquationInfo)] -> [Pat Id]-get_used_cons qs = remove_dups [pat | q <- qs, let pat = firstPatN q,-                                      isConPatOut pat]--isConPatOut :: Pat Id -> Bool-isConPatOut ConPatOut{ pat_con = L _ RealDataCon{} } = True-isConPatOut _                                        = False--remove_dups' :: [HsLit] -> [HsLit]-remove_dups' []                   = []-remove_dups' (x:xs) | x `elem` xs = remove_dups' xs-                    | otherwise   = x : remove_dups' xs---get_used_lits :: [(EqnNo, EquationInfo)] -> [HsLit]-get_used_lits qs = remove_dups' all_literals-                 where-                   all_literals = get_used_lits' qs--get_used_lits' :: [(EqnNo, EquationInfo)] -> [HsLit]-get_used_lits' [] = []-get_used_lits' (q:qs)-  | Just lit <- get_lit (firstPatN q) = lit : get_used_lits' qs-  | otherwise                         = get_used_lits qs--get_lit :: Pat id -> Maybe HsLit--- Get a representative HsLit to stand for the OverLit--- It doesn't matter which one, because they will only be compared--- with other HsLits gotten in the same way-get_lit (LitPat lit)                                      = Just lit-get_lit (NPat (OverLit { ol_val = HsIntegral i})    mb _) = Just (HsIntPrim   (mb_neg negate              mb i))-get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg negateFractionalLit mb f))-get_lit (NPat (OverLit { ol_val = HsIsString s })   _  _) = Just (HsStringPrim (fastStringToByteString s))-get_lit _                                                 = Nothing--mb_neg :: (a -> a) -> Maybe b -> a -> a-mb_neg _      Nothing  v = v-mb_neg negate (Just _) v = negate v--get_unused_cons :: [Pat Id] -> [DataCon]-get_unused_cons used_cons = {- ASSERT( not (null used_cons) ) -} unused_cons-     where-       used_set :: UniqSet DataCon-       used_set = mkUniqSet [d | ConPatOut{ pat_con = L _ (RealDataCon d) } <- used_cons]-       (ConPatOut { pat_con = L _ (RealDataCon con1), pat_arg_tys = inst_tys }) = head used_cons-       ty_con      = dataConTyCon con1-       unused_cons = filterOut is_used (tyConDataCons ty_con)-       is_used con = con `elementOfUniqSet` used_set-                     || dataConCannotMatch inst_tys con--all_vars :: [Pat Id] -> Bool-all_vars []             = True-all_vars (WildPat _:ps) = all_vars ps-all_vars _              = False--remove_var :: (EqnNo, EquationInfo) -> (EqnNo, EquationInfo)-remove_var (n, eqn@(EqnInfo { eqn_pats = WildPat _ : ps})) = (n, eqn { eqn_pats = ps })-remove_var _  = panic "Check.remove_var: equation does not begin with a variable"--------------------------{--eqnPats :: (EqnNo, EquationInfo) -> [Pat Id]-eqnPats (_, eqn) = eqn_pats eqn-okGroup :: [(EqnNo, EquationInfo)] -> Bool--- True if all equations have at least one pattern, and--- all have the same number of patterns-okGroup [] = True-okGroup (e:es) = n_pats > 0 && and [length (eqnPats e) == n_pats | e <- es]-               where-                 n_pats = length (eqnPats e)--}--- Half-baked print--- pprGroup :: [(EqnNo, EquationInfo)] -> SDoc--- pprEqnInfo :: (EqnNo, EquationInfo) -> SDoc--- pprGroup es = vcat (map pprEqnInfo es)--- pprEqnInfo e = ppr (eqnPats e)---firstPatN :: (EqnNo, EquationInfo) -> Pat Id-firstPatN (_, eqn) = firstPat eqn--is_con :: Pat Id -> Bool-is_con (ConPatOut {}) = True-is_con _              = False--is_lit :: Pat Id -> Bool-is_lit (LitPat _)      = True-is_lit (NPat _ _ _)  = True-is_lit _               = False--is_var :: Pat Id -> Bool-is_var (WildPat _) = True-is_var _           = False--is_var_con :: ConLike -> Pat Id -> Bool-is_var_con _   (WildPat _)                     = True-is_var_con con (ConPatOut{ pat_con = L _ id }) = id == con-is_var_con _   _                               = False--is_var_lit :: HsLit -> Pat Id -> Bool-is_var_lit _   (WildPat _)   = True-is_var_lit lit pat-  | Just lit' <- get_lit pat = lit == lit'-  | otherwise                = False-\end{code}--The difference beteewn @make_con@ and @make_whole_con@ is that-@make_wole_con@ creates a new constructor with all their arguments, and-@make_con@ takes a list of argumntes, creates the contructor getting their-arguments from the list. See where \fbox{\ ???\ } are used for details.--We need to reconstruct the patterns (make the constructors infix and-similar) at the same time that we create the constructors.--You can tell tuple constructors using-\begin{verbatim}-        Id.isTupleDataCon-\end{verbatim}-You can see if one constructor is infix with this clearer code :-))))))))))-\begin{verbatim}-        Lex.isLexConSym (Name.occNameString (Name.getOccName con))-\end{verbatim}--       Rather clumsy but it works. (Simon Peyton Jones)---We don't mind the @nilDataCon@ because it doesn't change the way to-print the message, we are searching only for things like: @[1,2,3]@,-not @x:xs@ ....--In @reconstruct_pat@ we want to ``undo'' the work-that we have done in @tidy_pat@.-In particular:-\begin{tabular}{lll}-        @((,) x y)@   & returns to be & @(x, y)@-\\      @((:) x xs)@  & returns to be & @(x:xs)@-\\      @(x:(...:[])@ & returns to be & @[x,...]@-\end{tabular}-%-The difficult case is the third one becouse we need to follow all the-contructors until the @[]@ to know that we need to use the second case,-not the second. \fbox{\ ???\ }-%-\begin{code}-isInfixCon :: DataCon -> Bool-isInfixCon con = isDataSymOcc (getOccName con)--is_nil :: Pat Name -> Bool-is_nil (ConPatIn con (PrefixCon [])) = unLoc con == getName nilDataCon-is_nil _                             = False--is_list :: Pat Name -> Bool-is_list (ListPat _ _ Nothing) = True-is_list _             = False--return_list :: DataCon -> Pat Name -> Bool-return_list id q = id == consDataCon && (is_nil q || is_list q)--make_list :: LPat Name -> Pat Name -> Pat Name-make_list p q | is_nil q    = ListPat [p] placeHolderType Nothing-make_list p (ListPat ps ty Nothing) = ListPat (p:ps) ty Nothing-make_list _ _               = panic "Check.make_list: Invalid argument"--make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat-make_con (ConPatOut{ pat_con = L _ (RealDataCon id) }) (lp:lq:ps, constraints)-     | return_list id q = (noLoc (make_list lp q) : ps, constraints)-     | isInfixCon id    = (nlInfixConPat (getName id) lp lq : ps, constraints)-   where q  = unLoc lq--make_con (ConPatOut{ pat_con = L _ (RealDataCon id), pat_args = PrefixCon pats, pat_arg_tys = tys }) (ps, constraints)-      | isTupleTyCon tc  = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) tys) : rest_pats, constraints)-      | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType)            : rest_pats, constraints)-      | otherwise        = (nlConPat name pats_con      : rest_pats, constraints)-    where-        name                  = getName id-        (pats_con, rest_pats) = splitAtList pats ps-        tc                    = dataConTyCon id--make_con _ _ = panic "Check.make_con: Not ConPatOut"---- reconstruct parallel array pattern------  * don't check for the type only; we need to make sure that we are really---   dealing with one of the fake constructors and not with the real---   representation--make_whole_con :: DataCon -> WarningPat-make_whole_con con | isInfixCon con = nlInfixConPat name nlWildPat nlWildPat-                   | otherwise      = nlConPat name pats-                where-                  name   = getName con-                  pats   = [nlWildPat | _ <- dataConOrigArgTys con]-\end{code}---------------------------------------------------------------------------                   Tidying equations---------------------------------------------------------------------------tidy_eqn does more or less the same thing as @tidy@ in @Match.lhs@;-that is, it removes syntactic sugar, reducing the number of cases that-must be handled by the main checking algorithm.  One difference is-that here we can do *all* the tidying at once (recursively), rather-than doing it incrementally.--\begin{code}-tidy_eqn :: EquationInfo -> EquationInfo-tidy_eqn eqn = eqn { eqn_pats = map tidy_pat (eqn_pats eqn),-                     eqn_rhs  = tidy_rhs (eqn_rhs eqn) }-  where-        -- Horrible hack.  The tidy_pat stuff converts "might-fail" patterns to-        -- WildPats which of course loses the info that they can fail to match.-        -- So we stick in a CanFail as if it were a guard.-    tidy_rhs (MatchResult can_fail body)-        | any might_fail_pat (eqn_pats eqn) = MatchResult CanFail body-        | otherwise                         = MatchResult can_fail body-----------------might_fail_pat :: Pat Id -> Bool--- Returns True of patterns that might fail (i.e. fall through) in a way--- that is not covered by the checking algorithm.  Specifically:---         NPlusKPat---         ViewPat (if refutable)---         ConPatOut of a PatSynCon---- First the two special cases-might_fail_pat (NPlusKPat {})                = True-might_fail_pat (ViewPat _ p _)               = not (isIrrefutableHsPat p)---- Now the recursive stuff-might_fail_pat (ParPat p)                    = might_fail_lpat p-might_fail_pat (AsPat _ p)                   = might_fail_lpat p-might_fail_pat (SigPatOut p _ )              = might_fail_lpat p-might_fail_pat (ListPat ps _ Nothing)        = any might_fail_lpat ps-might_fail_pat (ListPat _ _ (Just _))      = True-might_fail_pat (TuplePat ps _ _)             = any might_fail_lpat ps-might_fail_pat (PArrPat ps _)                = any might_fail_lpat ps-might_fail_pat (BangPat p)                   = might_fail_lpat p-might_fail_pat (ConPatOut { pat_con = con, pat_args = ps })-  = case unLoc con of-    RealDataCon _dcon -> any might_fail_lpat (hsConPatArgs ps)-    PatSynCon _psyn -> True---- Finally the ones that are sure to succeed, or which are covered by the checking algorithm-might_fail_pat (LazyPat _)                   = False -- Always succeeds-might_fail_pat _                             = False -- VarPat, WildPat, LitPat, NPat-----------------might_fail_lpat :: LPat Id -> Bool-might_fail_lpat (L _ p) = might_fail_pat p-----------------tidy_lpat :: LPat Id -> LPat Id-tidy_lpat p = fmap tidy_pat p-----------------tidy_pat :: Pat Id -> Pat Id-tidy_pat pat@(WildPat _)  = pat-tidy_pat (VarPat id)      = WildPat (idType id)-tidy_pat (ParPat p)       = tidy_pat (unLoc p)-tidy_pat (LazyPat p)      = WildPat (hsLPatType p)      -- For overlap and exhaustiveness checking-                                                        -- purposes, a ~pat is like a wildcard-tidy_pat (BangPat p)      = tidy_pat (unLoc p)-tidy_pat (AsPat _ p)      = tidy_pat (unLoc p)-tidy_pat (SigPatOut p _)  = tidy_pat (unLoc p)-tidy_pat (CoPat _ pat _)  = tidy_pat pat---- These two are might_fail patterns, so we map them to--- WildPats.  The might_fail_pat stuff arranges that the--- guard says "this equation might fall through".-tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id))-tidy_pat (ViewPat _ _ ty)     = WildPat ty-tidy_pat (ListPat _ _ (Just (ty,_))) = WildPat ty-tidy_pat (ConPatOut { pat_con = L _ (PatSynCon syn), pat_arg_tys = tys })-  = WildPat (patSynInstResTy syn tys)--tidy_pat pat@(ConPatOut { pat_con = L _ con, pat_args = ps })-  = pat { pat_args = tidy_con con ps }--tidy_pat (ListPat ps ty Nothing)-  = unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] [ty])-                                  (mkNilPat ty)-                                  (map tidy_lpat ps)---- introduce fake parallel array constructors to be able to handle parallel--- arrays with the existing machinery for constructor pattern----tidy_pat (PArrPat ps ty)-  = unLoc $ mkPrefixConPat (parrFakeCon (length ps))-                           (map tidy_lpat ps)-                           [ty]--tidy_pat (TuplePat ps boxity tys)-  = unLoc $ mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity)-                           (map tidy_lpat ps) tys-  where-    arity = length ps--tidy_pat (NPat lit mb_neg eq) = tidyNPat tidy_lit_pat lit mb_neg eq-tidy_pat (LitPat lit)         = tidy_lit_pat lit--tidy_pat (ConPatIn {})        = panic "Check.tidy_pat: ConPatIn"-tidy_pat (SplicePat {})       = panic "Check.tidy_pat: SplicePat"-tidy_pat (QuasiQuotePat {})   = panic "Check.tidy_pat: QuasiQuotePat"-tidy_pat (SigPatIn {})        = panic "Check.tidy_pat: SigPatIn"--tidy_lit_pat :: HsLit -> Pat Id--- Unpack string patterns fully, so we can see when they--- overlap with each other, or even explicit lists of Chars.-tidy_lit_pat lit-  | HsString s <- lit-  = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] [charTy])-                  (mkPrefixConPat nilDataCon [] [charTy]) (unpackFS s)-  | otherwise-  = tidyLitPat lit--------------------tidy_con :: ConLike -> HsConPatDetails Id -> HsConPatDetails Id-tidy_con _   (PrefixCon ps)   = PrefixCon (map tidy_lpat ps)-tidy_con _   (InfixCon p1 p2) = PrefixCon [tidy_lpat p1, tidy_lpat p2]-tidy_con con (RecCon (HsRecFields fs _))-  | null fs   = PrefixCon (replicate arity nlWildPat)-                -- Special case for null patterns; maybe not a record at all-  | otherwise = PrefixCon (map (tidy_lpat.snd) all_pats)-  where-    arity = case con of-        RealDataCon dcon -> dataConSourceArity dcon-        PatSynCon psyn -> patSynArity psyn--     -- pad out all the missing fields with WildPats.-    field_pats = case con of-        RealDataCon dc -> map (\ f -> (f, nlWildPat)) (dataConFieldLabels dc)-        PatSynCon{}    -> panic "Check.tidy_con: pattern synonym with record syntax"-    all_pats = foldr (\(HsRecField id p _) acc -> insertNm (getName (unLoc id)) p acc)-                     field_pats fs--    insertNm nm p [] = [(nm,p)]-    insertNm nm p (x@(n,_):xs)-      | nm == n    = (nm,p):xs-      | otherwise  = x : insertNm nm p xs-\end{code}
− src/Language/Haskell/Liquid/Desugar/Coverage.lhs 
@@ -1,1240 +0,0 @@-%-% (c) Galois, 2006-% (c) University of Glasgow, 2007-%-\begin{code}-module Language.Haskell.Liquid.Desugar.Coverage (addTicksToBinds, hpcInitCode) where--import Type-import HsSyn-import Module-import Outputable-import DynFlags-import Control.Monad-import SrcLoc-import ErrUtils-import NameSet hiding (FreeVars)-import Name-import Bag-import CostCentre-import CoreSyn-import Id-import VarSet-import Data.List-import FastString-import HscTypes-import TyCon-import Unique-import BasicTypes-import MonadUtils-import Maybes-import CLabel-import Util--import Data.Array-import Data.Time-import System.Directory--import Trace.Hpc.Mix-import Trace.Hpc.Util--import BreakArray-import Data.Map (Map)-import qualified Data.Map as Map-\end{code}---%************************************************************************-%*                                                                      *-%*              The main function: addTicksToBinds-%*                                                                      *-%************************************************************************--\begin{code}-addTicksToBinds-        :: DynFlags-        -> Module-        -> ModLocation          -- ... off the current module-        -> NameSet              -- Exported Ids.  When we call addTicksToBinds,-                                -- isExportedId doesn't work yet (the desugarer-                                -- hasn't set it), so we have to work from this set.-        -> [TyCon]              -- Type constructor in this module-        -> LHsBinds Id-        -> IO (LHsBinds Id, HpcInfo, ModBreaks)--addTicksToBinds dflags mod mod_loc exports tyCons binds =-- case ml_hs_file mod_loc of-   Nothing        -> return (binds, emptyHpcInfo False, emptyModBreaks)-   Just orig_file -> do--     if "boot" `isSuffixOf` orig_file-         then return (binds, emptyHpcInfo False, emptyModBreaks)-         else do--     let  orig_file2 = guessSourceFile binds orig_file--          (binds1,_,st)-                 = unTM (addTickLHsBinds binds)-                   (TTE-                      { fileName     = mkFastString orig_file2-                      , declPath     = []-                      , tte_dflags   = dflags-                      , exports      = exports-                      , inlines      = emptyVarSet-                      , inScope      = emptyVarSet-                      , blackList    = Map.fromList-                                          [ (getSrcSpan (tyConName tyCon),())-                                          | tyCon <- tyCons ]-                      , density      = mkDensity dflags-                      , this_mod     = mod-                      , tickishType  = case hscTarget dflags of-                          HscInterpreted          -> Breakpoints-                          _ | gopt Opt_Hpc dflags -> HpcTicks-                            | gopt Opt_SccProfilingOn dflags-                                                  -> ProfNotes-                            | otherwise           -> error "addTicksToBinds: No way to annotate!"-                       })-                   (TT-                      { tickBoxCount = 0-                      , mixEntries   = []-                      })--     let entries = reverse $ mixEntries st--     let count = tickBoxCount st-     hashNo <- writeMixEntries dflags mod count entries orig_file2-     modBreaks <- mkModBreaks dflags count entries--     when (dopt Opt_D_dump_ticked dflags) $-         log_action dflags dflags SevDump noSrcSpan defaultDumpStyle-             (pprLHsBinds binds1)--     return (binds1, HpcInfo count hashNo, modBreaks)---guessSourceFile :: LHsBinds Id -> FilePath -> FilePath-guessSourceFile binds orig_file =-     -- Try look for a file generated from a .hsc file to a-     -- .hs file, by peeking ahead.-     let top_pos = catMaybes $ foldrBag (\ (L pos _) rest ->-                                 srcSpanFileName_maybe pos : rest) [] binds-     in-     case top_pos of-        (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name-                      -> unpackFS file_name-        _ -> orig_file---mkModBreaks :: DynFlags -> Int -> [MixEntry_] -> IO ModBreaks-mkModBreaks dflags count entries = do-  breakArray <- newBreakArray dflags $ length entries-  let-         locsTicks = listArray (0,count-1) [ span  | (span,_,_,_)  <- entries ]-         varsTicks = listArray (0,count-1) [ vars  | (_,_,vars,_)  <- entries ]-         declsTicks= listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ]-         modBreaks = emptyModBreaks-                     { modBreaks_flags = breakArray-                     , modBreaks_locs  = locsTicks-                     , modBreaks_vars  = varsTicks-                     , modBreaks_decls = declsTicks-                     }-  ---  return modBreaks---writeMixEntries :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int-writeMixEntries dflags mod count entries filename-  | not (gopt Opt_Hpc dflags) = return 0-  | otherwise   = do-        let-            hpc_dir = hpcDir dflags-            mod_name = moduleNameString (moduleName mod)--            hpc_mod_dir-              | modulePackageId mod == mainPackageId  = hpc_dir-              | otherwise = hpc_dir ++ "/" ++ packageIdString (modulePackageId mod)--            tabStop = 8 -- <tab> counts as a normal char in GHC's location ranges.--        createDirectoryIfMissing True hpc_mod_dir-        modTime <- getModificationUTCTime filename-        let entries' = [ (hpcPos, box)-                       | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]-        when (length entries' /= count) $ do-          panic "the number of .mix entries are inconsistent"-        let hashNo = mixHash filename modTime tabStop entries'-        mixCreate hpc_mod_dir mod_name-                       $ Mix filename modTime (toHash hashNo) tabStop entries'-        return hashNo----- -------------------------------------------------------------------------------- TickDensity: where to insert ticks--data TickDensity-  = TickForCoverage       -- for Hpc-  | TickForBreakPoints    -- for GHCi-  | TickAllFunctions      -- for -prof-auto-all-  | TickTopFunctions      -- for -prof-auto-top-  | TickExportedFunctions -- for -prof-auto-exported-  | TickCallSites         -- for stack tracing-  deriving Eq--mkDensity :: DynFlags -> TickDensity-mkDensity dflags-  | gopt Opt_Hpc dflags                  = TickForCoverage-  | HscInterpreted  <- hscTarget dflags  = TickForBreakPoints-  | ProfAutoAll     <- profAuto dflags   = TickAllFunctions-  | ProfAutoTop     <- profAuto dflags   = TickTopFunctions-  | ProfAutoExports <- profAuto dflags   = TickExportedFunctions-  | ProfAutoCalls   <- profAuto dflags   = TickCallSites-  | otherwise = panic "desnity"-  -- ToDo: -fhpc is taking priority over -fprof-auto here.  It seems-  -- that coverage works perfectly well with profiling, but you don't-  -- get any auto-generated SCCs.  It would make perfect sense to-  -- allow both of them, and indeed to combine some of the other flags-  -- (-fprof-auto-calls -fprof-auto-top, for example)---- | Decide whether to add a tick to a binding or not.-shouldTickBind  :: TickDensity-                -> Bool         -- top level?-                -> Bool         -- exported?-                -> Bool         -- simple pat bind?-                -> Bool         -- INLINE pragma?-                -> Bool--shouldTickBind density top_lev exported simple_pat inline- = case density of-      TickForBreakPoints    -> not simple_pat-        -- we never add breakpoints to simple pattern bindings-        -- (there's always a tick on the rhs anyway).-      TickAllFunctions      -> not inline-      TickTopFunctions      -> top_lev && not inline-      TickExportedFunctions -> exported && not inline-      TickForCoverage       -> True-      TickCallSites         -> False--shouldTickPatBind :: TickDensity -> Bool -> Bool-shouldTickPatBind density top_lev-  = case density of-      TickForBreakPoints    -> False-      TickAllFunctions      -> True-      TickTopFunctions      -> top_lev-      TickExportedFunctions -> False-      TickForCoverage       -> False-      TickCallSites         -> False---- -------------------------------------------------------------------------------- Adding ticks to bindings--addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)-addTickLHsBinds = mapBagM addTickLHsBind--addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)-addTickLHsBind (L pos bind@(AbsBinds { abs_binds   = binds,-                                       abs_exports = abs_exports })) = do-  withEnv add_exports $ do-  withEnv add_inlines $ do-  binds' <- addTickLHsBinds binds-  return $ L pos $ bind { abs_binds = binds' }- where-   -- in AbsBinds, the Id on each binding is not the actual top-level-   -- Id that we are defining, they are related by the abs_exports-   -- field of AbsBinds.  So if we're doing TickExportedFunctions we need-   -- to add the local Ids to the set of exported Names so that we know to-   -- tick the right bindings.-   add_exports env =-     env{ exports = exports env `addListToNameSet`-                      [ idName mid-                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports-                      , idName pid `elemNameSet` (exports env) ] }--   add_inlines env =-     env{ inlines = inlines env `extendVarSetList`-                      [ mid-                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports-                      , isAnyInlinePragma (idInlinePragma pid) ] }---addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do-  env <- getEnv-  let dflags = tte_dflags env-  let name = getOccString id-  decl_path <- getPathEntry-  density <- getDensity--  inline_ids <- liftM inlines getEnv-  let inline   = isAnyInlinePragma (idInlinePragma id)-                 || id `elemVarSet` inline_ids--  -- See Note [inline sccs]-  if inline && gopt Opt_SccProfilingOn dflags then return (L pos funBind) else do--  (fvs, mg@(MG { mg_alts = matches' })) <--        getFreeVars $-        addPathEntry name $-        addTickMatchGroup False (fun_matches funBind)--  blackListed <- isBlackListed pos-  exported_names <- liftM exports getEnv--  -- We don't want to generate code for blacklisted positions-  -- We don't want redundant ticks on simple pattern bindings-  -- We don't want to tick non-exported bindings in TickExportedFunctions-  let simple = isSimplePatBind funBind-      toplev = null decl_path-      exported = idName id `elemNameSet` exported_names--  tick <- if not blackListed &&-               shouldTickBind density toplev exported simple inline-             then-                bindTick density name pos fvs-             else-                return Nothing--  return $ L pos $ funBind { fun_matches = mg { mg_alts = matches' }-                           , fun_tick = tick }--   where-   -- a binding is a simple pattern binding if it is a funbind with zero patterns-   isSimplePatBind :: HsBind a -> Bool-   isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0---- TODO: Revisit this-addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do-  let name = "(...)"-  (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs--  density <- getDensity-  decl_path <- getPathEntry-  let top_lev = null decl_path-  let add_ticks = shouldTickPatBind density top_lev--  tickish <- if add_ticks-                then bindTick density name pos fvs-                else return Nothing--  let patvars = map getOccString (collectPatBinders lhs)-  patvar_ticks <- if add_ticks-                     then mapM (\v -> bindTick density v pos fvs) patvars-                     else return []--  return $ L pos $ pat { pat_rhs = rhs',-                         pat_ticks = (tickish, patvar_ticks)}---- Only internal stuff, not from source, uses VarBind, so we ignore it.-addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind-addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind---bindTick :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))-bindTick density name pos fvs = do-  decl_path <- getPathEntry-  let-      toplev        = null decl_path-      count_entries = toplev || density == TickAllFunctions-      top_only      = density /= TickAllFunctions-      box_label     = if toplev then TopLevelBox [name]-                                else LocalBox (decl_path ++ [name])-  ---  allocATickBox box_label count_entries top_only pos fvs----- Note [inline sccs]------ It should be reasonable to add ticks to INLINE functions; however--- currently this tickles a bug later on because the SCCfinal pass--- does not look inside unfoldings to find CostCentres.  It would be--- difficult to fix that, because SCCfinal currently works on STG and--- not Core (and since it also generates CostCentres for CAFs,--- changing this would be difficult too).------ Another reason not to add ticks to INLINE functions is that this--- sometimes handy for avoiding adding a tick to a particular function--- (see #6131)------ So for now we do not add any ticks to INLINE functions at all.---- -------------------------------------------------------------------------------- Decorate an LHsExpr with ticks---- selectively add ticks to interesting expressions-addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)-addTickLHsExpr e@(L pos e0) = do-  d <- getDensity-  case d of-    TickForBreakPoints | isGoodBreakExpr e0 -> tick_it-    TickForCoverage    -> tick_it-    TickCallSites      | isCallSite e0      -> tick_it-    _other             -> dont_tick_it- where-   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0-   dont_tick_it = addTickLHsExprNever e---- Add a tick to an expression which is the RHS of an equation or a binding.--- We always consider these to be breakpoints, unless the expression is a 'let'--- (because the body will definitely have a tick somewhere).  ToDo: perhaps--- we should treat 'case' and 'if' the same way?-addTickLHsExprRHS :: LHsExpr Id -> TM (LHsExpr Id)-addTickLHsExprRHS e@(L pos e0) = do-  d <- getDensity-  case d of-     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it-                        | otherwise     -> tick_it-     TickForCoverage -> tick_it-     TickCallSites   | isCallSite e0 -> tick_it-     _other          -> dont_tick_it- where-   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0-   dont_tick_it = addTickLHsExprNever e---- The inner expression of an evaluation context:---    let binds in [], ( [] )--- we never tick these if we're doing HPC, but otherwise--- we treat it like an ordinary expression.-addTickLHsExprEvalInner :: LHsExpr Id -> TM (LHsExpr Id)-addTickLHsExprEvalInner e = do-   d <- getDensity-   case d of-     TickForCoverage -> addTickLHsExprNever e-     _otherwise      -> addTickLHsExpr e---- | A let body is treated differently from addTickLHsExprEvalInner--- above with TickForBreakPoints, because for breakpoints we always--- want to tick the body, even if it is not a redex.  See test--- break012.  This gives the user the opportunity to inspect the--- values of the let-bound variables.-addTickLHsExprLetBody :: LHsExpr Id -> TM (LHsExpr Id)-addTickLHsExprLetBody e@(L pos e0) = do-  d <- getDensity-  case d of-     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it-                        | otherwise     -> tick_it-     _other -> addTickLHsExprEvalInner e- where-   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0-   dont_tick_it = addTickLHsExprNever e---- version of addTick that does not actually add a tick,--- because the scope of this tick is completely subsumed by--- another.-addTickLHsExprNever :: LHsExpr Id -> TM (LHsExpr Id)-addTickLHsExprNever (L pos e0) = do-    e1 <- addTickHsExpr e0-    return $ L pos e1---- general heuristic: expressions which do not denote values are good break points-isGoodBreakExpr :: HsExpr Id -> Bool-isGoodBreakExpr (HsApp {})     = True-isGoodBreakExpr (OpApp {})     = True-isGoodBreakExpr (NegApp {})    = True-isGoodBreakExpr (HsIf {})      = True-isGoodBreakExpr (HsMultiIf {}) = True-isGoodBreakExpr (HsCase {})    = True-isGoodBreakExpr (RecordCon {}) = True-isGoodBreakExpr (RecordUpd {}) = True-isGoodBreakExpr (ArithSeq {})  = True-isGoodBreakExpr (PArrSeq {})   = True-isGoodBreakExpr _other         = False--isCallSite :: HsExpr Id -> Bool-isCallSite HsApp{}  = True-isCallSite OpApp{}  = True-isCallSite _ = False--addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)-addTickLHsExprOptAlt oneOfMany (L pos e0)-  = ifDensity TickForCoverage-        (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)-        (addTickLHsExpr (L pos e0))--addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)-addBinTickLHsExpr boxLabel (L pos e0)-  = ifDensity TickForCoverage-        (allocBinTickBox boxLabel pos $ addTickHsExpr e0)-        (addTickLHsExpr (L pos e0))----- -------------------------------------------------------------------------------- Decoarate an HsExpr with ticks--addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)-addTickHsExpr e@(HsVar id) = do freeVar id; return e-addTickHsExpr e@(HsIPVar _) = return e-addTickHsExpr e@(HsOverLit _) = return e-addTickHsExpr e@(HsLit _) = return e-addTickHsExpr (HsLam matchgroup) =-        liftM HsLam (addTickMatchGroup True matchgroup)-addTickHsExpr (HsLamCase ty mgs) =-        liftM (HsLamCase ty) (addTickMatchGroup True mgs)-addTickHsExpr (HsApp e1 e2) =-        liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2)-addTickHsExpr (OpApp e1 e2 fix e3) =-        liftM4 OpApp-                (addTickLHsExpr e1)-                (addTickLHsExprNever e2)-                (return fix)-                (addTickLHsExpr e3)-addTickHsExpr (NegApp e neg) =-        liftM2 NegApp-                (addTickLHsExpr e)-                (addTickSyntaxExpr hpcSrcSpan neg)-addTickHsExpr (HsPar e) =-        liftM HsPar (addTickLHsExprEvalInner e)-addTickHsExpr (SectionL e1 e2) =-        liftM2 SectionL-                (addTickLHsExpr e1)-                (addTickLHsExprNever e2)-addTickHsExpr (SectionR e1 e2) =-        liftM2 SectionR-                (addTickLHsExprNever e1)-                (addTickLHsExpr e2)-addTickHsExpr (ExplicitTuple es boxity) =-        liftM2 ExplicitTuple-                (mapM addTickTupArg es)-                (return boxity)-addTickHsExpr (HsCase e mgs) =-        liftM2 HsCase-                (addTickLHsExpr e) -- not an EvalInner; e might not necessarily-                                   -- be evaluated.-                (addTickMatchGroup False mgs)-addTickHsExpr (HsIf cnd e1 e2 e3) =-        liftM3 (HsIf cnd)-                (addBinTickLHsExpr (BinBox CondBinBox) e1)-                (addTickLHsExprOptAlt True e2)-                (addTickLHsExprOptAlt True e3)-addTickHsExpr (HsMultiIf ty alts)-  = do { let isOneOfMany = case alts of [_] -> False; _ -> True-       ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts-       ; return $ HsMultiIf ty alts' }-addTickHsExpr (HsLet binds e) =-        bindLocals (collectLocalBinders binds) $-        liftM2 HsLet-                (addTickHsLocalBinds binds) -- to think about: !patterns.-                (addTickLHsExprLetBody e)-addTickHsExpr (HsDo cxt stmts srcloc)-  = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())-       ; return (HsDo cxt stmts' srcloc) }-  where-        forQual = case cxt of-                    ListComp -> Just $ BinBox QualBinBox-                    _        -> Nothing-addTickHsExpr (ExplicitList ty wit es) =-        liftM3 ExplicitList-                (return ty)-                (addTickWit wit)-                (mapM (addTickLHsExpr) es) -             where addTickWit Nothing = return Nothing-                   addTickWit (Just fln) = do fln' <- addTickHsExpr fln-                                              return (Just fln')-addTickHsExpr (ExplicitPArr ty es) =-        liftM2 ExplicitPArr-                (return ty)-                (mapM (addTickLHsExpr) es)-addTickHsExpr (RecordCon id ty rec_binds) =-        liftM3 RecordCon-                (return id)-                (return ty)-                (addTickHsRecordBinds rec_binds)-addTickHsExpr (RecordUpd e rec_binds cons tys1 tys2) =-        liftM5 RecordUpd-                (addTickLHsExpr e)-                (addTickHsRecordBinds rec_binds)-                (return cons) (return tys1) (return tys2)--addTickHsExpr (ExprWithTySigOut e ty) =-        liftM2 ExprWithTySigOut-                (addTickLHsExprNever e) -- No need to tick the inner expression-                                    -- for expressions with signatures-                (return ty)-addTickHsExpr (ArithSeq  ty wit arith_seq) =-        liftM3 ArithSeq-                (return ty)-                (addTickWit wit)-                (addTickArithSeqInfo arith_seq)-             where addTickWit Nothing = return Nothing-                   addTickWit (Just fl) = do fl' <- addTickHsExpr fl-                                             return (Just fl')-addTickHsExpr (HsTickPragma _ (L pos e0)) = do-    e2 <- allocTickBox (ExpBox False) False False pos $-                addTickHsExpr e0-    return $ unLoc e2-addTickHsExpr (PArrSeq   ty arith_seq) =-        liftM2 PArrSeq-                (return ty)-                (addTickArithSeqInfo arith_seq)-addTickHsExpr (HsSCC nm e) =-        liftM2 HsSCC-                (return nm)-                (addTickLHsExpr e)-addTickHsExpr (HsCoreAnn nm e) =-        liftM2 HsCoreAnn-                (return nm)-                (addTickLHsExpr e)-addTickHsExpr e@(HsBracket     {})   = return e-addTickHsExpr e@(HsTcBracketOut  {}) = return e-addTickHsExpr e@(HsRnBracketOut  {}) = return e-addTickHsExpr e@(HsSpliceE  {})      = return e-addTickHsExpr (HsProc pat cmdtop) =-        liftM2 HsProc-                (addTickLPat pat)-                (liftL (addTickHsCmdTop) cmdtop)-addTickHsExpr (HsWrap w e) =-        liftM2 HsWrap-                (return w)-                (addTickHsExpr e)       -- explicitly no tick on inside--addTickHsExpr e@(HsType _) = return e-addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar"---- Others dhould never happen in expression content.-addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)--addTickTupArg :: HsTupArg Id -> TM (HsTupArg Id)-addTickTupArg (Present e)  = do { e' <- addTickLHsExpr e; return (Present e') }-addTickTupArg (Missing ty) = return (Missing ty)--addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id))-addTickMatchGroup is_lam mg@(MG { mg_alts = matches }) = do-  let isOneOfMany = matchesOneOfMany matches-  matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches-  return $ mg { mg_alts = matches' }--addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id))-addTickMatch isOneOfMany isLambda (Match pats opSig gRHSs) =-  bindLocals (collectPatsBinders pats) $ do-    gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs-    return $ Match pats opSig gRHSs'--addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id))-addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do-  bindLocals binders $ do-    local_binds' <- addTickHsLocalBinds local_binds-    guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded-    return $ GRHSs guarded' local_binds'-  where-    binders = collectLocalBinders local_binds--addTickGRHS :: Bool -> Bool -> GRHS Id (LHsExpr Id) -> TM (GRHS Id (LHsExpr Id))-addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do-  (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts-                        (addTickGRHSBody isOneOfMany isLambda expr)-  return $ GRHS stmts' expr'--addTickGRHSBody :: Bool -> Bool -> LHsExpr Id -> TM (LHsExpr Id)-addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do-  d <- getDensity-  case d of-    TickForCoverage  -> addTickLHsExprOptAlt isOneOfMany expr-    TickAllFunctions | isLambda ->-       addPathEntry "\\" $-         allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $-           addTickHsExpr e0-    _otherwise ->-       addTickLHsExprRHS expr--addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM [ExprLStmt Id]-addTickLStmts isGuard stmts = do-  (stmts, _) <- addTickLStmts' isGuard stmts (return ())-  return stmts--addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM a-               -> TM ([ExprLStmt Id], a)-addTickLStmts' isGuard lstmts res-  = bindLocals (collectLStmtsBinders lstmts) $-    do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts-       ; a <- res-       ; return (lstmts', a) }--addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id (LHsExpr Id) -> TM (Stmt Id (LHsExpr Id))-addTickStmt _isGuard (LastStmt e ret) = do-        liftM2 LastStmt-                (addTickLHsExpr e)-                (addTickSyntaxExpr hpcSrcSpan ret)-addTickStmt _isGuard (BindStmt pat e bind fail) = do-        liftM4 BindStmt-                (addTickLPat pat)-                (addTickLHsExprRHS e)-                (addTickSyntaxExpr hpcSrcSpan bind)-                (addTickSyntaxExpr hpcSrcSpan fail)-addTickStmt isGuard (BodyStmt e bind' guard' ty) = do-        liftM4 BodyStmt-                (addTick isGuard e)-                (addTickSyntaxExpr hpcSrcSpan bind')-                (addTickSyntaxExpr hpcSrcSpan guard')-                (return ty)-addTickStmt _isGuard (LetStmt binds) = do-        liftM LetStmt-                (addTickHsLocalBinds binds)-addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr) = do-    liftM3 ParStmt-        (mapM (addTickStmtAndBinders isGuard) pairs)-        (addTickSyntaxExpr hpcSrcSpan mzipExpr)-        (addTickSyntaxExpr hpcSrcSpan bindExpr)--addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts-                                    , trS_by = by, trS_using = using-                                    , trS_ret = returnExpr, trS_bind = bindExpr-                                    , trS_fmap = liftMExpr }) = do-    t_s <- addTickLStmts isGuard stmts-    t_y <- fmapMaybeM  addTickLHsExprRHS by-    t_u <- addTickLHsExprRHS using-    t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr-    t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr-    t_m <- addTickSyntaxExpr hpcSrcSpan liftMExpr-    return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u-                  , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }--addTickStmt isGuard stmt@(RecStmt {})-  = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)-       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)-       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)-       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)-       ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'-                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }--addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)-addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e-                  | otherwise          = addTickLHsExprRHS e--addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock Id Id-                      -> TM (ParStmtBlock Id Id)-addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =-    liftM3 ParStmtBlock-        (addTickLStmts isGuard stmts)-        (return ids)-        (addTickSyntaxExpr hpcSrcSpan returnExpr)--addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)-addTickHsLocalBinds (HsValBinds binds) =-        liftM HsValBinds-                (addTickHsValBinds binds)-addTickHsLocalBinds (HsIPBinds binds)  =-        liftM HsIPBinds-                (addTickHsIPBinds binds)-addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds--addTickHsValBinds :: HsValBindsLR Id a -> TM (HsValBindsLR Id b)-addTickHsValBinds (ValBindsOut binds sigs) =-        liftM2 ValBindsOut-                (mapM (\ (rec,binds') ->-                                liftM2 (,)-                                        (return rec)-                                        (addTickLHsBinds binds'))-                        binds)-                (return sigs)-addTickHsValBinds _ = panic "addTickHsValBinds"--addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id)-addTickHsIPBinds (IPBinds ipbinds dictbinds) =-        liftM2 IPBinds-                (mapM (liftL (addTickIPBind)) ipbinds)-                (return dictbinds)--addTickIPBind :: IPBind Id -> TM (IPBind Id)-addTickIPBind (IPBind nm e) =-        liftM2 IPBind-                (return nm)-                (addTickLHsExpr e)---- There is no location here, so we might need to use a context location??-addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)-addTickSyntaxExpr pos x = do-        L _ x' <- addTickLHsExpr (L pos x)-        return $ x'--- we do not walk into patterns.-addTickLPat :: LPat Id -> TM (LPat Id)-addTickLPat pat = return pat--addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id)-addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =-        liftM4 HsCmdTop-                (addTickLHsCmd cmd)-                (return tys)-                (return ty)-                (return syntaxtable)--addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)-addTickLHsCmd (L pos c0) = do-        c1 <- addTickHsCmd c0-        return $ L pos c1--addTickHsCmd :: HsCmd Id -> TM (HsCmd Id)-addTickHsCmd (HsCmdLam matchgroup) =-        liftM HsCmdLam (addTickCmdMatchGroup matchgroup)-addTickHsCmd (HsCmdApp c e) =-        liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e)-{--addTickHsCmd (OpApp e1 c2 fix c3) =-        liftM4 OpApp-                (addTickLHsExpr e1)-                (addTickLHsCmd c2)-                (return fix)-                (addTickLHsCmd c3)--}-addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e)-addTickHsCmd (HsCmdCase e mgs) =-        liftM2 HsCmdCase-                (addTickLHsExpr e)-                (addTickCmdMatchGroup mgs)-addTickHsCmd (HsCmdIf cnd e1 c2 c3) =-        liftM3 (HsCmdIf cnd)-                (addBinTickLHsExpr (BinBox CondBinBox) e1)-                (addTickLHsCmd c2)-                (addTickLHsCmd c3)-addTickHsCmd (HsCmdLet binds c) =-        bindLocals (collectLocalBinders binds) $-        liftM2 HsCmdLet-                (addTickHsLocalBinds binds) -- to think about: !patterns.-                (addTickLHsCmd c)-addTickHsCmd (HsCmdDo stmts srcloc)-  = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())-       ; return (HsCmdDo stmts' srcloc) }--addTickHsCmd (HsCmdArrApp   e1 e2 ty1 arr_ty lr) =-        liftM5 HsCmdArrApp-               (addTickLHsExpr e1)-               (addTickLHsExpr e2)-               (return ty1)-               (return arr_ty)-               (return lr)-addTickHsCmd (HsCmdArrForm e fix cmdtop) =-        liftM3 HsCmdArrForm-               (addTickLHsExpr e)-               (return fix)-               (mapM (liftL (addTickHsCmdTop)) cmdtop)--addTickHsCmd (HsCmdCast co cmd) -  = liftM2 HsCmdCast (return co) (addTickHsCmd cmd)---- Others should never happen in a command context.---addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)--addTickCmdMatchGroup :: MatchGroup Id (LHsCmd Id) -> TM (MatchGroup Id (LHsCmd Id))-addTickCmdMatchGroup mg@(MG { mg_alts = matches }) = do-  matches' <- mapM (liftL addTickCmdMatch) matches-  return $ mg { mg_alts = matches' }--addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id))-addTickCmdMatch (Match pats opSig gRHSs) =-  bindLocals (collectPatsBinders pats) $ do-    gRHSs' <- addTickCmdGRHSs gRHSs-    return $ Match pats opSig gRHSs'--addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id))-addTickCmdGRHSs (GRHSs guarded local_binds) = do-  bindLocals binders $ do-    local_binds' <- addTickHsLocalBinds local_binds-    guarded' <- mapM (liftL addTickCmdGRHS) guarded-    return $ GRHSs guarded' local_binds'-  where-    binders = collectLocalBinders local_binds--addTickCmdGRHS :: GRHS Id (LHsCmd Id) -> TM (GRHS Id (LHsCmd Id))--- The *guards* are *not* Cmds, although the body is--- C.f. addTickGRHS for the BinBox stuff-addTickCmdGRHS (GRHS stmts cmd)-  = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)-                                   stmts (addTickLHsCmd cmd)-       ; return $ GRHS stmts' expr' }--addTickLCmdStmts :: [LStmt Id (LHsCmd Id)] -> TM [LStmt Id (LHsCmd Id)]-addTickLCmdStmts stmts = do-  (stmts, _) <- addTickLCmdStmts' stmts (return ())-  return stmts--addTickLCmdStmts' :: [LStmt Id (LHsCmd Id)] -> TM a -> TM ([LStmt Id (LHsCmd Id)], a)-addTickLCmdStmts' lstmts res-  = bindLocals binders $ do-        lstmts' <- mapM (liftL addTickCmdStmt) lstmts-        a <- res-        return (lstmts', a)-  where-        binders = collectLStmtsBinders lstmts--addTickCmdStmt :: Stmt Id (LHsCmd Id) -> TM (Stmt Id (LHsCmd Id))-addTickCmdStmt (BindStmt pat c bind fail) = do-        liftM4 BindStmt-                (addTickLPat pat)-                (addTickLHsCmd c)-                (return bind)-                (return fail)-addTickCmdStmt (LastStmt c ret) = do-        liftM2 LastStmt-                (addTickLHsCmd c)-                (addTickSyntaxExpr hpcSrcSpan ret)-addTickCmdStmt (BodyStmt c bind' guard' ty) = do-        liftM4 BodyStmt-                (addTickLHsCmd c)-                (addTickSyntaxExpr hpcSrcSpan bind')-                (addTickSyntaxExpr hpcSrcSpan guard')-                (return ty)-addTickCmdStmt (LetStmt binds) = do-        liftM LetStmt-                (addTickHsLocalBinds binds)-addTickCmdStmt stmt@(RecStmt {})-  = do { stmts' <- addTickLCmdStmts (recS_stmts stmt)-       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)-       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)-       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)-       ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'-                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }---- Others should never happen in a command context.-addTickCmdStmt stmt  = pprPanic "addTickHsCmd" (ppr stmt)--addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)-addTickHsRecordBinds (HsRecFields fields dd)-  = do  { fields' <- mapM process fields-        ; return (HsRecFields fields' dd) }-  where-    process (HsRecField ids expr doc)-        = do { expr' <- addTickLHsExpr expr-             ; return (HsRecField ids expr' doc) }--addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)-addTickArithSeqInfo (From e1) =-        liftM From-                (addTickLHsExpr e1)-addTickArithSeqInfo (FromThen e1 e2) =-        liftM2 FromThen-                (addTickLHsExpr e1)-                (addTickLHsExpr e2)-addTickArithSeqInfo (FromTo e1 e2) =-        liftM2 FromTo-                (addTickLHsExpr e1)-                (addTickLHsExpr e2)-addTickArithSeqInfo (FromThenTo e1 e2 e3) =-        liftM3 FromThenTo-                (addTickLHsExpr e1)-                (addTickLHsExpr e2)-                (addTickLHsExpr e3)--liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a)-liftL f (L loc a) = do-  a' <- f a-  return $ L loc a'-\end{code}--\begin{code}-data TickTransState = TT { tickBoxCount:: Int-                         , mixEntries  :: [MixEntry_]-                         }--data TickTransEnv = TTE { fileName     :: FastString-                        , density      :: TickDensity-                        , tte_dflags   :: DynFlags-                        , exports      :: NameSet-                        , inlines      :: VarSet-                        , declPath     :: [String]-                        , inScope      :: VarSet-                        , blackList    :: Map SrcSpan ()-                        , this_mod     :: Module-                        , tickishType  :: TickishType-                        }----      deriving Show--data TickishType = ProfNotes | HpcTicks | Breakpoints----- | Tickishs that only make sense when their source code location--- refers to the current file. This might not always be true due to--- LINE pragmas in the code - which would confuse at least HPC.-tickSameFileOnly :: TickishType -> Bool-tickSameFileOnly HpcTicks = True-tickSameFileOnly _other   = False--type FreeVars = OccEnv Id-noFVs :: FreeVars-noFVs = emptyOccEnv---- Note [freevars]---   For breakpoints we want to collect the free variables of an---   expression for pinning on the HsTick.  We don't want to collect---   *all* free variables though: in particular there's no point pinning---   on free variables that are will otherwise be in scope at the GHCi---   prompt, which means all top-level bindings.  Unfortunately detecting---   top-level bindings isn't easy (collectHsBindsBinders on the top-level---   bindings doesn't do it), so we keep track of a set of "in-scope"---   variables in addition to the free variables, and the former is used---   to filter additions to the latter.  This gives us complete control---   over what free variables we track.--data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }-        -- a combination of a state monad (TickTransState) and a writer-        -- monad (FreeVars).--instance Functor TM where-    fmap = liftM--instance Applicative TM where-    pure = return-    (<*>) = ap--instance Monad TM where-  return a = TM $ \ _env st -> (a,noFVs,st)-  (TM m) >>= k = TM $ \ env st ->-                                case m env st of-                                  (r1,fv1,st1) ->-                                     case unTM (k r1) env st1 of-                                       (r2,fv2,st2) ->-                                          (r2, fv1 `plusOccEnv` fv2, st2)---- getState :: TM TickTransState--- getState = TM $ \ env st -> (st, noFVs, st)---- setState :: (TickTransState -> TickTransState) -> TM ()--- setState f = TM $ \ env st -> ((), noFVs, f st)--getEnv :: TM TickTransEnv-getEnv = TM $ \ env st -> (env, noFVs, st)--withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a-withEnv f (TM m) = TM $ \ env st ->-                                 case m (f env) st of-                                   (a, fvs, st') -> (a, fvs, st')--getDensity :: TM TickDensity-getDensity = TM $ \env st -> (density env, noFVs, st)--ifDensity :: TickDensity -> TM a -> TM a -> TM a-ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el--getFreeVars :: TM a -> TM (FreeVars, a)-getFreeVars (TM m)-  = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')--freeVar :: Id -> TM ()-freeVar id = TM $ \ env st ->-                if id `elemVarSet` inScope env-                   then ((), unitOccEnv (nameOccName (idName id)) id, st)-                   else ((), noFVs, st)--addPathEntry :: String -> TM a -> TM a-addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })--getPathEntry :: TM [String]-getPathEntry = declPath `liftM` getEnv--getFileName :: TM FastString-getFileName = fileName `liftM` getEnv--isGoodSrcSpan' :: SrcSpan -> Bool-isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos-isGoodSrcSpan' (UnhelpfulSpan _) = False--isGoodTickSrcSpan :: SrcSpan -> TM Bool-isGoodTickSrcSpan pos = do-  file_name <- getFileName-  tickish <- tickishType `liftM` getEnv-  let need_same_file = tickSameFileOnly tickish-      same_file      = Just file_name == srcSpanFileName_maybe pos-  return (isGoodSrcSpan' pos && (not need_same_file || same_file))--ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a-ifGoodTickSrcSpan pos then_code else_code = do-  good <- isGoodTickSrcSpan pos-  if good then then_code else else_code--bindLocals :: [Id] -> TM a -> TM a-bindLocals new_ids (TM m)-  = TM $ \ env st ->-                 case m env{ inScope = inScope env `extendVarSetList` new_ids } st of-                   (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')-  where occs = [ nameOccName (idName id) | id <- new_ids ]--isBlackListed :: SrcSpan -> TM Bool-isBlackListed pos = TM $ \ env st ->-              case Map.lookup pos (blackList env) of-                Nothing -> (False,noFVs,st)-                Just () -> (True,noFVs,st)---- the tick application inherits the source position of its--- expression argument to support nested box allocations-allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr Id)-             -> TM (LHsExpr Id)-allocTickBox boxLabel countEntries topOnly pos m =-  ifGoodTickSrcSpan pos (do-    (fvs, e) <- getFreeVars m-    env <- getEnv-    tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)-    return (L pos (HsTick tickish (L pos e)))-  ) (do-    e <- m-    return (L pos e)-  )---- the tick application inherits the source position of its--- expression argument to support nested box allocations-allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars-              -> TM (Maybe (Tickish Id))-allocATickBox boxLabel countEntries topOnly  pos fvs =-  ifGoodTickSrcSpan pos (do-    let-      mydecl_path = case boxLabel of-                      TopLevelBox x -> x-                      LocalBox xs  -> xs-                      _ -> panic "allocATickBox"-    tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path-    return (Just tickish)-  ) (return Nothing)---mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]-          -> TM (Tickish Id)-mkTickish boxLabel countEntries topOnly pos fvs decl_path =-  TM $ \ env st ->-    let c = tickBoxCount st-        ids = filter (not . isUnLiftedType . idType) $ occEnvElts fvs-            -- unlifted types cause two problems here:-            --   * we can't bind them  at the GHCi prompt-            --     (bindLocalsAtBreakpoint already fliters them out),-            --   * the simplifier might try to substitute a literal for-            --     the Id, and we can't handle that.--        mes = mixEntries st-        me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel)--        cc_name | topOnly   = head decl_path-                | otherwise = concat (intersperse "." decl_path)--        cc = mkUserCC (mkFastString cc_name) (this_mod env) pos (mkCostCentreUnique c)--        dflags = tte_dflags env--        count = countEntries && gopt Opt_ProfCountEntries dflags--        tickish = case tickishType env of-          HpcTicks    -> HpcTick (this_mod env) c-          ProfNotes   -> ProfNote cc count True{-scopes-}-          Breakpoints -> Breakpoint c ids-    in-    ( tickish-    , fvs-    , st {tickBoxCount=c+1,mixEntries=me:mes}-    )---allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr Id)-                -> TM (LHsExpr Id)-allocBinTickBox boxLabel pos m = do-  env <- getEnv-  case tickishType env of-    HpcTicks -> do e <- liftM (L pos) m-                   ifGoodTickSrcSpan pos-                     (mkBinTickBoxHpc boxLabel pos e)-                     (return e)-    _other   -> allocTickBox (ExpBox False) False False pos m--mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr Id-                -> TM (LHsExpr Id)-mkBinTickBoxHpc boxLabel pos e =- TM $ \ env st ->-  let meT = (pos,declPath env, [],boxLabel True)-      meF = (pos,declPath env, [],boxLabel False)-      meE = (pos,declPath env, [],ExpBox False)-      c = tickBoxCount st-      mes = mixEntries st-  in-             ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) e-           -- notice that F and T are reversed,-           -- because we are building the list in-           -- reverse...-             , noFVs-             , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}-             )--mkHpcPos :: SrcSpan -> HpcPos-mkHpcPos pos@(RealSrcSpan s)-   | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,-                                    srcSpanStartCol s,-                                    srcSpanEndLine s,-                                    srcSpanEndCol s - 1)-                              -- the end column of a SrcSpan is one-                              -- greater than the last column of the-                              -- span (see SrcLoc), whereas HPC-                              -- expects to the column range to be-                              -- inclusive, hence we subtract one above.-mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"--hpcSrcSpan :: SrcSpan-hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")-\end{code}---\begin{code}-matchesOneOfMany :: [LMatch Id body] -> Bool-matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1-  where-        matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss-\end{code}---\begin{code}-type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)---- For the hash value, we hash everything: the file name,---  the timestamp of the original source file, the tab stop,---  and the mix entries. We cheat, and hash the show'd string.--- This hash only has to be hashed at Mix creation time,--- and is for sanity checking only.--mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int-mixHash file tm tabstop entries = fromIntegral $ hashString-        (show $ Mix file tm 0 tabstop entries)-\end{code}--%************************************************************************-%*                                                                      *-%*              initialisation-%*                                                                      *-%************************************************************************--Each module compiled with -fhpc declares an initialisation function of-the form `hpc_init_<module>()`, which is emitted into the _stub.c file-and annotated with __attribute__((constructor)) so that it gets-executed at startup time.--The function's purpose is to call hs_hpc_module to register this-module with the RTS, and it looks something like this:--static void hpc_init_Main(void) __attribute__((constructor));-static void hpc_init_Main(void)-{extern StgWord64 _hpc_tickboxes_Main_hpc[];- hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);}--\begin{code}-hpcInitCode :: Module -> HpcInfo -> SDoc-hpcInitCode _ (NoHpcInfo {}) = empty-hpcInitCode this_mod (HpcInfo tickCount hashNo)- = vcat-    [ text "static void hpc_init_" <> ppr this_mod-         <> text "(void) __attribute__((constructor));"-    , text "static void hpc_init_" <> ppr this_mod <> text "(void)"-    , braces (vcat [-        ptext (sLit "extern StgWord64 ") <> tickboxes <>-               ptext (sLit "[]") <> semi,-        ptext (sLit "hs_hpc_module") <>-          parens (hcat (punctuate comma [-              doubleQuotes full_name_str,-              int tickCount, -- really StgWord32-              int hashNo,    -- really StgWord32-              tickboxes-            ])) <> semi-       ])-    ]-  where-    tickboxes = ppr (mkHpcTicksLabel $ this_mod)--    module_name  = hcat (map (text.charToC) $-                         bytesFS (moduleNameFS (Module.moduleName this_mod)))-    package_name = hcat (map (text.charToC) $-                         bytesFS (packageIdFS  (modulePackageId this_mod)))-    full_name_str-       | modulePackageId this_mod == mainPackageId-       = module_name-       | otherwise-       = package_name <> char '/' <> module_name-\end{code}
− src/Language/Haskell/Liquid/Desugar/Desugar.lhs 
@@ -1,440 +0,0 @@-%-% (c) The University of Glasgow 2006-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998-%--The Desugarer: turning HsSyn into Core.--\begin{code}-module Language.Haskell.Liquid.Desugar.Desugar ( deSugarWithLoc, deSugar, deSugarExpr ) where--import DynFlags-import HscTypes-import HsSyn-import TcRnTypes-import TcRnMonad ( finalSafeMode )-import MkIface-import Id-import Name-import Type-import FamInstEnv-import InstEnv-import Class-import Avail-import PatSyn-import CoreSyn-import CoreSubst-import PprCore-import DsMonad-import Language.Haskell.Liquid.Desugar.DsExpr-import Language.Haskell.Liquid.Desugar.DsBinds-import Language.Haskell.Liquid.Desugar.DsForeign-import Module-import NameSet-import NameEnv-import Rules-import BasicTypes       ( Activation(.. ) )-import CoreMonad        ( endPass, CoreToDo(..) )-import FastString-import ErrUtils-import Outputable-import SrcLoc-import Coverage-import Util-import MonadUtils-import OrdList-import Data.List-import Data.IORef-import Control.Monad( when )-\end{code}--%************************************************************************-%*                                                                      *-%*              The main function: deSugar-%*                                                                      *-%************************************************************************--\begin{code}--- | Main entry point to the desugarer.-deSugarWithLoc, deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)--- Can modify PCS by faulting in more declarations--deSugarWithLoc = deSugar --deSugar hsc_env-        mod_loc-        tcg_env@(TcGblEnv { tcg_mod          = mod,-                            tcg_src          = hsc_src,-                            tcg_type_env     = type_env,-                            tcg_imports      = imports,-                            tcg_exports      = exports,-                            tcg_keep         = keep_var,-                            tcg_th_splice_used = tc_splice_used,-                            tcg_rdr_env      = rdr_env,-                            tcg_fix_env      = fix_env,-                            tcg_inst_env     = inst_env,-                            tcg_fam_inst_env = fam_inst_env,-                            tcg_warns        = warns,-                            tcg_anns         = anns,-                            tcg_binds        = binds,-                            tcg_imp_specs    = imp_specs,-                            tcg_dependent_files = dependent_files,-                            tcg_ev_binds     = ev_binds,-                            tcg_fords        = fords,-                            tcg_rules        = rules,-                            tcg_vects        = vects,-                            tcg_patsyns      = patsyns,-                            tcg_tcs          = tcs,-                            tcg_insts        = insts,-                            tcg_fam_insts    = fam_insts,-                            tcg_hpc          = other_hpc_info })--  = do { let dflags = hsc_dflags hsc_env-        ; showPass dflags "Desugar"--        -- Desugar the program-        ; let export_set = availsToNameSet exports-              target     = hscTarget dflags-              hpcInfo    = emptyHpcInfo other_hpc_info-              want_ticks = gopt Opt_Hpc dflags-                        || target == HscInterpreted-                        || (gopt Opt_SccProfilingOn dflags-                            && case profAuto dflags of-                                 NoProfAuto -> False-                                 _          -> True)--        ; (binds_cvr, ds_hpc_info, modBreaks)-                         <- if want_ticks && not (isHsBoot hsc_src)-                              then addTicksToBinds dflags mod mod_loc export_set-                                          (typeEnvTyCons type_env) binds-                              else return (binds, hpcInfo, emptyModBreaks)--        ; (msgs, mb_res) <- initDs hsc_env mod rdr_env type_env fam_inst_env $-                       do { ds_ev_binds <- dsEvBinds ev_binds-                          ; core_prs <- dsTopLHsBinds binds_cvr-                          ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs-                          ; (ds_fords, foreign_prs) <- dsForeigns fords-                          ; ds_rules <- mapMaybeM dsRule rules-                          ; ds_vects <- mapM dsVect vects-                          ; let hpc_init-                                  | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info-                                  | otherwise = empty-                          ; return ( ds_ev_binds-                                   , foreign_prs `appOL` core_prs `appOL` spec_prs-                                   , spec_rules ++ ds_rules, ds_vects-                                   , ds_fords `appendStubC` hpc_init) }--        ; case mb_res of {-           Nothing -> return (msgs, Nothing) ;-           Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) -> do--     do {       -- Add export flags to bindings-          keep_alive <- readIORef keep_var-        ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules-              final_prs = addExportFlagsAndRules target export_set keep_alive-                                                 rules_for_locals (fromOL all_prs)--              final_pgm = combineEvBinds ds_ev_binds final_prs-        -- Notice that we put the whole lot in a big Rec, even the foreign binds-        -- When compiling PrelFloat, which defines data Float = F# Float#-        -- we want F# to be in scope in the foreign marshalling code!-        -- You might think it doesn't matter, but the simplifier brings all top-level-        -- things into the in-scope set before simplifying; so we get no unfolding for F#!--        ; (ds_binds, ds_rules_for_imps, ds_vects)-            <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0-                         -- The simpleOptPgm gets rid of type-                         -- bindings plus any stupid dead code--        ; endPass hsc_env CoreDesugarOpt ds_binds ds_rules_for_imps--        ; let used_names = mkUsedNames tcg_env-        ; deps <- mkDependencies tcg_env--        ; used_th <- readIORef tc_splice_used-        ; dep_files <- readIORef dependent_files-        ; safe_mode <- finalSafeMode dflags tcg_env--        ; let mod_guts = ModGuts {-                mg_module       = mod,-                mg_boot         = isHsBoot hsc_src,-                mg_exports      = exports,-                mg_deps         = deps,-                mg_used_names   = used_names,-                mg_used_th      = used_th,-                mg_dir_imps     = imp_mods imports,-                mg_rdr_env      = rdr_env,-                mg_fix_env      = fix_env,-                mg_warns        = warns,-                mg_anns         = anns,-                mg_tcs          = tcs,-                mg_insts        = insts,-                mg_fam_insts    = fam_insts,-                mg_inst_env     = inst_env,-                mg_fam_inst_env = fam_inst_env,-                mg_patsyns      = filter ((`elemNameSet` export_set) . patSynName) patsyns,-                mg_rules        = ds_rules_for_imps,-                mg_binds        = ds_binds,-                mg_foreign      = ds_fords,-                mg_hpc_info     = ds_hpc_info,-                mg_modBreaks    = modBreaks,-                mg_vect_decls   = ds_vects,-                mg_vect_info    = noVectInfo,-                mg_safe_haskell = safe_mode,-                mg_trust_pkg    = imp_trust_own_pkg imports,-                mg_dependent_files = dep_files-              }-        ; return (msgs, Just mod_guts)-        }}}--dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])-dsImpSpecs imp_specs- = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs-      ; let (spec_binds, spec_rules) = unzip spec_prs-      ; return (concatOL spec_binds, spec_rules) }--combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]--- Top-level bindings can include coercion bindings, but not via superclasses--- See Note [Top-level evidence]-combineEvBinds [] val_prs-  = [Rec val_prs]-combineEvBinds (NonRec b r : bs) val_prs-  | isId b    = combineEvBinds bs ((b,r):val_prs)-  | otherwise = NonRec b r : combineEvBinds bs val_prs-combineEvBinds (Rec prs : bs) val_prs-  = combineEvBinds bs (prs ++ val_prs)-\end{code}--Note [Top-level evidence]-~~~~~~~~~~~~~~~~~~~~~~~~~-Top-level evidence bindings may be mutually recursive with the top-level value-bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec-because the occurrence analyser doesn't teke account of type/coercion variables-when computing dependencies.--So we pull out the type/coercion variables (which are in dependency order),-and Rec the rest.---\begin{code}-deSugarExpr :: HscEnv -> LHsExpr Id -> IO (Messages, Maybe CoreExpr)--deSugarExpr hsc_env tc_expr-  = do { let dflags       = hsc_dflags hsc_env-             icntxt       = hsc_IC hsc_env-             rdr_env      = ic_rn_gbl_env icntxt-             type_env     = mkTypeEnvWithImplicits (ic_tythings icntxt)-             fam_insts    = snd (ic_instances icntxt)-             fam_inst_env = extendFamInstEnvList emptyFamInstEnv fam_insts-             -- This stuff is a half baked version of TcRnDriver.setInteractiveContext--       ; showPass dflags "Desugar"--         -- Do desugaring-       ; (msgs, mb_core_expr) <- initDs hsc_env (icInteractiveModule icntxt) rdr_env-                                        type_env fam_inst_env $-                                 dsLExpr tc_expr--       ; case mb_core_expr of-            Nothing   -> return ()-            Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)--       ; return (msgs, mb_core_expr) }-\end{code}--%************************************************************************-%*                                                                      *-%*              Add rules and export flags to binders-%*                                                                      *-%************************************************************************--\begin{code}-addExportFlagsAndRules-    :: HscTarget -> NameSet -> NameSet -> [CoreRule]-    -> [(Id, t)] -> [(Id, t)]-addExportFlagsAndRules target exports keep_alive rules prs-  = mapFst add_one prs-  where-    add_one bndr = add_rules name (add_export name bndr)-       where-         name = idName bndr--    ---------- Rules ---------        -- See Note [Attach rules to local ids]-        -- NB: the binder might have some existing rules,-        -- arising from specialisation pragmas-    add_rules name bndr-        | Just rules <- lookupNameEnv rule_base name-        = bndr `addIdSpecialisations` rules-        | otherwise-        = bndr-    rule_base = extendRuleBaseList emptyRuleBase rules--    ---------- Export flag ---------    -- See Note [Adding export flags]-    add_export name bndr-        | dont_discard name = setIdExported bndr-        | otherwise         = bndr--    dont_discard :: Name -> Bool-    dont_discard name = is_exported name-                     || name `elemNameSet` keep_alive--        -- In interactive mode, we don't want to discard any top-level-        -- entities at all (eg. do not inline them away during-        -- simplification), and retain them all in the TypeEnv so they are-        -- available from the command line.-        ---        -- isExternalName separates the user-defined top-level names from those-        -- introduced by the type checker.-    is_exported :: Name -> Bool-    is_exported | targetRetainsAllBindings target = isExternalName-                | otherwise                       = (`elemNameSet` exports)-\end{code}---Note [Adding export flags]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Set the no-discard flag if either-        a) the Id is exported-        b) it's mentioned in the RHS of an orphan rule-        c) it's in the keep-alive set--It means that the binding won't be discarded EVEN if the binding-ends up being trivial (v = w) -- the simplifier would usually just-substitute w for v throughout, but we don't apply the substitution to-the rules (maybe we should?), so this substitution would make the rule-bogus.--You might wonder why exported Ids aren't already marked as such;-it's just because the type checker is rather busy already and-I didn't want to pass in yet another mapping.--Note [Attach rules to local ids]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Find the rules for locally-defined Ids; then we can attach them-to the binders in the top-level bindings--Reason-  - It makes the rules easier to look up-  - It means that transformation rules and specialisations for-    locally defined Ids are handled uniformly-  - It keeps alive things that are referred to only from a rule-    (the occurrence analyser knows about rules attached to Ids)-  - It makes sure that, when we apply a rule, the free vars-    of the RHS are more likely to be in scope-  - The imported rules are carried in the in-scope set-    which is extended on each iteration by the new wave of-    local binders; any rules which aren't on the binding will-    thereby get dropped---%************************************************************************-%*                                                                      *-%*              Desugaring transformation rules-%*                                                                      *-%************************************************************************--\begin{code}-dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)-dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))-  = putSrcSpanDs loc $-    do  { let bndrs' = [var | RuleBndr (L _ var) <- vars]--        ; lhs' <- unsetGOptM Opt_EnableRewriteRules $-                  unsetWOptM Opt_WarnIdentities $-                  dsLExpr lhs   -- Note [Desugaring RULE left hand sides]--        ; rhs' <- dsLExpr rhs-        ; dflags <- getDynFlags--        -- Substitute the dict bindings eagerly,-        -- and take the body apart into a (f args) form-        ; case decomposeRuleLhs bndrs' lhs' of {-                Left msg -> do { warnDs msg; return Nothing } ;-                Right (final_bndrs, fn_id, args) -> do--        { let is_local = isLocalId fn_id-                -- NB: isLocalId is False of implicit Ids.  This is good because-                -- we don't want to attach rules to the bindings of implicit Ids,-                -- because they don't show up in the bindings until just before code gen-              fn_name   = idName fn_id-              final_rhs = simpleOptExpr rhs'    -- De-crap it-              rule      = mkRule False {- Not auto -} is_local-                                 name act fn_name final_bndrs args final_rhs--              inline_shadows_rule   -- Function can be inlined before rule fires-                | wopt Opt_WarnInlineRuleShadowing dflags-                , isLocalId fn_id || hasSomeUnfolding (idUnfolding fn_id)   -                       -- If imported with no unfolding, no worries-                = case (idInlineActivation fn_id, act) of-                    (NeverActive, _)    -> False-                    (AlwaysActive, _)   -> True-                    (ActiveBefore {}, _) -> True-                    (ActiveAfter {}, NeverActive)     -> True-                    (ActiveAfter n, ActiveAfter r)    -> r < n  -- Rule active strictly first-                    (ActiveAfter {}, AlwaysActive)    -> False-                    (ActiveAfter {}, ActiveBefore {}) -> False-                | otherwise = False--        ; when inline_shadows_rule $-          warnDs (vcat [ hang (ptext (sLit "Rule") <+> doubleQuotes (ftext name)-                               <+> ptext (sLit "may never fire"))-                            2 (ptext (sLit "because") <+> quotes (ppr fn_id)-                               <+> ptext (sLit "might inline first"))-                       , ptext (sLit "Probable fix: add an INLINE[n] or NOINLINE[n] pragma on")-                         <+> quotes (ppr fn_id) ])--        ; return (Just rule)-        } } }-\end{code}--Note [Desugaring RULE left hand sides]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For the LHS of a RULE we do *not* want to desugar-    [x]   to    build (\cn. x `c` n)-We want to leave explicit lists simply as chains-of cons's. We can achieve that slightly indirectly by-switching off EnableRewriteRules.  See DsExpr.dsExplicitList.--That keeps the desugaring of list comprehensions simple too.----Nor do we want to warn of conversion identities on the LHS;-the rule is precisly to optimise them:-  {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}---%************************************************************************-%*                                                                      *-%*              Desugaring vectorisation declarations-%*                                                                      *-%************************************************************************--\begin{code}-dsVect :: LVectDecl Id -> DsM CoreVect-dsVect (L loc (HsVect (L _ v) rhs))-  = putSrcSpanDs loc $-    do { rhs' <- dsLExpr rhs-       ; return $ Vect v rhs'-       }-dsVect (L _loc (HsNoVect (L _ v)))-  = return $ NoVect v-dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))-  = return $ VectType isScalar tycon' rhs_tycon-  where-    tycon' | Just ty <- coreView $ mkTyConTy tycon-           , (tycon', []) <- splitTyConApp ty      = tycon'-           | otherwise                             = tycon-dsVect vd@(L _ (HsVectTypeIn _ _ _))-  = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)-dsVect (L _loc (HsVectClassOut cls))-  = return $ VectClass (classTyCon cls)-dsVect vc@(L _ (HsVectClassIn _))-  = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc)-dsVect (L _loc (HsVectInstOut inst))-  = return $ VectInst (instanceDFunId inst)-dsVect vi@(L _ (HsVectInstIn _))-  = pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi)-\end{code}
− src/Language/Haskell/Liquid/Desugar/DsArrows.lhs 
@@ -1,1202 +0,0 @@-%-% (c) The University of Glasgow 2006-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998-%--Desugaring arrow commands--\begin{code}-{-# OPTIONS -fno-warn-tabs #-}--- The above warning supression flag is a temporary kludge.--- While working on this module you are encouraged to remove it and--- detab the module (please do the detabbing in a separate patch). See---     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces--- for details--module Language.Haskell.Liquid.Desugar.DsArrows ( dsProcExpr ) where---- #include "HsVersions.h"--import Language.Haskell.Liquid.Desugar.Match-import Language.Haskell.Liquid.Desugar.DsUtils-import DsMonad--import HsSyn	hiding (collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectLStmtBinders, collectStmtBinders )-import TcHsSyn---- NB: The desugarer, which straddles the source and Core worlds, sometimes---     needs to see source types (newtypes etc), and sometimes not---     So WATCH OUT; check each use of split*Ty functions.--- Sigh.  This is a pain.--import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr ( dsExpr, dsLExpr, dsLocalBinds )--import TcType-import TcEvidence-import CoreSyn-import CoreFVs-import CoreUtils-import MkCore-import Language.Haskell.Liquid.Desugar.DsBinds (dsHsWrapper)--import Name-import Var-import Id-import DataCon-import TysWiredIn-import BasicTypes-import PrelNames-import Outputable-import Bag-import VarSet-import SrcLoc-import ListSetOps( assocDefault )-import FastString-import Data.List-\end{code}--\begin{code}-data DsCmdEnv = DsCmdEnv {-	arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr-    }--mkCmdEnv :: CmdSyntaxTable Id -> DsM ([CoreBind], DsCmdEnv)--- See Note [CmdSyntaxTable] in HsExpr-mkCmdEnv tc_meths-  = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths-       ; return (meth_binds, DsCmdEnv {-               arr_id     = Var (find_meth prs arrAName),-               compose_id = Var (find_meth prs composeAName),-               first_id   = Var (find_meth prs firstAName),-               app_id     = Var (find_meth prs appAName),-               choice_id  = Var (find_meth prs choiceAName),-               loop_id    = Var (find_meth prs loopAName)-             }) }-  where-    mk_bind (std_name, expr)-      = do { rhs <- dsExpr expr-           ; id <- newSysLocalDs (exprType rhs)-           ; return (NonRec id rhs, (std_name, id)) }- -    find_meth prs std_name-      = assocDefault (mk_panic std_name) prs std_name-    mk_panic std_name = pprPanic "mkCmdEnv" (ptext (sLit "Not found:") <+> ppr std_name)---- arr :: forall b c. (b -> c) -> a b c-do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr-do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f]---- (>>>) :: forall b c d. a b c -> a c d -> a b d-do_compose :: DsCmdEnv -> Type -> Type -> Type ->-		CoreExpr -> CoreExpr -> CoreExpr-do_compose ids b_ty c_ty d_ty f g-  = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g]---- first :: forall b c d. a b c -> a (b,d) (c,d)-do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr-do_first ids b_ty c_ty d_ty f-  = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f]---- app :: forall b c. a (a b c, b) c-do_app :: DsCmdEnv -> Type -> Type -> CoreExpr-do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty]---- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d--- note the swapping of d and c-do_choice :: DsCmdEnv -> Type -> Type -> Type ->-		CoreExpr -> CoreExpr -> CoreExpr-do_choice ids b_ty c_ty d_ty f g-  = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g]---- loop :: forall b d c. a (b,d) (c,d) -> a b c--- note the swapping of d and c-do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr-do_loop ids b_ty c_ty d_ty f-  = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f]---- premap :: forall b c d. (b -> c) -> a c d -> a b d--- premap f g = arr f >>> g-do_premap :: DsCmdEnv -> Type -> Type -> Type ->-		CoreExpr -> CoreExpr -> CoreExpr-do_premap ids b_ty c_ty d_ty f g-   = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g--mkFailExpr :: HsMatchContext Id -> Type -> DsM CoreExpr-mkFailExpr ctxt ty-  = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)---- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a-mkFstExpr :: Type -> Type -> DsM CoreExpr-mkFstExpr a_ty b_ty = do-    a_var <- newSysLocalDs a_ty-    b_var <- newSysLocalDs b_ty-    pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)-    return (Lam pair_var-               (coreCasePair pair_var a_var b_var (Var a_var)))---- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b-mkSndExpr :: Type -> Type -> DsM CoreExpr-mkSndExpr a_ty b_ty = do-    a_var <- newSysLocalDs a_ty-    b_var <- newSysLocalDs b_ty-    pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)-    return (Lam pair_var-               (coreCasePair pair_var a_var b_var (Var b_var)))-\end{code}--Build case analysis of a tuple.  This cannot be done in the DsM monad,-because the list of variables is typically not yet defined.--\begin{code}--- coreCaseTuple [u1..] v [x1..xn] body---	= case v of v { (x1, .., xn) -> body }--- But the matching may be nested if the tuple is very big--coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr-coreCaseTuple uniqs scrut_var vars body-  = mkTupleCase uniqs vars body scrut_var (Var scrut_var)--coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr-coreCasePair scrut_var var1 var2 body-  = Case (Var scrut_var) scrut_var (exprType body)-         [(DataAlt (tupleCon BoxedTuple 2), [var1, var2], body)]-\end{code}--\begin{code}-mkCorePairTy :: Type -> Type -> Type-mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2]--mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr-mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]--mkCoreUnitExpr :: CoreExpr-mkCoreUnitExpr = mkCoreTup []-\end{code}--The input is divided into a local environment, which is a flat tuple-(unless it's too big), and a stack, which is a right-nested pair.-In general, the input has the form--	((x1,...,xn), (s1,...(sk,())...))--where xi are the environment values, and si the ones on the stack,-with s1 being the "top", the first one to be matched with a lambda.--\begin{code}-envStackType :: [Id] -> Type -> Type-envStackType ids stack_ty = mkCorePairTy (mkBigCoreVarTupTy ids) stack_ty---- splitTypeAt n (t1,... (tn,t)...) = ([t1, ..., tn], t)-splitTypeAt :: Int -> Type -> ([Type], Type)-splitTypeAt n ty-  | n == 0 = ([], ty)-  | otherwise = case tcTyConAppArgs ty of-      [t, ty'] -> let (ts, ty_r) = splitTypeAt (n-1) ty' in (t:ts, ty_r)-      _ -> pprPanic "splitTypeAt" (ppr ty)---------------------------------------------------		buildEnvStack------	((x1,...,xn),stk)--buildEnvStack :: [Id] -> Id -> CoreExpr-buildEnvStack env_ids stack_id-  = mkCorePairExpr (mkBigCoreVarTup env_ids) (Var stack_id)--------------------------------------------------- 		matchEnvStack------	\ ((x1,...,xn),stk) -> body---	=>---	\ pair ->---	case pair of (tup,stk) ->---	case tup of (x1,...,xn) ->---	body--matchEnvStack	:: [Id] 	-- x1..xn-		-> Id	 	-- stk-		-> CoreExpr 	-- e-		-> DsM CoreExpr-matchEnvStack env_ids stack_id body = do-    uniqs <- newUniqueSupply-    tup_var <- newSysLocalDs (mkBigCoreVarTupTy env_ids)-    let match_env = coreCaseTuple uniqs tup_var env_ids body-    pair_id <- newSysLocalDs (mkCorePairTy (idType tup_var) (idType stack_id))-    return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env))--------------------------------------------------- 		matchEnv------	\ (x1,...,xn) -> body---	=>---	\ tup ->---	case tup of (x1,...,xn) ->---	body--matchEnv :: [Id] 	-- x1..xn-	 -> CoreExpr 	-- e-	 -> DsM CoreExpr-matchEnv env_ids body = do-    uniqs <- newUniqueSupply-    tup_id <- newSysLocalDs (mkBigCoreVarTupTy env_ids)-    return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body))---------------------------------------------------		matchVarStack------	case (x1, ...(xn, s)...) -> e---	=>---	case z0 of (x1,z1) ->---	case zn-1 of (xn,s) ->---	e-matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr)-matchVarStack [] stack_id body = return (stack_id, body)-matchVarStack (param_id:param_ids) stack_id body = do-    (tail_id, tail_code) <- matchVarStack param_ids stack_id body-    pair_id <- newSysLocalDs (mkCorePairTy (idType param_id) (idType tail_id))-    return (pair_id, coreCasePair pair_id param_id tail_id tail_code)-\end{code}--\begin{code}-mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr Id-mkHsEnvStackExpr env_ids stack_id-  = mkLHsTupleExpr [mkLHsVarTuple env_ids, nlHsVar stack_id]-\end{code}--Translation of arrow abstraction--\begin{code}---- D; xs |-a c : () --> t'  	---> c'--- ----------------------------- D |- proc p -> c :: a t t'	---> premap (\ p -> ((xs),())) c'------		where (xs) is the tuple of variables bound by p--dsProcExpr-	:: LPat Id-	-> LHsCmdTop Id-	-> DsM CoreExpr-dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do-    (meth_binds, meth_ids) <- mkCmdEnv ids-    let locals = mkVarSet (collectPatBinders pat)-    (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals unitTy cmd_ty cmd-    let env_ty = mkBigCoreVarTupTy env_ids-    let env_stk_ty = mkCorePairTy env_ty unitTy-    let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr-    fail_expr <- mkFailExpr ProcExpr env_stk_ty-    var <- selectSimpleMatchVarL pat-    match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr-    let pat_ty = hsLPatType pat-        proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty-                    (Lam var match_code)-                    core_cmd-    return (mkLets meth_binds proc_code)-\end{code}--Translation of a command judgement of the form--	D; xs |-a c : stk --> t--to an expression e such that--	D |- e :: a (xs, stk) t--\begin{code}-dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd Id -> [Id]-       -> DsM (CoreExpr, IdSet)-dsLCmd ids local_vars stk_ty res_ty cmd env_ids-  = dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids--dsCmd   :: DsCmdEnv		-- arrow combinators-	-> IdSet		-- set of local vars available to this command-	-> Type			-- type of the stack (right-nested tuple)-	-> Type			-- return type of the command-	-> HsCmd Id		-- command to desugar-	-> [Id]			-- list of vars in the input to this command-				-- This is typically fed back,-				-- so don't pull on it too early-	-> DsM (CoreExpr,	-- desugared expression-		IdSet)		-- subset of local vars that occur free---- D |- fun :: a t1 t2--- D, xs |- arg :: t1--- -------------------------------- D; xs |-a fun -< arg : stk --> t2------		---> premap (\ ((xs), _stk) -> arg) fun--dsCmd ids local_vars stack_ty res_ty-        (HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _)-        env_ids = do-    let-        (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty-        (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty-    core_arrow <- dsLExpr arrow-    core_arg   <- dsLExpr arg-    stack_id   <- newSysLocalDs stack_ty-    core_make_arg <- matchEnvStack env_ids stack_id core_arg-    return (do_premap ids-              (envStackType env_ids stack_ty)-              arg_ty-              res_ty-              core_make_arg-              core_arrow,-            exprFreeIds core_arg `intersectVarSet` local_vars)---- D, xs |- fun :: a t1 t2--- D, xs |- arg :: t1--- --------------------------------- D; xs |-a fun -<< arg : stk --> t2------		---> premap (\ ((xs), _stk) -> (fun, arg)) app--dsCmd ids local_vars stack_ty res_ty-        (HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _)-        env_ids = do-    let-        (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty-        (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty-    -    core_arrow <- dsLExpr arrow-    core_arg   <- dsLExpr arg-    stack_id   <- newSysLocalDs stack_ty-    core_make_pair <- matchEnvStack env_ids stack_id-          (mkCorePairExpr core_arrow core_arg)--    return (do_premap ids-              (envStackType env_ids stack_ty)-              (mkCorePairTy arrow_ty arg_ty)-              res_ty-              core_make_pair-              (do_app ids arg_ty res_ty),-            (exprFreeIds core_arrow `unionVarSet` exprFreeIds core_arg)-              `intersectVarSet` local_vars)---- D; ys |-a cmd : (t,stk) --> t'--- D, xs |-  exp :: t--- --------------------------- D; xs |-a cmd exp : stk --> t'------		---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd--dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do-    core_arg <- dsLExpr arg-    let-        arg_ty = exprType core_arg-        stack_ty' = mkCorePairTy arg_ty stack_ty-    (core_cmd, free_vars, env_ids')-             <- dsfixCmd ids local_vars stack_ty' res_ty cmd-    stack_id <- newSysLocalDs stack_ty-    arg_id <- newSysLocalDs arg_ty-    -- push the argument expression onto the stack-    let-	stack' = mkCorePairExpr (Var arg_id) (Var stack_id)-        core_body = bindNonRec arg_id core_arg-			(mkCorePairExpr (mkBigCoreVarTup env_ids') stack')--    -- match the environment and stack against the input-    core_map <- matchEnvStack env_ids stack_id core_body-    return (do_premap ids-                      (envStackType env_ids stack_ty)-                      (envStackType env_ids' stack_ty')-                      res_ty-                      core_map-                      core_cmd,-            free_vars `unionVarSet`-              (exprFreeIds core_arg `intersectVarSet` local_vars))---- D; ys |-a cmd : stk t'--- -------------------------------------------------- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t'------		---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd--dsCmd ids local_vars stack_ty res_ty-        (HsCmdLam (MG { mg_alts = [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] }))-        env_ids = do-    let-        pat_vars = mkVarSet (collectPatsBinders pats)-        local_vars' = pat_vars `unionVarSet` local_vars-	(pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty-    (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty' res_ty body-    param_ids <- mapM newSysLocalDs pat_tys-    stack_id' <- newSysLocalDs stack_ty'--    -- the expression is built from the inside out, so the actions-    -- are presented in reverse order--    let-        -- build a new environment, plus what's left of the stack-        core_expr = buildEnvStack env_ids' stack_id'-        in_ty = envStackType env_ids stack_ty-        in_ty' = envStackType env_ids' stack_ty'-    -    fail_expr <- mkFailExpr LambdaExpr in_ty'-    -- match the patterns against the parameters-    match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr fail_expr-    -- match the parameters against the top of the old stack-    (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code-    -- match the old environment and stack against the input-    select_code <- matchEnvStack env_ids stack_id param_code-    return (do_premap ids in_ty in_ty' res_ty select_code core_body,-            free_vars `minusVarSet` pat_vars)--dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids-  = dsLCmd ids local_vars stack_ty res_ty cmd env_ids---- D, xs |- e :: Bool--- D; xs1 |-a c1 : stk --> t--- D; xs2 |-a c2 : stk --> t--- ------------------------------------------- D; xs |-a if e then c1 else c2 : stk --> t------		---> premap (\ ((xs),stk) ->---			 if e then Left ((xs1),stk) else Right ((xs2),stk))---		       (c1 ||| c2)--dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)-        env_ids = do-    core_cond <- dsLExpr cond-    (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack_ty res_ty then_cmd-    (core_else, fvs_else, else_ids) <- dsfixCmd ids local_vars stack_ty res_ty else_cmd-    stack_id   <- newSysLocalDs stack_ty-    either_con <- dsLookupTyCon eitherTyConName-    left_con   <- dsLookupDataCon leftDataConName-    right_con  <- dsLookupDataCon rightDataConName--    let mk_left_expr ty1 ty2 e = mkConApp left_con [Type ty1, Type ty2, e]-        mk_right_expr ty1 ty2 e = mkConApp right_con [Type ty1, Type ty2, e]--        in_ty = envStackType env_ids stack_ty-        then_ty = envStackType then_ids stack_ty-        else_ty = envStackType else_ids stack_ty-        sum_ty = mkTyConApp either_con [then_ty, else_ty]-        fvs_cond = exprFreeIds core_cond `intersectVarSet` local_vars-        -        core_left  = mk_left_expr  then_ty else_ty (buildEnvStack then_ids stack_id)-        core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_id)--    core_if <- case mb_fun of -       Just fun -> do { core_fun <- dsExpr fun-                      ; matchEnvStack env_ids stack_id $-                        mkCoreApps core_fun [core_cond, core_left, core_right] }-       Nothing  -> matchEnvStack env_ids stack_id $-                   mkIfThenElse core_cond core_left core_right--    return (do_premap ids in_ty sum_ty res_ty-                core_if-                (do_choice ids then_ty else_ty res_ty core_then core_else),-        fvs_cond `unionVarSet` fvs_then `unionVarSet` fvs_else)-\end{code}--Case commands are treated in much the same way as if commands-(see above) except that there are more alternatives.  For example--	case e of { p1 -> c1; p2 -> c2; p3 -> c3 }--is translated to--	premap (\ ((xs)*ts) -> case e of-		p1 -> (Left (Left (xs1)*ts))-		p2 -> Left ((Right (xs2)*ts))-		p3 -> Right ((xs3)*ts))-	((c1 ||| c2) ||| c3)--The idea is to extract the commands from the case, build a balanced tree-of choices, and replace the commands with expressions that build tagged-tuples, obtaining a case expression that can be desugared normally.-To build all this, we use triples describing segments of the list of-case bodies, containing the following fields:- * a list of expressions of the form (Left|Right)* ((xs)*ts), to be put-   into the case replacing the commands- * a sum type that is the common type of these expressions, and also the-   input type of the arrow- * a CoreExpr for an arrow built by combining the translated command-   bodies with |||.--\begin{code}-dsCmd ids local_vars stack_ty res_ty -      (HsCmdCase exp (MG { mg_alts = matches, mg_arg_tys = arg_tys, mg_origin = origin }))-      env_ids = do-    stack_id <- newSysLocalDs stack_ty--    -- Extract and desugar the leaf commands in the case, building tuple-    -- expressions that will (after tagging) replace these leaves--    let-        leaves = concatMap leavesMatch matches-        make_branch (leaf, bound_vars) = do-            (core_leaf, _fvs, leaf_ids) <--                  dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty res_ty leaf-            return ([mkHsEnvStackExpr leaf_ids stack_id],-                    envStackType leaf_ids stack_ty,-                    core_leaf)-    -    branches <- mapM make_branch leaves-    either_con <- dsLookupTyCon eitherTyConName-    left_con <- dsLookupDataCon leftDataConName-    right_con <- dsLookupDataCon rightDataConName-    let-        left_id  = HsVar (dataConWrapId left_con)-        right_id = HsVar (dataConWrapId right_con)-        left_expr  ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) left_id ) e-        right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) right_id) e--        -- Prefix each tuple with a distinct series of Left's and Right's,-        -- in a balanced way, keeping track of the types.--        merge_branches (builds1, in_ty1, core_exp1)-                       (builds2, in_ty2, core_exp2)-          = (map (left_expr in_ty1 in_ty2) builds1 ++-                map (right_expr in_ty1 in_ty2) builds2,-             mkTyConApp either_con [in_ty1, in_ty2],-             do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)-        (leaves', sum_ty, core_choices) = foldb merge_branches branches--        -- Replace the commands in the case with these tagged tuples,-        -- yielding a HsExpr Id we can feed to dsExpr.--        (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches-        in_ty = envStackType env_ids stack_ty--    core_body <- dsExpr (HsCase exp (MG { mg_alts = matches', mg_arg_tys = arg_tys-                                        , mg_res_ty = sum_ty, mg_origin = origin }))-        -- Note that we replace the HsCase result type by sum_ty,-        -- which is the type of matches'--    core_matches <- matchEnvStack env_ids stack_id core_body-    return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,-            exprFreeIds core_body  `intersectVarSet` local_vars)---- D; ys |-a cmd : stk --> t--- ------------------------------------- D; xs |-a let binds in cmd : stk --> t------		---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c--dsCmd ids local_vars stack_ty res_ty (HsCmdLet binds body) env_ids = do-    let-        defined_vars = mkVarSet (collectLocalBinders binds)-        local_vars' = defined_vars `unionVarSet` local_vars-    -    (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty res_ty body-    stack_id <- newSysLocalDs stack_ty-    -- build a new environment, plus the stack, using the let bindings-    core_binds <- dsLocalBinds binds (buildEnvStack env_ids' stack_id)-    -- match the old environment and stack against the input-    core_map <- matchEnvStack env_ids stack_id core_binds-    return (do_premap ids-                        (envStackType env_ids stack_ty)-                        (envStackType env_ids' stack_ty)-                        res_ty-                        core_map-                        core_body,-        exprFreeIds core_binds `intersectVarSet` local_vars)---- D; xs |-a ss : t--- ------------------------------------- D; xs |-a do { ss } : () --> t------		---> premap (\ (env,stk) -> env) c--dsCmd ids local_vars stack_ty res_ty (HsCmdDo stmts _) env_ids = do-    (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids-    let env_ty = mkBigCoreVarTupTy env_ids-    core_fst <- mkFstExpr env_ty stack_ty-    return (do_premap ids-		(mkCorePairTy env_ty stack_ty)-		env_ty-		res_ty-		core_fst-		core_stmts,-	env_ids')---- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t--- D; xs |-a ci :: stki --> ti--- -------------------------------------- D; xs |-a (|e c1 ... cn|) :: stk --> t	---> e [t_xs] c1 ... cn--dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ args) env_ids = do-    let env_ty = mkBigCoreVarTupTy env_ids-    core_op <- dsLExpr op-    (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args-    return (mkApps (App core_op (Type env_ty)) core_args,-            unionVarSets fv_sets)--dsCmd ids local_vars stack_ty res_ty (HsCmdCast coercion cmd) env_ids = do-    (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids-    wrapped_cmd <- dsHsWrapper (mkWpCast coercion) core_cmd-    return (wrapped_cmd, env_ids')--dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)---- D; ys |-a c : stk --> t	(ys <= xs)--- ------------------------ D; xs |-a c : stk --> t	---> premap (\ ((xs),stk) -> ((ys),stk)) c--dsTrimCmdArg-	:: IdSet		-- set of local vars available to this command-	-> [Id]			-- list of vars in the input to this command-	-> LHsCmdTop Id		-- command argument to desugar-	-> DsM (CoreExpr,	-- desugared expression-		IdSet)		-- subset of local vars that occur free-dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do-    (meth_binds, meth_ids) <- mkCmdEnv ids-    (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd-    stack_id <- newSysLocalDs stack_ty-    trim_code <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id)-    let-        in_ty = envStackType env_ids stack_ty-        in_ty' = envStackType env_ids' stack_ty-        arg_code = if env_ids' == env_ids then core_cmd else-                do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd-    return (mkLets meth_binds arg_code, free_vars)---- Given D; xs |-a c : stk --> t, builds c with xs fed back.--- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk))--dsfixCmd-	:: DsCmdEnv		-- arrow combinators-	-> IdSet		-- set of local vars available to this command-	-> Type			-- type of the stack (right-nested tuple)-	-> Type			-- return type of the command-	-> LHsCmd Id		-- command to desugar-	-> DsM (CoreExpr,	-- desugared expression-		IdSet,		-- subset of local vars that occur free-		[Id])		-- the same local vars as a list, fed back-dsfixCmd ids local_vars stk_ty cmd_ty cmd-  = trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd)---- Feed back the list of local variables actually used a command,--- for use as the input tuple of the generated arrow.--trimInput-	:: ([Id] -> DsM (CoreExpr, IdSet))-	-> DsM (CoreExpr,	-- desugared expression-		IdSet,		-- subset of local vars that occur free-		[Id])		-- same local vars as a list, fed back to-				-- the inner function to form the tuple of-				-- inputs to the arrow.-trimInput build_arrow-  = fixDs (\ ~(_,_,env_ids) -> do-        (core_cmd, free_vars) <- build_arrow env_ids-        return (core_cmd, free_vars, varSetElems free_vars))--\end{code}--Translation of command judgements of the form--	D |-a do { ss } : t--\begin{code}--dsCmdDo :: DsCmdEnv		-- arrow combinators-	-> IdSet		-- set of local vars available to this statement-	-> Type			-- return type of the statement-	-> [CmdLStmt Id]        -- statements to desugar-	-> [Id]			-- list of vars in the input to this statement-				-- This is typically fed back,-				-- so don't pull on it too early-	-> DsM (CoreExpr,	-- desugared expression-		IdSet)		-- subset of local vars that occur free--dsCmdDo _ _ _ [] _ = panic "dsCmdDo"---- D; xs |-a c : () --> t--- ----------------------------- D; xs |-a do { c } : t------		---> premap (\ (xs) -> ((xs), ())) c--dsCmdDo ids local_vars res_ty [L _ (LastStmt body _)] env_ids = do-    (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids-    let env_ty = mkBigCoreVarTupTy env_ids-    env_var <- newSysLocalDs env_ty-    let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr)-    return (do_premap ids-                        env_ty-			(mkCorePairTy env_ty unitTy)-                        res_ty-                        core_map-                        core_body,-	env_ids')--dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do-    let-        bound_vars = mkVarSet (collectLStmtBinders stmt)-        local_vars' = bound_vars `unionVarSet` local_vars-    (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts)-    (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids-    return (do_compose ids-                (mkBigCoreVarTupTy env_ids)-                (mkBigCoreVarTupTy env_ids')-                res_ty-                core_stmt-                core_stmts,-              fv_stmt)--\end{code}-A statement maps one local environment to another, and is represented-as an arrow from one tuple type to another.  A statement sequence is-translated to a composition of such arrows.-\begin{code}-dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt Id -> [Id]-           -> DsM (CoreExpr, IdSet)-dsCmdLStmt ids local_vars out_ids cmd env_ids-  = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids--dsCmdStmt-	:: DsCmdEnv		-- arrow combinators-	-> IdSet		-- set of local vars available to this statement-	-> [Id]			-- list of vars in the output of this statement-	-> CmdStmt Id           -- statement to desugar-	-> [Id]			-- list of vars in the input to this statement-				-- This is typically fed back,-				-- so don't pull on it too early-	-> DsM (CoreExpr,	-- desugared expression-		IdSet)		-- subset of local vars that occur free---- D; xs1 |-a c : () --> t--- D; xs' |-a do { ss } : t'--- --------------------------------- D; xs  |-a do { c; ss } : t'------		---> premap (\ ((xs)) -> (((xs1),()),(xs')))---			(first c >>> arr snd) >>> ss--dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do-    (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd-    core_mux <- matchEnv env_ids-        (mkCorePairExpr-	    (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)-	    (mkBigCoreVarTup out_ids))-    let-	in_ty = mkBigCoreVarTupTy env_ids-	in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy-	out_ty = mkBigCoreVarTupTy out_ids-	before_c_ty = mkCorePairTy in_ty1 out_ty-	after_c_ty = mkCorePairTy c_ty out_ty-    snd_fn <- mkSndExpr c_ty out_ty-    return (do_premap ids in_ty before_c_ty out_ty core_mux $-		do_compose ids before_c_ty after_c_ty out_ty-			(do_first ids in_ty1 c_ty out_ty core_cmd) $-		do_arr ids after_c_ty out_ty snd_fn,-	      extendVarSetList fv_cmd out_ids)---- D; xs1 |-a c : () --> t--- D; xs' |-a do { ss } : t'		xs2 = xs' - defs(p)--- -------------------------------------- D; xs  |-a do { p <- c; ss } : t'------		---> premap (\ (xs) -> (((xs1),()),(xs2)))---			(first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss------ It would be simpler and more consistent to do this using second,--- but that's likely to be defined in terms of first.--dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _) env_ids = do-    (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy (hsLPatType pat) cmd-    let-	pat_ty = hsLPatType pat-	pat_vars = mkVarSet (collectPatBinders pat)-	env_ids2 = varSetElems (mkVarSet out_ids `minusVarSet` pat_vars)-	env_ty2 = mkBigCoreVarTupTy env_ids2--    -- multiplexing function-    --		\ (xs) -> (((xs1),()),(xs2))--    core_mux <- matchEnv env_ids-        (mkCorePairExpr-	    (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)-	    (mkBigCoreVarTup env_ids2))--    -- projection function-    --		\ (p, (xs2)) -> (zs)--    env_id <- newSysLocalDs env_ty2-    uniqs <- newUniqueSupply-    let-	after_c_ty = mkCorePairTy pat_ty env_ty2-	out_ty = mkBigCoreVarTupTy out_ids-	body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)-    -    fail_expr <- mkFailExpr (StmtCtxt DoExpr) out_ty-    pat_id    <- selectSimpleMatchVarL pat-    match_code <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr-    pair_id   <- newSysLocalDs after_c_ty-    let-	proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)--    -- put it all together-    let-	in_ty = mkBigCoreVarTupTy env_ids-	in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy-	in_ty2 = mkBigCoreVarTupTy env_ids2-	before_c_ty = mkCorePairTy in_ty1 in_ty2-    return (do_premap ids in_ty before_c_ty out_ty core_mux $-		do_compose ids before_c_ty after_c_ty out_ty-			(do_first ids in_ty1 pat_ty in_ty2 core_cmd) $-		do_arr ids after_c_ty out_ty proj_expr,-	      fv_cmd `unionVarSet` (mkVarSet out_ids `minusVarSet` pat_vars))---- D; xs' |-a do { ss } : t--- ----------------------------------------- D; xs  |-a do { let binds; ss } : t------		---> arr (\ (xs) -> let binds in (xs')) >>> ss--dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do-    -- build a new environment using the let bindings-    core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids)-    -- match the old environment against the input-    core_map <- matchEnv env_ids core_binds-    return (do_arr ids-			(mkBigCoreVarTupTy env_ids)-			(mkBigCoreVarTupTy out_ids)-			core_map,-	    exprFreeIds core_binds `intersectVarSet` local_vars)---- D; ys  |-a do { ss; returnA -< ((xs1), (ys2)) } : ...--- D; xs' |-a do { ss' } : t--- --------------------------------------- D; xs  |-a do { rec ss; ss' } : t------			xs1 = xs' /\ defs(ss)---			xs2 = xs' - defs(ss)---			ys1 = ys - defs(ss)---			ys2 = ys /\ defs(ss)------		---> arr (\(xs) -> ((ys1),(xs2))) >>>---			first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>---			arr (\((xs1),(xs2)) -> (xs')) >>> ss'--dsCmdStmt ids local_vars out_ids-        (RecStmt { recS_stmts = stmts-                 , recS_later_ids = later_ids, recS_rec_ids = rec_ids-                 , recS_later_rets = later_rets, recS_rec_rets = rec_rets })-        env_ids = do-    let-        env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids-        env2_ids = varSetElems env2_id_set-        env2_ty = mkBigCoreVarTupTy env2_ids--    -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)--    uniqs <- newUniqueSupply-    env2_id <- newSysLocalDs env2_ty-    let-        later_ty = mkBigCoreVarTupTy later_ids-        post_pair_ty = mkCorePairTy later_ty env2_ty-        post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids)--    post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body--    --- loop (...)--    (core_loop, env1_id_set, env1_ids)-               <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets--    -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))--    let-        env1_ty = mkBigCoreVarTupTy env1_ids-        pre_pair_ty = mkCorePairTy env1_ty env2_ty-        pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids)-                                        (mkBigCoreVarTup env2_ids)--    pre_loop_fn <- matchEnv env_ids pre_loop_body--    -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn--    let-        env_ty = mkBigCoreVarTupTy env_ids-        out_ty = mkBigCoreVarTupTy out_ids-        core_body = do_premap ids env_ty pre_pair_ty out_ty-                pre_loop_fn-                (do_compose ids pre_pair_ty post_pair_ty out_ty-                        (do_first ids env1_ty later_ty env2_ty-                                core_loop)-                        (do_arr ids post_pair_ty out_ty-                                post_loop_fn))--    return (core_body, env1_id_set `unionVarSet` env2_id_set)--dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)----	loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids))---	      (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>>--dsRecCmd-        :: DsCmdEnv		-- arrow combinators-        -> IdSet		-- set of local vars available to this statement-        -> [CmdLStmt Id]        -- list of statements inside the RecCmd-        -> [Id]			-- list of vars defined here and used later-        -> [HsExpr Id]		-- expressions corresponding to later_ids-        -> [Id]			-- list of vars fed back through the loop-        -> [HsExpr Id]		-- expressions corresponding to rec_ids-        -> DsM (CoreExpr,	-- desugared statement-                IdSet,		-- subset of local vars that occur free-                [Id])		-- same local vars as a list--dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do-    let-        later_id_set = mkVarSet later_ids-        rec_id_set = mkVarSet rec_ids-        local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars--    -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets))--    core_later_rets <- mapM dsExpr later_rets-    core_rec_rets <- mapM dsExpr rec_rets-    let-        -- possibly polymorphic version of vars of later_ids and rec_ids-        out_ids = varSetElems (unionVarSets (map exprFreeIds (core_later_rets ++ core_rec_rets)))-        out_ty = mkBigCoreVarTupTy out_ids--        later_tuple = mkBigCoreTup core_later_rets-        later_ty = mkBigCoreVarTupTy later_ids--        rec_tuple = mkBigCoreTup core_rec_rets-        rec_ty = mkBigCoreVarTupTy rec_ids--        out_pair = mkCorePairExpr later_tuple rec_tuple-        out_pair_ty = mkCorePairTy later_ty rec_ty--    mk_pair_fn <- matchEnv out_ids out_pair--    -- ss--    (core_stmts, fv_stmts, env_ids) <- dsfixCmdStmts ids local_vars' out_ids stmts--    -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids)--    rec_id <- newSysLocalDs rec_ty-    let-        env1_id_set = fv_stmts `minusVarSet` rec_id_set-        env1_ids = varSetElems env1_id_set-        env1_ty = mkBigCoreVarTupTy env1_ids-        in_pair_ty = mkCorePairTy env1_ty rec_ty-        core_body = mkBigCoreTup (map selectVar env_ids)-          where-            selectVar v-                | v `elemVarSet` rec_id_set-                  = mkTupleSelector rec_ids v rec_id (Var rec_id)-                | otherwise = Var v--    squash_pair_fn <- matchEnvStack env1_ids rec_id core_body--    -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn))--    let-        env_ty = mkBigCoreVarTupTy env_ids-        core_loop = do_loop ids env1_ty later_ty rec_ty-                (do_premap ids in_pair_ty env_ty out_pair_ty-                        squash_pair_fn-                        (do_compose ids env_ty out_ty out_pair_ty-                                core_stmts-                                (do_arr ids out_ty out_pair_ty mk_pair_fn)))--    return (core_loop, env1_id_set, env1_ids)--\end{code}-A sequence of statements (as in a rec) is desugared to an arrow between-two environments (no stack)-\begin{code}--dsfixCmdStmts-	:: DsCmdEnv		-- arrow combinators-	-> IdSet		-- set of local vars available to this statement-	-> [Id]			-- output vars of these statements-	-> [CmdLStmt Id]        -- statements to desugar-	-> DsM (CoreExpr,	-- desugared expression-		IdSet,		-- subset of local vars that occur free-		[Id])		-- same local vars as a list--dsfixCmdStmts ids local_vars out_ids stmts-  = trimInput (dsCmdStmts ids local_vars out_ids stmts)--dsCmdStmts-	:: DsCmdEnv		-- arrow combinators-	-> IdSet		-- set of local vars available to this statement-	-> [Id]			-- output vars of these statements-	-> [CmdLStmt Id]        -- statements to desugar-	-> [Id]			-- list of vars in the input to these statements-	-> DsM (CoreExpr,	-- desugared expression-		IdSet)		-- subset of local vars that occur free--dsCmdStmts ids local_vars out_ids [stmt] env_ids-  = dsCmdLStmt ids local_vars out_ids stmt env_ids--dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do-    let-        bound_vars = mkVarSet (collectLStmtBinders stmt)-        local_vars' = bound_vars `unionVarSet` local_vars-    (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts-    (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids-    return (do_compose ids-                (mkBigCoreVarTupTy env_ids)-                (mkBigCoreVarTupTy env_ids')-                (mkBigCoreVarTupTy out_ids)-                core_stmt-                core_stmts,-              fv_stmt)--dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []"-\end{code}--Match a list of expressions against a list of patterns, left-to-right.--\begin{code}-matchSimplys :: [CoreExpr]              -- Scrutinees-	     -> HsMatchContext Name	-- Match kind-	     -> [LPat Id]         	-- Patterns they should match-	     -> CoreExpr                -- Return this if they all match-	     -> CoreExpr                -- Return this if they don't-	     -> DsM CoreExpr-matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr-matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do-    match_code <- matchSimplys exps ctxt pats result_expr fail_expr-    matchSimply exp ctxt pat match_code fail_expr-matchSimplys _ _ _ _ _ = panic "matchSimplys"-\end{code}--List of leaf expressions, with set of variables bound in each--\begin{code}-leavesMatch :: LMatch Id (Located (body Id)) -> [(Located (body Id), IdSet)]-leavesMatch (L _ (Match pats _ (GRHSs grhss binds)))-  = let-	defined_vars = mkVarSet (collectPatsBinders pats)-			`unionVarSet`-		       mkVarSet (collectLocalBinders binds)-    in-    [(body, -      mkVarSet (collectLStmtsBinders stmts) -	`unionVarSet` defined_vars) -    | L _ (GRHS stmts body) <- grhss]-\end{code}--Replace the leaf commands in a match--\begin{code}-replaceLeavesMatch-        :: Type                                 -- new result type-        -> [Located (body' Id)]                 -- replacement leaf expressions of that type-        -> LMatch Id (Located (body Id))        -- the matches of a case command-        -> ([Located (body' Id)],               -- remaining leaf expressions-            LMatch Id (Located (body' Id)))     -- updated match-replaceLeavesMatch _res_ty leaves (L loc (Match pat mt (GRHSs grhss binds)))-  = let-	(leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss-    in-    (leaves', L loc (Match pat mt (GRHSs grhss' binds)))--replaceLeavesGRHS-        :: [Located (body' Id)]                 -- replacement leaf expressions of that type-        -> LGRHS Id (Located (body Id))         -- rhss of a case command-        -> ([Located (body' Id)],               -- remaining leaf expressions-            LGRHS Id (Located (body' Id)))      -- updated GRHS-replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts _))-  = (leaves, L loc (GRHS stmts leaf))-replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"-\end{code}--Balanced fold of a non-empty list.--\begin{code}-foldb :: (a -> a -> a) -> [a] -> a-foldb _ [] = error "foldb of empty list"-foldb _ [x] = x-foldb f xs = foldb f (fold_pairs xs)-  where-    fold_pairs [] = []-    fold_pairs [x] = [x]-    fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs-\end{code}--Note [Dictionary binders in ConPatOut] See also same Note in HsUtils-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The following functions to collect value variables from patterns are-copied from HsUtils, with one change: we also collect the dictionary-bindings (pat_binds) from ConPatOut.  We need them for cases like--h :: Arrow a => Int -> a (Int,Int) Int-h x = proc (y,z) -> case compare x y of-                GT -> returnA -< z+x--The type checker turns the case into--                case compare x y of-                  GT { p77 = plusInt } -> returnA -< p77 z x--Here p77 is a local binding for the (+) operation.--See comments in HsUtils for why the other version does not include-these bindings.--\begin{code}-collectPatBinders :: LPat Id -> [Id]-collectPatBinders pat = collectl pat []--collectPatsBinders :: [LPat Id] -> [Id]-collectPatsBinders pats = foldr collectl [] pats------------------------collectl :: LPat Id -> [Id] -> [Id]--- See Note [Dictionary binders in ConPatOut]-collectl (L _ pat) bndrs-  = go pat-  where-    go (VarPat var)               = var : bndrs-    go (WildPat _)                = bndrs-    go (LazyPat pat)              = collectl pat bndrs-    go (BangPat pat)              = collectl pat bndrs-    go (AsPat (L _ a) pat)        = a : collectl pat bndrs-    go (ParPat  pat)              = collectl pat bndrs--    go (ListPat pats _ _)         = foldr collectl bndrs pats-    go (PArrPat pats _)           = foldr collectl bndrs pats-    go (TuplePat pats _ _)        = foldr collectl bndrs pats--    go (ConPatIn _ ps)            = foldr collectl bndrs (hsConPatArgs ps)-    go (ConPatOut {pat_args=ps, pat_binds=ds}) =-                                    collectEvBinders ds-                                    ++ foldr collectl bndrs (hsConPatArgs ps)-    go (LitPat _)                 = bndrs-    go (NPat _ _ _)               = bndrs-    go (NPlusKPat (L _ n) _ _ _)  = n : bndrs--    go (SigPatIn pat _)           = collectl pat bndrs-    go (SigPatOut pat _)          = collectl pat bndrs-    go (CoPat _ pat _)            = collectl (noLoc pat) bndrs-    go (ViewPat _ pat _)          = collectl pat bndrs-    go p@(SplicePat {})           = pprPanic "collectl/go" (ppr p)-    go p@(QuasiQuotePat {})       = pprPanic "collectl/go" (ppr p)--collectEvBinders :: TcEvBinds -> [Id]-collectEvBinders (EvBinds bs)   = foldrBag add_ev_bndr [] bs-collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"--add_ev_bndr :: EvBind -> [Id] -> [Id]-add_ev_bndr (EvBind b _) bs | isId b    = b:bs-                            | otherwise = bs-  -- A worry: what about coercion variable binders??--collectLStmtsBinders :: [LStmt Id body] -> [Id]-collectLStmtsBinders = concatMap collectLStmtBinders--collectLStmtBinders :: LStmt Id body -> [Id]-collectLStmtBinders = collectStmtBinders . unLoc--collectStmtBinders :: Stmt Id body -> [Id]-collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat-collectStmtBinders (LetStmt binds)      = collectLocalBinders binds-collectStmtBinders (BodyStmt {})        = []-collectStmtBinders (LastStmt {})        = []-collectStmtBinders (ParStmt xs _ _)     = collectLStmtsBinders-                                        $ [ s | ParStmtBlock ss _ _ <- xs, s <- ss]-collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts-collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids--\end{code}
− src/Language/Haskell/Liquid/Desugar/DsBinds.lhs 
@@ -1,900 +0,0 @@-%-% (c) The University of Glasgow 2006-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998-%--Pattern-matching bindings (HsBinds and MonoBinds)--Handles @HsBinds@; those at the top level require different handling,-in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at-lower levels it is preserved with @let@/@letrec@s).--\begin{code}-{-# OPTIONS -fno-warn-tabs #-}--- The above warning supression flag is a temporary kludge.--- While working on this module you are encouraged to remove it and--- detab the module (please do the detabbing in a separate patch). See---     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces--- for details--module Language.Haskell.Liquid.Desugar.DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,-                 dsHsWrapper, dsTcEvBinds, dsEvBinds-  ) where---- #include "HsVersions.h"--import {-# SOURCE #-}	Language.Haskell.Liquid.Desugar.DsExpr( dsLExpr )-import {-# SOURCE #-}	Language.Haskell.Liquid.Desugar.Match( matchWrapper )--import DsMonad-import Language.Haskell.Liquid.Desugar.DsGRHSs-import Language.Haskell.Liquid.Desugar.DsUtils--import HsSyn		-- lots of things-import CoreSyn		-- lots of things-import Literal          ( Literal(MachStr) )-import CoreSubst-import MkCore-import CoreUtils-import CoreArity ( etaExpand )-import CoreUnfold-import CoreFVs-import UniqSupply-import Unique( Unique )-import Digraph---import TyCon      ( tyConDataCons_maybe )-import TcEvidence-import TcType-import Type-import Coercion hiding (substCo)-import TysWiredIn ( eqBoxDataCon, coercibleDataCon, tupleCon )-import Id-import Class-import DataCon	( dataConWorkId )-import Name-import MkId	( seqId )-import Var-import VarSet-import Rules-import VarEnv-import Outputable-import SrcLoc-import Maybes-import OrdList-import Bag-import BasicTypes hiding ( TopLevel )-import DynFlags-import FastString-import ErrUtils( MsgDoc )-import ListSetOps( getNth )-import Util-import Control.Monad( when )-import MonadUtils-import Control.Monad(liftM)-\end{code}--%************************************************************************-%*									*-\subsection[dsMonoBinds]{Desugaring a @MonoBinds@}-%*									*-%************************************************************************--\begin{code}-dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))-dsTopLHsBinds binds = ds_lhs_binds binds--dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]-dsLHsBinds binds = do { binds' <- ds_lhs_binds binds-                      ; return (fromOL binds') }---------------------------ds_lhs_binds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))--ds_lhs_binds binds = do { ds_bs <- mapBagM dsLHsBind binds-                        ; return (foldBag appOL id nilOL ds_bs) }--dsLHsBind :: LHsBind Id -> DsM (OrdList (Id,CoreExpr))-dsLHsBind (L loc bind) = putSrcSpanDs loc $ dsHsBind bind--dsHsBind :: HsBind Id -> DsM (OrdList (Id,CoreExpr))--dsHsBind (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })-  = do  { dflags <- getDynFlags-        ; core_expr <- dsLExpr expr--	        -- Dictionary bindings are always VarBinds,-	        -- so we only need do this here-        ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr-	      	   | otherwise         = var--        ; return (unitOL (makeCorePair dflags var' False 0 core_expr)) }--dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches-                  , fun_co_fn = co_fn, fun_tick = tick-                  , fun_infix = inf })- = do	{ dflags <- getDynFlags-        ; (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches-        ; let body' = mkOptTickBox tick body-        ; rhs <- dsHsWrapper co_fn (mkLams args body')-        ; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -}-           return (unitOL (makeCorePair dflags fun False 0 rhs)) }--dsHsBind (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty-                  , pat_ticks = (rhs_tick, var_ticks) })-  = do	{ body_expr <- dsGuarded grhss ty-        ; let body' = mkOptTickBox rhs_tick body_expr-        ; sel_binds <- mkSelectorBinds var_ticks pat body'-	  -- We silently ignore inline pragmas; no makeCorePair-	  -- Not so cool, but really doesn't matter-    ; return (toOL sel_binds) }--	-- A common case: one exported variable-	-- Non-recursive bindings come through this way-	-- So do self-recursive bindings, and recursive bindings-	-- that have been chopped up with type signatures-dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts-                   , abs_exports = [export]-                   , abs_ev_binds = ev_binds, abs_binds = binds })-  | ABE { abe_wrap = wrap, abe_poly = global-        , abe_mono = local, abe_prags = prags } <- export-  = do  { dflags <- getDynFlags-        ; bind_prs    <- ds_lhs_binds binds-	; let	core_bind = Rec (fromOL bind_prs)-        ; ds_binds <- dsTcEvBinds ev_binds-        ; rhs <- dsHsWrapper wrap $  -- Usually the identity-			    mkLams tyvars $ mkLams dicts $ -	                    mkCoreLets ds_binds $-                            Let core_bind $-                            Var local-    -	; (spec_binds, rules) <- dsSpecs rhs prags--	; let   global'   = addIdSpecialisations global rules-		main_bind = makeCorePair dflags global' (isDefaultMethod prags)-                                         (dictArity dicts) rhs -    -	; return (main_bind `consOL` spec_binds) }--dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts-                   , abs_exports = exports, abs_ev_binds = ev_binds-                   , abs_binds = binds })-         -- See Note [Desugaring AbsBinds]-  = do  { dflags <- getDynFlags-        ; bind_prs    <- ds_lhs_binds binds-        ; let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs-                              | (lcl_id, rhs) <- fromOL bind_prs ]-	      	-- Monomorphic recursion possible, hence Rec--	      locals       = map abe_mono exports-	      tup_expr     = mkBigCoreVarTup locals-	      tup_ty	   = exprType tup_expr-        ; ds_binds <- dsTcEvBinds ev_binds-	; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $-	      		     mkCoreLets ds_binds $-			     Let core_bind $-	 	     	     tup_expr--	; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)--	; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global-                           , abe_mono = local, abe_prags = spec_prags })-	        = do { tup_id  <- newSysLocalDs tup_ty-	             ; rhs <- dsHsWrapper wrap $ -                                 mkLams tyvars $ mkLams dicts $-	      	     		 mkTupleSelector locals local tup_id $-			         mkVarApps (Var poly_tup_id) (tyvars ++ dicts)-                     ; let rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs-		     ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags-		     ; let global' = (global `setInlinePragma` defaultInlinePragma)-                                             `addIdSpecialisations` rules-                           -- Kill the INLINE pragma because it applies to-                           -- the user written (local) function.  The global-                           -- Id is just the selector.  Hmm.  -		     ; return ((global', rhs) `consOL` spec_binds) }--        ; export_binds_s <- mapM mk_bind exports--	; return ((poly_tup_id, poly_tup_rhs) `consOL` -		    concatOL export_binds_s) }-  where-    inline_env :: IdEnv Id   -- Maps a monomorphic local Id to one with-                             -- the inline pragma from the source-                             -- The type checker put the inline pragma-                             -- on the *global* Id, so we need to transfer it-    inline_env = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag)-                          | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports-                          , let prag = idInlinePragma gbl_id ]--    add_inline :: Id -> Id    -- tran-    add_inline lcl_id = lookupVarEnv inline_env lcl_id `orElse` lcl_id--dsHsBind (PatSynBind{}) = panic "dsHsBind: PatSynBind"---------------------------makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)-makeCorePair dflags gbl_id is_default_method dict_arity rhs-  | is_default_method		      -- Default methods are *always* inlined-  = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)--  | otherwise-  = case inlinePragmaSpec inline_prag of-      	  EmptyInlineSpec -> (gbl_id, rhs)-      	  NoInline        -> (gbl_id, rhs)-      	  Inlinable       -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)-          Inline          -> inline_pair--  where-    inline_prag   = idInlinePragma gbl_id-    inlinable_unf = mkInlinableUnfolding dflags rhs-    inline_pair-       | Just arity <- inlinePragmaSat inline_prag-      	-- Add an Unfolding for an INLINE (but not for NOINLINE)-	-- And eta-expand the RHS; see Note [Eta-expanding INLINE things]-       , let real_arity = dict_arity + arity-        -- NB: The arity in the InlineRule takes account of the dictionaries-       = ( gbl_id `setIdUnfolding` mkInlineUnfolding (Just real_arity) rhs-         , etaExpand real_arity rhs)--       | otherwise-       = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $-         (gbl_id `setIdUnfolding` mkInlineUnfolding Nothing rhs, rhs)---dictArity :: [Var] -> Arity--- Don't count coercion variables in arity-dictArity dicts = count isId dicts-\end{code}--[Desugaring AbsBinds]-~~~~~~~~~~~~~~~~~~~~~-In the general AbsBinds case we desugar the binding to this:--       tup a (d:Num a) = let fm = ...gm...-                             gm = ...fm...-                         in (fm,gm)-       f a d = case tup a d of { (fm,gm) -> fm }-       g a d = case tup a d of { (fm,gm) -> fm }--Note [Rules and inlining]-~~~~~~~~~~~~~~~~~~~~~~~~~-Common special case: no type or dictionary abstraction-This is a bit less trivial than you might suppose-The naive way woudl be to desguar to something like-	f_lcl = ...f_lcl...	-- The "binds" from AbsBinds-	M.f = f_lcl		-- Generated from "exports"-But we don't want that, because if M.f isn't exported,-it'll be inlined unconditionally at every call site (its rhs is -trivial).  That would be ok unless it has RULES, which would -thereby be completely lost.  Bad, bad, bad.--Instead we want to generate-	M.f = ...f_lcl...-	f_lcl = M.f-Now all is cool. The RULES are attached to M.f (by SimplCore), -and f_lcl is rapidly inlined away.--This does not happen in the same way to polymorphic binds,-because they desugar to-	M.f = /\a. let f_lcl = ...f_lcl... in f_lcl-Although I'm a bit worried about whether full laziness might-float the f_lcl binding out and then inline M.f at its call site--Note [Specialising in no-dict case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Even if there are no tyvars or dicts, we may have specialisation pragmas.-Class methods can generate-      AbsBinds [] [] [( ... spec-prag]-         { AbsBinds [tvs] [dicts] ...blah }-So the overloading is in the nested AbsBinds. A good example is in GHC.Float:--  class  (Real a, Fractional a) => RealFrac a  where-    round :: (Integral b) => a -> b--  instance  RealFrac Float  where-    {-# SPECIALIZE round :: Float -> Int #-}--The top-level AbsBinds for $cround has no tyvars or dicts (because the -instance does not).  But the method is locally overloaded!--Note [Abstracting over tyvars only]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When abstracting over type variable only (not dictionaries), we don't really need to-built a tuple and select from it, as we do in the general case. Instead we can take--	AbsBinds [a,b] [ ([a,b], fg, fl, _),-		         ([b],   gg, gl, _) ]-		{ fl = e1-		  gl = e2-		   h = e3 }--and desugar it to--	fg = /\ab. let B in e1-	gg = /\b. let a = () in let B in S(e2)-	h  = /\ab. let B in e3--where B is the *non-recursive* binding-	fl = fg a b-	gl = gg b-	h  = h a b    -- See (b); note shadowing!--Notice (a) g has a different number of type variables to f, so we must-	     use the mkArbitraryType thing to fill in the gaps.  -	     We use a type-let to do that.--	 (b) The local variable h isn't in the exports, and rather than-	     clone a fresh copy we simply replace h by (h a b), where-	     the two h's have different types!  Shadowing happens here,-	     which looks confusing but works fine.--	 (c) The result is *still* quadratic-sized if there are a lot of-	     small bindings.  So if there are more than some small-	     number (10), we filter the binding set B by the free-	     variables of the particular RHS.  Tiresome.--Why got to this trouble?  It's a common case, and it removes the-quadratic-sized tuple desugaring.  Less clutter, hopefullly faster-compilation, especially in a case where there are a *lot* of-bindings.---Note [Eta-expanding INLINE things]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   foo :: Eq a => a -> a-   {-# INLINE foo #-}-   foo x = ...--If (foo d) ever gets floated out as a common sub-expression (which can-happen as a result of method sharing), there's a danger that we never -get to do the inlining, which is a Terribly Bad thing given that the-user said "inline"!--To avoid this we pre-emptively eta-expand the definition, so that foo-has the arity with which it is declared in the source code.  In this-example it has arity 2 (one for the Eq and one for x). Doing this -should mean that (foo d) is a PAP and we don't share it.--Note [Nested arities]-~~~~~~~~~~~~~~~~~~~~~-For reasons that are not entirely clear, method bindings come out looking like-this:--  AbsBinds [] [] [$cfromT <= [] fromT]-    $cfromT [InlPrag=INLINE] :: T Bool -> Bool-    { AbsBinds [] [] [fromT <= [] fromT_1]-        fromT :: T Bool -> Bool-        { fromT_1 ((TBool b)) = not b } } }--Note the nested AbsBind.  The arity for the InlineRule on $cfromT should be-gotten from the binding for fromT_1.--It might be better to have just one level of AbsBinds, but that requires more-thought!--Note [Implementing SPECIALISE pragmas]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Example:-	f :: (Eq a, Ix b) => a -> b -> Bool-	{-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}-        f = <poly_rhs>--From this the typechecker generates--    AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds--    SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX-                      -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])--Note that wrap_fn can transform *any* function with the right type prefix -    forall ab. (Eq a, Ix b) => XXX-regardless of XXX.  It's sort of polymorphic in XXX.  This is-useful: we use the same wrapper to transform each of the class ops, as-well as the dict.--From these we generate:--    Rule: 	forall p, q, (dp:Ix p), (dq:Ix q). -                    f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq--    Spec bind:	f_spec = wrap_fn <poly_rhs>--Note that --  * The LHS of the rule may mention dictionary *expressions* (eg-    $dfIxPair dp dq), and that is essential because the dp, dq are-    needed on the RHS.--  * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it -    can fully specialise it.--\begin{code}--------------------------dsSpecs :: CoreExpr     -- Its rhs-        -> TcSpecPrags-        -> DsM ( OrdList (Id,CoreExpr) 	-- Binding for specialised Ids-	       , [CoreRule] )		-- Rules for the Global Ids--- See Note [Implementing SPECIALISE pragmas]-dsSpecs _ IsDefaultMethod = return (nilOL, [])-dsSpecs poly_rhs (SpecPrags sps)-  = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps-       ; let (spec_binds_s, rules) = unzip pairs-       ; return (concatOL spec_binds_s, rules) }--dsSpec :: Maybe CoreExpr  	-- Just rhs => RULE is for a local binding-       	  			-- Nothing => RULE is for an imported Id-				-- 	      rhs is in the Id's unfolding-       -> Located TcSpecPrag-       -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))-dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))-  | isJust (isClassOpId_maybe poly_id)-  = putSrcSpanDs loc $ -    do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for class method selector") -                 <+> quotes (ppr poly_id))-       ; return Nothing  }  -- There is no point in trying to specialise a class op-       	 		    -- Moreover, classops don't (currently) have an inl_sat arity set-			    -- (it would be Just 0) and that in turn makes makeCorePair bleat--  | no_act_spec && isNeverActive rule_act -  = putSrcSpanDs loc $ -    do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for NOINLINE function:")-                 <+> quotes (ppr poly_id))-       ; return Nothing  }  -- Function is NOINLINE, and the specialiation inherits that-       	 		    -- See Note [Activation pragmas for SPECIALISE]--  | otherwise-  = putSrcSpanDs loc $ -    do { uniq <- newUnique-       ; let poly_name = idName poly_id-             spec_occ  = mkSpecOcc (getOccName poly_name)-             spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)-       ; (bndrs, ds_lhs) <- liftM collectBinders-                                  (dsHsWrapper spec_co (Var poly_id))-       ; let spec_ty = mkPiTypes bndrs (exprType ds_lhs)-       ; case decomposeRuleLhs bndrs ds_lhs of {-           Left msg -> do { warnDs msg; return Nothing } ;-           Right (rule_bndrs, _fn, args) -> do--       { dflags <- getDynFlags-       ; let spec_unf = specUnfolding bndrs args (realIdUnfolding poly_id)-             spec_id  = mkLocalId spec_name spec_ty -         	            `setInlinePragma` inl_prag-         	 	    `setIdUnfolding`  spec_unf-             rule =  mkRule False {- Not auto -} is_local_id-                        (mkFastString ("SPEC " ++ showPpr dflags poly_name))-       			rule_act poly_name-       		        rule_bndrs args-       			(mkVarApps (Var spec_id) bndrs)--       ; spec_rhs <- dsHsWrapper spec_co poly_rhs-       ; let spec_pair = makeCorePair dflags spec_id False (dictArity bndrs) spec_rhs--       ; when (isInlinePragma id_inl && wopt Opt_WarnPointlessPragmas dflags)-              (warnDs (specOnInline poly_name))-       ; return (Just (unitOL spec_pair, rule))-       } } }-  where-    is_local_id = isJust mb_poly_rhs-    poly_rhs | Just rhs <-  mb_poly_rhs-             = rhs  	    -- Local Id; this is its rhs-             | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)-             = unfolding    -- Imported Id; this is its unfolding-	       		    -- Use realIdUnfolding so we get the unfolding -			    -- even when it is a loop breaker. -			    -- We want to specialise recursive functions!-             | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)-	                    -- The type checker has checked that it *has* an unfolding--    id_inl = idInlinePragma poly_id--    -- See Note [Activation pragmas for SPECIALISE]-    inl_prag | not (isDefaultInlinePragma spec_inl)    = spec_inl-             | not is_local_id  -- See Note [Specialising imported functions]-             	    		 -- in OccurAnal-             , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma-             | otherwise                               = id_inl-     -- Get the INLINE pragma from SPECIALISE declaration, or,-     -- failing that, from the original Id--    spec_prag_act = inlinePragmaActivation spec_inl--    -- See Note [Activation pragmas for SPECIALISE]-    -- no_act_spec is True if the user didn't write an explicit-    -- phase specification in the SPECIALISE pragma-    no_act_spec = case inlinePragmaSpec spec_inl of-                    NoInline -> isNeverActive  spec_prag_act-                    _        -> isAlwaysActive spec_prag_act-    rule_act | no_act_spec = inlinePragmaActivation id_inl   -- Inherit-             | otherwise   = spec_prag_act                   -- Specified by user---specUnfolding :: [Var] -> [CoreExpr] -> Unfolding -> Unfolding-specUnfolding new_bndrs new_args df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })-  = -- ASSERT2( equalLength new_args bndrs, ppr df $$ ppr new_args $$ ppr new_bndrs )-    df { df_bndrs = new_bndrs, df_args = map (substExpr (text "specUnfolding") subst) args }-  where-    subst = mkOpenSubst (mkInScopeSet fvs) (bndrs `zip` new_args)-    fvs = (exprsFreeVars args `delVarSetList` bndrs) `extendVarSetList` new_bndrs--specUnfolding _ _ _ = noUnfolding--specOnInline :: Name -> MsgDoc-specOnInline f = ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:") -                 <+> quotes (ppr f)-\end{code}---Note [Activation pragmas for SPECIALISE]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-From a user SPECIALISE pragma for f, we generate-  a) A top-level binding    spec_fn = rhs-  b) A RULE                 f dOrd = spec_fn--We need two pragma-like things:--* spec_fn's inline pragma: inherited from f's inline pragma (ignoring -                           activation on SPEC), unless overriden by SPEC INLINE--* Activation of RULE: from SPECIALISE pragma (if activation given)-                      otherwise from f's inline pragma--This is not obvious (see Trac #5237)!--Examples      Rule activation   Inline prag on spec'd fn-----------------------------------------------------------------------SPEC [n] f :: ty            [n]   Always, or NOINLINE [n]-                                  copy f's prag--NOINLINE f-SPEC [n] f :: ty            [n]   NOINLINE-                                  copy f's prag--NOINLINE [k] f-SPEC [n] f :: ty            [n]   NOINLINE [k]-                                  copy f's prag--INLINE [k] f-SPEC [n] f :: ty            [n]   INLINE [k] -                                  copy f's prag--SPEC INLINE [n] f :: ty     [n]   INLINE [n]-                                  (ignore INLINE prag on f,-                                  same activation for rule and spec'd fn)--NOINLINE [k] f-SPEC f :: ty                [n]   INLINE [k]---%************************************************************************-%*									*-\subsection{Adding inline pragmas}-%*									*-%************************************************************************--\begin{code}-decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr])--- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE,--- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs--- may add some extra dictionary binders (see Note [Constant rule dicts])------ Returns Nothing if the LHS isn't of the expected shape-decomposeRuleLhs bndrs lhs -  =  -- Note [Simplifying the left-hand side of a RULE]-    case collectArgs opt_lhs of-        (Var fn, args) -> check_bndrs fn args--        (Case scrut bndr ty [(DEFAULT, _, body)], args)-	        | isDeadBinder bndr	-- Note [Matching seqId]-		-> check_bndrs seqId (args' ++ args)-		where-		   args' = [Type (idType bndr), Type ty, scrut, body]-	   -	_other -> Left bad_shape_msg- where-   opt_lhs = simpleOptExpr lhs--   check_bndrs fn args-     | null dead_bndrs = Right (extra_dict_bndrs ++ bndrs, fn, args)-     | otherwise       = Left (vcat (map dead_msg dead_bndrs))-     where-       arg_fvs = exprsFreeVars args--            -- Check for dead binders: Note [Unused spec binders]-       dead_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs--            -- Add extra dict binders: Note [Constant rule dicts]-       extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)-                          | d <- varSetElems (arg_fvs `delVarSetList` bndrs)-         	          , isDictId d]---   bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar"))-                      2 (ppr opt_lhs)-   dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr-			     , ptext (sLit "is not bound in RULE lhs")])-                      2 (ppr opt_lhs)-   pp_bndr bndr-    | isTyVar bndr                      = ptext (sLit "type variable") <+> quotes (ppr bndr)-    | Just pred <- evVarPred_maybe bndr = ptext (sLit "constraint") <+> quotes (ppr pred)-    | otherwise                         = ptext (sLit "variable") <+> quotes (ppr bndr)-\end{code}--Note [Simplifying the left-hand side of a RULE]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-simpleOptExpr occurrence-analyses and simplifies the lhs-and thereby-(a) sorts dict bindings into NonRecs and inlines them-(b) substitute trivial lets so that they don't get in the way-    Note that we substitute the function too; we might -    have this as a LHS:  let f71 = M.f Int in f71-(c) does eta reduction--For (c) consider the fold/build rule, which without simplification-looked like:-	fold k z (build (/\a. g a))  ==>  ...-This doesn't match unless you do eta reduction on the build argument.-Similarly for a LHS like-	augment g (build h) -we do not want to get-	augment (\a. g a) (build h)-otherwise we don't match when given an argument like-	augment (\a. h a a) (build h)--NB: tcSimplifyRuleLhs is very careful not to generate complicated-    dictionary expressions that we might have to match--Note [Matching seqId]-~~~~~~~~~~~~~~~~~~~-The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack-and this code turns it back into an application of seq!  -See Note [Rules for seq] in MkId for the details.--Note [Unused spec binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-	f :: a -> a-	{-# SPECIALISE f :: Eq a => a -> a #-}-It's true that this *is* a more specialised type, but the rule-we get is something like this:-	f_spec d = f-	RULE: f = f_spec d-Note that the rule is bogus, because it mentions a 'd' that is-not bound on the LHS!  But it's a silly specialisation anyway, because-the constraint is unused.  We could bind 'd' to (error "unused")-but it seems better to reject the program because it's almost certainly-a mistake.  That's what the isDeadBinder call detects.--Note [Constant rule dicts]-~~~~~~~~~~~~~~~~~~~~~~~~~~-When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict, -which is presumably in scope at the function definition site, we can quantify -over it too.  *Any* dict with that type will do.--So for example when you have-	f :: Eq a => a -> a-	f = <rhs>-	{-# SPECIALISE f :: Int -> Int #-}--Then we get the SpecPrag-	SpecPrag (f Int dInt) --And from that we want the rule-	-	RULE forall dInt. f Int dInt = f_spec-	f_spec = let f = <rhs> in f Int dInt--But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External-Name, and you can't bind them in a lambda or forall without getting things-confused.   Likewise it might have an InlineRule or something, which would be-utterly bogus. So we really make a fresh Id, with the same unique and type-as the old one, but with an Internal name and no IdInfo.---%************************************************************************-%*									*-		Desugaring evidence-%*									*-%************************************************************************---\begin{code}-dsHsWrapper :: HsWrapper -> CoreExpr -> DsM CoreExpr-dsHsWrapper WpHole 	      e = return e-dsHsWrapper (WpTyApp ty)      e = return $ App e (Type ty)-dsHsWrapper (WpLet ev_binds)  e = do bs <- dsTcEvBinds ev_binds-                                     return (mkCoreLets bs e)-dsHsWrapper (WpCompose c1 c2) e = dsHsWrapper c1 =<< dsHsWrapper c2 e-dsHsWrapper (WpCast co)       e = -- ASSERT(tcCoercionRole co == Representational)-                                  dsTcCoercion co (mkCast e)-dsHsWrapper (WpEvLam ev)      e = return $ Lam ev e -dsHsWrapper (WpTyLam tv)      e = return $ Lam tv e -dsHsWrapper (WpEvApp evtrm)   e = liftM (App e) (dsEvTerm evtrm)-----------------------------------------dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]-dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds"    -- Zonker has got rid of this-dsTcEvBinds (EvBinds bs)   = dsEvBinds bs--dsEvBinds :: Bag EvBind -> DsM [CoreBind]-dsEvBinds bs = mapM ds_scc (sccEvBinds bs)-  where-    ds_scc (AcyclicSCC (EvBind v r)) = liftM (NonRec v) (dsEvTerm r)-    ds_scc (CyclicSCC bs)            = liftM Rec (mapM ds_pair bs)--    ds_pair (EvBind v r) = liftM ((,) v) (dsEvTerm r)--sccEvBinds :: Bag EvBind -> [SCC EvBind]-sccEvBinds bs = stronglyConnCompFromEdgedVertices edges-  where-    edges :: [(EvBind, EvVar, [EvVar])]-    edges = foldrBag ((:) . mk_node) [] bs --    mk_node :: EvBind -> (EvBind, EvVar, [EvVar])-    mk_node b@(EvBind var term) = (b, var, varSetElems (evVarsOfTerm term))-------------------------------------------dsEvTerm :: EvTerm -> DsM CoreExpr-dsEvTerm (EvId v) = return (Var v)--dsEvTerm (EvCast tm co) -  = do { tm' <- dsEvTerm tm-       ; dsTcCoercion co $ mkCast tm' }-                        -- 'v' is always a lifted evidence variable so it is-                        -- unnecessary to call varToCoreExpr v here.--dsEvTerm (EvDFunApp df tys tms) = do { tms' <- mapM dsEvTerm tms-                                     ; return (Var df `mkTyApps` tys `mkApps` tms') }--dsEvTerm (EvCoercion (TcCoVarCo v)) = return (Var v)  -- See Note [Simple coercions]-dsEvTerm (EvCoercion co)            = dsTcCoercion co mkEqBox--dsEvTerm (EvTupleSel v n)-   = do { tm' <- dsEvTerm v-        ; let scrut_ty = exprType tm'-              (tc, tys) = splitTyConApp scrut_ty-    	      Just [dc] = tyConDataCons_maybe tc-    	      xs = mkTemplateLocals tys-              the_x = getNth xs n-        ; -- ASSERT( isTupleTyCon tc )-          return $-          Case tm' (mkWildValBinder scrut_ty) (idType the_x) [(DataAlt dc, xs, Var the_x)] }--dsEvTerm (EvTupleMk tms) -  = do { tms' <- mapM dsEvTerm tms-       ; let tys = map exprType tms'-       ; return $ Var (dataConWorkId dc) `mkTyApps` tys `mkApps` tms' }-  where -    dc = tupleCon ConstraintTuple (length tms)--dsEvTerm (EvSuperClass d n)-  = do { d' <- dsEvTerm d-       ; let (cls, tys) = getClassPredTys (exprType d')-             sc_sel_id  = classSCSelId cls n	-- Zero-indexed-       ; return $ Var sc_sel_id `mkTyApps` tys `App` d' }-  where--dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]-  where -    errorId = rUNTIME_ERROR_ID-    litMsg  = Lit (MachStr (fastStringToByteString msg))--dsEvTerm (EvLit l) =-  case l of-    EvNum n -> mkIntegerExpr n-    EvStr s -> mkStringExprFS s------------------------------------------dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr--- This is the crucial function that moves --- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion--- e.g.  dsTcCoercion (trans g1 g2) k---       = case g1 of EqBox g1# ->---         case g2 of EqBox g2# ->---         k (trans g1# g2#)--- thing_inside will get a coercion at the role requested-dsTcCoercion co thing_inside-  = do { us <- newUniqueSupply-       ; let eqvs_covs :: [(EqVar,CoVar)]-             eqvs_covs = zipWith mk_co_var (varSetElems (coVarsOfTcCo co))-                                           (uniqsFromSupply us)--             subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs]-             result_expr = thing_inside (ds_tc_coercion subst co)-             result_ty   = exprType result_expr--       ; return (foldr (wrap_in_case result_ty) result_expr eqvs_covs) }-  where-    mk_co_var :: Id -> Unique -> (Id, Id)-    mk_co_var eqv uniq = (eqv, mkUserLocal occ uniq ty loc)-       where-         eq_nm = idName eqv-         occ = nameOccName eq_nm-         loc = nameSrcSpan eq_nm-         ty  = mkCoercionType (getEqPredRole (evVarPred eqv)) ty1 ty2-         (ty1, ty2) = getEqPredTys (evVarPred eqv)--    wrap_in_case result_ty (eqv, cov) body-      = case getEqPredRole (evVarPred eqv) of-         Nominal          -> Case (Var eqv) eqv result_ty [(DataAlt eqBoxDataCon, [cov], body)]-         Representational -> Case (Var eqv) eqv result_ty [(DataAlt coercibleDataCon, [cov], body)]-         Phantom          -> panic "wrap_in_case/phantom"--ds_tc_coercion :: CvSubst -> TcCoercion -> Coercion--- If the incoming TcCoercion if of type (a ~ b)   (resp.  Coercible a b)---                 the result is of type (a ~# b)  (reps.  a ~# b)--- The VarEnv maps EqVars of type (a ~ b) to Coercions of type (a ~# b) (resp. and so on)--- No need for InScope set etc because the -ds_tc_coercion subst tc_co-  = go tc_co-  where-    go (TcRefl r ty)            = Refl r (Coercion.substTy subst ty)-    go (TcTyConAppCo r tc cos)  = mkTyConAppCo r tc (map go cos)-    go (TcAppCo co1 co2)        = let leftCo    = go co1-                                      rightRole = nextRole leftCo in-                                  mkAppCoFlexible leftCo rightRole (go co2)-    go (TcForAllCo tv co)       = mkForAllCo tv' (ds_tc_coercion subst' co)-                              where-                                (subst', tv') = Coercion.substTyVarBndr subst tv-    go (TcAxiomInstCo ax ind cos)-                                = AxiomInstCo ax ind (map go cos)-    go (TcPhantomCo ty1 ty2)    = UnivCo Phantom ty1 ty2-    go (TcSymCo co)             = mkSymCo (go co)-    go (TcTransCo co1 co2)      = mkTransCo (go co1) (go co2)-    go (TcNthCo n co)           = mkNthCo n (go co)-    go (TcLRCo lr co)           = mkLRCo lr (go co)-    go (TcSubCo co)             = mkSubCo (go co)-    go (TcLetCo bs co)          = ds_tc_coercion (ds_co_binds bs) co-    go (TcCastCo co1 co2)       = mkCoCast (go co1) (go co2)-    go (TcCoVarCo v)            = ds_ev_id subst v-    go (TcAxiomRuleCo co ts cs) = AxiomRuleCo co (map (Coercion.substTy subst) ts) (map go cs)--    ds_co_binds :: TcEvBinds -> CvSubst-    ds_co_binds (EvBinds bs)      = foldl ds_scc subst (sccEvBinds bs)-    ds_co_binds eb@(TcEvBinds {}) = pprPanic "ds_co_binds" (ppr eb)--    ds_scc :: CvSubst -> SCC EvBind -> CvSubst-    ds_scc subst (AcyclicSCC (EvBind v ev_term))-      = extendCvSubstAndInScope subst v (ds_co_term subst ev_term)-    ds_scc _ (CyclicSCC other) = pprPanic "ds_scc:cyclic" (ppr other $$ ppr tc_co)--    ds_co_term :: CvSubst -> EvTerm -> Coercion-    ds_co_term subst (EvCoercion tc_co) = ds_tc_coercion subst tc_co-    ds_co_term subst (EvId v)           = ds_ev_id subst v-    ds_co_term subst (EvCast tm co)     = mkCoCast (ds_co_term subst tm) (ds_tc_coercion subst co)-    ds_co_term _ other = pprPanic "ds_co_term" (ppr other $$ ppr tc_co)--    ds_ev_id :: CvSubst -> EqVar -> Coercion-    ds_ev_id subst v-     | Just co <- Coercion.lookupCoVar subst v = co-     | otherwise  = pprPanic "ds_tc_coercion" (ppr v $$ ppr tc_co)-\end{code}--Note [Simple coercions]-~~~~~~~~~~~~~~~~~~~~~~~-We have a special case for coercions that are simple variables.-Suppose   cv :: a ~ b   is in scope-Lacking the special case, if we see-	f a b cv-we'd desguar to-        f a b (case cv of EqBox (cv# :: a ~# b) -> EqBox cv#)-which is a bit stupid.  The special case does the obvious thing.--This turns out to be important when desugaring the LHS of a RULE-(see Trac #7837).  Suppose we have-    normalise        :: (a ~ Scalar a) => a -> a-    normalise_Double :: Double -> Double-    {-# RULES "normalise" normalise = normalise_Double #-}--Then the RULE we want looks like-     forall a, (cv:a~Scalar a). -       normalise a cv = normalise_Double-But without the special case we generate the redundant box/unbox,-which simpleOpt (currently) doesn't remove. So the rule never matches.--Maybe simpleOpt should be smarter.  But it seems like a good plan-to simply never generate the redundant box/unbox in the first place.--
− src/Language/Haskell/Liquid/Desugar/DsExpr.lhs 
@@ -1,867 +0,0 @@-%-% (c) The University of Glasgow 2006-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998-%--Desugaring exporessions.--\begin{code}-module Language.Haskell.Liquid.Desugar.DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where--import Language.Haskell.Liquid.Desugar.Match-import Language.Haskell.Liquid.Desugar.MatchLit-import Language.Haskell.Liquid.Desugar.DsBinds-import Language.Haskell.Liquid.Desugar.DsGRHSs-import Language.Haskell.Liquid.Desugar.DsListComp-import Language.Haskell.Liquid.Desugar.DsUtils-import Language.Haskell.Liquid.Desugar.DsArrows-import DsMonad-import Name-import NameEnv-import FamInstEnv( topNormaliseType )--import HsSyn---- NB: The desugarer, which straddles the source and Core worlds, sometimes---     needs to see source types-import TcType-import Coercion ( Role(..) )-import TcEvidence-import TcRnMonad-import Type-import CoreSyn-import CoreUtils-import CoreFVs-import MkCore--import DynFlags-import CostCentre-import Id-import Module-import VarSet-import VarEnv-import ConLike-import DataCon-import TysWiredIn-import BasicTypes-import Maybes-import SrcLoc-import Util-import Bag-import Outputable-import FastString--import Control.Monad--srcSpanTick :: Module -> SrcSpan -> Tickish a-srcSpanTick m loc-  = ProfNote (AllCafsCC m loc) False True--\end{code}---%************************************************************************-%*                                                                      *-                dsLocalBinds, dsValBinds-%*                                                                      *-%************************************************************************--\begin{code}-dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr-dsLocalBinds EmptyLocalBinds    body = return body-dsLocalBinds (HsValBinds binds) body = dsValBinds binds body-dsLocalBinds (HsIPBinds binds)  body = dsIPBinds  binds body----------------------------dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr-dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds-dsValBinds (ValBindsIn  _     _) _    = panic "dsValBinds ValBindsIn"----------------------------dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr-dsIPBinds (IPBinds ip_binds ev_binds) body-  = do  { ds_binds <- dsTcEvBinds ev_binds-        ; let inner = mkCoreLets ds_binds body-                -- The dict bindings may not be in -                -- dependency order; hence Rec-        ; foldrM ds_ip_bind inner ip_binds }-  where-    ds_ip_bind (L _ (IPBind ~(Right n) e)) body-      = do e' <- dsLExpr e-           return (Let (NonRec n e') body)----------------------------ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr--- Special case for bindings which bind unlifted variables--- We need to do a case right away, rather than building--- a tuple and doing selections.--- Silently ignore INLINE and SPECIALISE pragmas...-ds_val_bind (NonRecursive, hsbinds) body-  | [L loc bind] <- bagToList hsbinds,-        -- Non-recursive, non-overloaded bindings only come in ones-        -- ToDo: in some bizarre case it's conceivable that there-        --       could be dict binds in the 'binds'.  (See the notes-        --       below.  Then pattern-match would fail.  Urk.)-    strictMatchOnly bind-  = putSrcSpanDs loc (dsStrictBind bind body)---- Ordinary case for bindings; none should be unlifted-ds_val_bind (_is_rec, binds) body-  = do  { prs <- dsLHsBinds binds-        ; -- ASSERT2( not (any (isUnLiftedType . idType . fst) prs), ppr _is_rec $$ ppr binds )-          case prs of-            [] -> return body-            _  -> return (Let (Rec prs) body) }-        -- Use a Rec regardless of is_rec. -        -- Why? Because it allows the binds to be all-        -- mixed up, which is what happens in one rare case-        -- Namely, for an AbsBind with no tyvars and no dicts,-        --         but which does have dictionary bindings.-        -- See notes with TcSimplify.inferLoop [NO TYVARS]-        -- It turned out that wrapping a Rec here was the easiest solution-        ---        -- NB The previous case dealt with unlifted bindings, so we-        --    only have to deal with lifted ones now; so Rec is ok---------------------dsStrictBind :: HsBind Id -> CoreExpr -> DsM CoreExpr-dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []-               , abs_exports = exports-               , abs_ev_binds = ev_binds-               , abs_binds = lbinds }) body-  = do { let body1 = foldr bind_export body exports-             bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b-       ; body2 <- foldlBagM (\body lbind -> dsStrictBind (unLoc lbind) body)-                            body1 lbinds -       ; ds_binds <- dsTcEvBinds ev_binds-       ; return (mkCoreLets ds_binds body2) }--dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches-                      , fun_tick = tick, fun_infix = inf }) body-                -- Can't be a bang pattern (that looks like a PatBind)-                -- so must be simply unboxed-  = do { (_, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches---        ; MASSERT( null args ) -- Functions aren't lifted---        ; MASSERT( isIdHsWrapper co_fn )-       ; let rhs' = mkOptTickBox tick rhs-       ; return (bindNonRec fun rhs' body) }--dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body-  =     -- let C x# y# = rhs in body-        -- ==> case rhs of C x# y# -> body-    do { rhs <- dsGuarded grhss ty-       ; let upat = unLoc pat-             eqn = EqnInfo { eqn_pats = [upat], -                             eqn_rhs = cantFailMatchResult body }-       ; var    <- selectMatchVar upat-       ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)-       ; return (bindNonRec var rhs result) }--dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)-------------------------strictMatchOnly :: HsBind Id -> Bool-strictMatchOnly (AbsBinds { abs_binds = lbinds })-  = anyBag (strictMatchOnly . unLoc) lbinds-strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = rhs_ty })-  =  isUnLiftedType rhs_ty-  || isStrictLPat lpat-  || any (isUnLiftedType . idType) (collectPatBinders lpat)-strictMatchOnly (FunBind { fun_id = L _ id })-  = isUnLiftedType (idType id)-strictMatchOnly _ = False -- I hope!  Checked immediately by caller in fact--\end{code}--%************************************************************************-%*                                                                      *-\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}-%*                                                                      *-%************************************************************************--\begin{code}-dsLExpr :: LHsExpr Id -> DsM CoreExpr--dsLExpr (L loc e) -  = do ce <- putSrcSpanDs loc $ dsExpr e-       m  <- getModule-       return $ Tick (srcSpanTick m loc) ce--dsExpr :: HsExpr Id -> DsM CoreExpr-dsExpr (HsPar e)              = dsLExpr e-dsExpr (ExprWithTySigOut e _) = dsLExpr e-dsExpr (HsVar var)            = return (varToCoreExpr var)   -- See Note [Desugaring vars]-dsExpr (HsIPVar _)            = panic "dsExpr: HsIPVar"-dsExpr (HsLit lit)            = dsLit lit-dsExpr (HsOverLit lit)        = dsOverLit lit--dsExpr (HsWrap co_fn e)-  = do { e' <- dsExpr e-       ; wrapped_e <- dsHsWrapper co_fn e'-       ; dflags <- getDynFlags-       ; warnAboutIdentities dflags e' (exprType wrapped_e)-       ; return wrapped_e }--dsExpr (NegApp expr neg_expr) -  = App <$> dsExpr neg_expr <*> dsLExpr expr--dsExpr (HsLam a_Match)-  = uncurry mkLams <$> matchWrapper LambdaExpr a_Match--dsExpr (HsLamCase arg matches)-  = do { arg_var <- newSysLocalDs arg-       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches-       ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }--dsExpr (HsApp fun arg)-  = mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg--dsExpr (HsUnboundVar _) = panic "dsExpr: HsUnboundVar"-\end{code}--Note [Desugaring vars]-~~~~~~~~~~~~~~~~~~~~~~-In one situation we can get a *coercion* variable in a HsVar, namely-the support method for an equality superclass:-   class (a~b) => C a b where ...-   instance (blah) => C (T a) (T b) where ..-Then we get-   $dfCT :: forall ab. blah => C (T a) (T b)-   $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah)--   $c$p1C :: forall ab. blah => (T a ~ T b)-   $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g--That 'g' in the 'in' part is an evidence variable, and when-converting to core it must become a CO.-   -Operator sections.  At first it looks as if we can convert-\begin{verbatim}-        (expr op)-\end{verbatim}-to-\begin{verbatim}-        \x -> op expr x-\end{verbatim}--But no!  expr might be a redex, and we can lose laziness badly this-way.  Consider-\begin{verbatim}-        map (expr op) xs-\end{verbatim}-for example.  So we convert instead to-\begin{verbatim}-        let y = expr in \x -> op y x-\end{verbatim}-If \tr{expr} is actually just a variable, say, then the simplifier-will sort it out.--\begin{code}-dsExpr (OpApp e1 op _ e2)-  = -- for the type of y, we need the type of op's 2nd argument-    mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2]-    -dsExpr (SectionL expr op)       -- Desugar (e !) to ((!) e)-  = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr---- dsLExpr (SectionR op expr)   -- \ x -> op x expr-dsExpr (SectionR op expr) = do-    core_op <- dsLExpr op-    -- for the type of x, we need the type of op's 2nd argument-    let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)-        -- See comment with SectionL-    y_core <- dsLExpr expr-    x_id <- newSysLocalDs x_ty-    y_id <- newSysLocalDs y_ty-    return (bindNonRec y_id y_core $-            Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))--dsExpr (ExplicitTuple tup_args boxity)-  = do { let go (lam_vars, args) (Missing ty)-                    -- For every missing expression, we need-                    -- another lambda in the desugaring.-               = do { lam_var <- newSysLocalDs ty-                    ; return (lam_var : lam_vars, Var lam_var : args) }-             go (lam_vars, args) (Present expr)-                    -- Expressions that are present don't generate-                    -- lambdas, just arguments.-               = do { core_expr <- dsLExpr expr-                    ; return (lam_vars, core_expr : args) }--       ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)-                -- The reverse is because foldM goes left-to-right--       ; return $ mkCoreLams lam_vars $ -                  mkConApp (tupleCon (boxityNormalTupleSort boxity) (length tup_args))-                           (map (Type . exprType) args ++ args) }--dsExpr (HsSCC cc expr@(L loc _)) = do-    mod_name <- getModule-    count <- goptM Opt_ProfCountEntries-    uniq <- newUnique-    Tick (ProfNote (mkUserCC cc mod_name loc uniq) count True) <$> dsLExpr expr--dsExpr (HsCoreAnn _ expr)-  = dsLExpr expr--dsExpr (HsCase discrim matches)-  = do { core_discrim <- dsLExpr discrim-       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches-       ; return (bindNonRec discrim_var core_discrim matching_code) }---- Pepe: The binds are in scope in the body but NOT in the binding group---       This is to avoid silliness in breakpoints-dsExpr (HsLet binds body) = do-    body' <- dsLExpr body-    dsLocalBinds binds body'---- We need the `ListComp' form to use `deListComp' (rather than the "do" form)--- because the interpretation of `stmts' depends on what sort of thing it is.----dsExpr (HsDo ListComp     stmts res_ty) = dsListComp stmts res_ty-dsExpr (HsDo PArrComp     stmts _)      = dsPArrComp (map unLoc stmts)-dsExpr (HsDo DoExpr       stmts _)      = dsDo stmts -dsExpr (HsDo GhciStmtCtxt stmts _)      = dsDo stmts -dsExpr (HsDo MDoExpr      stmts _)      = dsDo stmts -dsExpr (HsDo MonadComp    stmts _)      = dsMonadComp stmts--dsExpr (HsIf mb_fun guard_expr then_expr else_expr)-  = do { pred <- dsLExpr guard_expr-       ; b1 <- dsLExpr then_expr-       ; b2 <- dsLExpr else_expr-       ; case mb_fun of-           Just fun -> do { core_fun <- dsExpr fun-                          ; return (mkCoreApps core_fun [pred,b1,b2]) }-           Nothing  -> return $ mkIfThenElse pred b1 b2 }--dsExpr (HsMultiIf res_ty alts)-  | null alts-  = mkErrorExpr--  | otherwise-  = do { match_result <- liftM (foldr1 combineMatchResults)-                               (mapM (dsGRHS IfAlt res_ty) alts)-       ; error_expr   <- mkErrorExpr-       ; extractMatchResult match_result error_expr }-  where-    mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty-                               (ptext (sLit "multi-way if"))-\end{code}---\noindent-\underline{\bf Various data construction things}-%              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-\begin{code}-dsExpr (ExplicitList elt_ty wit xs) -  = dsExplicitList elt_ty wit xs---- We desugar [:x1, ..., xn:] as---   singletonP x1 +:+ ... +:+ singletonP xn----dsExpr (ExplicitPArr ty []) = do-    emptyP <- dsDPHBuiltin emptyPVar-    return (Var emptyP `App` Type ty)-dsExpr (ExplicitPArr ty xs) = do-    singletonP <- dsDPHBuiltin singletonPVar-    appP       <- dsDPHBuiltin appPVar-    xs'        <- mapM dsLExpr xs-    return . foldr1 (binary appP) $ map (unary singletonP) xs'-  where-    unary  fn x   = mkApps (Var fn) [Type ty, x]-    binary fn x y = mkApps (Var fn) [Type ty, x, y]--dsExpr (ArithSeq expr witness seq)-  = case witness of-     Nothing -> dsArithSeq expr seq-     Just fl -> do { -       ; fl' <- dsExpr fl-       ; newArithSeq <- dsArithSeq expr seq-       ; return (App fl' newArithSeq)}--dsExpr (PArrSeq expr (FromTo from to))-  = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]--dsExpr (PArrSeq expr (FromThenTo from thn to))-  = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]--dsExpr (PArrSeq _ _)-  = panic "DsExpr.dsExpr: Infinite parallel array!"-    -- the parser shouldn't have generated it and the renamer and typechecker-    -- shouldn't have let it through-\end{code}--\noindent-\underline{\bf Record construction and update}-%              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For record construction we do this (assuming T has three arguments)-\begin{verbatim}-        T { op2 = e }-==>-        let err = /\a -> recConErr a -        T (recConErr t1 "M.lhs/230/op1") -          e -          (recConErr t1 "M.lhs/230/op3")-\end{verbatim}-@recConErr@ then converts its arugment string into a proper message-before printing it as-\begin{verbatim}-        M.lhs, line 230: missing field op1 was evaluated-\end{verbatim}--We also handle @C{}@ as valid construction syntax for an unlabelled-constructor @C@, setting all of @C@'s fields to bottom.--\begin{code}-dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do-    con_expr' <- dsExpr con_expr-    let-        (arg_tys, _) = tcSplitFunTys (exprType con_expr')-        -- A newtype in the corner should be opaque; -        -- hence TcType.tcSplitFunTys--        mk_arg (arg_ty, lbl)    -- Selector id has the field label as its name-          = case findField (rec_flds rbinds) lbl of-              (rhs:_) -> -- ASSERT( null rhss )-                            dsLExpr rhs-              []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl)-        unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty empty--        labels = dataConFieldLabels (idDataCon data_con_id)-        -- The data_con_id is guaranteed to be the wrapper id of the constructor-    -    con_args <- if null labels-                then mapM unlabelled_bottom arg_tys-                else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)-    -    return (mkApps con_expr' con_args)-\end{code}--Record update is a little harder. Suppose we have the decl:-\begin{verbatim}-        data T = T1 {op1, op2, op3 :: Int}-               | T2 {op4, op2 :: Int}-               | T3-\end{verbatim}-Then we translate as follows:-\begin{verbatim}-        r { op2 = e }-===>-        let op2 = e in-        case r of-          T1 op1 _ op3 -> T1 op1 op2 op3-          T2 op4 _     -> T2 op4 op2-          other        -> recUpdError "M.lhs/230"-\end{verbatim}-It's important that we use the constructor Ids for @T1@, @T2@ etc on the-RHSs, and do not generate a Core constructor application directly, because the constructor-might do some argument-evaluation first; and may have to throw away some-dictionaries.--Note [Update for GADTs]-~~~~~~~~~~~~~~~~~~~~~~~-Consider -   data T a b where-     T1 { f1 :: a } :: T a Int--Then the wrapper function for T1 has type -   $WT1 :: a -> T a Int-But if x::T a b, then-   x { f1 = v } :: T a b   (not T a Int!)-So we need to cast (T a Int) to (T a b).  Sigh.--\begin{code}-dsExpr (RecordUpd record_expr (HsRecFields { rec_flds = fields })-                       cons_to_upd in_inst_tys out_inst_tys)-  | null fields-  = dsLExpr record_expr-  | otherwise-  = -- ASSERT2( notNull cons_to_upd, ppr expr )--    do  { record_expr' <- dsLExpr record_expr-        ; field_binds' <- mapM ds_field fields-        ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding-              upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']--        -- It's important to generate the match with matchWrapper,-        -- and the right hand sides with applications of the wrapper Id-        -- so that everything works when we are doing fancy unboxing on the-        -- constructor aguments.-        ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd-        ; ([discrim_var], matching_code) -                <- matchWrapper RecUpd (MG { mg_alts = alts, mg_arg_tys = [in_ty], mg_res_ty = out_ty, mg_origin = Generated })--        ; return (add_field_binds field_binds' $-                  bindNonRec discrim_var record_expr' matching_code) }-  where-    ds_field :: HsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)-      -- Clone the Id in the HsRecField, because its Name is that-      -- of the record selector, and we must not make that a lcoal binder-      -- else we shadow other uses of the record selector-      -- Hence 'lcl_id'.  Cf Trac #2735-    ds_field rec_field = do { rhs <- dsLExpr (hsRecFieldArg rec_field)-                            ; let fld_id = unLoc (hsRecFieldId rec_field)-                            ; lcl_id <- newSysLocalDs (idType fld_id)-                            ; return (idName fld_id, lcl_id, rhs) }--    add_field_binds [] expr = expr-    add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)--        -- Awkwardly, for families, the match goes -        -- from instance type to family type-    tycon     = dataConTyCon (head cons_to_upd)-    in_ty     = mkTyConApp tycon in_inst_tys-    out_ty    = mkFamilyTyConApp tycon out_inst_tys--    mk_alt upd_fld_env con-      = do { let (univ_tvs, ex_tvs, eq_spec, -                  theta, arg_tys, _) = dataConFullSig con-                 subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys)--                -- I'm not bothering to clone the ex_tvs-           ; eqs_vars   <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))-           ; theta_vars <- mapM newPredVarDs (substTheta subst theta)-           ; arg_ids    <- newSysLocalsDs (substTys subst arg_tys)-           ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg-                                         (dataConFieldLabels con) arg_ids-                 mk_val_arg field_name pat_arg_id -                     = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)-                 inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))-                        -- Reconstruct with the WrapId so that unpacking happens-                 wrap = mkWpEvVarApps theta_vars          <.>-                        mkWpTyApps    (mkTyVarTys ex_tvs) <.>-                        mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys-                                       , not (tv `elemVarEnv` wrap_subst) ]-                 rhs = foldl (\a b -> nlHsApp a b) inst_con val_args--                        -- Tediously wrap the application in a cast-                        -- Note [Update for GADTs]-                 wrap_co = mkTcTyConAppCo Nominal tycon-                                [ lookup tv ty | (tv,ty) <- univ_tvs `zip` out_inst_tys ]-                 lookup univ_tv ty = case lookupVarEnv wrap_subst univ_tv of-                                        Just co' -> co'-                                        Nothing  -> mkTcReflCo Nominal ty-                 wrap_subst = mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var))-                                       | ((tv,_),eq_var) <- eq_spec `zip` eqs_vars ]--                 pat = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon con)-                                         , pat_tvs = ex_tvs-                                         , pat_dicts = eqs_vars ++ theta_vars-                                         , pat_binds = emptyTcEvBinds-                                         , pat_args = PrefixCon $ map nlVarPat arg_ids-                                         , pat_arg_tys = in_inst_tys-                                         , pat_wrap = idHsWrapper }-           ; let wrapped_rhs | null eq_spec = rhs-                             | otherwise    = mkLHsWrap (mkWpCast (mkTcSubCo wrap_co)) rhs-           ; return (mkSimpleMatch [pat] wrapped_rhs) }--\end{code}--Here is where we desugar the Template Haskell brackets and escapes--\begin{code}--- Template Haskell stuff--dsExpr (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut"--- #ifdef GHCI--- dsExpr (HsTcBracketOut x ps) = dsBracket x ps--- #else-dsExpr (HsTcBracketOut _ _) = panic "dsExpr HsBracketOut"--- #endif-dsExpr (HsSpliceE _ s)      = pprPanic "dsExpr:splice" (ppr s)---- Arrow notation extension-dsExpr (HsProc pat cmd) = dsProcExpr pat cmd-\end{code}--Hpc Support --\begin{code}-dsExpr (HsTick tickish e) = do-  e' <- dsLExpr e-  return (Tick tickish e')---- There is a problem here. The then and else branches--- have no free variables, so they are open to lifting.--- We need someway of stopping this.--- This will make no difference to binary coverage--- (did you go here: YES or NO), but will effect accurate--- tick counting.--dsExpr (HsBinTick ixT ixF e) = do-  e2 <- dsLExpr e-  do { -- ASSERT(exprType e2 `eqType` boolTy)-       mkBinaryTickBox ixT ixF e2-     }-\end{code}--\begin{code}---- HsSyn constructs that just shouldn't be here:-dsExpr (ExprWithTySig {})  = panic "dsExpr:ExprWithTySig"-dsExpr (HsBracket     {})  = panic "dsExpr:HsBracket"-dsExpr (HsQuasiQuoteE {})  = panic "dsExpr:HsQuasiQuoteE"-dsExpr (HsArrApp      {})  = panic "dsExpr:HsArrApp"-dsExpr (HsArrForm     {})  = panic "dsExpr:HsArrForm"-dsExpr (HsTickPragma  {})  = panic "dsExpr:HsTickPragma"-dsExpr (EWildPat      {})  = panic "dsExpr:EWildPat"-dsExpr (EAsPat        {})  = panic "dsExpr:EAsPat"-dsExpr (EViewPat      {})  = panic "dsExpr:EViewPat"-dsExpr (ELazyPat      {})  = panic "dsExpr:ELazyPat"-dsExpr (HsType        {})  = panic "dsExpr:HsType"-dsExpr (HsDo          {})  = panic "dsExpr:HsDo"---findField :: [HsRecField Id arg] -> Name -> [arg]-findField rbinds lbl -  = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds -         , lbl == idName (unLoc id) ]-\end{code}--%----------------------------------------------------------------------Note [Desugaring explicit lists]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Explicit lists are desugared in a cleverer way to prevent some-fruitless allocations.  Essentially, whenever we see a list literal-[x_1, ..., x_n] we:--1. Find the tail of the list that can be allocated statically (say-   [x_k, ..., x_n]) by later stages and ensure we desugar that-   normally: this makes sure that we don't cause a code size increase-   by having the cons in that expression fused (see later) and hence-   being unable to statically allocate any more--2. For the prefix of the list which cannot be allocated statically,-   say [x_1, ..., x_(k-1)], we turn it into an expression involving-   build so that if we find any foldrs over it it will fuse away-   entirely!-   -   So in this example we will desugar to:-   build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]-   -   If fusion fails to occur then build will get inlined and (since we-   defined a RULE for foldr (:) []) we will get back exactly the-   normal desugaring for an explicit list.--This optimisation can be worth a lot: up to 25% of the total-allocation in some nofib programs. Specifically--        Program           Size    Allocs   Runtime  CompTime-        rewrite          +0.0%    -26.3%      0.02     -1.8%-           ansi          -0.3%    -13.8%      0.00     +0.0%-           lift          +0.0%     -8.7%      0.00     -2.3%--Of course, if rules aren't turned on then there is pretty much no-point doing this fancy stuff, and it may even be harmful.--=======>  Note by SLPJ Dec 08.--I'm unconvinced that we should *ever* generate a build for an explicit-list.  See the comments in GHC.Base about the foldr/cons rule, which -points out that (foldr k z [a,b,c]) may generate *much* less code than-(a `k` b `k` c `k` z).--Furthermore generating builds messes up the LHS of RULES. -Example: the foldr/single rule in GHC.Base-   foldr k z [x] = ...-We do not want to generate a build invocation on the LHS of this RULE!--We fix this by disabling rules in rule LHSs, and testing that-flag here; see Note [Desugaring RULE left hand sides] in Desugar--To test this I've added a (static) flag -fsimple-list-literals, which-makes all list literals be generated via the simple route.  ---\begin{code}-dsExplicitList :: PostTcType -> Maybe (SyntaxExpr Id) -> [LHsExpr Id] -> DsM CoreExpr--- See Note [Desugaring explicit lists]-dsExplicitList elt_ty Nothing xs-  = do { dflags <- getDynFlags-       ; xs' <- mapM dsLExpr xs-       ; let (dynamic_prefix, static_suffix) = spanTail is_static xs'-       ; if gopt Opt_SimpleListLiterals dflags        -- -fsimple-list-literals-         || not (gopt Opt_EnableRewriteRules dflags)  -- Rewrite rules off-                -- Don't generate a build if there are no rules to eliminate it!-                -- See Note [Desugaring RULE left hand sides] in Desugar-         || null dynamic_prefix   -- Avoid build (\c n. foldr c n xs)!-         then return $ mkListExpr elt_ty xs'-         else mkBuildExpr elt_ty (mkSplitExplicitList dynamic_prefix static_suffix) }-  where-    is_static :: CoreExpr -> Bool-    is_static e = all is_static_var (varSetElems (exprFreeVars e))--    is_static_var :: Var -> Bool-    is_static_var v -      | isId v = isExternalName (idName v)  -- Top-level things are given external names-      | otherwise = False                   -- Type variables--    mkSplitExplicitList prefix suffix (c, _) (n, n_ty)-      = do { let suffix' = mkListExpr elt_ty suffix-           ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix'-           ; return (foldr (App . App (Var c)) folded_suffix prefix) }--dsExplicitList elt_ty (Just fln) xs-  = do { fln' <- dsExpr fln-       ; list <- dsExplicitList elt_ty Nothing xs-       ; dflags <- getDynFlags-       ; return (App (App fln' (mkIntExprInt dflags (length xs))) list) }-       -spanTail :: (a -> Bool) -> [a] -> ([a], [a])-spanTail f xs = (reverse rejected, reverse satisfying)-    where (satisfying, rejected) = span f $ reverse xs-    -dsArithSeq :: PostTcExpr -> (ArithSeqInfo Id) -> DsM CoreExpr-dsArithSeq expr (From from)-  = App <$> dsExpr expr <*> dsLExpr from-dsArithSeq expr (FromTo from to)-  = do dflags <- getDynFlags-       warnAboutEmptyEnumerations dflags from Nothing to-       expr' <- dsExpr expr-       from' <- dsLExpr from-       to'   <- dsLExpr to-       return $ mkApps expr' [from', to']-dsArithSeq expr (FromThen from thn)-  = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]-dsArithSeq expr (FromThenTo from thn to)-  = do dflags <- getDynFlags-       warnAboutEmptyEnumerations dflags from (Just thn) to-       expr' <- dsExpr expr-       from' <- dsLExpr from-       thn'  <- dsLExpr thn-       to'   <- dsLExpr to-       return $ mkApps expr' [from', thn', to']-\end{code}--Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're-handled in DsListComp).  Basically does the translation given in the-Haskell 98 report:--\begin{code}-dsDo :: [ExprLStmt Id] -> DsM CoreExpr-dsDo stmts-  = goL stmts-  where-    goL [] = panic "dsDo"-    goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts)-  -    go _ (LastStmt body _) _-      = {- ASSERT( null stmts ) -} dsLExpr body-        -- The 'return' op isn't used for 'do' expressions--    go _ (BodyStmt rhs then_expr _ _) stmts-      = do { rhs2 <- dsLExpr rhs-           ; warnDiscardedDoBindings rhs (exprType rhs2) -           ; then_expr2 <- dsExpr then_expr-           ; rest <- goL stmts-           ; return (mkApps then_expr2 [rhs2, rest]) }-    -    go _ (LetStmt binds) stmts-      = do { rest <- goL stmts-           ; dsLocalBinds binds rest }--    go _ (BindStmt pat rhs bind_op fail_op) stmts-      = do  { body     <- goL stmts-            ; rhs'     <- dsLExpr rhs-            ; bind_op' <- dsExpr bind_op-            ; var   <- selectSimpleMatchVarL pat-            ; let bind_ty = exprType bind_op'   -- rhs -> (pat -> res1) -> res2-                  res1_ty = funResultTy (funArgTy (funResultTy bind_ty))-            ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat-                                      res1_ty (cantFailMatchResult body)-            ; match_code <- handle_failure pat match fail_op-            ; return (mkApps bind_op' [rhs', Lam var match_code]) }-    -    go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids-                    , recS_rec_ids = rec_ids, recS_ret_fn = return_op-                    , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op-                    , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts-      = goL (new_bind_stmt : stmts)  -- rec_ids can be empty; eg  rec { print 'x' }-      where-        new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTup later_pats)-                                         mfix_app bind_op -                                         noSyntaxExpr  -- Tuple cannot fail--        tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids-        tup_ty       = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case-        rec_tup_pats = map nlVarPat tup_ids-        later_pats   = rec_tup_pats-        rets         = map noLoc rec_rets-        mfix_app     = nlHsApp (noLoc mfix_op) mfix_arg-        mfix_arg     = noLoc $ HsLam (MG { mg_alts = [mkSimpleMatch [mfix_pat] body]-                                         , mg_arg_tys = [tup_ty], mg_res_ty = body_ty-                                         , mg_origin = Generated })-        mfix_pat     = noLoc $ LazyPat $ mkBigLHsPatTup rec_tup_pats-        body         = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty-        ret_app      = nlHsApp (noLoc return_op) (mkBigLHsTup rets)-        ret_stmt     = noLoc $ mkLastStmt ret_app-                     -- This LastStmt will be desugared with dsDo, -                     -- which ignores the return_op in the LastStmt,-                     -- so we must apply the return_op explicitly --    go _ (ParStmt   {}) _ = panic "dsDo ParStmt"-    go _ (TransStmt {}) _ = panic "dsDo TransStmt"--handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr-    -- In a do expression, pattern-match failure just calls-    -- the monadic 'fail' rather than throwing an exception-handle_failure pat match fail_op-  | matchCanFail match-  = do { fail_op' <- dsExpr fail_op-       ; dflags <- getDynFlags-       ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)-       ; extractMatchResult match (App fail_op' fail_msg) }-  | otherwise-  = extractMatchResult match (error "It can't fail")--mk_fail_msg :: DynFlags -> Located e -> String-mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ -                         showPpr dflags (getLoc pat)-\end{code}---%************************************************************************-%*                                                                      *-\subsection{Errors and contexts}-%*                                                                      *-%************************************************************************--\begin{code}--- Warn about certain types of values discarded in monadic bindings (#3263)-warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM ()-warnDiscardedDoBindings rhs rhs_ty-  | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty-  = do { warn_unused <- woptM Opt_WarnUnusedDoBind-       ; warn_wrong <- woptM Opt_WarnWrongDoBind-       ; when (warn_unused || warn_wrong) $-    do { fam_inst_envs <- dsGetFamInstEnvs-       ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty--           -- Warn about discarding non-() things in 'monadic' binding-       ; if warn_unused && not (isUnitTy norm_elt_ty)-         then warnDs (badMonadBind rhs elt_ty-                           (ptext (sLit "-fno-warn-unused-do-bind")))-         else--           -- Warn about discarding m a things in 'monadic' binding of the same type,-           -- but only if we didn't already warn due to Opt_WarnUnusedDoBind-           when warn_wrong $-                do { case tcSplitAppTy_maybe norm_elt_ty of-                         Just (elt_m_ty, _)-                            | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty-                            -> warnDs (badMonadBind rhs elt_ty-                                           (ptext (sLit "-fno-warn-wrong-do-bind")))-                         _ -> return () } } }--  | otherwise   -- RHS does have type of form (m ty), which is weird-  = return ()   -- but at lesat this warning is irrelevant--badMonadBind :: LHsExpr Id -> Type -> SDoc -> SDoc-badMonadBind rhs elt_ty flag_doc-  = vcat [ hang (ptext (sLit "A do-notation statement discarded a result of type"))-              2 (quotes (ppr elt_ty))-         , hang (ptext (sLit "Suppress this warning by saying"))-              2 (quotes $ ptext (sLit "_ <-") <+> ppr rhs)-         , ptext (sLit "or by using the flag") <+>  flag_doc ]-\end{code}
− src/Language/Haskell/Liquid/Desugar/DsExpr.lhs-boot 
@@ -1,11 +0,0 @@-\begin{code}-module Language.Haskell.Liquid.Desugar.DsExpr where-import HsSyn    ( HsExpr, LHsExpr, HsLocalBinds )-import Var      ( Id )-import DsMonad  ( DsM )-import CoreSyn  ( CoreExpr )--dsExpr  :: HsExpr  Id -> DsM CoreExpr-dsLExpr :: LHsExpr Id -> DsM CoreExpr-dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr-\end{code}
− src/Language/Haskell/Liquid/Desugar/DsForeign.lhs 
@@ -1,807 +0,0 @@-%-% (c) The University of Glasgow 2006-% (c) The AQUA Project, Glasgow University, 1998-%--Desugaring foreign declarations (see also DsCCall).--\begin{code}-module Language.Haskell.Liquid.Desugar.DsForeign ( dsForeigns-                 , dsForeigns'-                 , dsFImport, dsCImport, dsFCall, dsPrimCall-                 , dsFExport, dsFExportDynamic, mkFExportCBits-                 , toCType-                 , foreignExportInitialiser-                 ) where---- #include "HsVersions.h"-import TcRnMonad        -- temp--import TypeRep--import CoreSyn--import DsCCall-import DsMonad--import HsSyn-import DataCon-import CoreUnfold-import Id-import Literal-import Module-import Name-import Type-import TyCon-import Coercion-import TcEnv-import TcType--import CmmExpr-import CmmUtils-import HscTypes-import ForeignCall-import TysWiredIn-import TysPrim-import PrelNames-import BasicTypes-import SrcLoc-import Outputable-import FastString-import DynFlags-import Platform-import Config-import OrdList-import Pair-import Hooks--import Data.Maybe-import Data.List-\end{code}--Desugaring of @foreign@ declarations is naturally split up into-parts, an @import@ and an @export@  part. A @foreign import@-declaration-\begin{verbatim}-  foreign import cc nm f :: prim_args -> IO prim_res-\end{verbatim}-is the same as-\begin{verbatim}-  f :: prim_args -> IO prim_res-  f a1 ... an = _ccall_ nm cc a1 ... an-\end{verbatim}-so we reuse the desugaring code in @DsCCall@ to deal with these.--\begin{code}-type Binding = (Id, CoreExpr)   -- No rec/nonrec structure;-                                -- the occurrence analyser will sort it all out--dsForeigns :: [LForeignDecl Id]-           -> DsM (ForeignStubs, OrdList Binding)-dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos)--dsForeigns' :: [LForeignDecl Id]-            -> DsM (ForeignStubs, OrdList Binding)-dsForeigns' []-  = return (NoStubs, nilOL)-dsForeigns' fos = do-    fives <- mapM do_ldecl fos-    let-        (hs, cs, idss, bindss) = unzip4 fives-        fe_ids = concat idss-        fe_init_code = map foreignExportInitialiser fe_ids-    ---    return (ForeignStubs-             (vcat hs)-             (vcat cs $$ vcat fe_init_code),-            foldr (appOL . toOL) nilOL bindss)-  where-   do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)--   do_decl (ForeignImport id _ co spec) = do-      traceIf (text "fi start" <+> ppr id)-      (bs, h, c) <- dsFImport (unLoc id) co spec-      traceIf (text "fi end" <+> ppr id)-      return (h, c, [], bs)--   do_decl (ForeignExport (L _ id) _ co (CExport (CExportStatic ext_nm cconv))) = do-      (h, c, _, _) <- dsFExport id co ext_nm cconv False-      return (h, c, [id], [])-\end{code}---%************************************************************************-%*                                                                      *-\subsection{Foreign import}-%*                                                                      *-%************************************************************************--Desugaring foreign imports is just the matter of creating a binding-that on its RHS unboxes its arguments, performs the external call-(using the @CCallOp@ primop), before boxing the result up and returning it.--However, we create a worker/wrapper pair, thus:--        foreign import f :: Int -> IO Int-==>-        f x = IO ( \s -> case x of { I# x# ->-                         case fw s x# of { (# s1, y# #) ->-                         (# s1, I# y# #)}})--        fw s x# = ccall f s x#--The strictness/CPR analyser won't do this automatically because it doesn't look-inside returned tuples; but inlining this wrapper is a Really Good Idea-because it exposes the boxing to the call site.--\begin{code}-dsFImport :: Id-          -> Coercion-          -> ForeignImport-          -> DsM ([Binding], SDoc, SDoc)-dsFImport id co (CImport cconv safety mHeader spec) = do-    (ids, h, c) <- dsCImport id co spec cconv safety mHeader-    return (ids, h, c)--dsCImport :: Id-          -> Coercion-          -> CImportSpec-          -> CCallConv-          -> Safety-          -> Maybe Header-          -> DsM ([Binding], SDoc, SDoc)-dsCImport id co (CLabel _) _ _ _ = do-   -- dflags <- getDynFlags-   -- let ty = pFst $ coercionKind co-   --     fod = case tyConAppTyCon_maybe (dropForAlls ty) of-   --           Just tycon-   --            | tyConUnique tycon == funPtrTyConKey ->-   --               IsFunction-   --           _ -> IsData-   -- (resTy, foRhs) <- resultWrapper ty-   -- ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this-   let rhs = let x = x in x -- foRhs (Lit (MachLabel cid stdcall_info fod))-   let rhs' = Cast rhs co-   -- let stdcall_info = fun_type_arg_stdcall_info dflags cconv ty-   return ([(id, rhs')], empty, empty)--dsCImport id co (CFunction target) cconv@PrimCallConv safety _-  = dsPrimCall id co (CCall (CCallSpec target cconv safety))-dsCImport id co (CFunction target) cconv safety mHeader-  = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader-dsCImport id co CWrapper cconv _ _-  = dsFExportDynamic id co cconv---- For stdcall labels, if the type was a FunPtr or newtype thereof,--- then we need to calculate the size of the arguments in order to add--- the @n suffix to the label.--- fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int--- fun_type_arg_stdcall_info dflags StdCallConv ty---   | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,---    tyConUnique tc == funPtrTyConKey---   = let---        (_tvs,sans_foralls)        = tcSplitForAllTys arg_ty---        (fe_arg_tys, _orig_res_ty) = tcSplitFunTys sans_foralls---     in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys)--- fun_type_arg_stdcall_info _ _other_conv _---   = Nothing-\end{code}---%************************************************************************-%*                                                                      *-\subsection{Foreign calls}-%*                                                                      *-%************************************************************************--\begin{code}-dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header-        -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)-dsFCall fn_id co fcall mDeclHeader = do-    let-        ty                   = pFst $ coercionKind co-        (tvs, fun_ty)        = tcSplitForAllTys ty-        (arg_tys, io_res_ty) = tcSplitFunTys fun_ty-                -- Must use tcSplit* functions because we want to-                -- see that (IO t) in the corner--    args <- newSysLocalsDs arg_tys-    (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)--    let-        work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars--    (ccall_result_ty, res_wrapper) <- boxResult io_res_ty--    ccall_uniq <- newUnique-    work_uniq  <- newUnique--    dflags <- getDynFlags-    (fcall', cDoc) <--              case fcall of-              CCall (CCallSpec (StaticTarget cName mPackageId isFun) CApiConv safety) ->-               do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName)-                  let fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId True) CApiConv safety)-                      c = includes-                       $$ fun_proto <+> braces (cRet <> semi)-                      includes = vcat [ text "#include <" <> ftext h <> text ">"-                                      | Header h <- nub headers ]-                      fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes-                      cRet-                       | isVoidRes =                   cCall-                       | otherwise = text "return" <+> cCall-                      cCall = if isFun-                              then ppr cName <> parens argVals-                              else if null arg_tys-                                    then ppr cName-                                    else panic "dsFCall: Unexpected arguments to FFI value import"-                      raw_res_ty = case tcSplitIOType_maybe io_res_ty of-                                   Just (_ioTyCon, res_ty) -> res_ty-                                   Nothing                 -> io_res_ty-                      isVoidRes = raw_res_ty `eqType` unitTy-                      (mHeader, cResType)-                       | isVoidRes = (Nothing, text "void")-                       | otherwise = toCType raw_res_ty-                      pprCconv = ccallConvAttribute CApiConv-                      mHeadersArgTypeList-                          = [ (header, cType <+> char 'a' <> int n)-                            | (t, n) <- zip arg_tys [1..]-                            , let (header, cType) = toCType t ]-                      (mHeaders, argTypeList) = unzip mHeadersArgTypeList-                      argTypes = if null argTypeList-                                 then text "void"-                                 else hsep $ punctuate comma argTypeList-                      mHeaders' = mDeclHeader : mHeader : mHeaders-                      headers = catMaybes mHeaders'-                      argVals = hsep $ punctuate comma-                                    [ char 'a' <> int n-                                    | (_, n) <- zip arg_tys [1..] ]-                  return (fcall', c)-              _ ->-                  return (fcall, empty)-    let-        -- Build the worker-        worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)-        the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty-        work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)-        work_id       = mkSysLocal (fsLit "$wccall") work_uniq worker_ty--        -- Build the wrapper-        work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args-        wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers-        wrap_rhs     = mkLams (tvs ++ args) wrapper_body-        wrap_rhs'    = Cast wrap_rhs co-        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfolding (Just (length args)) wrap_rhs'--    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc)-\end{code}---%************************************************************************-%*                                                                      *-\subsection{Primitive calls}-%*                                                                      *-%************************************************************************--This is for `@foreign import prim@' declarations.--Currently, at the core level we pretend that these primitive calls are-foreign calls. It may make more sense in future to have them as a distinct-kind of Id, or perhaps to bundle them with PrimOps since semantically and-for calling convention they are really prim ops.--\begin{code}-dsPrimCall :: Id -> Coercion -> ForeignCall-           -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)-dsPrimCall fn_id co fcall = do-    let-        ty                   = pFst $ coercionKind co-        (tvs, fun_ty)        = tcSplitForAllTys ty-        (arg_tys, io_res_ty) = tcSplitFunTys fun_ty-                -- Must use tcSplit* functions because we want to-                -- see that (IO t) in the corner--    args <- newSysLocalsDs arg_tys--    ccall_uniq <- newUnique-    dflags <- getDynFlags-    let-        call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty-        rhs      = mkLams tvs (mkLams args call_app)-        rhs'     = Cast rhs co-    return ([(fn_id, rhs')], empty, empty)--\end{code}--%************************************************************************-%*                                                                      *-\subsection{Foreign export}-%*                                                                      *-%************************************************************************--The function that does most of the work for `@foreign export@' declarations.-(see below for the boilerplate code a `@foreign export@' declaration expands- into.)--For each `@foreign export foo@' in a module M we generate:-\begin{itemize}-\item a C function `@foo@', which calls-\item a Haskell stub `@M.\$ffoo@', which calls-\end{itemize}-the user-written Haskell function `@M.foo@'.--\begin{code}-dsFExport :: Id                 -- Either the exported Id,-                                -- or the foreign-export-dynamic constructor-          -> Coercion           -- Coercion between the Haskell type callable-                                -- from C, and its representation type-          -> CLabelString       -- The name to export to C land-          -> CCallConv-          -> Bool               -- True => foreign export dynamic-                                --         so invoke IO action that's hanging off-                                --         the first argument's stable pointer-          -> DsM ( SDoc         -- contents of Module_stub.h-                 , SDoc         -- contents of Module_stub.c-                 , String       -- string describing type to pass to createAdj.-                 , Int          -- size of args to stub function-                 )--dsFExport fn_id co ext_name cconv isDyn = do-    let-       ty                              = pSnd $ coercionKind co-       (_tvs,sans_foralls)             = tcSplitForAllTys ty-       (fe_arg_tys', orig_res_ty)      = tcSplitFunTys sans_foralls-       -- We must use tcSplits here, because we want to see-       -- the (IO t) in the corner of the type!-       fe_arg_tys | isDyn     = tail fe_arg_tys'-                  | otherwise = fe_arg_tys'--       -- Look at the result type of the exported function, orig_res_ty-       -- If it's IO t, return         (t, True)-       -- If it's plain t, return      (t, False)-       (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of-                                -- The function already returns IO t-                                Just (_ioTyCon, res_ty) -> (res_ty, True)-                                -- The function returns t-                                Nothing                 -> (orig_res_ty, False)--    dflags <- getDynFlags-    return $-      mkFExportCBits dflags ext_name-                     (if isDyn then Nothing else Just fn_id)-                     fe_arg_tys res_ty is_IO_res_ty cconv-\end{code}--@foreign import "wrapper"@ (previously "foreign export dynamic") lets-you dress up Haskell IO actions of some fixed type behind an-externally callable interface (i.e., as a C function pointer). Useful-for callbacks and stuff.--\begin{verbatim}-type Fun = Bool -> Int -> IO Int-foreign import "wrapper" f :: Fun -> IO (FunPtr Fun)---- Haskell-visible constructor, which is generated from the above:--- SUP: No check for NULL from createAdjustor anymore???--f :: Fun -> IO (FunPtr Fun)-f cback =-   bindIO (newStablePtr cback)-          (\StablePtr sp# -> IO (\s1# ->-              case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of-                 (# s2#, a# #) -> (# s2#, A# a# #)))--foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)---- and the helper in C:--f_helper(StablePtr s, HsBool b, HsInt i)-{-        rts_evalIO(rts_apply(rts_apply(deRefStablePtr(s),-                                       rts_mkBool(b)), rts_mkInt(i)));-}-\end{verbatim}--\begin{code}-dsFExportDynamic :: Id-                 -> Coercion-                 -> CCallConv-                 -> DsM ([Binding], SDoc, SDoc)-dsFExportDynamic id co0 cconv = do-    fe_id <-  newSysLocalDs ty-    mod <- getModule-    dflags <- getDynFlags-    let-        -- hack: need to get at the name of the C stub we're about to generate.-        -- TODO: There's no real need to go via String with-        -- (mkFastString . zString). In fact, is there a reason to convert-        -- to FastString at all now, rather than sticking with FastZString?-        fe_nm    = mkFastString (zString (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName dflags fe_id)--    cback <- newSysLocalDs arg_ty-    newStablePtrId <- dsLookupGlobalId newStablePtrName-    stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName-    let-        stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]-        export_ty     = mkFunTy stable_ptr_ty arg_ty-    bindIOId <- dsLookupGlobalId bindIOName-    stbl_value <- newSysLocalDs stable_ptr_ty-    (h_code, c_code, typestring, args_size) <- dsFExport id (mkReflCo Representational export_ty) fe_nm cconv True-    let-         {--          The arguments to the external function which will-          create a little bit of (template) code on the fly-          for allowing the (stable pointed) Haskell closure-          to be entered using an external calling convention-          (stdcall, ccall).-         -}-        adj_args      = [ mkIntLitInt dflags (ccallConvToInt cconv)-                        , Var stbl_value-                        , Lit (MachLabel fe_nm mb_sz_args IsFunction)-                        , Lit (mkMachString typestring)-                        ]-          -- name of external entry point providing these services.-          -- (probably in the RTS.)-        adjustor   = fsLit "createAdjustor"--          -- Determine the number of bytes of arguments to the stub function,-          -- so that we can attach the '@N' suffix to its label if it is a-          -- stdcall on Windows.-        mb_sz_args = case cconv of-                        StdCallConv -> Just args_size-                        _           -> Nothing--    ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])-        -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback--    let io_app = mkLams tvs                  $-                 Lam cback                   $-                 mkApps (Var bindIOId)-                        [ Type stable_ptr_ty-                        , Type res_ty-                        , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]-                        , Lam stbl_value ccall_adj-                        ]--        fed = (id `setInlineActivation` NeverActive, Cast io_app co0)-               -- Never inline the f.e.d. function, because the litlit-               -- might not be in scope in other modules.--    return ([fed], h_code, c_code)-- where-  ty                       = pFst (coercionKind co0)-  (tvs,sans_foralls)       = tcSplitForAllTys ty-  ([arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls-  Just (io_tc, res_ty)     = tcSplitIOType_maybe fn_res_ty-        -- Must have an IO type; hence Just--toCName :: DynFlags -> Id -> String-toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i)))-\end{code}--%*-%-\subsection{Generating @foreign export@ stubs}-%-%*--For each @foreign export@ function, a C stub function is generated.-The C stub constructs the application of the exported Haskell function-using the hugs/ghc rts invocation API.--\begin{code}-mkFExportCBits :: DynFlags-               -> FastString-               -> Maybe Id      -- Just==static, Nothing==dynamic-               -> [Type]-               -> Type-               -> Bool          -- True <=> returns an IO type-               -> CCallConv-               -> (SDoc,-                   SDoc,-                   String,      -- the argument reps-                   Int          -- total size of arguments-                  )-mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc- = (header_bits, c_bits, type_string,-    sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args-         -- NB. the calculation here isn't strictly speaking correct.-         -- We have a primitive Haskell type (eg. Int#, Double#), and-         -- we want to know the size, when passed on the C stack, of-         -- the associated C type (eg. HsInt, HsDouble).  We don't have-         -- this information to hand, but we know what GHC's conventions-         -- are for passing around the primitive Haskell types, so we-         -- use that instead.  I hope the two coincide --SDM-    )- where-  -- list the arguments to the C function-  arg_info :: [(SDoc,           -- arg name-                SDoc,           -- C type-                Type,           -- Haskell type-                CmmType)]       -- the CmmType-  arg_info  = [ let stg_type = showStgType ty in-                (arg_cname n stg_type,-                 stg_type,-                 ty,-                 typeCmmType dflags (getPrimTyOf ty))-              | (ty,n) <- zip arg_htys [1::Int ..] ]--  arg_cname n stg_ty-        | libffi    = char '*' <> parens (stg_ty <> char '*') <>-                      ptext (sLit "args") <> brackets (int (n-1))-        | otherwise = text ('a':show n)--  -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled-  libffi = cLibFFI && isNothing maybe_target--  type_string-      -- libffi needs to know the result type too:-      | libffi    = primTyDescChar dflags res_hty : arg_type_string-      | otherwise = arg_type_string--  arg_type_string = [primTyDescChar dflags ty | (_,_,ty,_) <- arg_info]-                -- just the real args--  -- add some auxiliary args; the stable ptr in the wrapper case, and-  -- a slot for the dummy return address in the wrapper + ccall case-  aug_arg_info-    | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info-    | otherwise              = arg_info--  stable_ptr_arg =-        (text "the_stableptr", text "StgStablePtr", undefined,-         typeCmmType dflags (mkStablePtrPrimTy alphaTy))--  -- stuff to do with the return type of the C function-  res_hty_is_unit = res_hty `eqType` unitTy     -- Look through any newtypes--  cResType | res_hty_is_unit = text "void"-           | otherwise       = showStgType res_hty--  -- when the return type is integral and word-sized or smaller, it-  -- must be assigned as type ffi_arg (#3516).  To see what type-  -- libffi is expecting here, take a look in its own testsuite, e.g.-  -- libffi/testsuite/libffi.call/cls_align_ulonglong.c-  ffi_cResType-     | is_ffi_arg_type = text "ffi_arg"-     | otherwise       = cResType-     where-       res_ty_key = getUnique (getName (typeTyCon res_hty))-       is_ffi_arg_type = res_ty_key `notElem`-              [floatTyConKey, doubleTyConKey,-               int64TyConKey, word64TyConKey]--  -- Now we can cook up the prototype for the exported function.-  pprCconv = ccallConvAttribute cc--  header_bits = ptext (sLit "extern") <+> fun_proto <> semi--  fun_args-    | null aug_arg_info = text "void"-    | otherwise         = hsep $ punctuate comma-                               $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info--  fun_proto-    | libffi-      = ptext (sLit "void") <+> ftext c_nm <>-          parens (ptext (sLit "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr"))-    | otherwise-      = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args--  -- the target which will form the root of what we ask rts_evalIO to run-  the_cfun-     = case maybe_target of-          Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"-          Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"--  cap = text "cap" <> comma--  -- the expression we give to rts_evalIO-  expr_to_run-     = foldl appArg the_cfun arg_info -- NOT aug_arg_info-       where-          appArg acc (arg_cname, _, arg_hty, _)-             = text "rts_apply"-               <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))--  -- various other bits for inside the fn-  declareResult = text "HaskellObj ret;"-  declareCResult | res_hty_is_unit = empty-                 | otherwise       = cResType <+> text "cret;"--  assignCResult | res_hty_is_unit = empty-                | otherwise       =-                        text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi--  -- an extern decl for the fn being called-  extern_decl-     = case maybe_target of-          Nothing -> empty-          Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi---  -- finally, the whole darn thing-  c_bits =-    space $$-    extern_decl $$-    fun_proto  $$-    vcat-     [ lbrace-     ,   ptext (sLit "Capability *cap;")-     ,   declareResult-     ,   declareCResult-     ,   text "cap = rts_lock();"-          -- create the application + perform it.-     ,   ptext (sLit "rts_evalIO") <> parens (-                char '&' <> cap <>-                ptext (sLit "rts_apply") <> parens (-                    cap <>-                    text "(HaskellObj)"-                 <> ptext (if is_IO_res_ty-                                then (sLit "runIO_closure")-                                else (sLit "runNonIO_closure"))-                 <> comma-                 <> expr_to_run-                ) <+> comma-               <> text "&ret"-             ) <> semi-     ,   ptext (sLit "rts_checkSchedStatus") <> parens (doubleQuotes (ftext c_nm)-                                                <> comma <> text "cap") <> semi-     ,   assignCResult-     ,   ptext (sLit "rts_unlock(cap);")-     ,   ppUnless res_hty_is_unit $-         if libffi-                  then char '*' <> parens (ffi_cResType <> char '*') <>-                       ptext (sLit "resp = cret;")-                  else ptext (sLit "return cret;")-     , rbrace-     ]---foreignExportInitialiser :: Id -> SDoc-foreignExportInitialiser hs_fn =-   -- Initialise foreign exports by registering a stable pointer from an-   -- __attribute__((constructor)) function.-   -- The alternative is to do this from stginit functions generated in-   -- codeGen/CodeGen.lhs; however, stginit functions have a negative impact-   -- on binary sizes and link times because the static linker will think that-   -- all modules that are imported directly or indirectly are actually used by-   -- the program.-   -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)-   vcat-    [ text "static void stginit_export_" <> ppr hs_fn-         <> text "() __attribute__((constructor));"-    , text "static void stginit_export_" <> ppr hs_fn <> text "()"-    , braces (text "foreignExportStablePtr"-       <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")-       <> semi)-    ]---mkHObj :: Type -> SDoc-mkHObj t = text "rts_mk" <> text (showFFIType t)--unpackHObj :: Type -> SDoc-unpackHObj t = text "rts_get" <> text (showFFIType t)--showStgType :: Type -> SDoc-showStgType t = text "Hs" <> text (showFFIType t)--showFFIType :: Type -> String-showFFIType t = getOccString (getName (typeTyCon t))--toCType :: Type -> (Maybe Header, SDoc)-toCType = f False-    where f voidOK t-           -- First, if we have (Ptr t) of (FunPtr t), then we need to-           -- convert t to a C type and put a * after it. If we don't-           -- know a type for t, then "void" is fine, though.-           | Just (ptr, [t']) <- splitTyConApp_maybe t-           , tyConName ptr `elem` [ptrTyConName, funPtrTyConName]-              = case f True t' of-                (mh, cType') ->-                    (mh, cType' <> char '*')-           -- Otherwise, if we have a type constructor application, then-           -- see if there is a C type associated with that constructor.-           -- Note that we aren't looking through type synonyms or-           -- anything, as it may be the synonym that is annotated.-           | TyConApp tycon _ <- t-           , Just (CType mHeader cType) <- tyConCType_maybe tycon-              = (mHeader, ftext cType)-           -- If we don't know a C type for this type, then try looking-           -- through one layer of type synonym etc.-           | Just t' <- coreView t-              = f voidOK t'-           -- Otherwise we don't know the C type. If we are allowing-           -- void then return that; otherwise something has gone wrong.-           | voidOK = (Nothing, ptext (sLit "void"))-           | otherwise-              = pprPanic "toCType" (ppr t)--typeTyCon :: Type -> TyCon-typeTyCon ty-  | UnaryRep rep_ty <- repType ty-  , Just (tc, _) <- tcSplitTyConApp_maybe rep_ty-  = tc-  | otherwise-  = pprPanic "DsForeign.typeTyCon" (ppr ty)--insertRetAddr :: DynFlags -> CCallConv-              -> [(SDoc, SDoc, Type, CmmType)]-              -> [(SDoc, SDoc, Type, CmmType)]-insertRetAddr dflags CCallConv args-    = case platformArch platform of-      ArchX86_64-       | platformOS platform == OSMinGW32 ->-          -- On other Windows x86_64 we insert the return address-          -- after the 4th argument, because this is the point-          -- at which we need to flush a register argument to the stack-          -- (See rts/Adjustor.c for details).-          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]-                        -> [(SDoc, SDoc, Type, CmmType)]-              go 4 args = ret_addr_arg dflags : args-              go n (arg:args) = arg : go (n+1) args-              go _ [] = []-          in go 0 args-       | otherwise ->-          -- On other x86_64 platforms we insert the return address-          -- after the 6th integer argument, because this is the point-          -- at which we need to flush a register argument to the stack-          -- (See rts/Adjustor.c for details).-          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]-                        -> [(SDoc, SDoc, Type, CmmType)]-              go 6 args = ret_addr_arg dflags : args-              go n (arg@(_,_,_,rep):args)-               | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args-               | otherwise  = arg : go n     args-              go _ [] = []-          in go 0 args-      _ ->-          ret_addr_arg dflags : args-    where platform = targetPlatform dflags-insertRetAddr _ _ args = args--ret_addr_arg :: DynFlags -> (SDoc, SDoc, Type, CmmType)-ret_addr_arg dflags = (text "original_return_addr", text "void*", undefined,-                       typeCmmType dflags addrPrimTy)---- This function returns the primitive type associated with the boxed--- type argument to a foreign export (eg. Int ==> Int#).-getPrimTyOf :: Type -> UnaryType-getPrimTyOf ty-  | isBoolTy rep_ty = intPrimTy-  -- Except for Bool, the types we are interested in have a single constructor-  -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).-  | otherwise =-  case splitDataProductType_maybe rep_ty of-     Just (_, _, _, [prim_ty]) ->-        -- ASSERT(dataConSourceArity data_con == 1)-        -- ASSERT2(isUnLiftedType prim_ty, ppr prim_ty)-        prim_ty-     _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)-  where-        UnaryRep rep_ty = repType ty---- represent a primitive type as a Char, for building a string that--- described the foreign function type.  The types are size-dependent,--- e.g. 'W' is a signed 32-bit integer.-primTyDescChar :: DynFlags -> Type -> Char-primTyDescChar dflags ty- | ty `eqType` unitTy = 'v'- | otherwise- = case typePrimRep (getPrimTyOf ty) of-     IntRep      -> signed_word-     WordRep     -> unsigned_word-     Int64Rep    -> 'L'-     Word64Rep   -> 'l'-     AddrRep     -> 'p'-     FloatRep    -> 'f'-     DoubleRep   -> 'd'-     _           -> pprPanic "primTyDescChar" (ppr ty)-  where-    (signed_word, unsigned_word)-       | wORD_SIZE dflags == 4  = ('W','w')-       | wORD_SIZE dflags == 8  = ('L','l')-       | otherwise              = panic "primTyDescChar"-\end{code}
− src/Language/Haskell/Liquid/Desugar/DsGRHSs.lhs 
@@ -1,160 +0,0 @@-%-% (c) The University of Glasgow 2006-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998-%--Matching guarded right-hand-sides (GRHSs)--\begin{code}-module Language.Haskell.Liquid.Desugar.DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS ) where---- #include "HsVersions.h"--import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr  ( dsLExpr, dsLocalBinds )-import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.Match   ( matchSinglePat )--import HsSyn-import MkCore-import CoreSyn-import Var-import Type--import DsMonad-import Language.Haskell.Liquid.Desugar.DsUtils-import TysWiredIn-import PrelNames-import Module-import Name-import SrcLoc-import Outputable-\end{code}--@dsGuarded@ is used for both @case@ expressions and pattern bindings.-It desugars:-\begin{verbatim}-        | g1 -> e1-        ...-        | gn -> en-        where binds-\end{verbatim}-producing an expression with a runtime error in the corner if-necessary.  The type argument gives the type of the @ei@.--\begin{code}-dsGuarded :: GRHSs Id (LHsExpr Id) -> Type -> DsM CoreExpr--dsGuarded grhss rhs_ty = do-    match_result <- dsGRHSs PatBindRhs [] grhss rhs_ty-    error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty-    extractMatchResult match_result error_expr-\end{code}--In contrast, @dsGRHSs@ produces a @MatchResult@.--\begin{code}-dsGRHSs :: HsMatchContext Name -> [Pat Id]      -- These are to build a MatchContext from-        -> GRHSs Id (LHsExpr Id)                -- Guarded RHSs-        -> Type                                 -- Type of RHS-        -> DsM MatchResult-dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty -  = -- ASSERT( notNull grhss )-    do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss-       ; let match_result1 = foldr1 combineMatchResults match_results-             match_result2 = adjustMatchResultDs-                                 (\e -> dsLocalBinds binds e)-                                 match_result1-                -- NB: nested dsLet inside matchResult-       ; return match_result2 }--dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id (LHsExpr Id) -> DsM MatchResult-dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs))-  = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty-\end{code}---%************************************************************************-%*                                                                      *-%*  matchGuard : make a MatchResult from a guarded RHS                  *-%*                                                                      *-%************************************************************************--\begin{code}-matchGuards :: [GuardStmt Id]       -- Guard-            -> HsStmtContext Name   -- Context-            -> LHsExpr Id           -- RHS-            -> Type                 -- Type of RHS of guard-            -> DsM MatchResult---- See comments with HsExpr.Stmt re what a BodyStmt means--- Here we must be in a guard context (not do-expression, nor list-comp)--matchGuards [] _ rhs _-  = do  { core_rhs <- dsLExpr rhs-        ; return (cantFailMatchResult core_rhs) }--        -- BodyStmts must be guards-        -- Turn an "otherwise" guard is a no-op.  This ensures that-        -- you don't get a "non-exhaustive eqns" message when the guards-        -- finish in "otherwise".-        -- NB:  The success of this clause depends on the typechecker not-        --      wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors-        --      If it does, you'll get bogus overlap warnings-matchGuards (BodyStmt e _ _ _ : stmts) ctx rhs rhs_ty-  | Just addTicks <- isTrueLHsExpr e = do-    match_result <- matchGuards stmts ctx rhs rhs_ty-    return (adjustMatchResultDs addTicks match_result)-matchGuards (BodyStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do-    match_result <- matchGuards stmts ctx rhs rhs_ty-    pred_expr <- dsLExpr expr-    return (mkGuardedMatchResult pred_expr match_result)--matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty = do-    match_result <- matchGuards stmts ctx rhs rhs_ty-    return (adjustMatchResultDs (dsLocalBinds binds) match_result)-        -- NB the dsLet occurs inside the match_result-        -- Reason: dsLet takes the body expression as its argument-        --         so we can't desugar the bindings without the-        --         body expression in hand--matchGuards (BindStmt pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do-    match_result <- matchGuards stmts ctx rhs rhs_ty-    core_rhs <- dsLExpr bind_rhs-    matchSinglePat core_rhs (StmtCtxt ctx) pat rhs_ty match_result--matchGuards (LastStmt  {} : _) _ _ _ = panic "matchGuards LastStmt"-matchGuards (ParStmt   {} : _) _ _ _ = panic "matchGuards ParStmt"-matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"-matchGuards (RecStmt   {} : _) _ _ _ = panic "matchGuards RecStmt"--isTrueLHsExpr :: LHsExpr Id -> Maybe (CoreExpr -> DsM CoreExpr)---- Returns Just {..} if we're sure that the expression is True--- I.e.   * 'True' datacon---        * 'otherwise' Id---        * Trivial wappings of these--- The arguments to Just are any HsTicks that we have found,--- because we still want to tick then, even it they are aways evaluted.-isTrueLHsExpr (L _ (HsVar v)) |  v `hasKey` otherwiseIdKey-                              || v `hasKey` getUnique trueDataConId-                                      = Just return-        -- trueDataConId doesn't have the same unique as trueDataCon-isTrueLHsExpr (L _ (HsTick tickish e))-    | Just ticks <- isTrueLHsExpr e-    = Just (\x -> ticks x >>= return .  (Tick tickish))-   -- This encodes that the result is constant True for Hpc tick purposes;-   -- which is specifically what isTrueLHsExpr is trying to find out.-isTrueLHsExpr (L _ (HsBinTick ixT _ e))-    | Just ticks <- isTrueLHsExpr e-    = Just (\x -> do e <- ticks x-                     this_mod <- getModule-                     return (Tick (HpcTick this_mod ixT) e))--isTrueLHsExpr (L _ (HsPar e))         = isTrueLHsExpr e-isTrueLHsExpr _                       = Nothing-\end{code}--Should {\em fail} if @e@ returns @D@-\begin{verbatim}-f x | p <- e', let C y# = e, f y# = r1-    | otherwise          = r2-\end{verbatim}
− src/Language/Haskell/Liquid/Desugar/DsListComp.lhs 
@@ -1,879 +0,0 @@-%-% (c) The University of Glasgow 2006-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998-%--Desugaring list comprehensions, monad comprehensions and array comprehensions--\begin{code}-{-# LANGUAGE NamedFieldPuns #-}--module Language.Haskell.Liquid.Desugar.DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where---- #include "HsVersions.h"--import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr ( dsExpr, dsLExpr, dsLocalBinds )--import HsSyn-import TcHsSyn-import CoreSyn-import MkCore--import DsMonad          -- the monadery used in the desugarer-import Language.Haskell.Liquid.Desugar.DsUtils--import DynFlags-import CoreUtils-import Id-import Type-import TysWiredIn-import Language.Haskell.Liquid.Desugar.Match-import PrelNames-import SrcLoc-import Outputable-import FastString-import TcType-import ListSetOps( getNth )-\end{code}--List comprehensions may be desugared in one of two ways: ``ordinary''-(as you would expect if you read SLPJ's book) and ``with foldr/build-turned on'' (if you read Gill {\em et al.}'s paper on the subject).--There will be at least one ``qualifier'' in the input.--\begin{code}-dsListComp :: [ExprLStmt Id]-           -> Type              -- Type of entire list-           -> DsM CoreExpr-dsListComp lquals res_ty = do-    dflags <- getDynFlags-    let quals = map unLoc lquals-        elt_ty = case tcTyConAppArgs res_ty of-                   [elt_ty] -> elt_ty-                   _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals)--    if not (gopt Opt_EnableRewriteRules dflags) || gopt Opt_IgnoreInterfacePragmas dflags-       -- Either rules are switched off, or we are ignoring what there are;-       -- Either way foldr/build won't happen, so use the more efficient-       -- Wadler-style desugaring-       || isParallelComp quals-       -- Foldr-style desugaring can't handle parallel list comprehensions-        then deListComp quals (mkNilExpr elt_ty)-        else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals)-             -- Foldr/build should be enabled, so desugar-             -- into foldrs and builds--  where-    -- We must test for ParStmt anywhere, not just at the head, because an extension-    -- to list comprehensions would be to add brackets to specify the associativity-    -- of qualifier lists. This is really easy to do by adding extra ParStmts into the-    -- mix of possibly a single element in length, so we do this to leave the possibility open-    isParallelComp = any isParallelStmt--    isParallelStmt (ParStmt {}) = True-    isParallelStmt _            = False----- This function lets you desugar a inner list comprehension and a list of the binders--- of that comprehension that we need in the outer comprehension into such an expression--- and the type of the elements that it outputs (tuples of binders)-dsInnerListComp :: (ParStmtBlock Id Id) -> DsM (CoreExpr, Type)-dsInnerListComp (ParStmtBlock stmts bndrs _)-  = do { expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTup bndrs)])-                            (mkListTy bndrs_tuple_type)-       ; return (expr, bndrs_tuple_type) }-  where-    bndrs_tuple_type = mkBigCoreVarTupTy bndrs---- This function factors out commonality between the desugaring strategies for GroupStmt.--- Given such a statement it gives you back an expression representing how to compute the transformed--- list and the tuple that you need to bind from that list in order to proceed with your desugaring-dsTransStmt :: ExprStmt Id -> DsM (CoreExpr, LPat Id)-dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap-                       , trS_by = by, trS_using = using }) = do-    let (from_bndrs, to_bndrs) = unzip binderMap-        from_bndrs_tys  = map idType from_bndrs-        to_bndrs_tys    = map idType to_bndrs-        to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys--    -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders-    (expr, from_tup_ty) <- dsInnerListComp (ParStmtBlock stmts from_bndrs noSyntaxExpr)--    -- Work out what arguments should be supplied to that expression: i.e. is an extraction-    -- function required? If so, create that desugared function and add to arguments-    usingExpr' <- dsLExpr using-    usingArgs <- case by of-                   Nothing   -> return [expr]-                   Just by_e -> do { by_e' <- dsLExpr by_e-                                   ; lam <- matchTuple from_bndrs by_e'-                                   ; return [lam, expr] }--    -- Create an unzip function for the appropriate arity and element types and find "map"-    unzip_stuff <- mkUnzipBind form from_bndrs_tys-    map_id <- dsLookupGlobalId mapName--    -- Generate the expressions to build the grouped list-    let -- First we apply the grouping function to the inner list-        inner_list_expr = mkApps usingExpr' usingArgs-        -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists-        -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and-        -- the "b" to be a tuple of "to" lists!-        -- Then finally we bind the unzip function around that expression-        bound_unzipped_inner_list_expr-          = case unzip_stuff of-              Nothing -> inner_list_expr-              Just (unzip_fn, unzip_rhs) -> Let (Rec [(unzip_fn, unzip_rhs)]) $-                                            mkApps (Var map_id) $-                                            [ Type (mkListTy from_tup_ty)-                                            , Type to_bndrs_tup_ty-                                            , Var unzip_fn-                                            , inner_list_expr]--    -- Build a pattern that ensures the consumer binds into the NEW binders,-    -- which hold lists rather than single values-    let pat = mkBigLHsVarPatTup to_bndrs-    return (bound_unzipped_inner_list_expr, pat)--dsTransStmt _ = panic "dsTransStmt: Not given a TransStmt"-\end{code}--%************************************************************************-%*                                                                      *-\subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions}-%*                                                                      *-%************************************************************************--Just as in Phil's chapter~7 in SLPJ, using the rules for-optimally-compiled list comprehensions.  This is what Kevin followed-as well, and I quite happily do the same.  The TQ translation scheme-transforms a list of qualifiers (either boolean expressions or-generators) into a single expression which implements the list-comprehension.  Because we are generating 2nd-order polymorphic-lambda-calculus, calls to NIL and CONS must be applied to a type-argument, as well as their usual value arguments.-\begin{verbatim}-TE << [ e | qs ] >>  =  TQ << [ e | qs ] ++ Nil (typeOf e) >>--(Rule C)-TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <<e>> TE <<L>>--(Rule B)-TQ << [ e | b , qs ] ++ L >> =-    if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>--(Rule A')-TQ << [ e | p <- L1, qs ]  ++  L2 >> =-  letrec-    h = \ u1 ->-          case u1 of-            []        ->  TE << L2 >>-            (u2 : u3) ->-                  (( \ TE << p >> -> ( TQ << [e | qs]  ++  (h u3) >> )) u2)-                    [] (h u3)-  in-    h ( TE << L1 >> )--"h", "u1", "u2", and "u3" are new variables.-\end{verbatim}--@deListComp@ is the TQ translation scheme.  Roughly speaking, @dsExpr@-is the TE translation scheme.  Note that we carry around the @L@ list-already desugared.  @dsListComp@ does the top TE rule mentioned above.--To the above, we add an additional rule to deal with parallel list-comprehensions.  The translation goes roughly as follows:-     [ e | p1 <- e11, let v1 = e12, p2 <- e13-         | q1 <- e21, let v2 = e22, q2 <- e23]-     =>-     [ e | ((x1, .., xn), (y1, ..., ym)) <--               zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13]-                   [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]]-where (x1, .., xn) are the variables bound in p1, v1, p2-      (y1, .., ym) are the variables bound in q1, v2, q2--In the translation below, the ParStmt branch translates each parallel branch-into a sub-comprehension, and desugars each independently.  The resulting lists-are fed to a zip function, we create a binding for all the variables bound in all-the comprehensions, and then we hand things off the the desugarer for bindings.-The zip function is generated here a) because it's small, and b) because then we-don't have to deal with arbitrary limits on the number of zip functions in the-prelude, nor which library the zip function came from.-The introduced tuples are Boxed, but only because I couldn't get it to work-with the Unboxed variety.--\begin{code}--deListComp :: [ExprStmt Id] -> CoreExpr -> DsM CoreExpr--deListComp [] _ = panic "deListComp"--deListComp (LastStmt body _ : _) list-  =     -- Figure 7.4, SLPJ, p 135, rule C above-    -- ASSERT( null quals )-    do { core_body <- dsLExpr body-       ; return (mkConsExpr (exprType core_body) core_body list) }--        -- Non-last: must be a guard-deListComp (BodyStmt guard _ _ _ : quals) list = do  -- rule B above-    core_guard <- dsLExpr guard-    core_rest <- deListComp quals list-    return (mkIfThenElse core_guard core_rest list)---- [e | let B, qs] = let B in [e | qs]-deListComp (LetStmt binds : quals) list = do-    core_rest <- deListComp quals list-    dsLocalBinds binds core_rest--deListComp (stmt@(TransStmt {}) : quals) list = do-    (inner_list_expr, pat) <- dsTransStmt stmt-    deBindComp pat inner_list_expr quals list--deListComp (BindStmt pat list1 _ _ : quals) core_list2 = do -- rule A' above-    core_list1 <- dsLExpr list1-    deBindComp pat core_list1 quals core_list2--deListComp (ParStmt stmtss_w_bndrs _ _ : quals) list-  = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs-       ; let (exps, qual_tys) = unzip exps_and_qual_tys--       ; (zip_fn, zip_rhs) <- mkZipBind qual_tys--        -- Deal with [e | pat <- zip l1 .. ln] in example above-       ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))-                    quals list }-  where-        bndrs_s = [bs | ParStmtBlock _ bs _ <- stmtss_w_bndrs]--        -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above-        pat  = mkBigLHsPatTup pats-        pats = map mkBigLHsVarPatTup bndrs_s--deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"-\end{code}---\begin{code}-deBindComp :: OutPat Id-           -> CoreExpr-           -> [ExprStmt Id]-           -> CoreExpr-           -> DsM (Expr Id)-deBindComp pat core_list1 quals core_list2 = do-    let-        u3_ty@u1_ty = exprType core_list1       -- two names, same thing--        -- u1_ty is a [alpha] type, and u2_ty = alpha-        u2_ty = hsLPatType pat--        res_ty = exprType core_list2-        h_ty   = u1_ty `mkFunTy` res_ty--    [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]--    -- the "fail" value ...-    let-        core_fail   = App (Var h) (Var u3)-        letrec_body = App (Var h) core_list1--    rest_expr <- deListComp quals core_fail-    core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail--    let-        rhs = Lam u1 $-              Case (Var u1) u1 res_ty-                   [(DataAlt nilDataCon,  [],       core_list2),-                    (DataAlt consDataCon, [u2, u3], core_match)]-                        -- Increasing order of tag--    return (Let (Rec [(h, rhs)]) letrec_body)-\end{code}--%************************************************************************-%*                                                                      *-\subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}-%*                                                                      *-%************************************************************************--@dfListComp@ are the rules used with foldr/build turned on:--\begin{verbatim}-TE[ e | ]            c n = c e n-TE[ e | b , q ]      c n = if b then TE[ e | q ] c n else n-TE[ e | p <- l , q ] c n = let-                                f = \ x b -> case x of-                                                  p -> TE[ e | q ] c b-                                                  _ -> b-                           in-                           foldr f n l-\end{verbatim}--\begin{code}-dfListComp :: Id -> Id      -- 'c' and 'n'-        -> [ExprStmt Id]    -- the rest of the qual's-        -> DsM CoreExpr--dfListComp _ _ [] = panic "dfListComp"--dfListComp c_id n_id (LastStmt body _ : _)-  = -- ASSERT( null quals )-    do { core_body <- dsLExpr body-       ; return (mkApps (Var c_id) [core_body, Var n_id]) }--        -- Non-last: must be a guard-dfListComp c_id n_id (BodyStmt guard _ _ _  : quals) = do-    core_guard <- dsLExpr guard-    core_rest <- dfListComp c_id n_id quals-    return (mkIfThenElse core_guard core_rest (Var n_id))--dfListComp c_id n_id (LetStmt binds : quals) = do-    -- new in 1.3, local bindings-    core_rest <- dfListComp c_id n_id quals-    dsLocalBinds binds core_rest--dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do-    (inner_list_expr, pat) <- dsTransStmt stmt-    -- Anyway, we bind the newly grouped list via the generic binding function-    dfBindComp c_id n_id (pat, inner_list_expr) quals--dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) = do-    -- evaluate the two lists-    core_list1 <- dsLExpr list1--    -- Do the rest of the work in the generic binding builder-    dfBindComp c_id n_id (pat, core_list1) quals--dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt"-dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"--dfBindComp :: Id -> Id          -- 'c' and 'n'-           -> (LPat Id, CoreExpr)-           -> [ExprStmt Id]     -- the rest of the qual's-           -> DsM CoreExpr-dfBindComp c_id n_id (pat, core_list1) quals = do-    -- find the required type-    let x_ty   = hsLPatType pat-        b_ty   = idType n_id--    -- create some new local id's-    [b, x] <- newSysLocalsDs [b_ty, x_ty]--    -- build rest of the comprehesion-    core_rest <- dfListComp c_id b quals--    -- build the pattern match-    core_expr <- matchSimply (Var x) (StmtCtxt ListComp)-                pat core_rest (Var b)--    -- now build the outermost foldr, and return-    mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1-\end{code}--%************************************************************************-%*                                                                      *-\subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring}-%*                                                                      *-%************************************************************************--\begin{code}--mkZipBind :: [Type] -> DsM (Id, CoreExpr)--- mkZipBind [t1, t2]--- = (zip, \as1:[t1] as2:[t2]---         -> case as1 of---              [] -> []---              (a1:as'1) -> case as2 of---                              [] -> []---                              (a2:as'2) -> (a1, a2) : zip as'1 as'2)]--mkZipBind elt_tys = do-    ass  <- mapM newSysLocalDs  elt_list_tys-    as'  <- mapM newSysLocalDs  elt_tys-    as's <- mapM newSysLocalDs  elt_list_tys--    zip_fn <- newSysLocalDs zip_fn_ty--    let inner_rhs = mkConsExpr elt_tuple_ty-                        (mkBigCoreVarTup as')-                        (mkVarApps (Var zip_fn) as's)-        zip_body  = foldr mk_case inner_rhs (zip3 ass as' as's)--    return (zip_fn, mkLams ass zip_body)-  where-    elt_list_tys      = map mkListTy elt_tys-    elt_tuple_ty      = mkBigCoreTupTy elt_tys-    elt_tuple_list_ty = mkListTy elt_tuple_ty--    zip_fn_ty         = mkFunTys elt_list_tys elt_tuple_list_ty--    mk_case (as, a', as') rest-          = Case (Var as) as elt_tuple_list_ty-                  [(DataAlt nilDataCon,  [],        mkNilExpr elt_tuple_ty),-                   (DataAlt consDataCon, [a', as'], rest)]-                        -- Increasing order of tag---mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr))--- mkUnzipBind [t1, t2]--- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2])---     -> case ax of---      (x1, x2) -> case axs of---                (xs1, xs2) -> (x1 : xs1, x2 : xs2))---      ([], [])---      ys)------ We use foldr here in all cases, even if rules are turned off, because we may as well!-mkUnzipBind ThenForm _- = return Nothing    -- No unzipping for ThenForm-mkUnzipBind _ elt_tys-  = do { ax  <- newSysLocalDs elt_tuple_ty-       ; axs <- newSysLocalDs elt_list_tuple_ty-       ; ys  <- newSysLocalDs elt_tuple_list_ty-       ; xs  <- mapM newSysLocalDs elt_tys-       ; xss <- mapM newSysLocalDs elt_list_tys--       ; unzip_fn <- newSysLocalDs unzip_fn_ty--       ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]--       ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)-             concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))-             tupled_concat_expression = mkBigCoreTup concat_expressions--             folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs)-             folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax)-             folder_body = mkLams [ax, axs] folder_body_outer_case--       ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)-       ; return (Just (unzip_fn, mkLams [ys] unzip_body)) }-  where-    elt_tuple_ty       = mkBigCoreTupTy elt_tys-    elt_tuple_list_ty  = mkListTy elt_tuple_ty-    elt_list_tys       = map mkListTy elt_tys-    elt_list_tuple_ty  = mkBigCoreTupTy elt_list_tys--    unzip_fn_ty        = elt_tuple_list_ty `mkFunTy` elt_list_tuple_ty--    mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail-\end{code}--%************************************************************************-%*                                                                      *-\subsection[DsPArrComp]{Desugaring of array comprehensions}-%*                                                                      *-%************************************************************************--\begin{code}---- entry point for desugaring a parallel array comprehension------   [:e | qss:] = <<[:e | qss:]>> () [:():]----dsPArrComp :: [ExprStmt Id]-            -> DsM CoreExpr---- Special case for parallel comprehension-dsPArrComp (ParStmt qss _ _ : quals) = dePArrParComp qss quals---- Special case for simple generators:------  <<[:e' | p <- e, qs:]>> = <<[: e' | qs :]>> p e------ if matching again p cannot fail, or else------  <<[:e' | p <- e, qs:]>> =---    <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e)----dsPArrComp (BindStmt p e _ _ : qs) = do-    filterP <- dsDPHBuiltin filterPVar-    ce <- dsLExpr e-    let ety'ce  = parrElemType ce-        false   = Var falseDataConId-        true    = Var trueDataConId-    v <- newSysLocalDs ety'ce-    pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false-    let gen | isIrrefutableHsPat p = ce-            | otherwise            = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]-    dePArrComp qs p gen--dsPArrComp qs = do -- no ParStmt in `qs'-    sglP <- dsDPHBuiltin singletonPVar-    let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []]-    dePArrComp qs (noLoc $ WildPat unitTy) unitArray------ the work horse----dePArrComp :: [ExprStmt Id]-           -> LPat Id           -- the current generator pattern-           -> CoreExpr          -- the current generator expression-           -> DsM CoreExpr--dePArrComp [] _ _ = panic "dePArrComp"-------  <<[:e' | :]>> pa ea = mapP (\pa -> e') ea----dePArrComp (LastStmt e' _ : _) pa cea-  = -- ASSERT( null quals )-    do { mapP <- dsDPHBuiltin mapPVar-       ; let ty = parrElemType cea-       ; (clam, ty'e') <- deLambda ty pa e'-       ; return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea] }------  <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)----dePArrComp (BodyStmt b _ _ _ : qs) pa cea = do-    filterP <- dsDPHBuiltin filterPVar-    let ty = parrElemType cea-    (clam,_) <- deLambda ty pa b-    dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea])-------  <<[:e' | p <- e, qs:]>> pa ea =---    let ef = \pa -> e---    in---    <<[:e' | qs:]>> (pa, p) (crossMap ea ef)------ if matching again p cannot fail, or else------  <<[:e' | p <- e, qs:]>> pa ea =---    let ef = \pa -> filterP (\x -> case x of {p -> True; _ -> False}) e---    in---    <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)----dePArrComp (BindStmt p e _ _ : qs) pa cea = do-    filterP <- dsDPHBuiltin filterPVar-    crossMapP <- dsDPHBuiltin crossMapPVar-    ce <- dsLExpr e-    let ety'cea = parrElemType cea-        ety'ce  = parrElemType ce-        false   = Var falseDataConId-        true    = Var trueDataConId-    v <- newSysLocalDs ety'ce-    pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false-    let cef | isIrrefutableHsPat p = ce-            | otherwise            = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]-    (clam, _) <- mkLambda ety'cea pa cef-    let ety'cef = ety'ce                    -- filter doesn't change the element type-        pa'     = mkLHsPatTup [pa, p]--    dePArrComp qs pa' (mkApps (Var crossMapP)-                                 [Type ety'cea, Type ety'cef, cea, clam])------  <<[:e' | let ds, qs:]>> pa ea =---    <<[:e' | qs:]>> (pa, (x_1, ..., x_n))---                    (mapP (\v@pa -> let ds in (v, (x_1, ..., x_n))) ea)---  where---    {x_1, ..., x_n} = DV (ds)         -- Defined Variables----dePArrComp (LetStmt ds : qs) pa cea = do-    mapP <- dsDPHBuiltin mapPVar-    let xs     = collectLocalBinders ds-        ty'cea = parrElemType cea-    v <- newSysLocalDs ty'cea-    clet <- dsLocalBinds ds (mkCoreTup (map Var xs))-    let'v <- newSysLocalDs (exprType clet)-    let projBody = mkCoreLet (NonRec let'v clet) $-                   mkCoreTup [Var v, Var let'v]-        errTy    = exprType projBody-        errMsg   = ptext (sLit "DsListComp.dePArrComp: internal error!")-    cerr <- mkErrorAppDs pAT_ERROR_ID errTy errMsg-    ccase <- matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr-    let pa'    = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)]-        proj   = mkLams [v] ccase-    dePArrComp qs pa' (mkApps (Var mapP)-                                   [Type ty'cea, Type errTy, proj, cea])------ The parser guarantees that parallel comprehensions can only appear as--- singleton qualifier lists, which we already special case in the caller.--- So, encountering one here is a bug.----dePArrComp (ParStmt {} : _) _ _ =-  panic "DsListComp.dePArrComp: malformed comprehension AST: ParStmt"-dePArrComp (TransStmt {} : _) _ _ = panic "DsListComp.dePArrComp: TransStmt"-dePArrComp (RecStmt   {} : _) _ _ = panic "DsListComp.dePArrComp: RecStmt"----  <<[:e' | qs | qss:]>> pa ea =---    <<[:e' | qss:]>> (pa, (x_1, ..., x_n))---                     (zipP ea <<[:(x_1, ..., x_n) | qs:]>>)---    where---      {x_1, ..., x_n} = DV (qs)----dePArrParComp :: [ParStmtBlock Id Id] -> [ExprStmt Id] -> DsM CoreExpr-dePArrParComp qss quals = do-    (pQss, ceQss) <- deParStmt qss-    dePArrComp quals pQss ceQss-  where-    deParStmt []             =-      -- empty parallel statement lists have no source representation-      panic "DsListComp.dePArrComp: Empty parallel list comprehension"-    deParStmt (ParStmtBlock qs xs _:qss) = do        -- first statement-      let res_expr = mkLHsVarTuple xs-      cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])-      parStmts qss (mkLHsVarPatTup xs) cqs-    ----    parStmts []             pa cea = return (pa, cea)-    parStmts (ParStmtBlock qs xs _:qss) pa cea = do  -- subsequent statements (zip'ed)-      zipP <- dsDPHBuiltin zipPVar-      let pa'      = mkLHsPatTup [pa, mkLHsVarPatTup xs]-          ty'cea   = parrElemType cea-          res_expr = mkLHsVarTuple xs-      cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])-      let ty'cqs = parrElemType cqs-          cea'   = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]-      parStmts qss pa' cea'---- generate Core corresponding to `\p -> e'----deLambda :: Type                        -- type of the argument-          -> LPat Id                    -- argument pattern-          -> LHsExpr Id                 -- body-          -> DsM (CoreExpr, Type)-deLambda ty p e =-    mkLambda ty p =<< dsLExpr e---- generate Core for a lambda pattern match, where the body is already in Core----mkLambda :: Type                        -- type of the argument-         -> LPat Id                     -- argument pattern-         -> CoreExpr                    -- desugared body-         -> DsM (CoreExpr, Type)-mkLambda ty p ce = do-    v <- newSysLocalDs ty-    let errMsg = ptext (sLit "DsListComp.deLambda: internal error!")-        ce'ty  = exprType ce-    cerr <- mkErrorAppDs pAT_ERROR_ID ce'ty errMsg-    res <- matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr-    return (mkLams [v] res, ce'ty)---- obtain the element type of the parallel array produced by the given Core--- expression----parrElemType   :: CoreExpr -> Type-parrElemType e  =-  case splitTyConApp_maybe (exprType e) of-    Just (tycon, [ty]) | tycon == parrTyCon -> ty-    _                                                     -> panic-      "DsListComp.parrElemType: not a parallel array type"-\end{code}--Translation for monad comprehensions--\begin{code}--- Entry point for monad comprehension desugaring-dsMonadComp :: [ExprLStmt Id] -> DsM CoreExpr-dsMonadComp stmts = dsMcStmts stmts--dsMcStmts :: [ExprLStmt Id] -> DsM CoreExpr-dsMcStmts []                    = panic "dsMcStmts"-dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)------------------dsMcStmt :: ExprStmt Id -> [ExprLStmt Id] -> DsM CoreExpr--dsMcStmt (LastStmt body ret_op) _-  = -- ASSERT( null stmts )-    do { body' <- dsLExpr body-       ; ret_op' <- dsExpr ret_op-       ; return (App ret_op' body') }----   [ .. | let binds, stmts ]-dsMcStmt (LetStmt binds) stmts-  = do { rest <- dsMcStmts stmts-       ; dsLocalBinds binds rest }----   [ .. | a <- m, stmts ]-dsMcStmt (BindStmt pat rhs bind_op fail_op) stmts-  = do { rhs' <- dsLExpr rhs-       ; dsMcBindStmt pat rhs' bind_op fail_op stmts }---- Apply `guard` to the `exp` expression------   [ .. | exp, stmts ]----dsMcStmt (BodyStmt exp then_exp guard_exp _) stmts-  = do { exp'       <- dsLExpr exp-       ; guard_exp' <- dsExpr guard_exp-       ; then_exp'  <- dsExpr then_exp-       ; rest       <- dsMcStmts stmts-       ; return $ mkApps then_exp' [ mkApps guard_exp' [exp']-                                   , rest ] }---- Group statements desugar like this:------   [| (q, then group by e using f); rest |]---   --->  f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup ->---         case unzip n_tup of qv' -> [| rest |]------ where   variables (v1:t1, ..., vk:tk) are bound by q---         qv = (v1, ..., vk)---         qt = (t1, ..., tk)---         (>>=) :: m2 a -> (a -> m3 b) -> m3 b---         f :: forall a. (a -> t) -> m1 a -> m2 (n a)---         n_tup :: n qt---         unzip :: n qt -> (n t1, ..., n tk)    (needs Functor n)--dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs-                    , trS_by = by, trS_using = using-                    , trS_ret = return_op, trS_bind = bind_op-                    , trS_fmap = fmap_op, trS_form = form }) stmts_rest-  = do { let (from_bndrs, to_bndrs) = unzip bndrs-             from_bndr_tys          = map idType from_bndrs     -- Types ty--       -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders-       ; expr <- dsInnerMonadComp stmts from_bndrs return_op--       -- Work out what arguments should be supplied to that expression: i.e. is an extraction-       -- function required? If so, create that desugared function and add to arguments-       ; usingExpr' <- dsLExpr using-       ; usingArgs <- case by of-                        Nothing   -> return [expr]-                        Just by_e -> do { by_e' <- dsLExpr by_e-                                        ; lam <- matchTuple from_bndrs by_e'-                                        ; return [lam, expr] }--       -- Generate the expressions to build the grouped list-       -- Build a pattern that ensures the consumer binds into the NEW binders,-       -- which hold monads rather than single values-       ; bind_op' <- dsExpr bind_op-       ; let bind_ty  = exprType bind_op'    -- m2 (n (a,b,c)) -> (n (a,b,c) -> r1) -> r2-             n_tup_ty = funArgTy $ funArgTy $ funResultTy bind_ty   -- n (a,b,c)-             tup_n_ty = mkBigCoreVarTupTy to_bndrs--       ; body       <- dsMcStmts stmts_rest-       ; n_tup_var  <- newSysLocalDs n_tup_ty-       ; tup_n_var  <- newSysLocalDs tup_n_ty-       ; tup_n_expr <- mkMcUnzipM form fmap_op n_tup_var from_bndr_tys-       ; us         <- newUniqueSupply-       ; let rhs'  = mkApps usingExpr' usingArgs-             body' = mkTupleCase us to_bndrs body tup_n_var tup_n_expr--       ; return (mkApps bind_op' [rhs', Lam n_tup_var body']) }---- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel--- statements, for example:------   [ body | qs1 | qs2 | qs3 ]---     ->  [ body | (bndrs1, (bndrs2, bndrs3))---                     <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ]------ where `mzip` has type---   mzip :: forall a b. m a -> m b -> m (a,b)--- NB: we need a polymorphic mzip because we call it several times--dsMcStmt (ParStmt blocks mzip_op bind_op) stmts_rest- = do  { exps_w_tys  <- mapM ds_inner blocks   -- Pairs (exp :: m ty, ty)-       ; mzip_op'    <- dsExpr mzip_op--       ; let -- The pattern variables-             pats = [ mkBigLHsVarPatTup bs | ParStmtBlock _ bs _ <- blocks]-             -- Pattern with tuples of variables-             -- [v1,v2,v3]  =>  (v1, (v2, v3))-             pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats-             (rhs, _) = foldr1 (\(e1,t1) (e2,t2) ->-                                 (mkApps mzip_op' [Type t1, Type t2, e1, e2],-                                  mkBoxedTupleTy [t1,t2]))-                               exps_w_tys--       ; dsMcBindStmt pat rhs bind_op noSyntaxExpr stmts_rest }-  where-    ds_inner (ParStmtBlock stmts bndrs return_op) -       = do { exp <- dsInnerMonadComp stmts bndrs return_op-            ; return (exp, mkBigCoreVarTupTy bndrs) }--dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)---matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr--- (matchTuple [a,b,c] body)---       returns the Core term---  \x. case x of (a,b,c) -> body-matchTuple ids body-  = do { us <- newUniqueSupply-       ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids)-       ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) }---- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a--- desugared `CoreExpr`-dsMcBindStmt :: LPat Id-             -> CoreExpr        -- ^ the desugared rhs of the bind statement-             -> SyntaxExpr Id-             -> SyntaxExpr Id-             -> [ExprLStmt Id]-             -> DsM CoreExpr-dsMcBindStmt pat rhs' bind_op fail_op stmts-  = do  { body     <- dsMcStmts stmts-        ; bind_op' <- dsExpr bind_op-        ; var      <- selectSimpleMatchVarL pat-        ; let bind_ty = exprType bind_op'       -- rhs -> (pat -> res1) -> res2-              res1_ty = funResultTy (funArgTy (funResultTy bind_ty))-        ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat-                                  res1_ty (cantFailMatchResult body)-        ; match_code <- handle_failure pat match fail_op-        ; return (mkApps bind_op' [rhs', Lam var match_code]) }--  where-    -- In a monad comprehension expression, pattern-match failure just calls-    -- the monadic `fail` rather than throwing an exception-    handle_failure pat match fail_op-      | matchCanFail match-        = do { fail_op' <- dsExpr fail_op-             ; dflags <- getDynFlags-             ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)-             ; extractMatchResult match (App fail_op' fail_msg) }-      | otherwise-        = extractMatchResult match (error "It can't fail")--    mk_fail_msg :: DynFlags -> Located e -> String-    mk_fail_msg dflags pat-        = "Pattern match failure in monad comprehension at " ++-          showPpr dflags (getLoc pat)---- Desugar nested monad comprehensions, for example in `then..` constructs---    dsInnerMonadComp quals [a,b,c] ret_op--- returns the desugaring of---       [ (a,b,c) | quals ]--dsInnerMonadComp :: [ExprLStmt Id]-                 -> [Id]        -- Return a tuple of these variables-                 -> HsExpr Id   -- The monomorphic "return" operator-                 -> DsM CoreExpr-dsInnerMonadComp stmts bndrs ret_op-  = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTup bndrs) ret_op)])---- The `unzip` function for `GroupStmt` in a monad comprehensions------   unzip :: m (a,b,..) -> (m a,m b,..)---   unzip m_tuple = ( liftM selN1 m_tuple---                   , liftM selN2 m_tuple---                   , .. )------   mkMcUnzipM fmap ys [t1, t2]---     = ( fmap (selN1 :: (t1, t2) -> t1) ys---       , fmap (selN2 :: (t1, t2) -> t2) ys )--mkMcUnzipM :: TransForm-           -> SyntaxExpr TcId   -- fmap-           -> Id                -- Of type n (a,b,c)-           -> [Type]            -- [a,b,c]-           -> DsM CoreExpr      -- Of type (n a, n b, n c)-mkMcUnzipM ThenForm _ ys _-  = return (Var ys) -- No unzipping to do--mkMcUnzipM _ fmap_op ys elt_tys-  = do { fmap_op' <- dsExpr fmap_op-       ; xs       <- mapM newSysLocalDs elt_tys-       ; let tup_ty = mkBigCoreTupTy elt_tys-       ; tup_xs   <- newSysLocalDs tup_ty--       ; let mk_elt i = mkApps fmap_op'  -- fmap :: forall a b. (a -> b) -> n a -> n b-                           [ Type tup_ty, Type (getNth elt_tys i)-                           , mk_sel i, Var ys]--             mk_sel n = Lam tup_xs $-                        mkTupleSelector xs (getNth xs n) tup_xs (Var tup_xs)--       ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) }-\end{code}
− src/Language/Haskell/Liquid/Desugar/DsMeta.hs 
@@ -1,2816 +0,0 @@------------------------------------------------------------------------------------ (c) The University of Glasgow 2006------ The purpose of this module is to transform an HsExpr into a CoreExpr which--- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the--- input HsExpr. We do this in the DsM monad, which supplies access to--- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.------ It also defines a bunch of knownKeyNames, in the same way as is done--- in prelude/PrelNames.  It's much more convenient to do it here, because--- otherwise we have to recompile PrelNames whenever we add a Name, which is--- a Royal Pain (triggers other recompilation).--------------------------------------------------------------------------------module Language.Haskell.Liquid.Desugar.DsMeta( dsBracket,-               templateHaskellNames, qTyConName, nameTyConName,-               liftName, liftStringName, expQTyConName, patQTyConName,-               decQTyConName, decsQTyConName, typeQTyConName,-               decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,-               quoteExpName, quotePatName, quoteDecName, quoteTypeName,-               tExpTyConName, tExpDataConName, unTypeName, unTypeQName,-               unsafeTExpCoerceName-                ) where---- #include "HsVersions.h"--import Language.Haskell.Liquid.Desugar.DsExpr ( dsExpr )--import Language.Haskell.Liquid.Desugar.MatchLit-import DsMonad--import qualified Language.Haskell.TH as TH--import HsSyn-import Class-import PrelNames--- To avoid clashes with DsMeta.varName we must make a local alias for--- OccName.varName we do this by removing varName from the import of--- OccName above, making a qualified instance of OccName and using--- OccNameAlias.varName where varName ws previously used in this file.-import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName, dataName )--import Module-import Id-import Name hiding( isVarOcc, isTcOcc, varName, tcName )-import NameEnv-import TcType-import TyCon-import TysWiredIn-import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName )-import CoreSyn-import MkCore-import CoreUtils-import SrcLoc-import Unique-import BasicTypes-import Outputable-import Bag-import DynFlags-import FastString-import ForeignCall-import Util--import Data.Maybe-import Control.Monad-import Data.List--------------------------------------------------------------------------------dsBracket :: HsBracket Name -> [PendingTcSplice] -> DsM CoreExpr--- Returns a CoreExpr of type TH.ExpQ--- The quoted thing is parameterised over Name, even though it has--- been type checked.  We don't want all those type decorations!--dsBracket brack splices-  = dsExtendMetaEnv new_bit (do_brack brack)-  where-    new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n, e) <- splices]--    do_brack (VarBr _ n) = do { MkC e1  <- lookupOcc n ; return e1 }-    do_brack (ExpBr e)   = do { MkC e1  <- repLE e     ; return e1 }-    do_brack (PatBr p)   = do { MkC p1  <- repTopP p   ; return p1 }-    do_brack (TypBr t)   = do { MkC t1  <- repLTy t    ; return t1 }-    do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }-    do_brack (DecBrL _)  = panic "dsBracket: unexpected DecBrL"-    do_brack (TExpBr e)  = do { MkC e1  <- repLE e     ; return e1 }--{- -------------- Examples ----------------------  [| \x -> x |]-====>-  gensym (unpackString "x"#) `bindQ` \ x1::String ->-  lam (pvar x1) (var x1)---  [| \x -> $(f [| x |]) |]-====>-  gensym (unpackString "x"#) `bindQ` \ x1::String ->-  lam (pvar x1) (f (var x1))--}-------------------------------------------------------------                      Declarations----------------------------------------------------------repTopP :: LPat Name -> DsM (Core TH.PatQ)-repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)-                 ; pat' <- addBinds ss (repLP pat)-                 ; wrapGenSyms ss pat' }--repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))-repTopDs group- = do { let { tv_bndrs = hsSigTvBinders (hs_valds group)-            ; bndrs = tv_bndrs ++ hsGroupBinders group } ;-        ss <- mkGenSyms bndrs ;--        -- Bind all the names mainly to avoid repeated use of explicit strings.-        -- Thus we get-        --      do { t :: String <- genSym "T" ;-        --           return (Data t [] ...more t's... }-        -- The other important reason is that the output must mention-        -- only "T", not "Foo:T" where Foo is the current module--        decls <- addBinds ss (do {-                        fix_ds  <- mapM repFixD (hs_fixds group) ;-                        val_ds  <- rep_val_binds (hs_valds group) ;-                        tycl_ds <- mapM repTyClD (tyClGroupConcat (hs_tyclds group)) ;-                        role_ds <- mapM repRoleD (concatMap group_roles (hs_tyclds group)) ;-                        inst_ds <- mapM repInstD (hs_instds group) ;-                        rule_ds <- mapM repRuleD (hs_ruleds group) ;-                        for_ds  <- mapM repForD  (hs_fords group) ;-                        -- more needed-                        return (de_loc $ sort_by_loc $-                                val_ds ++ catMaybes tycl_ds ++ role_ds ++ fix_ds-                                       ++ inst_ds ++ rule_ds ++ for_ds) }) ;--        decl_ty <- lookupType decQTyConName ;-        let { core_list = coreList' decl_ty decls } ;--        dec_ty <- lookupType decTyConName ;-        q_decs  <- repSequenceQ dec_ty core_list ;--        wrapGenSyms ss q_decs-      }---hsSigTvBinders :: HsValBinds Name -> [Name]--- See Note [Scoped type variables in bindings]-hsSigTvBinders binds-  = [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit qtvs _ _))) <- sigs-                     , tv <- hsQTvBndrs qtvs]-  where-    sigs = case binds of-             ValBindsIn  _ sigs -> sigs-             ValBindsOut _ sigs -> sigs---{- Notes--Note [Scoped type variables in bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   f :: forall a. a -> a-   f x = x::a-Here the 'forall a' brings 'a' into scope over the binding group.-To achieve this we--  a) Gensym a binding for 'a' at the same time as we do one for 'f'-     collecting the relevant binders with hsSigTvBinders--  b) When processing the 'forall', don't gensym--The relevant places are signposted with references to this Note--Note [Binders and occurrences]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we desugar [d| data T = MkT |]-we want to get-        Data "T" [] [Con "MkT" []] []-and *not*-        Data "Foo:T" [] [Con "Foo:MkT" []] []-That is, the new data decl should fit into whatever new module it is-asked to fit in.   We do *not* clone, though; no need for this:-        Data "T79" ....--But if we see this:-        data T = MkT-        foo = reifyDecl T--then we must desugar to-        foo = Data "Foo:T" [] [Con "Foo:MkT" []] []--So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.-And we use lookupOcc, rather than lookupBinder-in repTyClD and repC.---}---- represent associated family instances----repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))--repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ repFamilyDecl (L loc fam)--repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))-  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]-       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->-                repSynDecl tc1 bndrs rhs-       ; return (Just (loc, dec)) }--repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn }))-  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]-       ; tc_tvs <- mk_extra_tvs tc tvs defn-       ; dec <- addTyClTyVarBinds tc_tvs $ \bndrs ->-                repDataDefn tc1 bndrs Nothing (hsLTyVarNames tc_tvs) defn-       ; return (Just (loc, dec)) }--repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,-                             tcdTyVars = tvs, tcdFDs = fds,-                             tcdSigs = sigs, tcdMeths = meth_binds,-                             tcdATs = ats, tcdATDefs = [] }))-  = do { cls1 <- lookupLOcc cls         -- See note [Binders and occurrences]-       ; dec  <- addTyVarBinds tvs $ \bndrs ->-           do { cxt1   <- repLContext cxt-              ; sigs1  <- rep_sigs sigs-              ; binds1 <- rep_binds meth_binds-              ; fds1   <- repLFunDeps fds-              ; ats1   <- repFamilyDecls ats-              ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1)-              ; repClass cxt1 cls1 bndrs fds1 decls1-              }-       ; return $ Just (loc, dec)-       }---- Un-handled cases-repTyClD (L loc d) = putSrcSpanDs loc $-                     do { warnDs (hang ds_msg 4 (ppr d))-                        ; return Nothing }----------------------------repRoleD :: LRoleAnnotDecl Name -> DsM (SrcSpan, Core TH.DecQ)-repRoleD (L loc (RoleAnnotDecl tycon roles))-  = do { tycon1 <- lookupLOcc tycon-       ; roles1 <- mapM repRole roles-       ; roles2 <- coreList roleTyConName roles1-       ; dec <- repRoleAnnotD tycon1 roles2-       ; return (loc, dec) }----------------------------repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr]-            -> Maybe (Core [TH.TypeQ])-            -> [Name] -> HsDataDefn Name-            -> DsM (Core TH.DecQ)-repDataDefn tc bndrs opt_tys tv_names-          (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt-                      , dd_cons = cons, dd_derivs = mb_derivs })-  = do { cxt1     <- repLContext cxt-       ; derivs1  <- repDerivs mb_derivs-       ; case new_or_data of-           NewType  -> do { con1 <- repC tv_names (head cons)-                          ; repNewtype cxt1 tc bndrs opt_tys con1 derivs1 }-           DataType -> do { cons1 <- repList conQTyConName (repC tv_names) cons-                          ; repData cxt1 tc bndrs opt_tys cons1 derivs1 } }--repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr]-          -> LHsType Name-          -> DsM (Core TH.DecQ)-repSynDecl tc bndrs ty-  = do { ty1 <- repLTy ty-       ; repTySyn tc bndrs ty1 }--repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)-repFamilyDecl (L loc (FamilyDecl { fdInfo    = info,-                                   fdLName   = tc,-                                   fdTyVars  = tvs,-                                   fdKindSig = opt_kind }))-  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]-       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->-           case (opt_kind, info) of -                  (Nothing, ClosedTypeFamily eqns) ->-                    do { eqns1 <- mapM repTyFamEqn eqns-                       ; eqns2 <- coreList tySynEqnQTyConName eqns1-                       ; repClosedFamilyNoKind tc1 bndrs eqns2 }-                  (Just ki, ClosedTypeFamily eqns) ->-                    do { eqns1 <- mapM repTyFamEqn eqns-                       ; eqns2 <- coreList tySynEqnQTyConName eqns1-                       ; ki1 <- repLKind ki-                       ; repClosedFamilyKind tc1 bndrs ki1 eqns2 }              -                  (Nothing, _) ->-                    do { info' <- repFamilyInfo info-                       ; repFamilyNoKind info' tc1 bndrs }-                  (Just ki, _) ->-                    do { info' <- repFamilyInfo info-                       ; ki1 <- repLKind ki -                       ; repFamilyKind info' tc1 bndrs ki1 }-       ; return (loc, dec)-       }--repFamilyDecls :: [LFamilyDecl Name] -> DsM [Core TH.DecQ]-repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)----------------------------mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name-             -> HsDataDefn Name -> DsM (LHsTyVarBndrs Name)--- If there is a kind signature it must be of form---    k1 -> .. -> kn -> *--- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]-mk_extra_tvs tc tvs defn-  | HsDataDefn { dd_kindSig = Just hs_kind } <- defn-  = do { extra_tvs <- go hs_kind-       ; return (tvs { hsq_tvs = hsq_tvs tvs ++ extra_tvs }) }-  | otherwise-  = return tvs-  where-    go :: LHsKind Name -> DsM [LHsTyVarBndr Name]-    go (L loc (HsFunTy kind rest))-      = do { uniq <- newUnique-           ; let { occ = mkTyVarOccFS (fsLit "t")-                 ; nm = mkInternalName uniq occ loc-                 ; hs_tv = L loc (KindedTyVar nm kind) }-           ; hs_tvs <- go rest-           ; return (hs_tv : hs_tvs) }--    go (L _ (HsTyVar n))-      | n == liftedTypeKindTyConName-      = return []--    go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc)------------------------------ represent fundeps----repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])-repLFunDeps fds = repList funDepTyConName repLFunDep fds--repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)-repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName lookupBinder xs-                               ys' <- repList nameTyConName lookupBinder ys-                               repFunDep xs' ys'---- represent family declaration flavours----repFamilyInfo :: FamilyInfo Name -> DsM (Core TH.FamFlavour)-repFamilyInfo OpenTypeFamily      = rep2 typeFamName []-repFamilyInfo DataFamily          = rep2 dataFamName []-repFamilyInfo ClosedTypeFamily {} = panic "repFamilyInfo"---- Represent instance declarations----repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)-repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))-  = do { dec <- repTyFamInstD fi_decl-       ; return (loc, dec) }-repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))-  = do { dec <- repDataFamInstD fi_decl-       ; return (loc, dec) }-repInstD (L loc (ClsInstD { cid_inst = cls_decl }))-  = do { dec <- repClsInstD cls_decl-       ; return (loc, dec) }--repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ)-repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds-                         , cid_sigs = prags, cid_tyfam_insts = ats-                         , cid_datafam_insts = adts })-  = addTyVarBinds tvs $ \_ ->-            -- We must bring the type variables into scope, so their-            -- occurrences don't fail, even though the binders don't-            -- appear in the resulting data structure-            ---            -- But we do NOT bring the binders of 'binds' into scope-            -- because they are properly regarded as occurrences-            -- For example, the method names should be bound to-            -- the selector Ids, not to fresh names (Trac #5410)-            ---            do { cxt1 <- repContext cxt-               ; cls_tcon <- repTy (HsTyVar (unLoc cls))-               ; cls_tys <- repLTys tys-               ; inst_ty1 <- repTapps cls_tcon cls_tys-               ; binds1 <- rep_binds binds-               ; prags1 <- rep_sigs prags-               ; ats1 <- mapM (repTyFamInstD . unLoc) ats-               ; adts1 <- mapM (repDataFamInstD . unLoc) adts-               ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)-               ; repInst cxt1 inst_ty1 decls }- where-   Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty--repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)-repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })-  = do { let tc_name = tyFamInstDeclLName decl-       ; tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]  -       ; eqn1 <- repTyFamEqn eqn-       ; repTySynInst tc eqn1 }--repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)-repTyFamEqn (L loc (TyFamInstEqn { tfie_pats = HsWB { hswb_cts = tys-                                                    , hswb_kvs = kv_names-                                                    , hswb_tvs = tv_names }-                                 , tfie_rhs = rhs }))-  = do { let hs_tvs = HsQTvs { hsq_kvs = kv_names-                             , hsq_tvs = userHsTyVarBndrs loc tv_names }   -- Yuk-       ; addTyClTyVarBinds hs_tvs $ \ _ ->-         do { tys1 <- repLTys tys-            ; tys2 <- coreList typeQTyConName tys1-            ; rhs1 <- repLTy rhs-            ; repTySynEqn tys2 rhs1 } }--repDataFamInstD :: DataFamInstDecl Name -> DsM (Core TH.DecQ)-repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name-                                 , dfid_pats = HsWB { hswb_cts = tys, hswb_kvs = kv_names, hswb_tvs = tv_names }-                                 , dfid_defn = defn })-  = do { tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]-       ; let loc = getLoc tc_name-             hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names }   -- Yuk-       ; addTyClTyVarBinds hs_tvs $ \ bndrs ->-         do { tys1 <- repList typeQTyConName repLTy tys-            ; repDataDefn tc bndrs (Just tys1) tv_names defn } }--repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)-repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis)))- = do MkC name' <- lookupLOcc name-      MkC typ' <- repLTy typ-      MkC cc' <- repCCallConv cc-      MkC s' <- repSafety s-      cis' <- conv_cimportspec cis-      MkC str <- coreStringLit (static ++ chStr ++ cis')-      dec <- rep2 forImpDName [cc', s', str, name', typ']-      return (loc, dec)- where-    conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))-    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"-    conv_cimportspec (CFunction (StaticTarget fs _ True)) = return (unpackFS fs)-    conv_cimportspec (CFunction (StaticTarget _  _ False)) = panic "conv_cimportspec: values not supported yet"-    conv_cimportspec CWrapper = return "wrapper"-    static = case cis of-                 CFunction (StaticTarget _ _ _) -> "static "-                 _ -> ""-    chStr = case mch of-            Nothing -> ""-            Just (Header h) -> unpackFS h ++ " "-repForD decl = notHandled "Foreign declaration" (ppr decl)--repCCallConv :: CCallConv -> DsM (Core TH.Callconv)-repCCallConv CCallConv = rep2 cCallName []-repCCallConv StdCallConv = rep2 stdCallName []-repCCallConv callConv    = notHandled "repCCallConv" (ppr callConv)--repSafety :: Safety -> DsM (Core TH.Safety)-repSafety PlayRisky = rep2 unsafeName []-repSafety PlayInterruptible = rep2 interruptibleName []-repSafety PlaySafe = rep2 safeName []--repFixD :: LFixitySig Name -> DsM (SrcSpan, Core TH.DecQ)-repFixD (L loc (FixitySig name (Fixity prec dir)))-  = do { MkC name' <- lookupLOcc name-       ; MkC prec' <- coreIntLit prec-       ; let rep_fn = case dir of-                        InfixL -> infixLDName-                        InfixR -> infixRDName-                        InfixN -> infixNDName-       ; dec <- rep2 rep_fn [prec', name']-       ; return (loc, dec) }--repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)-repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))-  = do { let bndr_names = concatMap ruleBndrNames bndrs-       ; ss <- mkGenSyms bndr_names-       ; rule1 <- addBinds ss $-                  do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs-                     ; n'   <- coreStringLit $ unpackFS n-                     ; act' <- repPhases act-                     ; lhs' <- repLE lhs-                     ; rhs' <- repLE rhs-                     ; repPragRule n' bndrs' lhs' rhs' act' }-       ; rule2 <- wrapGenSyms ss rule1-       ; return (loc, rule2) }--ruleBndrNames :: RuleBndr Name -> [Name]-ruleBndrNames (RuleBndr n)      = [unLoc n]-ruleBndrNames (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs }))-  = unLoc n : kvs ++ tvs--repRuleBndr :: RuleBndr Name -> DsM (Core TH.RuleBndrQ)-repRuleBndr (RuleBndr n)-  = do { MkC n' <- lookupLBinder n-       ; rep2 ruleVarName [n'] }-repRuleBndr (RuleBndrSig n (HsWB { hswb_cts = ty }))-  = do { MkC n'  <- lookupLBinder n-       ; MkC ty' <- repLTy ty-       ; rep2 typedRuleVarName [n', ty'] }--ds_msg :: SDoc-ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")------------------------------------------------------------                      Constructors----------------------------------------------------------repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ)-repC _ (L _ (ConDecl { con_name = con, con_qvars = con_tvs, con_cxt = L _ []-                     , con_details = details, con_res = ResTyH98 }))-  | null (hsQTvBndrs con_tvs)-  = do { con1 <- lookupLOcc con         -- See Note [Binders and occurrences]-       ; repConstr con1 details  }--repC tvs (L _ (ConDecl { con_name = con-                       , con_qvars = con_tvs, con_cxt = L _ ctxt-                       , con_details = details-                       , con_res = res_ty }))-  = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty-       ; let ex_tvs = HsQTvs { hsq_kvs = filterOut (in_subst con_tv_subst) (hsq_kvs con_tvs)-                             , hsq_tvs = filterOut (in_subst con_tv_subst . hsLTyVarName) (hsq_tvs con_tvs) }--       ; binds <- mapM dupBinder con_tv_subst-       ; dsExtendMetaEnv (mkNameEnv binds) $     -- Binds some of the con_tvs-         addTyVarBinds ex_tvs $ \ ex_bndrs ->   -- Binds the remaining con_tvs-    do { con1      <- lookupLOcc con    -- See Note [Binders and occurrences]-       ; c'        <- repConstr con1 details-       ; ctxt'     <- repContext (eq_ctxt ++ ctxt)-       ; rep2 forallCName [unC ex_bndrs, unC ctxt', unC c'] } }--in_subst :: [(Name,Name)] -> Name -> Bool-in_subst []          _ = False-in_subst ((n',_):ns) n = n==n' || in_subst ns n--mkGadtCtxt :: [Name]            -- Tyvars of the data type-           -> ResType (LHsType Name)-           -> DsM (HsContext Name, [(Name,Name)])--- Given a data type in GADT syntax, figure out the equality--- context, so that we can represent it with an explicit--- equality context, because that is the only way to express--- the GADT in TH syntax------ Example:--- data T a b c where { MkT :: forall d e. d -> e -> T d [e] e---     mkGadtCtxt [a,b,c] [d,e] (T d [e] e)---   returns---     (b~[e], c~e), [d->a]------ This function is fiddly, but not really hard-mkGadtCtxt _ ResTyH98-  = return ([], [])-mkGadtCtxt data_tvs (ResTyGADT res_ty)-  | Just (_, tys) <- hsTyGetAppHead_maybe res_ty-  , data_tvs `equalLength` tys-  = return (go [] [] (data_tvs `zip` tys))--  | otherwise-  = failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty)-  where-    go cxt subst [] = (cxt, subst)-    go cxt subst ((data_tv, ty) : rest)-       | Just con_tv <- is_hs_tyvar ty-       , isTyVarName con_tv-       , not (in_subst subst con_tv)-       = go cxt ((con_tv, data_tv) : subst) rest-       | otherwise-       = go (eq_pred : cxt) subst rest-       where-         loc = getLoc ty-         eq_pred = L loc (HsEqTy (L loc (HsTyVar data_tv)) ty)--    is_hs_tyvar (L _ (HsTyVar n))  = Just n   -- Type variables *and* tycons-    is_hs_tyvar (L _ (HsParTy ty)) = is_hs_tyvar ty-    is_hs_tyvar _                  = Nothing---repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))-repBangTy ty= do-  MkC s <- rep2 str []-  MkC t <- repLTy ty'-  rep2 strictTypeName [s, t]-  where-    (str, ty') = case ty of-                   L _ (HsBangTy (HsUserBang (Just True) True) ty) -> (unpackedName,  ty)-                   L _ (HsBangTy (HsUserBang _     True) ty)       -> (isStrictName,  ty)-                   _                               -> (notStrictName, ty)------------------------------------------------------------                      Deriving clause----------------------------------------------------------repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])-repDerivs Nothing = coreList nameTyConName []-repDerivs (Just ctxt)-  = repList nameTyConName rep_deriv ctxt-  where-    rep_deriv :: LHsType Name -> DsM (Core TH.Name)-        -- Deriving clauses must have the simple H98 form-    rep_deriv ty-      | Just (cls, []) <- splitHsClassTy_maybe (unLoc ty)-      = lookupOcc cls-      | otherwise-      = notHandled "Non-H98 deriving clause" (ppr ty)-------------------------------------------------------------   Signatures in a class decl, or a group of bindings----------------------------------------------------------rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]-rep_sigs sigs = do locs_cores <- rep_sigs' sigs-                   return $ de_loc $ sort_by_loc locs_cores--rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]-        -- We silently ignore ones we don't recognise-rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;-                     return (concat sigs1) }--rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]-        -- Singleton => Ok-        -- Empty     => Too hard, signature ignored-rep_sig (L loc (TypeSig nms ty))      = mapM (rep_ty_sig loc ty) nms-rep_sig (L _   (GenericSig nm _))     = failWithDs msg-  where msg = vcat  [ ptext (sLit "Illegal default signature for") <+> quotes (ppr nm)-                    , ptext (sLit "Default signatures are not supported by Template Haskell") ]--rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc-rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc-rep_sig (L loc (SpecInstSig ty))      = rep_specialiseInst ty loc-rep_sig _                             = return []--rep_ty_sig :: SrcSpan -> LHsType Name -> Located Name-           -> DsM (SrcSpan, Core TH.DecQ)-rep_ty_sig loc (L _ ty) nm-  = do { nm1 <- lookupLOcc nm-       ; ty1 <- rep_ty ty-       ; sig <- repProto nm1 ty1-       ; return (loc, sig) }-  where-    -- We must special-case the top-level explicit for-all of a TypeSig-    -- See Note [Scoped type variables in bindings]-    rep_ty (HsForAllTy Explicit tvs ctxt ty)-      = do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)-                                         ; repTyVarBndrWithKind tv name }-           ; bndrs1 <- repList tyVarBndrTyConName rep_in_scope_tv (hsQTvBndrs tvs)-           ; ctxt1  <- repLContext ctxt-           ; ty1    <- repLTy ty-           ; repTForall bndrs1 ctxt1 ty1 }--    rep_ty ty = repTy ty---rep_inline :: Located Name-           -> InlinePragma      -- Never defaultInlinePragma-           -> SrcSpan-           -> DsM [(SrcSpan, Core TH.DecQ)]-rep_inline nm ispec loc-  = do { nm1    <- lookupLOcc nm-       ; inline <- repInline $ inl_inline ispec-       ; rm     <- repRuleMatch $ inl_rule ispec-       ; phases <- repPhases $ inl_act ispec-       ; pragma <- repPragInl nm1 inline rm phases-       ; return [(loc, pragma)]-       }--rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan-               -> DsM [(SrcSpan, Core TH.DecQ)]-rep_specialise nm ty ispec loc-  = do { nm1 <- lookupLOcc nm-       ; ty1 <- repLTy ty-       ; phases <- repPhases $ inl_act ispec-       ; let inline = inl_inline ispec-       ; pragma <- if isEmptyInlineSpec inline-                   then -- SPECIALISE-                     repPragSpec nm1 ty1 phases-                   else -- SPECIALISE INLINE-                     do { inline1 <- repInline inline-                        ; repPragSpecInl nm1 ty1 inline1 phases }-       ; return [(loc, pragma)]-       }--rep_specialiseInst :: LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]-rep_specialiseInst ty loc-  = do { ty1    <- repLTy ty-       ; pragma <- repPragSpecInst ty1-       ; return [(loc, pragma)] }--repInline :: InlineSpec -> DsM (Core TH.Inline)-repInline NoInline  = dataCon noInlineDataConName-repInline Inline    = dataCon inlineDataConName-repInline Inlinable = dataCon inlinableDataConName-repInline spec      = notHandled "repInline" (ppr spec)--repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)-repRuleMatch ConLike = dataCon conLikeDataConName-repRuleMatch FunLike = dataCon funLikeDataConName--repPhases :: Activation -> DsM (Core TH.Phases)-repPhases (ActiveBefore i) = do { MkC arg <- coreIntLit i-                                ; dataCon' beforePhaseDataConName [arg] }-repPhases (ActiveAfter i)  = do { MkC arg <- coreIntLit i-                                ; dataCon' fromPhaseDataConName [arg] }-repPhases _                = dataCon allPhasesDataConName------------------------------------------------------------                      Types----------------------------------------------------------addTyVarBinds :: LHsTyVarBndrs Name                            -- the binders to be added-              -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env-              -> DsM (Core (TH.Q a))--- gensym a list of type variables and enter them into the meta environment;--- the computations passed as the second argument is executed in that extended--- meta environment and gets the *new* names on Core-level as an argument--addTyVarBinds (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) m-  = do { fresh_kv_names <- mkGenSyms kvs-       ; fresh_tv_names <- mkGenSyms (map hsLTyVarName tvs)-       ; let fresh_names = fresh_kv_names ++ fresh_tv_names-       ; term <- addBinds fresh_names $-                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (tvs `zip` fresh_tv_names)-                    ; m kbs }-       ; wrapGenSyms fresh_names term }-  where-    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)--addTyClTyVarBinds :: LHsTyVarBndrs Name-                  -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))-                  -> DsM (Core (TH.Q a))---- Used for data/newtype declarations, and family instances,--- so that the nested type variables work right---    instance C (T a) where---      type W (T a) = blah--- The 'a' in the type instance is the one bound by the instance decl-addTyClTyVarBinds tvs m-  = do { let tv_names = hsLKiTyVarNames tvs-       ; env <- dsGetMetaEnv-       ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)-            -- Make fresh names for the ones that are not already in scope-            -- This makes things work for family declarations--       ; term <- addBinds freshNames $-                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs)-                    ; m kbs }--       ; wrapGenSyms freshNames term }-  where-    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)-                       ; repTyVarBndrWithKind tv v }---- Produce kinded binder constructors from the Haskell tyvar binders----repTyVarBndrWithKind :: LHsTyVarBndr Name-                     -> Core TH.Name -> DsM (Core TH.TyVarBndr)-repTyVarBndrWithKind (L _ (UserTyVar _)) nm-  = repPlainTV nm-repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm-  = repLKind ki >>= repKindedTV nm---- represent a type context----repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)-repLContext (L _ ctxt) = repContext ctxt--repContext :: HsContext Name -> DsM (Core TH.CxtQ)-repContext ctxt = do preds <- repList predQTyConName repLPred ctxt-                     repCtxt preds---- represent a type predicate----repLPred :: LHsType Name -> DsM (Core TH.PredQ)-repLPred (L _ p) = repPred p--repPred :: HsType Name -> DsM (Core TH.PredQ)-repPred (HsParTy ty) -  = repLPred ty-repPred ty-  | Just (cls, tys) <- splitHsClassTy_maybe ty-  = do-      cls1 <- lookupOcc cls-      tys1 <- repList typeQTyConName repLTy tys-      repClassP cls1 tys1-repPred (HsEqTy tyleft tyright)-  = do-      tyleft1  <- repLTy tyleft-      tyright1 <- repLTy tyright-      repEqualP tyleft1 tyright1-repPred ty-  = notHandled "Exotic predicate type" (ppr ty)---- yield the representation of a list of types----repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]-repLTys tys = mapM repLTy tys---- represent a type----repLTy :: LHsType Name -> DsM (Core TH.TypeQ)-repLTy (L _ ty) = repTy ty--repTy :: HsType Name -> DsM (Core TH.TypeQ)-repTy (HsForAllTy _ tvs ctxt ty)  =-  addTyVarBinds tvs $ \bndrs -> do-    ctxt1  <- repLContext ctxt-    ty1    <- repLTy ty-    repTForall bndrs ctxt1 ty1--repTy (HsTyVar n)-  | isTvOcc occ   = do tv1 <- lookupOcc n-                       repTvar tv1-  | isDataOcc occ = do tc1 <- lookupOcc n-                       repPromotedTyCon tc1-  | otherwise     = do tc1 <- lookupOcc n-                       repNamedTyCon tc1-  where-    occ = nameOccName n--repTy (HsAppTy f a)         = do-                                f1 <- repLTy f-                                a1 <- repLTy a-                                repTapp f1 a1-repTy (HsFunTy f a)         = do-                                f1   <- repLTy f-                                a1   <- repLTy a-                                tcon <- repArrowTyCon-                                repTapps tcon [f1, a1]-repTy (HsListTy t)          = do-                                t1   <- repLTy t-                                tcon <- repListTyCon-                                repTapp tcon t1-repTy (HsPArrTy t)          = do-                                t1   <- repLTy t-                                tcon <- repTy (HsTyVar (tyConName parrTyCon))-                                repTapp tcon t1-repTy (HsTupleTy HsUnboxedTuple tys) = do-                                tys1 <- repLTys tys-                                tcon <- repUnboxedTupleTyCon (length tys)-                                repTapps tcon tys1-repTy (HsTupleTy _ tys)     = do tys1 <- repLTys tys-                                 tcon <- repTupleTyCon (length tys)-                                 repTapps tcon tys1-repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)-                                   `nlHsAppTy` ty2)-repTy (HsParTy t)           = repLTy t-repTy (HsKindSig t k)       = do-                                t1 <- repLTy t-                                k1 <- repLKind k-                                repTSig t1 k1-repTy (HsSpliceTy splice _)     = repSplice splice-repTy (HsExplicitListTy _ tys)  = do-                                    tys1 <- repLTys tys-                                    repTPromotedList tys1-repTy (HsExplicitTupleTy _ tys) = do-                                    tys1 <- repLTys tys-                                    tcon <- repPromotedTupleTyCon (length tys)-                                    repTapps tcon tys1-repTy (HsTyLit lit) = do-                        lit' <- repTyLit lit-                        repTLit lit'-repTy ty                      = notHandled "Exotic form of type" (ppr ty)--repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)-repTyLit (HsNumTy i) = do iExpr <- mkIntegerExpr i-                          rep2 numTyLitName [iExpr]-repTyLit (HsStrTy s) = do { s' <- mkStringExprFS s-                         ; rep2 strTyLitName [s']-                         }---- represent a kind----repLKind :: LHsKind Name -> DsM (Core TH.Kind)-repLKind ki-  = do { let (kis, ki') = splitHsFunType ki-       ; kis_rep <- mapM repLKind kis-       ; ki'_rep <- repNonArrowLKind ki'-       ; kcon <- repKArrow-       ; let f k1 k2 = repKApp kcon k1 >>= flip repKApp k2-       ; foldrM f ki'_rep kis_rep-       }--repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind)-repNonArrowLKind (L _ ki) = repNonArrowKind ki--repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind)-repNonArrowKind (HsTyVar name)-  | name == liftedTypeKindTyConName = repKStar-  | name == constraintKindTyConName = repKConstraint-  | isTvOcc (nameOccName name)      = lookupOcc name >>= repKVar-  | otherwise                       = lookupOcc name >>= repKCon-repNonArrowKind (HsAppTy f a)       = do  { f' <- repLKind f-                                          ; a' <- repLKind a-                                          ; repKApp f' a'-                                          }-repNonArrowKind (HsListTy k)        = do  { k' <- repLKind k-                                          ; kcon <- repKList-                                          ; repKApp kcon k'-                                          }-repNonArrowKind (HsTupleTy _ ks)    = do  { ks' <- mapM repLKind ks-                                          ; kcon <- repKTuple (length ks)-                                          ; repKApps kcon ks'-                                          }-repNonArrowKind k                   = notHandled "Exotic form of kind" (ppr k)--repRole :: Located (Maybe Role) -> DsM (Core TH.Role)-repRole (L _ (Just Nominal))          = rep2 nominalRName []-repRole (L _ (Just Representational)) = rep2 representationalRName []-repRole (L _ (Just Phantom))          = rep2 phantomRName []-repRole (L _ Nothing)                 = rep2 inferRName []----------------------------------------------------------------------------------              Splices--------------------------------------------------------------------------------repSplice :: HsSplice Name -> DsM (Core a)--- See Note [How brackets and nested splices are handled] in TcSplice--- We return a CoreExpr of any old type; the context should know-repSplice (HsSplice n _)- = do { mb_val <- dsLookupMetaEnv n-       ; case mb_val of-           Just (Splice e) -> do { e' <- dsExpr e-                                 ; return (MkC e') }-           _ -> pprPanic "HsSplice" (ppr n) }-                        -- Should not happen; statically checked----------------------------------------------------------------------------------              Expressions--------------------------------------------------------------------------------repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])-repLEs es = repList expQTyConName repLE es---- FIXME: some of these panics should be converted into proper error messages---        unless we can make sure that constructs, which are plainly not---        supported in TH already lead to error messages at an earlier stage-repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)-repLE (L loc e) = putSrcSpanDs loc (repE e)--repE :: HsExpr Name -> DsM (Core TH.ExpQ)-repE (HsVar x)            =-  do { mb_val <- dsLookupMetaEnv x-     ; case mb_val of-        Nothing          -> do { str <- globalVar x-                               ; repVarOrCon x str }-        Just (Bound y)   -> repVarOrCon x (coreVar y)-        Just (Splice e)  -> do { e' <- dsExpr e-                               ; return (MkC e') } }-repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)--        -- Remember, we're desugaring renamer output here, so-        -- HsOverlit can definitely occur-repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }-repE (HsLit l)     = do { a <- repLiteral l;           repLit a }-repE (HsLam (MG { mg_alts = [m] })) = repLambda m-repE (HsLamCase _ (MG { mg_alts = ms }))-                   = do { ms' <- mapM repMatchTup ms-                        ; core_ms <- coreList matchQTyConName ms'-                        ; repLamCase core_ms }-repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}--repE (OpApp e1 op _ e2) =-  do { arg1 <- repLE e1;-       arg2 <- repLE e2;-       the_op <- repLE op ;-       repInfixApp arg1 the_op arg2 }-repE (NegApp x _)        = do-                              a         <- repLE x-                              negateVar <- lookupOcc negateName >>= repVar-                              negateVar `repApp` a-repE (HsPar x)            = repLE x-repE (SectionL x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b }-repE (SectionR x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }-repE (HsCase e (MG { mg_alts = ms }))-                          = do { arg <- repLE e-                               ; ms2 <- mapM repMatchTup ms-                               ; core_ms2 <- coreList matchQTyConName ms2-                               ; repCaseE arg core_ms2 }-repE (HsIf _ x y z)         = do-                              a <- repLE x-                              b <- repLE y-                              c <- repLE z-                              repCond a b c-repE (HsMultiIf _ alts)-  = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts-       ; expr' <- repMultiIf (nonEmptyCoreList alts')-       ; wrapGenSyms (concat binds) expr' }-repE (HsLet bs e)         = do { (ss,ds) <- repBinds bs-                               ; e2 <- addBinds ss (repLE e)-                               ; z <- repLetE ds e2-                               ; wrapGenSyms ss z }---- FIXME: I haven't got the types here right yet-repE e@(HsDo ctxt sts _)- | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }- = do { (ss,zs) <- repLSts sts;-        e'      <- repDoE (nonEmptyCoreList zs);-        wrapGenSyms ss e' }-- | ListComp <- ctxt- = do { (ss,zs) <- repLSts sts;-        e'      <- repComp (nonEmptyCoreList zs);-        wrapGenSyms ss e' }--  | otherwise-  = notHandled "mdo, monad comprehension and [: :]" (ppr e)--repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }-repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)-repE e@(ExplicitTuple es boxed)-  | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)-  | isBoxed boxed              = do { xs <- repLEs [e | Present e <- es]; repTup xs }-  | otherwise                  = do { xs <- repLEs [e | Present e <- es]; repUnboxedTup xs }--repE (RecordCon c _ flds)- = do { x <- lookupLOcc c;-        fs <- repFields flds;-        repRecCon x fs }-repE (RecordUpd e flds _ _ _)- = do { x <- repLE e;-        fs <- repFields flds;-        repRecUpd x fs }--repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }-repE (ArithSeq _ _ aseq) =-  case aseq of-    From e              -> do { ds1 <- repLE e; repFrom ds1 }-    FromThen e1 e2      -> do-                             ds1 <- repLE e1-                             ds2 <- repLE e2-                             repFromThen ds1 ds2-    FromTo   e1 e2      -> do-                             ds1 <- repLE e1-                             ds2 <- repLE e2-                             repFromTo ds1 ds2-    FromThenTo e1 e2 e3 -> do-                             ds1 <- repLE e1-                             ds2 <- repLE e2-                             ds3 <- repLE e3-                             repFromThenTo ds1 ds2 ds3--repE (HsSpliceE _ splice)  = repSplice splice-repE e@(PArrSeq {})        = notHandled "Parallel arrays" (ppr e)-repE e@(HsCoreAnn {})      = notHandled "Core annotations" (ppr e)-repE e@(HsSCC {})          = notHandled "Cost centres" (ppr e)-repE e@(HsTickPragma {})   = notHandled "Tick Pragma" (ppr e)-repE e@(HsTcBracketOut {}) = notHandled "TH brackets" (ppr e)-repE e                     = notHandled "Expression form" (ppr e)---------------------------------------------------------------------------------- Building representations of auxillary structures like Match, Clause, Stmt,--repMatchTup ::  LMatch Name (LHsExpr Name) -> DsM (Core TH.MatchQ)-repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) =-  do { ss1 <- mkGenSyms (collectPatBinders p)-     ; addBinds ss1 $ do {-     ; p1 <- repLP p-     ; (ss2,ds) <- repBinds wheres-     ; addBinds ss2 $ do {-     ; gs    <- repGuards guards-     ; match <- repMatch p1 gs ds-     ; wrapGenSyms (ss1++ss2) match }}}-repMatchTup _ = panic "repMatchTup: case alt with more than one arg"--repClauseTup ::  LMatch Name (LHsExpr Name) -> DsM (Core TH.ClauseQ)-repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) =-  do { ss1 <- mkGenSyms (collectPatsBinders ps)-     ; addBinds ss1 $ do {-       ps1 <- repLPs ps-     ; (ss2,ds) <- repBinds wheres-     ; addBinds ss2 $ do {-       gs <- repGuards guards-     ; clause <- repClause ps1 gs ds-     ; wrapGenSyms (ss1++ss2) clause }}}--repGuards ::  [LGRHS Name (LHsExpr Name)] ->  DsM (Core TH.BodyQ)-repGuards [L _ (GRHS [] e)]-  = do {a <- repLE e; repNormal a }-repGuards other-  = do { zs <- mapM repLGRHS other-       ; let (xs, ys) = unzip zs-       ; gd <- repGuarded (nonEmptyCoreList ys)-       ; wrapGenSyms (concat xs) gd }--repLGRHS :: LGRHS Name (LHsExpr Name) -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))-repLGRHS (L _ (GRHS [L _ (BodyStmt e1 _ _ _)] e2))-  = do { guarded <- repLNormalGE e1 e2-       ; return ([], guarded) }-repLGRHS (L _ (GRHS ss rhs))-  = do { (gs, ss') <- repLSts ss-       ; rhs' <- addBinds gs $ repLE rhs-       ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'-       ; return (gs, guarded) }--repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])-repFields (HsRecFields { rec_flds = flds })-  = repList fieldExpQTyConName rep_fld flds-  where-    rep_fld fld = do { fn <- lookupLOcc (hsRecFieldId fld)-                     ; e  <- repLE (hsRecFieldArg fld)-                     ; repFieldExp fn e }----------------------------------------------------------------------------------- Representing Stmt's is tricky, especially if bound variables--- shadow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]--- First gensym new names for every variable in any of the patterns.--- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))--- if variables didn't shaddow, the static gensym wouldn't be necessary--- and we could reuse the original names (x and x).------ do { x'1 <- gensym "x"---    ; x'2 <- gensym "x"---    ; doE [ BindSt (pvar x'1) [| f 1 |]---          , BindSt (pvar x'2) [| f x |]---          , NoBindSt [| g x |]---          ]---    }---- The strategy is to translate a whole list of do-bindings by building a--- bigger environment, and a bigger set of meta bindings--- (like:  x'1 <- gensym "x" ) and then combining these with the translations--- of the expressions within the Do---------------------------------------------------------------------------------- The helper function repSts computes the translation of each sub expression--- and a bunch of prefix bindings denoting the dynamic renaming.--repLSts :: [LStmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ])-repLSts stmts = repSts (map unLoc stmts)--repSts :: [Stmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ])-repSts (BindStmt p e _ _ : ss) =-   do { e2 <- repLE e-      ; ss1 <- mkGenSyms (collectPatBinders p)-      ; addBinds ss1 $ do {-      ; p1 <- repLP p;-      ; (ss2,zs) <- repSts ss-      ; z <- repBindSt p1 e2-      ; return (ss1++ss2, z : zs) }}-repSts (LetStmt bs : ss) =-   do { (ss1,ds) <- repBinds bs-      ; z <- repLetSt ds-      ; (ss2,zs) <- addBinds ss1 (repSts ss)-      ; return (ss1++ss2, z : zs) }-repSts (BodyStmt e _ _ _ : ss) =-   do { e2 <- repLE e-      ; z <- repNoBindSt e2-      ; (ss2,zs) <- repSts ss-      ; return (ss2, z : zs) }-repSts (ParStmt stmt_blocks _ _ : ss) =-   do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks-      ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1-            ss1 = concat ss_s-      ; z <- repParSt stmt_blocks2-      ; (ss2, zs) <- addBinds ss1 (repSts ss)-      ; return (ss1++ss2, z : zs) }-   where-     rep_stmt_block :: ParStmtBlock Name Name -> DsM ([GenSymBind], Core [TH.StmtQ])-     rep_stmt_block (ParStmtBlock stmts _ _) =-       do { (ss1, zs) <- repSts (map unLoc stmts)-          ; zs1 <- coreList stmtQTyConName zs-          ; return (ss1, zs1) }-repSts [LastStmt e _]-  = do { e2 <- repLE e-       ; z <- repNoBindSt e2-       ; return ([], [z]) }-repSts []    = return ([],[])-repSts other = notHandled "Exotic statement" (ppr other)-----------------------------------------------------------------                      Bindings--------------------------------------------------------------repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])-repBinds EmptyLocalBinds-  = do  { core_list <- coreList decQTyConName []-        ; return ([], core_list) }--repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)--repBinds (HsValBinds decs)- = do   { let { bndrs = hsSigTvBinders decs ++ collectHsValBinders decs }-                -- No need to worrry about detailed scopes within-                -- the binding group, because we are talking Names-                -- here, so we can safely treat it as a mutually-                -- recursive group-                -- For hsSigTvBinders see Note [Scoped type variables in bindings]-        ; ss        <- mkGenSyms bndrs-        ; prs       <- addBinds ss (rep_val_binds decs)-        ; core_list <- coreList decQTyConName-                                (de_loc (sort_by_loc prs))-        ; return (ss, core_list) }--rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]--- Assumes: all the binders of the binding are alrady in the meta-env-rep_val_binds (ValBindsOut binds sigs)- = do { core1 <- rep_binds' (unionManyBags (map snd binds))-      ; core2 <- rep_sigs' sigs-      ; return (core1 ++ core2) }-rep_val_binds (ValBindsIn _ _)- = panic "rep_val_binds: ValBindsIn"--rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]-rep_binds binds = do { binds_w_locs <- rep_binds' binds-                     ; return (de_loc (sort_by_loc binds_w_locs)) }--rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]-rep_binds' = mapM rep_bind . bagToList--rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)--- Assumes: all the binders of the binding are alrady in the meta-env---- Note GHC treats declarations of a variable (not a pattern)--- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match--- with an empty list of patterns-rep_bind (L loc (FunBind { fun_id = fn,-                           fun_matches = MG { mg_alts = [L _ (Match [] _ (GRHSs guards wheres))] } }))- = do { (ss,wherecore) <- repBinds wheres-        ; guardcore <- addBinds ss (repGuards guards)-        ; fn'  <- lookupLBinder fn-        ; p    <- repPvar fn'-        ; ans  <- repVal p guardcore wherecore-        ; ans' <- wrapGenSyms ss ans-        ; return (loc, ans') }--rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MG { mg_alts = ms } }))- =   do { ms1 <- mapM repClauseTup ms-        ; fn' <- lookupLBinder fn-        ; ans <- repFun fn' (nonEmptyCoreList ms1)-        ; return (loc, ans) }--rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))- =   do { patcore <- repLP pat-        ; (ss,wherecore) <- repBinds wheres-        ; guardcore <- addBinds ss (repGuards guards)-        ; ans  <- repVal patcore guardcore wherecore-        ; ans' <- wrapGenSyms ss ans-        ; return (loc, ans') }--rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))- =   do { v' <- lookupBinder v-        ; e2 <- repLE e-        ; x <- repNormal e2-        ; patcore <- repPvar v'-        ; empty_decls <- coreList decQTyConName []-        ; ans <- repVal patcore x empty_decls-        ; return (srcLocSpan (getSrcLoc v), ans) }--rep_bind (L _ (AbsBinds {}))  = panic "rep_bind: AbsBinds"-rep_bind (L _ dec@(PatSynBind {})) = notHandled "pattern synonyms" (ppr dec)--------------------------------------------------------------------------------- Since everything in a Bind is mutually recursive we need rename all--- all the variables simultaneously. For example:--- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to--- do { f'1 <- gensym "f"---    ; g'2 <- gensym "g"---    ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},---        do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}---      ]}--- This requires collecting the bindings (f'1 <- gensym "f"), and the--- environment ( f |-> f'1 ) from each binding, and then unioning them--- together. As we do this we collect GenSymBinds's which represent the renamed--- variables bound by the Bindings. In order not to lose track of these--- representations we build a shadow datatype MB with the same structure as--- MonoBinds, but which has slots for the representations----------------------------------------------------------------------------------- GHC allows a more general form of lambda abstraction than specified--- by Haskell 98. In particular it allows guarded lambda's like :--- (\  x | even x -> 0 | odd x -> 1) at the moment we can't represent this in--- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like--- (\ p1 .. pn -> exp) by causing an error.--repLambda :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ExpQ)-repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))- = do { let bndrs = collectPatsBinders ps ;-      ; ss  <- mkGenSyms bndrs-      ; lam <- addBinds ss (-                do { xs <- repLPs ps; body <- repLE e; repLam xs body })-      ; wrapGenSyms ss lam }--repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)-----------------------------------------------------------------------------------                      Patterns--- repP deals with patterns.  It assumes that we have already--- walked over the pattern(s) once to collect the binders, and--- have extended the environment.  So every pattern-bound--- variable should already appear in the environment.---- Process a list of patterns-repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])-repLPs ps = repList patQTyConName repLP ps--repLP :: LPat Name -> DsM (Core TH.PatQ)-repLP (L _ p) = repP p--repP :: Pat Name -> DsM (Core TH.PatQ)-repP (WildPat _)       = repPwild-repP (LitPat l)        = do { l2 <- repLiteral l; repPlit l2 }-repP (VarPat x)        = do { x' <- lookupBinder x; repPvar x' }-repP (LazyPat p)       = do { p1 <- repLP p; repPtilde p1 }-repP (BangPat p)       = do { p1 <- repLP p; repPbang p1 }-repP (AsPat x p)       = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }-repP (ParPat p)        = repLP p-repP (ListPat ps _ Nothing)    = do { qs <- repLPs ps; repPlist qs }-repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE e; repPview e' p}-repP (TuplePat ps boxed _)-  | isBoxed boxed       = do { qs <- repLPs ps; repPtup qs }-  | otherwise           = do { qs <- repLPs ps; repPunboxedTup qs }-repP (ConPatIn dc details)- = do { con_str <- lookupLOcc dc-      ; case details of-         PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }-         RecCon rec   -> do { fps <- repList fieldPatQTyConName rep_fld (rec_flds rec)-                            ; repPrec con_str fps }-         InfixCon p1 p2 -> do { p1' <- repLP p1;-                                p2' <- repLP p2;-                                repPinfix p1' con_str p2' }-   }- where-   rep_fld fld = do { MkC v <- lookupLOcc (hsRecFieldId fld)-                    ; MkC p <- repLP (hsRecFieldArg fld)-                    ; rep2 fieldPatName [v,p] }--repP (NPat l Nothing _)  = do { a <- repOverloadedLiteral l; repPlit a }-repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }-repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)-repP p@(SigPatIn {})  = notHandled "Type signatures in patterns" (ppr p)-        -- The problem is to do with scoped type variables.-        -- To implement them, we have to implement the scoping rules-        -- here in DsMeta, and I don't want to do that today!-        --       do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }-        --      repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)-        --      repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]--repP (SplicePat splice) = repSplice splice--repP other = notHandled "Exotic pattern" (ppr other)--------------------------------------------------------------- Declaration ordering helpers--sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]-sort_by_loc xs = sortBy comp xs-    where comp x y = compare (fst x) (fst y)--de_loc :: [(a, b)] -> [b]-de_loc = map snd---------------------------------------------------------------      The meta-environment---- A name/identifier association for fresh names of locally bound entities-type GenSymBind = (Name, Id)    -- Gensym the string and bind it to the Id-                                -- I.e.         (x, x_id) means-                                --      let x_id = gensym "x" in ...---- Generate a fresh name for a locally bound entity--mkGenSyms :: [Name] -> DsM [GenSymBind]--- We can use the existing name.  For example:---      [| \x_77 -> x_77 + x_77 |]--- desugars to---      do { x_77 <- genSym "x"; .... }--- We use the same x_77 in the desugared program, but with the type Bndr--- instead of Int------ We do make it an Internal name, though (hence localiseName)------ Nevertheless, it's monadic because we have to generate nameTy-mkGenSyms ns = do { var_ty <- lookupType nameTyConName-                  ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }---addBinds :: [GenSymBind] -> DsM a -> DsM a--- Add a list of fresh names for locally bound entities to the--- meta environment (which is part of the state carried around--- by the desugarer monad)-addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m--dupBinder :: (Name, Name) -> DsM (Name, DsMetaVal)-dupBinder (new, old)-  = do { mb_val <- dsLookupMetaEnv old-       ; case mb_val of-           Just val -> return (new, val)-           Nothing  -> pprPanic "dupBinder" (ppr old) }---- Look up a locally bound name----lookupLBinder :: Located Name -> DsM (Core TH.Name)-lookupLBinder (L _ n) = lookupBinder n--lookupBinder :: Name -> DsM (Core TH.Name)-lookupBinder = lookupOcc-  -- Binders are brought into scope before the pattern or what-not is-  -- desugared.  Moreover, in instance declaration the binder of a method-  -- will be the selector Id and hence a global; so we need the-  -- globalVar case of lookupOcc---- Look up a name that is either locally bound or a global name------  * If it is a global name, generate the "original name" representation (ie,---   the <module>:<name> form) for the associated entity----lookupLOcc :: Located Name -> DsM (Core TH.Name)--- Lookup an occurrence; it can't be a splice.--- Use the in-scope bindings if they exist-lookupLOcc (L _ n) = lookupOcc n--lookupOcc :: Name -> DsM (Core TH.Name)-lookupOcc n-  = do {  mb_val <- dsLookupMetaEnv n ;-          case mb_val of-                Nothing         -> globalVar n-                Just (Bound x)  -> return (coreVar x)-                Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)-    }--globalVar :: Name -> DsM (Core TH.Name)--- Not bound by the meta-env--- Could be top-level; or could be local---      f x = $(g [| x |])--- Here the x will be local-globalVar name-  | isExternalName name-  = do  { MkC mod <- coreStringLit name_mod-        ; MkC pkg <- coreStringLit name_pkg-        ; MkC occ <- occNameLit name-        ; rep2 mk_varg [pkg,mod,occ] }-  | otherwise-  = do  { MkC occ <- occNameLit name-        ; MkC uni <- coreIntLit (getKey (getUnique name))-        ; rep2 mkNameLName [occ,uni] }-  where-      mod = {- ASSERT( isExternalName name) -} nameModule name-      name_mod = moduleNameString (moduleName mod)-      name_pkg = packageIdString (modulePackageId mod)-      name_occ = nameOccName name-      mk_varg | OccName.isDataOcc name_occ = mkNameG_dName-              | OccName.isVarOcc  name_occ = mkNameG_vName-              | OccName.isTcOcc   name_occ = mkNameG_tcName-              | otherwise                  = pprPanic "DsMeta.globalVar" (ppr name)--lookupType :: Name      -- Name of type constructor (e.g. TH.ExpQ)-           -> DsM Type  -- The type-lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;-                          return (mkTyConApp tc []) }--wrapGenSyms :: [GenSymBind]-            -> Core (TH.Q a) -> DsM (Core (TH.Q a))--- wrapGenSyms [(nm1,id1), (nm2,id2)] y---      --> bindQ (gensym nm1) (\ id1 ->---          bindQ (gensym nm2 (\ id2 ->---          y))--wrapGenSyms binds body@(MkC b)-  = do  { var_ty <- lookupType nameTyConName-        ; go var_ty binds }-  where-    [elt_ty] = tcTyConAppArgs (exprType b)-        -- b :: Q a, so we can get the type 'a' by looking at the-        -- argument type. NB: this relies on Q being a data/newtype,-        -- not a type synonym--    go _ [] = return body-    go var_ty ((name,id) : binds)-      = do { MkC body'  <- go var_ty binds-           ; lit_str    <- occNameLit name-           ; gensym_app <- repGensym lit_str-           ; repBindQ var_ty elt_ty-                      gensym_app (MkC (Lam id body')) }--occNameLit :: Name -> DsM (Core String)-occNameLit n = coreStringLit (occNameString (nameOccName n))----- %*********************************************************************--- %*                                                                   *---              Constructing code--- %*                                                                   *--- %*********************************************************************---------------------------------------------------------------------------------- PHANTOM TYPES for consistency. In order to make sure we do this correct--- we invent a new datatype which uses phantom types.--newtype Core a = MkC CoreExpr-unC :: Core a -> CoreExpr-unC (MkC x) = x--rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)-rep2 n xs = do { id <- dsLookupGlobalId n-               ; return (MkC (foldl App (Var id) xs)) }--dataCon' :: Name -> [CoreExpr] -> DsM (Core a)-dataCon' n args = do { id <- dsLookupDataCon n-                     ; return $ MkC $ mkConApp id args }--dataCon :: Name -> DsM (Core a)-dataCon n = dataCon' n []---- Then we make "repConstructors" which use the phantom types for each of the--- smart constructors of the Meta.Meta datatypes.----- %*********************************************************************--- %*                                                                   *---              The 'smart constructors'--- %*                                                                   *--- %*********************************************************************----------------- Patterns ------------------repPlit   :: Core TH.Lit -> DsM (Core TH.PatQ)-repPlit (MkC l) = rep2 litPName [l]--repPvar :: Core TH.Name -> DsM (Core TH.PatQ)-repPvar (MkC s) = rep2 varPName [s]--repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)-repPtup (MkC ps) = rep2 tupPName [ps]--repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)-repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]--repPcon   :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)-repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]--repPrec   :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)-repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]--repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)-repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]--repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)-repPtilde (MkC p) = rep2 tildePName [p]--repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)-repPbang (MkC p) = rep2 bangPName [p]--repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)-repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]--repPwild  :: DsM (Core TH.PatQ)-repPwild = rep2 wildPName []--repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)-repPlist (MkC ps) = rep2 listPName [ps]--repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)-repPview (MkC e) (MkC p) = rep2 viewPName [e,p]----------------- Expressions ------------------repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)-repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str-                   | otherwise                  = repVar str--repVar :: Core TH.Name -> DsM (Core TH.ExpQ)-repVar (MkC s) = rep2 varEName [s]--repCon :: Core TH.Name -> DsM (Core TH.ExpQ)-repCon (MkC s) = rep2 conEName [s]--repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)-repLit (MkC c) = rep2 litEName [c]--repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repApp (MkC x) (MkC y) = rep2 appEName [x,y]--repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]--repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)-repLamCase (MkC ms) = rep2 lamCaseEName [ms]--repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)-repTup (MkC es) = rep2 tupEName [es]--repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)-repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]--repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]--repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ)-repMultiIf (MkC alts) = rep2 multiIfEName [alts]--repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]--repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)-repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]--repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)-repDoE (MkC ss) = rep2 doEName [ss]--repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)-repComp (MkC ss) = rep2 compEName [ss]--repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)-repListExp (MkC es) = rep2 listEName [es]--repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)-repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]--repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)-repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]--repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)-repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]--repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))-repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]--repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]--repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]--repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]-------------- Right hand sides (guarded expressions) -----repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)-repGuarded (MkC pairs) = rep2 guardedBName [pairs]--repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)-repNormal (MkC e) = rep2 normalBName [e]-------------- Guards -----repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))-repLNormalGE g e = do g' <- repLE g-                      e' <- repLE e-                      repNormalGE g' e'--repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))-repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]--repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))-repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]--------------- Stmts --------------------repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)-repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]--repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)-repLetSt (MkC ds) = rep2 letSName [ds]--repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)-repNoBindSt (MkC e) = rep2 noBindSName [e]--repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ)-repParSt (MkC sss) = rep2 parSName [sss]---------------- Range (Arithmetic sequences) ------------repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)-repFrom (MkC x) = rep2 fromEName [x]--repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]--repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]--repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]-------------- Match and Clause Tuples ------------repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)-repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]--repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)-repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]---------------- Dec ------------------------------repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)-repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]--repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)-repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]--repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]-        -> Maybe (Core [TH.TypeQ])-        -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)-repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs)-  = rep2 dataDName [cxt, nm, tvs, cons, derivs]-repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs)-  = rep2 dataInstDName [cxt, nm, tys, cons, derivs]--repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]-           -> Maybe (Core [TH.TypeQ])-           -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)-repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs)-  = rep2 newtypeDName [cxt, nm, tvs, con, derivs]-repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs)-  = rep2 newtypeInstDName [cxt, nm, tys, con, derivs]--repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]-         -> Core TH.TypeQ -> DsM (Core TH.DecQ)-repTySyn (MkC nm) (MkC tvs) (MkC rhs)-  = rep2 tySynDName [nm, tvs, rhs]--repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)-repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]--repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]-         -> Core [TH.FunDep] -> Core [TH.DecQ]-         -> DsM (Core TH.DecQ)-repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)-  = rep2 classDName [cxt, cls, tvs, fds, ds]--repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch-           -> Core TH.Phases -> DsM (Core TH.DecQ)-repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)-  = rep2 pragInlDName [nm, inline, rm, phases]--repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases-            -> DsM (Core TH.DecQ)-repPragSpec (MkC nm) (MkC ty) (MkC phases)-  = rep2 pragSpecDName [nm, ty, phases]--repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline-               -> Core TH.Phases -> DsM (Core TH.DecQ)-repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)-  = rep2 pragSpecInlDName [nm, ty, inline, phases]--repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ)-repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]--repPragRule :: Core String -> Core [TH.RuleBndrQ] -> Core TH.ExpQ-            -> Core TH.ExpQ -> Core TH.Phases -> DsM (Core TH.DecQ)-repPragRule (MkC nm) (MkC bndrs) (MkC lhs) (MkC rhs) (MkC phases)-  = rep2 pragRuleDName [nm, bndrs, lhs, rhs, phases]--repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]-                -> DsM (Core TH.DecQ)-repFamilyNoKind (MkC flav) (MkC nm) (MkC tvs)-    = rep2 familyNoKindDName [flav, nm, tvs]--repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]-              -> Core TH.Kind-              -> DsM (Core TH.DecQ)-repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)-    = rep2 familyKindDName [flav, nm, tvs, ki]--repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ)-repTySynInst (MkC nm) (MkC eqn)-    = rep2 tySynInstDName [nm, eqn]--repClosedFamilyNoKind :: Core TH.Name-                      -> Core [TH.TyVarBndr]-                      -> Core [TH.TySynEqnQ]-                      -> DsM (Core TH.DecQ)-repClosedFamilyNoKind (MkC nm) (MkC tvs) (MkC eqns)-    = rep2 closedTypeFamilyNoKindDName [nm, tvs, eqns]--repClosedFamilyKind :: Core TH.Name-                    -> Core [TH.TyVarBndr]-                    -> Core TH.Kind-                    -> Core [TH.TySynEqnQ]-                    -> DsM (Core TH.DecQ)-repClosedFamilyKind (MkC nm) (MkC tvs) (MkC ki) (MkC eqns)-    = rep2 closedTypeFamilyKindDName [nm, tvs, ki, eqns]--repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)-repTySynEqn (MkC lhs) (MkC rhs)-  = rep2 tySynEqnName [lhs, rhs]--repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ)-repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]--repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)-repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]--repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)-repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]--repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)-repCtxt (MkC tys) = rep2 cxtName [tys]--repClassP :: Core TH.Name -> Core [TH.TypeQ] -> DsM (Core TH.PredQ)-repClassP (MkC cla) (MkC tys) = rep2 classPName [cla, tys]--repEqualP :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.PredQ)-repEqualP (MkC ty1) (MkC ty2) = rep2 equalPName [ty1, ty2]--repConstr :: Core TH.Name -> HsConDeclDetails Name-          -> DsM (Core TH.ConQ)-repConstr con (PrefixCon ps)-    = do arg_tys  <- repList strictTypeQTyConName repBangTy ps-         rep2 normalCName [unC con, unC arg_tys]-repConstr con (RecCon ips)-    = do { arg_vtys <- repList varStrictTypeQTyConName rep_ip ips-         ; rep2 recCName [unC con, unC arg_vtys] }-    where-      rep_ip ip = do { MkC v  <- lookupLOcc (cd_fld_name ip)-                     ; MkC ty <- repBangTy  (cd_fld_type ip)-                     ; rep2 varStrictTypeName [v,ty] }--repConstr con (InfixCon st1 st2)-    = do arg1 <- repBangTy st1-         arg2 <- repBangTy st2-         rep2 infixCName [unC arg1, unC con, unC arg2]-------------- Types ---------------------repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ-           -> DsM (Core TH.TypeQ)-repTForall (MkC tvars) (MkC ctxt) (MkC ty)-    = rep2 forallTName [tvars, ctxt, ty]--repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)-repTvar (MkC s) = rep2 varTName [s]--repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)-repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]--repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)-repTapps f []     = return f-repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }--repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ)-repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]--repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ)-repTPromotedList []     = repPromotedNilTyCon-repTPromotedList (t:ts) = do  { tcon <- repPromotedConsTyCon-                              ; f <- repTapp tcon t-                              ; t' <- repTPromotedList ts-                              ; repTapp f t'-                              }--repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ)-repTLit (MkC lit) = rep2 litTName [lit]----------- Type constructors ----------------repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)-repNamedTyCon (MkC s) = rep2 conTName [s]--repTupleTyCon :: Int -> DsM (Core TH.TypeQ)--- Note: not Core Int; it's easier to be direct here-repTupleTyCon i = do dflags <- getDynFlags-                     rep2 tupleTName [mkIntExprInt dflags i]--repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)--- Note: not Core Int; it's easier to be direct here-repUnboxedTupleTyCon i = do dflags <- getDynFlags-                            rep2 unboxedTupleTName [mkIntExprInt dflags i]--repArrowTyCon :: DsM (Core TH.TypeQ)-repArrowTyCon = rep2 arrowTName []--repListTyCon :: DsM (Core TH.TypeQ)-repListTyCon = rep2 listTName []--repPromotedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)-repPromotedTyCon (MkC s) = rep2 promotedTName [s]--repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ)-repPromotedTupleTyCon i = do dflags <- getDynFlags-                             rep2 promotedTupleTName [mkIntExprInt dflags i]--repPromotedNilTyCon :: DsM (Core TH.TypeQ)-repPromotedNilTyCon = rep2 promotedNilTName []--repPromotedConsTyCon :: DsM (Core TH.TypeQ)-repPromotedConsTyCon = rep2 promotedConsTName []-------------- Kinds ---------------------repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr)-repPlainTV (MkC nm) = rep2 plainTVName [nm]--repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr)-repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]--repKVar :: Core TH.Name -> DsM (Core TH.Kind)-repKVar (MkC s) = rep2 varKName [s]--repKCon :: Core TH.Name -> DsM (Core TH.Kind)-repKCon (MkC s) = rep2 conKName [s]--repKTuple :: Int -> DsM (Core TH.Kind)-repKTuple i = do dflags <- getDynFlags-                 rep2 tupleKName [mkIntExprInt dflags i]--repKArrow :: DsM (Core TH.Kind)-repKArrow = rep2 arrowKName []--repKList :: DsM (Core TH.Kind)-repKList = rep2 listKName []--repKApp :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)-repKApp (MkC k1) (MkC k2) = rep2 appKName [k1, k2]--repKApps :: Core TH.Kind -> [Core TH.Kind] -> DsM (Core TH.Kind)-repKApps f []     = return f-repKApps f (k:ks) = do { f' <- repKApp f k; repKApps f' ks }--repKStar :: DsM (Core TH.Kind)-repKStar = rep2 starKName []--repKConstraint :: DsM (Core TH.Kind)-repKConstraint = rep2 constraintKName []---------------------------------------------------------------              Literals--repLiteral :: HsLit -> DsM (Core TH.Lit)-repLiteral lit-  = do lit' <- case lit of-                   HsIntPrim i    -> mk_integer i-                   HsWordPrim w   -> mk_integer w-                   HsInt i        -> mk_integer i-                   HsFloatPrim r  -> mk_rational r-                   HsDoublePrim r -> mk_rational r-                   _ -> return lit-       lit_expr <- dsLit lit'-       case mb_lit_name of-          Just lit_name -> rep2 lit_name [lit_expr]-          Nothing -> notHandled "Exotic literal" (ppr lit)-  where-    mb_lit_name = case lit of-                 HsInteger _ _  -> Just integerLName-                 HsInt     _    -> Just integerLName-                 HsIntPrim _    -> Just intPrimLName-                 HsWordPrim _   -> Just wordPrimLName-                 HsFloatPrim _  -> Just floatPrimLName-                 HsDoublePrim _ -> Just doublePrimLName-                 HsChar _       -> Just charLName-                 HsString _     -> Just stringLName-                 HsRat _ _      -> Just rationalLName-                 _              -> Nothing--mk_integer :: Integer -> DsM HsLit-mk_integer  i = do integer_ty <- lookupType integerTyConName-                   return $ HsInteger i integer_ty-mk_rational :: FractionalLit -> DsM HsLit-mk_rational r = do rat_ty <- lookupType rationalTyConName-                   return $ HsRat r rat_ty-mk_string :: FastString -> DsM HsLit-mk_string s = return $ HsString s--repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)-repOverloadedLiteral (OverLit { ol_val = val})-  = do { lit <- mk_lit val; repLiteral lit }-        -- The type Rational will be in the environment, because-        -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,-        -- and rationalL is sucked in when any TH stuff is used--mk_lit :: OverLitVal -> DsM HsLit-mk_lit (HsIntegral i)   = mk_integer  i-mk_lit (HsFractional f) = mk_rational f-mk_lit (HsIsString s)   = mk_string   s----------------- Miscellaneous ---------------------repGensym :: Core String -> DsM (Core (TH.Q TH.Name))-repGensym (MkC lit_str) = rep2 newNameName [lit_str]--repBindQ :: Type -> Type        -- a and b-         -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))-repBindQ ty_a ty_b (MkC x) (MkC y)-  = rep2 bindQName [Type ty_a, Type ty_b, x, y]--repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))-repSequenceQ ty_a (MkC list)-  = rep2 sequenceQName [Type ty_a, list]-------------- Lists and Tuples ---------------------- turn a list of patterns into a single pattern matching a list--repList :: Name -> (a  -> DsM (Core b))-                -> [a] -> DsM (Core [b])-repList tc_name f args-  = do { args1 <- mapM f args-       ; coreList tc_name args1 }--coreList :: Name        -- Of the TyCon of the element type-         -> [Core a] -> DsM (Core [a])-coreList tc_name es-  = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }--coreList' :: Type       -- The element type-          -> [Core a] -> Core [a]-coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))--nonEmptyCoreList :: [Core a] -> Core [a]-  -- The list must be non-empty so we can get the element type-  -- Otherwise use coreList-nonEmptyCoreList []           = panic "coreList: empty argument"-nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))--coreStringLit :: String -> DsM (Core String)-coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }-------------- Literals & Variables ---------------------coreIntLit :: Int -> DsM (Core Int)-coreIntLit i = do dflags <- getDynFlags-                  return (MkC (mkIntExprInt dflags i))--coreVar :: Id -> Core TH.Name   -- The Id has type Name-coreVar id = MkC (Var id)------------------- Failure ------------------------notHandled :: String -> SDoc -> DsM a-notHandled what doc = failWithDs msg-  where-    msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell"))-             2 doc----- %************************************************************************--- %*                                                                   *---              The known-key names for Template Haskell--- %*                                                                   *--- %************************************************************************---- To add a name, do three things------  1) Allocate a key---  2) Make a "Name"---  3) Add the name to knownKeyNames--templateHaskellNames :: [Name]--- The names that are implicitly mentioned by ``bracket''--- Should stay in sync with the import list of DsMeta--templateHaskellNames = [-    returnQName, bindQName, sequenceQName, newNameName, liftName,-    mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,-    liftStringName,-    unTypeName,-    unTypeQName,-    unsafeTExpCoerceName,--    -- Lit-    charLName, stringLName, integerLName, intPrimLName, wordPrimLName,-    floatPrimLName, doublePrimLName, rationalLName,-    -- Pat-    litPName, varPName, tupPName, unboxedTupPName,-    conPName, tildePName, bangPName, infixPName,-    asPName, wildPName, recPName, listPName, sigPName, viewPName,-    -- FieldPat-    fieldPatName,-    -- Match-    matchName,-    -- Clause-    clauseName,-    -- Exp-    varEName, conEName, litEName, appEName, infixEName,-    infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,-    tupEName, unboxedTupEName,-    condEName, multiIfEName, letEName, caseEName, doEName, compEName,-    fromEName, fromThenEName, fromToEName, fromThenToEName,-    listEName, sigEName, recConEName, recUpdEName,-    -- FieldExp-    fieldExpName,-    -- Body-    guardedBName, normalBName,-    -- Guard-    normalGEName, patGEName,-    -- Stmt-    bindSName, letSName, noBindSName, parSName,-    -- Dec-    funDName, valDName, dataDName, newtypeDName, tySynDName,-    classDName, instanceDName, sigDName, forImpDName,-    pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,-    pragRuleDName,-    familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,-    tySynInstDName, closedTypeFamilyKindDName, closedTypeFamilyNoKindDName,-    infixLDName, infixRDName, infixNDName,-    roleAnnotDName,-    -- Cxt-    cxtName,-    -- Pred-    classPName, equalPName,-    -- Strict-    isStrictName, notStrictName, unpackedName,-    -- Con-    normalCName, recCName, infixCName, forallCName,-    -- StrictType-    strictTypeName,-    -- VarStrictType-    varStrictTypeName,-    -- Type-    forallTName, varTName, conTName, appTName,-    tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName, litTName,-    promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,-    -- TyLit-    numTyLitName, strTyLitName,-    -- TyVarBndr-    plainTVName, kindedTVName,-    -- Role-    nominalRName, representationalRName, phantomRName, inferRName,-    -- Kind-    varKName, conKName, tupleKName, arrowKName, listKName, appKName,-    starKName, constraintKName,-    -- Callconv-    cCallName, stdCallName,-    -- Safety-    unsafeName,-    safeName,-    interruptibleName,-    -- Inline-    noInlineDataConName, inlineDataConName, inlinableDataConName,-    -- RuleMatch-    conLikeDataConName, funLikeDataConName,-    -- Phases-    allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName,-    -- TExp-    tExpDataConName,-    -- RuleBndr-    ruleVarName, typedRuleVarName,-    -- FunDep-    funDepName,-    -- FamFlavour-    typeFamName, dataFamName,-    -- TySynEqn-    tySynEqnName,--    -- And the tycons-    qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,-    clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,-    stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName,-    varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,-    typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,-    patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,-    predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName,-    roleTyConName, tExpTyConName,--    -- Quasiquoting-    quoteDecName, quoteTypeName, quoteExpName, quotePatName]--thSyn, thLib, qqLib :: Module-thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")-thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib")-qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")--mkTHModule :: FastString -> Module-mkTHModule m = mkModule thPackageId (mkModuleNameFS m)--libFun, libTc, thFun, thTc, thCon, qqFun :: FastString -> Unique -> Name-libFun = mk_known_key_name OccName.varName  thLib-libTc  = mk_known_key_name OccName.tcName   thLib-thFun  = mk_known_key_name OccName.varName  thSyn-thTc   = mk_known_key_name OccName.tcName   thSyn-thCon  = mk_known_key_name OccName.dataName thSyn-qqFun  = mk_known_key_name OccName.varName  qqLib---------------------- TH.Syntax ------------------------qTyConName, nameTyConName, fieldExpTyConName, patTyConName,-    fieldPatTyConName, expTyConName, decTyConName, typeTyConName,-    tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,-    predTyConName, tExpTyConName :: Name-qTyConName        = thTc (fsLit "Q")            qTyConKey-nameTyConName     = thTc (fsLit "Name")         nameTyConKey-fieldExpTyConName = thTc (fsLit "FieldExp")     fieldExpTyConKey-patTyConName      = thTc (fsLit "Pat")          patTyConKey-fieldPatTyConName = thTc (fsLit "FieldPat")     fieldPatTyConKey-expTyConName      = thTc (fsLit "Exp")          expTyConKey-decTyConName      = thTc (fsLit "Dec")          decTyConKey-typeTyConName     = thTc (fsLit "Type")         typeTyConKey-tyVarBndrTyConName= thTc (fsLit "TyVarBndr")    tyVarBndrTyConKey-matchTyConName    = thTc (fsLit "Match")        matchTyConKey-clauseTyConName   = thTc (fsLit "Clause")       clauseTyConKey-funDepTyConName   = thTc (fsLit "FunDep")       funDepTyConKey-predTyConName     = thTc (fsLit "Pred")         predTyConKey-tExpTyConName     = thTc (fsLit "TExp")         tExpTyConKey--returnQName, bindQName, sequenceQName, newNameName, liftName,-    mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,-    mkNameLName, liftStringName, unTypeName, unTypeQName,-    unsafeTExpCoerceName :: Name-returnQName    = thFun (fsLit "returnQ")   returnQIdKey-bindQName      = thFun (fsLit "bindQ")     bindQIdKey-sequenceQName  = thFun (fsLit "sequenceQ") sequenceQIdKey-newNameName    = thFun (fsLit "newName")   newNameIdKey-liftName       = thFun (fsLit "lift")      liftIdKey-liftStringName = thFun (fsLit "liftString")  liftStringIdKey-mkNameName     = thFun (fsLit "mkName")     mkNameIdKey-mkNameG_vName  = thFun (fsLit "mkNameG_v")  mkNameG_vIdKey-mkNameG_dName  = thFun (fsLit "mkNameG_d")  mkNameG_dIdKey-mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey-mkNameLName    = thFun (fsLit "mkNameL")    mkNameLIdKey-unTypeName     = thFun (fsLit "unType")     unTypeIdKey-unTypeQName    = thFun (fsLit "unTypeQ")    unTypeQIdKey-unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey----------------------- TH.Lib -------------------------- data Lit = ...-charLName, stringLName, integerLName, intPrimLName, wordPrimLName,-    floatPrimLName, doublePrimLName, rationalLName :: Name-charLName       = libFun (fsLit "charL")       charLIdKey-stringLName     = libFun (fsLit "stringL")     stringLIdKey-integerLName    = libFun (fsLit "integerL")    integerLIdKey-intPrimLName    = libFun (fsLit "intPrimL")    intPrimLIdKey-wordPrimLName   = libFun (fsLit "wordPrimL")   wordPrimLIdKey-floatPrimLName  = libFun (fsLit "floatPrimL")  floatPrimLIdKey-doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey-rationalLName   = libFun (fsLit "rationalL")     rationalLIdKey---- data Pat = ...-litPName, varPName, tupPName, unboxedTupPName, conPName, infixPName, tildePName, bangPName,-    asPName, wildPName, recPName, listPName, sigPName, viewPName :: Name-litPName   = libFun (fsLit "litP")   litPIdKey-varPName   = libFun (fsLit "varP")   varPIdKey-tupPName   = libFun (fsLit "tupP")   tupPIdKey-unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey-conPName   = libFun (fsLit "conP")   conPIdKey-infixPName = libFun (fsLit "infixP") infixPIdKey-tildePName = libFun (fsLit "tildeP") tildePIdKey-bangPName  = libFun (fsLit "bangP")  bangPIdKey-asPName    = libFun (fsLit "asP")    asPIdKey-wildPName  = libFun (fsLit "wildP")  wildPIdKey-recPName   = libFun (fsLit "recP")   recPIdKey-listPName  = libFun (fsLit "listP")  listPIdKey-sigPName   = libFun (fsLit "sigP")   sigPIdKey-viewPName  = libFun (fsLit "viewP")  viewPIdKey---- type FieldPat = ...-fieldPatName :: Name-fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey---- data Match = ...-matchName :: Name-matchName = libFun (fsLit "match") matchIdKey---- data Clause = ...-clauseName :: Name-clauseName = libFun (fsLit "clause") clauseIdKey---- data Exp = ...-varEName, conEName, litEName, appEName, infixEName, infixAppName,-    sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,-    unboxedTupEName, condEName, multiIfEName, letEName, caseEName,-    doEName, compEName :: Name-varEName        = libFun (fsLit "varE")        varEIdKey-conEName        = libFun (fsLit "conE")        conEIdKey-litEName        = libFun (fsLit "litE")        litEIdKey-appEName        = libFun (fsLit "appE")        appEIdKey-infixEName      = libFun (fsLit "infixE")      infixEIdKey-infixAppName    = libFun (fsLit "infixApp")    infixAppIdKey-sectionLName    = libFun (fsLit "sectionL")    sectionLIdKey-sectionRName    = libFun (fsLit "sectionR")    sectionRIdKey-lamEName        = libFun (fsLit "lamE")        lamEIdKey-lamCaseEName    = libFun (fsLit "lamCaseE")    lamCaseEIdKey-tupEName        = libFun (fsLit "tupE")        tupEIdKey-unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey-condEName       = libFun (fsLit "condE")       condEIdKey-multiIfEName    = libFun (fsLit "multiIfE")    multiIfEIdKey-letEName        = libFun (fsLit "letE")        letEIdKey-caseEName       = libFun (fsLit "caseE")       caseEIdKey-doEName         = libFun (fsLit "doE")         doEIdKey-compEName       = libFun (fsLit "compE")       compEIdKey--- ArithSeq skips a level-fromEName, fromThenEName, fromToEName, fromThenToEName :: Name-fromEName       = libFun (fsLit "fromE")       fromEIdKey-fromThenEName   = libFun (fsLit "fromThenE")   fromThenEIdKey-fromToEName     = libFun (fsLit "fromToE")     fromToEIdKey-fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey--- end ArithSeq-listEName, sigEName, recConEName, recUpdEName :: Name-listEName       = libFun (fsLit "listE")       listEIdKey-sigEName        = libFun (fsLit "sigE")        sigEIdKey-recConEName     = libFun (fsLit "recConE")     recConEIdKey-recUpdEName     = libFun (fsLit "recUpdE")     recUpdEIdKey---- type FieldExp = ...-fieldExpName :: Name-fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey---- data Body = ...-guardedBName, normalBName :: Name-guardedBName = libFun (fsLit "guardedB") guardedBIdKey-normalBName  = libFun (fsLit "normalB")  normalBIdKey---- data Guard = ...-normalGEName, patGEName :: Name-normalGEName = libFun (fsLit "normalGE") normalGEIdKey-patGEName    = libFun (fsLit "patGE")    patGEIdKey---- data Stmt = ...-bindSName, letSName, noBindSName, parSName :: Name-bindSName   = libFun (fsLit "bindS")   bindSIdKey-letSName    = libFun (fsLit "letS")    letSIdKey-noBindSName = libFun (fsLit "noBindS") noBindSIdKey-parSName    = libFun (fsLit "parS")    parSIdKey---- data Dec = ...-funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,-    instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,-    pragSpecInlDName, pragSpecInstDName, pragRuleDName, familyNoKindDName,-    familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName,-    closedTypeFamilyKindDName, closedTypeFamilyNoKindDName,-    infixLDName, infixRDName, infixNDName, roleAnnotDName :: Name-funDName          = libFun (fsLit "funD")          funDIdKey-valDName          = libFun (fsLit "valD")          valDIdKey-dataDName         = libFun (fsLit "dataD")         dataDIdKey-newtypeDName      = libFun (fsLit "newtypeD")      newtypeDIdKey-tySynDName        = libFun (fsLit "tySynD")        tySynDIdKey-classDName        = libFun (fsLit "classD")        classDIdKey-instanceDName     = libFun (fsLit "instanceD")     instanceDIdKey-sigDName          = libFun (fsLit "sigD")          sigDIdKey-forImpDName       = libFun (fsLit "forImpD")       forImpDIdKey-pragInlDName      = libFun (fsLit "pragInlD")      pragInlDIdKey-pragSpecDName     = libFun (fsLit "pragSpecD")     pragSpecDIdKey-pragSpecInlDName  = libFun (fsLit "pragSpecInlD")  pragSpecInlDIdKey-pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey-pragRuleDName     = libFun (fsLit "pragRuleD")     pragRuleDIdKey-familyNoKindDName = libFun (fsLit "familyNoKindD") familyNoKindDIdKey-familyKindDName   = libFun (fsLit "familyKindD")   familyKindDIdKey-dataInstDName     = libFun (fsLit "dataInstD")     dataInstDIdKey-newtypeInstDName  = libFun (fsLit "newtypeInstD")  newtypeInstDIdKey-tySynInstDName    = libFun (fsLit "tySynInstD")    tySynInstDIdKey-closedTypeFamilyKindDName-                  = libFun (fsLit "closedTypeFamilyKindD") closedTypeFamilyKindDIdKey-closedTypeFamilyNoKindDName-                  = libFun (fsLit "closedTypeFamilyNoKindD") closedTypeFamilyNoKindDIdKey-infixLDName       = libFun (fsLit "infixLD")       infixLDIdKey-infixRDName       = libFun (fsLit "infixRD")       infixRDIdKey-infixNDName       = libFun (fsLit "infixND")       infixNDIdKey-roleAnnotDName    = libFun (fsLit "roleAnnotD")    roleAnnotDIdKey---- type Ctxt = ...-cxtName :: Name-cxtName = libFun (fsLit "cxt") cxtIdKey---- data Pred = ...-classPName, equalPName :: Name-classPName = libFun (fsLit "classP") classPIdKey-equalPName = libFun (fsLit "equalP") equalPIdKey---- data Strict = ...-isStrictName, notStrictName, unpackedName :: Name-isStrictName      = libFun  (fsLit "isStrict")      isStrictKey-notStrictName     = libFun  (fsLit "notStrict")     notStrictKey-unpackedName      = libFun  (fsLit "unpacked")      unpackedKey---- data Con = ...-normalCName, recCName, infixCName, forallCName :: Name-normalCName = libFun (fsLit "normalC") normalCIdKey-recCName    = libFun (fsLit "recC")    recCIdKey-infixCName  = libFun (fsLit "infixC")  infixCIdKey-forallCName  = libFun (fsLit "forallC")  forallCIdKey---- type StrictType = ...-strictTypeName :: Name-strictTypeName    = libFun  (fsLit "strictType")    strictTKey---- type VarStrictType = ...-varStrictTypeName :: Name-varStrictTypeName = libFun  (fsLit "varStrictType") varStrictTKey---- data Type = ...-forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName,-    listTName, appTName, sigTName, litTName,-    promotedTName, promotedTupleTName,-    promotedNilTName, promotedConsTName :: Name-forallTName         = libFun (fsLit "forallT")        forallTIdKey-varTName            = libFun (fsLit "varT")           varTIdKey-conTName            = libFun (fsLit "conT")           conTIdKey-tupleTName          = libFun (fsLit "tupleT")         tupleTIdKey-unboxedTupleTName   = libFun (fsLit "unboxedTupleT")  unboxedTupleTIdKey-arrowTName          = libFun (fsLit "arrowT")         arrowTIdKey-listTName           = libFun (fsLit "listT")          listTIdKey-appTName            = libFun (fsLit "appT")           appTIdKey-sigTName            = libFun (fsLit "sigT")           sigTIdKey-litTName            = libFun (fsLit "litT")           litTIdKey-promotedTName       = libFun (fsLit "promotedT")      promotedTIdKey-promotedTupleTName  = libFun (fsLit "promotedTupleT") promotedTupleTIdKey-promotedNilTName    = libFun (fsLit "promotedNilT")   promotedNilTIdKey-promotedConsTName   = libFun (fsLit "promotedConsT")  promotedConsTIdKey---- data TyLit = ...-numTyLitName, strTyLitName :: Name-numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey-strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey---- data TyVarBndr = ...-plainTVName, kindedTVName :: Name-plainTVName       = libFun (fsLit "plainTV")       plainTVIdKey-kindedTVName      = libFun (fsLit "kindedTV")      kindedTVIdKey---- data Role = ...-nominalRName, representationalRName, phantomRName, inferRName :: Name-nominalRName          = libFun (fsLit "nominalR")          nominalRIdKey-representationalRName = libFun (fsLit "representationalR") representationalRIdKey-phantomRName          = libFun (fsLit "phantomR")          phantomRIdKey-inferRName            = libFun (fsLit "inferR")            inferRIdKey---- data Kind = ...-varKName, conKName, tupleKName, arrowKName, listKName, appKName,-  starKName, constraintKName :: Name-varKName        = libFun (fsLit "varK")         varKIdKey-conKName        = libFun (fsLit "conK")         conKIdKey-tupleKName      = libFun (fsLit "tupleK")       tupleKIdKey-arrowKName      = libFun (fsLit "arrowK")       arrowKIdKey-listKName       = libFun (fsLit "listK")        listKIdKey-appKName        = libFun (fsLit "appK")         appKIdKey-starKName       = libFun (fsLit "starK")        starKIdKey-constraintKName = libFun (fsLit "constraintK")  constraintKIdKey---- data Callconv = ...-cCallName, stdCallName :: Name-cCallName = libFun (fsLit "cCall") cCallIdKey-stdCallName = libFun (fsLit "stdCall") stdCallIdKey---- data Safety = ...-unsafeName, safeName, interruptibleName :: Name-unsafeName     = libFun (fsLit "unsafe") unsafeIdKey-safeName       = libFun (fsLit "safe") safeIdKey-interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey---- data Inline = ...-noInlineDataConName, inlineDataConName, inlinableDataConName :: Name-noInlineDataConName  = thCon (fsLit "NoInline")  noInlineDataConKey-inlineDataConName    = thCon (fsLit "Inline")    inlineDataConKey-inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey---- data RuleMatch = ...-conLikeDataConName, funLikeDataConName :: Name-conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey-funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey---- data Phases = ...-allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name-allPhasesDataConName   = thCon (fsLit "AllPhases")   allPhasesDataConKey-fromPhaseDataConName   = thCon (fsLit "FromPhase")   fromPhaseDataConKey-beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey---- newtype TExp a = ...-tExpDataConName :: Name-tExpDataConName = thCon (fsLit "TExp") tExpDataConKey---- data RuleBndr = ...-ruleVarName, typedRuleVarName :: Name-ruleVarName      = libFun (fsLit ("ruleVar"))      ruleVarIdKey-typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey---- data FunDep = ...-funDepName :: Name-funDepName     = libFun (fsLit "funDep") funDepIdKey---- data FamFlavour = ...-typeFamName, dataFamName :: Name-typeFamName = libFun (fsLit "typeFam") typeFamIdKey-dataFamName = libFun (fsLit "dataFam") dataFamIdKey---- data TySynEqn = ...-tySynEqnName :: Name-tySynEqnName = libFun (fsLit "tySynEqn") tySynEqnIdKey--matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,-    decQTyConName, conQTyConName, strictTypeQTyConName,-    varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,-    patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName,-    ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName :: Name-matchQTyConName         = libTc (fsLit "MatchQ")         matchQTyConKey-clauseQTyConName        = libTc (fsLit "ClauseQ")        clauseQTyConKey-expQTyConName           = libTc (fsLit "ExpQ")           expQTyConKey-stmtQTyConName          = libTc (fsLit "StmtQ")          stmtQTyConKey-decQTyConName           = libTc (fsLit "DecQ")           decQTyConKey-decsQTyConName          = libTc (fsLit "DecsQ")          decsQTyConKey  -- Q [Dec]-conQTyConName           = libTc (fsLit "ConQ")           conQTyConKey-strictTypeQTyConName    = libTc (fsLit "StrictTypeQ")    strictTypeQTyConKey-varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey-typeQTyConName          = libTc (fsLit "TypeQ")          typeQTyConKey-fieldExpQTyConName      = libTc (fsLit "FieldExpQ")      fieldExpQTyConKey-patQTyConName           = libTc (fsLit "PatQ")           patQTyConKey-fieldPatQTyConName      = libTc (fsLit "FieldPatQ")      fieldPatQTyConKey-predQTyConName          = libTc (fsLit "PredQ")          predQTyConKey-ruleBndrQTyConName      = libTc (fsLit "RuleBndrQ")      ruleBndrQTyConKey-tySynEqnQTyConName      = libTc (fsLit "TySynEqnQ")      tySynEqnQTyConKey-roleTyConName           = libTc (fsLit "Role")           roleTyConKey---- quasiquoting-quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name-quoteExpName        = qqFun (fsLit "quoteExp")  quoteExpKey-quotePatName        = qqFun (fsLit "quotePat")  quotePatKey-quoteDecName        = qqFun (fsLit "quoteDec")  quoteDecKey-quoteTypeName       = qqFun (fsLit "quoteType") quoteTypeKey---- TyConUniques available: 200-299--- Check in PrelNames if you want to change this--expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,-    decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,-    stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey,-    decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,-    fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,-    fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,-    predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey,-    roleTyConKey, tExpTyConKey :: Unique-expTyConKey             = mkPreludeTyConUnique 200-matchTyConKey           = mkPreludeTyConUnique 201-clauseTyConKey          = mkPreludeTyConUnique 202-qTyConKey               = mkPreludeTyConUnique 203-expQTyConKey            = mkPreludeTyConUnique 204-decQTyConKey            = mkPreludeTyConUnique 205-patTyConKey             = mkPreludeTyConUnique 206-matchQTyConKey          = mkPreludeTyConUnique 207-clauseQTyConKey         = mkPreludeTyConUnique 208-stmtQTyConKey           = mkPreludeTyConUnique 209-conQTyConKey            = mkPreludeTyConUnique 210-typeQTyConKey           = mkPreludeTyConUnique 211-typeTyConKey            = mkPreludeTyConUnique 212-decTyConKey             = mkPreludeTyConUnique 213-varStrictTypeQTyConKey  = mkPreludeTyConUnique 214-strictTypeQTyConKey     = mkPreludeTyConUnique 215-fieldExpTyConKey        = mkPreludeTyConUnique 216-fieldPatTyConKey        = mkPreludeTyConUnique 217-nameTyConKey            = mkPreludeTyConUnique 218-patQTyConKey            = mkPreludeTyConUnique 219-fieldPatQTyConKey       = mkPreludeTyConUnique 220-fieldExpQTyConKey       = mkPreludeTyConUnique 221-funDepTyConKey          = mkPreludeTyConUnique 222-predTyConKey            = mkPreludeTyConUnique 223-predQTyConKey           = mkPreludeTyConUnique 224-tyVarBndrTyConKey       = mkPreludeTyConUnique 225-decsQTyConKey           = mkPreludeTyConUnique 226-ruleBndrQTyConKey       = mkPreludeTyConUnique 227-tySynEqnQTyConKey       = mkPreludeTyConUnique 228-roleTyConKey            = mkPreludeTyConUnique 229-tExpTyConKey            = mkPreludeTyConUnique 230---- IdUniques available: 200-499--- If you want to change this, make sure you check in PrelNames--returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,-    mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,-    mkNameLIdKey, unTypeIdKey, unTypeQIdKey, unsafeTExpCoerceIdKey :: Unique-returnQIdKey        = mkPreludeMiscIdUnique 200-bindQIdKey          = mkPreludeMiscIdUnique 201-sequenceQIdKey      = mkPreludeMiscIdUnique 202-liftIdKey           = mkPreludeMiscIdUnique 203-newNameIdKey         = mkPreludeMiscIdUnique 204-mkNameIdKey          = mkPreludeMiscIdUnique 205-mkNameG_vIdKey       = mkPreludeMiscIdUnique 206-mkNameG_dIdKey       = mkPreludeMiscIdUnique 207-mkNameG_tcIdKey      = mkPreludeMiscIdUnique 208-mkNameLIdKey         = mkPreludeMiscIdUnique 209-unTypeIdKey          = mkPreludeMiscIdUnique 210-unTypeQIdKey         = mkPreludeMiscIdUnique 211-unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 212----- data Lit = ...-charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey,-    floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey :: Unique-charLIdKey        = mkPreludeMiscIdUnique 220-stringLIdKey      = mkPreludeMiscIdUnique 221-integerLIdKey     = mkPreludeMiscIdUnique 222-intPrimLIdKey     = mkPreludeMiscIdUnique 223-wordPrimLIdKey    = mkPreludeMiscIdUnique 224-floatPrimLIdKey   = mkPreludeMiscIdUnique 225-doublePrimLIdKey  = mkPreludeMiscIdUnique 226-rationalLIdKey    = mkPreludeMiscIdUnique 227--liftStringIdKey :: Unique-liftStringIdKey     = mkPreludeMiscIdUnique 228---- data Pat = ...-litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey,-    asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey, viewPIdKey :: Unique-litPIdKey         = mkPreludeMiscIdUnique 240-varPIdKey         = mkPreludeMiscIdUnique 241-tupPIdKey         = mkPreludeMiscIdUnique 242-unboxedTupPIdKey  = mkPreludeMiscIdUnique 243-conPIdKey         = mkPreludeMiscIdUnique 244-infixPIdKey       = mkPreludeMiscIdUnique 245-tildePIdKey       = mkPreludeMiscIdUnique 246-bangPIdKey        = mkPreludeMiscIdUnique 247-asPIdKey          = mkPreludeMiscIdUnique 248-wildPIdKey        = mkPreludeMiscIdUnique 249-recPIdKey         = mkPreludeMiscIdUnique 250-listPIdKey        = mkPreludeMiscIdUnique 251-sigPIdKey         = mkPreludeMiscIdUnique 252-viewPIdKey        = mkPreludeMiscIdUnique 253---- type FieldPat = ...-fieldPatIdKey :: Unique-fieldPatIdKey       = mkPreludeMiscIdUnique 260---- data Match = ...-matchIdKey :: Unique-matchIdKey          = mkPreludeMiscIdUnique 261---- data Clause = ...-clauseIdKey :: Unique-clauseIdKey         = mkPreludeMiscIdUnique 262----- data Exp = ...-varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,-    sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey, tupEIdKey,-    unboxedTupEIdKey, condEIdKey, multiIfEIdKey,-    letEIdKey, caseEIdKey, doEIdKey, compEIdKey,-    fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,-    listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique-varEIdKey         = mkPreludeMiscIdUnique 270-conEIdKey         = mkPreludeMiscIdUnique 271-litEIdKey         = mkPreludeMiscIdUnique 272-appEIdKey         = mkPreludeMiscIdUnique 273-infixEIdKey       = mkPreludeMiscIdUnique 274-infixAppIdKey     = mkPreludeMiscIdUnique 275-sectionLIdKey     = mkPreludeMiscIdUnique 276-sectionRIdKey     = mkPreludeMiscIdUnique 277-lamEIdKey         = mkPreludeMiscIdUnique 278-lamCaseEIdKey     = mkPreludeMiscIdUnique 279-tupEIdKey         = mkPreludeMiscIdUnique 280-unboxedTupEIdKey  = mkPreludeMiscIdUnique 281-condEIdKey        = mkPreludeMiscIdUnique 282-multiIfEIdKey     = mkPreludeMiscIdUnique 283-letEIdKey         = mkPreludeMiscIdUnique 284-caseEIdKey        = mkPreludeMiscIdUnique 285-doEIdKey          = mkPreludeMiscIdUnique 286-compEIdKey        = mkPreludeMiscIdUnique 287-fromEIdKey        = mkPreludeMiscIdUnique 288-fromThenEIdKey    = mkPreludeMiscIdUnique 289-fromToEIdKey      = mkPreludeMiscIdUnique 290-fromThenToEIdKey  = mkPreludeMiscIdUnique 291-listEIdKey        = mkPreludeMiscIdUnique 292-sigEIdKey         = mkPreludeMiscIdUnique 293-recConEIdKey      = mkPreludeMiscIdUnique 294-recUpdEIdKey      = mkPreludeMiscIdUnique 295---- type FieldExp = ...-fieldExpIdKey :: Unique-fieldExpIdKey       = mkPreludeMiscIdUnique 310---- data Body = ...-guardedBIdKey, normalBIdKey :: Unique-guardedBIdKey     = mkPreludeMiscIdUnique 311-normalBIdKey      = mkPreludeMiscIdUnique 312---- data Guard = ...-normalGEIdKey, patGEIdKey :: Unique-normalGEIdKey     = mkPreludeMiscIdUnique 313-patGEIdKey        = mkPreludeMiscIdUnique 314---- data Stmt = ...-bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique-bindSIdKey       = mkPreludeMiscIdUnique 320-letSIdKey        = mkPreludeMiscIdUnique 321-noBindSIdKey     = mkPreludeMiscIdUnique 322-parSIdKey        = mkPreludeMiscIdUnique 323---- data Dec = ...-funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,-    classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,-    pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey,-    familyNoKindDIdKey, familyKindDIdKey,-    dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey,-    closedTypeFamilyKindDIdKey, closedTypeFamilyNoKindDIdKey,-    infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey :: Unique-funDIdKey                    = mkPreludeMiscIdUnique 330-valDIdKey                    = mkPreludeMiscIdUnique 331-dataDIdKey                   = mkPreludeMiscIdUnique 332-newtypeDIdKey                = mkPreludeMiscIdUnique 333-tySynDIdKey                  = mkPreludeMiscIdUnique 334-classDIdKey                  = mkPreludeMiscIdUnique 335-instanceDIdKey               = mkPreludeMiscIdUnique 336-sigDIdKey                    = mkPreludeMiscIdUnique 337-forImpDIdKey                 = mkPreludeMiscIdUnique 338-pragInlDIdKey                = mkPreludeMiscIdUnique 339-pragSpecDIdKey               = mkPreludeMiscIdUnique 340-pragSpecInlDIdKey            = mkPreludeMiscIdUnique 341-pragSpecInstDIdKey           = mkPreludeMiscIdUnique 417-pragRuleDIdKey               = mkPreludeMiscIdUnique 418-familyNoKindDIdKey           = mkPreludeMiscIdUnique 342-familyKindDIdKey             = mkPreludeMiscIdUnique 343-dataInstDIdKey               = mkPreludeMiscIdUnique 344-newtypeInstDIdKey            = mkPreludeMiscIdUnique 345-tySynInstDIdKey              = mkPreludeMiscIdUnique 346-closedTypeFamilyKindDIdKey   = mkPreludeMiscIdUnique 347-closedTypeFamilyNoKindDIdKey = mkPreludeMiscIdUnique 348-infixLDIdKey                 = mkPreludeMiscIdUnique 349-infixRDIdKey                 = mkPreludeMiscIdUnique 350-infixNDIdKey                 = mkPreludeMiscIdUnique 351-roleAnnotDIdKey              = mkPreludeMiscIdUnique 352---- type Cxt = ...-cxtIdKey :: Unique-cxtIdKey            = mkPreludeMiscIdUnique 360---- data Pred = ...-classPIdKey, equalPIdKey :: Unique-classPIdKey         = mkPreludeMiscIdUnique 361-equalPIdKey         = mkPreludeMiscIdUnique 362---- data Strict = ...-isStrictKey, notStrictKey, unpackedKey :: Unique-isStrictKey         = mkPreludeMiscIdUnique 363-notStrictKey        = mkPreludeMiscIdUnique 364-unpackedKey         = mkPreludeMiscIdUnique 365---- data Con = ...-normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique-normalCIdKey      = mkPreludeMiscIdUnique 370-recCIdKey         = mkPreludeMiscIdUnique 371-infixCIdKey       = mkPreludeMiscIdUnique 372-forallCIdKey      = mkPreludeMiscIdUnique 373---- type StrictType = ...-strictTKey :: Unique-strictTKey        = mkPreludeMiscIdUnique 374---- type VarStrictType = ...-varStrictTKey :: Unique-varStrictTKey     = mkPreludeMiscIdUnique 375---- data Type = ...-forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey,-    listTIdKey, appTIdKey, sigTIdKey, litTIdKey,-    promotedTIdKey, promotedTupleTIdKey,-    promotedNilTIdKey, promotedConsTIdKey :: Unique-forallTIdKey        = mkPreludeMiscIdUnique 380-varTIdKey           = mkPreludeMiscIdUnique 381-conTIdKey           = mkPreludeMiscIdUnique 382-tupleTIdKey         = mkPreludeMiscIdUnique 383-unboxedTupleTIdKey  = mkPreludeMiscIdUnique 384-arrowTIdKey         = mkPreludeMiscIdUnique 385-listTIdKey          = mkPreludeMiscIdUnique 386-appTIdKey           = mkPreludeMiscIdUnique 387-sigTIdKey           = mkPreludeMiscIdUnique 388-litTIdKey           = mkPreludeMiscIdUnique 389-promotedTIdKey      = mkPreludeMiscIdUnique 390-promotedTupleTIdKey = mkPreludeMiscIdUnique 391-promotedNilTIdKey   = mkPreludeMiscIdUnique 392-promotedConsTIdKey  = mkPreludeMiscIdUnique 393---- data TyLit = ...-numTyLitIdKey, strTyLitIdKey :: Unique-numTyLitIdKey = mkPreludeMiscIdUnique 394-strTyLitIdKey = mkPreludeMiscIdUnique 395---- data TyVarBndr = ...-plainTVIdKey, kindedTVIdKey :: Unique-plainTVIdKey       = mkPreludeMiscIdUnique 396-kindedTVIdKey      = mkPreludeMiscIdUnique 397---- data Role = ...-nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique-nominalRIdKey          = mkPreludeMiscIdUnique 400-representationalRIdKey = mkPreludeMiscIdUnique 401-phantomRIdKey          = mkPreludeMiscIdUnique 402-inferRIdKey            = mkPreludeMiscIdUnique 403---- data Kind = ...-varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey,-  starKIdKey, constraintKIdKey :: Unique-varKIdKey         = mkPreludeMiscIdUnique 404-conKIdKey         = mkPreludeMiscIdUnique 405-tupleKIdKey       = mkPreludeMiscIdUnique 406-arrowKIdKey       = mkPreludeMiscIdUnique 407-listKIdKey        = mkPreludeMiscIdUnique 408-appKIdKey         = mkPreludeMiscIdUnique 409-starKIdKey        = mkPreludeMiscIdUnique 410-constraintKIdKey  = mkPreludeMiscIdUnique 411---- data Callconv = ...-cCallIdKey, stdCallIdKey :: Unique-cCallIdKey      = mkPreludeMiscIdUnique 412-stdCallIdKey    = mkPreludeMiscIdUnique 413---- data Safety = ...-unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique-unsafeIdKey        = mkPreludeMiscIdUnique 414-safeIdKey          = mkPreludeMiscIdUnique 415-interruptibleIdKey = mkPreludeMiscIdUnique 416---- data Inline = ...-noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique-noInlineDataConKey  = mkPreludeDataConUnique 40-inlineDataConKey    = mkPreludeDataConUnique 41-inlinableDataConKey = mkPreludeDataConUnique 42---- data RuleMatch = ...-conLikeDataConKey, funLikeDataConKey :: Unique-conLikeDataConKey = mkPreludeDataConUnique 43-funLikeDataConKey = mkPreludeDataConUnique 44---- data Phases = ...-allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique-allPhasesDataConKey   = mkPreludeDataConUnique 45-fromPhaseDataConKey   = mkPreludeDataConUnique 46-beforePhaseDataConKey = mkPreludeDataConUnique 47---- newtype TExp a = ...-tExpDataConKey :: Unique-tExpDataConKey = mkPreludeDataConUnique 48---- data FunDep = ...-funDepIdKey :: Unique-funDepIdKey = mkPreludeMiscIdUnique 419---- data FamFlavour = ...-typeFamIdKey, dataFamIdKey :: Unique-typeFamIdKey = mkPreludeMiscIdUnique 420-dataFamIdKey = mkPreludeMiscIdUnique 421---- data TySynEqn = ...-tySynEqnIdKey :: Unique-tySynEqnIdKey = mkPreludeMiscIdUnique 422---- quasiquoting-quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique-quoteExpKey  = mkPreludeMiscIdUnique 423-quotePatKey  = mkPreludeMiscIdUnique 424-quoteDecKey  = mkPreludeMiscIdUnique 425-quoteTypeKey = mkPreludeMiscIdUnique 426---- data RuleBndr = ...-ruleVarIdKey, typedRuleVarIdKey :: Unique-ruleVarIdKey      = mkPreludeMiscIdUnique 427-typedRuleVarIdKey = mkPreludeMiscIdUnique 428
− src/Language/Haskell/Liquid/Desugar/DsUtils.lhs 
@@ -1,835 +0,0 @@-%-% (c) The University of Glasgow 2006-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998-%--Utilities for desugaring--This module exports some utility functions of no great interest.--\begin{code}-{-# OPTIONS -fno-warn-tabs #-}--- The above warning supression flag is a temporary kludge.--- While working on this module you are encouraged to remove it and--- detab the module (please do the detabbing in a separate patch). See---     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces--- for details---- | Utility functions for constructing Core syntax, principally for desugaring-module Language.Haskell.Liquid.Desugar.DsUtils (-	EquationInfo(..), -	firstPat, shiftEqns,--	MatchResult(..), CanItFail(..), CaseAlt(..),-	cantFailMatchResult, alwaysFailMatchResult,-	extractMatchResult, combineMatchResults, -	adjustMatchResult,  adjustMatchResultDs,-	mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult, -	matchCanFail, mkEvalMatchResult,-	mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,-	wrapBind, wrapBinds,--	mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs,--        seqVar,--        -- LHs tuples-        mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat,-        mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,--        mkSelectorBinds,--	selectSimpleMatchVarL, selectMatchVars, selectMatchVar,-        mkOptTickBox, mkBinaryTickBox-    ) where---- #include "HsVersions.h"--import {-# SOURCE #-}	Language.Haskell.Liquid.Desugar.Match ( matchSimply )--import HsSyn-import TcHsSyn-import TcType( tcSplitTyConApp )-import CoreSyn-import DsMonad-import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr ( dsLExpr )--import CoreUtils-import MkCore-import MkId-import Id-import Literal-import TyCon-import ConLike-import DataCon-import PatSyn-import Type-import Coercion-import TysPrim-import TysWiredIn-import BasicTypes-import UniqSet-import UniqSupply-import Module-import PrelNames-import Outputable-import SrcLoc-import Util-import DynFlags-import FastString--import TcEvidence--import Control.Monad    ( zipWithM )-\end{code}---%************************************************************************-%*									*-\subsection{ Selecting match variables}-%*									*-%************************************************************************--We're about to match against some patterns.  We want to make some-@Ids@ to use as match variables.  If a pattern has an @Id@ readily at-hand, which should indeed be bound to the pattern as a whole, then use it;-otherwise, make one up.--\begin{code}-selectSimpleMatchVarL :: LPat Id -> DsM Id-selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)---- (selectMatchVars ps tys) chooses variables of type tys--- to use for matching ps against.  If the pattern is a variable,--- we try to use that, to save inventing lots of fresh variables.------ OLD, but interesting note:---    But even if it is a variable, its type might not match.  Consider---	data T a where---	  T1 :: Int -> T Int---	  T2 :: a   -> T a------	f :: T a -> a -> Int---	f (T1 i) (x::Int) = x---	f (T2 i) (y::a)   = 0---    Then we must not choose (x::Int) as the matching variable!--- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat--selectMatchVars :: [Pat Id] -> DsM [Id]-selectMatchVars ps = mapM selectMatchVar ps--selectMatchVar :: Pat Id -> DsM Id-selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)-selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)-selectMatchVar (ParPat pat)  = selectMatchVar (unLoc pat)-selectMatchVar (VarPat var)  = return (localiseId var)  -- Note [Localise pattern binders]-selectMatchVar (AsPat var _) = return (unLoc var)-selectMatchVar other_pat     = newSysLocalDs (hsPatType other_pat)-				  -- OK, better make up one...-\end{code}--Note [Localise pattern binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider     module M where-               [Just a] = e-After renaming it looks like-             module M where-               [Just M.a] = e--We don't generalise, since it's a pattern binding, monomorphic, etc,-so after desugaring we may get something like-             M.a = case e of (v:_) ->-                   case v of Just M.a -> M.a-Notice the "M.a" in the pattern; after all, it was in the original-pattern.  However, after optimisation those pattern binders can become-let-binders, and then end up floated to top level.  They have a-different *unique* by then (the simplifier is good about maintaining-proper scoping), but it's BAD to have two top-level bindings with the-External Name M.a, because that turns into two linker symbols for M.a.-It's quite rare for this to actually *happen* -- the only case I know-of is tc003 compiled with the 'hpc' way -- but that only makes it -all the more annoying.--To avoid this, we craftily call 'localiseId' in the desugarer, which-simply turns the External Name for the Id into an Internal one, but-doesn't change the unique.  So the desugarer produces this:-             M.a{r8} = case e of (v:_) ->-                       case v of Just a{r8} -> M.a{r8}-The unique is still 'r8', but the binding site in the pattern-is now an Internal Name.  Now the simplifier's usual mechanisms-will propagate that Name to all the occurrence sites, as well as-un-shadowing it, so we'll get-             M.a{r8} = case e of (v:_) ->-                       case v of Just a{s77} -> a{s77}-In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr-runs on the output of the desugarer, so all is well by the end of-the desugaring pass.---%************************************************************************-%*									*-%* type synonym EquationInfo and access functions for its pieces	*-%*									*-%************************************************************************-\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}--The ``equation info'' used by @match@ is relatively complicated and-worthy of a type synonym and a few handy functions.--\begin{code}-firstPat :: EquationInfo -> Pat Id-firstPat eqn = {- ASSERT( notNull (eqn_pats eqn) ) -} head (eqn_pats eqn)--shiftEqns :: [EquationInfo] -> [EquationInfo]--- Drop the first pattern in each equation-shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]-\end{code}--Functions on MatchResults--\begin{code}-matchCanFail :: MatchResult -> Bool-matchCanFail (MatchResult CanFail _)  = True-matchCanFail (MatchResult CantFail _) = False--alwaysFailMatchResult :: MatchResult-alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail)--cantFailMatchResult :: CoreExpr -> MatchResult-cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr)--extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr-extractMatchResult (MatchResult CantFail match_fn) _-  = match_fn (error "It can't fail!")--extractMatchResult (MatchResult CanFail match_fn) fail_expr = do-    (fail_bind, if_it_fails) <- mkFailurePair fail_expr-    body <- match_fn if_it_fails-    return (mkCoreLet fail_bind body)---combineMatchResults :: MatchResult -> MatchResult -> MatchResult-combineMatchResults (MatchResult CanFail      body_fn1)-                    (MatchResult can_it_fail2 body_fn2)-  = MatchResult can_it_fail2 body_fn-  where-    body_fn fail = do body2 <- body_fn2 fail-                      (fail_bind, duplicatable_expr) <- mkFailurePair body2-                      body1 <- body_fn1 duplicatable_expr-                      return (Let fail_bind body1)--combineMatchResults match_result1@(MatchResult CantFail _) _-  = match_result1--adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult-adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)-  = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail)--adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult-adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)-  = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail)--wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr-wrapBinds [] e = e-wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)--wrapBind :: Var -> Var -> CoreExpr -> CoreExpr-wrapBind new old body	-- NB: this function must deal with term-  | new==old    = body	-- variables, type variables or coercion variables-  | otherwise   = Let (NonRec new (varToCoreExpr old)) body--seqVar :: Var -> CoreExpr -> CoreExpr-seqVar var body = Case (Var var) var (exprType body)-			[(DEFAULT, [], body)]--mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult-mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)---- (mkViewMatchResult var' viewExpr var mr) makes the expression--- let var' = viewExpr var in mr-mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult-mkViewMatchResult var' viewExpr var = -    adjustMatchResult (mkCoreLet (NonRec var' (mkCoreAppDs viewExpr (Var var))))--mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult-mkEvalMatchResult var ty-  = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)]) --mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult-mkGuardedMatchResult pred_expr (MatchResult _ body_fn)-  = MatchResult CanFail (\fail -> do body <- body_fn fail-                                     return (mkIfThenElse pred_expr body fail))--mkCoPrimCaseMatchResult :: Id				-- Scrutinee-                    -> Type                             -- Type of the case-		    -> [(Literal, MatchResult)]		-- Alternatives-		    -> MatchResult			-- Literals are all unlifted-mkCoPrimCaseMatchResult var ty match_alts-  = MatchResult CanFail mk_case-  where-    mk_case fail = do-        alts <- mapM (mk_alt fail) sorted_alts-        return (Case (Var var) var ty ((DEFAULT, [], fail) : alts))--    sorted_alts = sortWith fst match_alts	-- Right order for a Case-    mk_alt fail (lit, MatchResult _ body_fn)-       = -- ASSERT( not (litIsLifted lit) )-         do body <- body_fn fail-            return (LitAlt lit, [], body)--data CaseAlt a = MkCaseAlt{ alt_pat :: a,-                            alt_bndrs :: [CoreBndr],-                            alt_wrapper :: HsWrapper,-                            alt_result :: MatchResult }--mkCoAlgCaseMatchResult -  :: DynFlags-  -> Id                 -- Scrutinee-  -> Type               -- Type of exp-  -> [CaseAlt DataCon]  -- Alternatives (bndrs *include* tyvars, dicts)-  -> MatchResult-mkCoAlgCaseMatchResult dflags var ty match_alts -  | isNewtype  -- Newtype case; use a let-  = -- ASSERT( null (tail match_alts) && null (tail arg_ids1) )-    mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1--  | isPArrFakeAlts match_alts-  = MatchResult CanFail $ mkPArrCase dflags var ty (sort_alts match_alts)-  | otherwise-  = mkDataConCase var ty match_alts-  where-    isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1))--	-- [Interesting: because of GADTs, we can't rely on the type of -	--  the scrutinised Id to be sufficiently refined to have a TyCon in it]--    alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 }-      = {- ASSERT( notNull match_alts ) -} head match_alts-    -- Stuff for newtype-    arg_id1       = {- ASSERT( notNull arg_ids1 ) -} head arg_ids1-    var_ty        = idType var-    (tc, ty_args) = tcSplitTyConApp var_ty	-- Don't look through newtypes-    	 	    		    		-- (not that splitTyConApp does, these days)-    newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)--        --- Stuff for parallel arrays-        ---	-- Concerning `isPArrFakeAlts':-	---	--  * it is *not* sufficient to just check the type of the type-	--   constructor, as we have to be careful not to confuse the real-	--   representation of parallel arrays with the fake constructors;-	--   moreover, a list of alternatives must not mix fake and real-	--   constructors (this is checked earlier on)-	---	-- FIXME: We actually go through the whole list and make sure that-	--	  either all or none of the constructors are fake parallel-	--	  array constructors.  This is to spot equations that mix fake-	--	  constructors with the real representation defined in-	--	  `PrelPArr'.  It would be nicer to spot this situation-	--	  earlier and raise a proper error message, but it can really-	--	  only happen in `PrelPArr' anyway.-	----    isPArrFakeAlts :: [CaseAlt DataCon] -> Bool-    isPArrFakeAlts [alt] = isPArrFakeCon (alt_pat alt)-    isPArrFakeAlts (alt:alts) =-      case (isPArrFakeCon (alt_pat alt), isPArrFakeAlts alts) of-        (True , True ) -> True-        (False, False) -> False-        _              -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns"-    isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"--mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult-mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt--\end{code}--\begin{code}-sort_alts :: [CaseAlt DataCon] -> [CaseAlt DataCon]-sort_alts = sortWith (dataConTag . alt_pat)--mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr-mkPatSynCase var ty alt fail = do-    matcher <- dsLExpr $ mkLHsWrap wrapper $ nlHsTyApp matcher [ty]-    let MatchResult _ mkCont = match_result-    cont <- mkCoreLams bndrs <$> mkCont fail-    return $ mkCoreAppsDs matcher [Var var, cont, fail]-  where-    MkCaseAlt{ alt_pat = psyn,-               alt_bndrs = bndrs,-               alt_wrapper = wrapper,-               alt_result = match_result} = alt-    matcher = patSynMatcher psyn--mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult-mkDataConCase _   _  []            = panic "mkDataConCase: no alternatives"-mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case-  where-    con1          = alt_pat alt1-    tycon         = dataConTyCon con1-    data_cons     = tyConDataCons tycon-    match_results = map alt_result alts--    sorted_alts :: [CaseAlt DataCon]-    sorted_alts  = sort_alts alts--    var_ty       = idType var-    (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes-                                          -- (not that splitTyConApp does, these days)--    mk_case :: CoreExpr -> DsM CoreExpr-    mk_case fail = do-        alts <- mapM (mk_alt fail) sorted_alts-        return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts)--    mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt-    mk_alt fail MkCaseAlt{ alt_pat = con,-                           alt_bndrs = args,-                           alt_result = MatchResult _ body_fn }-      = do { body <- body_fn fail-           ; case dataConBoxer con of {-                Nothing -> return (DataAlt con, args, body) ;-                Just (DCB boxer) ->-        do { us <- newUniqueSupply-           ; let (rep_ids, binds) = initUs_ us (boxer ty_args args)-           ; return (DataAlt con, rep_ids, mkLets binds body) } } }--    mk_default :: CoreExpr -> [CoreAlt]-    mk_default fail | exhaustive_case = []-                    | otherwise       = [(DEFAULT, [], fail)]--    fail_flag :: CanItFail-    fail_flag | exhaustive_case-              = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- match_results]-              | otherwise-              = CanFail--    mentioned_constructors = mkUniqSet $ map alt_pat alts-    un_mentioned_constructors-        = mkUniqSet data_cons `minusUniqSet` mentioned_constructors-    exhaustive_case = isEmptyUniqSet un_mentioned_constructors----- Stuff for parallel arrays------  * the following is to desugar cases over fake constructors for---   parallel arrays, which are introduced by `tidy1' in the `PArrPat'---   case----mkPArrCase :: DynFlags -> Id -> Type -> [CaseAlt DataCon] -> CoreExpr -> DsM CoreExpr-mkPArrCase dflags var ty sorted_alts fail = do-    lengthP <- dsDPHBuiltin lengthPVar-    alt <- unboxAlt-    return (mkWildCase (len lengthP) intTy ty [alt])-  where-    elemTy      = case splitTyConApp (idType var) of-        (_, [elemTy]) -> elemTy-        _             -> panic panicMsg-    panicMsg    = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"-    len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]-    ---    unboxAlt = do-        l      <- newSysLocalDs intPrimTy-        indexP <- dsDPHBuiltin indexPVar-        alts   <- mapM (mkAlt indexP) sorted_alts-        return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts))-      where-        dft  = (DEFAULT, [], fail)--    ---    -- each alternative matches one array length (corresponding to one-    -- fake array constructor), so the match is on a literal; each-    -- alternative's body is extended by a local binding for each-    -- constructor argument, which are bound to array elements starting-    -- with the first-    ---    mkAlt indexP alt@MkCaseAlt{alt_result = MatchResult _ bodyFun} = do-        body <- bodyFun fail-        return (LitAlt lit, [], mkCoreLets binds body)-      where-        lit   = MachInt $ toInteger (dataConSourceArity (alt_pat alt))-        binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] (alt_bndrs alt)]-        ---        indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr dflags i]-\end{code}--%************************************************************************-%*									*-\subsection{Desugarer's versions of some Core functions}-%*									*-%************************************************************************--\begin{code}-mkErrorAppDs :: Id 		-- The error function-	     -> Type		-- Type to which it should be applied-	     -> SDoc		-- The error message string to pass-	     -> DsM CoreExpr--mkErrorAppDs err_id ty msg = do-    src_loc <- getSrcSpanDs-    dflags <- getDynFlags-    let-        full_msg = showSDoc dflags (hcat [ppr src_loc, text "|", msg])-        core_msg = Lit (mkMachString full_msg)-        -- mkMachString returns a result of type String#-    return (mkApps (Var err_id) [Type ty, core_msg])-\end{code}--'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'.--Note [Desugaring seq (1)]  cf Trac #1031-~~~~~~~~~~~~~~~~~~~~~~~~~-   f x y = x `seq` (y `seq` (# x,y #))--The [CoreSyn let/app invariant] means that, other things being equal, because -the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:--   f x y = case (y `seq` (# x,y #)) of v -> x `seq` v--But that is bad for two reasons: -  (a) we now evaluate y before x, and -  (b) we can't bind v to an unboxed pair--Seq is very, very special!  So we recognise it right here, and desugar to-        case x of _ -> case y of _ -> (# x,y #)--Note [Desugaring seq (2)]  cf Trac #2273-~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   let chp = case b of { True -> fst x; False -> 0 }-   in chp `seq` ...chp...-Here the seq is designed to plug the space leak of retaining (snd x)-for too long.--If we rely on the ordinary inlining of seq, we'll get-   let chp = case b of { True -> fst x; False -> 0 }-   case chp of _ { I# -> ...chp... }--But since chp is cheap, and the case is an alluring contet, we'll-inline chp into the case scrutinee.  Now there is only one use of chp,-so we'll inline a second copy.  Alas, we've now ruined the purpose of-the seq, by re-introducing the space leak:-    case (case b of {True -> fst x; False -> 0}) of-      I# _ -> ...case b of {True -> fst x; False -> 0}...--We can try to avoid doing this by ensuring that the binder-swap in the-case happens, so we get his at an early stage:-   case chp of chp2 { I# -> ...chp2... }-But this is fragile.  The real culprit is the source program.  Perhaps we-should have said explicitly-   let !chp2 = chp in ...chp2...--But that's painful.  So the code here does a little hack to make seq-more robust: a saturated application of 'seq' is turned *directly* into-the case expression, thus:-   x  `seq` e2 ==> case x of x -> e2    -- Note shadowing!-   e1 `seq` e2 ==> case x of _ -> e2--So we desugar our example to:-   let chp = case b of { True -> fst x; False -> 0 }-   case chp of chp { I# -> ...chp... }-And now all is well.--The reason it's a hack is because if you define mySeq=seq, the hack-won't work on mySeq.  --Note [Desugaring seq (3)] cf Trac #2409-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The isLocalId ensures that we don't turn -        True `seq` e-into-        case True of True { ... }-which stupidly tries to bind the datacon 'True'. --\begin{code}-mkCoreAppDs  :: CoreExpr -> CoreExpr -> CoreExpr-mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2-  | f `hasKey` seqIdKey            -- Note [Desugaring seq (1), (2)]-  = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]-  where-    case_bndr = case arg1 of-                   Var v1 | isLocalId v1 -> v1        -- Note [Desugaring seq (2) and (3)]-                   _                     -> mkWildValBinder ty1--mkCoreAppDs fun arg = mkCoreApp fun arg	 -- The rest is done in MkCore--mkCoreAppsDs :: CoreExpr -> [CoreExpr] -> CoreExpr-mkCoreAppsDs fun args = foldl mkCoreAppDs fun args-\end{code}---%************************************************************************-%*									*-\subsection[mkSelectorBind]{Make a selector bind}-%*									*-%************************************************************************--This is used in various places to do with lazy patterns.-For each binder $b$ in the pattern, we create a binding:-\begin{verbatim}-    b = case v of pat' -> b'-\end{verbatim}-where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.--ToDo: making these bindings should really depend on whether there's-much work to be done per binding.  If the pattern is complex, it-should be de-mangled once, into a tuple (and then selected from).-Otherwise the demangling can be in-line in the bindings (as here).--Boring!  Boring!  One error message per binder.  The above ToDo is-even more helpful.  Something very similar happens for pattern-bound-expressions.--Note [mkSelectorBinds]-~~~~~~~~~~~~~~~~~~~~~~-Given   p = e, where p binds x,y-we are going to make EITHER--EITHER (A)   v = e   (where v is fresh)-             x = case v of p -> x-             y = case v of p -> y--OR (B)       t = case e of p -> (x,y)-             x = case t of (x,_) -> x-             y = case t of (_,y) -> y--We do (A) when - * Matching the pattern is cheap so we don't mind-   doing it twice.  - * Or if the pattern binds only one variable (so we'll only-   match once)- * AND the pattern can't fail (else we tiresomely get two inexhaustive -   pattern warning messages)--Otherwise we do (B).  Really (A) is just an optimisation for very common-cases like-     Just x = e-     (p,q) = e--\begin{code}-mkSelectorBinds :: [Maybe (Tickish Id)]  -- ticks to add, possibly-                -> LPat Id      -- The pattern-		-> CoreExpr	-- Expression to which the pattern is bound-		-> DsM [(Id,CoreExpr)]--mkSelectorBinds ticks (L _ (VarPat v)) val_expr-  = return [(v, case ticks of-                  [t] -> mkOptTickBox t val_expr-                  _   -> val_expr)]--mkSelectorBinds ticks pat val_expr-  | null binders -  = return []--  | isSingleton binders || is_simple_lpat pat-    -- See Note [mkSelectorBinds]-  = do { val_var <- newSysLocalDs (hsLPatType pat)-        -- Make up 'v' in Note [mkSelectorBinds]-        -- NB: give it the type of *pattern* p, not the type of the *rhs* e.-        -- This does not matter after desugaring, but there's a subtle -        -- issue with implicit parameters. Consider-        --      (x,y) = ?i-        -- Then, ?i is given type {?i :: Int}, a PredType, which is opaque-        -- to the desugarer.  (Why opaque?  Because newtypes have to be.  Why-        -- does it get that type?  So that when we abstract over it we get the-        -- right top-level type  (?i::Int) => ...)-        ---        -- So to get the type of 'v', use the pattern not the rhs.  Often more-        -- efficient too.--        -- For the error message we make one error-app, to avoid duplication.-        -- But we need it at different types... so we use coerce for that-       ; err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID  unitTy (ppr pat)-       ; err_var <- newSysLocalDs unitTy-       ; binds <- zipWithM (mk_bind val_var err_var) ticks' binders-       ; return ( (val_var, val_expr) : -                  (err_var, err_expr) :-                  binds ) }--  | otherwise-  = do { error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID   tuple_ty (ppr pat)-       ; tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr-       ; tuple_var <- newSysLocalDs tuple_ty-       ; let mk_tup_bind tick binder-              = (binder, mkOptTickBox tick $-                            mkTupleSelector local_binders binder-                                            tuple_var (Var tuple_var))-       ; return ( (tuple_var, tuple_expr) : zipWith mk_tup_bind ticks' binders ) }-  where-    binders       = collectPatBinders pat-    ticks'        = ticks ++ repeat Nothing--    local_binders = map localiseId binders      -- See Note [Localise pattern binders]-    local_tuple   = mkBigCoreVarTup binders-    tuple_ty      = exprType local_tuple--    mk_bind scrut_var err_var tick bndr_var = do-    -- (mk_bind sv err_var) generates-    --          bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var }-    -- Remember, pat binds bv-        rhs_expr <- matchSimply (Var scrut_var) PatBindRhs pat-                                (Var bndr_var) error_expr-        return (bndr_var, mkOptTickBox tick rhs_expr)-      where-        error_expr = mkCast (Var err_var) co-        co         = mkUnsafeCo (exprType (Var err_var)) (idType bndr_var)--    is_simple_lpat p = is_simple_pat (unLoc p)--    is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps-    is_simple_pat pat@(ConPatOut{})     = case unLoc (pat_con pat) of-        RealDataCon con -> isProductTyCon (dataConTyCon con)-                           && all is_triv_lpat (hsConPatArgs (pat_args pat))-        PatSynCon _     -> False-    is_simple_pat (VarPat _)                   = True-    is_simple_pat (ParPat p)                   = is_simple_lpat p-    is_simple_pat _                                    = False--    is_triv_lpat p = is_triv_pat (unLoc p)--    is_triv_pat (VarPat _)  = True-    is_triv_pat (WildPat _) = True-    is_triv_pat (ParPat p)  = is_triv_lpat p-    is_triv_pat _           = False-\end{code}--Creating big tuples and their types for full Haskell expressions.-They work over *Ids*, and create tuples replete with their types,-which is whey they are not in HsUtils.--\begin{code}-mkLHsPatTup :: [LPat Id] -> LPat Id-mkLHsPatTup []     = noLoc $ mkVanillaTuplePat [] Boxed-mkLHsPatTup [lpat] = lpat-mkLHsPatTup lpats  = L (getLoc (head lpats)) $ -		     mkVanillaTuplePat lpats Boxed--mkLHsVarPatTup :: [Id] -> LPat Id-mkLHsVarPatTup bs  = mkLHsPatTup (map nlVarPat bs)--mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id--- A vanilla tuple pattern simply gets its type from its sub-patterns-mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats)---- The Big equivalents for the source tuple expressions-mkBigLHsVarTup :: [Id] -> LHsExpr Id-mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)--mkBigLHsTup :: [LHsExpr Id] -> LHsExpr Id-mkBigLHsTup = mkChunkified mkLHsTupleExpr---- The Big equivalents for the source tuple patterns-mkBigLHsVarPatTup :: [Id] -> LPat Id-mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)--mkBigLHsPatTup :: [LPat Id] -> LPat Id-mkBigLHsPatTup = mkChunkified mkLHsPatTup-\end{code}--%************************************************************************-%*									*-\subsection[mkFailurePair]{Code for pattern-matching and other failures}-%*									*-%************************************************************************--Generally, we handle pattern matching failure like this: let-bind a-fail-variable, and use that variable if the thing fails:-\begin{verbatim}-	let fail.33 = error "Help"-	in-	case x of-		p1 -> ...-		p2 -> fail.33-		p3 -> fail.33-		p4 -> ...-\end{verbatim}-Then-\begin{itemize}-\item-If the case can't fail, then there'll be no mention of @fail.33@, and the-simplifier will later discard it.--\item-If it can fail in only one way, then the simplifier will inline it.--\item-Only if it is used more than once will the let-binding remain.-\end{itemize}--There's a problem when the result of the case expression is of-unboxed type.  Then the type of @fail.33@ is unboxed too, and-there is every chance that someone will change the let into a case:-\begin{verbatim}-	case error "Help" of-	  fail.33 -> case ....-\end{verbatim}--which is of course utterly wrong.  Rather than drop the condition that-only boxed types can be let-bound, we just turn the fail into a function-for the primitive case:-\begin{verbatim}-	let fail.33 :: Void -> Int#-	    fail.33 = \_ -> error "Help"-	in-	case x of-		p1 -> ...-		p2 -> fail.33 void-		p3 -> fail.33 void-		p4 -> ...-\end{verbatim}--Now @fail.33@ is a function, so it can be let-bound.--\begin{code}-mkFailurePair :: CoreExpr	-- Result type of the whole case expression-	      -> DsM (CoreBind,	-- Binds the newly-created fail variable-				-- to \ _ -> expression-		      CoreExpr)	-- Fail variable applied to realWorld#--- See Note [Failure thunks and CPR]-mkFailurePair expr-  = do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkFunTy` ty)-       ; fail_fun_arg <- newSysLocalDs voidPrimTy-       ; let real_arg = setOneShotLambda fail_fun_arg-       ; return (NonRec fail_fun_var (Lam real_arg expr),-                 App (Var fail_fun_var) (Var voidPrimId)) }-  where-    ty = exprType expr-\end{code}--Note [Failure thunks and CPR]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we make a failure point we ensure that it-does not look like a thunk. Example:--   let fail = \rw -> error "urk"-   in case x of -        [] -> fail realWorld#-        (y:ys) -> case ys of-                    [] -> fail realWorld#  -                    (z:zs) -> (y,z)--Reason: we know that a failure point is always a "join point" and is-entered at most once.  Adding a dummy 'realWorld' token argument makes-it clear that sharing is not an issue.  And that in turn makes it more-CPR-friendly.  This matters a lot: if you don't get it right, you lose-the tail call property.  For example, see Trac #3403.--\begin{code}-mkOptTickBox :: Maybe (Tickish Id) -> CoreExpr -> CoreExpr-mkOptTickBox Nothing e        = e-mkOptTickBox (Just tickish) e = Tick tickish e--mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr-mkBinaryTickBox ixT ixF e = do-       uq <- newUnique 	-       this_mod <- getModule-       let bndr1 = mkSysLocal (fsLit "t1") uq boolTy-       let-           falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId)-           trueBox  = Tick (HpcTick this_mod ixT) (Var trueDataConId)-       ---       return $ Case e bndr1 boolTy-                       [ (DataAlt falseDataCon, [], falseBox)-                       , (DataAlt trueDataCon,  [], trueBox)-                       ]-\end{code}
− src/Language/Haskell/Liquid/Desugar/HscMain.hs 
@@ -1,95 +0,0 @@-------------------------------------------------------------------------------------- | Main API for compiling plain Haskell source code.------ This module implements compilation of a Haskell source. It is--- /not/ concerned with preprocessing of source files; this is handled--- in "DriverPipeline".------ There are various entry points depending on what mode we're in:--- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and--- "interactive" mode (GHCi). There are also entry points for--- individual passes: parsing, typechecking/renaming, desugaring, and--- simplification.------ All the functions here take an 'HscEnv' as a parameter, but none of--- them return a new one: 'HscEnv' is treated as an immutable value--- from here on in (although it has mutable components, for the--- caches).------ Warning messages are dealt with consistently throughout this API:--- during compilation warnings are collected, and before any function--- in @HscMain@ returns, the warnings are either printed, or turned--- into a real compialtion error if the @-Werror@ flag is enabled.------ (c) The GRASP/AQUA Project, Glasgow University, 1993-2000-------------------------------------------------------------------------------------module Language.Haskell.Liquid.Desugar.HscMain (hscDesugarWithLoc) where--import Language.Haskell.Liquid.Desugar.Desugar (deSugarWithLoc)--import Module -import Lexer-import TcRnMonad--import ErrUtils--import HscTypes-import Bag-import Exception----- -------------------------------------------------------------------------------getWarnings :: Hsc WarningMessages-getWarnings = Hsc $ \_ w -> return (w, w)--clearWarnings :: Hsc ()-clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)--logWarnings :: WarningMessages -> Hsc ()-logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)------ | Throw some errors.-throwErrors :: ErrorMessages -> Hsc a-throwErrors = liftIO . throwIO . mkSrcErr---- --- | Convert a typechecked module to Core-hscDesugarWithLoc :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts-hscDesugarWithLoc hsc_env mod_summary tc_result =-    runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result--hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts-hscDesugar' mod_location tc_result = do-    hsc_env <- getHscEnv-    r <- ioMsgMaybe $-      {-# SCC "deSugar" #-}-      deSugarWithLoc hsc_env mod_location tc_result--    -- always check -Werror after desugaring, this is the last opportunity for-    -- warnings to arise before the backend.-    handleWarnings-    return r--getHscEnv :: Hsc HscEnv-getHscEnv = Hsc $ \e w -> return (e, w)--handleWarnings :: Hsc ()-handleWarnings = do-    dflags <- getDynFlags-    w <- getWarnings-    liftIO $ printOrThrowWarnings dflags w-    clearWarnings--ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a-ioMsgMaybe ioA = do-    ((warns,errs), mb_r) <- liftIO ioA-    logWarnings warns-    case mb_r of-        Nothing -> throwErrors errs-        Just r  -> return r
− src/Language/Haskell/Liquid/Desugar/Match.lhs 
@@ -1,1050 +0,0 @@-%-% (c) The University of Glasgow 2006-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998-%--The @match@ function--\begin{code}-module Language.Haskell.Liquid.Desugar.Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where---- #include "HsVersions.h"--import {-#SOURCE#-} Language.Haskell.Liquid.Desugar.DsExpr (dsLExpr, dsExpr)--import DynFlags-import HsSyn-import TcHsSyn-import TcEvidence-import TcRnMonad-import Check-import CoreSyn-import Literal-import CoreUtils-import MkCore-import DsMonad-import Language.Haskell.Liquid.Desugar.DsBinds-import Language.Haskell.Liquid.Desugar.DsGRHSs-import Language.Haskell.Liquid.Desugar.DsUtils-import Id-import ConLike-import DataCon-import PatSyn-import Language.Haskell.Liquid.Desugar.MatchCon-import Language.Haskell.Liquid.Desugar.MatchLit-import Type-import TysWiredIn-import ListSetOps-import SrcLoc-import Maybes-import Util-import Name-import Outputable-import BasicTypes ( boxityNormalTupleSort, isGenerated )-import FastString--import Control.Monad( when )-import qualified Data.Map as Map-\end{code}--This function is a wrapper of @match@, it must be called from all the parts where-it was called match, but only substitutes the first call, ....-if the associated flags are declared, warnings will be issued.-It can not be called matchWrapper because this name already exists :-(--JJCQ 30-Nov-1997--\begin{code}-matchCheck ::  DsMatchContext-            -> [Id]             -- Vars rep'ing the exprs we're matching with-            -> Type             -- Type of the case expression-            -> [EquationInfo]   -- Info about patterns, etc. (type synonym below)-            -> DsM MatchResult  -- Desugared result!--matchCheck ctx vars ty qs-  = do { dflags <- getDynFlags-       ; matchCheck_really dflags ctx vars ty qs }--matchCheck_really :: DynFlags-                  -> DsMatchContext-                  -> [Id]-                  -> Type-                  -> [EquationInfo]-                  -> DsM MatchResult-matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs-  = do { when shadow (dsShadowWarn ctx eqns_shadow)-       ; when incomplete (dsIncompleteWarn ctx pats)-       ; match vars ty qs }-  where-    (pats, eqns_shadow) = check qs-    incomplete = incomplete_flag hs_ctx && (notNull pats)-    shadow     = wopt Opt_WarnOverlappingPatterns dflags-              && notNull eqns_shadow--    incomplete_flag :: HsMatchContext id -> Bool-    incomplete_flag (FunRhs {})   = wopt Opt_WarnIncompletePatterns dflags-    incomplete_flag CaseAlt       = wopt Opt_WarnIncompletePatterns dflags-    incomplete_flag IfAlt         = False--    incomplete_flag LambdaExpr    = wopt Opt_WarnIncompleteUniPatterns dflags-    incomplete_flag PatBindRhs    = wopt Opt_WarnIncompleteUniPatterns dflags-    incomplete_flag ProcExpr      = wopt Opt_WarnIncompleteUniPatterns dflags--    incomplete_flag RecUpd        = wopt Opt_WarnIncompletePatternsRecUpd dflags--    incomplete_flag ThPatSplice   = False-    incomplete_flag PatSyn        = False-    incomplete_flag ThPatQuote    = False-    incomplete_flag (StmtCtxt {}) = False  -- Don't warn about incomplete patterns-                                           -- in list comprehensions, pattern guards-                                           -- etc.  They are often *supposed* to be-                                           -- incomplete-\end{code}--This variable shows the maximum number of lines of output generated for warnings.-It will limit the number of patterns/equations displayed to@ maximum_output@.--(ToDo: add command-line option?)--\begin{code}-maximum_output :: Int-maximum_output = 4-\end{code}--The next two functions create the warning message.--\begin{code}-dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()-dsShadowWarn ctx@(DsMatchContext kind loc) qs-  = putSrcSpanDs loc (warnDs warn)-  where-    warn | qs `lengthExceeds` maximum_output-         = pp_context ctx (ptext (sLit "are overlapped"))-                      (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$-                      ptext (sLit "..."))-         | otherwise-         = pp_context ctx (ptext (sLit "are overlapped"))-                      (\ f -> vcat $ map (ppr_eqn f kind) qs)---dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()-dsIncompleteWarn ctx@(DsMatchContext kind loc) pats-  = putSrcSpanDs loc (warnDs warn)-        where-          warn = pp_context ctx (ptext (sLit "are non-exhaustive"))-                            (\_ -> hang (ptext (sLit "Patterns not matched:"))-                                   4 ((vcat $ map (ppr_incomplete_pats kind)-                                                  (take maximum_output pats))-                                      $$ dots))--          dots | pats `lengthExceeds` maximum_output = ptext (sLit "...")-               | otherwise                           = empty--pp_context :: DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc-pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun-  = vcat [ptext (sLit "Pattern match(es)") <+> msg,-          sep [ptext (sLit "In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]-  where-    (ppr_match, pref)-        = case kind of-             FunRhs fun _ -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)-             _            -> (pprMatchContext kind, \ pp -> pp)--ppr_pats :: Outputable a => [a] -> SDoc-ppr_pats pats = sep (map ppr pats)--ppr_shadow_pats :: HsMatchContext Name -> [Pat Id] -> SDoc-ppr_shadow_pats kind pats-  = sep [ppr_pats pats, matchSeparator kind, ptext (sLit "...")]--ppr_incomplete_pats :: HsMatchContext Name -> ExhaustivePat -> SDoc-ppr_incomplete_pats _ (pats,[]) = ppr_pats pats-ppr_incomplete_pats _ (pats,constraints) =-                         sep [ppr_pats pats, ptext (sLit "with"),-                              sep (map ppr_constraint constraints)]--ppr_constraint :: (Name,[HsLit]) -> SDoc-ppr_constraint (var,pats) = sep [ppr var, ptext (sLit "`notElem`"), ppr pats]--ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> EquationInfo -> SDoc-ppr_eqn prefixF kind eqn = prefixF (ppr_shadow_pats kind (eqn_pats eqn))-\end{code}---%************************************************************************-%*                                                                      *-                The main matching function-%*                                                                      *-%************************************************************************--The function @match@ is basically the same as in the Wadler chapter,-except it is monadised, to carry around the name supply, info about-annotations, etc.--Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:-\begin{enumerate}-\item-A list of $n$ variable names, those variables presumably bound to the-$n$ expressions being matched against the $n$ patterns.  Using the-list of $n$ expressions as the first argument showed no benefit and-some inelegance.--\item-The second argument, a list giving the ``equation info'' for each of-the $m$ equations:-\begin{itemize}-\item-the $n$ patterns for that equation, and-\item-a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on-the front'' of the matching code, as in:-\begin{verbatim}-let <binds>-in  <matching-code>-\end{verbatim}-\item-and finally: (ToDo: fill in)--The right way to think about the ``after-match function'' is that it-is an embryonic @CoreExpr@ with a ``hole'' at the end for the-final ``else expression''.-\end{itemize}--There is a type synonym, @EquationInfo@, defined in module @DsUtils@.--An experiment with re-ordering this information about equations (in-particular, having the patterns available in column-major order)-showed no benefit.--\item-A default expression---what to evaluate if the overall pattern-match-fails.  This expression will (almost?) always be-a measly expression @Var@, unless we know it will only be used once-(as we do in @glue_success_exprs@).--Leaving out this third argument to @match@ (and slamming in lots of-@Var "fail"@s) is a positively {\em bad} idea, because it makes it-impossible to share the default expressions.  (Also, it stands no-chance of working in our post-upheaval world of @Locals@.)-\end{enumerate}--Note: @match@ is often called via @matchWrapper@ (end of this module),-a function that does much of the house-keeping that goes with a call-to @match@.--It is also worth mentioning the {\em typical} way a block of equations-is desugared with @match@.  At each stage, it is the first column of-patterns that is examined.  The steps carried out are roughly:-\begin{enumerate}-\item-Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add-bindings to the second component of the equation-info):-\begin{itemize}-\item-Remove the `as' patterns from column~1.-\item-Make all constructor patterns in column~1 into @ConPats@, notably-@ListPats@ and @TuplePats@.-\item-Handle any irrefutable (or ``twiddle'') @LazyPats@.-\end{itemize}-\item-Now {\em unmix} the equations into {\em blocks} [w\/ local function-@unmix_eqns@], in which the equations in a block all have variable-patterns in column~1, or they all have constructor patterns in ...-(see ``the mixture rule'' in SLPJ).-\item-Call @matchEqnBlock@ on each block of equations; it will do the-appropriate thing for each kind of column-1 pattern, usually ending up-in a recursive call to @match@.-\end{enumerate}--We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)-than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).-And gluing the ``success expressions'' together isn't quite so pretty.--This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@-(a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and-(b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em-un}mixes the equations], producing a list of equation-info-blocks, each block having as its first column of patterns either all-constructors, or all variables (or similar beasts), etc.--@match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the-Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@-corresponds roughly to @matchVarCon@.--\begin{code}--match :: [Id]             -- Variables rep\'ing the exprs we\'re matching with-      -> Type             -- Type of the case expression-      -> [EquationInfo]   -- Info about patterns, etc. (type synonym below)-      -> DsM MatchResult  -- Desugared result!--match [] _ eqns-  = -- ASSERT2( not (null eqns), ppr ty )-    return (foldr1 combineMatchResults match_results)-  where-    match_results = [ -- ASSERT( null (eqn_pats eqn) )-                      eqn_rhs eqn-                    | eqn <- eqns ]--match vars@(v:_) ty eqns    -- Eqns *can* be empty-  = do  { dflags <- getDynFlags-        ;       -- Tidy the first pattern, generating-                -- auxiliary bindings if necessary-          (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns--                -- Group the equations and match each group in turn-        ; let grouped = groupEquations dflags tidy_eqns--         -- print the view patterns that are commoned up to help debug-        ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped)--        ; match_results <- match_groups grouped-        ; return (adjustMatchResult (foldr (.) id aux_binds) $-                  foldr1 combineMatchResults match_results) }-  where-    dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo]-    dropGroup = map snd--    match_groups :: [[(PatGroup,EquationInfo)]] -> DsM [MatchResult]-    -- Result list of [MatchResult] is always non-empty-    match_groups [] = matchEmpty v ty-    match_groups gs = mapM match_group gs--    match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult-    match_group [] = panic "match_group"-    match_group eqns@((group,_) : _)-        = case group of-            PgCon _    -> matchConFamily  vars ty (subGroup [(c,e) | (PgCon c, e) <- eqns])-            PgSyn _    -> matchPatSyn     vars ty (dropGroup eqns)-            PgLit _    -> matchLiterals   vars ty (subGroup [(l,e) | (PgLit l, e) <- eqns])-            PgAny      -> matchVariables  vars ty (dropGroup eqns)-            PgN _      -> matchNPats      vars ty (dropGroup eqns)-            PgNpK _    -> matchNPlusKPats vars ty (dropGroup eqns)-            PgBang     -> matchBangs      vars ty (dropGroup eqns)-            PgCo _     -> matchCoercion   vars ty (dropGroup eqns)-            PgView _ _ -> matchView       vars ty (dropGroup eqns)-            PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns)--    -- FIXME: we should also warn about view patterns that should be-    -- commoned up but are not--    -- print some stuff to see what's getting grouped-    -- use -dppr-debug to see the resolution of overloaded literals-    debug eqns =-        let gs = map (\group -> foldr (\ (p,_) -> \acc ->-                                           case p of PgView e _ -> e:acc-                                                     _ -> acc) [] group) eqns-            maybeWarn [] = return ()-            maybeWarn l = warnDs (vcat l)-        in-          maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))-                       (filter (not . null) gs))--matchEmpty :: Id -> Type -> DsM [MatchResult]--- See Note [Empty case expressions]-matchEmpty var res_ty-  = return [MatchResult CanFail mk_seq]-  where-    mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty-                                      [(DEFAULT, [], fail)]--matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult--- Real true variables, just like in matchVar, SLPJ p 94--- No binding to do: they'll all be wildcards by now (done in tidy)-matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns)-matchVariables [] _ _ = panic "matchVariables"--matchBangs :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult-matchBangs (var:vars) ty eqns-  = do  { match_result <- match (var:vars) ty $-                          map (decomposeFirstPat getBangPat) eqns-        ; return (mkEvalMatchResult var ty match_result) }-matchBangs [] _ _ = panic "matchBangs"--matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult--- Apply the coercion to the match variable and then match that-matchCoercion (var:vars) ty (eqns@(eqn1:_))-  = do  { let CoPat co pat _ = firstPat eqn1-        ; var' <- newUniqueId var (hsPatType pat)-        ; match_result <- match (var':vars) ty $-                          map (decomposeFirstPat getCoPat) eqns-        ; rhs' <- dsHsWrapper co (Var var)-        ; return (mkCoLetMatchResult (NonRec var' rhs') match_result) }-matchCoercion _ _ _ = panic "matchCoercion"--matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult--- Apply the view function to the match variable and then match that-matchView (var:vars) ty (eqns@(eqn1:_))-  = do  { -- we could pass in the expr from the PgView,-         -- but this needs to extract the pat anyway-         -- to figure out the type of the fresh variable-         let ViewPat viewExpr (L _ pat) _ = firstPat eqn1-         -- do the rest of the compilation-        ; var' <- newUniqueId var (hsPatType pat)-        ; match_result <- match (var':vars) ty $-                          map (decomposeFirstPat getViewPat) eqns-         -- compile the view expressions-        ; viewExpr' <- dsLExpr viewExpr-        ; return (mkViewMatchResult var' viewExpr' var match_result) }-matchView _ _ _ = panic "matchView"--matchOverloadedList :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult-matchOverloadedList (var:vars) ty (eqns@(eqn1:_))--- Since overloaded list patterns are treated as view patterns,--- the code is roughly the same as for matchView-  = do { let ListPat _ elt_ty (Just (_,e)) = firstPat eqn1-       ; var' <- newUniqueId var (mkListTy elt_ty)  -- we construct the overall type by hand-       ; match_result <- match (var':vars) ty $-                            map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern-       ; e' <- dsExpr e-       ; return (mkViewMatchResult var' e' var match_result) }-matchOverloadedList _ _ _ = panic "matchOverloadedList"---- decompose the first pattern and leave the rest alone-decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo-decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))-        = eqn { eqn_pats = extractpat pat : pats}-decomposeFirstPat _ _ = panic "decomposeFirstPat"--getCoPat, getBangPat, getViewPat, getOLPat :: Pat Id -> Pat Id-getCoPat (CoPat _ pat _)     = pat-getCoPat _                   = panic "getCoPat"-getBangPat (BangPat pat  )   = unLoc pat-getBangPat _                 = panic "getBangPat"-getViewPat (ViewPat _ pat _) = unLoc pat-getViewPat _                 = panic "getViewPat"-getOLPat (ListPat pats ty (Just _)) = ListPat pats ty Nothing-getOLPat _                   = panic "getOLPat"-\end{code}--Note [Empty case alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The list of EquationInfo can be empty, arising from-    case x of {}   or    \case {}-In that situation we desugar to-    case x of { _ -> error "pattern match failure" }-The *desugarer* isn't certain whether there really should be no-alternatives, so it adds a default case, as it always does.  A later-pass may remove it if it's inaccessible.  (See also Note [Empty case-alternatives] in CoreSyn.)--We do *not* desugar simply to-   error "empty case"-or some such, because 'x' might be bound to (error "hello"), in which-case we want to see that "hello" exception, not (error "empty case").-See also Note [Case elimination: lifted case] in Simplify.---%************************************************************************-%*                                                                      *-                Tidying patterns-%*                                                                      *-%************************************************************************--Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@-which will be scrutinised.  This means:-\begin{itemize}-\item-Replace variable patterns @x@ (@x /= v@) with the pattern @_@,-together with the binding @x = v@.-\item-Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@.-\item-Removing lazy (irrefutable) patterns (you don't want to know...).-\item-Converting explicit tuple-, list-, and parallel-array-pats into ordinary-@ConPats@.-\item-Convert the literal pat "" to [].-\end{itemize}--The result of this tidying is that the column of patterns will include-{\em only}:-\begin{description}-\item[@WildPats@:]-The @VarPat@ information isn't needed any more after this.--\item[@ConPats@:]-@ListPats@, @TuplePats@, etc., are all converted into @ConPats@.--\item[@LitPats@ and @NPats@:]-@LitPats@/@NPats@ of ``known friendly types'' (Int, Char,-Float,  Double, at least) are converted to unboxed form; e.g.,-\tr{(NPat (HsInt i) _ _)} is converted to:-\begin{verbatim}-(ConPat I# _ _ [LitPat (HsIntPrim i)])-\end{verbatim}-\end{description}--\begin{code}-tidyEqnInfo :: Id -> EquationInfo-            -> DsM (DsWrapper, EquationInfo)-        -- DsM'd because of internal call to dsLHsBinds-        --      and mkSelectorBinds.-        -- "tidy1" does the interesting stuff, looking at-        -- one pattern and fiddling the list of bindings.-        ---        -- POST CONDITION: head pattern in the EqnInfo is-        --      WildPat-        --      ConPat-        --      NPat-        --      LitPat-        --      NPlusKPat-        -- but no other--tidyEqnInfo _ (EqnInfo { eqn_pats = [] })-  = panic "tidyEqnInfo"--tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats })-  = do { (wrap, pat') <- tidy1 v pat-       ; return (wrap, eqn { eqn_pats = do pat' : pats }) }--tidy1 :: Id               -- The Id being scrutinised-      -> Pat Id           -- The pattern against which it is to be matched-      -> DsM (DsWrapper,  -- Extra bindings to do before the match-              Pat Id)     -- Equivalent pattern------------------------------------------------------------      (pat', mr') = tidy1 v pat mr--- tidies the *outer level only* of pat, giving pat'--- It eliminates many pattern forms (as-patterns, variable patterns,--- list patterns, etc) yielding one of:---      WildPat---      ConPatOut---      LitPat---      NPat---      NPlusKPat--tidy1 v (ParPat pat)      = tidy1 v (unLoc pat)-tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat)-tidy1 _ (WildPat ty)      = return (idDsWrapper, WildPat ty)-tidy1 v (BangPat (L l p)) = tidy_bang_pat v l p--        -- case v of { x -> mr[] }-        -- = case v of { _ -> let x=v in mr[] }-tidy1 v (VarPat var)-  = return (wrapBind var v, WildPat (idType var))--        -- case v of { x@p -> mr[] }-        -- = case v of { p -> let x=v in mr[] }-tidy1 v (AsPat (L _ var) pat)-  = do  { (wrap, pat') <- tidy1 v (unLoc pat)-        ; return (wrapBind var v . wrap, pat') }--{- now, here we handle lazy patterns:-    tidy1 v ~p bs = (v, v1 = case v of p -> v1 :-                        v2 = case v of p -> v2 : ... : bs )--    where the v_i's are the binders in the pattern.--    ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?--    The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr--}--tidy1 v (LazyPat pat)-  = do  { sel_prs <- mkSelectorBinds [] pat (Var v)-        ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]-        ; return (mkCoreLets sel_binds, WildPat (idType v)) }--tidy1 _ (ListPat pats ty Nothing)-  = return (idDsWrapper, unLoc list_ConPat)-  where-    list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])-                        (mkNilPat ty)-                        pats---- Introduce fake parallel array constructors to be able to handle parallel--- arrays with the existing machinery for constructor pattern-tidy1 _ (PArrPat pats ty)-  = return (idDsWrapper, unLoc parrConPat)-  where-    arity      = length pats-    parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty]--tidy1 _ (TuplePat pats boxity tys)-  = return (idDsWrapper, unLoc tuple_ConPat)-  where-    arity = length pats-    tuple_ConPat = mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) pats tys---- LitPats: we *might* be able to replace these w/ a simpler form-tidy1 _ (LitPat lit)-  = return (idDsWrapper, tidyLitPat lit)---- NPats: we *might* be able to replace these w/ a simpler form-tidy1 _ (NPat lit mb_neg eq)-  = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq)---- Everything else goes through unchanged...--tidy1 _ non_interesting_pat-  = return (idDsWrapper, non_interesting_pat)-----------------------tidy_bang_pat :: Id -> SrcSpan -> Pat Id -> DsM (DsWrapper, Pat Id)---- Discard bang around strict pattern-tidy_bang_pat v _ p@(ListPat {})   = tidy1 v p-tidy_bang_pat v _ p@(TuplePat {})  = tidy1 v p-tidy_bang_pat v _ p@(PArrPat {})   = tidy1 v p-tidy_bang_pat v _ p@(ConPatOut {}) = tidy1 v p-tidy_bang_pat v _ p@(LitPat {})    = tidy1 v p---- Discard par/sig under a bang-tidy_bang_pat v _ (ParPat (L l p))      = tidy_bang_pat v l p-tidy_bang_pat v _ (SigPatOut (L l p) _) = tidy_bang_pat v l p---- Push the bang-pattern inwards, in the hope that--- it may disappear next time-tidy_bang_pat v l (AsPat v' p)  = tidy1 v (AsPat v' (L l (BangPat p)))-tidy_bang_pat v l (CoPat w p t) = tidy1 v (CoPat w (BangPat (L l p)) t)---- Default case, leave the bang there:--- VarPat, LazyPat, WildPat, ViewPat, NPat, NPlusKPat--- For LazyPat, remember that it's semantically like a VarPat---  i.e.  !(~p) is not like ~p, or p!  (Trac #8952)--tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p))-  -- NB: SigPatIn, ConPatIn should not happen-\end{code}--\noindent-{\bf Previous @matchTwiddled@ stuff:}--Now we get to the only interesting part; note: there are choices for-translation [from Simon's notes]; translation~1:-\begin{verbatim}-deTwiddle [s,t] e-\end{verbatim}-returns-\begin{verbatim}-[ w = e,-  s = case w of [s,t] -> s-  t = case w of [s,t] -> t-]-\end{verbatim}--Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple-evaluation of \tr{e}.  An alternative translation (No.~2):-\begin{verbatim}-[ w = case e of [s,t] -> (s,t)-  s = case w of (s,t) -> s-  t = case w of (s,t) -> t-]-\end{verbatim}--%************************************************************************-%*                                                                      *-\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}-%*                                                                      *-%************************************************************************--We might be able to optimise unmixing when confronted by-only-one-constructor-possible, of which tuples are the most notable-examples.  Consider:-\begin{verbatim}-f (a,b,c) ... = ...-f d ... (e:f) = ...-f (g,h,i) ... = ...-f j ...       = ...-\end{verbatim}-This definition would normally be unmixed into four equation blocks,-one per equation.  But it could be unmixed into just one equation-block, because if the one equation matches (on the first column),-the others certainly will.--You have to be careful, though; the example-\begin{verbatim}-f j ...       = ...---------------------f (a,b,c) ... = ...-f d ... (e:f) = ...-f (g,h,i) ... = ...-\end{verbatim}-{\em must} be broken into two blocks at the line shown; otherwise, you-are forcing unnecessary evaluation.  In any case, the top-left pattern-always gives the cue.  You could then unmix blocks into groups of...-\begin{description}-\item[all variables:]-As it is now.-\item[constructors or variables (mixed):]-Need to make sure the right names get bound for the variable patterns.-\item[literals or variables (mixed):]-Presumably just a variant on the constructor case (as it is now).-\end{description}--%************************************************************************-%*                                                                      *-%*  matchWrapper: a convenient way to call @match@                      *-%*                                                                      *-%************************************************************************-\subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}--Calls to @match@ often involve similar (non-trivial) work; that work-is collected here, in @matchWrapper@.  This function takes as-arguments:-\begin{itemize}-\item-Typchecked @Matches@ (of a function definition, or a case or lambda-expression)---the main input;-\item-An error message to be inserted into any (runtime) pattern-matching-failure messages.-\end{itemize}--As results, @matchWrapper@ produces:-\begin{itemize}-\item-A list of variables (@Locals@) that the caller must ``promise'' to-bind to appropriate values; and-\item-a @CoreExpr@, the desugared output (main result).-\end{itemize}--The main actions of @matchWrapper@ include:-\begin{enumerate}-\item-Flatten the @[TypecheckedMatch]@ into a suitable list of-@EquationInfo@s.-\item-Create as many new variables as there are patterns in a pattern-list-(in any one of the @EquationInfo@s).-\item-Create a suitable ``if it fails'' expression---a call to @error@ using-the error-string input; the {\em type} of this fail value can be found-by examining one of the RHS expressions in one of the @EquationInfo@s.-\item-Call @match@ with all of this information!-\end{enumerate}--\begin{code}-matchWrapper :: HsMatchContext Name         -- For shadowing warning messages-             -> MatchGroup Id (LHsExpr Id)  -- Matches being desugared-             -> DsM ([Id], CoreExpr)        -- Results-\end{code}-- There is one small problem with the Lambda Patterns, when somebody- writes something similar to:-\begin{verbatim}-    (\ (x:xs) -> ...)-\end{verbatim}- he/she don't want a warning about incomplete patterns, that is done with- the flag @opt_WarnSimplePatterns@.- This problem also appears in the:-\begin{itemize}-\item @do@ patterns, but if the @do@ can fail-      it creates another equation if the match can fail-      (see @DsExpr.doDo@ function)-\item @let@ patterns, are treated by @matchSimply@-   List Comprension Patterns, are treated by @matchSimply@ also-\end{itemize}--We can't call @matchSimply@ with Lambda patterns,-due to the fact that lambda patterns can have more than-one pattern, and match simply only accepts one pattern.--JJQC 30-Nov-1997--\begin{code}-matchWrapper ctxt (MG { mg_alts = matches-                      , mg_arg_tys = arg_tys-                      , mg_res_ty = rhs_ty-                      , mg_origin = origin })-  = do  { eqns_info   <- mapM mk_eqn_info matches-        ; new_vars    <- case matches of-                           []    -> mapM newSysLocalDs arg_tys-                           (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m))-        ; result_expr <- handleWarnings $-                         matchEquations ctxt new_vars eqns_info rhs_ty-        ; return (new_vars, result_expr) }-  where-    mk_eqn_info (L _ (Match pats _ grhss))-      = do { let upats = map unLoc pats-           ; match_result <- dsGRHSs ctxt upats grhss rhs_ty-           ; return (EqnInfo { eqn_pats = upats, eqn_rhs  = match_result}) }--    handleWarnings = if isGenerated origin-                     then discardWarningsDs-                     else id---matchEquations  :: HsMatchContext Name-                -> [Id] -> [EquationInfo] -> Type-                -> DsM CoreExpr-matchEquations ctxt vars eqns_info rhs_ty-  = do  { locn <- getSrcSpanDs-        ; let   ds_ctxt   = DsMatchContext ctxt locn-                error_doc = matchContextErrString ctxt--        ; match_result <- matchCheck ds_ctxt vars rhs_ty eqns_info--        ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc-        ; extractMatchResult match_result fail_expr }-\end{code}--%************************************************************************-%*                                                                      *-\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}-%*                                                                      *-%************************************************************************--@mkSimpleMatch@ is a wrapper for @match@ which deals with the-situation where we want to match a single expression against a single-pattern. It returns an expression.--\begin{code}-matchSimply :: CoreExpr                 -- Scrutinee-            -> HsMatchContext Name      -- Match kind-            -> LPat Id                  -- Pattern it should match-            -> CoreExpr                 -- Return this if it matches-            -> CoreExpr                 -- Return this if it doesn't-            -> DsM CoreExpr--- Do not warn about incomplete patterns; see matchSinglePat comments-matchSimply scrut hs_ctx pat result_expr fail_expr = do-    let-      match_result = cantFailMatchResult result_expr-      rhs_ty       = exprType fail_expr-        -- Use exprType of fail_expr, because won't refine in the case of failure!-    match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result-    extractMatchResult match_result' fail_expr--matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id-               -> Type -> MatchResult -> DsM MatchResult--- Do not warn about incomplete patterns--- Used for things like [ e | pat <- stuff ], where--- incomplete patterns are just fine-matchSinglePat (Var var) ctx (L _ pat) ty match_result-  = do { locn <- getSrcSpanDs-       ; matchCheck (DsMatchContext ctx locn)-                    [var] ty-                    [EqnInfo { eqn_pats = [pat], eqn_rhs  = match_result }] }--matchSinglePat scrut hs_ctx pat ty match_result-  = do { var <- selectSimpleMatchVarL pat-       ; match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result-       ; return (adjustMatchResult (bindNonRec var scrut) match_result') }-\end{code}---%************************************************************************-%*                                                                      *-                Pattern classification-%*                                                                      *-%************************************************************************--\begin{code}-data PatGroup-  = PgAny               -- Immediate match: variables, wildcards,-                        --                  lazy patterns-  | PgCon DataCon       -- Constructor patterns (incl list, tuple)-  | PgSyn PatSyn-  | PgLit Literal       -- Literal patterns-  | PgN   Literal       -- Overloaded literals-  | PgNpK Literal       -- n+k patterns-  | PgBang              -- Bang patterns-  | PgCo Type           -- Coercion patterns; the type is the type-                        --      of the pattern *inside*-  | PgView (LHsExpr Id) -- view pattern (e -> p):-                        -- the LHsExpr is the expression e-           Type         -- the Type is the type of p (equivalently, the result type of e)-  | PgOverloadedList--groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]]--- If the result is of form [g1, g2, g3],--- (a) all the (pg,eq) pairs in g1 have the same pg--- (b) none of the gi are empty--- The ordering of equations is unchanged-groupEquations dflags eqns-  = runs same_gp [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns]-  where-    same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool-    (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2--subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]--- Input is a particular group.  The result sub-groups the--- equations by with particular constructor, literal etc they match.--- Each sub-list in the result has the same PatGroup--- See Note [Take care with pattern order]-subGroup group-    = map reverse $ Map.elems $ foldl accumulate Map.empty group-  where-    accumulate pg_map (pg, eqn)-      = case Map.lookup pg pg_map of-          Just eqns -> Map.insert pg (eqn:eqns) pg_map-          Nothing   -> Map.insert pg [eqn]      pg_map--    -- pg_map :: Map a [EquationInfo]-    -- Equations seen so far in reverse order of appearance-\end{code}--Note [Take care with pattern order]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the subGroup function we must be very careful about pattern re-ordering,-Consider the patterns [ (True, Nothing), (False, x), (True, y) ]-Then in bringing together the patterns for True, we must not-swap the Nothing and y!---\begin{code}-sameGroup :: PatGroup -> PatGroup -> Bool--- Same group means that a single case expression--- or test will suffice to match both, *and* the order--- of testing within the group is insignificant.-sameGroup PgAny      PgAny      = True-sameGroup PgBang     PgBang     = True-sameGroup (PgCon _)  (PgCon _)  = True          -- One case expression-sameGroup (PgSyn p1) (PgSyn p2) = p1==p2-sameGroup (PgLit _)  (PgLit _)  = True          -- One case expression-sameGroup (PgN l1)   (PgN l2)   = l1==l2        -- Order is significant-sameGroup (PgNpK l1) (PgNpK l2) = l1==l2        -- See Note [Grouping overloaded literal patterns]-sameGroup (PgCo t1)  (PgCo t2)  = t1 `eqType` t2-        -- CoPats are in the same goup only if the type of the-        -- enclosed pattern is the same. The patterns outside the CoPat-        -- always have the same type, so this boils down to saying that-        -- the two coercions are identical.-sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2)-       -- ViewPats are in the same group iff the expressions-       -- are "equal"---conservatively, we use syntactic equality-sameGroup _          _          = False---- An approximation of syntactic equality used for determining when view--- exprs are in the same group.--- This function can always safely return false;--- but doing so will result in the application of the view function being repeated.------ Currently: compare applications of literals and variables---            and anything else that we can do without involving other---            HsSyn types in the recursion------ NB we can't assume that the two view expressions have the same type.  Consider---   f (e1 -> True) = ...---   f (e2 -> "hi") = ...-viewLExprEq :: (LHsExpr Id,Type) -> (LHsExpr Id,Type) -> Bool-viewLExprEq (e1,_) (e2,_) = lexp e1 e2-  where-    lexp :: LHsExpr Id -> LHsExpr Id -> Bool-    lexp e e' = exp (unLoc e) (unLoc e')--    ----------    exp :: HsExpr Id -> HsExpr Id -> Bool-    -- real comparison is on HsExpr's-    -- strip parens-    exp (HsPar (L _ e)) e'   = exp e e'-    exp e (HsPar (L _ e'))   = exp e e'-    -- because the expressions do not necessarily have the same type,-    -- we have to compare the wrappers-    exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e'-    exp (HsVar i) (HsVar i') =  i == i'-    -- the instance for IPName derives using the id, so this works if the-    -- above does-    exp (HsIPVar i) (HsIPVar i') = i == i'-    exp (HsOverLit l) (HsOverLit l') =-        -- Overloaded lits are equal if they have the same type-        -- and the data is the same.-        -- this is coarser than comparing the SyntaxExpr's in l and l',-        -- which resolve the overloading (e.g., fromInteger 1),-        -- because these expressions get written as a bunch of different variables-        -- (presumably to improve sharing)-        eqType (overLitType l) (overLitType l') && l == l'-    exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2'-    -- the fixities have been straightened out by now, so it's safe-    -- to ignore them?-    exp (OpApp l o _ ri) (OpApp l' o' _ ri') =-        lexp l l' && lexp o o' && lexp ri ri'-    exp (NegApp e n) (NegApp e' n') = lexp e e' && exp n n'-    exp (SectionL e1 e2) (SectionL e1' e2') =-        lexp e1 e1' && lexp e2 e2'-    exp (SectionR e1 e2) (SectionR e1' e2') =-        lexp e1 e1' && lexp e2 e2'-    exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) =-        eq_list tup_arg es1 es2-    exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') =-        lexp e e' && lexp e1 e1' && lexp e2 e2'--    -- Enhancement: could implement equality for more expressions-    --   if it seems useful-    -- But no need for HsLit, ExplicitList, ExplicitTuple,-    -- because they cannot be functions-    exp _ _  = False--    ----------    tup_arg (Present e1) (Present e2) = lexp e1 e2-    tup_arg (Missing t1) (Missing t2) = eqType t1 t2-    tup_arg _ _ = False--    ----------    wrap :: HsWrapper -> HsWrapper -> Bool-    -- Conservative, in that it demands that wrappers be-    -- syntactically identical and doesn't look under binders-    ---    -- Coarser notions of equality are possible-    -- (e.g., reassociating compositions,-    --        equating different ways of writing a coercion)-    wrap WpHole WpHole = True-    wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'-    wrap (WpCast co)       (WpCast co')        = co `eq_co` co'-    wrap (WpEvApp et1)     (WpEvApp et2)       = et1 `ev_term` et2-    wrap (WpTyApp t)       (WpTyApp t')        = eqType t t'-    -- Enhancement: could implement equality for more wrappers-    --   if it seems useful (lams and lets)-    wrap _ _ = False--    ----------    ev_term :: EvTerm -> EvTerm -> Bool-    ev_term (EvId a)       (EvId b)       = a==b-    ev_term (EvCoercion a) (EvCoercion b) = a `eq_co` b-    ev_term _ _ = False--    ----------    eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool-    eq_list _  []     []     = True-    eq_list _  []     (_:_)  = False-    eq_list _  (_:_)  []     = False-    eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys--    ----------    eq_co :: TcCoercion -> TcCoercion -> Bool-    -- Just some simple cases (should the r1 == r2 rather be an ASSERT?)-    eq_co (TcRefl r1 t1)             (TcRefl r2 t2)             = r1 == r2 && eqType t1 t2-    eq_co (TcCoVarCo v1)             (TcCoVarCo v2)             = v1==v2-    eq_co (TcSymCo co1)              (TcSymCo co2)              = co1 `eq_co` co2-    eq_co (TcTyConAppCo r1 tc1 cos1) (TcTyConAppCo r2 tc2 cos2) = r1 == r2 && tc1==tc2 && eq_list eq_co cos1 cos2-    eq_co _ _ = False--patGroup :: DynFlags -> Pat Id -> PatGroup-patGroup _      (WildPat {})                  = PgAny-patGroup _      (BangPat {})                  = PgBang-patGroup _      (ConPatOut { pat_con = con }) = case unLoc con of-    RealDataCon dcon -> PgCon dcon-    PatSynCon psyn -> PgSyn psyn-patGroup dflags (LitPat lit)                  = PgLit (hsLitKey dflags lit)-patGroup _      (NPat olit mb_neg _)          = PgN   (hsOverLitKey olit (isJust mb_neg))-patGroup _      (NPlusKPat _ olit _ _)        = PgNpK (hsOverLitKey olit False)-patGroup _      (CoPat _ p _)                 = PgCo  (hsPatType p) -- Type of innelexp pattern-patGroup _      (ViewPat expr p _)            = PgView expr (hsPatType (unLoc p))-patGroup _      (ListPat _ _ (Just _))        = PgOverloadedList-patGroup _      pat                           = pprPanic "patGroup" (ppr pat)-\end{code}--Note [Grouping overloaded literal patterns]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-WATCH OUT!  Consider--        f (n+1) = ...-        f (n+2) = ...-        f (n+1) = ...--We can't group the first and third together, because the second may match-the same thing as the first.  Same goes for *overloaded* literal patterns-        f 1 True = ...-        f 2 False = ...-        f 1 False = ...-If the first arg matches '1' but the second does not match 'True', we-cannot jump to the third equation!  Because the same argument might-match '2'!-Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.-
− src/Language/Haskell/Liquid/Desugar/Match.lhs-boot 
@@ -1,35 +0,0 @@-\begin{code}-module Language.Haskell.Liquid.Desugar.Match where-import Var      ( Id )-import TcType   ( Type )-import DsMonad  ( DsM, EquationInfo, MatchResult )-import CoreSyn  ( CoreExpr )-import HsSyn    ( LPat, HsMatchContext, MatchGroup, LHsExpr )-import Name     ( Name )--match   :: [Id]-        -> Type-        -> [EquationInfo]-        -> DsM MatchResult--matchWrapper-        :: HsMatchContext Name-        -> MatchGroup Id (LHsExpr Id)-        -> DsM ([Id], CoreExpr)--matchSimply-        :: CoreExpr-        -> HsMatchContext Name-        -> LPat Id-        -> CoreExpr-        -> CoreExpr-        -> DsM CoreExpr--matchSinglePat-        :: CoreExpr-        -> HsMatchContext Name-        -> LPat Id-        -> Type-        -> MatchResult-        -> DsM MatchResult-\end{code}
− src/Language/Haskell/Liquid/Desugar/MatchCon.lhs 
@@ -1,293 +0,0 @@-%-% (c) The University of Glasgow 2006-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998-%--Pattern-matching constructors--\begin{code}-{-# OPTIONS -fno-warn-tabs #-}--- The above warning supression flag is a temporary kludge.--- While working on this module you are encouraged to remove it and--- detab the module (please do the detabbing in a separate patch). See---     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces--- for details--module Language.Haskell.Liquid.Desugar.MatchCon ( matchConFamily, matchPatSyn ) where---- #include "HsVersions.h"--import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.Match	( match )--import HsSyn-import DsBinds-import ConLike-import DataCon-import PatSyn-import TcType-import DsMonad-import Language.Haskell.Liquid.Desugar.DsUtils-import MkCore   ( mkCoreLets )-import Util-import ListSetOps ( runs )-import Id-import NameEnv-import SrcLoc-import DynFlags-import Outputable-import Control.Monad(liftM)-\end{code}--We are confronted with the first column of patterns in a set of-equations, all beginning with constructors from one ``family'' (e.g.,-@[]@ and @:@ make up the @List@ ``family'').  We want to generate the-alternatives for a @Case@ expression.  There are several choices:-\begin{enumerate}-\item-Generate an alternative for every constructor in the family, whether-they are used in this set of equations or not; this is what the Wadler-chapter does.-\begin{description}-\item[Advantages:]-(a)~Simple.  (b)~It may also be that large sparsely-used constructor-families are mainly handled by the code for literals.-\item[Disadvantages:]-(a)~Not practical for large sparsely-used constructor families, e.g.,-the ASCII character set.  (b)~Have to look up a list of what-constructors make up the whole family.-\end{description}--\item-Generate an alternative for each constructor used, then add a default-alternative in case some constructors in the family weren't used.-\begin{description}-\item[Advantages:]-(a)~Alternatives aren't generated for unused constructors.  (b)~The-STG is quite happy with defaults.  (c)~No lookup in an environment needed.-\item[Disadvantages:]-(a)~A spurious default alternative may be generated.-\end{description}--\item-``Do it right:'' generate an alternative for each constructor used,-and add a default alternative if all constructors in the family-weren't used.-\begin{description}-\item[Advantages:]-(a)~You will get cases with only one alternative (and no default),-which should be amenable to optimisation.  Tuples are a common example.-\item[Disadvantages:]-(b)~Have to look up constructor families in TDE (as above).-\end{description}-\end{enumerate}--We are implementing the ``do-it-right'' option for now.  The arguments-to @matchConFamily@ are the same as to @match@; the extra @Int@-returned is the number of constructors in the family.--The function @matchConFamily@ is concerned with this-have-we-used-all-the-constructors? question; the local function-@match_cons_used@ does all the real work.-\begin{code}-matchConFamily :: [Id]-               -> Type-	       -> [[EquationInfo]]-	       -> DsM MatchResult--- Each group of eqns is for a single constructor-matchConFamily (var:vars) ty groups-  = do dflags <- getDynFlags-       alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups-       return (mkCoAlgCaseMatchResult dflags var ty alts)-  where-    toRealAlt alt = case alt_pat alt of-        RealDataCon dcon -> alt{ alt_pat = dcon }-        _ -> panic "matchConFamily: not RealDataCon"-matchConFamily [] _ _ = panic "matchConFamily []"--matchPatSyn :: [Id]-            -> Type-            -> [EquationInfo]-            -> DsM MatchResult-matchPatSyn (var:vars) ty eqns-  = do alt <- fmap toSynAlt $ matchOneConLike vars ty eqns-       return (mkCoSynCaseMatchResult var ty alt)-  where-    toSynAlt alt = case alt_pat alt of-        PatSynCon psyn -> alt{ alt_pat = psyn }-        _ -> panic "matchPatSyn: not PatSynCon"-matchPatSyn _ _ _ = panic "matchPatSyn []"--type ConArgPats = HsConDetails (LPat Id) (HsRecFields Id (LPat Id))--matchOneConLike :: [Id]-                -> Type-                -> [EquationInfo]-                -> DsM (CaseAlt ConLike)-matchOneConLike vars ty (eqn1 : eqns)	-- All eqns for a single constructor-  = do	{ arg_vars <- selectConMatchVars val_arg_tys args1-	 	-- Use the first equation as a source of -		-- suggestions for the new variables--	-- Divide into sub-groups; see Note [Record patterns]-        ; let groups :: [[(ConArgPats, EquationInfo)]]-	      groups = runs compatible_pats [ (pat_args (firstPat eqn), eqn) -	      	       	    	            | eqn <- eqn1:eqns ]--	; match_results <- mapM (match_group arg_vars) groups--        ; return $ MkCaseAlt{ alt_pat = con1,-                              alt_bndrs = tvs1 ++ dicts1 ++ arg_vars,-                              alt_wrapper = wrapper1,-                              alt_result = foldr1 combineMatchResults match_results } }-  where-    ConPatOut { pat_con = L _ con1, pat_arg_tys = arg_tys, pat_wrap = wrapper1,-	        pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }-	      = firstPat eqn1-    fields1 = case con1 of-        	RealDataCon dcon1 -> dataConFieldLabels dcon1-        	PatSynCon{}       -> []--    val_arg_tys = case con1 of-                    RealDataCon dcon1 -> dataConInstOrigArgTys dcon1 inst_tys-                    PatSynCon psyn1   -> patSynInstArgTys      psyn1 inst_tys-    inst_tys = -- ASSERT( tvs1 `equalLength` ex_tvs )-               arg_tys ++ mkTyVarTys tvs1-	-- dataConInstOrigArgTys takes the univ and existential tyvars-	-- and returns the types of the *value* args, which is what we want----     ex_tvs = case con1 of---                RealDataCon dcon1 -> dataConExTyVars dcon1---                PatSynCon psyn1   -> patSynExTyVars psyn1--    match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult-    -- All members of the group have compatible ConArgPats-    match_group arg_vars arg_eqn_prs-      = -- ASSERT( notNull arg_eqn_prs )-        do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs)-    	   ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs-    	   ; match_result <- match (group_arg_vars ++ vars) ty eqns'-    	   ; return (adjustMatchResult (foldr1 (.) wraps) match_result) }--    shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds, -					           pat_binds = bind, pat_args = args-					} : pats }))-      = do ds_bind <- dsTcEvBinds bind-           return ( wrapBinds (tvs `zip` tvs1)-                  . wrapBinds (ds  `zip` dicts1)-                  . mkCoreLets ds_bind-                  , eqn { eqn_pats = conArgPats val_arg_tys args ++ pats }-                  )-    shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)--    -- Choose the right arg_vars in the right order for this group-    -- Note [Record patterns]-    select_arg_vars arg_vars ((arg_pats, _) : _)-      | RecCon flds <- arg_pats-      , let rpats = rec_flds flds  -      , not (null rpats)     -- Treated specially; cf conArgPats-      = -- ASSERT2( length fields1 == length arg_vars, -        --          ppr con1 $$ ppr fields1 $$ ppr arg_vars )-        map lookup_fld rpats-      | otherwise-      = arg_vars-      where-        fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars-	lookup_fld rpat = lookupNameEnv_NF fld_var_env -		   	  		   (idName (unLoc (hsRecFieldId rpat)))-    select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"-matchOneConLike _ _ [] = panic "matchOneCon []"--------------------compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool--- Two constructors have compatible argument patterns if the number--- and order of sub-matches is the same in both cases-compatible_pats (RecCon flds1, _) (RecCon flds2, _) = same_fields flds1 flds2-compatible_pats (RecCon flds1, _) _                 = null (rec_flds flds1)-compatible_pats _                 (RecCon flds2, _) = null (rec_flds flds2)-compatible_pats _                 _                 = True -- Prefix or infix con--same_fields :: HsRecFields Id (LPat Id) -> HsRecFields Id (LPat Id) -> Bool-same_fields flds1 flds2 -  = all2 (\f1 f2 -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))-	 (rec_flds flds1) (rec_flds flds2)---------------------selectConMatchVars :: [Type] -> ConArgPats -> DsM [Id]-selectConMatchVars arg_tys (RecCon {})      = newSysLocalsDs arg_tys-selectConMatchVars _       (PrefixCon ps)   = selectMatchVars (map unLoc ps)-selectConMatchVars _       (InfixCon p1 p2) = selectMatchVars [unLoc p1, unLoc p2]--conArgPats :: [Type]	-- Instantiated argument types -			-- Used only to fill in the types of WildPats, which-			-- are probably never looked at anyway-	   -> ConArgPats-	   -> [Pat Id]-conArgPats _arg_tys (PrefixCon ps)   = map unLoc ps-conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2]-conArgPats  arg_tys (RecCon (HsRecFields { rec_flds = rpats }))-  | null rpats = map WildPat arg_tys-	-- Important special case for C {}, which can be used for a - 	-- datacon that isn't declared to have fields at all-  | otherwise  = map (unLoc . hsRecFieldArg) rpats-\end{code}--Note [Record patterns]-~~~~~~~~~~~~~~~~~~~~~~-Consider -	 data T = T { x,y,z :: Bool }--	 f (T { y=True, x=False }) = ...--We must match the patterns IN THE ORDER GIVEN, thus for the first-one we match y=True before x=False.  See Trac #246; or imagine -matching against (T { y=False, x=undefined }): should fail without-touching the undefined. --Now consider:--	 f (T { y=True, x=False }) = ...-	 f (T { x=True, y= False}) = ...--In the first we must test y first; in the second we must test x -first.  So we must divide even the equations for a single constructor-T into sub-goups, based on whether they match the same field in the-same order.  That's what the (runs compatible_pats) grouping.--All non-record patterns are "compatible" in this sense, because the-positional patterns (T a b) and (a `T` b) all match the arguments-in order.  Also T {} is special because it's equivalent to (T _ _).-Hence the (null rpats) checks here and there.---Note [Existentials in shift_con_pat]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-	data T = forall a. Ord a => T a (a->Int)--	f (T x f) True  = ...expr1...-	f (T y g) False = ...expr2..--When we put in the tyvars etc we get--	f (T a (d::Ord a) (x::a) (f::a->Int)) True =  ...expr1...-	f (T b (e::Ord b) (y::a) (g::a->Int)) True =  ...expr2...--After desugaring etc we'll get a single case:--	f = \t::T b::Bool -> -	    case t of-	       T a (d::Ord a) (x::a) (f::a->Int)) ->-	    case b of-		True  -> ...expr1...-		False -> ...expr2...--*** We have to substitute [a/b, d/e] in expr2! **-Hence-		False -> ....((/\b\(e:Ord b).expr2) a d)....--Originally I tried to use -	(\b -> let e = d in expr2) a -to do this substitution.  While this is "correct" in a way, it fails-Lint, because e::Ord b but d::Ord a.  -
− src/Language/Haskell/Liquid/Desugar/MatchLit.lhs 
@@ -1,468 +0,0 @@-%-% (c) The University of Glasgow 2006-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998-%--Pattern-matching literal patterns--\begin{code}-{-# LANGUAGE RankNTypes #-}--module Language.Haskell.Liquid.Desugar.MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey-                , tidyLitPat, tidyNPat-                , matchLiterals, matchNPlusKPats, matchNPats-                , warnAboutIdentities, warnAboutEmptyEnumerations -                ) where---- #include "HsVersions.h"--import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.Match  ( match )-import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr ( dsExpr )--import DsMonad-import Language.Haskell.Liquid.Desugar.DsUtils--import HsSyn--import Id-import CoreSyn-import MkCore-import TyCon-import DataCon-import TcHsSyn ( shortCutLit )-import TcType-import Name-import Type-import PrelNames-import TysWiredIn-import Literal-import SrcLoc-import Data.Ratio-import MonadUtils-import Outputable-import BasicTypes-import DynFlags-import Util-import FastString--\end{code}--%************************************************************************-%*                                                                      *-                Desugaring literals-        [used to be in DsExpr, but DsMeta needs it,-         and it's nice to avoid a loop]-%*                                                                      *-%************************************************************************--We give int/float literals type @Integer@ and @Rational@, respectively.-The typechecker will (presumably) have put \tr{from{Integer,Rational}s}-around them.--ToDo: put in range checks for when converting ``@i@''-(or should that be in the typechecker?)--For numeric literals, we try to detect there use at a standard type-(@Int@, @Float@, etc.) are directly put in the right constructor.-[NB: down with the @App@ conversion.]--See also below where we look for @DictApps@ for \tr{plusInt}, etc.--\begin{code}-dsLit :: HsLit -> DsM CoreExpr-dsLit (HsStringPrim s) = return (Lit (MachStr s))-dsLit (HsCharPrim   c) = return (Lit (MachChar c))-dsLit (HsIntPrim    i) = return (Lit (MachInt i))-dsLit (HsWordPrim   w) = return (Lit (MachWord w))-dsLit (HsInt64Prim  i) = return (Lit (MachInt64 i))-dsLit (HsWord64Prim w) = return (Lit (MachWord64 w))-dsLit (HsFloatPrim  f) = return (Lit (MachFloat (fl_value f)))-dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d)))--dsLit (HsChar c)       = return (mkCharExpr c)-dsLit (HsString str)   = mkStringExprFS str-dsLit (HsInteger i _)  = mkIntegerExpr i-dsLit (HsInt i)        = do dflags <- getDynFlags-                            return (mkIntExpr dflags i)--dsLit (HsRat r ty) = do-   num   <- mkIntegerExpr (numerator (fl_value r))-   denom <- mkIntegerExpr (denominator (fl_value r))-   return (mkConApp ratio_data_con [Type integer_ty, num, denom])-  where-    (ratio_data_con, integer_ty)-        = case tcSplitTyConApp ty of-                (tycon, [i_ty]) -> -- ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)-                                   (head (tyConDataCons tycon), i_ty)-                x -> pprPanic "dsLit" (ppr x)--dsOverLit :: HsOverLit Id -> DsM CoreExpr-dsOverLit lit = do { dflags <- getDynFlags-                   ; warnAboutOverflowedLiterals dflags lit-                   ; dsOverLit' dflags lit }--dsOverLit' :: DynFlags -> HsOverLit Id -> DsM CoreExpr--- Post-typechecker, the SyntaxExpr field of an OverLit contains--- (an expression for) the literal value itself-dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable-                           , ol_witness = witness, ol_type = ty })-  | not rebindable-  , Just expr <- shortCutLit dflags val ty = dsExpr expr        -- Note [Literal short cut]-  | otherwise                              = dsExpr witness-\end{code}--Note [Literal short cut]-~~~~~~~~~~~~~~~~~~~~~~~~-The type checker tries to do this short-cutting as early as possible, but-because of unification etc, more information is available to the desugarer.-And where it's possible to generate the correct literal right away, it's-much better to do so.---%************************************************************************-%*                                                                      *-                 Warnings about overflowed literals-%*                                                                      *-%************************************************************************--Warn about functions like toInteger, fromIntegral, that convert-between one type and another when the to- and from- types are the-same.  Then it's probably (albeit not definitely) the identity--\begin{code}-warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM ()-warnAboutIdentities dflags (Var conv_fn) type_of_conv-  | wopt Opt_WarnIdentities dflags-  , idName conv_fn `elem` conversionNames-  , Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv-  , arg_ty `eqType` res_ty  -- So we are converting  ty -> ty-  = warnDs (vcat [ ptext (sLit "Call of") <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv-                 , nest 2 $ ptext (sLit "can probably be omitted")-                 , parens (ptext (sLit "Use -fno-warn-identities to suppress this message"))-           ])-warnAboutIdentities _ _ _ = return ()--conversionNames :: [Name]-conversionNames-  = [ toIntegerName, toRationalName-    , fromIntegralName, realToFracName ]- -- We can't easily add fromIntegerName, fromRationalName,- -- because they are generated by literals-\end{code}--\begin{code}-warnAboutOverflowedLiterals :: DynFlags -> HsOverLit Id -> DsM ()-warnAboutOverflowedLiterals _ _---  | wopt Opt_WarnOverflowedLiterals dflags---  , Just (i, tc) <- getIntegralLit lit---   = if      tc == intTyConName    then check i tc (undefined :: Int)---     else if tc == int8TyConName   then check i tc (undefined :: Int8)---     else if tc == int16TyConName  then check i tc (undefined :: Int16)---     else if tc == int32TyConName  then check i tc (undefined :: Int32)---     else if tc == int64TyConName  then check i tc (undefined :: Int64)---     else if tc == wordTyConName   then check i tc (undefined :: Word)---     else if tc == word8TyConName  then check i tc (undefined :: Word8)---     else if tc == word16TyConName then check i tc (undefined :: Word16)---     else if tc == word32TyConName then check i tc (undefined :: Word32)---     else if tc == word64TyConName then check i tc (undefined :: Word64)---     else return ()--- -  | otherwise = return ()---   where---     check :: forall a. (Bounded a, Integral a) => Integer -> Name -> a -> DsM ()---     check i tc _proxy---       = when (i < minB || i > maxB) $ do---         warnDs (vcat [ ptext (sLit "Literal") <+> integer i---                        <+> ptext (sLit "is out of the") <+> ppr tc <+> ptext (sLit "range")---                        <+> integer minB <> ptext (sLit "..") <> integer maxB---                      , sug ])---       where---         minB = toInteger (minBound :: a)---         maxB = toInteger (maxBound :: a)---         sug | minB == -i   -- Note [Suggest NegativeLiterals]---             , i > 0---             , not (xopt Opt_NegativeLiterals dflags)---             = ptext (sLit "If you are trying to write a large negative literal, use NegativeLiterals")---             | otherwise = empty-\end{code}--Note [Suggest NegativeLiterals]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If you write-  x :: Int8-  x = -128-it'll parse as (negate 128), and overflow.  In this case, suggest NegativeLiterals.-We get an erroneous suggestion for-  x = 128-but perhaps that does not matter too much.--\begin{code}-warnAboutEmptyEnumerations :: DynFlags -> LHsExpr Id -> Maybe (LHsExpr Id) -> LHsExpr Id -> DsM ()--- Warns about [2,3 .. 1] which returns the empty list--- Only works for integral types, not floating point-warnAboutEmptyEnumerations _ _ _ _---   | wopt Opt_WarnEmptyEnumerations dflags---   , Just (from,tc) <- getLHsIntegralLit fromExpr---   , Just mThn      <- traverse getLHsIntegralLit mThnExpr---   , Just (to,_)    <- getLHsIntegralLit toExpr---   , let check :: forall a. (Enum a, Num a) => a -> DsM ()---         check _proxy---           = when (null enumeration) $---             warnDs (ptext (sLit "Enumeration is empty"))---           where---             enumeration :: [a]---             enumeration = case mThn of---                             Nothing      -> [fromInteger from                    .. fromInteger to]---                             Just (thn,_) -> [fromInteger from, fromInteger thn   .. fromInteger to]--- ---   = if      tc == intTyConName    then check (undefined :: Int)---     else if tc == int8TyConName   then check (undefined :: Int8)---     else if tc == int16TyConName  then check (undefined :: Int16)---     else if tc == int32TyConName  then check (undefined :: Int32)---     else if tc == int64TyConName  then check (undefined :: Int64)---     else if tc == wordTyConName   then check (undefined :: Word)---     else if tc == word8TyConName  then check (undefined :: Word8)---     else if tc == word16TyConName then check (undefined :: Word16)---     else if tc == word32TyConName then check (undefined :: Word32)---     else if tc == word64TyConName then check (undefined :: Word64)---     else return ()--- -  | otherwise = return ()-{--getLHsIntegralLit :: LHsExpr Id -> Maybe (Integer, Name)--- See if the expression is an Integral literal--- Remember to look through automatically-added tick-boxes! (Trac #8384)-getLHsIntegralLit (L _ (HsPar e))            = getLHsIntegralLit e-getLHsIntegralLit (L _ (HsTick _ e))         = getLHsIntegralLit e-getLHsIntegralLit (L _ (HsBinTick _ _ e))    = getLHsIntegralLit e-getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit-getLHsIntegralLit _ = Nothing--getIntegralLit :: HsOverLit Id -> Maybe (Integer, Name)-getIntegralLit (OverLit { ol_val = HsIntegral i, ol_type = ty })-  | Just tc <- tyConAppTyCon_maybe ty-  = Just (i, tyConName tc)-getIntegralLit _ = Nothing--}-\end{code}---%************************************************************************-%*                                                                      *-        Tidying lit pats-%*                                                                      *-%************************************************************************--\begin{code}-tidyLitPat :: HsLit -> Pat Id--- Result has only the following HsLits:---      HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim---      HsDoublePrim, HsStringPrim, HsString---  * HsInteger, HsRat, HsInt can't show up in LitPats---  * We get rid of HsChar right here-tidyLitPat (HsChar c) = unLoc (mkCharLitPat c)-tidyLitPat (HsString s)-  | lengthFS s <= 1     -- Short string literals only-  = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] [charTy])-                  (mkNilPat charTy) (unpackFS s)-        -- The stringTy is the type of the whole pattern, not-        -- the type to instantiate (:) or [] with!-tidyLitPat lit = LitPat lit-------------------tidyNPat :: (HsLit -> Pat Id)   -- How to tidy a LitPat-                 -- We need this argument because tidyNPat is called-                 -- both by Match and by Check, but they tidy LitPats-                 -- slightly differently; and we must desugar-                 -- literals consistently (see Trac #5117)-         -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id-         -> Pat Id-tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _-        -- False: Take short cuts only if the literal is not using rebindable syntax-        ---        -- Once that is settled, look for cases where the type of the-        -- entire overloaded literal matches the type of the underlying literal,-        -- and in that case take the short cut-        -- NB: Watch out for weird cases like Trac #3382-        --        f :: Int -> Int-        --        f "blah" = 4-        --     which might be ok if we hvae 'instance IsString Int'-        ----  | isIntTy ty,    Just int_lit <- mb_int_lit = mk_con_pat intDataCon    (HsIntPrim    int_lit)-  | isWordTy ty,   Just int_lit <- mb_int_lit = mk_con_pat wordDataCon   (HsWordPrim   int_lit)-  | isFloatTy ty,  Just rat_lit <- mb_rat_lit = mk_con_pat floatDataCon  (HsFloatPrim  rat_lit)-  | isDoubleTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat doubleDataCon (HsDoublePrim rat_lit)-  | isStringTy ty, Just str_lit <- mb_str_lit = tidy_lit_pat (HsString str_lit)-  where-    mk_con_pat :: DataCon -> HsLit -> Pat Id-    mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] [])--    mb_int_lit :: Maybe Integer-    mb_int_lit = case (mb_neg, val) of-                   (Nothing, HsIntegral i) -> Just i-                   (Just _,  HsIntegral i) -> Just (-i)-                   _ -> Nothing--    mb_rat_lit :: Maybe FractionalLit-    mb_rat_lit = case (mb_neg, val) of-                   (Nothing, HsIntegral   i) -> Just (integralFractionalLit (fromInteger i))-                   (Just _,  HsIntegral   i) -> Just (integralFractionalLit (fromInteger (-i)))-                   (Nothing, HsFractional f) -> Just f-                   (Just _, HsFractional f)  -> Just (negateFractionalLit f)-                   _ -> Nothing--    mb_str_lit :: Maybe FastString-    mb_str_lit = case (mb_neg, val) of-                   (Nothing, HsIsString s) -> Just s-                   _ -> Nothing--tidyNPat _ over_lit mb_neg eq-  = NPat over_lit mb_neg eq-\end{code}---%************************************************************************-%*                                                                      *-                Pattern matching on LitPat-%*                                                                      *-%************************************************************************--\begin{code}-matchLiterals :: [Id]-              -> Type                   -- Type of the whole case expression-              -> [[EquationInfo]]       -- All PgLits-              -> DsM MatchResult--matchLiterals (var:vars) ty sub_groups-  = -- ASSERT( notNull sub_groups && all notNull sub_groups )-    do  {       -- Deal with each group-        ; alts <- mapM match_group sub_groups--                -- Combine results.  For everything except String-                -- we can use a case expression; for String we need-                -- a chain of if-then-else-        ; if isStringTy (idType var) then-            do  { eq_str <- dsLookupGlobalId eqStringName-                ; mrs <- mapM (wrap_str_guard eq_str) alts-                ; return (foldr1 combineMatchResults mrs) }-          else-            return (mkCoPrimCaseMatchResult var ty alts)-        }-  where-    match_group :: [EquationInfo] -> DsM (Literal, MatchResult)-    match_group eqns-        = do dflags <- getDynFlags-             let LitPat hs_lit = firstPat (head eqns)-             match_result <- match vars ty (shiftEqns eqns)-             return (hsLitKey dflags hs_lit, match_result)--    wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult-        -- Equality check for string literals-    wrap_str_guard eq_str (MachStr s, mr)-        = do { -- We now have to convert back to FastString. Perhaps there-               -- should be separate MachBytes and MachStr constructors?-               s'     <- liftIO $ mkFastStringByteString s-             ; lit    <- mkStringExprFS s'-             ; let pred = mkApps (Var eq_str) [Var var, lit]-             ; return (mkGuardedMatchResult pred mr) }-    wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)--matchLiterals [] _ _ = panic "matchLiterals []"------------------------------hsLitKey :: DynFlags -> HsLit -> Literal--- Get a Core literal to use (only) a grouping key--- Hence its type doesn't need to match the type of the original literal---      (and doesn't for strings)--- It only works for primitive types and strings;--- others have been removed by tidy-hsLitKey dflags (HsIntPrim     i) = mkMachInt  dflags i-hsLitKey dflags (HsWordPrim    w) = mkMachWord dflags w-hsLitKey _      (HsInt64Prim   i) = mkMachInt64  i-hsLitKey _      (HsWord64Prim  w) = mkMachWord64 w-hsLitKey _      (HsCharPrim    c) = MachChar   c-hsLitKey _      (HsStringPrim  s) = MachStr    s-hsLitKey _      (HsFloatPrim   f) = MachFloat  (fl_value f)-hsLitKey _      (HsDoublePrim  d) = MachDouble (fl_value d)-hsLitKey _      (HsString s)      = MachStr    (fastStringToByteString s)-hsLitKey _      l                 = pprPanic "hsLitKey" (ppr l)------------------------------hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal--- Ditto for HsOverLit; the boolean indicates to negate-hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg------------------------------litValKey :: OverLitVal -> Bool -> Literal-litValKey (HsIntegral i)   False = MachInt i-litValKey (HsIntegral i)   True  = MachInt (-i)-litValKey (HsFractional r) False = MachFloat (fl_value r)-litValKey (HsFractional r) True  = MachFloat (negate (fl_value r))-litValKey (HsIsString s)   _   = {- ASSERT( not neg) -} MachStr (fastStringToByteString s)-\end{code}--%************************************************************************-%*                                                                      *-                Pattern matching on NPat-%*                                                                      *-%************************************************************************--\begin{code}-matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult-matchNPats (var:vars) ty (eqn1:eqns)    -- All for the same literal-  = do  { let NPat lit mb_neg eq_chk = firstPat eqn1-        ; lit_expr <- dsOverLit lit-        ; neg_lit <- case mb_neg of-                            Nothing -> return lit_expr-                            Just neg -> do { neg_expr <- dsExpr neg-                                           ; return (App neg_expr lit_expr) }-        ; eq_expr <- dsExpr eq_chk-        ; let pred_expr = mkApps eq_expr [Var var, neg_lit]-        ; match_result <- match vars ty (shiftEqns (eqn1:eqns))-        ; return (mkGuardedMatchResult pred_expr match_result) }-matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))-\end{code}---%************************************************************************-%*                                                                      *-                Pattern matching on n+k patterns-%*                                                                      *-%************************************************************************--For an n+k pattern, we use the various magic expressions we've been given.-We generate:-\begin{verbatim}-    if ge var lit then-        let n = sub var lit-        in  <expr-for-a-successful-match>-    else-        <try-next-pattern-or-whatever>-\end{verbatim}---\begin{code}-matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult--- All NPlusKPats, for the *same* literal k-matchNPlusKPats (var:vars) ty (eqn1:eqns)-  = do  { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1-        ; ge_expr     <- dsExpr ge-        ; minus_expr  <- dsExpr minus-        ; lit_expr    <- dsOverLit lit-        ; let pred_expr   = mkApps ge_expr [Var var, lit_expr]-              minusk_expr = mkApps minus_expr [Var var, lit_expr]-              (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)-        ; match_result <- match vars ty eqns'-        ; return  (mkGuardedMatchResult pred_expr               $-                   mkCoLetMatchResult (NonRec n1 minusk_expr)   $-                   adjustMatchResult (foldr1 (.) wraps)         $-                   match_result) }-  where-    shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })-        = (wrapBind n n1, eqn { eqn_pats = pats })-        -- The wrapBind is a no-op for the first equation-    shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)--matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns))-\end{code}
src/Language/Haskell/Liquid/Desugar710/Check.hs view
@@ -11,6 +11,7 @@  -- #include "HsVersions.h" +import Prelude hiding (error) import HsSyn import TcHsSyn import Language.Haskell.Liquid.Desugar710.DsUtils
src/Language/Haskell/Liquid/Desugar710/Coverage.hs view
@@ -7,6 +7,7 @@  module Language.Haskell.Liquid.Desugar710.Coverage (addTicksToBinds, hpcInitCode) where +import Prelude hiding (error) import Type import HsSyn import Module
src/Language/Haskell/Liquid/Desugar710/Desugar.hs view
@@ -10,6 +10,7 @@  module Language.Haskell.Liquid.Desugar710.Desugar ( deSugarWithLoc, deSugar, deSugarExpr ) where +import Prelude hiding (error) import DynFlags import HscTypes import HsSyn@@ -66,7 +67,7 @@ deSugarWithLoc, deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts) -- Can modify PCS by faulting in more declarations -deSugarWithLoc = deSugar +deSugarWithLoc = deSugar  deSugar hsc_env         mod_loc
src/Language/Haskell/Liquid/Desugar710/DsArrows.hs view
@@ -33,6 +33,7 @@ import CoreUtils import MkCore import Language.Haskell.Liquid.Desugar710.DsBinds (dsHsWrapper)+import qualified Language.Haskell.Liquid.Types.Errors as Err  import Name import Var@@ -1084,7 +1085,7 @@ -- Balanced fold of a non-empty list.  foldb :: (a -> a -> a) -> [a] -> a-foldb _ [] = error "foldb of empty list"+foldb _ [] = Err.panic Nothing "foldb of empty list" foldb _ [x] = x foldb f xs = foldb f (fold_pairs xs)   where
src/Language/Haskell/Liquid/Desugar710/DsBinds.hs view
@@ -21,6 +21,7 @@ import {-# SOURCE #-}   Language.Haskell.Liquid.Desugar710.DsExpr( dsLExpr ) import {-# SOURCE #-}   Language.Haskell.Liquid.Desugar710.Match( matchWrapper ) +import Prelude hiding (error) import DsMonad import Language.Haskell.Liquid.Desugar710.DsGRHSs import Language.Haskell.Liquid.Desugar710.DsUtils
src/Language/Haskell/Liquid/Desugar710/DsCCall.hs view
@@ -17,7 +17,7 @@  -- #include "HsVersions.h" -+import Prelude hiding (error) import CoreSyn  import DsMonad@@ -42,7 +42,6 @@ import VarSet import DynFlags import Outputable-import Util  import Data.Maybe
src/Language/Haskell/Liquid/Desugar710/DsExpr.hs view
@@ -12,6 +12,7 @@  -- #include "HsVersions.h" +import Prelude hiding (error) import Language.Haskell.Liquid.Desugar710.Match import Language.Haskell.Liquid.Desugar710.MatchLit import Language.Haskell.Liquid.Desugar710.DsBinds@@ -23,7 +24,7 @@ import Name import NameEnv import FamInstEnv( topNormaliseType )-+import Language.Haskell.Liquid.Types.Errors (impossible)  import HsSyn @@ -190,7 +191,7 @@  dsLExpr :: LHsExpr Id -> DsM CoreExpr -dsLExpr (L loc e) +dsLExpr (L loc e)   = do ce <- putSrcSpanDs loc $ dsExpr e        m  <- getModule        return $ Tick (srcSpanTick m loc) ce@@ -299,7 +300,7 @@        ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)                 -- The reverse is because foldM goes left-to-right -       ; return $ mkCoreLams lam_vars $ +       ; return $ mkCoreLams lam_vars $                   mkConApp (tupleCon (boxityNormalTupleSort boxity) (length tup_args))                            (map (Type . exprType) args ++ args) } @@ -899,7 +900,7 @@        ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)        ; extractMatchResult match (App fail_op' fail_msg) }   | otherwise-  = extractMatchResult match (error "It can't fail")+  = extractMatchResult match (impossible Nothing "It can't fail")  mk_fail_msg :: DynFlags -> Located e -> String mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
src/Language/Haskell/Liquid/Desugar710/DsForeign.hs view
@@ -18,7 +18,7 @@  -- #include "HsVersions.h" import TcRnMonad        -- temp-+import Prelude hiding (error) import TypeRep  import CoreSyn
src/Language/Haskell/Liquid/Desugar710/DsGRHSs.hs view
@@ -14,7 +14,7 @@  import {-# SOURCE #-} Language.Haskell.Liquid.Desugar710.DsExpr  ( dsLExpr, dsLocalBinds ) import {-# SOURCE #-} Language.Haskell.Liquid.Desugar710.Match   ( matchSinglePat )-+import Prelude hiding (error) import HsSyn import MkCore import CoreSyn
src/Language/Haskell/Liquid/Desugar710/DsListComp.hs view
@@ -14,6 +14,7 @@  import {-# SOURCE #-} Language.Haskell.Liquid.Desugar710.DsExpr ( dsExpr, dsLExpr, dsLocalBinds ) +import Prelude hiding (error) import HsSyn import TcHsSyn import CoreSyn@@ -21,6 +22,7 @@  import DsMonad          -- the monadery used in the desugarer import Language.Haskell.Liquid.Desugar710.DsUtils+import Language.Haskell.Liquid.Types.Errors (impossible)  import DynFlags import CoreUtils@@ -817,7 +819,7 @@              ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)              ; extractMatchResult match (App fail_op' fail_msg) }       | otherwise-        = extractMatchResult match (error "It can't fail")+        = extractMatchResult match (impossible Nothing "It can't fail")      mk_fail_msg :: DynFlags -> Located e -> String     mk_fail_msg dflags pat
src/Language/Haskell/Liquid/Desugar710/DsMeta.hs view
@@ -28,7 +28,7 @@ -- #include "HsVersions.h"  import Language.Haskell.Liquid.Desugar710.DsExpr ( dsExpr )-+import Prelude hiding (error) import Language.Haskell.Liquid.Desugar710.MatchLit import DsMonad @@ -912,7 +912,7 @@ repTy (HsTyLit lit) = do                         lit' <- repTyLit lit                         repTLit lit'-                          + repTy ty                      = notHandled "Exotic form of type" (ppr ty)  repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
src/Language/Haskell/Liquid/Desugar710/DsUtils.hs view
@@ -42,6 +42,7 @@  import {-# SOURCE #-}   Language.Haskell.Liquid.Desugar710.Match ( matchSimply ) +import Prelude hiding (error) import HsSyn import TcHsSyn import Coercion( Coercion, isReflCo )@@ -49,6 +50,7 @@ import CoreSyn import DsMonad import {-# SOURCE #-} Language.Haskell.Liquid.Desugar710.DsExpr ( dsLExpr )+import Language.Haskell.Liquid.Types.Errors (impossible)  import CoreUtils import MkCore@@ -192,7 +194,7 @@  extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr extractMatchResult (MatchResult CantFail match_fn) _-  = match_fn (error "It can't fail!")+  = match_fn (impossible Nothing "It can't fail!")  extractMatchResult (MatchResult CanFail match_fn) fail_expr = do     (fail_bind, if_it_fails) <- mkFailurePair fail_expr
src/Language/Haskell/Liquid/Desugar710/HscMain.hs view
@@ -29,8 +29,8 @@ module Language.Haskell.Liquid.Desugar710.HscMain (hscDesugarWithLoc) where  import Language.Haskell.Liquid.Desugar710.Desugar (deSugarWithLoc)--import Module +import Prelude hiding (error)+import Module import Lexer import TcRnMonad @@ -58,7 +58,7 @@ throwErrors :: ErrorMessages -> Hsc a throwErrors = liftIO . throwIO . mkSrcErr --- +-- -- | Convert a typechecked module to Core hscDesugarWithLoc :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts hscDesugarWithLoc hsc_env mod_summary tc_result =
src/Language/Haskell/Liquid/Desugar710/Match.hs view
@@ -13,7 +13,7 @@ -- #include "HsVersions.h"  import {-#SOURCE#-} Language.Haskell.Liquid.Desugar710.DsExpr (dsLExpr, dsExpr)-+import Prelude hiding (error) import DynFlags import HsSyn import TcHsSyn
src/Language/Haskell/Liquid/Desugar710/MatchCon.hs view
@@ -13,7 +13,7 @@ -- #include "HsVersions.h"  import {-# SOURCE #-} Language.Haskell.Liquid.Desugar710.Match     ( match )-+import Prelude hiding (error) import HsSyn import DsBinds import ConLike
src/Language/Haskell/Liquid/Desugar710/MatchLit.hs view
@@ -19,7 +19,7 @@  import {-# SOURCE #-} Language.Haskell.Liquid.Desugar710.Match  ( match ) import {-# SOURCE #-} Language.Haskell.Liquid.Desugar710.DsExpr ( dsExpr )-+import Prelude hiding (error) import DsMonad import Language.Haskell.Liquid.Desugar710.DsUtils
− src/Language/Haskell/Liquid/Dictionaries.hs 
@@ -1,65 +0,0 @@-module Language.Haskell.Liquid.Dictionaries (-    makeDictionaries-  , makeDictionary--  , dfromList-  , dmapty-  , dmap-  , dinsert-  , dlookup-  , dhasinfo-  ) where--import Control.Applicative      ((<$>))--import Var---import Language.Fixpoint.Names      (dropModuleNames)-import Language.Fixpoint.Types-import Language.Fixpoint.Misc--import Language.Haskell.Liquid.GhcMisc ()-import Language.Haskell.Liquid.Types--import qualified Data.HashMap.Strict as M-import Language.Haskell.Liquid.PrettyPrint ()--makeDictionaries :: [RInstance SpecType] -> DEnv Symbol SpecType-makeDictionaries = DEnv . M.fromList . map makeDictionary---makeDictionary :: RInstance SpecType -> (Symbol, M.HashMap Symbol SpecType)-makeDictionary (RI c t xts) = (makeDictionaryName c t, M.fromList (mapFst val <$> xts))--makeDictionaryName :: Located Symbol -> SpecType -> Symbol-makeDictionaryName t (RApp c _ _ _) = symbol ("$f" ++ (symbolString $ val t) ++ c')-  where-        c' = symbolString (dropModuleNames $ symbol $ rtc_tc c)--makeDictionaryName _ _              = errorstar "makeDictionaryName: called with invalid type"---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- Dictionay Environment ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------dfromList :: [(Var, M.HashMap Symbol t)] -> DEnv Var t-dfromList = DEnv . M.fromList--dmapty :: (a -> b) -> DEnv v a -> DEnv v b-dmapty f (DEnv e) = DEnv (M.map (M.map f) e)--dmap f xts = M.map f xts--dinsert (DEnv denv) x xts = DEnv $ M.insert x xts denv--dlookup (DEnv denv) x     = M.lookup x denv---dhasinfo Nothing _    = Nothing-dhasinfo (Just xts) x = M.lookup x' xts-  where-     x' = (dropModuleNames $ symbol $ show x)
− src/Language/Haskell/Liquid/DiffCheck.hs 
@@ -1,459 +0,0 @@--- | This module contains the code for Incremental checking, which finds the---   part of a target file (the subset of the @[CoreBind]@ that have been---   modified since it was last checked, as determined by a diff against---   a saved version of the file.--{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}--module Language.Haskell.Liquid.DiffCheck (--   -- * Changed binders + Unchanged Errors-     DiffCheck (..)--   -- * Use previously saved info to generate DiffCheck target-   , slice--   -- * Use target binders to generate DiffCheck target-   , thin--   -- * Save current information for next time-   , saveResult--   )-   where---- import            Debug.Trace (trace)-import            Control.Applicative          ((<$>), (<*>))-import            Data.Aeson-import qualified  Data.Text as T-import            Data.Algorithm.Diff-import            Data.Monoid                   (mempty)-import            Data.Maybe                    (listToMaybe, mapMaybe, fromMaybe)-import            Data.Hashable-import qualified  Data.IntervalMap.FingerTree as IM-import            CoreSyn                       hiding (sourceName)-import            Name-import            SrcLoc hiding (Located)-import            Var-import qualified  Data.HashSet                  as S-import qualified  Data.HashMap.Strict           as M-import qualified  Data.List                     as L-import            System.Directory                (copyFile, doesFileExist)-import            Language.Fixpoint.Misc          (mkGraph)-import            Language.Fixpoint.Types         (FixResult (..), Located (..))-import            Language.Fixpoint.Files-import            Language.Haskell.Liquid.Types   (SpecType, GhcSpec (..), AnnInfo (..), DataConP (..), Error, TError (..), Output (..))-import            Language.Haskell.Liquid.GhcMisc-import            Language.Haskell.Liquid.Visitors-import            Language.Haskell.Liquid.Errors   ()-import            Text.Parsec.Pos                  (sourceName, sourceLine, sourceColumn, SourcePos, newPos)-import            Text.PrettyPrint.HughesPJ        (text, render, Doc)---import qualified  Data.ByteString               as B-import qualified  Data.ByteString.Lazy          as LB------------------------------------------------------------------------------- Data Types ----------------------------------------------------------------------------------------------------------------------------------------- | Main type of value returned for diff-check.-data DiffCheck = DC { newBinds  :: [CoreBind]-                    , oldOutput :: !(Output Doc)-                    , newSpec   :: !GhcSpec-                    }---- | Variable definitions-data Def  = D { start  :: Int -- ^ line at which binder definition starts-              , end    :: Int -- ^ line at which binder definition ends-              , binder :: Var -- ^ name of binder-              }-            deriving (Eq, Ord)---- | Variable dependencies "call-graph"-type Deps = M.HashMap Var (S.HashSet Var)---- | Map from saved-line-num ---> current-line-num-type LMap   = IM.IntervalMap Int Int---- | Intervals of line numbers that have been re-checked-type ChkItv = IM.IntervalMap Int ()--instance Show Def where-  show (D i j x) = showPpr x ++ " start: " ++ show i ++ " end: " ++ show j-------------------------------------------------------------------------------- | `slice` returns a subset of the @[CoreBind]@ of the input `target`---    file which correspond to top-level binders whose code has changed---    and their transitive dependencies.---------------------------------------------------------------------------slice :: FilePath -> [CoreBind] -> GhcSpec -> IO (Maybe DiffCheck)---------------------------------------------------------------------------slice target cbs sp = ifM (doesFileExist saved) dc (return Nothing)-  where-    saved           = extFileName Saved target-    dc              = sliceSaved target saved cbs sp--sliceSaved :: FilePath -> FilePath -> [CoreBind] -> GhcSpec -> IO (Maybe DiffCheck)-sliceSaved target saved cbs sp-  = do (is, lm) <- lineDiff target saved-       res      <- loadResult target-       return    $ sliceSaved' is lm (DC cbs res sp)--sliceSaved' :: [Int] -> LMap -> DiffCheck -> Maybe DiffCheck-sliceSaved' is lm (DC cbs res sp)-  | globalDiff is sp = Nothing-  | otherwise        = Just $ DC cbs' res' sp'-  where-    cbs'             = thinWith sigs cbs $ diffVars is dfs-    sigs             = S.fromList $ M.keys sigm-    sigm             = sigVars is sp-    res'             = adjustOutput lm cm res-    cm               = checkedItv chDfs-    dfs              = coreDefs cbs ++ specDefs sp-    chDfs            = coreDefs cbs'-    sp'              = assumeSpec sigm sp---- Add the specified signatures for vars-with-preserved-sigs,--- whose bodies have been pruned from [CoreBind] into the "assumes"-assumeSpec :: M.HashMap Var (Located SpecType) -> GhcSpec -> GhcSpec-assumeSpec sigm sp = sp { asmSigs = M.toList $ M.union sigm assm }-  where-    assm           = M.fromList $ asmSigs sp-    -- sigm'       = trace ("INCCHECK: sigm = " ++ show zs) sigm-    -- zs          = M.keys sigm--diffVars :: [Int] -> [Def] -> [Var]-diffVars ls defs'    = -- tracePpr ("INCCHECK: diffVars lines = " ++ show ls ++ " defs= " ++ show defs) $-                       go (L.sort ls) defs-  where-    defs             = L.sort defs'-    go _      []     = []-    go []     _      = []-    go (i:is) (d:ds)-      | i < start d  = go is (d:ds)-      | i > end d    = go (i:is) ds-      | otherwise    = binder d : go (i:is) ds--sigVars :: [Int] -> GhcSpec -> M.HashMap Var (Located SpecType)-sigVars ls sp = M.fromList $ filter (ok . snd) $ specSigs sp-  where-    ok        = not . isDiff ls--globalDiff :: [Int] -> GhcSpec -> Bool-globalDiff ls sp = measDiff || invsDiff || dconsDiff-  where-    measDiff  = any (isDiff ls) (snd  <$> meas sp)-    invsDiff  = any (isDiff ls) (invariants   sp)-    dconsDiff = any (isDiff ls) (dloc . snd <$> dconsP sp)-    dloc dc   = Loc (dc_loc dc) (dc_locE dc) ()--isDiff :: [Int] -> Located a -> Bool-isDiff ls x = any hits ls-  where-    hits i  = line x <= i && i <= lineE x------------------------------------------------------------------------------ | @thin@ returns a subset of the @[CoreBind]@ given which correspond---   to those binders that depend on any of the @Var@s provided.---------------------------------------------------------------------------thin :: [CoreBind] -> [Var] -> [CoreBind]---------------------------------------------------------------------------thin = thinWith S.empty--thinWith :: S.HashSet Var -> [CoreBind] -> [Var] -> [CoreBind]-thinWith sigs cbs xs = filterBinds cbs ys-  where-    ys               = txClosure (coreDeps cbs) sigs (S.fromList xs)--coreDeps    :: [CoreBind] -> Deps-coreDeps bs = mkGraph $ calls ++ calls'-  where-    calls   = concatMap deps bs-    calls'  = [(y, x) | (x, y) <- calls]-    deps b  = [(x, y) | x <- bindersOf b-                      , y <- freeVars S.empty b]----txClosure :: Deps -> S.HashSet Var -> S.HashSet Var -> S.HashSet Var-txClosure d sigs xs = go S.empty xs-  where-    next           = S.unions . fmap deps . S.toList-    deps x         = M.lookupDefault S.empty x d-    go seen new-      | S.null new = seen-      | otherwise  = let seen' = S.union seen new-                         new'  = next new `S.difference` seen'-                         new'' = new'  `S.difference` sigs-                     in go seen' new''------------------------------------------------------------------------------filterBinds        :: [CoreBind] -> S.HashSet Var -> [CoreBind]---------------------------------------------------------------------------filterBinds cbs ys = filter f cbs-  where-    f (NonRec x _) = x `S.member` ys-    f (Rec xes)    = any (`S.member` ys) $ fst <$> xes-----------------------------------------------------------------------------specDefs :: GhcSpec -> [Def]---------------------------------------------------------------------------specDefs       = map def . specSigs-  where-    def (x, t) = D (line t) (lineE t) x--specSigs :: GhcSpec -> [(Var, Located SpecType)]-specSigs sp = tySigs sp ++ asmSigs sp ++ ctors sp----------------------------------------------------------------------------coreDefs     :: [CoreBind] -> [Def]---------------------------------------------------------------------------coreDefs cbs = L.sort [D l l' x | b <- cbs-                                , x <- bindersOf b-                                , isGoodSrcSpan (getSrcSpan x)-                                , (l, l') <- coreDef b]-coreDef b    = meetSpans b eSp vSp-  where-    eSp      = lineSpan b $ catSpans b $ bindSpans b-    vSp      = lineSpan b $ catSpans b $ getSrcSpan <$> bindersOf b------------------------------------------------------------------------------- | `meetSpans` cuts off the start-line to be no less than the line at which---   the binder is defined. Without this, i.e. if we ONLY use the ticks and---   spans appearing inside the definition of the binder (i.e. just `eSp`)---   then the generated span can be WAY before the actual definition binder,---   possibly due to GHC INLINE pragmas or dictionaries OR ...---   for an example: see the "INCCHECK: Def" generated by---      liquid -d benchmarks/bytestring-0.9.2.1/Data/ByteString.hs---   where `spanEnd` is a single line function around 1092 but where---   the generated span starts mysteriously at 222 where Data.List is imported.--meetSpans _ Nothing       _-  = []-meetSpans _ (Just (l,l')) Nothing-  = [(l, l')]-meetSpans _ (Just (l,l')) (Just (m,_))-  = [(max l m, l')]--lineSpan _ (RealSrcSpan sp) = Just (srcSpanStartLine sp, srcSpanEndLine sp)-lineSpan _ _                = Nothing--catSpans b []               = error $ "DIFFCHECK: catSpans: no spans found for " ++ showPpr b-catSpans b xs               = foldr combineSrcSpans noSrcSpan [x | x@(RealSrcSpan z) <- xs, bindFile b == srcSpanFile z]--bindFile (NonRec x _) = varFile x-bindFile (Rec xes)    = varFile $ fst $ head xes--varFile b = case getSrcSpan b of-              RealSrcSpan z -> srcSpanFile z-              _             -> error $ "DIFFCHECK: getFile: no file found for: " ++ showPpr b---bindSpans (NonRec x e)    = getSrcSpan x : exprSpans e-bindSpans (Rec    xes)    = map getSrcSpan xs ++ concatMap exprSpans es-  where-    (xs, es)              = unzip xes--exprSpans (Tick t e)-  | isJunkSpan sp         = exprSpans e-  | otherwise             = [sp]-  where-    sp                    = tickSrcSpan t--exprSpans (Var x)         = [getSrcSpan x]-exprSpans (Lam x e)       = getSrcSpan x : exprSpans e-exprSpans (App e a)       = exprSpans e ++ exprSpans a-exprSpans (Let b e)       = bindSpans b ++ exprSpans e-exprSpans (Cast e _)      = exprSpans e-exprSpans (Case e x _ cs) = getSrcSpan x : exprSpans e ++ concatMap altSpans cs-exprSpans _               = []--altSpans (_, xs, e)       = map getSrcSpan xs ++ exprSpans e--isJunkSpan (RealSrcSpan _) = False-isJunkSpan _               = True------------------------------------------------------------------------------ | Diff Interface ------------------------------------------------------------------------------------------------------------------------------------ | `lineDiff new old` compares the contents of `src` with `dst`---   and returns the lines of `src` that are different.---------------------------------------------------------------------------lineDiff :: FilePath -> FilePath -> IO ([Int], LMap)---------------------------------------------------------------------------lineDiff new old  = lineDiff' <$> getLines new <*> getLines old-  where-    getLines      = fmap lines . readFile--lineDiff'         :: [String] -> [String] -> ([Int], LMap)-lineDiff' new old = (ns, lm)-  where-    ns            = diffLines 1 diff-    lm            = foldr setShift IM.empty $ diffShifts diff-    diff          = fmap length <$> getGroupedDiff new old--diffLines _ []                  = []-diffLines n (Both i _ : d)      = diffLines n' d                         where n' = n + i -- length ls-diffLines n (First i : d)       = [n .. (n' - 1)] ++ diffLines n' d      where n' = n + i -- length ls-diffLines n (Second _ : d)      = diffLines n d--diffShifts                      :: [Diff Int] -> [(Int, Int, Int)]-diffShifts                      = go 1 1-  where-    go old new (Both n _ : d)   = (old, old + n - 1, new - old) : go (old + n) (new + n) d-    go old new (Second n : d)   = go (old + n) new d-    go old new (First n  : d)   = go old (new + n) d-    go _   _   []               = []--instance Functor Diff where-  fmap f (First x)  = First (f x)-  fmap f (Second x) = Second (f x)-  fmap f (Both x y) = Both (f x) (f y)---- | @save@ creates an .saved version of the @target@ file, which will be---    used to find what has changed the /next time/ @target@ is checked.---------------------------------------------------------------------------saveResult :: FilePath -> Output Doc -> IO ()---------------------------------------------------------------------------saveResult target res-  = do copyFile target saveF-       B.writeFile errF $ LB.toStrict $ encode res-    where-       saveF = extFileName Saved  target-       errF  = extFileName Cache  target----------------------------------------------------------------------------loadResult   :: FilePath -> IO (Output Doc)---------------------------------------------------------------------------loadResult f = ifM (doesFileExist jsonF) out (return mempty)-  where-    jsonF    = extFileName Cache f-    out      = (fromMaybe mempty . decode . LB.fromStrict) <$> B.readFile jsonF----------------------------------------------------------------------------adjustOutput :: LMap -> ChkItv -> Output Doc -> Output Doc---------------------------------------------------------------------------adjustOutput lm cm o  = mempty { o_types  = adjustTypes  lm cm (o_types  o) }-                               { o_result = adjustResult lm cm (o_result o) }--adjustTypes :: LMap -> ChkItv -> AnnInfo a -> AnnInfo a-adjustTypes lm cm (AI m)          = AI $ M.fromList-                                    [(sp', v) | (sp, v)  <- M.toList m-                                              , Just sp' <- [adjustSrcSpan lm cm sp]]--adjustResult :: LMap -> ChkItv -> FixResult Error -> FixResult Error-adjustResult lm cm (Unsafe es)    = errorsResult Unsafe      $ adjustErrors lm cm es-adjustResult lm cm (Crash es z)   = errorsResult (`Crash` z) $ adjustErrors lm cm es-adjustResult _  _  r              = r--errorsResult :: ([a] -> FixResult b) -> [a] -> FixResult b-errorsResult _ []                 = Safe-errorsResult f es                 = f es--adjustErrors :: LMap -> ChkItv -> [TError a] -> [TError a]-adjustErrors lm cm                = mapMaybe adjustError-  where-    adjustError (ErrSaved sp m)   =  (`ErrSaved` m) <$> adjustSrcSpan lm cm sp-    adjustError e                 = Just e----------------------------------------------------------------------------adjustSrcSpan :: LMap -> ChkItv -> SrcSpan -> Maybe SrcSpan---------------------------------------------------------------------------adjustSrcSpan lm cm sp-  = do sp' <- adjustSpan lm sp-       if isCheckedSpan cm sp'-         then Nothing-         else Just sp'--isCheckedSpan cm (RealSrcSpan sp) = isCheckedRealSpan cm sp-isCheckedSpan _  _                = False-isCheckedRealSpan cm              = not . null . (`IM.search` cm) . srcSpanStartLine--adjustSpan lm (RealSrcSpan rsp)   = RealSrcSpan <$> adjustReal lm rsp-adjustSpan _  sp                  = Just sp-adjustReal lm rsp-  | Just δ <- getShift l1 lm      = Just $ realSrcSpan f (l1 + δ) c1 (l2 + δ) c2-  | otherwise                     = Nothing-  where-    (f, l1, c1, l2, c2)           = unpackRealSrcSpan rsp----- | @getShift lm old@ returns @Just δ@ if the line number @old@ shifts by @δ@--- in the diff and returns @Nothing@ otherwise.-getShift     :: Int -> LMap -> Maybe Int-getShift old = fmap snd . listToMaybe . IM.search old---- | @setShift (lo, hi, δ) lm@ updates the interval map @lm@ appropriately-setShift             :: (Int, Int, Int) -> LMap -> LMap-setShift (l1, l2, δ) = IM.insert (IM.Interval l1 l2) δ---checkedItv :: [Def] -> ChkItv-checkedItv chDefs = foldr (`IM.insert` ()) IM.empty is-  where-    is            = [IM.Interval l1 l2 | D l1 l2 _ <- chDefs]---ifM b x y    = b >>= \z -> if z then x else y------------------------------------------------------------------------------ | Aeson instances --------------------------------------------------------------------------------------------------------------------------------instance ToJSON SourcePos where-  toJSON p = object [   "sourceName"   .= f-                      , "sourceLine"   .= l-                      , "sourceColumn" .= c-                      ]-             where-               f    = sourceName   p-               l    = sourceLine   p-               c    = sourceColumn p--instance FromJSON SourcePos where-  parseJSON (Object v) = newPos <$> v .: "sourceName"-                                <*> v .: "sourceLine"-                                <*> v .: "sourceColumn"-  parseJSON _          = mempty---instance ToJSON (FixResult Error)-instance FromJSON (FixResult Error)--instance ToJSON Doc where-  toJSON = String . T.pack . render--instance FromJSON Doc where-  parseJSON (String s) = return $ text $ T.unpack s-  parseJSON _          = mempty--instance (ToJSON k, ToJSON v) => ToJSON (M.HashMap k v) where-  toJSON = toJSON . M.toList--instance (Eq k, Hashable k, FromJSON k, FromJSON v) => FromJSON (M.HashMap k v) where-  parseJSON = fmap M.fromList . parseJSON--instance ToJSON a => ToJSON (AnnInfo a)-instance FromJSON a => FromJSON (AnnInfo a)--instance ToJSON (Output Doc)-instance FromJSON (Output Doc)---line :: Located a -> Int-line  = sourceLine . loc--lineE :: Located a -> Int-lineE = sourceLine . locE
− src/Language/Haskell/Liquid/Errors.hs 
@@ -1,304 +0,0 @@--{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}---- | This module contains the functions related to @Error@ type,--- in particular, to @tidyError@ using a solution, and @pprint@ errors.--module Language.Haskell.Liquid.Errors (tidyError, exitWithPanic) where---import           Control.Applicative                 ((<$>), (<*>))-import           Control.Arrow                       (second)-import           Control.Exception                   (Exception (..))-import           Data.Aeson-import           Data.Generics                       (everywhere, mkT)-import qualified Data.HashMap.Strict                 as M-import qualified Data.HashSet                        as S-import           Data.Hashable-import           Data.List                           (intersperse)-import           Data.Maybe                          (fromMaybe, maybeToList)-import           Data.Monoid                         hiding ((<>))-import           Language.Fixpoint.Misc              hiding (intersperse)-import           Language.Fixpoint.Types             hiding (shiftVV)-import           Language.Haskell.Liquid.PrettyPrint-import           Language.Haskell.Liquid.RefType-import           Language.Haskell.Liquid.Simplify-import           Language.Haskell.Liquid.Tidy-import           Language.Haskell.Liquid.Types-import           SrcLoc                              (SrcSpan)-import           Text.PrettyPrint.HughesPJ-import qualified Control.Exception as Ex--type Ctx = M.HashMap Symbol SpecType---------------------------------------------------------------------------tidyError :: FixSolution -> Error -> Error--------------------------------------------------------------------------tidyError sol-  = fmap (tidySpecType Full)-  . tidyErrContext sol-  . applySolution sol--tidyErrContext _ err@(ErrSubType {})-  = err { ctx = c', tact = subst θ tA, texp = subst θ tE }-    where-      (θ, c') = tidyCtx xs $ ctx err-      xs      = syms tA ++ syms tE-      tA      = tact err-      tE      = texp err--tidyErrContext _ err-  = err------------------------------------------------------------------------------------tidyCtx       :: [Symbol] -> Ctx -> (Subst, Ctx)-----------------------------------------------------------------------------------tidyCtx xs m  = (θ, M.fromList yts)-  where-    yts       = [tBind x t | (x, t) <- xts]-    (θ, xts)  = tidyTemps $ second stripReft <$> tidyREnv xs m-    tBind x t = (x', shiftVV t x') where x' = tidySymbol x---stripReft     :: SpecType -> SpecType-stripReft t   = maybe t' (strengthen t') ro-  where-    (t', ro)  = stripRType t--stripRType    :: SpecType -> (SpecType, Maybe RReft)-stripRType st = (t', ro)-  where-    t'        = fmap (const (uTop mempty)) t-    ro        = stripRTypeBase  t-    t         = simplifyBounds st--tidyREnv      :: [Symbol] -> M.HashMap Symbol SpecType -> [(Symbol, SpecType)]-tidyREnv xs m = [(x, t) | x <- xs', t <- maybeToList (M.lookup x m), ok t]-  where-    xs'       = expandFix deps xs-    deps y    = fromMaybe [] $ fmap (syms . rTypeReft) $ M.lookup y m-    ok        = not . isFunTy--expandFix :: (Eq a, Hashable a) => (a -> [a]) -> [a] -> [a]-expandFix f xs            = S.toList $ go S.empty xs-  where-    go seen []            = seen-    go seen (x:xs)-      | x `S.member` seen = go seen xs-      | otherwise         = go (S.insert x seen) (f x ++ xs)--tidyTemps     :: (Subable t) => [(Symbol, t)] -> (Subst, [(Symbol, t)])-tidyTemps xts = (θ, [(txB x, txTy t) | (x, t) <- xts])-  where-    txB  x    = M.lookupDefault x x m-    txTy      = subst θ-    m         = M.fromList yzs-    θ         = mkSubst [(y, EVar z) | (y, z) <- yzs]-    yzs       = zip ys niceTemps-    ys        = [ x | (x,_) <- xts, isTmpSymbol x]--niceTemps     :: [Symbol]-niceTemps     = mkSymbol <$> xs ++ ys-  where-    mkSymbol  = symbol . ('?' :)-    xs        = single   <$> ['a' .. 'z']-    ys        = ("a" ++) <$> [show n | n <- [0 ..]]------------------------------------------------------------------------------ | Pretty Printing Error Messages ----------------------------------------------------------------------------------------------------------------- | Need to put @PPrint Error@ instance here (instead of in Types),---   as it depends on @PPrint SpecTypes@, which lives in this module.--instance PPrint Error where-  pprint       = pprintTidy Full-  pprintTidy k = ppError k . fmap ppSpecTypeErr--ppSpecTypeErr   :: SpecType -> Doc-ppSpecTypeErr-  = rtypeDoc Lossy . tidySpecType Lossy . fmap (everywhere (mkT noCasts))-  where-    noCasts (ECst x _) = x-    noCasts e          = e---- full = isNontrivialVV $ rTypeValueVar t =--instance Show Error where-  show = showpp--instance Exception Error-instance Exception [Error]---------------------------------------------------------------------------ppError :: (PPrint a, Show a) => Tidy -> TError a -> Doc---------------------------------------------------------------------------ppError k e  = ppError' k (pprintE $ errSpan e) e-pprintE l    = pprint l <> text ": Error:"--nests n      = foldr (\d acc -> nest n (d $+$ acc)) empty--sepVcat d ds = vcat $ intersperse d ds-blankLine    = sizedText 5 " "---------------------------------------------------------------------------ppError' :: (PPrint a, Show a) => Tidy -> Doc -> TError a -> Doc--------------------------------------------------------------------------ppError' _ dSp (ErrAssType _ OCons _ _)-  = dSp <+> text "Constraint Check"--ppError' _ dSp (ErrAssType _ OTerm _ _)-  = dSp <+> text "Termination Check"--ppError' _ dSp (ErrAssType _ OInv _ _)-  = dSp <+> text "Invariant Check"--ppError' Lossy dSp (ErrSubType _ _ _ _ _)-  = dSp <+> text "Liquid Type Mismatch"--ppError' Full  dSp (ErrSubType _ _ c tA tE)-  = dSp <+> text "Liquid Type Mismatch"-        $+$ sepVcat blankLine-              [ nests 2 [ text "Inferred type"-                        , text "VV :" <+> pprint tA]-              , nests 2 [ text "not a subtype of Required type"-                        , text "VV :" <+> pprint tE]-              , nests 2 [ text "In Context"-                        , pprint c                 ]]--ppError' _  dSp (ErrFCrash _ _ c tA tE)-  = dSp <+> text "Fixpoint Crash on Constraint"-        $+$ sepVcat blankLine-              [ nests 2 [ text "Inferred type"-                        , text "VV :" <+> pprint tA]-              , nests 2 [ text "Required type"-                        , text "VV :" <+> pprint tE]-              , nests 2 [ text "Context"-                        , pprint c                 ]]--ppError' _ dSp (ErrParse _ _ e)-  = dSp <+> text "Cannot parse specification:"-    $+$ (nest 4 $ pprint e)--ppError' _ dSp (ErrTySpec _ v t s)-  = dSp <+> text "Bad Type Specification"-    $+$ (pprint v <+> dcolon <+> pprint t)-    $+$ (nest 4 $ pprint s)--ppError' _ dSp (ErrBadData _ v s)-  = dSp <+> text "Bad Data Specification"-    $+$ (pprint v <+> dcolon <+> pprint s)--ppError' _ dSp (ErrTermSpec _ v e s)-  = dSp <+> text "Bad Termination Specification"-    $+$ (pprint v <+> dcolon <+> pprint e)-    $+$ (nest 4 $ pprint s)--ppError' _ dSp (ErrInvt _ t s)-  = dSp <+> text "Bad Invariant Specification"-    $+$ (nest 4 $ text "invariant " <+> pprint t $+$ pprint s)--ppError' _ dSp (ErrIAl _ t s)-  = dSp <+> text "Bad Using Specification"-    $+$ (nest 4 $ text "as" <+> pprint t $+$ pprint s)--ppError' _ dSp (ErrIAlMis _ t1 t2 s)-  = dSp <+> text "Incompatible Using Specification"-    $+$ (nest 4 $ (text "using" <+> pprint t1 <+> text "as" <+> pprint t2) $+$ pprint s)--ppError' _ dSp (ErrMeas _ t s)-  = dSp <+> text "Bad Measure Specification"-    $+$ (nest 4 $ text "measure " <+> pprint t $+$ pprint s)--ppError' _ dSp (ErrHMeas _ t s)-  = dSp <+> text "Cannot promote Haskell function" <+> pprint t <+> text "to logic"-    $+$ (nest 4 $ pprint s)--ppError' _ dSp (ErrDupSpecs _ v ls)-  = dSp <+> text "Multiple Specifications for" <+> pprint v <> colon-    $+$ (nest 4 $ vcat $ pprint <$> ls)--ppError' _ dSp (ErrDupAlias _ k v ls)-  = dSp <+> text "Multiple Declarations! "-    $+$ (nest 2 $ text "Multiple Declarations of" <+> pprint k <+> ppVar v $+$ text "Declared at:")-    <+> (nest 4 $ vcat $ pprint <$> ls)--ppError' _ dSp (ErrUnbound _ x)-  = dSp <+> text "Unbound variable"-    $+$ (nest 4 $ pprint x)--ppError' _ dSp (ErrGhc _ s)-  = dSp <+> text "GHC Error"-    $+$ (nest 4 $ pprint s)--ppError' _ dSp (ErrMismatch _ x τ t)-  = dSp <+> text "Specified Type Does Not Refine Haskell Type for" <+> pprint x-    $+$ text "Haskell:" <+> pprint τ-    $+$ text "Liquid :" <+> pprint t--ppError' _ dSp (ErrAliasCycle _ acycle)-  = dSp <+> text "Cyclic Alias Definitions"-    $+$ text "The following alias definitions form a cycle:"-    $+$ (nest 4 $ sepVcat blankLine $ map describe acycle)-  where-    describe (pos, name)-      = text "Type alias:"     <+> pprint name-        $+$ text "Defined at:" <+> pprint pos--ppError' _ dSp (ErrIllegalAliasApp _ dn dl)-  = dSp <+> text "Refinement Type Alias cannot be used in this context"-    $+$ text "Type alias:" <+> pprint dn-    $+$ text "Defined at:" <+> pprint dl--ppError' _ dSp (ErrAliasApp _ n name dl dn)-  = dSp <+> text "Malformed Type Alias Application"-    $+$ text "Type alias:" <+> pprint name-    $+$ text "Defined at:" <+> pprint dl-    $+$ text "Expects"     <+> pprint dn <+> text "arguments, but is given" <+> pprint n--ppError' _ dSp (ErrSaved _ s)-  = dSp <+> s--ppError' _ dSp (ErrTermin xs _ s)-  = dSp <+> text "Termination Error on" <+> (hsep $ intersperse comma $ map pprint xs) $+$ s--ppError' _ dSp (ErrRClass pos cls insts)-  = dSp <+> text "Refined classes cannot have refined instances"-    $+$ (nest 4 $ sepVcat blankLine $ describeCls : map describeInst insts)-  where-    describeCls-      = text "Refined class definition for:" <+> cls-        $+$ text "Defined at:" <+> pprint pos-    describeInst (pos, t)-      = text "Refined instance for:" <+> t-        $+$ text "Defined at:" <+> pprint pos--ppError' _ _ (ErrOther _ s)-  = text "Panic!" <+> nest 4 (pprint s)---ppVar v = text "`" <> pprint v <> text "'"---instance ToJSON Error where-  toJSON e = object [ "pos" .= (errSpan e)-                    , "msg" .= (render $ ppError' Full empty e)-                    ]--instance FromJSON Error where-  parseJSON (Object v) = errSaved <$> v .: "pos"-                                  <*> v .: "msg"-  parseJSON _          = mempty---errSaved :: SrcSpan -> String -> Error-errSaved x = ErrSaved x . text---- | Throw a panic exception-exitWithPanic  :: String -> a-exitWithPanic  = Ex.throw . errOther . text-
− src/Language/Haskell/Liquid/Fresh.hs 
@@ -1,140 +0,0 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE TypeSynonymInstances  #-}-{-# LANGUAGE UndecidableInstances  #-}--module Language.Haskell.Liquid.Fresh (Freshable(..)) where--import           Control.Applicative           (Applicative, (<$>), (<*>))-import           Data.Monoid                   (mempty)-import           Language.Fixpoint.Misc-import           Language.Fixpoint.Types-import           Language.Haskell.Liquid.Types--class (Applicative m, Monad m) => Freshable m a where-  fresh   :: m a-  true    :: a -> m a-  true    = return . id-  refresh :: a -> m a-  refresh = return . id--instance Freshable m Integer => Freshable m Symbol where-  fresh = tempSymbol "x" <$> fresh--instance Freshable m Integer => Freshable m Refa where-  fresh  = kv <$> fresh-    where-      kv = Refa . (`PKVar` mempty) . intKvar--instance Freshable m Integer => Freshable m [Refa] where-  fresh = single <$> fresh--instance Freshable m Integer => Freshable m Reft where-  fresh                = errorstar "fresh Reft"-  true    (Reft (v,_)) = return $ Reft (v, mempty)-  refresh (Reft (_,_)) = (Reft .) . (,) <$> freshVV <*> fresh-    where-      freshVV          = vv . Just <$> fresh--instance Freshable m Integer => Freshable m RReft where-  fresh             = errorstar "fresh RReft"-  true (U r _ s)    = U <$> true r    <*> return mempty <*> true s-  refresh (U r _ s) = U <$> refresh r <*> return mempty <*> refresh s--instance Freshable m Integer => Freshable m Strata where-  fresh      = (:[]) . SVar <$> fresh-  true []    = fresh-  true s     = return s-  refresh [] = fresh-  refresh s  = return s--instance (Freshable m Integer, Freshable m r, Reftable r, RefTypable RTyCon RTyVar r) => Freshable m (RRType r) where-  fresh   = errorstar "fresh RefType"-  refresh = refreshRefType-  true    = trueRefType--------------------------------------------------------------------------------------------------trueRefType :: (Freshable m Integer, Freshable m r, Reftable r, RefTypable RTyCon RTyVar r) => RRType r -> m (RRType r)-------------------------------------------------------------------------------------------------trueRefType (RAllT α t)-  = RAllT α <$> true t--trueRefType (RAllP π t)-  = RAllP π <$> true t--trueRefType (RFun _ t t' _)-  = rFun <$> fresh <*> true t <*> true t'--trueRefType (RApp c ts _  _) | isClass c-  = rRCls c <$> mapM true ts--trueRefType (RApp c ts rs r)-  = RApp c <$> mapM true ts <*> mapM trueRef rs <*> true r--trueRefType (RAppTy t t' _)-  = RAppTy <$> true t <*> true t' <*> return mempty--trueRefType (RVar a r)-  = RVar a <$> true r--trueRefType (RAllE y ty tx)-  = do y'  <- fresh -       ty' <- true ty-       tx' <- true tx-       return $ RAllE y' ty' (tx' `subst1` (y, EVar y')) --trueRefType (RRTy e o r t)-  = RRTy e o r <$> trueRefType t --trueRefType t -  = return t--trueRef (RProp s t) = RProp s <$> trueRefType t-trueRef _           = errorstar "trueRef: unexpected"---------------------------------------------------------------------------------------------------refreshRefType :: (Freshable m Integer, Freshable m r, Reftable r, RefTypable RTyCon RTyVar r) => RRType r -> m (RRType r)-------------------------------------------------------------------------------------------------refreshRefType (RAllT α t)-  = RAllT α <$> refresh t--refreshRefType (RAllP π t)-  = RAllP π <$> refresh t--refreshRefType (RFun b t t' _)-  | b == dummySymbol = rFun <$> fresh <*> refresh t <*> refresh t'-  | otherwise        = rFun     b     <$> refresh t <*> refresh t'--refreshRefType (RApp rc ts _ _) | isClass rc-  = return $ rRCls rc ts --refreshRefType (RApp rc ts rs r)-  = RApp rc <$> mapM refresh ts <*> mapM refreshRef rs <*> refresh r--refreshRefType (RVar a r)-  = RVar a <$> refresh r--refreshRefType (RAppTy t t' r)-  = RAppTy <$> refresh t <*> refresh t' <*> refresh r--refreshRefType (RAllE y ty tx)-  = do y'  <- fresh -       ty' <- refresh ty-       tx' <- refresh tx-       return $ RAllE y' ty' (tx' `subst1` (y, EVar y')) --refreshRefType (RRTy e o r t)-  = RRTy e o r <$> refreshRefType t --refreshRefType t-  = return t--refreshRef (RProp s t) = RProp <$> mapM freshSym s <*> refreshRefType t-refreshRef _           = errorstar "refreshRef: unexpected"-freshSym (_, t)        = (, t) <$> fresh-
+ src/Language/Haskell/Liquid/GHC/Interface.hs view
@@ -0,0 +1,402 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TypeSynonymInstances      #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE TupleSections             #-}+{-# LANGUAGE ScopedTypeVariables       #-}++module Language.Haskell.Liquid.GHC.Interface (++  -- * extract all information needed for verification+    getGhcInfo++  -- * printer+  , pprintCBs+  ) where++import Prelude hiding (error)++import GHC hiding (Target, desugarModule)+import GHC.Paths (libdir)++import Bag+import Class+import CoreMonad+import CoreSyn+import DataCon+import DriverPhases+import DriverPipeline+import DynFlags+import ErrUtils+import HscTypes hiding (Target)+import IdInfo+import InstEnv+import Var++import Control.Exception+import Control.Monad++import Data.List hiding (intersperse)+import Data.Maybe+import qualified Data.HashSet as S++import System.Console.CmdArgs.Verbosity hiding (Loud)+import System.Directory+import System.FilePath+import System.IO.Temp++import Text.PrettyPrint.HughesPJ++import Language.Fixpoint.Types hiding (Error, Result, Expr)+import Language.Fixpoint.Misc++import Language.Haskell.Liquid.Bare+import Language.Haskell.Liquid.GHC.Misc+import qualified Language.Haskell.Liquid.Measure as Ms+import Language.Haskell.Liquid.Misc+import Language.Haskell.Liquid.Parse+import Language.Haskell.Liquid.Transforms.ANF+import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.Types.PrettyPrint+import Language.Haskell.Liquid.Types.Visitors+import Language.Haskell.Liquid.UX.CmdLine+import Language.Haskell.Liquid.UX.Tidy+import Language.Fixpoint.Utils.Files++--------------------------------------------------------------------------------+-- GHC Interface Pipeline ------------------------------------------------------+--------------------------------------------------------------------------------++getGhcInfo :: Maybe HscEnv -> Config -> FilePath -> IO (GhcInfo, HscEnv)+getGhcInfo hscEnv cfg0 target = do+  tryIgnore "create temp directory" $+    createDirectoryIfMissing False $ tempDirectory target+  (cfg, name, tgtSpec) <- parseRootTarget cfg0 target+  runLiquidGhc hscEnv cfg $ getGhcInfo' cfg target name tgtSpec++getGhcInfo' :: Config -> FilePath -> ModName -> Ms.BareSpec -> Ghc (GhcInfo, HscEnv)+getGhcInfo' cfg target name tgtSpec = do+  paths <- importPaths <$> getSessionDynFlags+  liftIO $ whenLoud $ putStrLn $ "paths = " ++ show paths++  impSpecs <- findAndLoadTargets cfg paths target++  modGuts <- makeMGIModGuts target+  hscEnv <- getSession+  coreBinds <- liftIO $ anormalize (not $ nocaseexpand cfg) hscEnv modGuts++  logicMap <- liftIO makeLogicMap++  let dataCons = concatMap (map dataConWorkId . tyConDataCons) (mgi_tcs modGuts)++  let impVs = importVars coreBinds ++ classCons (mgi_cls_inst modGuts)+  let defVs = definedVars coreBinds+  let useVs = readVars coreBinds+  let letVs = letVars coreBinds+  let derVs = derivedVars coreBinds $ ((is_dfun <$>) <$>) $ mgi_cls_inst modGuts++  (spc, imps, incs) <- moduleSpec cfg coreBinds (impVs ++ defVs) letVs name modGuts tgtSpec logicMap impSpecs+  liftIO $ whenLoud $ putStrLn $ "Module Imports: " ++ show imps+  hqualFiles <- moduleHquals modGuts paths target imps incs++  let info = GI target hscEnv coreBinds derVs impVs (letVs ++ dataCons) useVs hqualFiles imps incs spc+  hscEnv' <- getSession+  return (info, hscEnv')++--------------------------------------------------------------------------------+-- Configure GHC for Liquid Haskell --------------------------------------------+--------------------------------------------------------------------------------++runLiquidGhc :: Maybe HscEnv -> Config -> Ghc a -> IO a+runLiquidGhc hscEnv cfg act =+  withSystemTempDirectory "liquid" $ \tmp ->+    runGhc (Just libdir) $ do+      maybe (return ()) setSession hscEnv+      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 = nub $ idirs cfg ++ includePaths df'+                     , packageFlags = ExposePackage (PackageArg "ghc-prim") (ModRenaming True []) : packageFlags df'+                     -- , profAuto     = ProfAutoCalls+                     , ghcLink      = LinkInMemory+                     --FIXME: this *should* be HscNothing, but that prevents us from+                     -- looking up *unexported* names in another source module..+                     , hscTarget    = HscInterpreted -- HscNothing+                     , 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+                     } `xopt_set` Opt_MagicHash+                       `gopt_set` Opt_ImplicitImportQualified+                       `gopt_set` Opt_PIC+      setSessionDynFlags df''+      defaultCleanupHandler df'' act++--------------------------------------------------------------------------------+-- Parse, Find, & Load Targets -------------------------------------------------+--------------------------------------------------------------------------------++parseRootTarget :: Config -> FilePath -> IO (Config, ModName, Ms.BareSpec)+parseRootTarget cfg0 target = do+  (name, tgtSpec) <- parseSpec target+  cfg <- withPragmas cfg0 target $ Ms.pragmas tgtSpec+  return (cfg, ModName Target $ getModName name, tgtSpec)++findAndLoadTargets :: Config -> [FilePath] -> FilePath -> Ghc [(ModName, Ms.BareSpec)]+findAndLoadTargets cfg paths target = do+  setTargets . return =<< guessTarget target Nothing++  impNames <- allDepNames <$> depanal [] False+  impSpecs <- getSpecs cfg paths target impNames [Spec, Hs, LHs]+  liftIO $ whenNormal $ donePhase Loud "Parsed All Specifications"++  compileCFiles =<< liftIO (foldM (\c (f,_,s) -> withPragmas c f (Ms.pragmas s)) cfg impSpecs)++  impSpecs' <- forM impSpecs $ \(f, n, s) -> do+                 unless (isSpecImport n) $+                   addTarget =<< guessTarget f Nothing+                 return (n, s)+  load LoadAllTargets+  liftIO $ whenNormal $ donePhase Loud "Loaded Targets"++  return impSpecs'++allDepNames :: [ModSummary] -> [String]+allDepNames = concatMap (map declNameString . ms_textual_imps)++declNameString :: GHC.Located (ImportDecl RdrName) -> String+declNameString = moduleNameString . unLoc . ideclName . unLoc++compileCFiles :: Config -> Ghc ()+compileCFiles cfg = do+  df  <- getSessionDynFlags+  setSessionDynFlags $ df { includePaths = nub $ idirs cfg ++ includePaths df+                          , 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 = map (FileOption "") os ++ ldInputs df }++--------------------------------------------------------------------------------+-- Assemble Information for Spec Extraction ------------------------------------+--------------------------------------------------------------------------------++makeMGIModGuts :: FilePath -> Ghc MGIModGuts+makeMGIModGuts f = do+  modGraph <- getModuleGraph+  case find (\m -> not (isBootSummary m) && f == msHsFilePath m) modGraph of+    Just modSummary -> do+      parsed <- parseModule modSummary+      modGuts <- coreModule <$> (desugarModule =<< typecheckModule (ignoreInline parsed))+      let deriv = Just $ instEnvElts $ mg_inst_env modGuts+      return $! miModGuts deriv modGuts+    Nothing ->+      panic Nothing $ "Ghc Interface: Unable to get GhcModGuts"++makeLogicMap :: IO (Either Error LogicMap)+makeLogicMap = do+  lg    <- getCoreToLogicPath+  lspec <- readFile lg+  return $ parseSymbolToLogic lg lspec++--------------------------------------------------------------------------------+-- Extract Ids -----------------------------------------------------------------+--------------------------------------------------------------------------------++classCons :: Maybe [ClsInst] -> [Id]+classCons Nothing   = []+classCons (Just cs) = concatMap (dataConImplicitIds . head . tyConDataCons . classTyCon . is_cls) cs++derivedVars :: CoreProgram -> Maybe [DFunId] -> [Id]+derivedVars cbs (Just fds) = concatMap (derivedVs cbs) fds+derivedVars _   Nothing    = []++derivedVs :: CoreProgram -> DFunId -> [Id]+derivedVs cbs fd = concatMap bindersOf cbs' ++ deps+  where+    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++--------------------------------------------------------------------------------+-- Find & Parse Specs ----------------------------------------------------------+--------------------------------------------------------------------------------++getSpecs cfg paths target names exts = do+  fs' <- sortNub <$> moduleImports exts paths names+  patSpec <- getPatSpec paths $ totality cfg+  rlSpec <- getRealSpec paths $ not $ linear cfg+  let fs = patSpec ++ rlSpec ++ fs'+  transParseSpecs exts paths (S.singleton target) mempty (map snd fs \\ [target])++getPatSpec paths totalitycheck+ | totalitycheck = (map (patErrorName,)) . maybeToList <$> moduleFile paths patErrorName Spec+ | otherwise     = return []+ where+  patErrorName = "PatErr"++getRealSpec paths freal+  | freal     = (map (realSpecName,))    . maybeToList <$> moduleFile paths realSpecName    Spec+  | otherwise = (map (notRealSpecName,)) . maybeToList <$> moduleFile paths notRealSpecName Spec+  where+    realSpecName    = "Real"+    notRealSpecName = "NotReal"+++transParseSpecs _ _ _ specs [] = return specs+transParseSpecs exts paths seenFiles specs newFiles = do+  newSpecs <- liftIO $ mapM (\f -> addFst3 f <$> parseSpec f) newFiles+  impFiles <- moduleImports exts paths $ specsImports newSpecs+  let seenFiles' = seenFiles `S.union` (S.fromList newFiles)+  let specs'     = specs ++ map (third3 noTerm) newSpecs+  let newFiles'  = [f | (_, f) <- impFiles, not (f `S.member` seenFiles')]+  transParseSpecs exts paths seenFiles' specs' newFiles'+  where+    specsImports ss = nub $ concatMap (map symbolString . Ms.imports . thd3) ss+    noTerm spec = spec { Ms.decr = mempty, Ms.lazy = mempty, Ms.termexprs = mempty }++parseSpec :: FilePath -> IO (ModName, Ms.BareSpec)+parseSpec file = either throw return . specParser file =<< readFile file++specParser f str+  | isExtFile Spec   f = specSpecificationP f str+  | isExtFile Hs     f = hsSpecificationP   f str+  | isExtFile HsBoot f = hsSpecificationP   f str+  | isExtFile LHs    f = lhsSpecificationP  f str+  | otherwise          = panic Nothing $ "SpecParser: Cannot Parse File " ++ f+++moduleSpec cfg cbs vars letVs tgtMod mgi tgtSpec lm impSpecs = do+  let tgtCxt = IIModule $ getModName tgtMod+  let impCxt = map (IIDecl . qualImportDecl . getModName . fst) impSpecs+  setContext (tgtCxt : impCxt)++  hsc <-getSession++  let impNames = map (getModString . fst) impSpecs+  let exports  = mgi_exports mgi++  let specs = (tgtMod, tgtSpec) : impSpecs+  let imps  = sortNub $ impNames ++ [ symbolString x+                                    | (_, sp) <- specs+                                    , x <- Ms.imports sp+                                    ]++  ghcSpec <- liftIO $ makeGhcSpec cfg tgtMod cbs vars letVs exports hsc lm specs+  return (ghcSpec, imps, Ms.includes tgtSpec)++moduleHquals mgi paths target imps incs = do+  hqs   <- specIncludes Hquals paths incs+  hqs'  <- moduleImports [Hquals] paths (mgi_namestring mgi : imps)+  hqs'' <- liftIO $ filterM doesFileExist [extFileName Hquals target]+  return $ sortNub $ hqs'' ++ hqs ++ (snd <$> hqs')+++moduleImports :: [Ext] -> [FilePath] -> [String] -> Ghc [(String, FilePath)]+moduleImports exts paths names = liftM concat $ forM names $ \name ->+  map (name,) . catMaybes <$> mapM (moduleFile paths name) exts++moduleFile :: [FilePath] -> String -> Ext -> Ghc (Maybe FilePath)+moduleFile paths name ext+  | ext `elem` [Hs, LHs] = do+    graph <- getModuleGraph+    case find (\m -> not (isBootSummary m) &&+                     name == moduleNameString (ms_mod_name m)) graph of+      Nothing -> liftIO $ getFileInDirs (extModuleName name ext) paths+      Just ms -> return $ normalise <$> ml_hs_file (ms_location ms)+  | otherwise = liftIO $ getFileInDirs (extModuleName name ext) paths++specIncludes :: Ext -> [FilePath] -> [FilePath] -> Ghc [FilePath]+specIncludes ext paths reqs = do+  let libFile = extFileNameR ext $ symbolString preludeName+  let incFiles = catMaybes $ reqFile ext <$> reqs+  liftIO $ forM (libFile : incFiles) $ \f -> do+    mfile <- getFileInDirs f paths+    case mfile of+      Just file -> return file+      Nothing -> panic Nothing $ "cannot find " ++ f ++ " in " ++ show paths++reqFile :: Ext -> FilePath -> Maybe FilePath+reqFile ext s+  | isExtFile ext s = Just s+  | otherwise = Nothing++--------------------------------------------------------------------------------+-- Pretty Printing -------------------------------------------------------------+--------------------------------------------------------------------------------++instance PPrint GhcSpec where+  pprintTidy k spec =  (text "******* Target Variables ********************")+              $$ (pprintTidy k $ tgtVars spec)+              $$ (text "******* Type Signatures *********************")+              $$ (pprintLongList $ tySigs spec)+              $$ (text "******* Assumed Type Signatures *************")+              $$ (pprintLongList $ asmSigs spec)+              $$ (text "******* DataCon Specifications (Measure) ****")+              $$ (pprintLongList $ ctors spec)+              $$ (text "******* Measure Specifications **************")+              $$ (pprintLongList $ meas spec)++instance PPrint GhcInfo where+  pprintTidy k info =   (text "*************** Imports *********************")+              $+$ (intersperse comma $ text <$> imports info)+              $+$ (text "*************** Includes ********************")+              $+$ (intersperse comma $ text <$> includes info)+              $+$ (text "*************** Imported Variables **********")+              $+$ (pprDoc $ impVars info)+              $+$ (text "*************** Defined Variables ***********")+              $+$ (pprDoc $ defVars info)+              $+$ (text "*************** Specification ***************")+              $+$ (pprintTidy k $ spec info)+              $+$ (text "*************** Core Bindings ***************")+              $+$ (pprintCBs $ cbs info)++pprintCBs :: [CoreBind] -> Doc+pprintCBs = pprDoc . tidyCBs++instance Show GhcInfo 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")+         . concatMap errMsgErrors+         . bagToList+         . srcErrorMessages++errMsgErrors e = [ ErrGhc (errMsgSpan e) (pprint e)]+
+ src/Language/Haskell/Liquid/GHC/Misc.hs view
@@ -0,0 +1,542 @@+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE TupleSections             #-}+{-# LANGUAGE TypeSynonymInstances      #-}+{-# LANGUAGE UndecidableInstances      #-}+{-# LANGUAGE ViewPatterns              #-}++-- | 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 PrelNames (fractionalClassKeys)+import Class     (classKey)++import           Debug.Trace++import           Prelude                      hiding (error)+import           Avail                        (availsToNameSet)+import           BasicTypes                   (Arity)+import           CoreSyn                      hiding (Expr, sourceName)+import qualified CoreSyn as Core+import           CostCentre+import           GHC                          hiding (L)+import           HscTypes                     (Dependencies, ImportedMods, ModGuts(..), HscEnv(..), FindResult(..))+import           Kind                         (superKind)+import           NameSet                      (NameSet)+import           SrcLoc                       hiding (L)+import           Bag+import           ErrUtils+import           CoreLint+import           CoreMonad++import           Text.Parsec.Pos              (sourceName, sourceLine, sourceColumn, newPos)++import           Name                         (mkInternalName, getSrcSpan, nameModule_maybe)+import           Module                       (moduleNameFS)+import           OccName                      (mkTyVarOcc, mkVarOcc, mkTcOcc, occNameFS)+import           Unique+import           Finder                       (findImportedModule, cannotFindModule)+import           Panic                        (throwGhcException)+import           FastString+import           TcRnDriver+-- import           TcRnTypes+++import           RdrName+import           Type                         (liftedTypeKind)+import           TypeRep+import           Var+import           IdInfo+import qualified TyCon                        as TC+import           Data.Char                    (isLower, isSpace)+import           Data.Maybe                   (fromMaybe)+import           Data.Hashable+import qualified Data.HashSet                 as S++import qualified Data.Text.Encoding           as T+import qualified Data.Text                    as T+import           Control.Arrow                (second)+import           Control.Monad                ((>=>))+import           Outputable                   (Outputable (..), text, ppr)+import qualified Outputable                   as Out+import           DynFlags+import qualified Text.PrettyPrint.HughesPJ    as PJ+import           Language.Fixpoint.Types      hiding (L, Loc (..), SrcSpan, Constant, SESearch (..))+import qualified Language.Fixpoint.Types      as F+import           Language.Fixpoint.Misc       (safeHead, safeLast, safeInit)+import           Language.Haskell.Liquid.Desugar710.HscMain+import           Control.DeepSeq+import           Language.Haskell.Liquid.Types.Errors+++-----------------------------------------------------------------------+--------------- Datatype For Holding GHC ModGuts ----------------------+-----------------------------------------------------------------------++data MGIModGuts = MI {+    mgi_binds     :: !CoreProgram+  , mgi_module    :: !Module+  , mgi_deps      :: !Dependencies+  , mgi_dir_imps  :: !ImportedMods+  , mgi_rdr_env   :: !GlobalRdrEnv+  , mgi_tcs       :: ![TyCon]+  , mgi_fam_insts :: ![FamInst]+  , mgi_exports   :: !NameSet+  , mgi_cls_inst  :: !(Maybe [ClsInst])+  }++miModGuts cls mg  = MI {+    mgi_binds     = mg_binds mg+  , mgi_module    = mg_module mg+  , mgi_deps      = mg_deps mg+  , mgi_dir_imps  = mg_dir_imps mg+  , mgi_rdr_env   = mg_rdr_env mg+  , mgi_tcs       = mg_tcs mg+  , mgi_fam_insts = mg_fam_insts mg+  , mgi_exports   = availsToNameSet $ mg_exports mg+  , mgi_cls_inst  = cls+  }++mgi_namestring = moduleNameString . moduleName . mgi_module++--------------------------------------------------------------------------------+-- | 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+tickSrcSpan _                 = noSrcSpan++-----------------------------------------------------------------------+--------------- Generic Helpers for Accessing GHC Innards -------------+-----------------------------------------------------------------------++stringTyVar :: String -> TyVar+stringTyVar s = mkTyVar name liftedTypeKind+  where name = mkInternalName (mkUnique 'x' 24)  occ noSrcSpan+        occ  = mkTyVarOcc s++stringVar :: String -> Type -> Var+stringVar s t = mkLocalVar VanillaId name t vanillaIdInfo+   where+      name = mkInternalName (mkUnique 'x' 25) occ noSrcSpan+      occ  = mkVarOcc s++stringTyCon :: Char -> Int -> String -> TyCon+stringTyCon = stringTyConWithKind superKind++stringTyConWithKind :: Kind -> Char -> Int -> String -> TyCon+stringTyConWithKind k c n s = TC.mkKindTyCon name k+  where+    name          = mkInternalName (mkUnique c n) occ noSrcSpan+    occ           = mkTcOcc s++hasBaseTypeVar = isBaseType . varType++-- same as Constraint isBase+isBaseType (ForAllTy _ t)  = isBaseType t+isBaseType (TyVarTy _)     = True+isBaseType (TyConApp _ ts) = all isBaseType ts+isBaseType (AppTy t1 t2)   = isBaseType t1 && isBaseType t2+isBaseType (FunTy _ _)     = False -- isBaseType t1 && isBaseType t2+isBaseType _               = False++validTyVar :: String -> Bool+validTyVar s@(c:_) = isLower c && all (not . isSpace) s+validTyVar _       = False++tvId α = {- traceShow ("tvId: α = " ++ show α) $ -} showPpr α ++ show (varUnique α)++tracePpr s x = trace ("\nTrace: [" ++ s ++ "] : " ++ showPpr x) x++pprShow = text . show+++tidyCBs = map unTick++unTick (NonRec b e) = NonRec b (unTickExpr e)+unTick (Rec bs)     = Rec $ map (second unTickExpr) bs++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 clas = classKey clas `elem` fractionalClassKeys++-----------------------------------------------------------------------+------------------ Generic Helpers for DataConstructors ---------------+-----------------------------------------------------------------------++isDataConId id = case idDetails id of+                  DataConWorkId _ -> True+                  DataConWrapId _ -> True+                  _               -> False++getDataConVarUnique v+  | isId v && isDataConId v = getUnique $ idDataCon v+  | otherwise               = getUnique v+++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 s) = hashWithSalt i (uniq s)+  hashWithSalt i (RealSrcSpan s)   = hashWithSalt i (srcSpanStartLine s, srcSpanStartCol s, srcSpanEndCol s)++instance Outputable a => Outputable (S.HashSet a) where+  ppr = ppr . S.toList++++-------------------------------------------------------++toFixSDoc = PJ.text . PJ.render . toFix+sDocDoc   = PJ.text . showSDoc+pprDoc    = sDocDoc . ppr++-- Overriding Outputable functions because they now require DynFlags!+showPpr       = showSDoc . ppr++-- FIXME: somewhere we depend on this printing out all GHC entities with+-- fully-qualified names...+showSDoc sdoc = Out.renderWithStyle unsafeGlobalDynFlags sdoc (Out.mkUserStyle Out.alwaysQualify Out.AllTheWay)+showSDocDump  = Out.showSDocDump unsafeGlobalDynFlags++typeUniqueString = {- ("sort_" ++) . -} showSDocDump . ppr++fSrcSpan :: (F.Loc a) => a -> SrcSpan+fSrcSpan = fSrcSpanSrcSpan . 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 l c l' c'+  where+    (f, l,  c)         = F.sourcePosElts p+    (_, l', c')        = F.sourcePosElts p'++sourcePosSrcSpan   :: SourcePos -> SrcSpan+sourcePosSrcSpan = srcLocSpan . sourcePosSrcLoc++sourcePosSrcLoc    :: SourcePos -> SrcLoc+sourcePosSrcLoc p = mkSrcLoc (fsLit file) line col+  where+    file          = sourceName p+    line          = sourceLine p+    col           = sourceColumn p++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    = maybe "" unpackFS . srcSpanFileName_maybe+srcSpanStartLoc l  = L (srcSpanStartLine l, srcSpanStartCol l)+srcSpanEndLoc l    = L (srcSpanEndLine l, srcSpanEndCol l)+oneLine l          = srcSpanStartLine l == srcSpanEndLine l+lineCol l          = (srcSpanStartLine l, srcSpanStartCol l)++realSrcSpanSourcePos :: RealSrcSpan -> SourcePos+realSrcSpanSourcePos s = newPos file line col+  where+    file               = unpackFS $ srcSpanFile s+    line               = srcSpanStartLine       s+    col                = srcSpanStartCol        s+++realSrcSpanSourcePosE :: RealSrcSpan -> SourcePos+realSrcSpanSourcePosE s = newPos file line col+  where+    file                = unpackFS $ srcSpanFile s+    line                = srcSpanEndLine       s+    col                 = srcSpanEndCol        s+++getSourcePos           = srcSpanSourcePos  . getSrcSpan+getSourcePosE          = srcSpanSourcePosE . getSrcSpan++collectArguments n e = if length xs > n then take n xs else xs+  where (vs', e') = collectValBinders' $ snd $ collectTyBinders e+        vs        = fst $ collectValBinders $ ignoreLetBinds e'+        xs        = vs' ++ vs++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 (Let (NonRec _ _) e')+  = ignoreLetBinds e'+ignoreLetBinds e+  = e++isDictionaryExpression :: Core.Expr Id -> Maybe Id+isDictionaryExpression (Tick _ e) = isDictionaryExpression e+isDictionaryExpression (Var x)    | isDictionary x = Just x+isDictionaryExpression _          = Nothing+++realTcArity :: TyCon -> Arity+realTcArity+  = kindArity . TC.tyConKind++kindArity :: Kind -> Arity+kindArity (FunTy _ res)+  = 1 + kindArity res+kindArity (ForAllTy _ res)+  = kindArity res+kindArity _+  = 0+++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 = Imported [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+                        _     -> Out.panic "lookupRdrNameInModule"+                Nothing -> throwCmdLineErrorS dflags $ Out.hsep [Out.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 . Out.showSDoc dflags+        throwCmdLineError = throwGhcException . CmdLineError+++qualImportDecl mn = (simpleImportDecl mn) { ideclQualified = True }++ignoreInline x = x {pm_parsed_source = go <$> pm_parsed_source x}+  where go  x = x {hsmodDecls = filter go' $ hsmodDecls x}+        go' x | SigD (InlineSig _ _) <-  unLoc x = False+              | otherwise                        = True++symbolTyConWithKind k x i n = stringTyConWithKind k x i (symbolString n)+symbolTyCon x i n = stringTyCon x i (symbolString n)+symbolTyVar n = stringTyVar (symbolString n)++++varSymbol ::  Var -> Symbol+varSymbol v+  | us `isSuffixOfSym` vs = vs+  | otherwise             = suffixSymbol vs us+  where+    us                    = symbol $ showPpr $ getDataConVarUnique v+    vs                    = symbol $ getName v++qualifiedNameSymbol n = symbol $+  case nameModule_maybe n of+    Nothing -> occNameFS (getOccName n)+    Just m  -> concatFS [moduleNameFS (moduleName m), fsLit ".", occNameFS (getOccName n)]++instance Symbolic FastString where+  symbol = symbol . fastStringText++fastStringText = T.decodeUtf8 . fastStringToByteString++tyConTyVarsDef c | TC.isPrimTyCon c || isFunTyCon c = []+tyConTyVarsDef c | TC.isPromotedTyCon   c = panic Nothing ("TyVars on " ++ show c) -- tyConTyVarsDef $ TC.ty_con c+tyConTyVarsDef c | TC.isPromotedDataCon c = panic Nothing ("TyVars on " ++ show c) -- DC.dataConUnivTyVars $ TC.datacon c+tyConTyVarsDef c = TC.tyConTyVars c++----------------------------------------------------------------------+-- Myriad Instances+----------------------------------------------------------------------++instance Symbolic TyCon where+  symbol = symbol . qualifiedNameSymbol . getName++instance Symbolic Name where+  symbol = symbol . showPpr++instance Symbolic Var where+  symbol = varSymbol++instance Hashable Var where+  hashWithSalt = uniqueHash++instance Hashable TyCon 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 = showPpr++instance Show Var where+  show = showPpr++instance Show Class where+  show = showPpr++instance Show TyCon where+  show = showPpr++instance NFData Class where+  rnf t = seq t ()++instance NFData SrcSpan 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 ()+++----------------------------------------------------------------------+-- GHC Compatibility Layer+----------------------------------------------------------------------++gHC_VERSION :: String+gHC_VERSION = show __GLASGOW_HASKELL__++symbolFastString :: Symbol -> FastString+symbolFastString = mkFastStringByteString . T.encodeUtf8 . symbolText++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 $ hscDesugarWithLoc hsc_env_tmp ms tcg+  return DesugaredModule { dm_typechecked_module = tcm, dm_core_module = guts }++-- desugarModule = GHC.desugarModule++type Prec = TyPrec++lintCoreBindings :: [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc)+lintCoreBindings = CoreLint.lintCoreBindings CoreDoNothing++synTyConRhs_maybe :: TyCon -> Maybe Type+synTyConRhs_maybe = TC.synTyConRhs_maybe++tcRnLookupRdrName :: HscEnv -> GHC.Located RdrName -> IO (Messages, Maybe [Name])+tcRnLookupRdrName = TcRnDriver.tcRnLookupRdrName+++------------------------------------------------------------------------+-- | Manipulating Symbols ----------------------------------------------+------------------------------------------------------------------------++dropModuleNames, takeModuleNames, dropModuleUnique :: Symbol -> Symbol+dropModuleNames  = mungeNames lastName sepModNames "dropModuleNames: "+  where+    lastName msg = symbol . safeLast msg++takeModuleNames  = mungeNames initName sepModNames "takeModuleNames: "+  where+    initName msg = symbol . T.intercalate "." . safeInit msg++dropModuleUnique = mungeNames headName sepUnique   "dropModuleUnique: "+  where+    headName msg = symbol . safeHead msg+++sepModNames = "."+sepUnique   = "#"+++-- safeHead :: String -> [T.Text] -> Symbol+-- safeHead msg []  = errorstar $ "safeHead with empty list" ++ msg+-- safeHead _ (x:_) = symbol x++-- safeInit :: String -> [T.Text] -> Symbol+-- safeInit _ xs@(_:_)      = symbol $ T.intercalate "." $ init xs+-- safeInit msg _           = errorstar $ "safeInit with empty list " ++ msg++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)++isQualified y = "." `T.isInfixOf` y+wrapParens x  = "(" `mappend` x `mappend` ")"+isParened xs  = xs /= stripParens xs++isDictionary = isPrefixOfSym "$f" . dropModuleNames . symbol+isInternal   = isPrefixOfSym "$"  . 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++--------------------------------------------------------------------------------+-- | Source Info = Stack of most recent binders/spans+--------------------------------------------------------------------------------
+ src/Language/Haskell/Liquid/GHC/Play.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TypeSynonymInstances      #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE TupleSections             #-}++module Language.Haskell.Liquid.GHC.Play where++import Prelude hiding (error)+import GHC+import CoreSyn+import Var+import TypeRep++import Coercion++import           Control.Arrow       ((***))+import qualified Data.HashMap.Strict as M++import Language.Haskell.Liquid.GHC.Misc ()+import Language.Haskell.Liquid.Types.Errors++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 (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 s tv@(TyVarTy v)  = M.lookupDefault tv v s+substTysWith s (FunTy t1 t2)   = FunTy (substTysWith s t1) (substTysWith s t2)+substTysWith s (ForAllTy v t)  = ForAllTy v (substTysWith (M.delete 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
+ src/Language/Haskell/Liquid/GHC/SpanStack.hs view
@@ -0,0 +1,75 @@+{-# 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           SrcLoc+import qualified Var+import           CoreSyn                   hiding (Tick, Var)+import           Name                             (getSrcSpan)+import           FastString                       (fsLit)+import           Data.Maybe                       (listToMaybe, fromMaybe)+import           Language.Haskell.Liquid.GHC.Misc (tickSrcSpan, showPpr)++-- | 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  !Var.Var           -- ^ binder for whom we are generating constraint+  | Tick !(Tickish Var.Var) -- ^ nearest known Source Span++instance Show Span where+  show (Var x)   = show x+  show (Tick tt) = showPpr tt++--------------------------------------------------------------------------------+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++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/GhcInterface.hs 
@@ -1,387 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE TypeSynonymInstances      #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE ScopedTypeVariables       #-}--module Language.Haskell.Liquid.GhcInterface (--  -- * extract all information needed for verification-    getGhcInfo--  ) where-import IdInfo-import InstEnv-import Bag (bagToList)-import ErrUtils-import GHC hiding (Target, desugarModule)-import DriverPhases (Phase(..))-import DriverPipeline (compileFile)-import Text.PrettyPrint.HughesPJ-import HscTypes hiding (Target)-import CoreSyn--import Class-import Var-import CoreMonad    (liftIO)-import DataCon-import qualified Control.Exception as Ex--import GHC.Paths (libdir)-import System.FilePath ( replaceExtension, normalise)--import DynFlags-import Control.Monad (filterM, foldM, when, forM, forM_, liftM)-import Control.Applicative  hiding (empty)-import Data.Monoid hiding ((<>))-import Data.List (find, nub)-import Data.Maybe (catMaybes, maybeToList)-import qualified Data.HashSet        as S--import System.Console.CmdArgs.Verbosity (whenLoud)-import System.Directory (removeFile, createDirectoryIfMissing, doesFileExist)-import Language.Fixpoint.Types hiding (Result, Expr)-import Language.Fixpoint.Misc--import Language.Haskell.Liquid.Types-import Language.Haskell.Liquid.Errors-import Language.Haskell.Liquid.ANFTransform-import Language.Haskell.Liquid.Bare-import Language.Haskell.Liquid.GhcMisc-import Language.Haskell.Liquid.Misc-import Language.Haskell.Liquid.PrettyPrint-import Language.Haskell.Liquid.Visitors-import Language.Haskell.Liquid.CmdLine (withCabal, withPragmas)-import Language.Haskell.Liquid.Parse-import qualified Language.Haskell.Liquid.Measure as Ms--import Language.Fixpoint.Names-import Language.Fixpoint.Files-------------------------------------------------------------------------getGhcInfo :: Config -> FilePath -> IO (Either ErrorResult GhcInfo)----------------------------------------------------------------------getGhcInfo cfg target = (Right <$> getGhcInfo' cfg target)-                          `Ex.catch` (\(e :: SourceError) -> handle e)-                          `Ex.catch` (\(e :: Error)       -> handle e)-                          `Ex.catch` (\(e :: [Error])     -> handle e)-  where-    handle            = return . Left . result---getGhcInfo' cfg0 target-  = runGhc (Just libdir) $ do-      liftIO              $ cleanFiles target-      addTarget         =<< guessTarget target Nothing-      (name,tgtSpec)     <- liftIO $ parseSpec target-      cfg                <- liftIO $ withPragmas cfg0 target $ Ms.pragmas tgtSpec-      cfg                <- liftIO $ withCabal cfg-      let paths           = idirs cfg-      updateDynFlags cfg-      liftIO              $ whenLoud $ putStrLn ("paths = " ++ show paths)-      let name'           = ModName Target (getModName name)-      impNames           <- allDepNames <$> depanal [] False-      impSpecs           <- getSpecs (real cfg) (totality cfg) target paths impNames [Spec, Hs, LHs]-      compileCFiles      =<< liftIO (foldM (\c (f,_,s) -> withPragmas c f (Ms.pragmas s)) cfg impSpecs)-      impSpecs'          <- forM impSpecs $ \(f,n,s) -> do-        when (not $ isSpecImport n) $-          addTarget =<< guessTarget f Nothing-        return (n,s)-      load LoadAllTargets-      modguts            <- getGhcModGuts1 target-      hscEnv             <- getSession-      coreBinds          <- liftIO $ anormalize (not $ nocaseexpand cfg) hscEnv modguts-      let datacons        = [ dataConWorkId dc-                            | tc <- mgi_tcs modguts-                            , dc <- tyConDataCons tc-                            ]-      let impVs           = importVars  coreBinds ++ classCons (mgi_cls_inst modguts)-      let defVs           = definedVars coreBinds-      let useVs           = readVars    coreBinds-      let letVs           = letVars     coreBinds-      let derVs           = derivedVars coreBinds $ fmap (fmap is_dfun) $ mgi_cls_inst modguts-      logicmap           <- liftIO makeLogicMap-      (spec, imps, incs) <- moduleSpec cfg coreBinds (impVs ++ defVs) letVs name' modguts tgtSpec logicmap impSpecs'-      liftIO              $ whenLoud $ putStrLn $ "Module Imports: " ++ show imps-      hqualFiles         <- moduleHquals modguts paths target imps incs-      return              $ GI hscEnv coreBinds derVs impVs (letVs ++ datacons) useVs hqualFiles imps incs spec---makeLogicMap-  = do lg    <- getCoreToLogicPath-       lspec <- readFile lg-       return $ parseSymbolToLogic lg lspec--classCons :: Maybe [ClsInst] -> [Id]-classCons Nothing   = []-classCons (Just cs) = concatMap (dataConImplicitIds . head . tyConDataCons . classTyCon . is_cls) cs--derivedVars :: CoreProgram -> Maybe [DFunId] -> [Id]-derivedVars cbs (Just fds) = concatMap (derivedVs cbs) fds-derivedVars _    Nothing    = []--derivedVs :: CoreProgram -> DFunId -> [Id]-derivedVs cbs fd = concatMap bindersOf cbf ++ deps-  where cbf            = filter f cbs--        f (NonRec x _) = eqFd x-        f (Rec xes   ) = any eqFd (fst <$> xes)-        eqFd x         = varName x == varName fd-        deps :: [Id]-        deps = concatMap dep $ (unfoldingInfo . idInfo <$> concatMap bindersOf cbf)--        dep (DFunUnfolding _ _ e)         = concatMap grapDep  e-        dep (CoreUnfolding {uf_tmpl = e}) = grapDep  e-        dep _                             = []--        grapDep :: CoreExpr -> [Id]-        grapDep e           = freeVars S.empty e--updateDynFlags cfg-  = do df <- getSessionDynFlags-       let df' = df { importPaths  = idirs cfg ++ importPaths df-                    , libraryPaths = idirs cfg ++ libraryPaths df-                    , includePaths = idirs cfg ++ includePaths df-                    , profAuto     = ProfAutoCalls-                    , ghcLink      = LinkInMemory-                    --FIXME: this *should* be HscNothing, but that prevents us from-                    -- looking up *unexported* names in another source module..-                    , hscTarget    = HscInterpreted -- HscNothing-                    , ghcMode      = CompManager-                    -- prevent GHC from printing anything-                    , log_action   = \_ _ _ _ _ -> return ()-                    -- , verbosity = 3-                    } `xopt_set` Opt_MagicHash-                  --     `gopt_set` Opt_Hpc-                      `gopt_set` Opt_ImplicitImportQualified-                      `gopt_set` Opt_PIC-#if __GLASGOW_HASKELL__ >= 710-                      `gopt_set` Opt_Debug-#endif-       (df'',_,_) <- parseDynamicFlags df' (map noLoc $ ghcOptions cfg)-       setSessionDynFlags $ df'' -- {profAuto = ProfAutoAll}--compileCFiles cfg-  = do df  <- getSessionDynFlags-       setSessionDynFlags $ df { includePaths = nub $ idirs cfg ++ includePaths df-                               , 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-       setSessionDynFlags $ df { ldInputs = map (FileOption "") os ++ ldInputs df }---mgi_namestring = moduleNameString . moduleName . mgi_module--importVars            = freeVars S.empty--definedVars           = concatMap defs-  where-    defs (NonRec x _) = [x]-    defs (Rec xes)    = map fst xes------------------------------------------------------------------------ | Extracting CoreBindings From File -----------------------------------------------------------------------------------------------getGhcModGuts1 :: FilePath -> Ghc MGIModGuts-getGhcModGuts1 fn = do-   modGraph <- getModuleGraph-   case find ((== fn) . msHsFilePath) modGraph of-     Just modSummary -> do-       -- mod_guts <- modSummaryModGuts modSummary-       mod_p    <- parseModule modSummary-       mod_guts <- coreModule <$> (desugarModule =<< typecheckModule (ignoreInline mod_p))-       let deriv = getDerivedDictionaries mod_guts -       return   $! (miModGuts (Just deriv) mod_guts)-     Nothing     -> exitWithPanic "Ghc Interface: Unable to get GhcModGuts"--getDerivedDictionaries cm = instEnvElts $ mg_inst_env cm--cleanFiles :: FilePath -> IO ()-cleanFiles fn-  = do forM_ bins (tryIgnore "delete binaries" . removeFileIfExists)-       tryIgnore "create temp directory" $ createDirectoryIfMissing False dir-    where-       bins = replaceExtension fn <$> ["hi", "o"]-       dir  = tempDirectory fn---removeFileIfExists f = doesFileExist f >>= (`when` removeFile f)------------------------------------------------------------------------------------- | Desugaring (Taken from GHC, modified to hold onto Loc in Ticks) ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- | Extracting Qualifiers ----------------------------------------------------------------------------------------------------------------------------------------moduleHquals mg paths target imps incs-  = do hqs   <- specIncludes Hquals paths incs-       hqs'  <- moduleImports [Hquals] paths (mgi_namestring mg : imps)-       hqs'' <- liftIO   $ filterM doesFileExist [extFileName Hquals target]-       let rv = sortNub  $ hqs'' ++ hqs ++ (snd <$> hqs')-       liftIO $ whenLoud $ putStrLn $ "Reading Qualifiers From: " ++ show rv-       return rv------------------------------------------------------------------------------------- | Extracting Specifications (Measures + Assumptions) -----------------------------------------------------------------------------------------------------------moduleSpec cfg cbs vars defVars target mg tgtSpec logicmap impSpecs-  = do addImports  impSpecs-       addContext  $ IIModule $ moduleName $ mgi_module mg-       env        <- getSession-       let specs   = (target,tgtSpec):impSpecs-       let imps    = sortNub $ impNames ++ [ symbolString x-                                           | (_,spec) <- specs-                                           , x <- Ms.imports spec-                                           ]-       ghcSpec    <- liftIO $ makeGhcSpec cfg target cbs vars defVars exports env logicmap specs-       return      (ghcSpec, imps, Ms.includes tgtSpec)-    where-      exports    = mgi_exports mg-      impNames   = map (getModString.fst) impSpecs-      addImports = mapM (addContext . IIDecl . qualImportDecl . getModName . fst)--allDepNames = concatMap (map declNameString . ms_textual_imps)--declNameString = moduleNameString . unLoc . ideclName . unLoc--patErrorName    = "PatErr"-realSpecName    = "Real"-notRealSpecName = "NotReal"--getSpecs rflag tflag target paths names exts-  = do fs'     <- sortNub <$> moduleImports exts paths names-       patSpec <- getPatSpec paths tflag-       rlSpec  <- getRealSpec paths rflag-       let fs  = patSpec ++ rlSpec ++ fs'-       liftIO  $ whenLoud $ putStrLn ("getSpecs: " ++ show fs)-       transParseSpecs exts paths (S.singleton target) mempty (map snd fs)--getPatSpec paths totalitycheck-  | totalitycheck-  = (map (patErrorName, )) . maybeToList <$> moduleFile paths patErrorName Spec-  | otherwise-  = return []--getRealSpec paths freal-  | freal-  = (map (realSpecName, )) . maybeToList <$> moduleFile paths realSpecName Spec-  | otherwise-  = (map (notRealSpecName, )) . maybeToList <$> moduleFile paths notRealSpecName Spec--transParseSpecs _ _ _ specs []-  = return specs-transParseSpecs exts paths seenFiles specs newFiles-  = do newSpecs  <- liftIO $ mapM (\f -> addFst3 f <$> parseSpec f) newFiles-       impFiles  <- moduleImports exts paths $ specsImports newSpecs-       let seenFiles' = seenFiles  `S.union` (S.fromList newFiles)-       let specs'     = specs ++ map (third noTerm) newSpecs-       let newFiles'  = [f | (_,f) <- impFiles, not (f `S.member` seenFiles')]-       transParseSpecs exts paths seenFiles' specs' newFiles'-  where-    specsImports ss = nub $ concatMap (map symbolString . Ms.imports . thd3) ss-    noTerm spec = spec { Ms.decr=mempty, Ms.lazy=mempty, Ms.termexprs=mempty }-    third f (a,b,c) = (a,b,f c)--parseSpec :: FilePath -> IO (ModName, Ms.BareSpec)-parseSpec file-  = do whenLoud $ putStrLn $ "parseSpec: " ++ file-       either Ex.throw return . specParser file =<< readFile file--specParser file str-  | isExtFile Spec file  = specSpecificationP file str-  | isExtFile Hs file    = hsSpecificationP   file str-  | isExtFile LHs file   = lhsSpecificationP  file str-  | otherwise            = exitWithPanic $ "SpecParser: Cannot Parse File " ++ file--moduleImports :: GhcMonad m => [Ext] -> [FilePath] -> [String] -> m [(String, FilePath)]-moduleImports exts paths names-  = liftM concat $ forM names $ \name -> do-      map (name,) . catMaybes <$> mapM (moduleFile paths name) exts--moduleFile :: GhcMonad m => [FilePath] -> String -> Ext -> m (Maybe FilePath)-moduleFile paths name ext-  | ext `elem` [Hs, LHs]-  = do mg <- getModuleGraph-       case find ((==name) . moduleNameString . ms_mod_name) mg of-         Nothing -> liftIO $ getFileInDirs (extModuleName name ext) paths-         Just ms -> return $ normalise <$> ml_hs_file (ms_location ms)-  | otherwise-  = liftIO $ getFileInDirs (extModuleName name ext) paths--specIncludes :: GhcMonad m => Ext -> [FilePath] -> [FilePath] -> m [FilePath]-specIncludes ext paths reqs-  = do let libFile  = extFileNameR ext $ symbolString preludeName-       let incFiles = catMaybes $ reqFile ext <$> reqs-       liftIO $ forM (libFile : incFiles) $ \f -> do-         mfile <- getFileInDirs f paths-         case mfile of-           Just file -> return file-           Nothing -> errorstar $ "cannot find " ++ f ++ " in " ++ show paths--reqFile ext s-  | isExtFile ext s-  = Just s-  | otherwise-  = Nothing------instance PPrint GhcSpec where-  pprint spec =  (text "******* Target Variables ********************")-              $$ (pprint $ tgtVars spec)-              $$ (text "******* Type Signatures *********************")-              $$ (pprintLongList $ tySigs spec)-              $$ (text "******* Assumed Type Signatures *************")-              $$ (pprintLongList $ asmSigs spec)-              $$ (text "******* DataCon Specifications (Measure) ****")-              $$ (pprintLongList $ ctors spec)-              $$ (text "******* Measure Specifications **************")-              $$ (pprintLongList $ meas spec)--instance PPrint GhcInfo where-  pprint info =   (text "*************** Imports *********************")-              $+$ (intersperse comma $ text <$> imports info)-              $+$ (text "*************** Includes ********************")-              $+$ (intersperse comma $ text <$> includes info)-              $+$ (text "*************** Imported Variables **********")-              $+$ (pprDoc $ impVars info)-              $+$ (text "*************** Defined Variables ***********")-              $+$ (pprDoc $ defVars info)-              $+$ (text "*************** Specification ***************")-              $+$ (pprint $ spec info)-              $+$ (text "*************** Core Bindings ***************")-              $+$ (pprint $ cbs info)--instance Show GhcInfo where-  show = showpp--instance PPrint [CoreBind] where-  pprint = pprDoc . tidyCBs--instance PPrint TargetVars where-  pprint AllVars   = text "All Variables"-  pprint (Only vs) = text "Only Variables: " <+> pprint vs----------------------------------------------------------------------------- Dealing With Errors ----------------------------------------------------------------------------------------------------------------------------- | Convert a GHC error into one of ours-instance Result SourceError where-  result = (`Crash` "Invalid Source")-         . concatMap errMsgErrors-         . bagToList-         . srcErrorMessages--errMsgErrors e = [ ErrGhc (errMsgSpan e) (pprint e)]
− src/Language/Haskell/Liquid/GhcMisc.hs 
@@ -1,520 +0,0 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE TypeSynonymInstances      #-}-{-# LANGUAGE UndecidableInstances      #-}---- | 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.GhcMisc where--import PrelNames (fractionalClassKeys)-import Class     (classKey)--import           Debug.Trace--import           Avail                        (availsToNameSet)-import           BasicTypes                   (Arity)-import           CoreSyn                      hiding (Expr, sourceName)-import qualified CoreSyn as Core-import           CostCentre-import           GHC                          hiding (L)-import           HscTypes                     (Dependencies, ImportedMods, ModGuts(..))-import           Kind                         (superKind)-import           NameSet                      (NameSet)-import           SrcLoc                       (mkRealSrcLoc, mkRealSrcSpan, srcSpanFileName_maybe)-import           Bag-import           ErrUtils-import           CoreLint-import           CoreMonad--import           Language.Fixpoint.Names      (dropModuleNames)-import           Text.Parsec.Pos              (sourceName, sourceLine, sourceColumn, SourcePos, newPos)-import           Language.Fixpoint.Types      hiding (Constant (..), SESearch(..))-import           Name                         (mkInternalName, getSrcSpan, nameModule_maybe)-import           Module                       (moduleNameFS)-import           OccName                      (mkTyVarOcc, mkTcOcc, occNameFS)-import           Unique-import           Finder                       (findImportedModule, cannotFindModule)-import           Panic                        (throwGhcException)-import           HscTypes                     (HscEnv(..), FindResult(..))-import           FastString-import           TcRnDriver-import           TcRnTypes--import           RdrName-import           Type                         (liftedTypeKind)-import           TypeRep-import           Var-import           IdInfo-import qualified TyCon                        as TC--- import qualified DataCon                      as DC-import           Data.Char                    (isLower, isSpace)-import           Data.Monoid                  (mempty)-import           Data.Hashable-import qualified Data.HashSet                 as S-import qualified Data.List                    as L-import           Data.Aeson-import qualified Data.Text.Encoding           as T-import qualified Data.Text.Unsafe             as T-import           Control.Applicative          ((<$>), (<*>))-import           Control.Arrow                (second)-import           Outputable                   (Outputable (..), text, ppr)-import qualified Outputable                   as Out-import           DynFlags--import qualified Text.PrettyPrint.HughesPJ    as PJ--import Data.Monoid (mappend)--import Language.Fixpoint.Names      (symSepName, isSuffixOfSym, singletonSym)---#if __GLASGOW_HASKELL__ < 710-import Language.Haskell.Liquid.Desugar.HscMain-#else-import Language.Haskell.Liquid.Desugar710.HscMain---import qualified HscMain as GHC-#endif------------------------------------------------------------------------------------------ Datatype For Holding GHC ModGuts ------------------------------------------------------------------------------------------------data MGIModGuts = MI {-    mgi_binds     :: !CoreProgram-  , mgi_module    :: !Module-  , mgi_deps      :: !Dependencies-  , mgi_dir_imps  :: !ImportedMods-  , mgi_rdr_env   :: !GlobalRdrEnv-  , mgi_tcs       :: ![TyCon]-  , mgi_fam_insts :: ![FamInst]-  , mgi_exports   :: !NameSet-  , mgi_cls_inst  :: !(Maybe [ClsInst])-  }--miModGuts cls mg  = MI {-    mgi_binds     = mg_binds mg-  , mgi_module    = mg_module mg-  , mgi_deps      = mg_deps mg-  , mgi_dir_imps  = mg_dir_imps mg-  , mgi_rdr_env   = mg_rdr_env mg-  , mgi_tcs       = mg_tcs mg-  , mgi_fam_insts = mg_fam_insts mg-  , mgi_exports   = availsToNameSet $ mg_exports mg-  , mgi_cls_inst  = cls-  }----------------------------------------------------------------------------------------- Generic Helpers for Encoding Location -------------------------------------------------------------------------------------------srcSpanTick :: Module -> SrcSpan -> Tickish a-srcSpanTick m loc-  = ProfNote (AllCafsCC m loc) False True--tickSrcSpan ::  Outputable a => Tickish a -> SrcSpan-tickSrcSpan (ProfNote cc _ _) = cc_loc cc-#if __GLASGOW_HASKELL__ >= 710-tickSrcSpan (SourceNote ss _) = RealSrcSpan ss-#endif-tickSrcSpan _                 = noSrcSpan----------------------------------------------------------------------------------------- Generic Helpers for Accessing GHC Innards ---------------------------------------------------------------------------------------stringTyVar :: String -> TyVar-stringTyVar s = mkTyVar name liftedTypeKind-  where name = mkInternalName (mkUnique 'x' 24)  occ noSrcSpan-        occ  = mkTyVarOcc s--stringTyCon :: Char -> Int -> String -> TyCon-stringTyCon c n s = TC.mkKindTyCon name superKind-  where-    name          = mkInternalName (mkUnique c n) occ noSrcSpan-    occ           = mkTcOcc s--hasBaseTypeVar = isBaseType . varType---- same as Constraint isBase-isBaseType (TyVarTy _)     = True-isBaseType (TyConApp _ ts) = all isBaseType ts-isBaseType (FunTy t1 t2)   = isBaseType t1 && isBaseType t2-isBaseType _               = False-validTyVar :: String -> Bool-validTyVar s@(c:_) = isLower c && all (not . isSpace) s-validTyVar _       = False--tvId α = {- traceShow ("tvId: α = " ++ show α) $ -} showPpr α ++ show (varUnique α)--tracePpr s x = trace ("\nTrace: [" ++ s ++ "] : " ++ showPpr x) x--pprShow = text . show---tidyCBs = map unTick--unTick (NonRec b e) = NonRec b (unTickExpr e)-unTick (Rec bs)     = Rec $ map (second unTickExpr) bs--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 clas = classKey clas `elem` fractionalClassKeys-------------------------------------------------------------------------------------------- Generic Helpers for DataConstructors -----------------------------------------------------------------------------------------isDataConId id = case idDetails id of-                  DataConWorkId _ -> True-                  DataConWrapId _ -> True-                  _               -> False--getDataConVarUnique v-  | isId v && isDataConId v = getUnique $ idDataCon v-  | otherwise               = getUnique v---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 s) = hashWithSalt i (uniq s)-  hashWithSalt i (RealSrcSpan s)   = hashWithSalt i (srcSpanStartLine s, srcSpanStartCol s, srcSpanEndCol s)--instance Outputable a => Outputable (S.HashSet a) where-  ppr = ppr . S.toList--instance ToJSON RealSrcSpan where-  toJSON sp = object [ "filename"  .= f  -- (unpackFS $ srcSpanFile sp)-                     , "startLine" .= l1 -- srcSpanStartLine sp-                     , "startCol"  .= c1 -- srcSpanStartCol  sp-                     , "endLine"   .= l2 -- srcSpanEndLine   sp-                     , "endCol"    .= c2 -- srcSpanEndCol    sp-                     ]-    where-      (f, l1, c1, l2, c2) = unpackRealSrcSpan sp--unpackRealSrcSpan rsp = (f, l1, c1, l2, c2)-  where-    f                 = unpackFS $ srcSpanFile rsp-    l1                = srcSpanStartLine rsp-    c1                = srcSpanStartCol  rsp-    l2                = srcSpanEndLine   rsp-    c2                = srcSpanEndCol    rsp---instance FromJSON RealSrcSpan where-  parseJSON (Object v) = realSrcSpan <$> v .: "filename"-                                     <*> v .: "startLine"-                                     <*> v .: "startCol"-                                     <*> v .: "endLine"-                                     <*> v .: "endCol"-  parseJSON _          = mempty--realSrcSpan f l1 c1 l2 c2 = mkRealSrcSpan loc1 loc2-  where-    loc1                  = mkRealSrcLoc (fsLit f) l1 c1-    loc2                  = mkRealSrcLoc (fsLit f) l2 c2----instance ToJSON SrcSpan where-  toJSON (RealSrcSpan rsp) = object [ "realSpan" .= True, "spanInfo" .= rsp ]-  toJSON (UnhelpfulSpan _) = object [ "realSpan" .= False ]--instance FromJSON SrcSpan where-  parseJSON (Object v) = do tag <- v .: "realSpan"-                            case tag of-                              False -> return noSrcSpan-                              True  -> RealSrcSpan <$> v .: "spanInfo"-  parseJSON _          = mempty------------------------------------------------------------toFixSDoc = PJ.text . PJ.render . toFix-sDocDoc   = PJ.text . showSDoc-pprDoc    = sDocDoc . ppr---- Overriding Outputable functions because they now require DynFlags!-showPpr       = showSDoc . ppr---- FIXME: somewhere we depend on this printing out all GHC entities with--- fully-qualified names...-showSDoc sdoc = Out.renderWithStyle unsafeGlobalDynFlags sdoc (Out.mkUserStyle Out.alwaysQualify Out.AllTheWay)-showSDocDump  = Out.showSDocDump unsafeGlobalDynFlags--typeUniqueString = {- ("sort_" ++) . -} showSDocDump . ppr--instance Fixpoint Var where-  toFix = pprDoc--instance Fixpoint Name where-  toFix = pprDoc--instance Fixpoint Type where-  toFix = pprDoc--instance Show Name where-  show = showPpr--instance Show Var where-  show = showPpr--instance Show Class where-  show = showPpr--instance Show TyCon where-  show = showPpr--sourcePosSrcSpan   :: SourcePos -> SrcSpan-sourcePosSrcSpan = srcLocSpan . sourcePosSrcLoc--sourcePosSrcLoc    :: SourcePos -> SrcLoc-sourcePosSrcLoc p = mkSrcLoc (fsLit file) line col-  where-    file          = sourceName p-    line          = sourceLine p-    col           = sourceColumn p--srcSpanSourcePos :: SrcSpan -> SourcePos-srcSpanSourcePos (UnhelpfulSpan _) = dummyPos "LH.GhcMisc.srcSpanSourcePos"-srcSpanSourcePos (RealSrcSpan s)   = realSrcSpanSourcePos s--srcSpanSourcePosE :: SrcSpan -> SourcePos-srcSpanSourcePosE (UnhelpfulSpan _) = dummyPos "LH.GhcMisc.srcSpanSourcePos"-srcSpanSourcePosE (RealSrcSpan s)   = realSrcSpanSourcePosE s----srcSpanFilename    = maybe "" unpackFS . srcSpanFileName_maybe-srcSpanStartLoc l  = L (srcSpanStartLine l, srcSpanStartCol l)-srcSpanEndLoc l    = L (srcSpanEndLine l, srcSpanEndCol l)-oneLine l          = srcSpanStartLine l == srcSpanEndLine l-lineCol l          = (srcSpanStartLine l, srcSpanStartCol l)--realSrcSpanSourcePos :: RealSrcSpan -> SourcePos-realSrcSpanSourcePos s = newPos file line col-  where-    file               = unpackFS $ srcSpanFile s-    line               = srcSpanStartLine       s-    col                = srcSpanStartCol        s---realSrcSpanSourcePosE :: RealSrcSpan -> SourcePos-realSrcSpanSourcePosE s = newPos file line col-  where-    file                = unpackFS $ srcSpanFile s-    line                = srcSpanEndLine       s-    col                 = srcSpanEndCol        s---getSourcePos           = srcSpanSourcePos  . getSrcSpan-getSourcePosE          = srcSpanSourcePosE . getSrcSpan--collectArguments n e = if length xs > n then take n xs else xs-  where (vs', e') = collectValBinders' $ snd $ collectTyBinders e-        vs        = fst $ collectValBinders $ ignoreLetBinds e'-        xs        = vs' ++ vs--collectValBinders' expr = go [] expr-  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 (Let (NonRec _ _) e')-  = ignoreLetBinds e'-ignoreLetBinds e-  = e--isDictionaryExpression :: Core.Expr Id -> Maybe Id-isDictionaryExpression (Tick _ e) = isDictionaryExpression e-isDictionaryExpression (Var x)    | isDictionary x = Just x-isDictionaryExpression _          = Nothing--isDictionary x = L.isPrefixOf "$f" (symbolString $ dropModuleNames $ symbol x)-isInternal   x = L.isPrefixOf "$"  (symbolString $ dropModuleNames $ symbol x)---realTcArity :: TyCon -> Arity-realTcArity-  = kindArity . TC.tyConKind--kindArity :: Kind -> Arity-kindArity (FunTy _ res)-  = 1 + kindArity res-kindArity (ForAllTy _ res)-  = kindArity res-kindArity _-  = 0---instance Hashable Var where-  hashWithSalt = uniqueHash--instance Hashable TyCon where-  hashWithSalt = uniqueHash--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 = Imported [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-                        _     -> Out.panic "lookupRdrNameInModule"-                Nothing -> throwCmdLineErrorS dflags $ Out.hsep [Out.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 . Out.showSDoc dflags-        throwCmdLineError = throwGhcException . CmdLineError---addContext m = getContext >>= setContext . (m:)--qualImportDecl mn = (simpleImportDecl mn) { ideclQualified = True }--ignoreInline x = x {pm_parsed_source = go <$> pm_parsed_source x}-  where go  x = x {hsmodDecls = filter go' $ hsmodDecls x}-        go' x | SigD (InlineSig _ _) <-  unLoc x = False-              | otherwise                        = True--symbolTyCon x i n = stringTyCon x i (symbolString n)-symbolTyVar n = stringTyVar (symbolString n)--instance Symbolic TyCon where-  symbol = symbol . qualifiedNameSymbol . getName--instance Symbolic Name where-  symbol = symbol . showPpr -- qualifiedNameSymbol---instance Symbolic Var where-  symbol = varSymbol--varSymbol ::  Var -> Symbol-varSymbol v-  | us `isSuffixOfSym` vs = vs-  | otherwise             = vs `mappend` singletonSym symSepName `mappend` us-  where us  = symbol $ showPpr $ getDataConVarUnique v-        vs  = symbol $ getName v---qualifiedNameSymbol n = symbol $-  case nameModule_maybe n of-    Nothing -> occNameFS (getOccName n)-    Just m  -> concatFS [moduleNameFS (moduleName m), fsLit ".", occNameFS (getOccName n)]--instance Symbolic FastString where-  symbol = symbol . fastStringText--fastStringText = T.decodeUtf8 . fastStringToByteString--tyConTyVarsDef c | TC.isPrimTyCon c || isFunTyCon c = []-tyConTyVarsDef c | TC.isPromotedTyCon   c = error ("TyVars on " ++ show c) -- tyConTyVarsDef $ TC.ty_con c-tyConTyVarsDef c | TC.isPromotedDataCon c = error ("TyVars on " ++ show c) -- DC.dataConUnivTyVars $ TC.datacon c-tyConTyVarsDef c = TC.tyConTyVars c ----------------------------------------------------------------------------- GHC Compatibility Layer-------------------------------------------------------------------------gHC_VERSION :: String-gHC_VERSION = show __GLASGOW_HASKELL__--desugarModule :: TypecheckedModule -> Ghc DesugaredModule--symbolFastString :: Symbol -> FastString--lintCoreBindings :: [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc)--synTyConRhs_maybe :: TyCon -> Maybe Type--tcRnLookupRdrName :: HscEnv -> GHC.Located RdrName -> IO (Messages, Maybe [Name])--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 $ hscDesugarWithLoc hsc_env_tmp ms tcg-  return $ DesugaredModule { dm_typechecked_module = tcm, dm_core_module = guts }--#if __GLASGOW_HASKELL__ < 710---- 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 $ hscDesugarWithLoc hsc_env_tmp ms tcg---   return $ DesugaredModule { dm_typechecked_module = tcm, dm_core_module = guts }--symbolFastString = T.unsafeDupablePerformIO . mkFastStringByteString . T.encodeUtf8 . symbolText--lintCoreBindings = CoreLint.lintCoreBindings--synTyConRhs_maybe t-  | Just (TC.SynonymTyCon rhs) <- TC.synTyConRhs_maybe t-  = Just rhs-synTyConRhs_maybe _                     = Nothing--tcRnLookupRdrName env rn = TcRnDriver.tcRnLookupRdrName env (unLoc rn)--#else---- desugarModule = GHC.desugarModule--symbolFastString = mkFastStringByteString . T.encodeUtf8 . symbolText--type Prec = TyPrec--lintCoreBindings = CoreLint.lintCoreBindings CoreDoNothing--synTyConRhs_maybe = TC.synTyConRhs_maybe--tcRnLookupRdrName = TcRnDriver.tcRnLookupRdrName--#endif
− src/Language/Haskell/Liquid/GhcPlay.hs 
@@ -1,84 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE TypeSynonymInstances      #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE TupleSections             #-}--module Language.Haskell.Liquid.GhcPlay where--import GHC-import CoreSyn-import Var-import TypeRep-import TcRnMonad-import Coercion--import           Control.Arrow       ((***))-import qualified Data.HashMap.Strict as M--import Language.Haskell.Liquid.GhcMisc ()--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 _ _              = error "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 (Var x) = x-subVar  _      = error "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 s tv@(TyVarTy v)  = M.lookupDefault tv v s-substTysWith s (FunTy t1 t2)   = FunTy (substTysWith s t1) (substTysWith s t2)-substTysWith s (ForAllTy v t)  = ForAllTy v (substTysWith (M.delete 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
+ src/Language/Haskell/Liquid/Interactive/Handler.hs view
@@ -0,0 +1,30 @@+module Language.Haskell.Liquid.Interactive.Handler (+    -- * Initial state for server+    initial++    -- * Command handler+  , handler+  ) where++import Prelude hiding (error)+import Control.Concurrent.MVar+import Language.Haskell.Liquid.Interactive.Types+import Language.Haskell.Liquid.Liquid++------------------------------------------------------------------------------+handler :: MVar State -> Command -> IO Response+------------------------------------------------------------------------------+handler r = modifyMVar r . runLiquid'++runLiquid' :: Command -> State -> IO (State, Response)+runLiquid' cfg s = do+  let mE    = sMbEnv s+  let n     = sCount s+  (c, mE') <- runLiquid mE cfg+  let s'    = State (n + 1) mE'+  return      (s', (status c, n))++------------------------------------------------------------------------------+initial :: State+------------------------------------------------------------------------------+initial = State 0 Nothing
+ src/Language/Haskell/Liquid/Interactive/Types.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances  #-}++module Language.Haskell.Liquid.Interactive.Types+  (+    -- * Commands+    Command++    -- * Response+  , Response++  , status++    -- * State+  , State (..)++  ) where++import Prelude        hiding (error)+import Data.Serialize        ( Serialize )+import GHC.Generics+import System.Console.CmdArgs+import System.Exit+import Language.Haskell.Liquid.Types (Config (..))+import Language.Haskell.Liquid.Liquid+import Language.Fixpoint.Types ()++-------------------------------------------------------------------------------+-- | State --------------------------------------------------------------------+-------------------------------------------------------------------------------++data State = State { sCount  :: Int+                   , sMbEnv :: MbEnv+                   }++-------------------------------------------------------------------------------+-- | Command ------------------------------------------------------------------+-------------------------------------------------------------------------------++type Command = Config++-------------------------------------------------------------------------------+-- | Response -----------------------------------------------------------------+-------------------------------------------------------------------------------++data Status = ResOk+            | ResFail Int+               deriving ( Generic, Data, Typeable, Show )++type Response = (Status, Int)++instance Serialize Status++status :: ExitCode -> Status+status ExitSuccess     = ResOk+status (ExitFailure n) = ResFail n
+ src/Language/Haskell/Liquid/Liquid.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-@ LIQUID "--diff"     @-}++module Language.Haskell.Liquid.Liquid (+   -- * Executable command+    liquid++   -- * Single query+  , runLiquid++   -- * Ghci State+  , MbEnv+  ) where++import           Prelude hiding (error)+import           Data.Maybe+import           System.Exit+import           Control.DeepSeq+import           Text.PrettyPrint.HughesPJ+import           CoreSyn+import           Var+import           HscTypes                         (SourceError)+import           System.Console.CmdArgs.Verbosity (whenLoud, whenNormal)+import           System.Console.CmdArgs.Default+import           GHC (HscEnv)++import qualified Control.Exception as Ex+import qualified Language.Fixpoint.Types.Config as FC+import qualified Language.Haskell.Liquid.UX.DiffCheck as DC+import           Language.Fixpoint.Misc+import           Language.Fixpoint.Solver+import qualified Language.Fixpoint.Types as F+import           Language.Haskell.Liquid.Types+import           Language.Haskell.Liquid.UX.Errors+import           Language.Haskell.Liquid.UX.CmdLine+import           Language.Haskell.Liquid.UX.Tidy+import           Language.Haskell.Liquid.GHC.Interface+import           Language.Haskell.Liquid.Constraint.Generate+import           Language.Haskell.Liquid.Constraint.ToFixpoint+import           Language.Haskell.Liquid.Constraint.Types+import           Language.Haskell.Liquid.Transforms.Rec+import           Language.Haskell.Liquid.UX.Annotate (mkOutput)++type MbEnv = Maybe HscEnv++------------------------------------------------------------------------------+liquid :: [String] -> IO b+------------------------------------------------------------------------------+liquid args = getOpts args >>= runLiquid Nothing >>= exitWith . fst++------------------------------------------------------------------------------+-- | This fellow does the real work+------------------------------------------------------------------------------+runLiquid :: MbEnv -> Config -> IO (ExitCode, MbEnv)+------------------------------------------------------------------------------+runLiquid mE cfg = do+  (d, mE') <- checkMany cfg mempty mE (files cfg)+  return      (ec d, mE')+  where+    ec     = resultExit . o_result+++------------------------------------------------------------------------------+checkMany :: Config -> Output Doc -> MbEnv -> [FilePath] -> IO (Output Doc, MbEnv)+------------------------------------------------------------------------------+checkMany cfg d mE (f:fs) = do+  (d', mE') <- checkOne mE cfg f+  checkMany cfg (d `mappend` d') mE' fs++checkMany _   d mE [] =+  return (d, mE)++------------------------------------------------------------------------------+checkOne :: MbEnv -> Config -> FilePath -> IO (Output Doc, Maybe HscEnv)+------------------------------------------------------------------------------+checkOne mE cfg t = do+  z <- actOrDie (checkOne' mE cfg t)+  case z of+    Left e -> do+      d <- exitWithResult cfg t $ mempty { o_result = e }+      return (d, Nothing)+    Right r ->+      return r+++checkOne' :: MbEnv -> Config -> FilePath -> IO (Output Doc, Maybe HscEnv)+checkOne' mE cfg t = do+  (gInfo, hEnv) <- getGhcInfo mE cfg t+  d <- liquidOne t gInfo+  return (d, Just hEnv)+++actOrDie :: IO a -> IO (Either ErrorResult a)+actOrDie act =+    (Right <$> act)+      `Ex.catch` (\(e :: SourceError) -> handle e)+      `Ex.catch` (\(e :: Error)       -> handle e)+      `Ex.catch` (\(e :: UserError)   -> handle e)+      `Ex.catch` (\(e :: [Error])     -> handle e)++handle :: (Result a) => a -> IO (Either ErrorResult b)+handle = return . Left . result++------------------------------------------------------------------------------+liquidOne :: FilePath -> GhcInfo -> IO (Output Doc)+------------------------------------------------------------------------------+liquidOne tgt info = do+  whenNormal $ donePhase Loud "Extracted Core using GHC"+  let cfg   = config $ spec info+  whenLoud  $ do putStrLn "**** Config **************************************************"+                 print cfg+  whenLoud  $ do putStrLn $ showpp info+                 putStrLn "*************** Original CoreBinds ***************************"+                 putStrLn $ render $ pprintCBs (cbs info)+  let cbs' = transformScope (cbs info)+  whenLoud  $ do donePhase Loud "transformRecExpr"+                 putStrLn "*************** Transform Rec Expr CoreBinds *****************"+                 putStrLn $ render $ pprintCBs cbs'+                 putStrLn "*************** Slicing Out Unchanged CoreBinds *****************"+  dc <- prune cfg cbs' tgt info+  let cbs'' = maybe cbs' DC.newBinds dc+  let info' = maybe info (\z -> info {spec = DC.newSpec z}) dc+  let cgi   = {-# SCC "generateConstraints" #-} generateConstraints $! info' {cbs = cbs''}+  cgi `deepseq` donePhase Loud "generateConstraints"+  whenLoud  $ dumpCs cgi+  out      <- solveCs cfg tgt cgi info' dc+  whenNormal $ donePhase Loud "solve"+  let out'  = mconcat [maybe mempty DC.oldOutput dc, out]+  DC.saveResult tgt out'+  exitWithResult cfg tgt out'++dumpCs :: CGInfo -> IO ()+dumpCs cgi = do+  putStrLn "***************************** SubCs *******************************"+  putStrLn $ render $ pprintMany (hsCs cgi)+  putStrLn "***************************** FixCs *******************************"+  putStrLn $ render $ pprintMany (fixCs cgi)+  putStrLn "***************************** WfCs ********************************"+  putStrLn $ render $ pprintMany (hsWfs cgi)++pprintMany :: (PPrint a) => [a] -> Doc+pprintMany xs = vcat [ pprint x $+$ text " " | x <- xs ]++checkedNames ::  Maybe DC.DiffCheck -> Maybe [String]+checkedNames dc          = concatMap names . DC.newBinds <$> dc+   where+     names (NonRec v _ ) = [render . text $ shvar v]+     names (Rec xs)      = map (shvar . fst) xs+     shvar               = showpp . varName++prune :: Config -> [CoreBind] -> FilePath -> GhcInfo -> IO (Maybe DC.DiffCheck)+prune cfg cbinds tgt info+  | not (null vs) = return . Just $ DC.DC (DC.thin cbinds vs) mempty sp+  | diffcheck cfg = DC.slice tgt cbinds sp+  | otherwise     = return Nothing+  where+    vs            = tgtVars sp+    sp            = spec info++++solveCs :: Config -> FilePath -> CGInfo -> GhcInfo -> Maybe DC.DiffCheck -> IO (Output Doc)+solveCs cfg tgt cgi info dc+  = do finfo        <- cgInfoFInfo info cgi tgt+       F.Result r sol <- solve fx finfo+       let names = checkedNames dc+       let warns = logErrors cgi+       let annm  = annotMap cgi+       let res   = ferr sol r+       let out0  = mkOutput cfg res sol annm+       return    $ out0 { o_vars    = names             }+                        { o_errors  = e2u sol <$> warns }+                        { o_result  = res               }+    where+       fx        = def { FC.solver      = fromJust (smtsolver cfg)+                       , FC.linear      = linear      cfg+                       , FC.newcheck    = newcheck    cfg+                       -- , FC.extSolver   = extSolver   cfg+                       , FC.eliminate   = eliminate   cfg+                       , FC.save        = saveQuery cfg+                       , FC.srcFile     = tgt+                       , FC.cores       = cores       cfg+                       , FC.minPartSize = minPartSize cfg+                       , FC.maxPartSize = maxPartSize cfg+                       , FC.elimStats   = elimStats   cfg+                       -- , FC.stats   = True+                       }+       ferr s  = fmap (cinfoUserError s . snd)+++cinfoUserError   :: F.FixSolution -> Cinfo -> UserError+cinfoUserError s =  e2u s . cinfoError++e2u :: F.FixSolution -> Error -> UserError+e2u s = fmap pprint . tidyError s++-- writeCGI tgt cgi = {-# SCC "ConsWrite" #-} writeFile (extFileName Cgi tgt) str+--   where+--     str          = {-# SCC "PPcgi" #-} showpp cgi
− src/Language/Haskell/Liquid/Literals.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Language.Haskell.Liquid.Literals (-        literalFRefType, literalFReft, literalConst-        ) where--import TypeRep-import Literal --import Language.Haskell.Liquid.Measure-import Language.Haskell.Liquid.Types-import Language.Haskell.Liquid.RefType-import Language.Haskell.Liquid.CoreToLogic (mkLit)--import qualified Language.Fixpoint.Types as F--import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Data.Monoid-import Control.Applicative----------------------------------------------------------------------------------------- Typing Literals -----------------------------------------------------------------------------------------makeRTypeBase (TyVarTy α)    x-  = RVar (rTyVar α) x-makeRTypeBase (TyConApp c ts) x-  = rApp c ((`makeRTypeBase` mempty) <$> ts) [] x-makeRTypeBase _              _-  = error "RefType : makeRTypeBase"--literalFRefType l-  = makeRTypeBase (literalType l) (literalFReft l)--literalFReft l = maybe mempty mkReft $ mkLit l--mkReft e = case e of-            F.ESym (F.SL str) ->-              -- FIXME: unsorted equality is shady, better to not embed Add# as int..-              F.meet (F.uexprReft e)-                     (F.reft "v" (F.PAtom F.Eq-                                  (F.EApp (name strLen) [F.EVar "v"])-                                  (F.ECon (F.I (fromIntegral (T.length str))))))-            _ -> F.exprReft e---- | `literalConst` returns `Nothing` for unhandled lits because---    otherwise string-literals show up as global int-constants---    which blow up qualifier instantiation.--literalConst tce l         = (sort, mkLit l)-  where-    sort                   = typeSort tce $ literalType l
src/Language/Haskell/Liquid/Measure.hs view
@@ -9,13 +9,13 @@   , MSpec (..)   , mkM, mkMSpec, mkMSpec'   , qualifySpec-  , mapTy   , dataConTypes   , defRefType   , strLen   , wiredInMeasures   ) where +import Prelude hiding (error) import GHC hiding (Located) import Var import Type@@ -24,30 +24,33 @@ import Text.PrettyPrint.HughesPJ hiding (first) import Text.Printf (printf) import DataCon+import Language.Haskell.Liquid.Types.Errors -import qualified Data.HashMap.Strict as M -import qualified Data.HashSet        as S -import Data.List (foldl')+import qualified Data.HashMap.Strict as M+import qualified Data.HashSet        as S+import Data.List (foldl', partition) -import Data.Monoid hiding ((<>))-import Data.Bifunctor-import Control.Applicative      ((<$>)) -import Data.Maybe (fromMaybe) +++import Data.Maybe (fromMaybe, isNothing)+ import Language.Fixpoint.Misc-import Language.Fixpoint.Types hiding (Def, R)-import Language.Haskell.Liquid.GhcMisc+import Language.Fixpoint.Types hiding (R, SrcSpan)+import Language.Haskell.Liquid.GHC.Misc import Language.Haskell.Liquid.Types    hiding (GhcInfo(..), GhcSpec (..))-import Language.Haskell.Liquid.RefType-import Language.Haskell.Liquid.Variance-import Language.Haskell.Liquid.Bounds +import Language.Haskell.Liquid.Types.RefType+import Language.Haskell.Liquid.Types.Variance+import Language.Haskell.Liquid.Types.Bounds+import Language.Haskell.Liquid.UX.Tidy+ -- MOVE TO TYPES type BareSpec      = Spec BareType LocSymbol -data Spec ty bndr  = Spec {-    measures   :: ![Measure ty bndr]            -- ^ User-defined properties for ADTs+data Spec ty bndr  = Spec+  { measures   :: ![Measure ty bndr]            -- ^ User-defined properties for ADTs   , asmSigs    :: ![(LocSymbol, ty)]            -- ^ Assumed (unchecked) types   , sigs       :: ![(LocSymbol, ty)]            -- ^ Imported functions and types   , localSigs  :: ![(LocSymbol, ty)]            -- ^ Local type signatures@@ -57,17 +60,17 @@   , dataDecls  :: ![DataDecl]                   -- ^ Predicated data definitions   , includes   :: ![FilePath]                   -- ^ Included qualifier files   , aliases    :: ![RTAlias Symbol BareType]    -- ^ RefType aliases-  , paliases   :: ![RTAlias Symbol Pred]        -- ^ Refinement/Predicate aliases   , ealiases   :: ![RTAlias Symbol Expr]        -- ^ Expression aliases-  , embeds     :: !(TCEmb (LocSymbol))          -- ^ GHC-Tycon-to-fixpoint Tycon map+  , embeds     :: !(TCEmb LocSymbol)            -- ^ GHC-Tycon-to-fixpoint Tycon map   , qualifiers :: ![Qualifier]                  -- ^ Qualifiers in source/spec files   , decr       :: ![(LocSymbol, [Int])]         -- ^ Information on decreasing arguments-  , lvars      :: ![(LocSymbol)]                -- ^ Variables that should be checked in the environment they are used+  , lvars      :: ![LocSymbol]                  -- ^ Variables that should be checked in the environment they are used   , lazy       :: !(S.HashSet LocSymbol)        -- ^ Ignore Termination Check in these Functions+  , axioms     :: !(S.HashSet LocSymbol)        -- ^ Binders to turn into axiomatized functions   , hmeas      :: !(S.HashSet LocSymbol)        -- ^ Binders to turn into measures using haskell definitions   , hbounds    :: !(S.HashSet LocSymbol)        -- ^ Binders to turn into bounds using haskell definitions   , inlines    :: !(S.HashSet LocSymbol)        -- ^ Binders to turn into logic inline using haskell definitions-  , autosize   :: !(S.HashSet LocSymbol)        -- ^ Type Constructors that get automatically sizing info +  , autosize   :: !(S.HashSet LocSymbol)        -- ^ Type Constructors that get automatically sizing info   , pragmas    :: ![Located String]             -- ^ Command-line configurations passed in through source   , cmeasures  :: ![Measure ty ()]              -- ^ Measures attached to a type-class   , imeasures  :: ![Measure ty bndr]            -- ^ Mappings from (measure,type) -> measure@@ -79,36 +82,6 @@   }  --- MOVE TO TYPES-data MSpec ty ctor = MSpec { -    ctorMap  :: M.HashMap Symbol [Def ty ctor]-  , measMap  :: M.HashMap LocSymbol (Measure ty ctor)-  , cmeasMap :: M.HashMap LocSymbol (Measure ty ())-  , imeas    :: ![Measure ty ctor]-  }---instance (Show ty, Show ctor, PPrint ctor, PPrint ty) => Show (MSpec ty ctor) where-  show (MSpec ct m cm im)-    = "\nMSpec:\n" ++-      "\nctorMap:\t "  ++ show ct ++-      "\nmeasMap:\t "  ++ show m  ++-      "\ncmeasMap:\t " ++ show cm ++-      "\nimeas:\t "    ++ show im ++-      "\n"--instance Eq ctor => Monoid (MSpec ty ctor) where-  mempty = MSpec M.empty M.empty M.empty []--  (MSpec c1 m1 cm1 im1) `mappend` (MSpec c2 m2 cm2 im2)-    | null dups-    = MSpec (M.unionWith (++) c1 c2) (m1 `M.union` m2)-           (cm1 `M.union` cm2) (im1 ++ im2)-    | otherwise-    = errorstar $ err (head dups)-    where dups = [(k1, k2) | k1 <- M.keys m1 , k2 <- M.keys m2, val k1 == val k2]-          err (k1, k2) = printf "\nDuplicate Measure Definitions for %s\n%s" (showpp k1) (showpp $ map loc [k1, k2])- qualifySpec name sp = sp { sigs      = [ (tx x, t)  | (x, t)  <- sigs sp]                          , asmSigs   = [ (tx x, t)  | (x, t)  <- asmSigs sp] --                          , termexprs = [ (tx x, es) | (x, es) <- termexprs sp]@@ -117,11 +90,11 @@     tx = fmap (qualifySymbol name)  mkM ::  LocSymbol -> ty -> [Def ty bndr] -> Measure ty bndr-mkM name typ eqns +mkM name typ eqns   | all ((name ==) . measure) eqns   = M name typ eqns   | otherwise-  = errorstar $ "invalid measure definition for " ++ (show name)+  = panic Nothing $ "invalid measure definition for " ++ show name  -- mkMSpec :: [Measure ty LocSymbol] -> [Measure ty ()] -> [Measure ty LocSymbol] --         -> MSpec ty LocSymbol@@ -139,14 +112,21 @@     ms'    = checkDuplicateMeasure ms     -- ms'    = checkFail "Duplicate Measure Definition" (distinct . fmap name) ms -+--checkFail ::  [Char] -> (a -> Bool) -> a -> a+--checkFail msg f x+--  | f x+--  = x+--  | otherwise+--  = errorstar $ "Check-Failure: " ++ msg +--distinct ::  Ord a => [a] -> Bool+--distinct xs = length xs == length (sortNub xs)   checkDuplicateMeasure ms   = case M.toList dups of       []         -> ms-      mms        -> errorstar $ concatMap err mms+      mms        -> panic Nothing $ concatMap err mms     where       gms        = group [(name m , m) | m <- ms]       dups       = M.filter ((1 <) . length) gms@@ -168,13 +148,13 @@            , dataDecls  = dataDecls s1            ++ dataDecls s2            , includes   = sortNub $ includes s1   ++ includes s2            , aliases    =           aliases s1    ++ aliases s2-           , paliases   =           paliases s1   ++ paliases s2            , ealiases   =           ealiases s1   ++ ealiases s2-           , embeds     = M.union   (embeds s1)     (embeds s2)+           , embeds     = M.union   (embeds s1)      (embeds s2)            , qualifiers =           qualifiers s1 ++ qualifiers s2            , decr       =           decr s1       ++ decr s2            , lvars      =           lvars s1      ++ lvars s2            , lazy       = S.union   (lazy s1)        (lazy s2)+           , axioms     = S.union   (axioms s1)      (axioms s2)            , hmeas      = S.union   (hmeas s1)       (hmeas s2)            , hbounds    = S.union   (hbounds s1)     (hbounds s2)            , inlines    = S.union   (inlines s1)     (inlines s2)@@ -200,7 +180,6 @@            , dataDecls  = []            , includes   = []            , aliases    = []-           , paliases   = []            , ealiases   = []            , embeds     = M.empty            , qualifiers = []@@ -208,6 +187,7 @@            , lvars      = []            , lazy       = S.empty            , hmeas      = S.empty+           , axioms     = S.empty            , hbounds    = S.empty            , inlines    = S.empty            , autosize   = S.empty@@ -221,136 +201,157 @@            , bounds     = M.empty            } --- MOVE TO TYPES-instance Functor (Def t) where-  fmap f def = def { ctor = f (ctor def) }+dataConTypes :: MSpec (RRType Reft) DataCon -> ([(Var, RRType Reft)], [(LocSymbol, RRType Reft)])+dataConTypes  s = (ctorTys, measTys)+  where+    measTys     = [(name m, sort m) | m <- M.elems (measMap s) ++ imeas s]+    ctorTys     = concatMap makeDataConType (snd <$> (M.toList $ ctorMap s)) --- MOVE TO TYPES-instance Functor (Measure t) where-  fmap f (M n s eqs) = M n s (fmap (fmap f) eqs) -instance Functor CMeasure where-  fmap f (CM n t) = CM n (f t) --- MOVE TO TYPES-instance Functor (MSpec t) where-  fmap f (MSpec c m cm im) = MSpec (fc c) (fm m) cm (fmap (fmap f) im)-     where fc = fmap $ fmap $ fmap f-           fm = fmap $ fmap f+makeDataConType :: [Def (RRType Reft) DataCon] -> [(Var, RRType Reft)]+makeDataConType []+  = []+makeDataConType ds | isNothing (dataConWrapId_maybe dc)+  = [(woId, combineDCTypes t ts)]+  where+    dc   = ctor $ head ds+    woId = dataConWorkId dc+    t    = varType woId+    ts   = defRefType t <$> ds --- MOVE TO TYPES-instance Bifunctor Def where-  first  f def  = def { dparams = mapSnd f <$> dparams def-                      , dsort = f <$> dsort def-                      , binds = mapSnd (f <$>) <$> binds def}-  second f def  = def {ctor    = f $ ctor def}+makeDataConType ds+  = [(woId, extend loci woRType wrRType), (wrId, extend loci wrRType woRType)]+  where+    (wo, wr) = partition isWorkerDef ds+    dc       = ctor $ head ds+    loci     = loc $ measure $ head ds+    woId     = dataConWorkId dc+    wot      = varType woId+    wrId     = dataConWrapId dc+    wrt      = varType wrId+    wots     = defRefType wot <$> wo+    wrts     = defRefType wrt <$> wr --- MOVE TO TYPES-instance Bifunctor Measure where-  first f (M n s eqs)  = M n (f s) (first f <$> eqs)-  second f (M n s eqs) = M n s (second f <$> eqs)+    wrRType  = combineDCTypes wrt wrts+    woRType  = combineDCTypes wot wots --- MOVE TO TYPES-instance Bifunctor MSpec   where-  first f (MSpec c m cm im) = MSpec (fmap (fmap (first f)) c) (fmap (first f) m) (fmap (first f) cm) (fmap (first f) im)-  second                    = fmap --- MOVE TO TYPES-instance Bifunctor Spec    where-  first f s-    = s { measures   = first  f <$> (measures s)-        , asmSigs    = second f <$> (asmSigs s)-        , sigs       = second f <$> (sigs s)-        , localSigs  = second f <$> (localSigs s)-        , invariants = fmap   f <$> (invariants s)-        , ialiases   = fmapP  f <$> (ialiases s)-        , cmeasures  = first f  <$> (cmeasures s)-        , imeasures  = first f  <$> (imeasures s)-        , classes    = fmap f   <$> (classes s)-        , rinstance  = fmap f   <$> (rinstance s)-        , bounds     = fmap (first f) (bounds s)-        }-    where fmapP f (x, y)       = (fmap f x, fmap f y)+    isWorkerDef def+      -- types are missing for arguments, so definition came from a logical measure+      -- and it is for the worker datacon+      | any isNothing (snd <$> binds def)+      = True+      | otherwise+      = length (binds def) == length (fst $ splitFunTys $ snd $ splitForAllTys wot) -  second f s-    = s { measures   = fmap (second f) (measures s)-        , imeasures  = fmap (second f) (imeasures s)-        } --- MOVE TO TYPES-instance PPrint Body where-  pprint (E e)   = pprint e-  pprint (P p)   = pprint p-  pprint (R v p) = braces (pprint v <+> text "|" <+> pprint p)+extend lc t1' t2+  | Just su <- mapArgumens lc t1 t2+  = t1 `strengthenResult` (subst su $ fromMaybe mempty (stripRTypeBase $ resultTy t2))+  | otherwise+  = t1+  where+    t1 = noDummySyms t1' --- instance PPrint a => Fixpoint (PPrint a) where---   toFix (BDc c)  = toFix c---   toFix (BTup n) = parens $ toFix n --- MOVE TO TYPES-instance PPrint a => PPrint (Def t a) where-  pprint (Def m p c _ bs body) = pprint m <+> pprint (fst <$> p) <+> cbsd <> text " = " <> pprint body   -    where cbsd = parens (pprint c <> hsep (pprint `fmap` (fst <$> bs)))+resultTy = ty_res . toRTypeRep --- MOVE TO TYPES-instance (PPrint t, PPrint a) => PPrint (Measure t a) where-  pprint (M n s eqs) =  pprint n <> text " :: " <> pprint s-                     $$ vcat (pprint `fmap` eqs)+strengthenResult t r = fromRTypeRep $ rep{ty_res = ty_res rep `strengthen` r}+  where+    rep = toRTypeRep t --- MOVE TO TYPES-instance (PPrint t, PPrint a) => PPrint (MSpec t a) where-  pprint =  vcat . fmap pprint . fmap snd . M.toList . measMap --- MOVE TO TYPES-instance PPrint (Measure t a) => Show (Measure t a) where-  show = showpp+noDummySyms t+  | any isDummy (ty_binds rep)+  = subst su $ fromRTypeRep $ rep{ty_binds = xs'}+  | otherwise+  = t+  where+    rep = toRTypeRep t+    xs' = zipWith (\_ i -> symbol ("x" ++ show i)) (ty_binds rep) [1..]+    su  = mkSubst $ zip (ty_binds rep) (EVar <$> xs') -instance PPrint t => PPrint (CMeasure t) where-  pprint (CM n s) =  pprint n <> text " :: " <> pprint s+combineDCTypes t = foldl' strengthenRefTypeGen (ofType t) -instance PPrint (CMeasure t) => Show (CMeasure t) where-  show = showpp+mapArgumens :: SourcePos -> RRType Reft -> RRType Reft -> Maybe Subst+mapArgumens lc t1 t2 = go xts1' xts2'+  where+    xts1 = zip (ty_binds rep1) (ty_args rep1)+    xts2 = zip (ty_binds rep2) (ty_args rep2)+    rep1 = toRTypeRep t1+    rep2 = toRTypeRep t2 --- MOVE TO TYPES-mapTy :: (tya -> tyb) -> Measure tya c -> Measure tyb c-mapTy = first +    xts1' = dropWhile canDrop xts1+    xts2' = dropWhile canDrop xts2 -dataConTypes :: MSpec (RRType Reft) DataCon -> ([(Var, RRType Reft)], [(LocSymbol, RRType Reft)])-dataConTypes  s = (ctorTys, measTys)+    canDrop (_, t) = isClassType t || isEqType t++    go xs ys+      | length xs == length ys && and (zipWith (==) (toRSort . snd <$> xts1') (toRSort . snd <$> xts2'))+      = Just $ mkSubst $ zipWith (\y x -> (fst x, EVar $ fst y)) xts1' xts2'+      | otherwise+      = panic (Just $ sourcePosSrcSpan lc) ("The types for the wrapper and worker data constroctors cannot be merged\n"+          ++ show t1 ++ "\n" ++ show t2 )++defRefType :: Type -> Def (RRType Reft) DataCon -> RRType Reft+defRefType tdc (Def f args dc mt xs body)+                     = {- traceShow "defRefType: " $ -} generalize $ mkArrow [] [] [] xts t'   where-    measTys     = [(name m, sort m) | m <- M.elems (measMap s) ++ imeas s]-    ctorTys     = concatMap mkDataConIdsTy [(defsVar ds, defsTy ds)-                                           | (_, ds) <- M.toList (ctorMap s)-                                                       ]-    defsTy ds@(d:_) = foldl' strengthenRefTypeGen (ofType $ dataConUserType $ ctor d) (defRefType <$> ds)-    defsTy []       = errorstar "Measure.defsTy: This cannot happen"+    xts              = stitchArgs (fSrcSpan f) dc xs ts+    t                = fromMaybe (ofType tr) mt+    t'               = mkForAlls args $ refineWithCtorBody dc f (fst <$> args) body t+    mkForAlls xts t  = foldl' (\t (x, tx) -> RAllE x tx t) t xts+    (ts, tr)         = splitFunTys $ snd $ splitForAllTys tdc -    defsVar     = ctor . safeHead "defsVar"  -defRefType :: Def (RRType Reft) DataCon -> RRType Reft-defRefType (Def f args dc mt xs body) = generalize $ mkArrow [] [] [] xts t'-  where -    t   = fromMaybe (ofType $ dataConOrigResTy dc) mt-    xts = safeZipWith msg g xs $ ofType `fmap` dataConOrigArgTys dc-    g (x, Nothing) t = (x, t, mempty) -    g (x, Just t)  _ = (x, t, mempty)-    t'  = mkForAlls args $ refineWithCtorBody dc f (fst <$> args) body t -    msg = "defRefType dc = " ++ showPpr dc +stitchArgs sp dc xs ts+  | nXs == nTs         = zipWith g xs $ ofType `fmap` ts+  | otherwise          = panicFieldNumMismatch sp dc nXs nTs+    where+      nXs              = length xs+      nTs              = length ts+      g (x, Just t) _  = (x, t, mempty)+      g (x, _)      t  = (x, t, mempty) -    mkForAlls xts t = foldl' (\t (x, tx) -> RAllE x tx t) t xts+-- validArgs :: [(Symbol, Maybe (RRType Reft))] -> [Type] -> Bool+-- validArgs xs ts = nXs == nTs+--   where+--    otherwise               = and (zipWith eqBSort xs ts)+--   nXs /= nTs            = panicFieldNumMismatch sp dc nXs nTs+--     eqBSort (_, Nothing) _  = True+--     eqBSort (x, Just t)  t'+--       | eqSort t t'         = True+--       | otherwise           = panicFieldSortMismatch sp dc x +-- eqSort :: RRType Reft -> Type -> Bool+-- eqSort t t'             = s == s'+  -- where+    -- s  = traceShow "sort1" $ toRSort t+    -- s' = traceShow "sort2" $ toRSort (ofType t' :: RRType Reft) +panicFieldNumMismatch sp dc nXs nTs = panicDataCon sp dc msg+  where+    msg = "Requires" <+> pprint nTs <+> "fields but given" <+> pprint nXs++-- panicFieldSortMismatch sp dc x = panicDataCon sp dc msg+  -- where+    -- msg = "Field type mismatch for" <+> pprint x++panicDataCon sp dc d+  = panicError $ ErrDataCon sp (pprint dc) d+ refineWithCtorBody dc f as body t =-  case stripRTypeBase t of +  case stripRTypeBase t of     Just (Reft (v, _)) ->-      strengthen t $ Reft (v, Refa $ bodyPred (EApp f (eVar <$> (as ++ [v]))) body)-    Nothing -> -      errorstar $ "measure mismatch " ++ showpp f ++ " on con " ++ showPpr dc+      strengthen t $ Reft (v, bodyPred (mkEApp f (eVar <$> (as ++ [v]))) body)+    Nothing ->+      panic Nothing $ "measure mismatch " ++ showpp f ++ " on con " ++ showPpr dc  -bodyPred ::  Expr -> Body -> Pred+bodyPred ::  Expr -> Body -> Expr bodyPred fv (E e)    = PAtom Eq fv e-bodyPred fv (P p)    = PIff  (PBexp fv) p+bodyPred fv (P p)    = PIff  fv p bodyPred fv (R v' p) = subst1 p (v', fv)
src/Language/Haskell/Liquid/Misc.hs view
@@ -1,40 +1,34 @@-{-# LANGUAGE CPP                       #-} {-# LANGUAGE TupleSections             #-}  module Language.Haskell.Liquid.Misc where -import Control.Applicative-import System.FilePath--import qualified Data.List as L--import Language.Fixpoint.Misc (errorstar)+import Prelude hiding (error)+import Control.Monad (liftM2) -import Data.List              (sort)+import Control.Arrow (first)+import System.FilePath -import Paths_liquidhaskell+import           Control.Exception     (catch, IOException)+import qualified Data.HashSet          as S+import qualified Data.HashMap.Strict   as M+import qualified Data.List             as L+import           Data.Maybe+import           Data.Hashable+import qualified Data.ByteString       as B+import           Data.ByteString.Char8 (pack, unpack)+import           Text.PrettyPrint.HughesPJ ((<>), char) -firstDuplicate :: Ord a => [a] -> Maybe a-firstDuplicate = go . sort-  where-    go (y:x:xs) | x == y    = Just x -                | otherwise = go (x:xs)-    go _                    = Nothing            +import           Language.Fixpoint.Misc+import           Paths_liquidhaskell  -safeIndex err n ls -  | n >= length ls-  = errorstar err-  | otherwise -  = ls !! n- (!?) :: [a] -> Int -> Maybe a []     !? _ = Nothing (x:_)  !? 0 = Just x (_:xs) !? n = xs !? (n-1)  safeFromJust _  (Just x) = x-safeFromJust err _        = errorstar err+safeFromJust err _       = errorstar err  fst4 (a,_,_,_) = a snd4 (_,b,_,_) = b@@ -51,7 +45,9 @@ fourth4 (_,_,_,x) = x third4  (_,_,x,_) = x -mapSndM f (x, y) = return . (x,) =<< f y+mapSndM :: (Applicative m) => (b -> m c) -> (a, b) -> m (a, c)+-- mapSndM f (x, y) = return . (x,) =<< f y+mapSndM f (x, y) = (x, ) <$> f y  firstM  f (a,b) = (,b) <$> f a secondM f (a,b) = (a,) <$> f b@@ -62,23 +58,15 @@  third3 f (a,b,c) = (a,b,f c) -zip4 (x1:xs1) (x2:xs2) (x3:xs3) (x4:xs4) = (x1, x2, x3, x4) : (zip4 xs1 xs2 xs3 xs4) +zip4 (x1:xs1) (x2:xs2) (x3:xs3) (x4:xs4) = (x1, x2, x3, x4) : zip4 xs1 xs2 xs3 xs4 zip4 _ _ _ _                             = [] -#if __GLASGOW_HASKELL__ < 710-ghc = "ghc-7.8"-#else-ghc = "ghc-7.10"-#endif  getIncludeDir      = dropFileName <$> getDataFileName ("include" </> "Prelude.spec") getCssPath         = getDataFileName $ "syntax" </> "liquid.css" getCoreToLogicPath = fmap (</> "CoreToLogic.lg") getIncludeDir  -maximumWithDefault zero [] = zero-maximumWithDefault _    xs = maximum xs- {-@ type ListN a N = {v:[a] | len v = N} @-} {-@ type ListL a L = ListN a (len L) @-} @@ -97,25 +85,86 @@ mapN n f (x:xs) = x : mapN (n-1) f xs mapN _ _ []     = [] +zipWithDefM :: Monad m => (a -> a -> m a) -> [a] -> [a] -> m [a]+zipWithDefM _ []     []     = return []+zipWithDefM _ xs     []     = return xs+zipWithDefM _ []     ys     = return ys+zipWithDefM f (x:xs) (y:ys) = liftM2 (:) (f x y) (zipWithDefM f xs ys) - -pad _ f [] ys   = (f <$> ys, ys)-pad _ f xs []   = (xs, f <$> xs)-pad msg _ xs ys-  | nxs == nys  = (xs, ys)-  | otherwise   = errorstar $ "pad: " ++ msg+--------------------------------------------------------------------------------+-- Originally part of Fixpoint's Misc:+--------------------------------------------------------------------------------++single x = [x]++mapFst f (x, y)  = (f x, y)+mapSnd f (x, y)  = (x, f y)++mapFst3 f (x, y, z) = (f x, y, z)+mapSnd3 f (x, y, z) = (x, f y, z)+mapThd3 f (x, y, z) = (x, y, f z)+++hashMapMapWithKey   :: (k -> v1 -> v2) -> M.HashMap k v1 -> M.HashMap k v2+hashMapMapWithKey f = fromJust . M.traverseWithKey (\k v -> Just (f k v))++hashMapMapKeys      :: (Eq k, Hashable k) => (t -> k) -> M.HashMap t v -> M.HashMap k v+hashMapMapKeys f    = M.fromList . fmap (first f) . M.toList++concatMapM f = fmap concat . mapM f++firstElems ::  [(B.ByteString, B.ByteString)] -> B.ByteString -> Maybe (Int, B.ByteString, (B.ByteString, B.ByteString))+firstElems seps str+  = case splitters seps str of+      [] -> Nothing+      is -> Just $ L.minimumBy (\x y -> compare (fst3 x) (fst3 y)) is++splitters seps str+  = [(i, c', z) | (c, c') <- seps+                , let z   = B.breakSubstring c str+                , let i   = B.length (fst z)+                , i < B.length str                 ]++bchopAlts :: [(B.ByteString, B.ByteString)] -> B.ByteString -> [B.ByteString]+bchopAlts seps  = go   where-    nxs         = length xs-    nys         = length ys+    go  s               = maybe [s] go' (firstElems seps s)+    go' (_,c',(s0, s1)) = if (B.length s2 == B.length s1) then [B.concat [s0,s1]] else (s0 : s2' : go s3')+                          where (s2, s3) = B.breakSubstring c' s1+                                s2'      = B.append s2 c'+                                s3'      = B.drop (B.length c') s3 +chopAlts seps str = unpack <$> bchopAlts [(pack c, pack c') | (c, c') <- seps] (pack str) +sortDiff :: (Ord a) => [a] -> [a] -> [a]+sortDiff x1s x2s             = go (sortNub x1s) (sortNub x2s)+  where+    go xs@(x:xs') ys@(y:ys')+      | x <  y               = x : go xs' ys+      | x == y               = go xs' ys'+      | otherwise            = go xs ys'+    go xs []                 = xs+    go [] _                  = [] -ordNub :: Ord a => [a] -> [a]-ordNub = map head . L.group . L.sort+angleBrackets p    = char '<' <> p <> char '>' +mkGraph :: (Eq a, Eq b, Hashable a, Hashable b) => [(a, b)] -> M.HashMap a (S.HashSet b)+mkGraph = fmap S.fromList . group++tryIgnore :: String -> IO () -> IO ()+tryIgnore s a = catch a $ \e ->+                do let err = show (e :: IOException)+                   writeLoud ("Warning: Couldn't do " ++ s ++ ": " ++ err)+                   return ()++(=>>) m f = m >>= (\x -> f x >> return x)+++firstJust :: (a -> Maybe b) -> [a] -> Maybe b+firstJust f xs = listToMaybe $ mapMaybe f xs+ intToString :: Int -> String intToString 1 = "1st" intToString 2 = "2nd" intToString 3 = "3rd" intToString n = show n ++ "th"-
− src/Language/Haskell/Liquid/Names.hs 
@@ -1,6 +0,0 @@-module Language.Haskell.Liquid.Names where--import Language.Fixpoint.Types---lenLocSymbol = dummyLoc $ symbol ("autolen" :: String)
src/Language/Haskell/Liquid/Parse.hs view
@@ -12,6 +12,7 @@   )   where +import Prelude hiding (error) import Control.Monad import Text.Parsec import Text.Parsec.Error (newErrorMessage, Message (..))@@ -23,8 +24,8 @@ import qualified Data.HashSet        as S import Data.Monoid -import Control.Applicative ((<$>), (<*), (<*>))-import Data.Char (isLower, isSpace, isAlpha, isUpper, isAlphaNum)++import Data.Char (isSpace, isAlpha, isUpper, isAlphaNum) import Data.List (foldl', partition)  import GHC (mkModuleName)@@ -32,19 +33,21 @@  import Language.Preprocessor.Unlit (unlit) -import Language.Fixpoint.Types hiding (Def, R)+import Language.Fixpoint.Types hiding (Error, R) -import Language.Haskell.Liquid.GhcMisc-import Language.Haskell.Liquid.Types-import Language.Haskell.Liquid.RefType-import Language.Haskell.Liquid.Variance-import Language.Haskell.Liquid.Bounds+import Language.Haskell.Liquid.GHC.Misc+import Language.Haskell.Liquid.Types hiding (Axiom)+import Language.Haskell.Liquid.Misc (mapSnd)+import Language.Haskell.Liquid.Types.RefType+import Language.Haskell.Liquid.Types.Variance+import Language.Haskell.Liquid.Types.Bounds  import qualified Language.Haskell.Liquid.Measure as Measure-import Language.Fixpoint.Names (listConName, hpropConName, propConName, tupConName, headSym)-import Language.Fixpoint.Misc hiding (dcolon, dot)-import Language.Fixpoint.Parse hiding (angles) +import Language.Fixpoint.Parse hiding (angles, refBindP, refP, refDefP)++-- import Debug.Trace+ ---------------------------------------------------------------------------- -- Top Level Parsing API --------------------------------------------------- ----------------------------------------------------------------------------@@ -97,7 +100,7 @@ parseWithError parser f s   = case runParser (remainderP (whiteSpace >> parser)) 0 f s of       Left e            -> Left  $ parseErrorError f e-      Right (r, "", _)  -> Right $ r+      Right (r, "", _)  -> Right r       Right (_, rem, _) -> Left  $ parseErrorError f $ remParseError f s rem  ---------------------------------------------------------------------------@@ -125,9 +128,9 @@     remLine        = length remLines     col            = srcCol - remCol     srcCol         = length $ srcLines !! (line - 1)-    remCol         = length $ remLines !! 0-    srcLines       = lines  $ src-    remLines       = lines  $ rem+    remCol         = length $ head remLines+    srcLines       = lines  src+    remLines       = lines  rem   @@ -175,9 +178,9 @@  <|> try bareConstraintP  <|> try bareFunP  <|> bareAtomP (refBindP bindP)- <|> try (angles (do t <- parens $ bareTypeP+ <|> try (angles (do t <- parens bareTypeP                      p <- monoPredicateP-                     return $ t `strengthen` (U mempty p mempty)))+                     return $ t `strengthen` MkUReft mempty p mempty))  bareArgP vv   =  bareAtomP (refDefP vv)@@ -188,10 +191,27 @@  <|> holeP  <|> try (dummyP (bbaseP <* spaces)) -holeP       = reserved "_" >> spaces >> return (RHole $ uTop $ Reft ("VV", Refa hole))+refBindP :: Subable a => Parser Symbol -> Parser Expr -> Parser (Reft -> a) -> Parser a+refBindP bp rp kindP+  = braces $ do+      x  <- bp+      i  <- freshIntP+      t  <- kindP+      reserved "|"+      ra <- rp <* spaces+      let xi = intSymbol x i+      let su v = if v == x then xi else v+      return $ substa su $ t (Reft (x, ra))++refP       = refBindP bindP refaP+refDefP x  = refBindP (optBindP x)++optBindP x = try bindP <|> return x++holeP       = reserved "_" >> spaces >> return (RHole $ uTop $ Reft ("VV", hole)) holeRefP    = reserved "_" >> spaces >> return (RHole . uTop) refasHoleP  = try refaP-           <|> (reserved "_" >> return (Refa hole))+           <|> (reserved "_" >> return hole)  -- FIXME: the use of `blanks = oneOf " \t"` here is a terrible and fragile hack -- to avoid parsing:@@ -259,7 +279,7 @@               return xts)   <|> return [] -rrTy ct t = RRTy (xts ++ [(dummySymbol, tr)]) mempty OCons t+rrTy ct = RRTy (xts ++ [(dummySymbol, tr)]) mempty OCons   where     tr   = ty_res trep     xts  = zip (ty_binds trep) (ty_args trep)@@ -267,7 +287,7 @@  bareAllS   = do reserved "forall"-       ss <- (angles $ sepBy1 symbolP comma)+       ss <- angles $ sepBy1 symbolP comma        dot        t  <- bareTypeP        return $ foldr RAllS t ss@@ -281,8 +301,9 @@        return $ foldr RAllT (foldr RAllP t ps) as  tyVarIdP :: Parser Symbol-tyVarIdP = symbol <$> condIdP alphanums (isLower . head)-           where alphanums = ['a'..'z'] ++ ['0'..'9']+tyVarIdP = symbol <$> condIdP alphanums (isSmall . head)+           where+             alphanums = S.fromList $ ['a'..'z'] ++ ['0'..'9']  predVarDefsP   =  try (angles $ sepBy1 predVarDefP comma)@@ -298,6 +319,8 @@   where     (_, τ) = safeLast "bPVar last" xts     τxs    = [ (τ, x, EVar x) | (x, τ) <- init xts ]+    safeLast _ xs@(_:_) = last xs+    safeLast msg _      = panic Nothing $ "safeLast with empty list " ++ msg  predVarTypeP :: Parser [(Symbol, BSort)] predVarTypeP = bareTypeP >>= either parserFail return . mkPredVarType@@ -314,7 +337,7 @@     err       = "Predicate Variable with non-Prop output sort: " ++ showpp t  xyP lP sepP rP-  = liftM3 (\x _ y -> (x, y)) lP (spaces >> sepP) rP+  = (\x _ y -> (x, y)) <$> lP <*> (spaces >> sepP) <*> rP  data ArrowSym = ArrowFun | ArrowPred @@ -374,7 +397,7 @@  predicate1P    =  try (RProp <$> symsP <*> refP bbaseP)-  <|> (RPropP [] . predUReft <$> monoPredicate1P)+  <|> (rPropP [] . predUReft <$> monoPredicate1P)   <|> (braces $ bRProp <$> symsP' <*> refaP)    where     symsP'       = do ss    <- symsP@@ -402,8 +425,8 @@ funArgsP  = try realP <|> empP   where     empP  = (,[]) <$> predVarIdP-    realP = do EApp lp xs <- funAppP-               return (val lp, xs)+    realP = do (EVar lp, xs) <- splitEApp <$> funAppP+               return (lp, xs)   @@ -433,7 +456,7 @@ ----------------------- Wrapped Constructors --------------------------- ------------------------------------------------------------------------ -bRProp []    _    = errorstar "Parse.bRProp empty list"+bRProp []    _    = panic Nothing "Parse.bRProp empty list" bRProp syms' expr = RProp ss $ bRVar dummyName mempty mempty r   where     (ss, (v, _))  = (init syms, last syms)@@ -441,7 +464,7 @@     su            = mkSubst [(x, EVar y) | ((x, _), y) <- syms']     r             = su `subst` Reft (v, expr) -bRVar α s p r             = RVar α (U r p s)+bRVar α s p r             = RVar α (MkUReft r p s) bLst (Just t) rs r        = RApp (dummyLoc listConName) [t] rs (reftUReft r) bLst (Nothing) rs r       = RApp (dummyLoc listConName) []  rs (reftUReft r) @@ -453,16 +476,19 @@ -- Temporarily restore this hack benchmarks/esop2013-submission/Array.hs fails -- w/o it -- TODO RApp Int [] [p] true should be syntactically different than RApp Int [] [] p-bCon b s [RPropP _ r1] [] _ r = RApp b [] [] $ r1 `meet` (U r mempty s)-bCon b s rs            ts p r = RApp b ts rs $ U r p s+-- bCon b s [RProp _ (RHole r1)] [] _ r = RApp b [] [] $ r1 `meet` (MkUReft r mempty s)+bCon b s rs            ts p r = RApp b ts rs $ MkUReft r p s --- bAppTy v t r             = RAppTy (RVar v top) t (reftUReft r)-bAppTy v ts r             = (foldl' (\a b -> RAppTy a b mempty) (RVar v mempty) ts) `strengthen` (reftUReft r)+bAppTy v ts r  = ts' `strengthen` reftUReft r+  where+    ts'        = foldl' (\a b -> RAppTy a b mempty) (RVar v mempty) ts +reftUReft r    = MkUReft r mempty mempty -reftUReft      = \r -> U r mempty mempty-predUReft      = \p -> U dummyReft p mempty+predUReft p    = MkUReft dummyReft p mempty+ dummyReft      = mempty+ dummyTyId      = ""  ------------------------------------------------------------------@@ -481,7 +507,6 @@   | Invt    (Located ty)   | IAlias  (Located ty, Located ty)   | Alias   (RTAlias Symbol BareType)-  | PAlias  (RTAlias Symbol Pred)   | EAlias  (RTAlias Symbol Expr)   | Embed   (LocSymbol, FTycon)   | Qualif  Qualifier@@ -489,10 +514,11 @@   | LVars   LocSymbol   | Lazy    LocSymbol   | HMeas   LocSymbol+  | Axiom   LocSymbol   | Inline  LocSymbol   | ASize   LocSymbol   | HBound  LocSymbol-  | PBound  (Bound ty Pred)+  | PBound  (Bound ty Expr)   | Pragma  (Located String)   | CMeas   (Measure ty ())   | IMeas   (Measure ty ctor)@@ -513,13 +539,13 @@   show (Invt   _) = "Invt"   show (IAlias _) = "IAlias"   show (Alias  _) = "Alias"-  show (PAlias _) = "PAlias"   show (EAlias _) = "EAlias"   show (Embed  _) = "Embed"   show (Qualif _) = "Qualif"   show (Decr   _) = "Decr"   show (LVars  _) = "LVars"   show (Lazy   _) = "Lazy"+  show (Axiom  _) = "Axiom"   show (HMeas  _) = "HMeas"   show (HBound _) = "HBound"   show (Inline _) = "Inline"@@ -547,13 +573,13 @@   , Measure.dataDecls  = [d | DDecl  d <- xs]   , Measure.includes   = [q | Incl   q <- xs]   , Measure.aliases    = [a | Alias  a <- xs]-  , Measure.paliases   = [p | PAlias p <- xs]   , Measure.ealiases   = [e | EAlias e <- xs]   , Measure.embeds     = M.fromList [e | Embed e <- xs]   , Measure.qualifiers = [q | Qualif q <- xs]   , Measure.decr       = [d | Decr d   <- xs]   , Measure.lvars      = [d | LVars d  <- xs]   , Measure.lazy       = S.fromList [s | Lazy   s <- xs]+  , Measure.axioms     = S.fromList [s | Axiom  s <- xs]   , Measure.hmeas      = S.fromList [s | HMeas  s <- xs]   , Measure.inlines    = S.fromList [s | Inline s <- xs]   , Measure.autosize   = S.fromList [s | ASize  s <- xs]@@ -574,6 +600,7 @@     <|> (reservedToken "assert"    >> liftM Asrt   tyBindP   )     <|> (reservedToken "autosize"  >> liftM ASize  asizeP    )     <|> (reservedToken "Local"     >> liftM LAsrt  tyBindP   )+    <|> (reservedToken "axiomatize" >> liftM Axiom  axiomP )     <|> try (reservedToken "measure"  >> liftM Meas   measureP  )     <|> (reservedToken "measure"   >> liftM HMeas  hmeasureP )     <|> (reservedToken "inline"   >> liftM Inline  inlineP )@@ -590,7 +617,7 @@     <|> (reservedToken "invariant" >> liftM Invt   invariantP)     <|> (reservedToken "using"     >> liftM IAlias invaliasP )     <|> (reservedToken "type"      >> liftM Alias  aliasP    )-    <|> (reservedToken "predicate" >> liftM PAlias paliasP   )+    <|> (reservedToken "predicate" >> liftM EAlias ealiasP   )     <|> (reservedToken "expression">> liftM EAlias ealiasP   )     <|> (reservedToken "embed"     >> liftM Embed  embedP    )     <|> (reservedToken "qualif"    >> liftM Qualif (qualifierP sortP))@@ -614,6 +641,9 @@ hmeasureP :: Parser LocSymbol hmeasureP = locParserP binderP +axiomP :: Parser LocSymbol+axiomP = locParserP binderP+ hboundP :: Parser LocSymbol hboundP = locParserP binderP @@ -625,7 +655,8 @@  decreaseP :: Parser (LocSymbol, [Int]) decreaseP = mapSnd f <$> liftM2 (,) (locParserP binderP) (spaces >> (many integer))-  where f = ((\n -> fromInteger n - 1) <$>)+  where+    f     = ((\n -> fromInteger n - 1) <$>)  filePathP     :: Parser FilePath filePathP     = angles $ many1 pathCharP@@ -633,7 +664,7 @@     pathCharP = choice $ char <$> pathChars     pathChars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['.', '/'] -datavarianceP = liftM2 (,) (locUpperIdP) (spaces >> many varianceP)+datavarianceP = liftM2 (,) locUpperIdP (spaces >> many varianceP)  varianceP = (reserved "bivariant"     >> return Bivariant)         <|> (reserved "invariant"     >> return Invariant)@@ -674,8 +705,8 @@   aliasP  = rtAliasP id     bareTypeP-paliasP = rtAliasP symbol predP-ealiasP = rtAliasP symbol exprP+ealiasP = try (rtAliasP symbol predP)+      <|> rtAliasP symbol exprP  rtAliasP :: (Symbol -> tv) -> Parser ty -> Parser (RTAlias tv ty) rtAliasP f bodyP@@ -686,11 +717,13 @@        whiteSpace >> reservedOp "=" >> whiteSpace        body <- bodyP        posE <- getPosition-       let (tArgs, vArgs) = partition (isLower . headSym) args+       let (tArgs, vArgs) = partition (isSmall . headSym) args        return $ RTA name (f <$> tArgs) (f <$> vArgs) body pos posE  aliasIdP :: Parser Symbol-aliasIdP = condIdP (['A' .. 'Z'] ++ ['a'..'z'] ++ ['0'..'9']) (isAlpha . head)+aliasIdP = condIdP alphaNums (isAlpha . head)+           where+             alphaNums = S.fromList $ ['A' .. 'Z'] ++ ['a'..'z'] ++ ['0'..'9']  measureP :: Parser (Measure BareType LocSymbol) measureP@@ -720,17 +753,23 @@  classP :: Parser (RClass BareType) classP-  = do sups <- superP+  = do sups <- supersP        c <- locUpperIdP        spaces        tvs <- manyTill tyVarIdP (try $ reserved "where")        ms <- grabs tyBindP        spaces-       return $ RClass (fmap symbol c) (mb sups) tvs ms+       return $ RClass (fmap symbol c) sups tvs ms   where-    mb Nothing   = []-    mb (Just xs) = xs-    superP = maybeP (parens ( liftM (toRCls <$>)  (bareTypeP `sepBy1` comma)) <* reserved "=>")+    superP =  toRCls <$> bareAtomP (refBindP bindP)+      -- c <- locUpperIdP+      -- spaces+      -- tvs <- many1 bareAtomNoAppP+      -- return (RApp c tvs [] mempty)++    supersP = try (((parens (superP `sepBy1` comma)) <|> fmap pure superP)+                      <* reserved "=>")+              <|> return []     toRCls x = x --     toRCls (RApp c ts rs r) = RCls c ts --     toRCls t@(RCls _ _)     = t@@ -838,14 +877,15 @@   =  try upperIdP  <|> pwr <$> parens (idP bad)   where-     idP p  = symbol <$> many1 (satisfy (not . p))+     idP p  = many1 (satisfy (not . p))      bad c  = isSpace c || c `elem` ("(,)" :: String)-     pwr s  = "(" <> s <> ")"+     pwr s  = symbol $ "(" <> s <> ")"  dataSizeP   = (brackets $ (Just . mkFun) <$> locLowerIdP)   <|> return Nothing-  where mkFun s = \x -> EApp (symbol <$> s) [EVar x]+  where+    mkFun s x = mkEApp (symbol <$> s) [EVar x]  dataDeclP :: Parser DataDecl dataDeclP = try dataDeclFullP <|> dataDeclSizeP@@ -875,29 +915,6 @@ -- | Parsing Qualifiers --------------------------------------------- --------------------------------------------------------------------- --- qualifierP = do---   pos    <- getPosition---   n      <- upperIdP---   params <- parens $ sepBy1 sortBindP comma---   _      <- colon---   body   <- predP---   return  $ mkQual n params body pos------ sortBindP = (,) <$> symbolP <* colon <*> sortP--sortP-  =   try (parens $ sortP)-  -- <|> try (string "@"    >> varSortP)-  <|> try (fApp (Left listFTyCon) . single <$> brackets sortP)-  -- <|> try bvSortP-  -- <|> try baseSortP-  -- THIS IS THE PROBLEM HEREHEREHERE <|> try (symbolSort <$> locLowerIdP)-  <|> try (fApp  <$> (Left <$> fTyConP) <*> sepBy sortP blanks)-  <|> (FObj . symbol <$> lowerIdP)---- varSortP  = FVar  <$> parens intP--- funcSortP = parens $ FFunc <$> intP <* comma <*> sortsP- fTyConP :: Parser FTycon fTyConP   =   (reserved "int"     >> return intFTyCon)@@ -909,16 +926,14 @@   <|> (symbolFTycon      <$> locUpperIdP)  -- --------------------------------------------------------------------- ------------ Interacting with Fixpoint ------------------------------ ---------------------------------------------------------------------  grabUpto p-  =  try (lookAhead p >>= return . Just)- <|> try (eof         >> return Nothing)- <|> (anyChar >> grabUpto p)+  =  try (Just <$> lookAhead p)+ <|> try (eof   >> return Nothing)+ <|> (anyChar   >> grabUpto p)  betweenMany leftP rightP p   = do z <- grabUpto leftP
− src/Language/Haskell/Liquid/PredType.hs 
@@ -1,334 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, FlexibleContexts, UndecidableInstances, TupleSections, OverloadedStrings #-}-module Language.Haskell.Liquid.PredType (-    PrType-  , TyConP (..), DataConP (..)-  , dataConTy-  , dataConPSpecType-  , makeTyConInfo-  , replacePreds--  , replacePredsWithRefs-  , pVartoRConc--  -- * Dummy `Type` that represents _all_ abstract-predicates-  , predType--  -- * Compute @RType@ of a given @PVar@-  , pvarRType--  , substParg-  , pApp-  , wiredSortedSyms-  ) where--import Type-import TypeRep-import qualified TyCon as TC-import Text.PrettyPrint.HughesPJ-import DataCon--import qualified Data.HashMap.Strict as M-import Data.List        (partition, foldl')-import Data.Monoid      (mempty, mappend, mconcat)--import Language.Fixpoint.Misc-import Language.Fixpoint.Types hiding (Predicate, Expr)-import qualified Language.Fixpoint.Types as F-import Language.Haskell.Liquid.Types-import Language.Haskell.Liquid.RefType  hiding (generalize)-import Language.Haskell.Liquid.GhcMisc-import Language.Haskell.Liquid.Misc--import Control.Applicative  ((<$>))-import Data.List (nub)--import Data.Default--makeTyConInfo = hashMapMapWithKey mkRTyCon . M.fromList--mkRTyCon ::  TC.TyCon -> TyConP -> RTyCon-mkRTyCon tc (TyConP αs' ps _ tyvariance predvariance size) = RTyCon tc pvs' (mkTyConInfo tc tyvariance predvariance size)-  where τs   = [rVar α :: RSort |  α <- tyConTyVarsDef tc]-        pvs' = subts (zip αs' τs) <$> ps--dataConPSpecType :: DataCon -> DataConP -> SpecType-dataConPSpecType dc (DataConP _ vs ps ls cs yts rt _) = mkArrow vs ps ls ts' rt'-  where-    (xs, ts) = unzip $ reverse yts-    mkDSym   = (`mappend` symbol dc) . (`mappend` "_") . symbol-    ys       = mkDSym <$> xs-    tx _  []     []     []     = []-    tx su (x:xs) (y:ys) (t:ts) = (y, subst (F.mkSubst su) t, mempty)-                               : tx ((x, F.EVar y):su) xs ys ts-    tx _ _ _ _ = errorstar "PredType.dataConPSpecType.tx called on invalid inputs"-    yts'     = tx [] xs ys ts-    ts'      = map ("" , , mempty) cs ++ yts'-    su       = F.mkSubst [(x, F.EVar y) | (x, y) <- zip xs ys]-    rt'      = subst su rt--instance PPrint TyConP where-  pprint (TyConP vs ps ls _ _ _)-    = (parens $ hsep (punctuate comma (map pprint vs))) <+>-      (parens $ hsep (punctuate comma (map pprint ps))) <+>-      (parens $ hsep (punctuate comma (map pprint ls)))--instance Show TyConP where- show = showpp -- showSDoc . ppr--instance PPrint DataConP where-  pprint (DataConP _ vs ps ls cs yts t _)-     = (parens $ hsep (punctuate comma (map pprint vs))) <+>-       (parens $ hsep (punctuate comma (map pprint ps))) <+>-       (parens $ hsep (punctuate comma (map pprint ls))) <+>-       (parens $ hsep (punctuate comma (map pprint cs))) <+>-       (parens $ hsep (punctuate comma (map pprint yts))) <+>-       pprint t--instance Show DataConP where-  show = showpp--dataConTy m (TyVarTy v)-  = M.lookupDefault (rVar v) (RTV v) m-dataConTy m (FunTy t1 t2)-  = rFun dummySymbol (dataConTy m t1) (dataConTy m t2)-dataConTy m (ForAllTy α t)-  = RAllT (rTyVar α) (dataConTy m t)-dataConTy m (TyConApp c ts)-  = rApp c (dataConTy m <$> ts) [] mempty-dataConTy _ _-  = error "ofTypePAppTy"------------------------------------------------------------------------------------ Interface: Replace Predicate With Uninterprented Function Symbol ------------------------------------------------------------------------------------replacePredsWithRefs (p, r) (U (Reft(v, Refa rs)) (Pr ps) s)-  = U (Reft (v, Refa rs'')) (Pr ps2) s-  where-    rs''             = mconcat $ rs : rs'-    rs'              = r . (v,) . pargs <$> ps1-    (ps1, ps2)       = partition (== p) ps--pVartoRConc p (v, args) | length args == length (pargs p)-  = pApp (pname p) $ EVar v : (thd3 <$> args)--pVartoRConc p (v, args)-  = pApp (pname p) $ EVar v : args'-  where-    args' = (thd3 <$> args) ++ (drop (length args) (thd3 <$> pargs p))---------------------------------------------------------------------------- | @pvarRType π@ returns a trivial @RType@ corresponding to the---   function signature for a @PVar@ @π@. For example, if---      @π :: T1 -> T2 -> T3 -> Prop@---   then @pvarRType π@ returns an @RType@ with an @RTycon@ called---   @predRTyCon@ `RApp predRTyCon [T1, T2, T3]`-------------------------------------------------------------------------pvarRType :: (PPrint r, Reftable r) => PVar RSort -> RRType r-------------------------------------------------------------------------pvarRType (PV _ k {- (PVProp τ) -} _ args) = rpredType k (fst3 <$> args) -- (ty:tys)-  -- where-  --   ty  = uRTypeGen τ-  --   tys = uRTypeGen . fst3 <$> args----- rpredType    :: (PPrint r, Reftable r) => PVKind (RRType r) -> [RRType r] -> RRType r-rpredType (PVProp t) ts = RApp predRTyCon  (uRTypeGen <$> t : ts) [] mempty-rpredType PVHProp    ts = RApp wpredRTyCon (uRTypeGen <$>     ts) [] mempty--predRTyCon   :: RTyCon-predRTyCon   = symbolRTyCon predName--wpredRTyCon   :: RTyCon-wpredRTyCon   = symbolRTyCon wpredName--symbolRTyCon   :: Symbol -> RTyCon-symbolRTyCon n = RTyCon (stringTyCon 'x' 42 $ symbolString n) [] def------------------------------------------------------------------------------------------ | Instantiate `PVar` with `RTProp` ---------------------------------------------------------------------------------------------------------------------------------------- | @replacePreds@ is the main function used to substitute an (abstract)---   predicate with a concrete Ref, that is either an `RProp` or `RHProp`---   type. The substitution is invoked to obtain the `SpecType` resulting---   at /predicate application/ sites in 'Language.Haskell.Liquid.Constraint'.---   The range of the `PVar` substitutions are /fresh/ or /true/ `RefType`.---   That is, there are no further _quantified_ `PVar` in the target.---------------------------------------------------------------------------------------replacePreds                 :: String -> SpecType -> [(RPVar, SpecProp)] -> SpecType---------------------------------------------------------------------------------------replacePreds msg             = foldl' go-  where-    go z (π, t@(RProp _ _)) = substPred msg   (π, t)     z-    go _ (_, RPropP _ _)    = error "replacePreds on RPropP"-    go _ (_, RHProp _ _)    = errorstar "TODO:EFFECTS:replacePreds"---- TODO: replace `replacePreds` with--- instance SubsTy RPVar (Ref RReft SpecType) SpecType where---   subt (pv, r) t = replacePreds "replacePred" t (pv, r)---- replacePreds :: String -> SpecType -> [(RPVar, Ref Reft RefType)] -> SpecType--- replacePreds msg       = foldl' go---   where go z (π, RProp t) = substPred msg   (π, t)     z---         go z (π, RPropP r) = replacePVarReft (π, r) <$> z----------------------------------------------------------------------------------substPred :: String -> (RPVar, SpecProp) -> SpecType -> SpecType----------------------------------------------------------------------------------substPred _   (π, RProp ss (RVar a1 r1)) t@(RVar a2 r2)-  | isPredInReft && a1 == a2    = RVar a1 $ meetListWithPSubs πs ss r1 r2'-  | isPredInReft                = errorstar ("substPred RVar Var Mismatch" ++ show (a1, a2))-  | otherwise                   = t-  where-    (r2', πs)                   = splitRPvar π r2-    isPredInReft                = not $ null πs--substPred msg su@(π, _ ) (RApp c ts rs r)-  | null πs                     = t'-  | otherwise                   = substRCon msg su t' πs r2'-  where-    t'                          = RApp c (substPred msg su <$> ts) (substPredP msg su <$> rs) r-    (r2', πs)                   = splitRPvar π r--substPred msg (p, tp) (RAllP (q@(PV _ _ _ _)) t)-  | p /= q                      = RAllP q $ substPred msg (p, tp) t-  | otherwise                   = RAllP q t--substPred msg su (RAllT a t)    = RAllT a (substPred msg su t)--substPred msg su@(π,_ ) (RFun x t t' r)-  | null πs                     = RFun x (substPred msg su t) (substPred msg su t') r-  | otherwise                   = {-meetListWithPSubs πs πt -}(RFun x t t' r')-  where (r', πs)                = splitRPvar π r--substPred msg su (RRTy e r o t) = RRTy (mapSnd (substPred msg su) <$> e) r o (substPred msg su t)-substPred msg su (RAllE x t t') = RAllE x (substPred msg su t) (substPred msg su t')-substPred msg su (REx x t t')   = REx   x (substPred msg su t) (substPred msg su t')-substPred _   _  t              = t---- | Requires: @not $ null πs@--- substRCon :: String -> (RPVar, SpecType) -> SpecType -> SpecType--substRCon msg (_, RProp ss (RApp c1 ts1 rs1 r1)) (RApp c2 ts2 rs2 _) πs r2'-  | rtc_tc c1 == rtc_tc c2 = RApp c1 ts rs $ meetListWithPSubs πs ss r1 r2'-  where-    ts                     = safeZipWith (msg ++ ": substRCon")  strSub  ts1  ts2-    rs                     = safeZipWith (msg ++ ": substRCon2") strSubR rs1' rs2'-    -- TODO: REMOVE `pad` just use rs2 ?-    (rs1', rs2')           = pad "substRCon" top rs1 rs2-    strSub r1 r2           = meetListWithPSubs πs ss r1 r2-    strSubR r1 r2          = meetListWithPSubsRef πs ss r1 r2----substRCon msg su t _ _        = errorstar $ msg ++ " substRCon " ++ showpp (su, t)--substPredP msg su@(p, RProp ss _) (RProp s t)-  = RProp ss' $ substPred (msg ++ ": substPredP") su t- where-   ss' = drop n ss ++  s-   n   = length ss - length (freeArgsPs p t)--substPredP _ _  (RHProp _ _)-  = errorstar "TODO:EFFECTS:substPredP"--substPredP _ su p@(RPropP _ _)-  = errorstar ("PredType.substPredP1 called on invalid inputs" ++ showpp (su, p))--substPredP _ su p-  = errorstar ("PredType.substPredP called on invalid inputs" ++ showpp (su, p))---splitRPvar pv (U x (Pr pvs) s) = (U x (Pr pvs') s, epvs)-  where-    (epvs, pvs')               = partition (uPVar pv ==) pvs--freeArgsPs p (RVar _ r)-  = freeArgsPsRef p r-freeArgsPs p (RFun _ t1 t2 r)-  = nub $  freeArgsPsRef p r ++ freeArgsPs p t1 ++ freeArgsPs p t2-freeArgsPs p (RAllT _ t)-  = freeArgsPs p t-freeArgsPs p (RAllS _ t)-  = freeArgsPs p t-freeArgsPs p (RAllP p' t)-  | p == p'   = []-  | otherwise = freeArgsPs p t-freeArgsPs p (RApp _ ts _ r)-  = nub $ freeArgsPsRef p r ++ concatMap (freeArgsPs p) ts-freeArgsPs p (RAllE _ t1 t2)-  = nub $ freeArgsPs p t1 ++ freeArgsPs p t2-freeArgsPs p (REx _ t1 t2)-  = nub $ freeArgsPs p t1 ++ freeArgsPs p t2-freeArgsPs p (RAppTy t1 t2 r)-  = nub $ freeArgsPsRef p r ++ freeArgsPs p t1 ++ freeArgsPs p t2-freeArgsPs _ (RExprArg _)-  = []-freeArgsPs p (RHole r)-  = freeArgsPsRef p r-freeArgsPs p (RRTy env r _ t)-  = nub $ concatMap (freeArgsPs p) (snd <$> env) ++ freeArgsPsRef p r ++ freeArgsPs p t--freeArgsPsRef p (U _ (Pr ps) _) = [x | (_, x, w) <- (concatMap pargs ps'),  (EVar x) == w]-  where-   ps' = f <$> filter (uPVar p ==) ps-   f q = q {pargs = pargs q ++ drop (length (pargs q)) (pargs $ uPVar p)}--meetListWithPSubs πs ss r1 r2    = foldl' (meetListWithPSub ss r1) r2 πs-meetListWithPSubsRef πs ss r1 r2 = foldl' ((meetListWithPSubRef ss) r1) r2 πs--meetListWithPSub ::  (Reftable r, PPrint t) => [(Symbol, RSort)]-> r -> r -> PVar t -> r-meetListWithPSub ss r1 r2 π-  | all (\(_, x, EVar y) -> x == y) (pargs π)-  = r2 `meet` r1-  | all (\(_, x, EVar y) -> x /= y) (pargs π)-  = r2 `meet` (subst su r1)-  | otherwise-  = errorstar $ "PredType.meetListWithPSub partial application to " ++ showpp π-  where-    su  = mkSubst [(x, y) | (x, (_, _, y)) <- zip (fst <$> ss) (pargs π)]--meetListWithPSubRef ss (RProp s1 r1) (RProp s2 r2) π-  | all (\(_, x, EVar y) -> x == y) (pargs π)-  = RProp s1 $ r2 `meet` r1-  | all (\(_, x, EVar y) -> x /= y) (pargs π)-  = RProp s2 $ r2 `meet` (subst su r1)-  | otherwise-  = errorstar $ "PredType.meetListWithPSubRef partial application to " ++ showpp π-  where su  = mkSubst [(x, y) | (x, (_, _, y)) <- zip (fst <$> ss) (pargs π)]-meetListWithPSubRef _ _ _ _-  = errorstar "PredType.meetListWithPSubRef called with invalid input"--------------------------------------------------------------------------------- | Interface: Modified CoreSyn.exprType due to predApp -------------------------------------------------------------------------------------------------predType   :: Type-predType   = symbolType predName--wpredName, predName   :: Symbol-predName   = "Pred"-wpredName  = "WPred"--symbolType = TyVarTy . symbolTyVar---substParg :: Functor f => (Symbol, F.Expr) -> f Predicate -> f Predicate-substParg (x, y) = fmap fp-  where-    fxy s        = if (s == EVar x) then y else s-    fp           = subvPredicate (\pv -> pv { pargs = mapThd3 fxy <$> pargs pv })---------------------------------------------------------------------------------------------------------------  Predicate Application ------------------------------------------------------------------------------------------------------------pappArity  = 7--pappSort n = FFunc (2 * n) $ [ptycon] ++ args ++ [boolSort]-  where ptycon = fApp (Left predFTyCon) $ FVar <$> [0..n-1]-        args   = FVar <$> [n..(2*n-1)]--wiredSortedSyms = [(pappSym n, pappSort n) | n <- [1..pappArity]]--predFTyCon = symbolFTycon $ dummyLoc predName
− src/Language/Haskell/Liquid/PrettyPrint.hs 
@@ -1,337 +0,0 @@-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE OverloadedStrings    #-}-{-# LANGUAGE TupleSections        #-}---- | Module with all the printing and serialization routines--module Language.Haskell.Liquid.PrettyPrint (--  -- * Tidy level-  Tidy (..)--  -- * Printing RType-  , rtypeDoc-  , ppr_rtype--  -- * Printing an Orderable List-  , pprManyOrdered--  -- * Printing a List with many large items-  , pprintLongList-  , ppSpine-  , pprintSymbol-  ) where--import ErrUtils                         (ErrMsg)-import HscTypes                         (SourceError)-import SrcLoc                           -- (RealSrcSpan, SrcSpan (..))-import GHC                              (Name, Class)---import VarEnv                           (emptyTidyEnv)-import Language.Haskell.Liquid.Misc-import Language.Haskell.Liquid.GhcMisc-import Text.PrettyPrint.HughesPJ-import Language.Fixpoint.Types hiding (Predicate)-import Language.Fixpoint.Misc-import Language.Haskell.Liquid.Types hiding (sort)-import Language.Fixpoint.Names (dropModuleNames, propConName, hpropConName)-import TypeRep          hiding (maybeParen, pprArrowChain)-import Text.Parsec.Error (ParseError, errorMessages, showErrorMessages)-import Var              (Var)-import TyCon            (TyCon)-import Control.Applicative ((<$>))-import Data.Maybe   (fromMaybe)-import Data.List    (sort, sortBy)-import Data.Function (on)-import Data.Monoid   (mempty)-import qualified Data.HashMap.Strict as M----pprintSymbol :: Symbol -> Doc-pprintSymbol x = char '‘' <> pprint x <> char '’'--instance PPrint SrcSpan where-  pprint = pprDoc--instance PPrint Doc where-  pprint x = x--instance PPrint ErrMsg where-  pprint = text . show--instance PPrint SourceError where-  pprint = text . show--instance PPrint ParseError where-  pprint e = vcat $ tail $ map text ls-    where-      ls = lines $ showErrorMessages "or" "unknown parse error"-                                     "expecting" "unexpected" "end of input"-                                     (errorMessages e)---- instance PPrint LParseError where---   pprint (LPE _ msgs) = text "Parse Error: " <> vcat (map pprint msgs)--instance PPrint Var where-  pprint = pprDoc--instance PPrint Name where-  pprint = pprDoc--instance PPrint TyCon where-  pprint = pprDoc--instance PPrint Type where-  pprint = pprDoc -- . tidyType emptyTidyEnv -- WHY WOULD YOU DO THIS???--instance PPrint Class where-  pprint = pprDoc--instance Show Predicate where-  show = showpp----- | Printing an Ordered List------------------------------------------------------------------pprManyOrdered :: (PPrint a, Ord a) => Tidy -> String -> [a] -> [Doc]-----------------------------------------------------------------pprManyOrdered k msg = map ((text msg <+>) . pprintTidy k) . sort--------------------------------------------------------------------- | Pretty Printing RefType ------------------------------------------------------------------------------------------------------ Should just make this a @Pretty@ instance but its too damn tedious--- to figure out all the constraints.--rtypeDoc k    = ppr_rtype (ppE k) TopPrec-  where-    ppE Lossy = ppEnvShort ppEnv-    ppE Full  = ppEnv--ppTyConB bb-  | ppShort bb = text . symbolString . dropModuleNames . symbol . render . ppTycon-  | otherwise  = ppTycon---ppr_rtype bb p t@(RAllT _ _)-  = ppr_forall bb p t-ppr_rtype bb p t@(RAllP _ _)-  = ppr_forall bb p t-ppr_rtype bb p t@(RAllS _ _)-  = ppr_forall bb p t-ppr_rtype _ _ (RVar a r)-  = ppTy r $ pprint a-ppr_rtype bb p t@(RFun _ _ _ _)-  = maybeParen p FunPrec $ ppr_rty_fun bb empty t-ppr_rtype bb p (RApp c [t] rs r)-  | isList c-  = ppTy r $ brackets (ppr_rtype bb p t) <> ppReftPs bb rs-ppr_rtype bb p (RApp c ts rs r)-  | isTuple c-  = ppTy r $ parens (intersperse comma (ppr_rtype bb p <$> ts)) <> ppReftPs bb rs-ppr_rtype bb p (RApp c ts rs r)-  | isEmpty rsDoc && isEmpty tsDoc-  = ppTy r $ ppT c-  | otherwise-  = ppTy r $ parens $ ppT c <+> rsDoc <+> tsDoc-  where-    rsDoc            = ppReftPs bb rs-    tsDoc            = hsep (ppr_rtype bb p <$> ts)-    ppT              = ppTyConB bb--ppr_rtype bb p t@(REx _ _ _)-  = ppExists bb p t-ppr_rtype bb p t@(RAllE _ _ _)-  = ppAllExpr bb p t-ppr_rtype _ _ (RExprArg e)-  = braces $ pprint e-ppr_rtype bb p (RAppTy t t' r)-  = 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]-  where ppe = (hsep $ punctuate comma (pprint <$> e)) <+> colon <> colon-        ppp = \doc -> text "<<" <+> doc <+> text ">>"-ppr_rtype _ _ (RHole r)-  = ppTy r $ text "_"---ppr_rsubtype bb p e -  = pprint_env <+> text "|-" <+> ppr_rtype bb p tl <+> "<:" <+> ppr_rtype 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 -    pprint_env         = hsep $ punctuate comma (pprint_bind <$> env)--ppSpine (RAllT _ t)      = text "RAllT" <+> parens (ppSpine t)-ppSpine (RAllP _ t)      = text "RAllP" <+> parens (ppSpine t)-ppSpine (RAllS _ t)      = text "RAllS" <+> parens (ppSpine t)-ppSpine (RAllE _ _ t)    = text "RAllE" <+> parens (ppSpine t)-ppSpine (REx _ _ t)      = text "REx" <+> parens (ppSpine t)-ppSpine (RFun _ i o _)   = ppSpine i <+> text "->" <+> ppSpine o-ppSpine (RAppTy t t' _)  = text "RAppTy" <+> parens (ppSpine t) <+> parens (ppSpine t')-ppSpine (RHole _)        = text "RHole"-ppSpine (RApp c _ _ _)   = text "RApp" <+> parens (pprint c)-ppSpine (RVar _ _)       = text "RVar"-ppSpine (RExprArg _)     = text "RExprArg"-ppSpine (RRTy _ _ _ _)   = text "RRTy"---- | From GHC: TypeRep -maybeParen :: Prec -> Prec -> Doc -> Doc-maybeParen ctxt_prec inner_prec pretty-  | ctxt_prec < inner_prec = pretty-  | otherwise                  = parens pretty----- ppExists :: (RefTypable p c tv (), RefTypable p c tv r) => Bool -> Prec -> RType p 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'-    where (zs,  t')               = split [] t-          split zs (REx x t t')   = split ((x,t):zs) t'-          split zs t                = (reverse zs, t)---- ppAllExpr :: (RefTypable p c tv (), RefTypable p c tv r) => Bool -> Prec -> RType p c tv r -> Doc-ppAllExpr bb p t-  = text "forall" <+> brackets (intersperse comma [ppr_dbind bb TopPrec x t | (x, t) <- zs]) <> dot <> ppr_rtype bb p t'-    where (zs,  t')               = split [] t-          split zs (RAllE x t t') = split ((x,t):zs) t'-          split zs t                = (reverse zs, t)--ppReftPs _ rs-  | all isTauto rs   = empty-  | not (ppPs ppEnv) = empty-  | otherwise        = angleBrackets $ hsep $ punctuate comma $ pprint <$> rs---- ppr_dbind :: (RefTypable p c tv (), RefTypable p c tv r) => Bool -> Prec -> Symbol -> RType p c tv r -> Doc-ppr_dbind bb p x t-  | isNonSymbol x || (x == dummySymbol)-  = ppr_rtype bb p t-  | otherwise-  = pprint x <> colon <> ppr_rtype bb p t---ppr_rty_fun bb prefix t-  = prefix <+> ppr_rty_fun' bb t--ppr_rty_fun' bb (RFun b t t' _)-  = ppr_dbind bb FunPrec b t <+> ppr_rty_fun bb arrow t'-ppr_rty_fun' bb t-  = ppr_rtype bb TopPrec t----- ppr_forall :: (RefTypable p c tv (), RefTypable p c tv r) => Bool -> Prec -> RType p c tv r -> Doc-ppr_forall bb p t-  = maybeParen p FunPrec $ sep [ ppr_foralls (ppPs bb) (ty_vars trep) (ty_preds trep) (ty_labels trep) , ppr_clss cls, ppr_rtype bb TopPrec t' ]-  where-    trep                   = toRTypeRep t-    (cls, t')              = bkClass $ fromRTypeRep $ trep {ty_vars = [], ty_preds = [], ty_labels = []}--    ppr_foralls False _ _  _= empty-    ppr_foralls _    [] [] [] = empty-    ppr_foralls True αs πs ss = text "forall" <+> dαs αs <+> dπs (ppPs bb) πs <+> dss (ppSs bb) ss <> dot-    ppr_clss []            = empty-    ppr_clss cs            = (parens $ hsep $ punctuate comma (uncurry (ppr_cls bb p) <$> cs)) <+> text "=>"--    dαs αs                 = sep $ pprint <$> αs--    dπs _ []               = empty-    dπs False _            = empty-    dπs True πs            = angleBrackets $ intersperse comma $ ppr_pvar_def pprint <$> πs-    dss _ []               = empty-    dss _ ss               = angleBrackets $ intersperse comma $ pprint <$> ss---ppr_cls bb p c ts-  = pp c <+> hsep (map (ppr_rtype bb p) ts)-  where-    pp | ppShort bb = text . symbolString . dropModuleNames . symbol . render . pprint-       | otherwise  = pprint---ppr_pvar_def pprv (PV s t _ xts)-  = pprint s <+> dcolon <+> intersperse arrow dargs <+> ppr_pvar_kind pprv t--  where-    dargs = [pprv t | (t,_,_) <- xts]--ppr_pvar_kind pprv (PVProp t) = pprv t <+> arrow <+> ppr_name propConName-ppr_pvar_kind _    (PVHProp)  = ppr_name hpropConName-ppr_name                      = text . symbolString--instance PPrint RTyVar where-  pprint (RTV α)-   | ppTyVar ppEnv = ppr_tyvar α-   | otherwise     = ppr_tyvar_short α--ppr_tyvar       = text . tvId-ppr_tyvar_short = text . showPpr--instance (Reftable s, PPrint s, PPrint p, Reftable  p, PPrint t, PPrint (RType b c p)) => PPrint (Ref t s (RType b c p)) where-  pprint (RPropP ss s) = ppRefArgs (fst <$> ss) <+> pprint s-  pprint (RProp  ss s) = ppRefArgs (fst <$> ss) <+> pprint (fromMaybe mempty (stripRTypeBase s))-  pprint (RHProp ss _) = ppRefArgs (fst <$> ss) <+> text "world"---ppRefArgs [] = empty-ppRefArgs ss = text "\\" <> hsep (ppRefSym <$> ss ++ [vv Nothing]) <+> text "->"--ppRefSym "" = text "_"-ppRefSym s  = pprint s--instance (PPrint r, Reftable r) => PPrint (UReft r) where-  pprint (U r p _)-    | isTauto r  = pprint p-    | isTauto p  = pprint r-    | otherwise  = pprint p <> text " & " <> pprint r--pprintLongList :: PPrint a => [a] -> Doc-pprintLongList = brackets . vcat . map pprint----instance (PPrint t) => PPrint (Annot t) where-  pprint (AnnUse t) = text "AnnUse" <+> pprint t-  pprint (AnnDef t) = text "AnnDef" <+> pprint t-  pprint (AnnRDf t) = text "AnnRDf" <+> pprint t-  pprint (AnnLoc l) = text "AnnLoc" <+> pprDoc l--pprAnnInfoBinds (l, xvs)-  = vcat $ map (pprAnnInfoBind . (l,)) xvs--pprAnnInfoBind (RealSrcSpan k, xv)-  = xd $$ pprDoc l $$ pprDoc c $$ pprint n $$ vd $$ text "\n\n\n"-    where-      l        = srcSpanStartLine k-      c        = srcSpanStartCol k-      (xd, vd) = pprXOT xv-      n        = length $ lines $ render vd--pprAnnInfoBind (_, _)-  = empty--pprXOT (x, v) = (xd, pprint v)-  where-    xd = maybe (text "unknown") pprint x--instance PPrint a => PPrint (AnnInfo a) where-  pprint (AI m) = vcat $ map pprAnnInfoBinds $ M.toList m--instance (Ord k, PPrint k, PPrint v) => PPrint (M.HashMap k v) where-  pprint = ppTable--ppTable m = vcat $ pprxt <$> xts-  where-    pprxt (x,t) = pprint x $$ nest n (colon <+> pprint t)-    n          = 1 + maximumWithDefault 0 [ i | (x, _) <- xts, let i = keySize x, i <= thresh ]-    keySize     = length . render . pprint-    xts         = sortBy (compare `on` fst) $ M.toList m-    thresh      = 6
+ src/Language/Haskell/Liquid/Prover/Constants.hs view
@@ -0,0 +1,25 @@+module Language.Haskell.Liquid.Prover.Constants where++-------------------------------------------------------------------------------+----------------------------   Debugging  -------------------------------------+-------------------------------------------------------------------------------++debug = True +whenLoud act = if debug then act else return ()++-------------------------------------------------------------------------------+------------------------   Constant Numbers   ---------------------------------+-------------------------------------------------------------------------------++delta, epsilon, default_depth :: Int +delta   = 5 +epsilon = 10 +default_depth = 2 +++-------------------------------------------------------------------------------+------------------------   Files  ---------------------------------------------+-------------------------------------------------------------------------------++smtFileExtention = ".smt"+smtFile fn = fn ++ smtFileExtention
+ src/Language/Haskell/Liquid/Prover/Misc.hs view
@@ -0,0 +1,38 @@+module Language.Haskell.Liquid.Prover.Misc where++import Data.List+++++-------------------------------------------------------------------------------+-----------------------   Playing with lists    -------------------------------+-------------------------------------------------------------------------------++-- | Powerset +powerset = sortBy (\l1 l2 -> compare (length l1) (length l2)) . powerset'++powerset'       :: [a] -> [[a]]+powerset' []     = [[]]+powerset' (x:xs) = xss /\/ map (x:) xss+   where xss = powerset' xs++(/\/)        :: [a] -> [a] -> [a]+[]     /\/ ys = ys+(x:xs) /\/ ys = x : (ys /\/ xs)+++++-------------------------------------------------------------------------------+-----------------------   Playing with monads   -------------------------------+-------------------------------------------------------------------------------++findM :: (Monad m) => (a -> m Bool) -> [a] -> m (Maybe a)+findM _ []     = return Nothing +findM p (x:xs) = do {r <- p x; if r then return (Just x) else findM p xs}+++mapSnd f (x, y) = (x, f y)++second3 f (x, y, z) = (x, f y, z)
+ src/Language/Haskell/Liquid/Prover/Names.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE OverloadedStrings #-}++module Language.Haskell.Liquid.Prover.Names where++import Language.Fixpoint.Types++exprToBoolSym :: Symbol+exprToBoolSym = "exprToBool"
+ src/Language/Haskell/Liquid/Prover/Parser.hs view
@@ -0,0 +1,100 @@+module Language.Haskell.Liquid.Prover.Parser where++import Language.Haskell.Liquid.Prover.Types+import Language.Haskell.Liquid.Prover.Constants (default_depth)++import Text.Parsec++import Language.Fixpoint.Parse hiding (bindP)+import Language.Fixpoint.Types        (Expr(PAnd), symbol, Sort(FObj))++parseQuery :: String -> IO LQuery+parseQuery fn = parseFromFile (queryP fn) fn +++queryP fn = do+  n      <- depthP+  bs     <- sepBy envP   whiteSpace+  semi+  vars   <- sepBy bindP  whiteSpace+  semi+  ds     <- declsP+  axioms <- sepBy axiomP whiteSpace+  semi+  ctors  <- sepBy ctorP  whiteSpace+  semi +  goal   <- goalP+  return $ mempty { q_axioms = axioms+                  , q_vars   = vars+                  , q_ctors  = ctors+                  , q_goal   = goal+                  , q_fname  = fn+                  , q_depth  = n +                  , q_env    = bs+                  , q_decls  = ds+                  }+++declsP :: Parser [Predicate]+declsP = try (do {n <- sepBy declP whiteSpace; semi; return n} )+      <|> return []++declP :: Parser Predicate+declP = reserved "declare" >> predicateP++depthP :: Parser Int +depthP = try (do {reserved "depth"; reserved "="; n <- fromInteger <$> integer; semi; return n} )+      <|> return default_depth++goalP :: Parser Predicate+goalP = reserved "goal" >> colon >> predicateP++ctorP :: Parser LVarCtor+ctorP = do reserved "constructor"+           v <- varP+           (vs, p) <- try (ctorAxiomP)+           return $ VarCtor v vs p++ctorAxiomP +   =  do reserved "with"+         reserved "forall"+         aargs <- argumentsP+         abody <- predicateP+         return (aargs, abody) +  <|> return ([], Pred $ PAnd [])++bindP :: Parser LVar+bindP = reserved "bind" >> varP++envP :: Parser LVar+envP = reserved "constant" >> varP++predicateP :: Parser Predicate+predicateP = Pred <$> predP++axiomP :: Parser LAxiom+axiomP = do +  reserved "axiom"+  aname <- mkVar <$> symbolP+  colon+  reserved "forall"+  aargs <- argumentsP+  abody <- predicateP+  return $ Axiom aname aargs abody+ where+   dummySort = FObj (symbol "dummySort")+   mkVar x   = Var x dummySort ()+++argumentsP :: Parser ([LVar])+argumentsP = brackets $ sepBy varP comma++varP :: Parser LVar+varP = do +  x <- symbolP+  colon+  s <- sortP+  return $ Var x s ()+++
+ src/Language/Haskell/Liquid/Prover/Pretty.hs view
@@ -0,0 +1,64 @@+module Language.Haskell.Liquid.Prover.Pretty where++import Language.Haskell.Liquid.Prover.Types++import Language.Fixpoint.Types hiding (Predicate, EApp, EVar, Expr)++instance PPrint (Var a) where+   pprintTidy k = pprintTidy k . var_name++instance PPrint (Expr a) where+   pprintTidy k = pprintTidy k . mkExpr++instance PPrint Predicate where+   pprintTidy k = pprintTidy k . p_pred++instance Show (Axiom a) where+   show a = showpp (axiom_name a) ++ ": " ++ "forall"++ par(sep ", " $ map show (axiom_vars a)) ++ "."  ++ show (axiom_body a) ++ "\n"++instance Show (Instance a) where+   show i = "\nInstance :: " ++ show (inst_axiom i) ++ "With Arguments :: " ++  (sep ", " $ map show (inst_args i))+                       --      ++ "\n\nPredicate = " ++ show (inst_pred i)  ++ "\n\n"++instance Show (Var a) where+   show v = showpp (var_name v) ++ " : " ++ showpp (var_sort v)++instance Show (Ctor a) where+   show c = show (ctor_expr c) ++ "\t \\" ++ (sep ", " $ map show (ctor_vars c)) -- ++ " -> " ++ show (ctor_prop c)++instance Show (VarCtor a) where+   show c = show (vctor_var c) ++ "\t \\" ++ (sep ", " $ map show (vctor_vars c)) --  ++ " -> " ++ show (vctor_prop c)++instance Show (Expr a) where+   show (EVar v)    = showpp v+   show (EApp c es) = show c ++ par (sep ", "  $ map show es)++instance Show Predicate where+   show (Pred p) = showpp $ pprint p++instance Show (Query a) where+   show q = "\nQuery\n" +++              "\nAxioms::" ++ (showNum $ q_axioms q) +++              "\nVars  ::" ++ (sep ", " $ map show   $ q_vars   q) +++              "\nCtors ::" ++ (sep ", " $ map show   $ q_ctors  q) +++              "\nDecls ::" ++ (sep ", " $ map show   $ q_decls  q) +++              "\nGoal  ::" ++ (show $ q_goal q) +++              "\nDecls ::" ++ (show $ q_decls q) +++              "\nFname ::" ++ (show $ q_fname q)++instance Show (Proof a) where+  show Invalid    = "\nInvalid\n"+  show (Proof is) = "\nProof ::\n" ++ (sep "\n" $ map show is)+++instance Show (ArgExpr a) where+  show ae = "\nArgExpr for " ++ show (arg_sort ae) ++ "\n\nEXPRS = \n\n" ++  (sep ", " (map show $ arg_exprs ae)) +++            "\n\nConstructors = " ++ (sep ", " (map show $ arg_ctors ae)) ++ "\n\n"++showNum ls = concat [ show i ++ " . " ++ show l | (l, i) <- zip ls [1..] ]+++par str = " (" ++ str ++ ") "+sep _ []     = []+sep _ [x]    = x+sep c (x:xs) = x ++ c ++ sep c xs
+ src/Language/Haskell/Liquid/Prover/SMTInterface.hs view
@@ -0,0 +1,14 @@+module Language.Haskell.Liquid.Prover.SMTInterface where++import Language.Fixpoint.Smt.Interface ++import Language.Fixpoint.Types++makeContext :: FilePath -> [(Symbol, Sort)] -> IO Context +makeContext = makeZ3Context++checkValid :: Context -> [Expr] -> Expr -> IO Bool+checkValid me is q = checkValidWithContext me [] (pAnd is) q++assert :: Context -> Expr -> IO ()+assert =  smtAssert
+ src/Language/Haskell/Liquid/Prover/Solve.hs view
@@ -0,0 +1,304 @@+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TupleSections #-}++module Language.Haskell.Liquid.Prover.Solve where++import Language.Haskell.Liquid.Prover.Types+import Language.Haskell.Liquid.Prover.SMTInterface+import Language.Haskell.Liquid.Prover.Pretty ()+import Language.Haskell.Liquid.Prover.Constants+import Language.Haskell.Liquid.Prover.Misc (findM, powerset)++import Language.Fixpoint.Smt.Interface (Context)+-- import Language.Fixpoint.Misc +import qualified Language.Fixpoint.Types as F ++import Data.List  (nubBy, nub, isPrefixOf, partition)+import Data.Maybe (isJust, fromJust, catMaybes)++import System.IO++-- import Control.Monad (filterM)++import Language.Fixpoint.SortCheck+import Language.Fixpoint.Types.Refinements (SortedReft)++type PrEnv = F.SEnv SortedReft  ++solve :: Query a -> IO (Proof a)+solve q = +  do putStrLn $ "Solving Query\n" ++ show q+     cxt     <- makeContext (smtFile $ q_fname q) env+     mapM_ (assert cxt) (p_pred <$> q_decls q)+     proof   <- iterativeSolve γ (q_depth q) cxt (varCtorToCtor <$> q_ctors q) es (p_pred $ q_goal q) (q_axioms q)+     putStrLn $ ("\nProof = \n" ++ show proof)+     return proof+  where +    es    = initExpressions $ filter notGHCVar vars+    env   = nub ([(var_name v, var_sort v) | v <- ((vctor_var <$> q_ctors q) ++ q_vars q), notGHCVar v ] ++ [(var_name v, var_sort v) | v <- q_env q])+    γ     = F.fromListSEnv $ [(x, F.trueSortedReft s) | (x,s) <- env]+    vars  = if q_isHO q then ((vctor_var <$> q_ctors q) ++ q_vars q) else q_vars q+++notGHCVar v +  = not $ isPrefixOf "GHC" (show v)++iterativeSolve :: PrEnv -> Int -> Context -> [Ctor a] -> [Expr a] -> F.Expr -> [Axiom a] -> IO (Proof a)+iterativeSolve γ iter cxt cts es q axioms = go is0 [] 0 tes+  where +    go _  _      i _  | i == iter = return Invalid +    go as old_es i es = do prf   <- findValid cxt is q  +                           -- putStr ("Validity check with " ++ show is ++ " IS " ++ show prf) +                           -- putStrLn ("\nITERATION\n" ++ show i)+                           if isJust prf +                                then do putStrLn "Minimizing Solution"+                                        Proof <$> minimize cxt (fromJust prf) q+                                else do es' <-  makeExpressions γ cxt is cts es +                                        mapM_ (assertExpressions γ cxt) es'+                                        go is (mergeExpressions es old_es) (i+1) es' +                        where +                         is = concatMap (instantiate γ old_es es) asn ++ as+    (as0, asn) = partition (null . axiom_vars) axioms+    is0        = (\a -> Inst a [] (axiom_body a)) <$> as0 +    tes        = groupExpressions γ es +++type Arguments a = [(F.Sort, [Expr a])] ++groupExpressions :: PrEnv -> [Expr a] -> Arguments a +groupExpressions γ = go [] +  where+    go acc []     = acc+    go acc (e:es) = go (placeExpr γ acc e) es ++placeExpr :: PrEnv -> Arguments a -> Expr a -> Arguments a +placeExpr γ acc e = go [] acc +  where+    t = sortExpr F.dummySpan γ' $ mkExpr e+    go old_as []           = (t, [e]):(acc ++ old_as)+    go old_as ((s, es):as) | unifiable s t = (s,e:es):(as ++ old_as)+                           | otherwise     = go ((s,es):old_as) as +    γ' = F.fromListSEnv $ [(x, F.sr_sort s) | (x,s) <- F.toListSEnv γ]++mergeExpressions :: Arguments a -> Arguments a -> Arguments a +mergeExpressions as1 as2 = merge as1 as2 +  where+    merge as1 []     = as1  +    merge as1 (a:as) = merge (placeArg as1 a) as ++placeArg as a = go [] a as +  where+    go acc a [] = a:acc+    go acc (s, es) ((s', es'):as) | unifiable s s' = (s, es++es'):(as++acc) +                                  | otherwise      = go ((s', es'):acc) (s, es) as +++findValid :: Context -> [Instance a] -> F.Expr -> IO (Maybe [Instance a])+findValid cxt ps q +  = (\b -> if b then Just ps else Nothing) <$> checkValid cxt (p_pred . inst_pred <$> ps) q++minimize :: Context -> [Instance a] -> F.Expr -> IO [Instance a]+minimize cxt ps q | length ps < epsilon = fromJust <$> bruteSearch cxt ps q +minimize cxt ps q = go 1 [] ps +  where+    n = length ps `div` delta+    go _ acc [] = if (length acc < length ps) then minimize cxt acc q else fromJust <$> bruteSearch cxt acc q  +    go i acc is = do let (ps1, ps2) = splitAt n is +                     let as = p_pred . inst_pred <$> (acc ++ ps2)+                     res <- checkValid cxt as q+                     let _msg = show i ++ " / " ++ show delta ++ "\n"+                     putStr "*" >> hFlush stdout+                     if res then go (i+1) acc          ps2 +                            else go (i+1) (acc ++ ps1) ps2 ++bruteSearch :: Context -> [Instance a] -> F.Expr -> IO (Maybe [Instance a])+bruteSearch cxt ps q +  = findM (\is -> checkValid cxt (p_pred . inst_pred <$> is) q) (powerset ps)++filterEquivalentExpressions :: PrEnv -> Context -> [Instance a] -> Arguments a -> Arguments a -> IO (Arguments a)+filterEquivalentExpressions γ cxt is esold esnew +  = mapM filterArguments esnew+  where +    filterArguments (s, es) = (s,) <$> foo [] (grapOldArgs s esold) es  +    f eold e@(EApp c es) = not <$> checkValid cxt ((predCtor γ c (mkExpr <$> es)):(p_pred . inst_pred <$> is))+                                     (F.POr $ catMaybes $ (makeEq γ e <$> eold))+    f eold e = not <$> checkValid cxt (p_pred . inst_pred <$> is) (F.POr $ catMaybes $ (makeEq γ e <$> eold))+++    foo acc _   []     = return acc +    foo acc old (e:es) = do r <- f (acc ++ old) e+                            if r then foo (e:acc) old es +                                 else foo acc     old es  ++++    grapOldArgs _ []  = [] +    grapOldArgs s ((t, es):as) +      | unifiable s t = es ++ grapOldArgs s as +      | otherwise     = grapOldArgs s as ++makeEq :: PrEnv -> Expr a -> Expr a -> Maybe (F.Expr)+makeEq γ e1 e2 = case (checkSortedReftFull γ p) of +                   Nothing -> Just p +                   Just _  -> Nothing +              where+                p = F.PAtom F.Eq (mkExpr e1) (mkExpr e2) +++assertExpressions :: PrEnv -> Context -> (F.Sort, [Expr a]) -> IO ()+assertExpressions γ cxt a = mapM_ go (snd a) +  where+    go (EApp c es) +      | length es == length (ctor_vars c)+      = do mapM go es +           assert cxt $ predCtor γ c (mkExpr <$> es)+    go _    +      = return ()++predCtor γ c es +  | length es /= length (ctor_vars c) && length (ctor_vars c) /= 0+  = F.PTrue +  | otherwise +  = case checkSortedReftFull γ p of+     Nothing -> p+     Just _  -> F.PTrue +  where +    su = F.mkSubst $ zip (var_name <$> ctor_vars c) es+    p  = F.subst su (p_pred $ ctor_prop c)++makeExpressions :: PrEnv -> Context -> [Instance a] -> [Ctor a] -> Arguments a -> IO (Arguments a)+makeExpressions γ cxt is cts es +  = -- traceShow ("\nNew expressions from \n" ++ show cts ++ "\nAND\n" ++ show es) <$> +     filterEquivalentExpressions γ cxt is es newes       +  where+    newes = groupExpr [] [EApp c ess | c <- cts, ess <- makeCTorArgs c es]++    groupExpr acc []     = acc +    groupExpr acc (e:es) = groupExpr (putExpr e (checkSortExpr γ' $ mkExpr e) acc) es  ++    γ' = F.fromListSEnv $ [(x, F.sr_sort s) | (x,s) <- F.toListSEnv γ]+++putExpr _ Nothing  as  +  = as +putExpr e (Just t) []  +  = [(t, [e])]+putExpr e (Just t) ((s, es):as)+  | unifiable t s = (s, e:es):as+  | otherwise     = (s, es):putExpr e (Just t) as   +++makeArguments :: [F.Sort] -> Arguments a -> [[Expr a]]+makeArguments ss es = applyArguments ees +  where +    ees = -- traceShow ("\nCandicate for \n" ++ show ss  ++ "\nWith arguments \n" ++ show es) +          ((`makeCandicates` es) <$> ss)++    makeCandicates _ [] = [] +    makeCandicates s ((t,xs):xss) +       | unifiable s t  = xs ++ makeCandicates s xss  +       | otherwise      = makeCandicates s xss +++makeCTorArgs :: Ctor a -> Arguments a -> [[Expr a]]+makeCTorArgs c = makeArguments ((var_sort <$> ctor_vars c) ++ (argumentssort $ ctor_sort c))+  where+    argumentssort (F.FAbs _ s)   = argumentssort s +    argumentssort (F.FFunc s' s) = s':argumentssort s +    argumentssort _              = [] ++applyArguments :: [[a]] -> [[a]]+applyArguments []           = []+applyArguments ([]:_)       = [] +applyArguments ((x:xs):ess) = [x] : ((map (x:) (filter (not . null ) $ applyArguments ess)) ++ applyArguments (xs:ess))++makeArgumnetsExpr n es = concatMap (`makeArgs` es) [1..n]++arity :: Ctor a -> Int+arity c +  = case F.functionSort $ ctor_sort c of +      Nothing -> 0 +      Just (_, ss, _) -> length ss ++initExpressions :: [Var a] -> [Expr a]+initExpressions = map EVar++instantiate :: PrEnv -> Arguments a -> Arguments a -> Axiom a -> [Instance a]+instantiate γ oldses ses a +  = {- traceShow ("\nInstances for\n" ++ show a ++ +               "ALL expr = " ++ show (oldses, mergeExpressions oldses ses) ++ +               "\nTYPES = \n" ++ show ss +++               "\nmake arguments = \n" ++ show (makeArguments ss (mergeExpressions ses oldses))+              ) $ -} +     catMaybes (axiomInstance γ a <$> args) +  where+    args   = filter (\es -> length es == length ss && hasNew es) $ makeArguments ss (mergeExpressions ses oldses)+    hasNew = any (`elem` (concatMap snd ses))+    ss     = var_sort <$> axiom_vars a ++makeArgs' n es +  | length es < n = []+  | otherwise     = makeArgs n es  +-- NV TODO: allow multiple occurences of the same argument+duplicateArgs _ e = [e]++makeArgs :: Int -> [Expr a] -> [[Expr a]]+makeArgs 0 _      = [[]]+makeArgs n (x:xs) + | n == length (x:xs)+ = [x:xs] + | otherwise+ = ((x:)<$> makeArgs (n-1) xs) ++ makeArgs n xs+makeArgs n xs = error ("makeArgs for "  ++ show (n, xs))+++axiomInstance :: PrEnv -> Axiom a -> [Expr a] -> Maybe (Instance a) +axiomInstance γ a es +  = case checkSortedReftFull γ $ p_pred pred of+     Nothing -> Just {-  traceShow "\n\n Add instance" -}  i+     Just _e  -> {- traceShow (show _e ++ "\n\n Reject instance " ++ show i ) -}   Nothing +  where +    pred = F.subst (F.mkSubst $ zip (var_name <$> (axiom_vars a)) (mkExpr <$> es)) (axiom_body a)+    i    = Inst { inst_axiom = a+                , inst_args  = es+                , inst_pred  = pred+                }+++checkExpr :: PrEnv -> Expr a -> Bool+checkExpr γ e = not $ isJust $ checkSortedReftFull γ $ mkExpr e ++mkcheckExpr :: PrEnv -> Expr a -> F.Expr+mkcheckExpr γ e +  = case checkSortedReftFull γ e' of+      Nothing -> e'+      Just d -> error ("Unsorted expression\n" ++ show e ++ "\nExpr = \n" ++ show e' ++ "\nError\n" ++ show d)++  where e' = mkExpr e   +++makeSorts :: Query a -> [F.Sort]+makeSorts q = nubBy unifiable (asorts ++ csorts)+  where +     asorts = var_sort <$> (concatMap axiom_vars $ q_axioms q)+     csorts = concatMap argumentsort ((var_sort . vctor_var) <$> q_ctors q)+     argumentsort s = case F.functionSort s of {Nothing -> []; Just (_, ss, s) -> s:ss}++++unifiable :: F.Sort -> F.Sort -> Bool+unifiable (F.FVar _)   (F.FVar _)       = True +unifiable (F.FVar _)   (F.FObj _)       = True +unifiable (F.FObj _)   (F.FVar _)       = True +unifiable (F.FVar _)   _                = True  +unifiable _            (F.FVar _)       = True +unifiable (F.FObj _)   _                = True +unifiable _            (F.FObj _)       = True  +unifiable (F.FApp t s) (F.FApp t' s') = unifiable t t' && unifiable s s'+unifiable (F.FFunc t s) (F.FFunc t' s') = unifiable t t' && unifiable s s'+unifiable (F.FAbs _ t) t'               = unifiable t t'+unifiable t            (F.FAbs _ t')    = unifiable t t'++unifiable t1 t2 = isJust $ unify (const $ error "NV TODO: prover.Solve") t1 t2++
+ src/Language/Haskell/Liquid/Prover/Types.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE PatternGuards        #-}++module Language.Haskell.Liquid.Prover.Types where++import Language.Haskell.Liquid.Prover.Constants (default_depth)++import qualified Language.Fixpoint.Types as F+import Language.Fixpoint.Types hiding (Predicate, EApp, EVar, Expr)++type LVar     = Var     ()+type LVarCtor = VarCtor ()+type LAxiom   = Axiom   ()+type LQuery   = Query   ()+++data Axiom a = Axiom { axiom_name :: Var a+                     , axiom_vars :: [LVar]+                     , axiom_body :: Predicate+                     }++data Var a   = Var { var_name :: Symbol+                   , var_sort :: Sort+                   , var_info :: a+                   }++instance Eq (Var a) where+  v1 == v2 = (var_name v1) == (var_name v2)+++-- Note: Ctors may be higher order, like compose+-- when not fully instantiated, the predicate should not be used+data Ctor a  = Ctor { ctor_expr :: Expr a+                    , ctor_sort :: Sort +                    , ctor_vars :: [LVar]+                    , ctor_prop :: Predicate+                    }+              -- constructors can be expressions like (compose f g)+++data VarCtor a  = VarCtor { vctor_var  :: Var a+                          , vctor_vars :: [LVar]+                          , vctor_prop :: Predicate+                          }+++instance Eq (Ctor a) where+  c1 == c2 = (ctor_expr c1) == (ctor_expr c2)++data Expr a  = EVar (Var a)+             | EApp (Ctor a) [Expr a]++  deriving (Eq)++newtype Predicate = Pred {p_pred :: F.Expr}++data Proof a     = Invalid+                 | Proof { p_evidence :: [Instance a]}++data Instance a  = Inst { inst_axiom :: Axiom a+                        , inst_args  :: [Expr a]+                        , inst_pred  :: Predicate+                        }+++data Query a = Query { q_axioms :: ![Axiom a]+                     , q_ctors  :: ![VarCtor a]+                     , q_vars   :: ![Var a]+                     , q_env    :: ![LVar]+                     , q_goal   :: !Predicate+                     , q_fname  :: !FilePath+                     , q_depth  :: !Int+                     , q_decls  :: [Predicate]+                     , q_isHO   :: Bool +                     }++-- | ArgExpr provides for each sort s+-- | a list of expressions of sort s+-- | and the list of constroctors that can create an expression of sort s.+data ArgExpr a = ArgExpr { arg_sort  :: Sort+                         , arg_exprs :: [Expr a]+                         , arg_ctors :: [Ctor a]+                         }++instance Monoid Predicate where+    mempty                      = Pred mempty+    mappend (Pred p1) (Pred p2) = Pred (p1 `mappend` p2)++instance Monoid (Query a) where+    mempty        = Query { q_axioms = mempty+                          , q_ctors  = mempty+                          , q_vars   = mempty+                          , q_env    = mempty+                          , q_goal   = mempty+                          , q_fname  = mempty+                          , q_depth  = default_depth+                          , q_decls  = mempty+                          , q_isHO   = False +                          }+    mappend q1 q2 = Query { q_axioms = q_axioms q1 `mappend` q_axioms q2+                          , q_ctors  = q_ctors  q1 `mappend` q_ctors  q2+                          , q_env    = q_env    q1 `mappend` q_env    q2+                          , q_vars   = q_vars   q1 `mappend` q_vars   q2+                          , q_goal   = q_goal   q1 `mappend` q_goal   q2+                          , q_fname  = q_fname  q1 `mappend` q_fname  q2+                          , q_decls  = q_decls  q1 `mappend` q_decls  q2+                          , q_depth  = q_depth  q1 `max`     q_depth  q2+                          , q_isHO   = q_isHO   q1 ||        q_isHO   q2+                          }+++instance F.Subable Predicate where+  subst su (Pred p)  = Pred $ subst su p+  substa su (Pred p) = Pred $ substa su p+  substf su (Pred p) = Pred $ substf su p+  syms (Pred p)      = syms p++varCtorToCtor :: VarCtor a -> Ctor a+varCtorToCtor (VarCtor v vs p) = Ctor (EVar v) (var_sort v) vs p+++isEVar (EVar _) = True+isEVar _        = False++mkExpr :: Expr a -> F.Expr+mkExpr (EVar v)    +  = F.EVar (var_name v)+mkExpr (EApp c es)+  = F.eApps (mkExpr $ ctor_expr c) (mkExpr <$> es)
− src/Language/Haskell/Liquid/Qualifier.hs 
@@ -1,133 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns      #-}-module Language.Haskell.Liquid.Qualifier (-  specificationQualifiers-  ) where--import Language.Haskell.Liquid.Bare-import Language.Haskell.Liquid.RefType-import Language.Haskell.Liquid.GhcMisc  (getSourcePos)-import Language.Haskell.Liquid.PredType-import Language.Haskell.Liquid.Types-import Language.Fixpoint.Types-import Language.Fixpoint.Misc--import Control.Applicative      ((<$>))-import Data.List                (delete, nub)-import Data.Maybe               (fromMaybe)-import qualified Data.HashSet as S-import Data.Bifunctor           (second)--------------------------------------------------------------------------------------specificationQualifiers :: Int -> GhcInfo -> [Qualifier]-------------------------------------------------------------------------------------specificationQualifiers k info-  = [ q | (x, t) <- (tySigs $ spec info) ++ (asmSigs $ spec info) ++ (ctors $ spec info)-        -- FIXME: this mines extra, useful qualifiers but causes a significant increase in running time-        -- , ((isClassOp x || isDataCon x) && x `S.member` (S.fromList $ impVars info ++ defVars info)) || x `S.member` (S.fromList $ defVars info)-        , x `S.member` (S.fromList $ defVars info)-        , q <- refTypeQuals (getSourcePos x) (tcEmbeds $ spec info) (val t)-        , length (q_params q) <= k + 1-    ]---- GRAVEYARD: scraping quals from imports kills the system with too much crap--- specificationQualifiers info = {- filter okQual -} qs---   where---     qs                       = concatMap refTypeQualifiers ts---     refTypeQualifiers        = refTypeQuals $ tcEmbeds spc---     ts                       = val <$> t1s ++ t2s---     t1s                      = [t | (x, t) <- tySigs spc, x `S.member` definedVars]---     t2s                      = [] -- [t | (_, t) <- ctor spc                            ]---     definedVars              = S.fromList $ defVars info---     spc                      = spec info------ okQual                       = not . any isPred . map snd . q_params---   where---     isPred (FApp tc _)       = tc == stringFTycon "Pred"---     isPred _                 = False---refTypeQuals l tce t  = quals ++ pAppQuals l tce preds quals-  where-    quals             = refTypeQuals' l tce t-    preds             = filter isPropPV $ ty_preds $ toRTypeRep t--pAppQuals l tce ps qs = [ pAppQual l tce p xs (v, e) | p <- ps, (s, v, _) <- pargs p, (xs, e) <- mkE s ]-  where-    mkE s             = concatMap (expressionsOfSort (rTypeSort tce s)) qs--expressionsOfSort sort (Q _ pars (PAtom Eq (EVar v) e2) _)-  | (v, sort) `elem` pars-  = [(filter (/=(v, sort)) pars, e2)]--expressionsOfSort _ _-  = []--pAppQual l tce p args (v, expr) =  Q "Auto" freeVars pred l-  where-    freeVars                  = (vv, tyvv) : (predv, typred) : args-    pred                      = pApp predv $ EVar vv:predArgs-    vv                        = "v"-    predv                     = "~P"-    tyvv                      = rTypeSort tce $ pvType p-    typred                    = rTypeSort tce (pvarRType p :: RSort)-    predArgs                  = mkexpr <$> (snd3 <$> pargs p)-    mkexpr x                  = if x == v then expr else EVar x---- refTypeQuals :: SpecType -> [Qualifier]-refTypeQuals' l tce t0        = go emptySEnv t0-  where-    go γ t@(RVar _ _)         = refTopQuals l tce t0 γ t-    go γ (RAllT _ t)          = go γ t-    go γ (RAllP _ t)          = go γ t-    go γ t@(RAppTy t1 t2 _)   = go γ t1 ++ go γ t2 ++ refTopQuals l tce t0 γ t-    go γ (RFun x t t' _)      = (go γ t)-                                ++ (go (insertSEnv x (rTypeSort tce t) γ) t')-    go γ t@(RApp c ts rs _)   = (refTopQuals l tce t0 γ t)-                                ++ concatMap (go (insertSEnv (rTypeValueVar t) (rTypeSort tce t) γ)) ts-                                ++ goRefs c (insertSEnv (rTypeValueVar t) (rTypeSort tce t) γ) rs-    go γ (RAllE x t t')       = (go γ t)-                                ++ (go (insertSEnv x (rTypeSort tce t) γ) t')-    go γ (REx x t t')         = (go γ t)-                                ++ (go (insertSEnv x (rTypeSort tce t) γ) t')-    go _ _                    = []-    goRefs c g rs             = concat $ zipWith (goRef g) rs (rTyConPVs c)-    goRef g (RProp  s t)  _   = go (insertsSEnv g s) t-    goRef _ (RPropP _ _)  _   = []-    goRef _ (RHProp _ _)  _   = errorstar "TODO: EFFECTS"-    insertsSEnv               = foldr (\(x, t) γ -> insertSEnv x (rTypeSort tce t) γ)--refTopQuals l tce t0 γ t-  = [ mkQual l t0 γ v so pa  | let (RR so (Reft (v, ra))) = rTypeSortedReft tce t-                             , pa                        <- conjuncts $ raPred ra-                             , not $ isHole pa-    ] ++-    [ mkPQual l tce t0 γ s e | let (U _ (Pr ps) _) = fromMaybe (msg t) $ stripRTypeBase t-                             , p <- findPVar (ty_preds $ toRTypeRep t0) <$> ps-                             , (s, _, e) <- pargs p-    ]-    where-      msg t = errorstar $ "Qualifier.refTopQuals: no typebase" ++ showpp t--mkPQual l tce t0 γ t e = mkQual l t0 γ' v so pa-  where-    v                  = "vv"-    so                 = rTypeSort tce t-    γ'                 = insertSEnv v so γ-    pa                 = PAtom Eq (EVar v) e--mkQual l t0 γ v so p   = Q "Auto" ((v, so) : yts) p' l-  where-    yts                = [(y, lookupSort t0 x γ) | (x, y) <- xys ]-    p'                 = subst (mkSubst (second EVar <$> xys)) p-    xys                = zipWith (\x i -> (x, symbol ("~A" ++ show i))) xs [0..]-    xs                 = delete v $ orderedFreeVars γ p--lookupSort t0 x γ  = fromMaybe (errorstar msg) $ lookupSEnv x γ-  where-    msg            = "Unknown freeVar " ++ show x ++ " in specification " ++ show t0--orderedFreeVars γ = nub . filter (`memberSEnv` γ) . syms---- atoms (PAnd ps)   = concatMap atoms ps--- atoms p           = [p]
− src/Language/Haskell/Liquid/RefSplit.hs 
@@ -1,123 +0,0 @@-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE UndecidableInstances #-}--module Language.Haskell.Liquid.RefSplit (--        splitXRelatedRefs--        ) where--import Control.Applicative-import Data.List (partition)-import Text.PrettyPrint.HughesPJ--import Language.Haskell.Liquid.Types-import Language.Haskell.Liquid.PrettyPrint ()--import Language.Fixpoint.Types-import Language.Fixpoint.Misc--splitXRelatedRefs :: Symbol -> SpecType -> (SpecType, SpecType)-splitXRelatedRefs x t = splitRType x t----splitRType f (RVar a r) = (RVar a r1, RVar a r2)-  where-        (r1, r2) = splitRef f r--splitRType f (RFun x tx t r) = (RFun x tx1 t1 r1, RFun x tx2 t2 r2)-  where-        (tx1, tx2) = splitRType f tx-        (t1,  t2)  = splitRType f t-        (r1,  r2)  = splitRef   f r--splitRType f (RAllT v t) = (RAllT v t1, RAllT v t2)-  where-        (t1, t2) = splitRType f t--splitRType f (RAllP p t) = (RAllP p t1, RAllP p t2)-  where-        (t1, t2) = splitRType f t--splitRType f (RAllS s t) = (RAllS s t1, RAllS s t2)-  where-        (t1, t2) = splitRType f t---splitRType f (RApp c ts rs r) = (RApp c ts1 rs1 r1, RApp c ts2 rs2 r2)-  where-        (ts1, ts2) = unzip (splitRType f <$> ts)-        (rs1, rs2) = unzip (splitUReft f <$> rs)-        (r1,  r2)  = splitRef f r--splitRType f (RAllE x tx t) = (RAllE x tx1 t1, RAllE x tx2 t2)-  where-        (tx1, tx2) = splitRType f tx-        (t1, t2)   = splitRType f t--splitRType f (REx x tx t) = (REx x tx1 t1, REx x tx2 t2)-  where-        (tx1, tx2) = splitRType f tx-        (t1, t2)   = splitRType f t--splitRType _ (RExprArg e) = (RExprArg e, RExprArg e)--splitRType f (RAppTy tx t r) = (RAppTy tx1 t1 r1, RAppTy tx2 t2 r2)-  where-        (tx1, tx2) = splitRType f tx-        (t1,  t2)  = splitRType f t-        (r1,  r2)  = splitRef   f r--splitRType f (RRTy xs r o t) = (RRTy xs1 r1 o t1, RRTy xs2 r2 o t2)-  where-        (xs1, xs2) = unzip (go <$> xs)-        (r1, r2) = splitRef   f r-        (t1, t2) = splitRType f t--        go (x, t) = let (t1, t2) = splitRType f t in ((x,t1), (x, t2))---splitRType f (RHole r) = (RHole r1, RHole r2)-  where-        (r1, r2) = splitRef f r--splitUReft :: Symbol -> RTProp c tv (UReft Reft) -> (RTProp c tv (UReft Reft), RTProp c tv (UReft Reft))-splitUReft x (RPropP xs r) = (RPropP xs r1, RPropP xs r2)-  where-        (r1, r2) = splitRef x r--splitUReft x (RProp xs t) = (RProp xs t1, RProp xs t2)-  where-        (t1, t2) = splitRType x t--splitUReft _ (RHProp xs _) = (RHProp xs w1, RHProp xs w2)-  where-        (w1, w2) = error "TODO: RefSplit.splitUReft"--splitRef f (U r p s) = (U r1 p1 s, U r2 p2 s)-        where-                (r1, r2) = splitReft f r-                (p1, p2) = splitPred f p--splitReft f (Reft (v, Refa xs)) = (Reft (v, Refa $ pAnd xs1), Reft (v, Refa $ pAnd xs2))-  where-    (xs1, xs2)       = partition (isFree f) (unPAnd xs)--    unPAnd (PAnd ps) = concatMap unPAnd ps-    unPAnd p         = [p]--splitPred f (Pr ps) = (Pr ps1, Pr ps2)-  where-    (ps1, ps2) = partition g ps-    g p = any (isFree f) (thd3 <$> pargs p)---class IsFree a where-        isFree :: Symbol -> a -> Bool--instance (Subable x) => (IsFree x) where-        isFree x p = x `elem` syms p--instance Show (UReft Reft) where-         show = render . pprint
− src/Language/Haskell/Liquid/RefType.hs 
@@ -1,1143 +0,0 @@-{-# LANGUAGE IncoherentInstances       #-}-{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE MultiParamTypeClasses     #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE UndecidableInstances      #-}-{-# LANGUAGE TypeSynonymInstances      #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE PatternGuards             #-}---- | Refinement Types. Mostly mirroring the GHC Type definition, but with---   room for refinements of various sorts.---- TODO: Desperately needs re-organization.-module Language.Haskell.Liquid.RefType (--  -- * Functions for lifting Reft-values to Spec-values-    uTop, uReft, uRType, uRType', uRTypeGen, uPVar--  -- * Applying a solution to a SpecType-  , applySolution--  -- * Functions for decreasing arguments-  , isDecreasing, makeDecrType, makeNumEnv-  , makeLexRefa--  -- * Functions for manipulating `Predicate`s-  , pdVar-  , findPVar-  , freeTyVars, tyClasses, tyConName--  -- TODO: categorize these!-  , ofType, toType-  , rTyVar, rVar, rApp, rEx-  , symbolRTyVar-  , addTyConInfo-  -- , expandRApp-  , appRTyCon-  , typeSort, typeUniqueSymbol-  , strengthen-  , generalize, normalizePds-  , subts, subvPredicate, subvUReft-  , subsTyVar_meet, subsTyVars_meet, subsTyVar_nomeet, subsTyVars_nomeet-  , dataConSymbol, dataConMsReft, dataConReft-  , classBinds--  , isSizeable--  -- * Manipulating Refinements in RTypes-  , rTypeSortedReft-  , rTypeSort-  , shiftVV--  , mkDataConIdsTy-  , mkTyConInfo---  , strengthenRefTypeGen-  , strengthenDataConType--  ) where--import WwLib-import FamInstEnv (emptyFamInstEnv)-import Var-import GHC              hiding (Located)-import DataCon-import qualified TyCon  as TC-import TypeRep          hiding (maybeParen, pprArrowChain)-import Type             (splitFunTys, expandTypeSynonyms, substTyWith, isClassPred)-import TysWiredIn       (listTyCon, intDataCon, trueDataCon, falseDataCon,-                         intTyCon, charTyCon)--import           Data.Monoid      hiding ((<>))-import           Data.Maybe               (fromMaybe, isJust)-import           Data.Hashable-import qualified Data.HashMap.Strict  as M-import qualified Data.HashSet         as S-import qualified Data.List as L-import Control.Applicative  hiding (empty)-import Control.DeepSeq-import Control.Monad  (void)-import Text.Printf-import Text.PrettyPrint.HughesPJ--import Language.Haskell.Liquid.PrettyPrint-import qualified Language.Fixpoint.Types as F-import Language.Fixpoint.Types hiding (shiftVV, Predicate)-import Language.Fixpoint.Visitor (mapKVars)-import Language.Haskell.Liquid.Types hiding (R, DataConP (..), sort)--import Language.Haskell.Liquid.Variance--import Language.Haskell.Liquid.Misc-import Language.Haskell.Liquid.Names-import Language.Fixpoint.Misc-import Language.Haskell.Liquid.GhcMisc (typeUniqueString, tvId, showPpr, stringTyVar, tyConTyVarsDef)-import Language.Fixpoint.Names (listConName, tupConName)-import Data.List (sort, foldl')---strengthenDataConType (x, t) = (x, fromRTypeRep trep{ty_res = tres})-    where-      trep = toRTypeRep t-      tres = ty_res trep `strengthen` U (exprReft expr) mempty mempty-      xs   = ty_binds trep-      as   = ty_vars  trep-      x'   = symbol x-      expr | null xs && null as = EVar x'-           | null xs            = EApp (dummyLoc x') []-           | otherwise          = EApp (dummyLoc x') (EVar <$> xs)--pdVar v        = Pr [uPVar v]--findPVar :: [PVar (RType c tv ())] -> UsedPVar -> PVar (RType c tv ())-findPVar ps p-  = PV name ty v (zipWith (\(_, _, e) (t, s, _) -> (t, s, e)) (pargs p) args)-  where PV name ty v args = fromMaybe (msg p) $ L.find ((== pname p) . pname) ps-        msg p = errorstar $ "RefType.findPVar" ++ showpp p ++ "not found"---- | Various functions for converting vanilla `Reft` to `Spec`--uRType          ::  RType c tv a -> RType c tv (UReft a)-uRType          = fmap uTop--uRType'         ::  RType c tv (UReft a) -> RType c tv a-uRType'         = fmap ur_reft--uRTypeGen       :: Reftable b => RType c tv a -> RType c tv b-uRTypeGen       = fmap $ const mempty--uPVar           :: PVar t -> UsedPVar-uPVar           = void--uReft           :: (Symbol, Refa) -> UReft Reft-uReft           = uTop . Reft--uTop            ::  r -> UReft r-uTop r          = U r mempty mempty------------------------------------------------------------------------------------- (Class) Predicates for Valid Refinement Types -------------------------------------------------------------------------------- Monoid Instances ------------------------------------------------------------instance ( SubsTy tv (RType c tv ()) (RType c tv ())-         , SubsTy tv (RType c tv ()) c-         , RefTypable c tv ()-         , RefTypable c tv r-         , PPrint (RType c tv r)-         , FreeVar c tv-         )-        => Monoid (RType c tv r)  where-  mempty  = errorstar "mempty: RType"-  mappend = strengthenRefType---- MOVE TO TYPES-instance ( SubsTy tv (RType c tv ()) (RType c tv ())-         , SubsTy tv (RType c tv ()) c-         , Reftable r-         , RefTypable c tv ()-         , RefTypable c tv (UReft r))-         => Monoid (Ref (RType c tv ()) r (RType c tv (UReft r))) where-  mempty      = errorstar "mempty: RType 2"-  mappend _ _ = errorstar "mappend: RType 2"--instance (SubsTy c (RType b c ()) b, Monoid r, Reftable r, RefTypable b c r, RefTypable b c (), FreeVar b c, SubsTy c (RType b c ()) (RType b c ()))-         => Monoid (RTProp b c r) where-  mempty         = errorstar "mempty: RTProp"--  mappend (RPropP s1 r1) (RPropP s2 r2)-    | isTauto r1 = RPropP s2 r2-    | isTauto r2 = RPropP s1 r1-    | otherwise  = RPropP s1 $ r1 `meet`-                               (subst (mkSubst $ zip (fst <$> s2) (EVar . fst <$> s1)) r2)--  mappend (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)----   mappend (RPropP s1 t1) (RProp s2 t2) = errorstar "Reftable.mappend on invalid inputs"-  mappend t1 t2 = errorstar ("Reftable.mappend on invalid inputs" ++ show (t1, t2))---   mappend _ _ = errorstar "Reftable.mappend on invalid inputs"--instance (Reftable r, RefTypable c tv r, RefTypable c tv (), FreeVar c tv, SubsTy tv (RType c tv ()) (RType c tv ()), SubsTy tv (RType c tv ()) c)-    => Reftable (RTProp c tv r) where-  isTauto (RPropP _ r) = isTauto r-  isTauto (RProp  _ t) = isTrivial t-  isTauto (RHProp _ _) = errorstar "RefType: Reftable isTauto in RHProp"-  top (RProp xs t)     = RProp xs $ mapReft top t-  top _                = errorstar "RefType: Reftable top"-  ppTy (RPropP _ r) d  = ppTy r d-  ppTy (RProp  _ _) _  = errorstar "RefType: Reftable ppTy in RProp"-  ppTy (RHProp _ _) _  = errorstar "RefType: Reftable ppTy in RProp"-  toReft               = errorstar "RefType: Reftable toReft"-  params               = errorstar "RefType: Reftable params for Ref"-  bot                  = errorstar "RefType: Reftable bot    for Ref"-  ofReft               = errorstar "RefType: Reftable ofReft for Ref"---------------------------------------------------------------------------------- | Subable Instances ------------------------------------------------------------------------------------------------------------------------------------instance Subable (RRProp Reft) where-  syms (RPropP ss r)     = (fst <$> ss) ++ syms r-  syms (RProp ss t)      = (fst <$> ss) ++ syms t-  syms _                 = error "TODO:EFFECTS"--  subst su (RPropP ss r) = RPropP (mapSnd (subst su) <$> ss) $ subst su r-  subst su (RProp ss r)  = RProp  (mapSnd (subst su) <$> ss) $ subst su r-  subst _  _             = error "TODO:EFFECTS"--  substf f (RPropP ss r) = RPropP (mapSnd (substf f) <$> ss) $ substf f r-  substf f (RProp  ss r) = RProp  (mapSnd (substf f) <$> ss) $ substf f r-  substf _ _             = error "TODO:EFFECTS"-  substa f (RPropP ss r) = RPropP (mapSnd (substa f) <$> ss) $ substa f r-  substa f (RProp  ss r) = RProp  (mapSnd (substa f) <$> ss) $ substa f r-  substa _ _             = error "TODO:EFFECTS"------------------------------------------------------------------------------------ | Reftable Instances -----------------------------------------------------------------------------------------------------------------------------------------instance (PPrint r, Reftable r) => Reftable (RType RTyCon RTyVar r) where-  isTauto     = isTrivial-  ppTy        = errorstar "ppTy RProp Reftable"-  toReft      = errorstar "toReft on RType"-  params      = errorstar "params on RType"-  bot         = errorstar "bot on RType"-  ofReft      = errorstar "ofReft on RType"-------------------------------------------------------------------------------------- | RefTypable Instances ----------------------------------------------------------------------------------------------------------------------------------------- MOVE TO TYPES-instance Fixpoint String where-  toFix = text---- MOVE TO TYPES-instance Fixpoint Class where-  toFix = text . showPpr---- MOVE TO TYPES-instance (SubsTy Symbol (RType c Symbol ()) c, TyConable c, Reftable r, PPrint r, PPrint c, FreeVar c Symbol, SubsTy Symbol (RType c Symbol ()) (RType c Symbol ())) => RefTypable c Symbol r where---   ppCls   = ppClassSymbol-  ppRType = ppr_rtype ppEnv---- MOVE TO TYPES-instance (Reftable r, PPrint r) => RefTypable RTyCon RTyVar r where---   ppCls   = ppClassClassPred-  ppRType = ppr_rtype ppEnv---- MOVE TO TYPES-class FreeVar a v where-  freeVars :: a -> [v]---- MOVE TO TYPES-instance FreeVar RTyCon RTyVar where-  freeVars = (RTV <$>) . tyConTyVarsDef . rtc_tc---- MOVE TO TYPES-instance FreeVar LocSymbol Symbol where-  freeVars _ = []----- Eq Instances ---------------------------------------------------------- MOVE TO TYPES-instance (RefTypable c tv ()) => Eq (RType c tv ()) where-  (==) = eqRSort M.empty--eqRSort m (RAllP _ t) (RAllP _ t')-  = eqRSort m t t'-eqRSort m (RAllS _ t) (RAllS _ t')-  = eqRSort m t t'-eqRSort m (RAllP _ t) t'-  = eqRSort m t t'-eqRSort m (RAllT a t) (RAllT a' t')-  | a == a'-  = eqRSort m t t'-  | otherwise-  = eqRSort (M.insert a' a m) t t'-eqRSort m (RAllT _ t) t'-  = eqRSort m t t'-eqRSort m t (RAllT _ t')-  = eqRSort m t t'-eqRSort m (RFun _ t1 t2 _) (RFun _ t1' t2' _)-  = eqRSort m t1 t1' && eqRSort m t2 t2'-eqRSort m (RAppTy t1 t2 _) (RAppTy t1' t2' _)-  = eqRSort m t1 t1' && eqRSort m t2 t2'-eqRSort m (RApp c ts _ _) (RApp c' ts' _ _)-  = c == c' && length ts == length ts' && and (zipWith (eqRSort m) ts ts')-eqRSort m (RVar a _) (RVar a' _)-  = a == M.lookupDefault a' a' m-eqRSort _ (RHole _) _-  = True-eqRSort _ _         (RHole _)-  = True-eqRSort _ _ _-  = False------------------------------------------------------------------------- | Wrappers for GHC Type Elements -------------------------------------------------------------------------------------------------------instance Eq Predicate where-  (==) = eqpd--eqpd (Pr vs) (Pr ws)-  = and $ (length vs' == length ws') : [v == w | (v, w) <- zip vs' ws']-    where vs' = sort vs-          ws' = sort ws---instance Eq RTyVar where-  RTV α == RTV α' = tvId α == tvId α'--instance Ord RTyVar where-  compare (RTV α) (RTV α') = compare (tvId α) (tvId α')--instance Hashable RTyVar where-  hashWithSalt i (RTV α) = hashWithSalt i α--instance Ord RTyCon where-  compare x y = compare (rtc_tc x) (rtc_tc y)--instance Hashable RTyCon where-  hashWithSalt i = hashWithSalt i . rtc_tc--------------------------------------------------------------------------------------------- Helper Functions ---------------------------------------------------------------------------------------------------rVar        = (`RVar` mempty) . RTV-rTyVar      = RTV--symbolRTyVar = rTyVar . stringTyVar . symbolString--normalizePds t = addPds ps t'-  where (t', ps) = nlzP [] t--rPred     = RAllP-rEx xts t = foldr (\(x, tx) t -> REx x tx t) t xts-rApp c    = RApp (RTyCon c [] (mkTyConInfo c [] [] Nothing))----- NV TODO : remove this code!!!--addPds ps (RAllT v t) = RAllT v $ addPds ps t-addPds ps t           = foldl' (flip rPred) t ps--nlzP ps t@(RVar _ _ )- = (t, ps)-nlzP ps (RFun b t1 t2 r)- = (RFun b t1' t2' r, ps ++ ps1 ++ ps2)-  where (t1', ps1) = nlzP [] t1-        (t2', ps2) = nlzP [] t2-nlzP ps (RAppTy t1 t2 r)- = (RAppTy t1' t2' r, ps ++ ps1 ++ ps2)-  where (t1', ps1) = nlzP [] t1-        (t2', ps2) = nlzP [] t2-nlzP ps (RAllT v t )- = (RAllT v t', ps ++ ps')-  where (t', ps') = nlzP [] t-nlzP ps t@(RApp _ _ _ _)- = (t, ps)-nlzP ps (RAllS _ t)- = (t, ps)-nlzP ps (RAllP p t)- = (t', [p] ++ ps ++ ps')-  where (t', ps') = nlzP [] t-nlzP ps t@(REx _ _ _)- = (t, ps)-nlzP ps t@(RRTy _ _ _ t')- = (t, ps ++ ps')- where ps' = snd $ nlzP [] t'-nlzP ps t@(RAllE _ _ _)- = (t, ps)-nlzP _ t- = errorstar $ "RefType.nlzP: cannot handle " ++ show t---strengthenRefTypeGen, strengthenRefType ::-         ( RefTypable c tv ()-         , RefTypable c tv r-         , PPrint (RType c tv r)-         , FreeVar c tv-         , SubsTy tv (RType c tv ()) (RType c tv ())-         , SubsTy tv (RType c tv ()) c-         ) => RType c tv r -> RType c tv r -> RType c tv r-strengthenRefType_ ::-         ( RefTypable c tv ()-         , RefTypable c tv r-         , PPrint (RType c tv r)-         , FreeVar c tv-         , SubsTy tv (RType c tv ()) (RType c tv ())-         , SubsTy tv (RType c tv ()) c-         ) => (RType c tv r -> RType c tv r -> RType c tv r)-           ->  RType c tv r -> RType c tv r -> RType c tv r--strengthenRefTypeGen t1 t2 = strengthenRefType_ f t1 t2-  where-    f (RVar v1 r1) t  = RVar v1 (r1 `meet` fromMaybe mempty (stripRTypeBase t))-    f t (RVar v1 r1)  = RVar v1 (r1 `meet` fromMaybe mempty (stripRTypeBase t))-    f t1 t2           = error $ printf "strengthenRefTypeGen on differently shaped types \nt1 = %s [shape = %s]\nt2 = %s [shape = %s]"-                         (showpp t1) (showpp (toRSort t1)) (showpp t2) (showpp (toRSort t2))----- NEWISH: with unifying type variables: causes big problems with TUPLES?---strengthenRefType t1 t2 = maybe (errorstar msg) (strengthenRefType_ t1) (unifyShape t1 t2)---  where msg = printf "strengthen on differently shaped reftypes \nt1 = %s [shape = %s]\nt2 = %s [shape = %s]"---                 (render t1) (render (toRSort t1)) (render t2) (render (toRSort t2))---- OLD: without unifying type variables, but checking α-equivalence-strengthenRefType t1 t2-  | eqt t1 t2-  = strengthenRefType_ (\x _ -> x) t1 t2-  | otherwise-  = errorstar msg-  where-    eqt t1 t2 = {- render -} toRSort t1 == {- render -} toRSort t2-    msg       = printf "strengthen on differently shaped reftypes \nt1 = %s [shape = %s]\nt2 = %s [shape = %s]"-                  (showpp t1) (showpp (toRSort t1)) (showpp t2) (showpp (toRSort t2))---strengthenRefType_ f (RAllT a1 t1) (RAllT a2 t2)-  = RAllT a1 $ strengthenRefType_ f t1 (subsTyVar_meet (a2, toRSort t, t) t2)-  where t = RVar a1 mempty--strengthenRefType_ f (RAllT a t1) t2-  = RAllT a $ strengthenRefType_ f t1 t2--strengthenRefType_ f t1 (RAllT a t2)-  = RAllT a $ strengthenRefType_ f t1 t2--strengthenRefType_ f (RAllP p1 t1) (RAllP _ t2)-  = RAllP p1 $ strengthenRefType_ f t1 t2--strengthenRefType_ f (RAllP p t1) t2-  = RAllP p $ strengthenRefType_ f t1 t2--strengthenRefType_ f t1 (RAllP p t2)-  = RAllP p $ strengthenRefType_ f t1 t2--strengthenRefType_ f (RAllS s t1) t2-  = RAllS s $ strengthenRefType_ f t1 t2--strengthenRefType_ f t1 (RAllS s t2)-  = RAllS s $ strengthenRefType_ f t1 t2--strengthenRefType_ f (RAllE x tx t1) (RAllE y ty t2) | x == y-  = RAllE x (strengthenRefType_ f tx ty) $ strengthenRefType_ f t1 t2--strengthenRefType_ f (RAllE x tx t1) t2-  = RAllE x tx $ strengthenRefType_ f t1 t2--strengthenRefType_ f t1 (RAllE x tx t2)-  = RAllE x tx $ strengthenRefType_ f t1 t2--strengthenRefType_ f (RAppTy t1 t1' r1) (RAppTy t2 t2' r2)-  = RAppTy t t' (r1 `meet` r2)-    where t  = strengthenRefType_ f t1 t2-          t' = strengthenRefType_ f t1' t2'--strengthenRefType_ f (RFun x1 t1 t1' r1) (RFun x2 t2 t2' r2)-  = RFun x2 t t' (r1 `meet` r2)-    where t  = strengthenRefType_ f t1 t2-          t' = strengthenRefType_ f (subst1 t1' (x1, EVar x2)) t2'--strengthenRefType_ f (RApp tid t1s rs1 r1) (RApp _ t2s rs2 r2)-  = RApp tid ts rs (r1 `meet` r2)-    where ts  = zipWith (strengthenRefType_ f) t1s t2s-          rs  = meets rs1 rs2---strengthenRefType_ _ (RVar v1 r1)  (RVar v2 r2) | v1 == v2-  = RVar v1 (r1 `meet` r2)-strengthenRefType_ f t1 t2-  = f t1 t2--meets :: (F.Reftable r) => [r] -> [r] -> [r]-meets [] rs                 = rs-meets rs []                 = rs-meets rs rs'-  | length rs == length rs' = zipWith meet rs rs'-  | otherwise               = errorstar "meets: unbalanced rs"---strengthen :: Reftable r => RType c tv r -> r -> RType c tv r-strengthen (RApp c ts rs r) r'  = RApp c ts rs (r `meet` r')-strengthen (RVar a r) r'        = RVar a       (r `meet` r')-strengthen (RFun b t1 t2 r) r'  = RFun b t1 t2 (r `meet` r')-strengthen (RAppTy t1 t2 r) r'  = RAppTy t1 t2 (r `meet` r')-strengthen t _                  = t------------------------------------------------------------------------------addTyConInfo :: (PPrint r, Reftable r)-             => (M.HashMap TyCon FTycon)-             -> (M.HashMap TyCon RTyCon)-             -> RRType r-             -> RRType r---------------------------------------------------------------------------addTyConInfo tce tyi = mapBot (expandRApp tce tyi)----------------------------------------------------------------------------expandRApp :: (PPrint r, Reftable r)-           => (M.HashMap TyCon FTycon)-           -> (M.HashMap TyCon RTyCon)-           -> RRType r-           -> RRType r---------------------------------------------------------------------------expandRApp tce tyi t@(RApp {}) = RApp rc' ts rs' r-  where-    RApp rc ts rs r            = t-    rc'                        = appRTyCon tce tyi rc as-    pvs                        = rTyConPVs rc'-    rs'                        = applyNonNull rs0 (rtPropPV rc pvs) rs-    rs0                        = rtPropTop <$> pvs-    n                          = length fVs-    fVs                        = tyConTyVarsDef $ rtc_tc rc-    as                         = choosen n ts (rVar <$> fVs)--    choosen 0 _ _           = []-    choosen i (x:xs) (_:ys) = x:choosen (i-1) xs ys-    choosen i []     (y:ys) = y:choosen (i-1) [] ys-    choosen _ _ _           = errorstar "choosen: this cannot happen"--expandRApp _ _ t               = t--rtPropTop pv = case ptype pv of-                 PVProp t -> RProp xts $ ofRSort t-                 PVHProp  -> RProp xts $ mempty-               where-                 xts      =  pvArgs pv--rtPropPV rc = safeZipWith msg mkRTProp-  where-    msg     = "appRefts: " ++ showFix rc--mkRTProp pv (RPropP ss r)-  = RProp ss $ (ofRSort $ pvType pv) `strengthen` r--mkRTProp pv (RProp ss t)-  | length (pargs pv) == length ss-  = RProp ss t-  | otherwise-  = RProp (pvArgs pv) t--mkRTProp pv (RHProp ss w)-  | length (pargs pv) == length ss-  = RHProp ss w-  | otherwise-  = RHProp (pvArgs pv) w--pvArgs pv = [(s, t) | (t, s, _) <- pargs pv]---appRTyCon tce tyi rc ts = RTyCon c ps' (rtc_info rc'')-  where-    c    = rtc_tc rc-    ps'  = subts (zip (RTV <$> αs) ts') <$> rTyConPVs rc'-    ts'  = if null ts then rVar <$> βs else toRSort <$> ts-    rc'  = M.lookupDefault rc c tyi-    αs   = tyConTyVarsDef $ rtc_tc rc'-    βs   = tyConTyVarsDef c-    rc'' = if isNumeric tce rc' then addNumSizeFun rc' else rc'----- RJ: The code of `isNumeric` is incomprehensible.--- Please fix it to use intSort instead of intFTyCon-isNumeric tce c-  =  fromMaybe-       (symbolFTycon . dummyLoc $ tyConName (rtc_tc c))-       (M.lookup (rtc_tc c) tce) == F.intFTyCon--addNumSizeFun c-  = c {rtc_info = (rtc_info c) {sizeFunction = Just EVar} }---generalize :: (RefTypable c tv r) => RType c tv r -> RType c tv r-generalize t = mkUnivs (freeTyVars t) [] [] t--freeTyVars (RAllP _ t)     = freeTyVars t-freeTyVars (RAllS _ t)     = freeTyVars t-freeTyVars (RAllT α t)     = freeTyVars t L.\\ [α]-freeTyVars (RFun _ t t' _) = freeTyVars t `L.union` freeTyVars t'-freeTyVars (RApp _ ts _ _) = L.nub $ concatMap freeTyVars ts-freeTyVars (RVar α _)      = [α]-freeTyVars (RAllE _ tx t)  = freeTyVars tx `L.union` freeTyVars t-freeTyVars (REx _ tx t)    = freeTyVars tx `L.union` freeTyVars t-freeTyVars (RExprArg _)    = []-freeTyVars (RAppTy t t' _) = freeTyVars t `L.union` freeTyVars t'-freeTyVars (RHole _)       = []-freeTyVars (RRTy e _ _ t)  = L.nub $ concatMap freeTyVars (t:(snd <$> e))---tyClasses (RAllP _ t)     = tyClasses t-tyClasses (RAllS _ t)     = tyClasses t-tyClasses (RAllT _ t)     = tyClasses t-tyClasses (RAllE _ _ t)   = tyClasses t-tyClasses (REx _ _ t)     = tyClasses t-tyClasses (RFun _ t t' _) = tyClasses t ++ tyClasses t'-tyClasses (RAppTy t t' _) = tyClasses t ++ tyClasses t'-tyClasses (RApp c ts _ _)-  | Just cl <- tyConClass_maybe $ rtc_tc c-  = [(cl, ts)]-  | otherwise-  = []-tyClasses (RVar _ _)      = []-tyClasses (RRTy _ _ _ t)  = tyClasses t-tyClasses (RHole _)       = []-tyClasses t               = errorstar ("RefType.tyClasses cannot handle" ++ show t)------------------------------------------------------------------------------------------ Strictness -------------------------------------------------------------------------------------------------instance (NFData a, NFData b, NFData t) => NFData (Ref t a b) where-  rnf (RPropP s a) = rnf s `seq` rnf a-  rnf (RProp  s b) = rnf s `seq` rnf b-  rnf (RHProp _ _) = errorstar "TODO RHProp.rnf"--instance (NFData b, NFData c, NFData e) => NFData (RType b c e) where-  rnf (RVar α r)       = rnf α `seq` rnf r-  rnf (RAllT α t)      = rnf α `seq` rnf t-  rnf (RAllP π t)      = rnf π `seq` rnf t-  rnf (RAllS s t)      = rnf s `seq` rnf t-  rnf (RFun x t t' r)  = rnf x `seq` rnf t `seq` rnf t' `seq` rnf r-  rnf (RApp _ ts rs r) = rnf ts `seq` rnf rs `seq` rnf r-  rnf (RAllE x t t')   = rnf x `seq` rnf t `seq` rnf t'-  rnf (REx x t t')     = rnf x `seq` rnf t `seq` rnf t'-  rnf (RExprArg e)     = rnf e-  rnf (RAppTy t t' r)  = rnf t `seq` rnf t' `seq` rnf r-  rnf (RRTy _ r _ t)   = rnf r `seq` rnf t-  rnf (RHole r)        = rnf r------------------------------------------------------------------------------------- Printing Refinement Types --------------------------------------------------------------------------------------instance Show RTyVar where-  show = showpp--instance PPrint (UReft r) => Show (UReft r) where-  show = showpp--instance (RefTypable c tv r) => PPrint (RType c tv r) where-  pprint = ppRType TopPrec--instance PPrint (RType c tv r) => Show (RType c tv r) where-  show = showpp--instance PPrint (RTProp c tv r) => Show (RTProp c tv r) where-  show = showpp--instance PPrint REnv where-  pprint (REnv m)  = pprint m----------------------------------------------------------------------------------------------- TODO: Rewrite subsTyvars with Traversable---------------------------------------------------------------------------------------------subsTyVars_meet       = subsTyVars True-subsTyVars_nomeet     = subsTyVars False-subsTyVar_nomeet      = subsTyVar False-subsTyVar_meet        = subsTyVar True-subsTyVars meet ats t = foldl' (flip (subsTyVar meet)) t ats-subsTyVar meet        = subsFree meet S.empty--subsFree m s z (RAllS l t)-  = RAllS l (subsFree m s z t)-subsFree m s z@(α, τ,_) (RAllP π t)-  = RAllP (subt (α, τ) π) (subsFree m s z t)-subsFree m s z (RAllT α t)-  = RAllT α $ subsFree m (α `S.insert` s) z t-subsFree m s z@(_, _, _) (RFun x t t' r)-  = RFun x (subsFree m s z t) (subsFree m s z t') r-subsFree m s z@(α, τ, _) (RApp c ts rs r)-  = RApp (subt z' c) (subsFree m s z <$> ts) (subsFreeRef m s z <$> rs) r-    where z' = (α, τ) -- UNIFY: why instantiating INSIDE parameters?-subsFree meet s (α', _, t') t@(RVar α r)-  | α == α' && not (α `S.member` s)-  = if meet then t' `strengthen` r else t'-  | otherwise-  = t-subsFree m s z (RAllE x t t')-  = RAllE x (subsFree m s z t) (subsFree m s z t')-subsFree m s z (REx x t t')-  = REx x (subsFree m s z t) (subsFree m s z t')-subsFree m s z@(_, _, _) (RAppTy t t' r)-  = subsFreeRAppTy m s (subsFree m s z t) (subsFree m s z t') r-subsFree _ _ _ t@(RExprArg _)-  = t-subsFree m s z (RRTy e r o t)-  = RRTy (mapSnd (subsFree m s z) <$> e) r o (subsFree m s z t)-subsFree _ _ _ t@(RHole _)-  = t--subsFrees m s zs t = foldl' (flip(subsFree m s)) t zs---- GHC INVARIANT: RApp is Type Application to something other than TYCon-subsFreeRAppTy m s (RApp c ts rs r) t' r'-  = mkRApp m s c (ts ++ [t']) rs r r'-subsFreeRAppTy _ _ t t' r'-  = RAppTy t t' r'--mkRApp m s c ts rs r r'-  | isFun c, [t1, t2] <- ts-  = RFun dummySymbol t1 t2 $ refAppTyToFun r'-  | otherwise-  = subsFrees m s zs $ RApp c ts rs $ r `meet` r' -- (refAppTyToApp r')-  where-    zs = [(tv, toRSort t, t) | (tv, t) <- zip (freeVars c) ts]--refAppTyToFun r-  | isTauto r = r-  | otherwise = errorstar "RefType.refAppTyToFun"--subsFreeRef m s (α', τ', t')  (RProp ss t)-  = RProp (mapSnd (subt (α', τ')) <$> ss) $ subsFree m s (α', τ', fmap top t') t-subsFreeRef _ _ (α', τ', _) (RPropP ss r)-  = RPropP (mapSnd (subt (α', τ')) <$> ss) r-subsFreeRef _ _ _ (RHProp _ _)-  = errorstar "TODO RHProp.subsFreeRef"----------------------------------------------------------------------------------------- Type Substitutions --------------------------------------------------------------------------------------------------subts = flip (foldr subt)--instance SubsTy tv ty ()   where-  subt _ = id--instance SubsTy tv ty Reft where-  subt _ = id--instance (SubsTy tv ty ty) => SubsTy tv ty (PVKind ty) where-  subt su (PVProp t) = PVProp (subt su t)-  subt _   PVHProp   = PVHProp--instance (SubsTy tv ty ty) => SubsTy tv ty (PVar ty) where-  subt su (PV n t v xts) = PV n (subt su t) v [(subt su t, x, y) | (t,x,y) <- xts]--instance SubsTy RTyVar RSort RTyCon where-   subt z c = RTyCon tc ps' i-     where-       tc   = rtc_tc c-       ps'  = subt z <$> rTyConPVs c-       i    = rtc_info c---- NOTE: This DOES NOT substitute at the binders-instance SubsTy RTyVar RSort PrType where-  subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ)--instance SubsTy RTyVar RSort SpecType where-  subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ)--instance SubsTy RTyVar RTyVar SpecType where-  subt (α, a) = subt (α, RVar a () :: RSort)---instance SubsTy RTyVar RSort RSort where-  subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ)---- Here the "String" is a Bare-TyCon. TODO: wrap in newtype-instance SubsTy Symbol BSort LocSymbol where-  subt _ t = t--instance SubsTy Symbol BSort BSort where-  subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ)--instance (SubsTy tv ty (UReft r), SubsTy tv ty (RType c tv ())) => SubsTy tv ty (RTProp c tv (UReft r))  where-  subt m (RPropP ss p) = RPropP ((mapSnd (subt m)) <$> ss) $ subt m p-  subt m (RProp  ss t) = RProp ((mapSnd (subt m)) <$> ss) $ fmap (subt m) t-  subt _ (RHProp _  _) = errorstar "TODO: RHProp.subt"--subvUReft     :: (UsedPVar -> UsedPVar) -> UReft Reft -> UReft Reft-subvUReft f (U r p s) = U r (subvPredicate f p) s--subvPredicate :: (UsedPVar -> UsedPVar) -> Predicate -> Predicate-subvPredicate f (Pr pvs) = Pr (f <$> pvs)-------------------------------------------------------------------ofType = ofType_ . expandTypeSynonyms--ofType_ (TyVarTy α)-  = rVar α-ofType_ (FunTy τ τ')-  = rFun dummySymbol (ofType_ τ) (ofType_ τ')-ofType_ (ForAllTy α τ)-  = RAllT (rTyVar α) $ ofType_ τ-ofType_ (TyConApp c τs)-  | Just (αs, τ) <- TC.synTyConDefn_maybe c-  = ofType_ $ substTyWith αs τs τ-  | otherwise-  = rApp c (ofType_ <$> τs) [] mempty-ofType_ (AppTy t1 t2)-  = RAppTy (ofType_ t1) (ofType t2) mempty-ofType_ (LitTy x)-  = fromTyLit x-  where-    fromTyLit (NumTyLit _) = rApp intTyCon [] [] mempty-    fromTyLit (StrTyLit _) = rApp listTyCon [rApp charTyCon [] [] mempty] [] mempty-------------------------------------------------------------------------------------- Converting to Fixpoint -----------------------------------------------------------------------------------------instance Expression Var where-  expr   = eVar--dataConSymbol ::  DataCon -> Symbol-dataConSymbol = symbol . dataConWorkId---- TODO: turn this into a map lookup?-dataConReft ::  DataCon -> [Symbol] -> Reft-dataConReft c []-  | c == trueDataCon-  = predReft $ eProp vv_-  | c == falseDataCon-  = predReft $ PNot $ eProp vv_--dataConReft c [x]-  | c == intDataCon-  = symbolReft x -- OLD (vv_, [RConc (PAtom Eq (EVar vv_) (EVar x))])-dataConReft c _-  | not $ isBaseDataCon c-  = mempty-dataConReft c xs-  = exprReft dcValue -- OLD Reft (vv_, [RConc (PAtom Eq (EVar vv_) dcValue)])-  where-    dcValue-      | null xs && null (dataConUnivTyVars c)-      = EVar $ dataConSymbol c-      | otherwise-      = EApp (dummyLoc $ dataConSymbol c) (eVar <$> xs)--isBaseDataCon c = and $ isBaseTy <$> dataConOrigArgTys c ++ dataConRepArgTys c--isBaseTy (TyVarTy _)     = True-isBaseTy (AppTy _ _)     = False-isBaseTy (TyConApp _ ts) = and $ isBaseTy <$> ts-isBaseTy (FunTy _ _)     = False-isBaseTy (ForAllTy _ _)  = False-isBaseTy (LitTy _)       = True---dataConMsReft ty ys  = subst su (rTypeReft (ignoreOblig $ ty_res trep))-  where-    trep = toRTypeRep ty-    xs   = ty_binds trep-    ts   = ty_args  trep-    su   = mkSubst $ [(x, EVar y) | ((x, _), y) <- zip (zip xs ts) ys]---------------------------------------------------------------------------------------- Embedding RefTypes ---------------------------------------------------------------------------------------- TODO: remove toType, generalize typeSort-toType  :: (Reftable r, PPrint r) => RRType r -> Type-toType (RFun _ t t' _)-  = FunTy (toType t) (toType t')-toType (RAllT (RTV α) t)-  = ForAllTy α (toType t)-toType (RAllP _ t)-  = toType t-toType (RAllS _ t)-  = toType t-toType (RVar (RTV α) _)-  = TyVarTy α-toType (RApp (RTyCon {rtc_tc = c}) ts _ _)-  = TyConApp c (toType <$> filter notExprArg ts)-  where-  notExprArg (RExprArg _) = False-  notExprArg _            = True-toType (RAllE _ _ t)-  = toType t-toType (REx _ _ t)-  = toType t-toType (RAppTy t (RExprArg _) _)-  = toType t-toType (RAppTy t t' _)-  = AppTy (toType t) (toType t')-toType t@(RExprArg _)-  = errorstar $ "CANNOT HAPPEN: RefType.toType called with: " ++ show t-toType (RRTy _ _ _ t)-  = toType t-toType t-  = errorstar $ "RefType.toType cannot handle: " ++ show t----------------------------------------------------------------------------------- Annotations and Solutions --------------------------------------------------------------------------------------rTypeSortedReft       ::  (PPrint r, Reftable r) => TCEmb TyCon -> RRType r -> SortedReft-rTypeSortedReft emb t = RR (rTypeSort emb t) (rTypeReft t)--rTypeSort     ::  (PPrint r, Reftable r) => TCEmb TyCon -> RRType r -> Sort-rTypeSort tce = typeSort tce . toType----------------------------------------------------------------------------------applySolution :: (Functor f) => FixSolution -> f SpecType -> f SpecType---------------------------------------------------------------------------------applySolution = fmap . fmap . mapReft . appSolRefa-  where-    mapReft f (U (Reft (x, z)) p s) = U (Reft (x, f z)) p s--- OLD    appSolRefa _ ra@(RConc _)        = ra--- OLD    appSolRefa s (RKvar k su)        = RConc $ subst su $ M.lookupDefault PTop k s--appSolRefa s (Refa p) = Refa $ mapKVars f p-  where-    f k               = Just $ M.lookupDefault PTop k s----------------------------------------------------------------------------------shiftVV :: SpecType -> Symbol -> SpecType----------------------------------------------------------------------------------shiftVV t@(RApp _ ts _ r) vv'-  = t { rt_args = subst1 ts (rTypeValueVar t, EVar vv') }-      { rt_reft = (`F.shiftVV` vv') <$> r }--shiftVV t@(RFun _ _ _ r) vv'-  = t { rt_reft = (`F.shiftVV` vv') <$> r }--shiftVV t@(RAppTy _ _ r) vv'-  = t { rt_reft = (`F.shiftVV` vv') <$> r }--shiftVV t@(RVar _ r) vv'-  = t { rt_reft = (`F.shiftVV` vv') <$> r }--shiftVV t _-  = t -- errorstar $ "shiftVV: cannot handle " ++ showpp t-------------------------------------------------------------------------------------------- Auxiliary Stuff Used Elsewhere ----------------------------------------------------------------------------------------------------- MOVE TO TYPES-instance (Show tv, Show ty) => Show (RTAlias tv ty) where-  show (RTA n as xs t p _) =-    printf "type %s %s %s = %s -- defined at %s" (symbolString n)-      (L.intercalate " " (show <$> as))-      (L.intercalate " " (show <$> xs))-      (show t) (show p)------------------------------------------------------------------------------- From Old Fixpoint ----------------------------------------------------------------------------------------------------typeUniqueSymbol :: Type -> Symbol-typeUniqueSymbol = symbol . typeUniqueString--typeSort :: TCEmb TyCon -> Type -> Sort-typeSort tce τ@(ForAllTy _ _)-  = typeSortForAll tce τ-typeSort tce t@(FunTy _ _)-  = typeSortFun tce t-typeSort tce (TyConApp c τs)-  = fApp (Left $ tyConFTyCon tce c) (typeSort tce <$> τs)-typeSort tce (AppTy t1 t2)-  = fApp (Right $ typeSort tce t1) [typeSort tce t2]-typeSort _ τ-  = FObj $ typeUniqueSymbol τ--tyConFTyCon tce c    = fromMaybe (symbolFTycon $ dummyLoc $ tyConName c) (M.lookup c tce)--typeSortForAll tce τ-  = genSort $ typeSort tce tbody-  where genSort (FFunc _ t) = FFunc n (sortSubst su <$> t)-        genSort t           = FFunc n [sortSubst su t]-        (as, tbody)         = splitForAllTys τ-        su                  = M.fromList $ zip sas (FVar <$>  [0..])-        sas                 = (typeUniqueSymbol . TyVarTy) <$> as-        n                   = length as--tyConName c-  | listTyCon == c    = listConName-  | TC.isTupleTyCon c = tupConName-  | otherwise         = symbol c--typeSortFun tce t -- τ1 τ2-  = FFunc 0  sos-  where sos  = typeSort tce <$> τs-        τs   = grabArgs [] t-grabArgs τs (FunTy τ1 τ2 )-  | not $ isClassPred τ1 = grabArgs (τ1:τs) τ2-  | otherwise            = grabArgs τs τ2-grabArgs τs τ              = reverse (τ:τs)---mkDataConIdsTy (dc, t) = [expandProductType id t | id <- dataConImplicitIds dc]--expandProductType x t-  | ofType (varType x) == toRSort t = (x, t)-  | otherwise                       = (x, t')-     where t'         = fromRTypeRep $ trep {ty_binds = xs', ty_args = ts', ty_refts = rs'}-           τs         = fst $ splitFunTys $ toType t-           trep       = toRTypeRep t-           (xs', ts', rs') = unzip3 $ concatMap mkProductTy $ zip4 τs (ty_binds trep) (ty_args trep) (ty_refts trep)--mkProductTy (τ, x, t, r) = maybe [(x, t, r)] f $ deepSplitProductType_maybe menv τ-  where f    = ((<$>) ((dummySymbol, , mempty) . ofType)) . third4-        menv = (emptyFamInstEnv, emptyFamInstEnv)---------------------------------------------------------------------------------------------- | Binders generated by class predicates, typically for constraining tyvars (e.g. FNum)--------------------------------------------------------------------------------------------classBinds (RApp c ts _ _)-   | isFracCls c-   = [(rTyVarSymbol a, trueSortedReft FFrac) | (RVar a _) <- ts]-   | isNumCls c-   = [(rTyVarSymbol a, trueSortedReft FNum) | (RVar a _) <- ts]-classBinds _-  = []--rTyVarSymbol (RTV α) = typeUniqueSymbol $ TyVarTy α----------------------------------------------------------------------------------------------------------------------- Termination Predicates ----------------------------------------------------------------------------------------------------------------------------------makeNumEnv = concatMap go-  where-    go (RApp c ts _ _) | isNumCls c || isFracCls c = [ a | (RVar a _) <- ts]-    go _ = []--isDecreasing autoenv  _ (RApp c _ _ _)-  =  isJust (sizeFunction (rtc_info c)) -- user specified size or-  || isSizeable autoenv tc-  where tc = rtc_tc c-isDecreasing _ cenv (RVar v _)-  = v `elem` cenv-isDecreasing _ _ _-  = False--makeDecrType autoenv = mkDType autoenv [] []--mkDType autoenv xvs acc [(v, (x, t))]-  = (x, ) $ t `strengthen` tr-  where-    tr = uTop $ Reft (vv, Refa $ pOr (r:acc))-    r  = cmpLexRef xvs (v', vv, f)-    v' = symbol v-    f  = mkDecrFun autoenv  t-    vv = "vvRec"--mkDType autoenv xvs acc ((v, (x, t)):vxts)-  = mkDType autoenv ((v', x, f):xvs) (r:acc) vxts-  where-    r  = cmpLexRef xvs  (v', x, f)-    v' = symbol v-    f  = mkDecrFun autoenv t---mkDType _ _ _ _-  = errorstar "RefType.mkDType called on invalid input"--isSizeable  :: S.HashSet TyCon -> TyCon -> Bool-isSizeable autoenv tc =  S.member tc autoenv --   TC.isAlgTyCon tc -- && TC.isRecursiveTyCon tc--mkDecrFun autoenv (RApp c _ _ _)-  | Just f <- sizeFunction $ rtc_info c-  = f-  | isSizeable autoenv $ rtc_tc c-  = \v -> F.EApp lenLocSymbol [F.EVar v]-mkDecrFun _ (RVar _ _)-  = EVar-mkDecrFun _ _-  = errorstar "RefType.mkDecrFun called on invalid input"--cmpLexRef vxs (v, x, g)-  = pAnd $  (PAtom Lt (g x) (g v)) : (PAtom Ge (g x) zero)-         :  [PAtom Eq (f y) (f z) | (y, z, f) <- vxs]-         ++ [PAtom Ge (f y) zero  | (y, _, f) <- vxs]-  where zero = ECon $ I 0--makeLexRefa es' es = uTop $ Reft (vv, Refa $ PIff (PBexp $ EVar vv) $ pOr rs)-  where-    rs = makeLexReft [] [] es es'-    vv = "vvRec"--makeLexReft _ acc [] []-  = acc-makeLexReft old acc (e:es) (e':es')-  = makeLexReft ((e,e'):old) (r:acc) es es'-  where-    r    = pAnd $  (PAtom Lt e' e)-                :  (PAtom Ge e' zero)-                :  [PAtom Eq o' o    | (o,o') <- old]-                ++ [PAtom Ge o' zero | (_,o') <- old]-    zero = ECon $ I 0-makeLexReft _ _ _ _-  = errorstar "RefType.makeLexReft on invalid input"-----------------------------------------------------------------------------------mkTyConInfo :: TyCon -> VarianceInfo -> VarianceInfo -> (Maybe (Symbol -> Expr)) -> TyConInfo--mkTyConInfo c usertyvar userprvariance f-  = TyConInfo (if null usertyvar then defaulttyvar else usertyvar) userprvariance f-  where-        defaulttyvar      = varSignToVariance <$> [0 ..n]--        varSignToVariance i = case filter (\p -> fst p == i) varsigns of-                                []       -> Invariant-                                [(_, b)] -> if b then Covariant else Contravariant-                                _        -> Bivariant--        varsigns  = L.nub $ concatMap goDCon $ TC.tyConDataCons c-        initmap   = zip (showPpr <$> tyvars) [0..n]-        mkmap vs  = zip (showPpr <$> vs) (repeat dindex) ++ initmap-        goDCon dc = concatMap (go (mkmap (DataCon.dataConExTyVars dc)) True) (DataCon.dataConOrigArgTys dc)-        go m pos (ForAllTy v t)  = go ((showPpr v, dindex):m) pos t-        go m pos (TyVarTy v)     = [(varLookup (showPpr v) m, pos)]-        go m pos (AppTy t1 t2)   = go m pos t1 ++ go m pos t2-        go m pos (TyConApp _ ts) = concatMap (go m pos) ts-        go m pos (FunTy t1 t2)   = go m (not pos) t1 ++ go m pos t2-        go _ _   (LitTy _)       = []--        varLookup v m = fromMaybe (errmsg v) $ L.lookup v m-        tyvars        = tyConTyVarsDef c-        n             = (TC.tyConArity c) - 1-        errmsg v      = error $ "GhcMisc.getTyConInfo: var not found" ++ showPpr v-        dindex        = -1
− src/Language/Haskell/Liquid/Simplify.hs 
@@ -1,42 +0,0 @@-module Language.Haskell.Liquid.Simplify (simplifyBounds) where--import Language.Haskell.Liquid.Types-import Language.Fixpoint.Types-import Language.Fixpoint.Visitor--- import Control.Applicative                 ((<$>))-import Data.Monoid--simplifyBounds :: SpecType -> SpecType-simplifyBounds = fmap go-  where-    go x       = x { ur_reft = go' $ ur_reft x }-    -- OLD go' (Reft (v, rs)) = Reft(v, filter (not . isBoundLike) rs)-    go' (Reft (v, Refa p)) = Reft(v, Refa $ dropBoundLike p)--dropBoundLike :: Pred -> Pred-dropBoundLike p-  | isKvar p          = p-  | isBoundLikePred p = mempty-  | otherwise         = p-  where-    isKvar            = not . null . kvars--isBoundLikePred :: Pred -> Bool-isBoundLikePred (PAnd ps) = simplifyLen <= length [p | p <- ps, isImp p ]-isBoundLikePred _         = False--isImp :: Pred -> Bool-isImp (PImp _ _) = True-isImp _          = False---- OLD isBoundLike (RConc pred)  = isBoundLikePred pred--- OLD isBoundLike (RKvar _ _)   = False----- OLD moreThan 0 _            = True--- OLD moreThan _ []           = False--- OLD moreThan i (True  : xs) = moreThan (i-1) xs--- OLD moreThan i (False : xs) = moreThan i xs--simplifyLen :: Int-simplifyLen = 5
− src/Language/Haskell/Liquid/Strata.hs 
@@ -1,70 +0,0 @@-{-# LANGUAGE TypeSynonymInstances      #-}-{-# LANGUAGE FlexibleInstances         #-}--module Language.Haskell.Liquid.Strata (-    SubStratum(..)-  , solveStrata-  , (<:=)-  ) where--import Control.Applicative      ((<$>))--import Language.Fixpoint.Types (Symbol)-import Language.Haskell.Liquid.Types hiding (Def, Loc)--s1 <:= s2 -  | any (==SDiv) s1 && any (==SFin) s2 = False-  | otherwise                          = True--solveStrata = go True [] [] -  where go False solved _   [] = solved-        go True  solved acc [] = go False solved [] $ {-traceShow ("OLD \n" ++ showMap solved acc ) $ -} subsS solved <$> acc-        go mod   solved acc (([], _):ls) = go mod solved acc ls-        go mod   solved acc ((_, []):ls) = go mod solved acc ls-        go mod   solved acc (l:ls) | allSVars l  = go mod solved (l:acc) ls-                                   | noSVar   l  = go mod solved acc ls -                                   | noUpdate l  = go mod solved (l:acc) ls -                                   | otherwise   = go True (solve l ++ solved) (l:acc) ls ---allSVars (xs, ys) = all isSVar $ xs ++ ys-noSVar   (xs, ys) = all (not . isSVar) (xs ++ ys)-noUpdate (xs, ys) = (not $ updateFin(xs, ys)) && (not $ updateDiv (xs, ys)) --updateFin (xs, ys) = any (==SFin) ys && any isSVar   xs-updateDiv (xs, ys) = any isSVar   ys && any (==SDiv) xs--solve (xs, ys) -  | any (== SDiv) xs = [(l, SDiv) | SVar l <- ys] -  | any (== SFin) ys = [(l, SFin) | SVar l <- xs] -  | otherwise        = []---class SubStratum a where-  subS  :: (Symbol, Stratum) -> a -> a-  subsS :: [(Symbol, Stratum)] -> a -> a--  subsS su x = foldr subS x su--instance SubStratum Stratum where-  subS (x, s) (SVar y) | x == y    = s-                       | otherwise = (SVar y)-  subS _      s        = s---instance (SubStratum a, SubStratum b) => SubStratum (a, b) where-  subS su (x, y) = (subS su x, subS su y)--instance (SubStratum a) => SubStratum [a] where-  subS su xs = subS su <$> xs--instance SubStratum (Annot SpecType) where-  subS su (AnnUse t) = AnnUse $ subS su t-  subS su (AnnDef t) = AnnDef $ subS su t-  subS su (AnnRDf t) = AnnRDf $ subS su t-  subS _  (AnnLoc s) = AnnLoc s--instance SubStratum SpecType where-  subS su t = (\r -> r {ur_strata = subS su (ur_strata r)}) <$> t--
− src/Language/Haskell/Liquid/Tidy.hs 
@@ -1,141 +0,0 @@-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE OverloadedStrings #-}------------------------------------------------------------------------- | This module contains functions for cleaning up types before---   they are rendered, e.g. in error messages or annoations.-------------------------------------------------------------------------module Language.Haskell.Liquid.Tidy (--    -- * Tidying functions-    tidySpecType-  , tidySymbol--    -- * Tidyness tests-  , isTmpSymbol-  ) where--import Control.Applicative-import qualified Data.HashMap.Strict as M-import qualified Data.HashSet        as S-import qualified Data.List           as L-import qualified Data.Text           as T--import Language.Fixpoint.Names              (symSepName, isPrefixOfSym, takeWhileSym)-import Language.Fixpoint.Types-import Language.Haskell.Liquid.GhcMisc      (stringTyVar)-import Language.Haskell.Liquid.Types-import Language.Haskell.Liquid.RefType hiding (shiftVV)----------------------------------------------------------------------------tidySymbol :: Symbol -> Symbol---------------------------------------------------------------------------tidySymbol = takeWhileSym (/= symSepName)-----------------------------------------------------------------------------isTmpSymbol    :: Symbol -> Bool---------------------------------------------------------------------------isTmpSymbol x  = any (`isPrefixOfSym` x) [anfPrefix, tempPrefix, "ds_"]-----------------------------------------------------------------------------tidySpecType :: Tidy -> SpecType -> SpecType---------------------------------------------------------------------------tidySpecType k = tidyValueVars-               . tidyDSymbols-               . tidySymbols-               . tidyLocalRefas k-               . tidyFunBinds-               . tidyTyVars--tidyValueVars :: SpecType -> SpecType-tidyValueVars = mapReft $ \u -> u { ur_reft = tidyVV $ ur_reft u }--tidyVV r@(Reft (va,_))-  | isJunk va = shiftVV r v'-  | otherwise = r-  where-    v'        = if v `elem` xs then symbol ("v'" :: T.Text) else v-    v         = symbol ("v" :: T.Text)-    xs        = syms r-    isJunk    = isPrefixOfSym "x"--tidySymbols :: SpecType -> SpecType-tidySymbols t = substa tidySymbol $ mapBind dropBind t-  where-    xs         = S.fromList (syms t)-    dropBind x = if x `S.member` xs then tidySymbol x else nonSymbol---tidyLocalRefas   :: Tidy -> SpecType -> SpecType-tidyLocalRefas k = mapReft (txStrata . txReft' k)-  where-    txReft' Full                  = id-    txReft' Lossy                 = txReft-    txStrata (U r p l)            = U r p (txStr l)-    txReft u                      = u { ur_reft = mapPredReft dropLocals $ ur_reft u }-    dropLocals                    = pAnd . filter (not . any isTmp . syms) . conjuncts-    isTmp x                       = any (`isPrefixOfSym` x) [anfPrefix, "ds_"]-    txStr                         = filter (not . isSVar)---tidyDSymbols :: SpecType -> SpecType-tidyDSymbols t = mapBind tx $ substa tx t-  where-    tx         = bindersTx [x | x <- syms t, isTmp x]-    isTmp      = (tempPrefix `isPrefixOfSym`)--tidyFunBinds :: SpecType -> SpecType-tidyFunBinds t = mapBind tx $ substa tx t-  where-    tx         = bindersTx $ filter isTmpSymbol $ funBinds t--tidyTyVars :: SpecType -> SpecType-tidyTyVars t = subsTyVarsAll αβs t-  where-    αβs  = zipWith (\α β -> (α, toRSort β, β)) αs βs-    αs   = L.nub (tyVars t)-    βs   = map (rVar . stringTyVar) pool-    pool = [[c] | c <- ['a'..'z']] ++ [ "t" ++ show i | i <- [1..]]---bindersTx ds   = \y -> M.lookupDefault y y m-  where-    m          = M.fromList $ zip ds $ var <$> [1..]-    var        = symbol . ('x' :) . show---tyVars (RAllP _ t)     = tyVars t-tyVars (RAllS _ t)     = tyVars t-tyVars (RAllT α t)     = α : tyVars t-tyVars (RFun _ t t' _) = tyVars t ++ tyVars t'-tyVars (RAppTy t t' _) = tyVars t ++ tyVars t'-tyVars (RApp _ ts _ _) = concatMap tyVars ts-tyVars (RVar α _)      = [α]-tyVars (RAllE _ _ t)   = tyVars t-tyVars (REx _ _ t)     = tyVars t-tyVars (RExprArg _)    = []-tyVars (RRTy _ _ _ t)  = tyVars t-tyVars (RHole _)       = []--subsTyVarsAll ats = go-  where-    abm            = M.fromList [(a, b) | (a, _, (RVar b _)) <- ats]-    go (RAllT a t) = RAllT (M.lookupDefault a a abm) (go t)-    go t           = subsTyVars_meet ats t---funBinds (RAllT _ t)      = funBinds t-funBinds (RAllP _ t)      = funBinds t-funBinds (RAllS _ t)      = funBinds t-funBinds (RFun b t1 t2 _) = b : funBinds t1 ++ funBinds t2-funBinds (RApp _ ts _ _)  = concatMap funBinds ts-funBinds (RAllE b t1 t2)  = b : funBinds t1 ++ funBinds t2-funBinds (REx b t1 t2)    = b : funBinds t1 ++ funBinds t2-funBinds (RVar _ _)       = []-funBinds (RRTy _ _ _ t)   = funBinds t-funBinds (RAppTy t1 t2 _) = funBinds t1 ++ funBinds t2-funBinds (RExprArg _)     = []-funBinds (RHole _)        = []
− src/Language/Haskell/Liquid/TransformRec.hs 
@@ -1,245 +0,0 @@-{-# LANGUAGE DeriveDataTypeable        #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE TypeSynonymInstances      #-}--module Language.Haskell.Liquid.TransformRec (-     transformRecExpr, transformScope-     ) where--import           Bag-import           Coercion-import           Control.Arrow       (second)-import           Control.Monad.State-import           CoreSyn-import           CoreUtils-import qualified Data.HashMap.Strict as M-import           ErrUtils-import           Id                  (idOccInfo, setIdInfo)-import           IdInfo-import           MkCore              (mkCoreLams)-import           SrcLoc-import           Type                (mkForAllTys, splitForAllTys)-import           TypeRep-import           Unique              hiding (deriveUnique)-import           Var-import           Name (isSystemName)-import           Language.Haskell.Liquid.GhcMisc-import           Language.Haskell.Liquid.GhcPlay-import           Language.Haskell.Liquid.Misc (mapSndM)-import           Language.Fixpoint.Misc       (mapSnd)--import           Data.List                (foldl', isInfixOf)-import           Control.Applicative      ((<$>))--import qualified Data.List as L---transformRecExpr :: CoreProgram -> CoreProgram-transformRecExpr cbs-  | isEmptyBag $ filterBag isTypeError e-  =  {-trace "new cbs"-} pg -  | otherwise -  = error ("Type-check" ++ showSDoc (pprMessageBag e))-  where pg0    = evalState (transPg (inlineLoopBreaker <$> cbs)) initEnv-        (_, e) = lintCoreBindings [] pg-        pg     = inlineFailCases pg0-----inlineLoopBreaker (NonRec x e) | Just (lbx, lbe) <- hasLoopBreaker be -  = Rec [(x, foldr Lam (sub (M.singleton lbx e') lbe) (αs ++ as))]-  where-    (αs, as, be) = collectTyAndValBinders e--    e' = foldl' App (foldl' App (Var x) ((Type . TyVarTy) <$> αs)) (Var <$> as)--    hasLoopBreaker (Let (Rec [(x1, e1)]) (Var x2)) | isLoopBreaker x1 && x1 == x2 = Just (x1, e1)-    hasLoopBreaker _                               = Nothing--    isLoopBreaker =  isStrongLoopBreaker . occInfo . idInfo--inlineLoopBreaker bs -  = bs--inlineFailCases :: CoreProgram -> CoreProgram-inlineFailCases = (go [] <$>)-  where -    go su (Rec xes)    = Rec (mapSnd (go' su) <$> xes)-    go su (NonRec x e) = NonRec x (go' su e)--    go' su (App (Var x) _)       | isFailId x, Just e <- getFailExpr x su = e  -    go' su (Let (NonRec x ex) e) | isFailId x   = go' (addFailExpr x (go' su ex) su) e--    go' su (App e1 e2)      = App (go' su e1) (go' su e2)-    go' su (Lam x e)        = Lam x (go' su e)-    go' su (Let xs e)       = Let (go su xs) (go' su e)-    go' su (Case e x t alt) = Case (go' su e) x t (goalt su <$> alt) -    go' su (Cast e c)       = Cast (go' su e) c-    go' su (Tick t e)       = Tick t (go' su e)-    go' _  e                = e--    goalt su (c, xs, e)     = (c, xs, go' su e)--    isFailId x  = isLocalId x && (isSystemName $ varName x) && L.isPrefixOf "fail" (show x)-    getFailExpr = L.lookup--    addFailExpr x (Lam _ e) su = (x, e):su -    addFailExpr _ _         _  = error "internal error" -- this cannot happen--isTypeError s | isInfixOf "Non term variable" (showSDoc s) = False-isTypeError _ = True--transformScope = outerScTr . innerScTr--outerScTr = mapNonRec (go [])-  where-   go ack x (xe : xes) | isCaseArg x xe = go (xe:ack) x xes-   go ack _ xes        = ack ++ xes--isCaseArg x (NonRec _ (Case (Var z) _ _ _)) = z == x-isCaseArg _ _                               = False--innerScTr = (mapBnd scTrans <$>)--scTrans x e = mapExpr scTrans $ foldr Let e0 bs-  where (bs, e0)           = go [] x e-        go bs x (Let b e)  | isCaseArg x b = go (b:bs) x e-        go bs x (Tick t e) = second (Tick t) $ go bs x e-        go bs _ e          = (bs, e)--type TE = State TrEnv--data TrEnv = Tr { freshIndex  :: !Int-                , _loc        :: SrcSpan-                }--initEnv = Tr 0 noSrcSpan--transPg = mapM transBd--transBd (NonRec x e) = liftM (NonRec x) (transExpr =<< mapBdM transBd e)-transBd (Rec xes)    = liftM Rec $ mapM (mapSndM (mapBdM transBd)) xes--transExpr :: CoreExpr -> TE CoreExpr-transExpr e-  | (isNonPolyRec e') && (not (null tvs)) -  = trans tvs ids bs e'-  | otherwise-  = return e-  where (tvs, ids, e'')       = collectTyAndValBinders e-        (bs, e')              = collectNonRecLets e''--isNonPolyRec (Let (Rec xes) _) = any nonPoly (snd <$> xes)-isNonPolyRec _                 = False--nonPoly = null . fst . splitForAllTys . exprType--collectNonRecLets = go []-  where go bs (Let b@(NonRec _ _) e') = go (b:bs) e'-        go bs e'                      = (reverse bs, e')--appTysAndIds tvs ids x = mkApps (mkTyApps (Var x) (map TyVarTy tvs)) (map Var ids)--trans vs ids bs (Let (Rec xes) e)-  = liftM (mkLam . mkLet) (makeTrans vs liveIds e')-  where liveIds = mkAlive <$> ids-        mkLet e = foldr Let e bs-        mkLam e = foldr Lam e $ vs ++ liveIds-        e'      = Let (Rec xes') e-        xes'    = (second mkLet) <$> xes--trans _ _ _ _ = error "TransformRec.trans called with invalid input"--makeTrans vs ids (Let (Rec xes) e)- = do fids    <- mapM (mkFreshIds vs ids) xs-      let (ids', ys) = unzip fids-      let yes  = appTysAndIds vs ids <$> ys-      ys'     <- mapM fresh xs-      let su   = M.fromList $ zip xs (Var <$> ys')-      let rs   = zip ys' yes-      let es'  = zipWith (mkE ys) ids' es-      let xes' = zip ys es'-      return   $ mkRecBinds rs (Rec xes') (sub su e)- where -   (xs, es)       = unzip xes-   mkSu ys ids'   = mkSubs ids vs ids' (zip xs ys)-   mkE ys ids' e' = mkCoreLams (vs ++ ids') (sub (mkSu ys ids') e')--makeTrans _ _ _ = error "TransformRec.makeTrans called with invalid input"--mkRecBinds :: [(b, Expr b)] -> Bind b -> Expr b -> Expr b-mkRecBinds xes rs e = Let rs (foldl' f e xes)-  where f e (x, xe) = Let (NonRec x xe) e  --mkSubs ids tvs xs ys = M.fromList $ s1 ++ s2-  where s1 = (second (appTysAndIds tvs xs)) <$> ys-        s2 = zip ids (Var <$> xs)--mkFreshIds tvs ids x-  = do ids'  <- mapM fresh ids-       let t  = mkForAllTys tvs $ mkType (reverse ids') $ varType x-       let x' = setVarType x t-       return (ids', x')-  where -    mkType ids ty = foldl (\t x -> FunTy (varType x) t) ty ids--class Freshable a where-  fresh :: a -> TE a--instance Freshable Int where-  fresh _ = freshInt--instance Freshable Unique where-  fresh _ = freshUnique--instance Freshable Var where-  fresh v = liftM (setVarUnique v) freshUnique--freshInt-  = do s <- get-       let n = freshIndex s-       put s{freshIndex = n+1}-       return n--freshUnique = liftM (mkUnique 'X') freshInt--mkAlive x-  | isId x && isDeadOcc (idOccInfo x)-  = setIdInfo x (setOccInfo (idInfo x) NoOccInfo)-  | otherwise-  = x--mapNonRec f (NonRec x xe:xes) = NonRec x xe : f x (mapNonRec f xes)-mapNonRec f (xe:xes)          = xe : mapNonRec f xes-mapNonRec _ []                = []--mapBnd f (NonRec b e)             = NonRec b (mapExpr f  e)-mapBnd f (Rec bs)                 = Rec (map (second (mapExpr f)) bs)--mapExpr f (Let (NonRec x ex) e)   = Let (NonRec x (f x ex) ) (f x e)-mapExpr f (App e1 e2)             = App  (mapExpr f e1) (mapExpr f e2)-mapExpr f (Lam b e)               = Lam b (mapExpr f e)-mapExpr f (Let bs e)              = Let (mapBnd f bs) (mapExpr f e)-mapExpr f (Case e b t alt)        = Case e b t (map (mapAlt f) alt)-mapExpr f (Tick t e)              = Tick t (mapExpr f e)-mapExpr _  e                      = e--mapAlt f (d, bs, e) = (d, bs, mapExpr f e)---- Do not apply transformations to inner code--mapBdM _ = return---- mapBdM f (Let b e)        = liftM2 Let (f b) (mapBdM f e)--- mapBdM f (App e1 e2)      = liftM2 App (mapBdM f e1) (mapBdM f e2)--- mapBdM f (Lam b e)        = liftM (Lam b) (mapBdM f e)--- mapBdM f (Case e b t alt) = liftM (Case e b t) (mapM (mapBdAltM f) alt)--- mapBdM f (Tick t e)       = liftM (Tick t) (mapBdM f e)--- mapBdM _  e               = return  e--- --- mapBdAltM f (d, bs, e) = liftM ((,,) d bs) (mapBdM f e)
+ src/Language/Haskell/Liquid/Transforms/ANF.hs view
@@ -0,0 +1,313 @@++--------------------------------------------------------------------------------+-- | Convert GHC Core into Administrative Normal Form (ANF) --------------------+--------------------------------------------------------------------------------++{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeSynonymInstances       #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+++module Language.Haskell.Liquid.Transforms.ANF (anormalize) where++import           Prelude                          hiding (error)+import           CoreSyn+import           CoreUtils                        (exprType)+import qualified DsMonad+import           DsMonad                          (initDs)+import           GHC                              hiding (exprType)+import           HscTypes++import           OccName                          (mkVarOccFS)+import           Id                               (mkUserLocalM)+import           Literal+import           MkCore                           (mkCoreLets)+import           Outputable                       (trace)+import           Var                              (varType, setVarType)+import           TypeRep+import           Type                             (mkForAllTys, substTy, mkForAllTys, mkTopTvSubst, isTyVar)+import           TyCon                            (tyConDataCons_maybe)+import           DataCon                          (dataConInstArgTys)+import           FamInstEnv                       (emptyFamInstEnv)+import           VarEnv                           (VarEnv, emptyVarEnv, extendVarEnv, lookupWithDefaultVarEnv)+import           Control.Monad.State.Lazy+import           UniqSupply                       (MonadUnique)+import           Language.Fixpoint.Misc             (fst3)+import           Language.Fixpoint.Types            (anfPrefix)+import           Language.Haskell.Liquid.Misc       (concatMapM)+import           Language.Haskell.Liquid.GHC.Misc   (MGIModGuts(..), showPpr, symbolFastString)+import           Language.Haskell.Liquid.Transforms.Rec+import           Language.Haskell.Liquid.Types.Errors+import qualified Language.Haskell.Liquid.GHC.SpanStack as Sp+import           Data.Maybe                       (fromMaybe)+import           Data.List                        (sortBy, (\\))+++--------------------------------------------------------------------------------+-- | A-Normalize a module ------------------------------------------------------+--------------------------------------------------------------------------------+anormalize :: Bool -> HscEnv -> MGIModGuts -> IO [CoreBind]+--------------------------------------------------------------------------------+anormalize expandFlag hscEnv modGuts+  = do -- putStrLn "***************************** GHC CoreBinds ***************************"+       -- putStrLn $ showPpr orig_cbs+       (fromMaybe err . snd) <$> initDs hscEnv m grEnv tEnv emptyFamInstEnv act+    where+      m        = mgi_module modGuts+      grEnv    = mgi_rdr_env modGuts+      tEnv     = modGutsTypeEnv modGuts+      act      = concatMapM (normalizeTopBind expandFlag emptyAnfEnv) orig_cbs+      orig_cbs = transformRecExpr $ mgi_binds modGuts+      err      = panic Nothing "Oops, cannot A-Normalize GHC Core!"++modGutsTypeEnv mg  = typeEnvFromEntities ids tcs fis+  where+    ids            = bindersOfBinds (mgi_binds mg)+    tcs            = mgi_tcs mg+    fis            = mgi_fam_insts mg++--------------------------------------------------------------------------------+-- | A-Normalize a @CoreBind@ --------------------------------------------------+--------------------------------------------------------------------------------++-- Can't make the below default for normalizeBind as it+-- fails tests/pos/lets.hs due to GHCs odd let-bindings++normalizeTopBind :: Bool -> AnfEnv -> Bind CoreBndr -> DsMonad.DsM [CoreBind]+normalizeTopBind expandFlag γ (NonRec x e)+  = do e' <- runDsM $ evalStateT (stitch γ e) (DsST expandFlag  [])+       return [normalizeTyVars $ NonRec x e']++normalizeTopBind expandFlag γ (Rec xes)+  = do xes' <- runDsM $ execStateT (normalizeBind γ (Rec xes)) (DsST expandFlag [])+       return $ map normalizeTyVars (st_binds xes')++normalizeTyVars :: Bind Id -> Bind Id+normalizeTyVars (NonRec x e) = NonRec (setVarType x t') $ normalizeForAllTys e+  where t'       = subst msg as as' bt+        msg      = "WARNING unable to renameVars on " ++ showPpr x+        as'      = fst $ splitForAllTys $ exprType e+        (as, bt) = splitForAllTys (varType x)+normalizeTyVars (Rec xes)    = Rec xes'+  where nrec = normalizeTyVars <$> ((\(x, e) -> NonRec x e) <$> xes)+        xes' = (\(NonRec x e) -> (x, e)) <$> nrec++subst :: String -> [TyVar] -> [TyVar] -> Type -> Type+subst msg as as' bt+  | length as == length as'+  = mkForAllTys as' $ substTy su bt+  | otherwise+  = trace msg $ mkForAllTys as bt+  where su = mkTopTvSubst $ zip as (mkTyVarTys as')++-- | eta-expand CoreBinds with quantified types+normalizeForAllTys :: CoreExpr -> CoreExpr+normalizeForAllTys e = case e of+  Lam b _ | isTyVar b+    -> e+  _ -> mkLams tvs (mkTyApps e (map mkTyVarTy tvs))+  where+  (tvs, _) = splitForAllTys (exprType e)+++newtype DsM a = DsM {runDsM :: DsMonad.DsM a}+   deriving (Functor, Monad, MonadUnique, Applicative)++data DsST = DsST { st_expandflag :: Bool+                 , st_binds      :: [CoreBind]+                 }++type DsMW = StateT DsST DsM++------------------------------------------------------------------+normalizeBind :: AnfEnv -> CoreBind -> DsMW ()+------------------------------------------------------------------+normalizeBind γ (NonRec x e)+   = do e' <- normalize γ e+        add [NonRec x e']++normalizeBind γ (Rec xes)+  = do es' <- mapM (stitch γ) es+       add [Rec (zip xs es')]+    where (xs, es) = unzip xes++--------------------------------------------------------------------+normalizeName :: AnfEnv -> CoreExpr -> DsMW CoreExpr+--------------------------------------------------------------------++-- normalizeNameDebug γ e+--   = liftM (tracePpr ("normalizeName" ++ showPpr e)) $ normalizeName γ e++normalizeName γ e@(Lit l)+  | shouldNormalize l+  = normalizeLiteral γ e+  | otherwise+  = return e++normalizeName γ (Var x)+  = return $ Var (lookupAnfEnv γ x x)++normalizeName _ e@(Type _)+  = return e++normalizeName γ e@(Coercion _)+  = do x     <- lift $ freshNormalVar γ $ exprType e+       add  [NonRec x e]+       return $ Var x++normalizeName γ (Tick tt e)+  = do e'    <- normalizeName (γ `at` tt) e+       return $ Tick tt e'++normalizeName γ e+  = do e'   <- normalize γ e+       x    <- lift $ freshNormalVar γ $ exprType e+       add [NonRec x e']+       return $ Var x++shouldNormalize l = case l of+  LitInteger _ _ -> True+  MachStr _ -> True+  _ -> False++add :: [CoreBind] -> DsMW ()+add w = modify $ \s -> s{st_binds = st_binds s++w}++---------------------------------------------------------------------+normalizeLiteral :: AnfEnv -> CoreExpr -> DsMW CoreExpr+---------------------------------------------------------------------+normalizeLiteral γ e =+  do x <- lift $ freshNormalVar γ $ exprType e+     add [NonRec x e]+     return $ Var x++---------------------------------------------------------------------+normalize :: AnfEnv -> CoreExpr -> DsMW CoreExpr+---------------------------------------------------------------------++normalize γ (Lam x e)+  = do e' <- stitch γ e+       return $ Lam x e'++normalize γ (Let b e)+  = do normalizeBind γ b+       normalize γ e+       -- Need to float bindings all the way up to the top+       -- Due to GHCs odd let-bindings (see tests/pos/lets.hs)++normalize γ (Case e x t as)+  = do n     <- normalizeName γ e+       x'    <- lift $ freshNormalVar γ τx -- rename "wild" to avoid shadowing+       let γ' = extendAnfEnv γ x x'+       as'   <- forM as $ \(c, xs, e') -> liftM (c, xs,) (stitch γ' e')+       flag  <- st_expandflag <$> get+       as''  <- lift $ expandDefaultCase γ flag τx as'+       return $ Case n x' t as''+    where τx = varType x++normalize γ (Var x)+  = return $ Var (lookupAnfEnv γ x x)++normalize _ e@(Lit _)+  = return e++normalize _ e@(Type _)+  = return e++normalize γ (Cast e τ)+  = do e'    <- normalizeName γ e+       return $ Cast e' τ++normalize γ (App e1 e2)+  = do e1' <- normalize γ e1+       n2  <- normalizeName γ e2+       return $ App e1' n2++normalize γ (Tick tt e)+  = do e' <- normalize (γ `at` tt) e+       return $ Tick tt e'++normalize _ (Coercion c)+  = return $ Coercion c++stitch :: AnfEnv -> CoreExpr -> DsMW CoreExpr+stitch γ e+  = do bs'   <- get+       modify $ \s -> s {st_binds = []}+       e'    <- normalize γ e+       bs    <- st_binds <$> get+       put bs'+       return $ mkCoreLets bs e'++--------------------------------------------------------------------------------+expandDefaultCase :: AnfEnv+                  -> Bool+                  -> Type+                  -> [(AltCon, [Id], CoreExpr)]+                  -> DsM [(AltCon, [Id], CoreExpr)]+--------------------------------------------------------------------------------++expandDefaultCase γ flag tyapp zs@((DEFAULT, _ ,_) : _) | flag+  = expandDefaultCase' γ tyapp zs++expandDefaultCase γ _    tyapp@(TyConApp tc _) z@((DEFAULT, _ ,_):dcs)+  = case tyConDataCons_maybe tc of+       Just ds -> do let ds' = ds \\ [ d | (DataAlt d, _ , _) <- dcs]+                     if (length ds') == 1+                      then expandDefaultCase' γ tyapp z+                      else return z+       Nothing -> return z --++expandDefaultCase _ _ _ z+   = return z++expandDefaultCase' γ (TyConApp tc argτs) z@((DEFAULT, _ ,e) : dcs)+  = case tyConDataCons_maybe tc of+       Just ds -> do let ds' = ds \\ [ d | (DataAlt d, _ , _) <- dcs]+                     dcs'   <- forM ds' $ cloneCase γ argτs e+                     return $ sortCases $ dcs' ++ dcs+       Nothing -> return z --++expandDefaultCase' _ _ z+   = return z++cloneCase γ argτs e d+  = do xs  <- mapM (freshNormalVar γ) $ dataConInstArgTys d argτs+       return (DataAlt d, xs, e)++sortCases = sortBy (\x y -> cmpAltCon (fst3 x) (fst3 y))+++--------------------------------------------------------------------------------+-- | ANF Environments ----------------------------------------------------------+--------------------------------------------------------------------------------++-- freshNormalVar :: Type -> DsM Id+-- freshNormalVar = mkSysLocalM (symbolFastString anfPrefix)++freshNormalVar :: AnfEnv -> Type -> DsM Id+freshNormalVar γ t = mkUserLocalM anfOcc t sp+  where+    anfOcc         = mkVarOccFS $ symbolFastString anfPrefix+    sp             = Sp.srcSpan (aeSrcSpan γ)+++data AnfEnv = AnfEnv+  { aeVarEnv  :: VarEnv Id+  , aeSrcSpan :: Sp.SpanStack+  }++emptyAnfEnv :: AnfEnv+emptyAnfEnv = AnfEnv emptyVarEnv Sp.empty++lookupAnfEnv :: AnfEnv -> Id -> Id -> Id+lookupAnfEnv γ x y = lookupWithDefaultVarEnv (aeVarEnv γ) x y++extendAnfEnv :: AnfEnv -> Id -> Id -> AnfEnv+extendAnfEnv γ x y = γ { aeVarEnv = extendVarEnv (aeVarEnv γ) x y }++at :: AnfEnv -> Tickish Id -> AnfEnv+at γ tt = γ { aeSrcSpan = Sp.push (Sp.Tick tt) (aeSrcSpan γ)}
+ src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs view
@@ -0,0 +1,456 @@+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE UndecidableInstances   #-}+{-# LANGUAGE OverloadedStrings      #-}+{-# LANGUAGE TupleSections          #-}++module Language.Haskell.Liquid.Transforms.CoreToLogic (++  coreToDef , coreToFun,+  coreToLogic, coreToPred,+  mkLit, runToLogic,+  logicType,+  strengthenResult++  ) where++import Prelude hiding (error)+import GHC hiding (Located)+import Var+import Type+import TypeRep++import qualified CoreSyn   as C+import Literal+import IdInfo++import Data.Text.Encoding++import TysWiredIn++++import Language.Fixpoint.Misc (snd3)++import Language.Fixpoint.Types hiding (Error, R, simplify)+import qualified Language.Fixpoint.Types as F+import Language.Haskell.Liquid.GHC.Misc+import Language.Haskell.Liquid.GHC.Play+import Language.Haskell.Liquid.Types    hiding (GhcInfo(..), GhcSpec (..), LM)+import Language.Haskell.Liquid.Misc (mapSnd)+import Language.Haskell.Liquid.WiredIn+import Language.Haskell.Liquid.Types.RefType+++import qualified Data.HashMap.Strict as M+++++logicType :: (Reftable r) => Type -> RRType r+logicType τ = fromRTypeRep $ t{ty_res = res, ty_binds = binds, ty_args = args, ty_refts = refts}+  where+    t   = toRTypeRep $ ofType τ+    res = mkResType $ ty_res t+    (binds, args, refts) = unzip3 $ dropWhile (isClassType.snd3) $ zip3 (ty_binds t) (ty_args t) (ty_refts t)+++    mkResType t+     | isBool t   = propType+     | otherwise  = t++isBool (RApp (RTyCon{rtc_tc = c}) _ _ _) = c == boolTyCon+isBool _ = False++{- strengthenResult type: the refinement depends on whether the result type is a Bool or not:++CASE1: measure f@logic :: X -> Prop <=> f@haskell :: x:X -> {v:Bool | (Prop v) <=> (f@logic x)}++CASE2: measure f@logic :: X -> Y    <=> f@haskell :: x:X -> {v:Y    | v = (f@logic x)}+-}++strengthenResult :: Var -> SpecType+strengthenResult v+  | isBool res+  = -- traceShow ("Type for " ++ showPpr v ++ "\t OF \t" ++ show (ty_binds rep)) $+    fromRTypeRep $ rep{ty_res = res `strengthen` r, ty_binds = xs}+  | otherwise+  = -- traceShow ("Type for " ++ showPpr v ++ "\t OF \t" ++ show (ty_binds rep)) $+    fromRTypeRep $ rep{ty_res = res `strengthen` r', ty_binds = xs}+  where rep = toRTypeRep t+        res = ty_res rep+        xs  = intSymbol (symbol ("x" :: String)) <$> [1..length $ ty_binds rep]+        r'  = MkUReft (exprReft (mkEApp f (mkA <$> vxs)))         mempty mempty+        r   = MkUReft (propReft (mkEApp f (mkA <$> vxs))) mempty mempty+        vxs = dropWhile (isClassType.snd) $ zip xs (ty_args rep)+        f   = dummyLoc $ dropModuleNames $ simplesymbol v+        t   = (ofType $ varType v) :: SpecType+        mkA = EVar . fst -- if isBool t then EApp (dummyLoc propConName) [(EVar x)] else EVar x+++simplesymbol = symbol . getName++newtype LogicM a = LM {runM :: LState -> Either a Error}++data LState = LState { symbolMap :: LogicMap+                     , mkError   :: String -> Error+                     , ltce      :: TCEmb TyCon+                     }+++instance Monad LogicM where+  return = LM . const . Left+  (LM m) >>= f+    = LM $ \s -> case m s of+                (Left x) -> (runM (f x)) s+                (Right x) -> Right x++instance Functor LogicM where+  fmap f (LM m) = LM $ \s -> case m s of+                              (Left  x) -> Left $ f x+                              (Right x) -> Right x++instance Applicative LogicM where+  pure = LM . const . Left+  (LM f) <*> (LM m)+    = LM $ \s -> case (f s, m s) of+                  (Left f , Left x ) -> Left $ f x+                  (Right f, Left _ ) -> Right f+                  (Left _ , Right x) -> Right x+                  (Right _, Right x) -> Right x++throw :: String -> LogicM a+throw str = LM $ \s -> Right $ (mkError s) str++getState :: LogicM LState+getState = LM $ Left++runToLogic tce lmap ferror  (LM m)+  = m $ LState {symbolMap = lmap, mkError = ferror, ltce = tce }++coreToDef :: Reftable r => LocSymbol -> Var -> C.CoreExpr ->  LogicM [Def (RRType r) DataCon]+coreToDef x _ e = go [] $ inline_preds $ simplify e+  where+    go args (C.Lam  x e) = go (x:args) e+    go args (C.Tick _ e) = go args e+    go args (C.Case _ _ t alts)+      | eqType t boolTy  = mapM (goalt_prop (reverse $ tail args) (head args)) alts+      | otherwise        = mapM (goalt      (reverse $ tail args) (head args)) alts+    go _ _               = throw "Measure Functions should have a case at top level"++    goalt args dx ((C.DataAlt d), xs, e)+      = ((Def x (toArgs id args) d (Just $ ofType $ varType dx) (toArgs Just xs)) . E)+        <$> coreToLg e+    goalt _ _ alt+       = throw $ "Bad alternative" ++ showPpr alt++    goalt_prop args dx ((C.DataAlt d), xs, e)+      = ((Def x (toArgs id args) d (Just $ ofType $ varType dx) (toArgs Just xs)) . P)+        <$> coreToPd  e+    goalt_prop _ _ alt+      = throw $ "Bad alternative" ++ showPpr alt++    toArgs f args = [(symbol x, f $ ofType $ varType x) | x <- args]++    inline_preds = inline (eqType boolTy . varType)++coreToFun :: LocSymbol -> Var -> C.CoreExpr ->  LogicM ([Var], Either Expr Expr)+coreToFun _ v e = go [] $ normalize e+  where+    go acc (C.Lam x e)  | isTyVar    x = go acc e+    go acc (C.Lam x e)  | isErasable x = go acc e+    go acc (C.Lam x e)  = go (x:acc) e+    go acc (C.Tick _ e) = go acc e+    go acc e            | eqType rty boolTy+                        = (reverse acc,) . Left  <$> coreToPd e+                        | otherwise+                        = (reverse acc,) . Right <$> coreToLg e+++    rty = snd $ splitFunTys $ snd $ splitForAllTys $ varType v++coreToPred :: C.CoreExpr -> LogicM Expr+coreToPred e = coreToPd $ normalize e+++coreToPd :: C.CoreExpr -> LogicM Expr+coreToPd (C.Let b p)  = subst1 <$> coreToPd p <*>  makesub b+coreToPd (C.Tick _ p) = coreToPd p+coreToPd (C.App (C.Var v) e) | ignoreVar v = coreToPd e+coreToPd (C.Var x)+  | x == falseDataConId+  = return PFalse+  | x == trueDataConId+  = return PTrue+  | eqType boolTy (varType x)+  = return $ mkEApp (dummyLoc propConName) [(EVar $ symbol x)]+coreToPd p@(C.App _ _) = toPredApp p+coreToPd e+  = coreToLg e+-- coreToPd e+--  = throw ("Cannot transform to Logical Predicate:\t" ++ showPpr e)+++instance Show C.CoreExpr where+  show = showPpr++coreToLogic :: C.CoreExpr -> LogicM Expr+coreToLogic = coreToLg . simplify+++coreToLg :: C.CoreExpr -> LogicM Expr+coreToLg (C.Let b e)  = subst1 <$> coreToLg e <*>  makesub b+coreToLg (C.Tick _ e) = coreToLg e+coreToLg (C.App (C.Var v) e) | ignoreVar v = coreToLg e+coreToLg (C.Lit l)+  = case mkLit l of+     Nothing -> throw $ "Bad Literal in measure definition" ++ showPpr l+     Just i -> return i+coreToLg (C.Var x)+  | x == falseDataConId+  = return PFalse+  | x == trueDataConId+  = return PTrue+  | eqType boolTy (varType x)+  = return $ mkEApp (dummyLoc propConName) [(EVar $ symbol x)]+coreToLg (C.Var x)           = (symbolMap <$> getState) >>= eVarWithMap x+coreToLg e@(C.App _ _)       = toLogicApp e+coreToLg (C.Case e b _ alts) | eqType (varType b) boolTy+  = checkBoolAlts alts >>= coreToIte e+coreToLg (C.Lam x e)+  = do p   <- coreToLg e+       tce <- ltce <$> getState +       return $ ELam (symbol x, typeSort tce $ varType x) p+-- coreToLg p@(C.App _ _) = toPredApp p+coreToLg e                   = throw ("Cannot transform to Logic:\t" ++ showPpr e)++checkBoolAlts :: [C.CoreAlt] -> LogicM (C.CoreExpr, C.CoreExpr)+checkBoolAlts [(C.DataAlt false, [], efalse), (C.DataAlt true, [], etrue)]+  | false == falseDataCon, true == trueDataCon+  = return (efalse, etrue)+checkBoolAlts [(C.DataAlt true, [], etrue), (C.DataAlt false, [], efalse)]+  | false == falseDataCon, true == trueDataCon+  = return (efalse, etrue)+checkBoolAlts alts+  = throw ("checkBoolAlts failed on " ++ showPpr alts)++coreToIte e (efalse, etrue)+  = do p  <- coreToPd e+       e1 <- coreToLg efalse+       e2 <- coreToLg etrue+       return $ EIte p e2 e1++toPredApp :: C.CoreExpr -> LogicM Expr+toPredApp p+  = do let (f, es) = splitArgs p+       let f'      = tomaybesymbol f+       go f' es+  where+    go (Just f) [e1, e2]+      | Just rel <- M.lookup f brels+      = PAtom rel <$> (coreToLg e1) <*> (coreToLg e2)+    go (Just f) [e]+      | f == symbol ("not" :: String)+      = PNot <$>  coreToPd e+    go (Just f) [e1, e2]+      | f == symbol ("||" :: String)+      = POr <$> mapM coreToPd [e1, e2]+      | f == symbol ("&&" :: String)+      = PAnd <$> mapM coreToPd [e1, e2]+      | f == symbol ("==>" :: String)+      = PImp <$> coreToPd e1 <*> coreToPd e2+    go (Just f) es+      | f == symbol ("or" :: String)+      = POr <$> mapM coreToPd es+      | f == symbol ("and" :: String)+      = PAnd <$> mapM coreToPd es+    go _ _ = toLogicApp p++toLogicApp :: C.CoreExpr -> LogicM Expr+toLogicApp e+  =  do let (f, es) = splitArgs e+        case f of +          C.Var _ -> do args       <- mapM coreToLg es+                        lmap       <- symbolMap <$> getState+                        def         <- (`mkEApp` args) <$> tosymbol f+                        (\x -> makeApp def lmap x args) <$> tosymbol' f+          _ -> do (fe:args) <- mapM coreToLg (f:es) +                  return $ foldl EApp fe args  ++makeApp :: Expr -> LogicMap -> Located Symbol-> [Expr] -> Expr+makeApp _ _ f [e] | val f == symbol ("GHC.Num.negate" :: String)+  = ENeg e++makeApp _ _ f [e1, e2] | Just op <- M.lookup (val f) bops+  = EBin op e1 e2++makeApp def lmap f es+  = eAppWithMap lmap f es def++eVarWithMap :: Id -> LogicMap -> LogicM Expr+eVarWithMap x lmap+  = do f' <- tosymbol' (C.Var x :: C.CoreExpr)+       return $ eAppWithMap lmap f' [] (eVar x )+  where+    eVar x | isPolyCst $ varType x  = mkEApp (dummyLoc $ symbol x) []+           | otherwise              = EVar $ symbol x++    isPolyCst (ForAllTy _ t) = isCst t+    isPolyCst _              = False+    isCst     (ForAllTy _ t) = isCst t+    isCst     (FunTy _ _)    = False+    isCst     _              = True+++brels :: M.HashMap Symbol Brel+brels = M.fromList [ (symbol ("==" :: String), Eq)+                   , (symbol ("/=" :: String), Ne)+                   , (symbol (">=" :: String), Ge)+                   , (symbol (">" :: String) , Gt)+                   , (symbol ("<=" :: String), Le)+                   , (symbol ("<" :: String) , Lt)+                   ]++bops :: M.HashMap Symbol Bop+bops = M.fromList [ (numSymbol "+", Plus)+                  , (numSymbol "-", Minus)+                  , (numSymbol "*", Times)+                  , (numSymbol "/", Div)+                  , (numSymbol "%", Mod)+                  ]+  where+    numSymbol :: String -> Symbol+    numSymbol =  symbol . (++) "GHC.Num."++splitArgs e = (f, reverse es)+ where+    (f, es) = go e++    go (C.App (C.Var i) e) | ignoreVar i       = go e+    go (C.App f (C.Var v)) | isErasable v    = go f+    go (C.App f e) = (f', e:es) where (f', es) = go f+    go f           = (f, [])++tomaybesymbol (C.Var c) | isDataConId  c = Just $ symbol c+tomaybesymbol (C.Var x) = Just $ simpleSymbolVar x+tomaybesymbol _         = Nothing ++tosymbol e         + = case tomaybesymbol e of +    Just x -> return $ dummyLoc x +    _      -> throw ("Bad Measure Definition:\n" ++ showPpr e ++ "\t cannot be applied")++tosymbol' (C.Var x) = return $ dummyLoc $ simpleSymbolVar' x+tosymbol'  e        = throw ("Bad Measure Definition:\n" ++ showPpr e ++ "\t cannot be applied")++makesub (C.NonRec x e) =  (symbol x,) <$> coreToLg e+makesub  _             = throw "Cannot make Logical Substitution of Recursive Definitions"++mkLit :: Literal -> Maybe Expr+mkLit (MachInt    n)   = mkI n+mkLit (MachInt64  n)   = mkI n+mkLit (MachWord   n)   = mkI n+mkLit (MachWord64 n)   = mkI n+mkLit (MachFloat  n)   = mkR n+mkLit (MachDouble n)   = mkR n+mkLit (LitInteger n _) = mkI n+mkLit (MachStr s)      = mkS s+mkLit _                = Nothing -- ELit sym sort++mkI                    = Just . ECon . I+mkR                    = Just . ECon . F.R . fromRational+mkS                    = Just . ESym . SL  . decodeUtf8++ignoreVar i = simpleSymbolVar i `elem` ["I#"]+++simpleSymbolVar  = dropModuleNames . symbol . showPpr . getName+simpleSymbolVar' = symbol . showPpr . getName++isErasable v = isPrefixOfSym (symbol ("$"      :: String)) (simpleSymbolVar v)+isANF      v = isPrefixOfSym (symbol ("lq_anf" :: String)) (simpleSymbolVar v)++isDead     = isDeadOcc . occInfo . idInfo++class Simplify a where+  simplify :: a -> a+  inline   :: (Id -> Bool) -> a -> a+++  normalize :: a -> a+  normalize = inline_preds . inline_anf . simplify+   where+    inline_preds = inline (eqType boolTy . varType)+    inline_anf   = inline isANF++instance Simplify C.CoreExpr where+  simplify e@(C.Var _)+    = e+  simplify e@(C.Lit _)+    = e+  simplify (C.App e (C.Type _))+    = simplify e+  simplify (C.App e (C.Var dict))  | isErasable dict+    = simplify e+  simplify (C.App (C.Lam x e) _)   | isDead x+    = simplify e+  simplify (C.App e1 e2)+    = C.App (simplify e1) (simplify e2)+  simplify (C.Lam x e) | isTyVar x+    = simplify e+  simplify (C.Lam x e) | isErasable x+    = simplify e+  simplify (C.Lam x e)+    = C.Lam x (simplify e)+  simplify (C.Let (C.NonRec x _) e) | isErasable x+    = simplify e+  simplify (C.Let (C.Rec xes) e)    | all (isErasable . fst) xes+    = simplify e+  simplify (C.Let xes e)+    = C.Let (simplify xes) (simplify e)+  simplify (C.Case e x t alts)+    = C.Case (simplify e) x t (filter (not . isUndefined) (simplify <$> alts))+  simplify (C.Cast e _)+    = simplify e+  simplify (C.Tick _ e)+    = simplify e+  simplify (C.Coercion c)+    = C.Coercion c+  simplify (C.Type t)+    = C.Type t++  inline p (C.Let (C.NonRec x ex) e) | p x+                               = sub (M.singleton x (inline p ex)) (inline p e)+  inline p (C.Let xes e)       = C.Let (inline p xes) (inline p e)+  inline p (C.App e1 e2)       = C.App (inline p e1) (inline p e2)+  inline p (C.Lam x e)         = C.Lam x (inline p e)+  inline p (C.Case e x t alts) = C.Case (inline p e) x t (inline p <$> alts)+  inline p (C.Cast e c)        = C.Cast (inline p e) c+  inline p (C.Tick t e)        = C.Tick t (inline p e)+  inline _ (C.Var x)           = C.Var x+  inline _ (C.Lit l)           = C.Lit l+  inline _ (C.Coercion c)      = C.Coercion c+  inline _ (C.Type t)          = C.Type t++isUndefined (_, _, e) = isUndefinedExpr e+  where+   -- auto generated undefined case: (\_ -> (patError @type "error message")) void+   isUndefinedExpr (C.App (C.Var x) _) | (show x) `elem` perrors = True+   isUndefinedExpr (C.Let _ e) = isUndefinedExpr e+   -- otherwise+   isUndefinedExpr _ = False++   perrors = ["Control.Exception.Base.patError"]+++instance Simplify C.CoreBind where+  simplify (C.NonRec x e) = C.NonRec x (simplify e)+  simplify (C.Rec xes)    = C.Rec (mapSnd simplify <$> xes )++  inline p (C.NonRec x e) = C.NonRec x (inline p e)+  inline p (C.Rec xes)    = C.Rec (mapSnd (inline p) <$> xes)++instance Simplify C.CoreAlt where+  simplify (c, xs, e) = (c, xs, simplify e)++  inline p (c, xs, e) = (c, xs, inline p e)
+ src/Language/Haskell/Liquid/Transforms/Rec.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TupleSections             #-}+{-# LANGUAGE TypeSynonymInstances      #-}++module Language.Haskell.Liquid.Transforms.Rec (+     transformRecExpr, transformScope+     ) where++import           Prelude             hiding (error)+import           Bag+import           Coercion+import           Control.Arrow       (second)+import           Control.Monad.State+import           CoreSyn+import           CoreUtils+import qualified Data.HashMap.Strict as M+import           ErrUtils+import           Id                  (idOccInfo, setIdInfo)+import           IdInfo+import           MkCore              (mkCoreLams)+import           SrcLoc+import           Type                (mkForAllTys, splitForAllTys)+import           TypeRep+import           Unique              hiding (deriveUnique)+import           Var+import           Name (isSystemName)+import           Language.Haskell.Liquid.GHC.Misc+import           Language.Haskell.Liquid.GHC.Play+import           Language.Haskell.Liquid.Misc (mapSndM, mapSnd)+import           Language.Haskell.Liquid.Types.Errors++import           Data.List                (foldl', isInfixOf)+++import qualified Data.List as L+++transformRecExpr :: CoreProgram -> CoreProgram+transformRecExpr cbs+  | isEmptyBag $ filterBag isTypeError e+  =  {-trace "new cbs"-} pg+  | otherwise+  = panic Nothing ("Type-check" ++ showSDoc (pprMessageBag e))+  where pg0    = evalState (transPg (inlineLoopBreaker <$> cbs)) initEnv+        (_, e) = lintCoreBindings [] pg+        pg     = inlineFailCases pg0+++++inlineLoopBreaker (NonRec x e) | Just (lbx, lbe) <- hasLoopBreaker be+  = Rec [(x, foldr Lam (sub (M.singleton lbx e') lbe) (αs ++ as))]+  where+    (αs, as, be) = collectTyAndValBinders e++    e' = foldl' App (foldl' App (Var x) ((Type . TyVarTy) <$> αs)) (Var <$> as)++    hasLoopBreaker (Let (Rec [(x1, e1)]) (Var x2)) | isLoopBreaker x1 && x1 == x2 = Just (x1, e1)+    hasLoopBreaker _                               = Nothing++    isLoopBreaker =  isStrongLoopBreaker . occInfo . idInfo++inlineLoopBreaker bs+  = bs++inlineFailCases :: CoreProgram -> CoreProgram+inlineFailCases = (go [] <$>)+  where+    go su (Rec xes)    = Rec (mapSnd (go' su) <$> xes)+    go su (NonRec x e) = NonRec x (go' su e)++    go' su (App (Var x) _)       | isFailId x, Just e <- getFailExpr x su = e+    go' su (Let (NonRec x ex) e) | isFailId x   = go' (addFailExpr x (go' su ex) su) e++    go' su (App e1 e2)      = App (go' su e1) (go' su e2)+    go' su (Lam x e)        = Lam x (go' su e)+    go' su (Let xs e)       = Let (go su xs) (go' su e)+    go' su (Case e x t alt) = Case (go' su e) x t (goalt su <$> alt)+    go' su (Cast e c)       = Cast (go' su e) c+    go' su (Tick t e)       = Tick t (go' su e)+    go' _  e                = e++    goalt su (c, xs, e)     = (c, xs, go' su e)++    isFailId x  = isLocalId x && (isSystemName $ varName x) && L.isPrefixOf "fail" (show x)+    getFailExpr = L.lookup++    addFailExpr x (Lam _ e) su = (x, e):su+    addFailExpr _ _         _  = impossible Nothing "internal error" -- this cannot happen++isTypeError s | isInfixOf "Non term variable" (showSDoc s) = False+isTypeError _ = True++transformScope = outerScTr . innerScTr++outerScTr = mapNonRec (go [])+  where+   go ack x (xe : xes) | isCaseArg x xe = go (xe:ack) x xes+   go ack _ xes        = ack ++ xes++isCaseArg x (NonRec _ (Case (Var z) _ _ _)) = z == x+isCaseArg _ _                               = False++innerScTr = (mapBnd scTrans <$>)++scTrans x e = mapExpr scTrans $ foldr Let e0 bs+  where (bs, e0)           = go [] x e+        go bs x (Let b e)  | isCaseArg x b = go (b:bs) x e+        go bs x (Tick t e) = second (Tick t) $ go bs x e+        go bs _ e          = (bs, e)++type TE = State TrEnv++data TrEnv = Tr { freshIndex  :: !Int+                , _loc        :: SrcSpan+                }++initEnv = Tr 0 noSrcSpan++transPg = mapM transBd++transBd (NonRec x e) = liftM (NonRec x) (transExpr =<< mapBdM transBd e)+transBd (Rec xes)    = liftM Rec $ mapM (mapSndM (mapBdM transBd)) xes++transExpr :: CoreExpr -> TE CoreExpr+transExpr e+  | (isNonPolyRec e') && (not (null tvs))+  = trans tvs ids bs e'+  | otherwise+  = return e+  where (tvs, ids, e'')       = collectTyAndValBinders e+        (bs, e')              = collectNonRecLets e''++isNonPolyRec (Let (Rec xes) _) = any nonPoly (snd <$> xes)+isNonPolyRec _                 = False++nonPoly = null . fst . splitForAllTys . exprType++collectNonRecLets = go []+  where go bs (Let b@(NonRec _ _) e') = go (b:bs) e'+        go bs e'                      = (reverse bs, e')++appTysAndIds tvs ids x = mkApps (mkTyApps (Var x) (map TyVarTy tvs)) (map Var ids)++trans vs ids bs (Let (Rec xes) e)+  = liftM (mkLam . mkLet) (makeTrans vs liveIds e')+  where liveIds = mkAlive <$> ids+        mkLet e = foldr Let e bs+        mkLam e = foldr Lam e $ vs ++ liveIds+        e'      = Let (Rec xes') e+        xes'    = (second mkLet) <$> xes++trans _ _ _ _ = panic Nothing "TransformRec.trans called with invalid input"++makeTrans vs ids (Let (Rec xes) e)+ = do fids    <- mapM (mkFreshIds vs ids) xs+      let (ids', ys) = unzip fids+      let yes  = appTysAndIds vs ids <$> ys+      ys'     <- mapM fresh xs+      let su   = M.fromList $ zip xs (Var <$> ys')+      let rs   = zip ys' yes+      let es'  = zipWith (mkE ys) ids' es+      let xes' = zip ys es'+      return   $ mkRecBinds rs (Rec xes') (sub su e)+ where+   (xs, es)       = unzip xes+   mkSu ys ids'   = mkSubs ids vs ids' (zip xs ys)+   mkE ys ids' e' = mkCoreLams (vs ++ ids') (sub (mkSu ys ids') e')++makeTrans _ _ _ = panic Nothing "TransformRec.makeTrans called with invalid input"++mkRecBinds :: [(b, Expr b)] -> Bind b -> Expr b -> Expr b+mkRecBinds xes rs e = Let rs (foldl' f e xes)+  where f e (x, xe) = Let (NonRec x xe) e++mkSubs ids tvs xs ys = M.fromList $ s1 ++ s2+  where s1 = (second (appTysAndIds tvs xs)) <$> ys+        s2 = zip ids (Var <$> xs)++mkFreshIds tvs ids x+  = do ids'  <- mapM fresh ids+       let t  = mkForAllTys tvs $ mkType (reverse ids') $ varType x+       let x' = setVarType x t+       return (ids', x')+  where+    mkType ids ty = foldl (\t x -> FunTy (varType x) t) ty ids++class Freshable a where+  fresh :: a -> TE a++instance Freshable Int where+  fresh _ = freshInt++instance Freshable Unique where+  fresh _ = freshUnique++instance Freshable Var where+  fresh v = liftM (setVarUnique v) freshUnique++freshInt+  = do s <- get+       let n = freshIndex s+       put s{freshIndex = n+1}+       return n++freshUnique = liftM (mkUnique 'X') freshInt++mkAlive x+  | isId x && isDeadOcc (idOccInfo x)+  = setIdInfo x (setOccInfo (idInfo x) NoOccInfo)+  | otherwise+  = x++mapNonRec f (NonRec x xe:xes) = NonRec x xe : f x (mapNonRec f xes)+mapNonRec f (xe:xes)          = xe : mapNonRec f xes+mapNonRec _ []                = []++mapBnd f (NonRec b e)             = NonRec b (mapExpr f  e)+mapBnd f (Rec bs)                 = Rec (map (second (mapExpr f)) bs)++mapExpr f (Let (NonRec x ex) e)   = Let (NonRec x (f x ex) ) (f x e)+mapExpr f (App e1 e2)             = App  (mapExpr f e1) (mapExpr f e2)+mapExpr f (Lam b e)               = Lam b (mapExpr f e)+mapExpr f (Let bs e)              = Let (mapBnd f bs) (mapExpr f e)+mapExpr f (Case e b t alt)        = Case e b t (map (mapAlt f) alt)+mapExpr f (Tick t e)              = Tick t (mapExpr f e)+mapExpr _  e                      = e++mapAlt f (d, bs, e) = (d, bs, mapExpr f e)++-- Do not apply transformations to inner code++mapBdM _ = return++-- mapBdM f (Let b e)        = liftM2 Let (f b) (mapBdM f e)+-- mapBdM f (App e1 e2)      = liftM2 App (mapBdM f e1) (mapBdM f e2)+-- mapBdM f (Lam b e)        = liftM (Lam b) (mapBdM f e)+-- mapBdM f (Case e b t alt) = liftM (Case e b t) (mapM (mapBdAltM f) alt)+-- mapBdM f (Tick t e)       = liftM (Tick t) (mapBdM f e)+-- mapBdM _  e               = return  e+--+-- mapBdAltM f (d, bs, e) = liftM ((,,) d bs) (mapBdM f e)
+ src/Language/Haskell/Liquid/Transforms/RefSplit.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE UndecidableInstances #-}++module Language.Haskell.Liquid.Transforms.RefSplit (++        splitXRelatedRefs++        ) where++import Prelude hiding (error)++import Data.List (partition)+import Text.PrettyPrint.HughesPJ++import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.Types.PrettyPrint ()++import Language.Fixpoint.Types+import Language.Fixpoint.Misc++splitXRelatedRefs :: Symbol -> SpecType -> (SpecType, SpecType)+splitXRelatedRefs x t = splitRType x t++++splitRType f (RVar a r) = (RVar a r1, RVar a r2)+  where+        (r1, r2) = splitRef f r+splitRType f (RFun x tx t r) = (RFun x tx1 t1 r1, RFun x tx2 t2 r2)+  where+        (tx1, tx2) = splitRType f tx+        (t1,  t2)  = splitRType f t+        (r1,  r2)  = splitRef   f r+splitRType f (RAllT v t) = (RAllT v t1, RAllT v t2)+  where+        (t1, t2) = splitRType f t+splitRType f (RAllP p t) = (RAllP p t1, RAllP p t2)+  where+        (t1, t2) = splitRType f t+splitRType f (RAllS s t) = (RAllS s t1, RAllS s t2)+  where+        (t1, t2) = splitRType f t+splitRType f (RApp c ts rs r) = (RApp c ts1 rs1 r1, RApp c ts2 rs2 r2)+  where+        (ts1, ts2) = unzip (splitRType f <$> ts)+        (rs1, rs2) = unzip (splitUReft f <$> rs)+        (r1,  r2)  = splitRef f r+splitRType f (RAllE x tx t) = (RAllE x tx1 t1, RAllE x tx2 t2)+  where+        (tx1, tx2) = splitRType f tx+        (t1, t2)   = splitRType f t+splitRType f (REx x tx t) = (REx x tx1 t1, REx x tx2 t2)+  where+        (tx1, tx2) = splitRType f tx+        (t1, t2)   = splitRType f t+splitRType _ (RExprArg e) = (RExprArg e, RExprArg e)+splitRType f (RAppTy tx t r) = (RAppTy tx1 t1 r1, RAppTy tx2 t2 r2)+  where+        (tx1, tx2) = splitRType f tx+        (t1,  t2)  = splitRType f t+        (r1,  r2)  = splitRef   f r+splitRType f (RRTy xs r o t) = (RRTy xs1 r1 o t1, RRTy xs2 r2 o t2)+  where+        (xs1, xs2) = unzip (go <$> xs)+        (r1, r2) = splitRef   f r+        (t1, t2) = splitRType f t++        go (x, t) = let (t1, t2) = splitRType f t in ((x,t1), (x, t2))+splitRType f (RHole r) = (RHole r1, RHole r2)+  where+        (r1, r2) = splitRef f r+++splitUReft :: Symbol -> RTProp c tv (UReft Reft) -> (RTProp c tv (UReft Reft), RTProp c tv (UReft Reft))+splitUReft x (RProp xs (RHole r)) = (RProp xs (RHole r1), RProp xs (RHole r2))+  where+        (r1, r2) = splitRef x r+splitUReft x (RProp xs t) = (RProp xs t1, RProp xs t2)+  where+        (t1, t2) = splitRType x t++splitRef f (MkUReft r p s) = (MkUReft r1 p1 s, MkUReft r2 p2 s)+        where+                (r1, r2) = splitReft f r+                (p1, p2) = splitPred f p+splitReft f (Reft (v, xs)) = (Reft (v, pAnd xs1), Reft (v, pAnd xs2))+  where+    (xs1, xs2)       = partition (isFree f) (unPAnd xs)++    unPAnd (PAnd ps) = concatMap unPAnd ps+    unPAnd p         = [p]+++splitPred f (Pr ps) = (Pr ps1, Pr ps2)+  where+    (ps1, ps2) = partition g ps+    g p = any (isFree f) (thd3 <$> pargs p)+++class IsFree a where+        isFree :: Symbol -> a -> Bool++instance (Subable x) => (IsFree x) where+        isFree x p = x `elem` syms p++instance Show (UReft Reft) where+         show = render . pprint
+ src/Language/Haskell/Liquid/Transforms/Simplify.hs view
@@ -0,0 +1,43 @@+module Language.Haskell.Liquid.Transforms.Simplify (simplifyBounds) where++import Prelude hiding (error)+import Language.Haskell.Liquid.Types+import Language.Fixpoint.Types+import Language.Fixpoint.Types.Visitor+-- import Control.Applicative                 ((<$>))+++simplifyBounds :: SpecType -> SpecType+simplifyBounds = fmap go+  where+    go x       = x { ur_reft = go' $ ur_reft x }+    -- OLD go' (Reft (v, rs)) = Reft(v, filter (not . isBoundLike) rs)+    go' (Reft (v, p)) = Reft(v, dropBoundLike p)++dropBoundLike :: Expr -> Expr+dropBoundLike p+  | isKvar p          = p+  | isBoundLikePred p = mempty+  | otherwise         = p+  where+    isKvar            = not . null . kvars++isBoundLikePred :: Expr -> Bool+isBoundLikePred (PAnd ps) = simplifyLen <= length [p | p <- ps, isImp p ]+isBoundLikePred _         = False++isImp :: Expr -> Bool+isImp (PImp _ _) = True+isImp _          = False++-- OLD isBoundLike (RConc pred)  = isBoundLikePred pred+-- OLD isBoundLike (RKvar _ _)   = False+++-- OLD moreThan 0 _            = True+-- OLD moreThan _ []           = False+-- OLD moreThan i (True  : xs) = moreThan (i-1) xs+-- OLD moreThan i (False : xs) = moreThan i xs++simplifyLen :: Int+simplifyLen = 5
src/Language/Haskell/Liquid/Types.hs view
@@ -1,1857 +1,1662 @@ {-# LANGUAGE StandaloneDeriving         #-} {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveTraversable          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE TypeSynonymInstances       #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE OverlappingInstances       #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE RecordWildCards            #-}---- | This module should contain all the global type definitions and basic instances.--{-@ LIQUID "--cabaldir" @-}--module Language.Haskell.Liquid.Types (--  -- * Options-    Config (..)--  -- * Ghc Information-  , GhcInfo (..)-  , GhcSpec (..)-  , TargetVars (..)--  -- * Located Things-  , Located (..)-  , dummyLoc--  -- * Symbols-  , LocSymbol-  , LocText--  -- * Default unknown name-  , dummyName, isDummy--  -- * Refined Type Constructors-  , RTyCon (RTyCon, rtc_tc, rtc_info)-  , TyConInfo(..), defaultTyConInfo-  , rTyConPVs-  , rTyConPropVs-  , isClassRTyCon, isClassType--  -- * Refinement Types-  , RType (..), Ref(..), RTProp-  , RTyVar (..)-  , RTAlias (..)--  -- * Worlds-  , HSeg (..)-  , World (..)--  -- * Classes describing operations on `RTypes`-  , TyConable (..)-  , RefTypable (..)-  , SubsTy (..)--  -- * Predicate Variables-  , PVar (PV, pname, parg, ptype, pargs), isPropPV, pvType-  , PVKind (..)-  , Predicate (..)--  -- * Refinements-  , UReft(..)--  -- * Parse-time entities describing refined data types-  , DataDecl (..)-  , DataConP (..)-  , TyConP (..)--  -- * Pre-instantiated RType-  , RRType, BRType, RRProp-  , BSort, BPVar--  -- * Instantiated RType-  , BareType, PrType-  , SpecType, SpecProp-  , RSort-  , UsedPVar, RPVar, RReft-  , REnv (..)--  -- * Constructing & Destructing RTypes-  , RTypeRep(..), fromRTypeRep, toRTypeRep-  , mkArrow, bkArrowDeep, bkArrow, safeBkArrow-  , mkUnivs, bkUniv, bkClass-  , rFun, rCls, rRCls--  -- * Manipulating `Predicates`-  , pvars, pappSym, pApp--  -- * Some tests on RTypes-  , isBase-  , isFunTy-  , isTrivial--  -- * Traversing `RType`-  , efoldReft, foldReft-  , mapReft, mapReftM-  , mapBot, mapBind--  -- * ???-  , Oblig(..)-  , ignoreOblig-  , addTermCond-  , addInvCond---  -- * Inferred Annotations-  , AnnInfo (..)-  , Annot (..)--  -- * Overall Output-  , Output (..)--  -- * Refinement Hole-  , hole, isHole, hasHole--  -- * Converting To and From Sort-  , ofRSort, toRSort-  , rTypeValueVar-  , rTypeReft-  , stripRTypeBase--  -- * Class for values that can be pretty printed-  , PPrint (..)-  , showpp--  -- * Printer Configuration-  , PPEnv (..)-  , Tidy  (..)-  , ppEnv-  , ppEnvShort--  -- * Modules and Imports-  , ModName (..), ModType (..)-  , isSrcImport, isSpecImport-  , getModName, getModString--  -- * Refinement Type Aliases-  , RTEnv (..)-  , mapRT, mapRP, mapRE--  -- * Final Result-  , Result (..)--  -- * Errors and Error Messages-  , Error-  , TError (..)-  , EMsg (..)-  -- , LParseError (..)-  , ErrorResult-  , errSpan-  , errOther-  , errToFCrash--  -- * Source information (associated with constraints)-  , Cinfo (..)--  -- * Measures-  , Measure (..)-  , CMeasure (..)-  , Def (..)-  , Body (..)--  -- * Type Classes-  , RClass (..)--  -- * KV Profiling-  , KVKind (..)   -- types of kvars-  , KVProf        -- profile table-  , emptyKVProf   -- empty profile-  , updKVProf     -- extend profile--  -- * Misc-  , mapRTAVars-  , insertsSEnv--  -- * Strata-  , Stratum(..), Strata-  , isSVar-  , getStrata-  , makeDivType, makeFinType--  -- * CoreToLogic-  , LogicMap, toLogicMap, eAppWithMap, LMap(..)--  -- * Refined Instances-  , RDEnv, DEnv(..), RInstance(..)--  -- * Ureftable Instances-  , UReftable(..)--  -- * String Literals-  , liquidBegin, liquidEnd-  )-  where--import SrcLoc                                   (noSrcSpan, SrcSpan)-import TyCon-import DataCon-import NameSet-import Module                                   (moduleNameFS)-import TypeRep                          hiding  (maybeParen, pprArrowChain)-import Var-import Text.Printf-import GHC                                      (HscEnv, ModuleName, moduleNameString)-import GHC.Generics-import Language.Haskell.Liquid.GhcMisc--import PrelInfo         (isNumericClass)---import TysWiredIn                               (listTyCon)-import Control.Arrow                            (second)-import Control.Monad                            (liftM, liftM2, liftM3, liftM4)-import qualified Control.Monad.Error as Ex-import Control.DeepSeq-import Control.Applicative                      ((<$>))-import Data.Typeable                            (Typeable)-import Data.Generics                            (Data)-import Data.Monoid                              hiding ((<>))-import qualified  Data.Foldable as F-import            Data.Hashable-import qualified  Data.HashMap.Strict as M-import qualified  Data.HashSet as S-import            Data.Maybe                   (fromMaybe)-import            Data.Traversable             hiding (mapM)-import            Data.List                    (nub)-import            Data.Text                    (Text)-import qualified  Data.Text                    as T-import Text.Parsec.Pos              (SourcePos)-import Text.Parsec.Error            (ParseError)-import Text.PrettyPrint.HughesPJ-import Language.Fixpoint.Config     hiding (Config)-import Language.Fixpoint.Misc-import Language.Fixpoint.Types      hiding (Result, Predicate, Def, R)-import Language.Fixpoint.Names      (funConName, listConName, tupConName)-import qualified Language.Fixpoint.PrettyPrint as F-import CoreSyn (CoreBind)--import Language.Haskell.Liquid.Variance-import Language.Haskell.Liquid.Misc (mapSndM, safeZip3WithError)---import Data.Default--------------------------------------------------------------------------------- | Command Line Config Options ------------------------------------------------------------------------------------------------------------------------------ NOTE: adding strictness annotations breaks the help message-data Config = Config {-    files          :: [FilePath] -- ^ source files to check-  , idirs          :: [FilePath] -- ^ path to directory for including specs-  , diffcheck      :: Bool       -- ^ check subset of binders modified (+ dependencies) since last check-  , real           :: Bool       -- ^ supports real number arithmetic-  , fullcheck      :: Bool       -- ^ check all binders (overrides diffcheck)-  , native         :: Bool       -- ^ use native (Haskell) fixpoint constraint solver-  , binders        :: [String]   -- ^ set of binders to check-  , noCheckUnknown :: Bool       -- ^ whether to complain about specifications for unexported and unused values-  , notermination  :: Bool       -- ^ disable termination check-  , nowarnings     :: Bool       -- ^ disable warnings output (only show errors)-  , trustinternals :: Bool       -- ^ type all internal variables with true-  , nocaseexpand   :: Bool       -- ^ disable case expand-  , strata         :: Bool       -- ^ enable strata analysis-  , notruetypes    :: Bool       -- ^ disable truing top level types-  , totality       :: Bool       -- ^ check totality in definitions-  , noPrune        :: Bool       -- ^ disable prunning unsorted Refinements-  , maxParams      :: Int        -- ^ the maximum number of parameters to accept when mining qualifiers-  , smtsolver      :: Maybe SMTSolver  -- ^ name of smtsolver to use [default: try z3, cvc4, mathsat in order]-  , shortNames     :: Bool       -- ^ drop module qualifers from pretty-printed names.-  , shortErrors    :: Bool       -- ^ don't show subtyping errors and contexts.-  , cabalDir       :: Bool       -- ^ find and use .cabal file to include paths to sources for imported modules-  , ghcOptions     :: [String]   -- ^ command-line options to pass to GHC-  , cFiles         :: [String]   -- ^ .c files to compile and link against (for GHC)-  } deriving (Data, Typeable, Show, Eq)----------------------------------------------------------------------------------- | Printer ------------------------------------------------------------------------------------------------------------------------------------------------data Tidy = Lossy | Full deriving (Eq, Ord)--class PPrint a where-  pprint     :: a -> Doc--  pprintTidy :: Tidy -> a -> Doc-  pprintTidy _ = pprint--showpp :: (PPrint a) => a -> String-showpp = render . pprint--instance PPrint a => PPrint (Maybe a) where-  pprint = maybe (text "Nothing") ((text "Just" <+>) . pprint)--instance PPrint a => PPrint [a] where-  pprint = brackets . intersperse comma . map pprint--instance (PPrint a, PPrint b) => PPrint (a,b) where-  pprint (x, y)  = pprint x <+> text ":" <+> pprint y--data PPEnv-  = PP { ppPs    :: Bool-       , ppTyVar :: Bool -- TODO if set to True all Bare fails-       , ppSs    :: Bool-       , ppShort :: Bool-       }--ppEnv           = ppEnvPrintPreds-_ppEnvCurrent    = PP False False False False-ppEnvPrintPreds = PP False False False False-ppEnvShort pp   = pp { ppShort = True }------------------------------------------------------------------------- | GHC Information :  Code & Spec ---------------------------------------------------------------------------------------------------data GhcInfo = GI {-    env      :: !HscEnv-  , cbs      :: ![CoreBind]-  , derVars  :: ![Var]-  , impVars  :: ![Var]-  , defVars  :: ![Var]-  , useVars  :: ![Var]-  , hqFiles  :: ![FilePath]-  , imports  :: ![String]-  , includes :: ![FilePath]-  , spec     :: !GhcSpec-  }---- | The following is the overall type for /specifications/ obtained from--- parsing the target source and dependent libraries--data GhcSpec = SP {-    tySigs     :: ![(Var, Located SpecType)]     -- ^ Asserted Reftypes-                                                 -- eg.  see include/Prelude.spec-  , asmSigs    :: ![(Var, Located SpecType)]     -- ^ Assumed Reftypes-  , ctors      :: ![(Var, Located SpecType)]     -- ^ Data Constructor Measure Sigs-                                                 -- eg.  (:) :: a -> xs:[a] -> {v: Int | v = 1 + len(xs) }-  , meas       :: ![(Symbol, Located SpecType)]  -- ^ Measure Types-                                                 -- eg.  len :: [a] -> Int-  , invariants :: ![Located SpecType]            -- ^ Data Type Invariants-                                                 -- eg.  forall a. {v: [a] | len(v) >= 0}-  , ialiases   :: ![(Located SpecType, Located SpecType)] -- ^ Data Type Invariant Aliases-  , dconsP     :: ![(DataCon, DataConP)]         -- ^ Predicated Data-Constructors-                                                 -- e.g. see tests/pos/Map.hs-  , tconsP     :: ![(TyCon, TyConP)]             -- ^ Predicated Type-Constructors-                                                 -- eg.  see tests/pos/Map.hs-  , freeSyms   :: ![(Symbol, Var)]               -- ^ List of `Symbol` free in spec and corresponding GHC var-                                                 -- eg. (Cons, Cons#7uz) from tests/pos/ex1.hs-  , tcEmbeds   :: TCEmb TyCon                    -- ^ How to embed GHC Tycons into fixpoint sorts-                                                 -- e.g. "embed Set as Set_set" from include/Data/Set.spec-  , qualifiers :: ![Qualifier]                   -- ^ Qualifiers in Source/Spec files-                                                 -- e.g tests/pos/qualTest.hs-  , tgtVars    :: ![Var]                         -- ^ Top-level Binders To Verify (empty means ALL binders)-  , decr       :: ![(Var, [Int])]                -- ^ Lexicographically ordered size witnesses for termination-  , texprs     :: ![(Var, [Expr])]               -- ^ Lexicographically ordered expressions for termination-  , lvars      :: !(S.HashSet Var)               -- ^ Variables that should be checked in the environment they are used-  , lazy       :: !(S.HashSet Var)             -- ^ Binders to IGNORE during termination checking-  , autosize   :: !(S.HashSet TyCon)             -- ^ Binders to IGNORE during termination checking-  , config     :: !Config                        -- ^ Configuration Options-  , exports    :: !NameSet                       -- ^ `Name`s exported by the module being verified-  , measures   :: [Measure SpecType DataCon]-  , tyconEnv   :: M.HashMap TyCon RTyCon-  , dicts      :: DEnv Var SpecType              -- ^ Dictionary Environment-  }--type LogicMap = M.HashMap Symbol LMap--data LMap = LMap { lvar  :: Symbol-                 , largs :: [Symbol]-                 , lexpr :: Expr-                 }--instance Show LMap where-  show (LMap x xs e) = show x ++ " " ++ show xs ++ "\t|->\t" ++ show e---toLogicMap = M.fromList . map toLMap-  where-    toLMap (x, xs, e) = (x, LMap {lvar = x, largs = xs, lexpr = e})--eAppWithMap lmap f es def-  | Just (LMap _ xs e) <- M.lookup (val f) lmap-  = subst (mkSubst $ zip xs es) e-  | otherwise-  = def---data TyConP = TyConP { freeTyVarsTy :: ![RTyVar]-                     , freePredTy   :: ![PVar RSort]-                     , freeLabelTy  :: ![Symbol]-                     , varianceTs   :: !VarianceInfo-                     , variancePs   :: !VarianceInfo-                     , sizeFun      :: !(Maybe (Symbol -> Expr))-                     } deriving (Generic, Data, Typeable)--data DataConP = DataConP { dc_loc     :: !SourcePos-                         , freeTyVars :: ![RTyVar]-                         , freePred   :: ![PVar RSort]-                         , freeLabels :: ![Symbol]-                         , tyConsts   :: ![SpecType] -- ^ FIXME: WHAT IS THIS??-                         , tyArgs     :: ![(Symbol, SpecType)] -- ^ These are backwards, why??-                         , tyRes      :: !SpecType-                         , dc_locE    :: !SourcePos-                         } deriving (Generic, Data, Typeable)---- instance {-# OVERLAPPING #-} Data TyConP--- instance {-# OVERLAPPING #-} Data DataConP---- | Which Top-Level Binders Should be Verified-data TargetVars = AllVars | Only ![Var]-------------------------------------------------------------------------- | Abstract Predicate Variables ---------------------------------------------------------------------------------------------------------data PVar t-  = PV { pname :: !Symbol-       , ptype :: !(PVKind t)-       , parg  :: !Symbol-       , pargs :: ![(t, Symbol, Expr)]-       }-    deriving (Generic, Data, Typeable, Show)--pvType p = case ptype p of-             PVProp t -> t-             PVHProp  -> errorstar "pvType on HProp-PVar"--data PVKind t-  = PVProp t | PVHProp-    deriving (Generic, Data, Typeable, F.Foldable, Traversable, Show)--instance Eq (PVar t) where-  pv == pv' = pname pv == pname pv' {- UNIFY: What about: && eqArgs pv pv' -}--instance Ord (PVar t) where-  compare (PV n _ _ _)  (PV n' _ _ _) = compare n n'--instance Functor PVKind where-  fmap f (PVProp t) = PVProp (f t)-  fmap _ (PVHProp)  = PVHProp--instance Functor PVar where-  fmap f (PV x t v txys) = PV x (f <$> t) v (mapFst3 f <$> txys)--instance (NFData a) => NFData (PVKind a) where-  rnf (PVProp t) = rnf t-  rnf (PVHProp)  = ()--instance (NFData a) => NFData (PVar a) where-  rnf (PV n t v txys) = rnf n `seq` rnf v `seq` rnf t `seq` rnf txys--instance Hashable (PVar a) where-  hashWithSalt i (PV n _ _ _) = hashWithSalt i n------------------------------------------------------------------------------- Strictness -------------------------------------------------------------------------------------------------------------------------instance NFData Var where-  rnf x = seq x ()--instance NFData SrcSpan where-  rnf x = seq x ()----------------------------------------------------------------------------------------- Predicates -------------------------------------------------------------------------------------------------------------type UsedPVar      = PVar ()-newtype Predicate  = Pr [UsedPVar] deriving (Generic, Data, Typeable)--instance NFData Predicate where-  rnf _ = ()--instance Monoid Predicate where-  mempty       = pdTrue-  mappend p p' = pdAnd [p, p']--instance (Monoid a) => Monoid (UReft a) where-  mempty                         = U mempty mempty mempty-  mappend (U x y z) (U x' y' z') = U (mappend x x') (mappend y y') (mappend z z')---pdTrue         = Pr []-pdAnd ps       = Pr (nub $ concatMap pvars ps)-pvars (Pr pvs) = pvs--instance Subable UsedPVar where-  syms pv         = [ y | (_, x, EVar y) <- pargs pv, x /= y ]-  subst s pv      = pv { pargs = mapThd3 (subst s)  <$> pargs pv }-  substf f pv     = pv { pargs = mapThd3 (substf f) <$> pargs pv }-  substa f pv     = pv { pargs = mapThd3 (substa f) <$> pargs pv }---instance Subable Predicate where-  syms (Pr pvs)     = concatMap syms pvs-  subst s (Pr pvs)  = Pr (subst s <$> pvs)-  substf f (Pr pvs) = Pr (substf f <$> pvs)-  substa f (Pr pvs) = Pr (substa f <$> pvs)--instance Subable Qualifier where-  syms   = syms . q_body-  subst  = mapQualBody . subst-  substf = mapQualBody . substf-  substa = mapQualBody . substa--mapQualBody f q = q { q_body = f (q_body q) }--instance NFData r => NFData (UReft r) where-  rnf (U r p s) = rnf r `seq` rnf p `seq` rnf s--instance NFData Strata where-  rnf _ = ()--instance NFData PrType where-  rnf _ = ()--instance NFData RTyVar where-  rnf _ = ()----- MOVE TO TYPES-newtype RTyVar = RTV TyVar deriving (Generic, Data, Typeable)--instance Symbolic RTyVar where-  symbol (RTV tv) = symbol . T.pack . showPpr $ tv---data RTyCon = RTyCon-  { rtc_tc    :: TyCon         -- ^ GHC Type Constructor-  , rtc_pvars :: ![RPVar]      -- ^ Predicate Parameters-  , rtc_info  :: !TyConInfo    -- ^ TyConInfo-  }-  deriving (Generic, Data, Typeable)---- | Accessors for @RTyCon@---isClassRTyCon = isClassTyCon . rtc_tc-rTyConPVs     = rtc_pvars-rTyConPropVs  = filter isPropPV . rtc_pvars-isPropPV      = isProp . ptype----isClassType (RApp c _ _ _) = isClass c-isClassType _              = False---- rTyConPVHPs = filter isHPropPV . rtc_pvars--- isHPropPV   = not . isPropPV--isProp (PVProp _) = True-isProp _          = False---defaultTyConInfo = TyConInfo [] [] Nothing--instance Default TyConInfo where-  def = defaultTyConInfo----------------------------------------------------------------------------- | Co- and Contra-variance for TyCon ------------------------------------------------------------------------------------------------------------ | Indexes start from 0 and type or predicate arguments can be both---   covariant and contravaariant e.g., for the below Foo dataType------     data Foo a b c d <p :: b -> Prop, q :: Int -> Prop, r :: a -> Prop>---       = F (a<r> -> b<p>) | Q (c -> a) | G (Int<q> -> a<r>)------  there will be:------    varianceTyArgs     = [Bivariant , Covariant, Contravatiant, Invariant]---    variancePsArgs     = [Covariant, Contravatiant, Bivariant]-----data TyConInfo = TyConInfo-  { varianceTyArgs  :: !VarianceInfo             -- ^ variance info for type variables-  , variancePsArgs  :: !VarianceInfo             -- ^ variance info for predicate variables-  , sizeFunction    :: !(Maybe (Symbol -> Expr)) -- ^ logical function that computes the size of the structure-  } deriving (Generic, Data, Typeable)---- instance {-# OVERLAPPING #-} Data TyConInfo--instance Show TyConInfo where-  show (TyConInfo x y _) = show x ++ "\n" ++ show y--------------------------------------------------------------------------- Unified Representation of Refinement Types --------------------------------------------------------------------------------------------- MOVE TO TYPES-data RType c tv r-  = RVar {-      rt_var    :: !tv-    , rt_reft   :: !r-    }--  | RFun  {-      rt_bind   :: !Symbol-    , rt_in     :: !(RType c tv r)-    , rt_out    :: !(RType c tv r)-    , rt_reft   :: !r-    }--  | RAllT {-      rt_tvbind :: !tv-    , rt_ty     :: !(RType c tv r)-    }--  | RAllP {-      rt_pvbind :: !(PVar (RType c tv ()))-    , rt_ty     :: !(RType c tv r)-    }--  | RAllS {-      rt_sbind  :: !(Symbol)-    , rt_ty     :: !(RType c tv r)-    }--  | RApp  {-      rt_tycon  :: !c-    , rt_args   :: ![RType  c tv r]-    , rt_pargs  :: ![RTProp c tv r]-    , rt_reft   :: !r-    }--  | RAllE {-      rt_bind   :: !Symbol-    , rt_allarg :: !(RType c tv r)-    , rt_ty     :: !(RType c tv r)-    }--  | REx {-      rt_bind   :: !Symbol-    , rt_exarg  :: !(RType c tv r)-    , rt_ty     :: !(RType c tv r)-    }--  | RExprArg (Located Expr)                     -- ^ For expression arguments to type aliases-                                                --   see tests/pos/vector2.hs-  | RAppTy{-      rt_arg   :: !(RType c tv r)-    , rt_res   :: !(RType c tv r)-    , rt_reft  :: !r-    }--  | RRTy  {-      rt_env   :: ![(Symbol, RType c tv r)]-    , rt_ref   :: !r-    , rt_obl   :: !Oblig-    , rt_ty    :: !(RType c tv r)-    }--  | RHole r -- ^ let LH match against the Haskell type and add k-vars, e.g. `x:_`-            --   see tests/pos/Holes.hs-  deriving (Generic, Data, Typeable)--data Oblig-  = OTerm -- ^ Obligation that proves termination-  | OInv  -- ^ Obligation that proves invariants-  | OCons -- ^ Obligation that proves constraints-  deriving (Generic, Data, Typeable)--ignoreOblig (RRTy _ _ _ t) = t-ignoreOblig t              = t--instance Show Oblig where-  show OTerm = "termination-condition"-  show OInv  = "invariant-obligation"-  show OCons = "constraint-obligation"--instance PPrint Oblig where-  pprint = text . show---- | @Ref@ describes `Prop τ` and `HProp` arguments applied to type constructors.---   For example, in [a]<{\h -> v > h}>, we apply (via `RApp`)---   * the `RProp`  denoted by `{\h -> v > h}` to---   * the `RTyCon` denoted by `[]`.---   Thus, @Ref@ is used for abstract-predicate (arguments) that are associated---   with _type constructors_ i.e. whose semantics are _dependent upon_ the data-type.---   In contrast, the `Predicate` argument in `ur_pred` in the @UReft@ applies---   directly to any type and has semantics _independent of_ the data-type.--data Ref τ r t-  = RPropP {-      rf_args :: [(Symbol, τ)]-    , rf_reft :: r-    }                              -- ^ Parse-time `RProp`--  | RProp  {-      rf_args :: [(Symbol, τ)]-    , rf_body :: t-    }                              -- ^ Abstract refinement associated with `RTyCon`--  | RHProp {-      rf_args :: [(Symbol, τ)]-    , rf_heap :: World t-    }                              -- ^ Abstract heap-refinement associated with `RTyCon`-  deriving (Generic, Data, Typeable)---- | @RTProp@ is a convenient alias for @Ref@ that will save a bunch of typing.---   In general, perhaps we need not expose @Ref@ directly at all.-type RTProp c tv r = Ref (RType c tv ()) r (RType c tv r)----- | A @World@ is a Separation Logic predicate that is essentially a sequence of binders---   that satisfies two invariants (TODO:LIQUID):---   1. Each `hs_addr :: Symbol` appears at most once,---   2. There is at most one `HVar` in a list.--newtype World t = World [HSeg t]-                deriving (Generic, Data, Typeable)--data    HSeg  t = HBind {hs_addr :: !Symbol, hs_val :: t}-                | HVar UsedPVar-                deriving (Generic, Data, Typeable)--data UReft r-  = U { ur_reft :: !r, ur_pred :: !Predicate, ur_strata :: !Strata }-    deriving (Generic, Data, Typeable)--type BRType     = RType LocSymbol Symbol-type RRType     = RType RTyCon    RTyVar--type BSort      = BRType    ()-type RSort      = RRType    ()--type BPVar      = PVar      BSort-type RPVar      = PVar      RSort--type RReft      = UReft     Reft-type PrType     = RRType    Predicate-type BareType   = BRType    RReft-type SpecType   = RRType    RReft-type SpecProp   = RRProp    RReft-type RRProp r   = Ref       RSort r (RRType r)---data Stratum    = SVar Symbol | SDiv | SWhnf | SFin-                  deriving (Generic, Data, Typeable, Eq)--type Strata = [Stratum]--isSVar (SVar _) = True-isSVar _        = False--instance Monoid Strata where-  mempty        = []-  mappend s1 s2 = nub $ s1 ++ s2--class SubsTy tv ty a where-  subt :: (tv, ty) -> a -> a--class (Eq c) => TyConable c where-  isFun    :: c -> Bool-  isList   :: c -> Bool-  isTuple  :: c -> Bool-  ppTycon  :: c -> Doc-  isClass  :: c -> Bool--  isNumCls  :: c -> Bool-  isFracCls :: c -> Bool--  isClass   = const False-  isNumCls  = const False-  isFracCls = const False--class ( TyConable c-      , Eq c, Eq tv-      , Hashable tv-      , Reftable r-      , PPrint r-      ) => RefTypable c tv r-  where---     ppCls    :: p -> [RType c tv r] -> Doc-    ppRType  :: Prec -> RType c tv r -> Doc-------------------------------------------------------------------------------------- | TyConable Instances ------------------------------------------------------------------------------------------------------------------------------------------- MOVE TO TYPES-instance TyConable RTyCon where-  isFun      = isFunTyCon . rtc_tc-  isList     = (listTyCon ==) . rtc_tc-  isTuple    = TyCon.isTupleTyCon   . rtc_tc-  isClass    = isClassRTyCon-  ppTycon    = toFix--  isNumCls c  = maybe False isNumericClass    (tyConClass_maybe $ rtc_tc c)-  isFracCls c = maybe False isFractionalClass (tyConClass_maybe $ rtc_tc c)---- MOVE TO TYPES-instance TyConable Symbol where-  isFun   s = funConName == s-  isList  s = listConName == s-  isTuple s = tupConName == s-  ppTycon = text . symbolString--instance TyConable LocSymbol where-  isFun   = isFun . val-  isList  = isList . val-  isTuple = isTuple . val-  ppTycon = ppTycon . val---instance Eq RTyCon where-  x == y = rtc_tc x == rtc_tc y--instance Fixpoint RTyCon where-  toFix (RTyCon c _ _) = text $ showPpr c -- <+> text "\n<<" <+> hsep (map toFix ts) <+> text ">>\n"--instance Fixpoint Cinfo where-  toFix = text . showPpr . ci_loc--instance PPrint RTyCon where-  pprint = text . showPpr . rtc_tc---instance Show RTyCon where-  show = showpp------------------------------------------------------------------------------- | Refined Instances --------------------------------------------------------------------------------------------------------------------------------data RInstance t = RI { riclass :: LocSymbol-                      , ritype  :: t-                      , risigs  :: [(LocSymbol, t)]-                      }--newtype DEnv x ty = DEnv (M.HashMap x (M.HashMap Symbol ty)) deriving (Monoid)--type RDEnv = DEnv Var SpecType--instance Functor RInstance where-  fmap f (RI x t xts) = RI x (f t) (mapSnd f <$> xts)-------------------------------------------------------------------------------- | Values Related to Specifications -------------------------------------------------------------------------------------------------------------------- | Data type refinements-data DataDecl   = D { tycName   :: LocSymbol-                                -- ^ Type  Constructor Name-                    , tycTyVars :: [Symbol]-                                -- ^ Tyvar Parameters-                    , tycPVars  :: [PVar BSort]-                                -- ^ PVar  Parameters-                    , tycTyLabs :: [Symbol]-                                -- ^ PLabel  Parameters-                    , tycDCons  :: [(LocSymbol, [(Symbol, BareType)])]-                                -- ^ [DataCon, [(fieldName, fieldType)]]-                    , tycSrcPos :: !SourcePos-                                -- ^ Source Position-                    , tycSFun   :: (Maybe (Symbol -> Expr))-                                -- ^ Measure that should decrease in recursive calls-                    }-     --              deriving (Show)---instance Eq DataDecl where-   d1 == d2 = (tycName d1) == (tycName d2)--instance Ord DataDecl where-   compare d1 d2 = compare (tycName d1) (tycName d2)---- | For debugging.-instance Show DataDecl where-  show dd = printf "DataDecl: data = %s, tyvars = %s"-              (show $ tycName   dd)-              (show $ tycTyVars dd)---- | Refinement Type Aliases--data RTAlias tv ty-  = RTA { rtName  :: Symbol-        , rtTArgs :: [tv]-        , rtVArgs :: [tv]-        , rtBody  :: ty-        , rtPos   :: SourcePos-        , rtPosE  :: SourcePos-        }--mapRTAVars f rt = rt { rtTArgs = f <$> rtTArgs rt-                     , rtVArgs = f <$> rtVArgs rt-                     }----------------------------------------------------------------------------- | Constructor and Destructors for RTypes -------------------------------------------------------------------------------------------------------data RTypeRep c tv r-  = RTypeRep { ty_vars   :: [tv]-             , ty_preds  :: [PVar (RType c tv ())]-             , ty_labels :: [Symbol]-             , ty_binds  :: [Symbol]-             , ty_refts  :: [r]-             , ty_args   :: [RType c tv r]-             , ty_res    :: (RType c tv r)-             }--fromRTypeRep (RTypeRep {..})-  = mkArrow ty_vars ty_preds ty_labels arrs ty_res-  where-    arrs = safeZip3WithError "fromRTypeRep" ty_binds ty_args ty_refts--toRTypeRep           :: RType c tv r -> RTypeRep c tv r-toRTypeRep t         = RTypeRep αs πs ls xs rs ts t''-  where-    (αs, πs, ls, t')  = bkUniv  t-    (xs, ts, rs, t'') = bkArrow t'--mkArrow αs πs ls xts = mkUnivs αs πs ls . mkArrs xts-  where-    mkArrs xts t  = foldr (\(b,t1,r) t2 -> RFun b t1 t2 r) t xts--bkArrowDeep (RAllT _ t)     = bkArrowDeep t-bkArrowDeep (RAllP _ t)     = bkArrowDeep t-bkArrowDeep (RAllS _ t)     = bkArrowDeep t-bkArrowDeep (RFun x t t' r) = let (xs, ts, rs, t'') = bkArrowDeep t'  in (x:xs, t:ts, r:rs, t'')-bkArrowDeep t               = ([], [], [], t)--bkArrow (RFun x t t' r) = let (xs, ts, rs, t'') = bkArrow t'  in (x:xs, t:ts, r:rs, t'')-bkArrow t               = ([], [], [], t)--safeBkArrow (RAllT _ _) = errorstar "safeBkArrow on RAllT"-safeBkArrow (RAllP _ _) = errorstar "safeBkArrow on RAllP"-safeBkArrow (RAllS _ t) = safeBkArrow t-safeBkArrow t           = bkArrow t--mkUnivs αs πs ls t = foldr RAllT (foldr RAllP (foldr RAllS t ls) πs) αs--bkUniv :: RType t1 a t2 -> ([a], [PVar (RType t1 a ())], [Symbol], RType t1 a t2)-bkUniv (RAllT α t)      = let (αs, πs, ls, t') = bkUniv t in  (α:αs, πs, ls, t')-bkUniv (RAllP π t)      = let (αs, πs, ls, t') = bkUniv t in  (αs, π:πs, ls, t')-bkUniv (RAllS s t)      = let (αs, πs, ss, t') = bkUniv t in  (αs, πs, s:ss, t')-bkUniv t                = ([], [], [], t)--bkClass (RFun _ (RApp c t _ _) t' _)-  | isClass c-  = let (cs, t'') = bkClass t' in ((c, t):cs, t'')-bkClass (RRTy e r o t)-  = let (cs, t') = bkClass t in (cs, RRTy e r o t')-bkClass t-  = ([], t)--rFun b t t' = RFun b t t' mempty-rCls c ts   = RApp (RTyCon c [] defaultTyConInfo) ts [] mempty-rRCls rc ts = RApp rc ts [] mempty--addTermCond = addObligation OTerm--addInvCond :: SpecType -> RReft -> SpecType-addInvCond t r'-  | isTauto $ ur_reft r' -- null rv-  = t-  | otherwise-  = fromRTypeRep $ trep {ty_res = RRTy [(x', tbd)] r OInv tbd}-  where-    trep = toRTypeRep t-    tbd  = ty_res trep-    r    = r' {ur_reft = Reft (v, Refa rx)}-    su   = (v, EVar x')-    x'   = "xInv"-    rx   = PIff (PBexp $ EVar v) $ subst1 (raPred rv) su-    Reft(v, rv) = ur_reft r'--addObligation :: Oblig -> SpecType -> RReft -> SpecType-addObligation o t r  = mkArrow αs πs ls xts $ RRTy [] r o t2-  where-    (αs, πs, ls, t1) = bkUniv t-    (xs, ts, rs, t2) = bkArrow t1-    xts              = zip3 xs ts rs------------------------------------------------instance Subable Stratum where-  syms (SVar s) = [s]-  syms _        = []-  subst su (SVar s) = SVar $ subst su s-  subst _ s         = s-  substf f (SVar s) = SVar $ substf f s-  substf _ s        = s-  substa f (SVar s) = SVar $ substa f s-  substa _ s        = s--instance Subable Strata where-  syms s     = concatMap syms s-  subst su   = (subst su <$>)-  substf f   = (substf f <$>)-  substa f   = (substa f <$>)--instance Reftable Strata where-  isTauto []         = True-  isTauto _          = False--  ppTy _             = error "ppTy on Strata"-  toReft _           = mempty-  params s           = [l | SVar l <- s]-  bot _              = []-  top _              = []--  ofReft = error "TODO: Strata.ofReft"---class Reftable r => UReftable r where-  ofUReft :: UReft Reft -> r-  ofUReft (U r _ _) = ofReft r---instance UReftable (UReft Reft) where-   ofUReft r = r--instance UReftable () where-   ofUReft _ = mempty--instance (PPrint r, Reftable r) => Reftable (UReft r) where-  isTauto            = isTauto_ureft-  ppTy               = ppTy_ureft-  toReft (U r ps _)  = toReft r `meet` toReft ps-  params (U r _ _)   = params r-  bot (U r _ s)      = U (bot r) (Pr []) (bot s)-  top (U r p s)      = U (top r) (top p) s--  ofReft r = U (ofReft r) mempty mempty--isTauto_ureft u      = isTauto (ur_reft u) && isTauto (ur_pred u) -- && (isTauto $ ur_strata u)--ppTy_ureft u@(U r p s) d-  | isTauto_ureft  u  = d-  | otherwise         = ppr_reft r (ppTy p d) s--ppr_reft r d s       = braces (pprint v <+> colon <+> d <> ppr_str s <+> text "|" <+> pprint r')-  where-    r'@(Reft (v, _)) = toReft r--ppr_str [] = empty-ppr_str s  = text "^" <> pprint s--instance Subable r => Subable (UReft r) where-  syms (U r p _)     = syms r ++ syms p-  subst s (U r z l)  = U (subst s r) (subst s z) (subst s l)-  substf f (U r z l) = U (substf f r) (substf f z) (substf f l)-  substa f (U r z l) = U (substa f r) (substa f z) (substa f l)--instance (Reftable r, RefTypable c tv r) => Subable (RTProp c tv r) where-  syms (RPropP ss r)     = (fst <$> ss) ++ syms r-  syms (RProp  ss r)     = (fst <$> ss) ++ syms r-  syms (RHProp _  _)     = error "TODO: PHProp.syms"--  subst su (RPropP ss r) = RPropP ss (subst su r)-  subst su (RProp  ss t) = RProp ss (subst su <$> t)-  subst _  (RHProp _  _) = error "TODO: PHProp.subst"--  substf f (RPropP ss r) = RPropP ss (substf f r)-  substf f (RProp  ss t) = RProp ss (substf f <$> t)-  substf _ (RHProp _  _) = error "TODO PHProp.substf"-  substa f (RPropP ss r) = RPropP ss (substa f r)-  substa f (RProp  ss t) = RProp ss (substa f <$> t)-  substa _ (RHProp _  _) = error "TODO PHProp.substa"--instance (Subable r, RefTypable c tv r) => Subable (RType c tv r) where-  syms        = foldReft (\r acc -> syms r ++ acc) []-  substa f    = mapReft (substa f)-  substf f    = emapReft (substf . substfExcept f) []-  subst su    = emapReft (subst  . substExcept su) []-  subst1 t su = emapReft (\xs r -> subst1Except xs r su) [] t-----instance Reftable Predicate where-  isTauto (Pr ps)      = null ps--  bot (Pr _)           = errorstar "No BOT instance for Predicate"-  -- NV: This does not print abstract refinements....-  -- HACK: Hiding to not render types in WEB DEMO. NEED TO FIX.-  ppTy r d | isTauto r        = d-           | not (ppPs ppEnv) = d-           | otherwise        = d <> (angleBrackets $ pprint r)--  toReft (Pr ps@(p:_))        = Reft (parg p, refa $ pToRef <$> ps)-  toReft _                    = mempty-  params                      = errorstar "TODO: instance of params for Predicate"--  ofReft = error "TODO: Predicate.ofReft"--pToRef p = pApp (pname p) $ (EVar $ parg p) : (thd3 <$> pargs p)--pApp      :: Symbol -> [Expr] -> Pred-pApp p es = PBexp $ EApp (dummyLoc $ pappSym $ length es) (EVar p:es)--pappSym n  = symbol $ "papp" ++ show n--------------------------------------------------------------------------------------------- Visitors --------------------------------------------------------------------------------------------isTrivial t = foldReft (\r b -> isTauto r && b) True t--instance Functor UReft where-  fmap f (U r p s) = U (f r) p s--instance Functor (RType a b) where-  fmap  = mapReft---- instance Fold.Foldable (RType a b c) where---   foldr = foldReft--mapReft ::  (r1 -> r2) -> RType c tv r1 -> RType c tv r2-mapReft f = emapReft (\_ -> f) []--emapReft ::  ([Symbol] -> r1 -> r2) -> [Symbol] -> RType c tv r1 -> RType c tv r2--emapReft f γ (RVar α r)          = RVar  α (f γ r)-emapReft f γ (RAllT α t)         = RAllT α (emapReft f γ t)-emapReft f γ (RAllP π t)         = RAllP π (emapReft f γ t)-emapReft f γ (RAllS p t)         = RAllS p (emapReft f γ t)-emapReft f γ (RFun x t t' r)     = RFun  x (emapReft f γ t) (emapReft f (x:γ) t') (f γ r)-emapReft f γ (RApp c ts rs r)    = RApp  c (emapReft f γ <$> ts) (emapRef f γ <$> rs) (f γ r)-emapReft f γ (RAllE z t t')      = RAllE z (emapReft f γ t) (emapReft f γ t')-emapReft f γ (REx z t t')        = REx   z (emapReft f γ t) (emapReft f γ t')-emapReft _ _ (RExprArg e)        = RExprArg e-emapReft f γ (RAppTy t t' r)     = RAppTy (emapReft f γ t) (emapReft f γ t') (f γ r)-emapReft f γ (RRTy e r o t)      = RRTy  (mapSnd (emapReft f γ) <$> e) (f γ r) o (emapReft f γ t)-emapReft f γ (RHole r)           = RHole (f γ r)--emapRef :: ([Symbol] -> t -> s) ->  [Symbol] -> RTProp c tv t -> RTProp c tv s-emapRef  f γ (RPropP s r)         = RPropP s $ f γ r-emapRef  f γ (RProp  s t)         = RProp s $ emapReft f γ t-emapRef  _ _ (RHProp _ _)         = error "TODO: PHProp empaReft"----------------------------------------------------------------------------------------------------------- isBase' x t = traceShow ("isBase: " ++ showpp x) $ isBase t---- isBase :: RType a -> Bool-isBase (RAllT _ t)      = isBase t-isBase (RAllP _ t)      = isBase t-isBase (RVar _ _)       = True-isBase (RApp _ ts _ _)  = all isBase ts-isBase (RFun _ t1 t2 _) = isBase t1 && isBase t2-isBase (RAppTy t1 t2 _) = isBase t1 && isBase t2-isBase (RRTy _ _ _ t)   = isBase t-isBase (RAllE _ _ t)    = isBase t-isBase _                = False--isFunTy (RAllE _ _ t)    = isFunTy t-isFunTy (RAllS _ t)      = isFunTy t-isFunTy (RAllT _ t)      = isFunTy t-isFunTy (RAllP _ t)      = isFunTy t-isFunTy (RFun _ _ _ _)   = True-isFunTy _                = False---mapReftM :: (Monad m) => (r1 -> m r2) -> RType c tv r1 -> m (RType c tv r2)-mapReftM f (RVar α r)         = liftM   (RVar  α)   (f r)-mapReftM f (RAllT α t)        = liftM   (RAllT α)   (mapReftM f t)-mapReftM f (RAllP π t)        = liftM   (RAllP π)   (mapReftM f t)-mapReftM f (RAllS s t)        = liftM   (RAllS s)   (mapReftM f t)-mapReftM f (RFun x t t' r)    = liftM3  (RFun x)    (mapReftM f t)          (mapReftM f t')       (f r)-mapReftM f (RApp c ts rs r)   = liftM3  (RApp  c)   (mapM (mapReftM f) ts)  (mapM (mapRefM f) rs) (f r)-mapReftM f (RAllE z t t')     = liftM2  (RAllE z)   (mapReftM f t)          (mapReftM f t')-mapReftM f (REx z t t')       = liftM2  (REx z)     (mapReftM f t)          (mapReftM f t')-mapReftM _ (RExprArg e)       = return  $ RExprArg e-mapReftM f (RAppTy t t' r)    = liftM3  RAppTy (mapReftM f t) (mapReftM f t') (f r)-mapReftM f (RHole r)          = liftM   RHole       (f r)-mapReftM f (RRTy xts r o t)   = liftM4  RRTy (mapM (mapSndM (mapReftM f)) xts) (f r) (return o) (mapReftM f t)--mapRefM  :: (Monad m) => (t -> m s) -> (RTProp c tv t) -> m (RTProp c tv s)-mapRefM  f (RPropP s r)       = liftM   (RPropP s)     (f r)-mapRefM  f (RProp  s t)       = liftM   (RProp s)      (mapReftM f t)-mapRefM  _ (RHProp _ _)       = error "TODO PHProp.mapRefM"---- foldReft :: (r -> a -> a) -> a -> RType c tv r -> a-foldReft f = efoldReft (\_ _ -> []) (\_ -> ()) (\_ _ -> f) (\_ γ -> γ) emptySEnv---- efoldReft :: Reftable r =>(p -> [RType c tv r] -> [(Symbol, a)])-> (RType c tv r -> a)-> (SEnv a -> Maybe (RType c tv r) -> r -> c1 -> c1)-> SEnv a-> c1-> RType c tv r-> c1-efoldReft cb g f fp = go-  where-    -- folding over RType-    go γ z me@(RVar _ r)                = f γ (Just me) r z-    go γ z (RAllT _ t)                  = go γ z t-    go γ z (RAllP p t)                  = go (fp p γ) z t-    go γ z (RAllS _ t)                  = go γ z t-    go γ z me@(RFun _ (RApp c ts _ _) t' r)-       | isClass c                      = f γ (Just me) r (go (insertsSEnv γ (cb c ts)) (go' γ z ts) t')-    go γ z me@(RFun x t t' r)           = f γ (Just me) r (go (insertSEnv x (g t) γ) (go γ z t) t')-    go γ z me@(RApp _ ts rs r)          = f γ (Just me) r (ho' γ (go' (insertSEnv (rTypeValueVar me) (g me) γ) z ts) rs)--    go γ z (RAllE x t t')               = go (insertSEnv x (g t) γ) (go γ z t) t'-    go γ z (REx x t t')                 = go (insertSEnv x (g t) γ) (go γ z t) t'-    go γ z me@(RRTy [] r _ t)          = f γ (Just me) r (go γ z t)-    go γ z me@(RRTy xts r _ t)          = f γ (Just me) r (go γ (go γ z (envtoType xts)) t)-    go γ z me@(RAppTy t t' r)           = f γ (Just me) r (go γ (go γ z t) t')-    go _ z (RExprArg _)                 = z-    go γ z me@(RHole r)                 = f γ (Just me) r z--    -- folding over Ref-    ho  γ z (RPropP ss r)               = f (insertsSEnv γ (mapSnd (g . ofRSort) <$> ss)) Nothing r z-    ho  γ z (RProp  ss t)               = go (insertsSEnv γ ((mapSnd (g . ofRSort)) <$> ss)) z t-    ho  _ _ (RHProp _  _)               = error "TODO: RHProp.ho"--    -- folding over [RType]-    go' γ z ts                 = foldr (flip $ go γ) z ts--    -- folding over [Ref]-    ho' γ z rs                 = foldr (flip $ ho γ) z rs--    envtoType xts = foldr (\(x,t1) t2 -> rFun x t1 t2) (snd $ last xts) (init xts)--mapBot f (RAllT α t)       = RAllT α (mapBot f t)-mapBot f (RAllP π t)       = RAllP π (mapBot f t)-mapBot f (RAllS s t)       = RAllS s (mapBot f t)-mapBot f (RFun x t t' r)   = RFun x (mapBot f t) (mapBot f t') r-mapBot f (RAppTy t t' r)   = RAppTy (mapBot f t) (mapBot f t') r-mapBot f (RApp c ts rs r)  = f $ RApp c (mapBot f <$> ts) (mapBotRef f <$> rs) r-mapBot f (REx b t1 t2)     = REx b  (mapBot f t1) (mapBot f t2)-mapBot f (RAllE b t1 t2)   = RAllE b  (mapBot f t1) (mapBot f t2)-mapBot f (RRTy e r o t)    = RRTy (mapSnd (mapBot f) <$> e) r o (mapBot f t)-mapBot f t'                = f t'-mapBotRef _ (RPropP s r)    = RPropP s $ r-mapBotRef f (RProp  s t)    = RProp  s $ mapBot f t-mapBotRef _ (RHProp _ _)    = error "TODO: RHProp.mapBotRef"--mapBind f (RAllT α t)      = RAllT α (mapBind f t)-mapBind f (RAllP π t)      = RAllP π (mapBind f t)-mapBind f (RAllS s t)      = RAllS s (mapBind f t)-mapBind f (RFun b t1 t2 r) = RFun (f b)  (mapBind f t1) (mapBind f t2) r-mapBind f (RApp c ts rs r) = RApp c (mapBind f <$> ts) (mapBindRef f <$> rs) r-mapBind f (RAllE b t1 t2)  = RAllE  (f b) (mapBind f t1) (mapBind f t2)-mapBind f (REx b t1 t2)    = REx    (f b) (mapBind f t1) (mapBind f t2)-mapBind _ (RVar α r)       = RVar α r-mapBind _ (RHole r)        = RHole r-mapBind f (RRTy e r o t)   = RRTy e r o (mapBind f t)-mapBind _ (RExprArg e)     = RExprArg e-mapBind f (RAppTy t t' r)  = RAppTy (mapBind f t) (mapBind f t') r--mapBindRef f (RPropP s r)   = RPropP (mapFst f <$> s) r-mapBindRef f (RProp  s t)   = RProp  (mapFst f <$> s) $ mapBind f t-mapBindRef _ (RHProp _ _)   = error "TODO: RHProp.mapBindRef"------------------------------------------------------ofRSort ::  Reftable r => RType c tv () -> RType c tv r-ofRSort = fmap mempty--toRSort :: RType c tv r -> RType c tv ()-toRSort = stripAnnotations . mapBind (const dummySymbol) . fmap (const ())--stripAnnotations (RAllT α t)      = RAllT α (stripAnnotations t)-stripAnnotations (RAllP _ t)      = stripAnnotations t-stripAnnotations (RAllS _ t)      = stripAnnotations t-stripAnnotations (RAllE _ _ t)    = stripAnnotations t-stripAnnotations (REx _ _ t)      = stripAnnotations t-stripAnnotations (RFun x t t' r)  = RFun x (stripAnnotations t) (stripAnnotations t') r-stripAnnotations (RAppTy t t' r)  = RAppTy (stripAnnotations t) (stripAnnotations t') r-stripAnnotations (RApp c ts rs r) = RApp c (stripAnnotations <$> ts) (stripAnnotationsRef <$> rs) r-stripAnnotations (RRTy _ _ _ t)   = stripAnnotations t-stripAnnotations t                = t-stripAnnotationsRef (RProp s t)   = RProp s $ stripAnnotations t-stripAnnotationsRef r             = r---insertsSEnv  = foldr (\(x, t) γ -> insertSEnv x t γ)--rTypeValueVar :: (Reftable r) => RType c tv r -> Symbol-rTypeValueVar t = vv where Reft (vv,_) =  rTypeReft t--rTypeReft :: (Reftable r) => RType c tv r -> Reft-rTypeReft = fromMaybe trueReft . fmap toReft . stripRTypeBase---- stripRTypeBase ::  RType a -> Maybe a-stripRTypeBase (RApp _ _ _ x)-  = Just x-stripRTypeBase (RVar _ x)-  = Just x-stripRTypeBase (RFun _ _ _ x)-  = Just x-stripRTypeBase (RAppTy _ _ x)-  = Just x-stripRTypeBase _-  = Nothing--mapRBase f (RApp c ts rs r) = RApp c ts rs $ f r-mapRBase f (RVar a r)       = RVar a $ f r-mapRBase f (RFun x t1 t2 r) = RFun x t1 t2 $ f r-mapRBase f (RAppTy t1 t2 r) = RAppTy t1 t2 $ f r-mapRBase _ t                = t----makeLType :: Stratum -> SpecType -> SpecType-makeLType l t = fromRTypeRep trep{ty_res = mapRBase f $ ty_res trep}-  where trep = toRTypeRep t-        f (U r p _) = U r p [l]---makeDivType = makeLType SDiv-makeFinType = makeLType SFin--getStrata = maybe [] ur_strata . stripRTypeBase---------------------------------------------------------------------------------- | PPrint -------------------------------------------------------------------------------------------------------------------------------------------------instance Show Stratum where-  show SFin = "Fin"-  show SDiv = "Div"-  show SWhnf = "Whnf"-  show (SVar s) = show s--instance PPrint Stratum where-  pprint = text . show--instance PPrint Strata where-  pprint [] = empty-  pprint ss = hsep (pprint <$> nub ss)--instance PPrint SourcePos where-  pprint = text . show--instance PPrint () where-  pprint = text . show--instance PPrint String where-  pprint = text--instance PPrint Text where-  pprint = text . T.unpack--instance PPrint a => PPrint (Located a) where-  pprint = pprint . val--instance PPrint Int where-  pprint = F.pprint--instance PPrint Integer where-  pprint = F.pprint--instance PPrint Constant where-  pprint = F.pprint--instance PPrint Brel where-  pprint = F.pprint--instance PPrint Bop where-  pprint = F.pprint--instance PPrint Sort where-  pprint = F.pprint--instance PPrint Symbol where-  pprint = pprint . symbolText--instance PPrint Expr where-  pprint = F.pprint--instance PPrint SymConst where-  pprint = F.pprint--instance PPrint Pred where-  pprint = F.pprint--instance PPrint a => PPrint (PVar a) where-  pprint (PV s _ _ xts)   = pprint s <+> hsep (pprint <$> dargs xts)-    where-      dargs               = map thd3 . takeWhile (\(_, x, y) -> EVar x /= y)--instance PPrint Predicate where-  pprint (Pr [])       = text "True"-  pprint (Pr pvs)      = hsep $ punctuate (text "&") (map pprint pvs)--instance PPrint Refa where-  pprint = pprint . raPred--instance PPrint Reft where-  pprint = F.pprint--instance PPrint SortedReft where-  pprint = F.pprint----------------------------------------------------------------------------- | Error Data Type ------------------------------------------------------------------------------------------------------------------------------- | The type used during constraint generation, used also to define contexts--- for errors, hence in this file, and NOT in Constraint.hs-newtype REnv = REnv  (M.HashMap Symbol SpecType)--type ErrorResult = FixResult Error--newtype EMsg     = EMsg String deriving (Generic, Data, Typeable)--instance PPrint EMsg where-  pprint (EMsg s) = text s---- | In the below, we use EMsg instead of, say, SpecType because---   the latter is impossible to serialize, as it contains GHC---   internals like TyCon and Class inside it.--type Error = TError SpecType----- | INVARIANT : all Error constructors should have a pos field-data TError t =-    ErrSubType { pos  :: !SrcSpan-               , msg  :: !Doc-               , ctx  :: !(M.HashMap Symbol t)-               , tact :: !t-               , texp :: !t-               } -- ^ liquid type error-  | ErrFCrash  { pos  :: !SrcSpan-               , msg  :: !Doc-               , ctx  :: !(M.HashMap Symbol t)-               , tact :: !t-               , texp :: !t-               } -- ^ liquid type error-  | ErrAssType { pos :: !SrcSpan-               , obl :: !Oblig-               , msg :: !Doc-               , ref :: !RReft-               } -- ^ liquid type error--  | ErrParse    { pos :: !SrcSpan-                , msg :: !Doc-                , err :: !ParseError-                } -- ^ specification parse error--  | ErrTySpec   { pos :: !SrcSpan-                , var :: !Doc-                , typ :: !t-                , msg :: !Doc-                } -- ^ sort error in specification--  | ErrTermSpec { pos :: !SrcSpan-                , var :: !Doc-                , exp :: !Expr-                , msg :: !Doc-                } -- ^ sort error in specification-  | ErrDupAlias { pos  :: !SrcSpan-                , var  :: !Doc-                , kind :: !Doc-                , locs :: ![SrcSpan]-                } -- ^ multiple alias with same name error--  | ErrDupSpecs { pos :: !SrcSpan-                , var :: !Doc-                , locs:: ![SrcSpan]-                } -- ^ multiple specs for same binder error--  | ErrBadData  { pos :: !SrcSpan-                , var :: !Doc-                , msg :: !Doc-                } -- ^ multiple specs for same binder error--  | ErrInvt     { pos :: !SrcSpan-                , inv :: !t-                , msg :: !Doc-                } -- ^ Invariant sort error--  | ErrIAl      { pos :: !SrcSpan-                , inv :: !t-                , msg :: !Doc-                } -- ^ Using  sort error--  | ErrIAlMis   { pos :: !SrcSpan-                , t1  :: !t-                , t2  :: !t-                , msg :: !Doc-                } -- ^ Incompatible using error--  | ErrMeas     { pos :: !SrcSpan-                , ms  :: !Symbol-                , msg :: !Doc-                } -- ^ Measure sort error--  | ErrHMeas    { pos :: !SrcSpan-                , ms  :: !Symbol-                , msg :: !Doc-                } -- ^ Haskell bad Measure error--  | ErrUnbound  { pos :: !SrcSpan-                , var :: !Doc-                } -- ^ Unbound symbol in specification--  | ErrGhc      { pos :: !SrcSpan-                , msg :: !Doc-                } -- ^ GHC error: parsing or type checking--  | ErrMismatch { pos  :: !SrcSpan-                , var  :: !Doc-                , hs   :: !Type-                , lq   :: !Type-                } -- ^ Mismatch between Liquid and Haskell types--  | ErrAliasCycle { pos    :: !SrcSpan-                  , acycle :: ![(SrcSpan, Doc)]-                  } -- ^ Cyclic Refined Type Alias Definitions--  | ErrIllegalAliasApp { pos   :: !SrcSpan-                       , dname :: !Doc-                       , dpos  :: !SrcSpan-                       } -- ^ Illegal RTAlias application (from BSort, eg. in PVar)--  | ErrAliasApp { pos   :: !SrcSpan-                , nargs :: !Int-                , dname :: !Doc-                , dpos  :: !SrcSpan-                , dargs :: !Int-                }--  | ErrSaved    { pos :: !SrcSpan-                , msg :: !Doc-                } -- ^ Previously saved error, that carries over after DiffCheck--  | ErrTermin   { bind :: ![Var]-                , pos  :: !SrcSpan-                , msg  :: !Doc-                } -- ^ Termination Error--  | ErrRClass   { pos   :: !SrcSpan-                , cls   :: !Doc-                , insts :: ![(SrcSpan, Doc)]-                } -- ^ Refined Class/Interfaces Conflict--  | ErrOther    { pos :: !SrcSpan-                , msg :: !Doc-                } -- ^ Unexpected PANIC-  deriving (Typeable, Functor)---- data LParseError = LPE !SourcePos [String]---                    deriving (Data, Typeable, Generic)-----errToFCrash :: Error -> Error-errToFCrash (ErrSubType l m g t1 t2)-  = ErrFCrash l m g t1 t2-errToFCrash e-  = e---instance Eq Error where-  e1 == e2 = pos e1 == pos e2--instance Ord Error where-  e1 <= e2 = pos e1 <= pos e2--instance Ex.Error Error where-  strMsg = errOther . pprint--errSpan :: TError a -> SrcSpan-errSpan = pos--errOther :: Doc -> Error-errOther = ErrOther noSrcSpan----------------------------------------------------------------------------- | Source Information Associated With Constraints -----------------------------------------------------------------------------------------------data Cinfo    = Ci { ci_loc :: !SrcSpan-                   , ci_err :: !(Maybe Error)-                   }-                deriving (Eq, Ord, Generic)--instance NFData Cinfo where-  rnf x = seq x ()------------------------------------------------------------------------------ | Converting Results To Answers ----------------------------------------------------------------------------------------------------------------class Result a where-  result :: a -> FixResult Error--instance Result [Error] where-  result es = Crash es ""--instance Result Error where-  result (ErrOther _ d) = UnknownError $ render d-  result e              = result [e]--instance Result (FixResult Cinfo) where-  result = fmap cinfoError-------------------------------------------------------------------------------------- Module Names-----------------------------------------------------------------------------------data ModName = ModName !ModType !ModuleName deriving (Eq,Ord)--instance Show ModName where-  show = getModString--instance Symbolic ModName where-  symbol (ModName _ m) = symbol m--instance Symbolic ModuleName where-  symbol = symbol . moduleNameFS--data ModType = Target | SrcImport | SpecImport deriving (Eq,Ord)--isSrcImport (ModName SrcImport _) = True-isSrcImport _                     = False--isSpecImport (ModName SpecImport _) = True-isSpecImport _                      = False--getModName (ModName _ m) = m--getModString = moduleNameString . getModName---------------------------------------------------------------------------------------------- Refinement Type Aliases -----------------------------------------------------------------------------------------------------------------------------data RTEnv   = RTE { typeAliases :: M.HashMap Symbol (RTAlias RTyVar SpecType)-                   , predAliases :: M.HashMap Symbol (RTAlias Symbol Pred)-                   , exprAliases :: M.HashMap Symbol (RTAlias Symbol Expr)-                   }--instance Monoid RTEnv where-  (RTE ta1 pa1 ea1) `mappend` (RTE ta2 pa2 ea2)-    = RTE (ta1 `M.union` ta2) (pa1 `M.union` pa2) (ea1 `M.union` ea2)-  mempty = RTE M.empty M.empty M.empty--mapRT f e = e { typeAliases = f $ typeAliases e }-mapRP f e = e { predAliases = f $ predAliases e }-mapRE f e = e { exprAliases = f $ exprAliases e }--cinfoError (Ci _ (Just e)) = e-cinfoError (Ci l _)        = errOther $ text $ "Cinfo:" ++ showPpr l--------------------------------------------------------------------------------------- Measures----------------------------------------------------------------------------------data Measure ty ctor = M {-    name :: LocSymbol-  , sort :: ty-  , eqns :: [Def ty ctor]-  } deriving (Data, Typeable)--data CMeasure ty-  = CM { cName :: LocSymbol-       , cSort :: ty-       }--data Def ty ctor-  = Def {-    measure :: LocSymbol-  , dparams :: [(Symbol, ty)]-  , ctor    :: ctor-  , dsort   :: Maybe ty-  , binds   :: [(Symbol, Maybe ty)]-  , body    :: Body-  } deriving (Show, Data, Typeable)-deriving instance (Eq ctor, Eq ty) => Eq (Def ty ctor)--data Body-  = E Expr          -- ^ Measure Refinement: {v | v = e }-  | P Pred          -- ^ Measure Refinement: {v | (? v) <=> p }-  | R Symbol Pred   -- ^ Measure Refinement: {v | p}-  deriving (Show, Eq, Data, Typeable)--instance Subable (Measure ty ctor) where-  syms (M _ _ es)      = concatMap syms es-  substa f  (M n s es) = M n s $ substa f  <$> es-  substf f  (M n s es) = M n s $ substf f  <$> es-  subst  su (M n s es) = M n s $ subst  su <$> es--instance Subable (Def ty ctor) where-  syms (Def _ sp _ _ sb bd)  = (fst <$> sp) ++ (fst <$> sb) ++ syms bd-  substa f  (Def m p c t b bd) = Def m p c t b $ substa f  bd-  substf f  (Def m p c t b bd) = Def m p c t b $ substf f  bd-  subst  su (Def m p c t b bd) = Def m p c t b $ subst  su bd--instance Subable Body where-  syms (E e)       = syms e-  syms (P e)       = syms e-  syms (R s e)     = s:syms e--  substa f (E e)   = E $ substa f e-  substa f (P e)   = P $ substa f e-  substa f (R s e) = R s $ substa f e--  substf f (E e)   = E $ substf f e-  substf f (P e)   = P $ substf f e-  substf f (R s e) = R s $ substf f e--  subst su (E e)   = E $ subst su e-  subst su (P e)   = P $ subst su e-  subst su (R s e) = R s $ subst su e----data RClass ty-  = RClass { rcName    :: LocSymbol-           , rcSupers  :: [ty]-           , rcTyVars  :: [Symbol]-           , rcMethods :: [(LocSymbol,ty)]-           } deriving (Show)--instance Functor RClass where-  fmap f (RClass n ss tvs ms) = RClass n (fmap f ss) tvs (fmap (second f) ms)----------------------------------------------------------------------------- | Annotations ----------------------------------------------------------------------------------------------------------------------------------newtype AnnInfo a = AI (M.HashMap SrcSpan [(Maybe Text, a)]) deriving (Generic)--data Annot t      = AnnUse t-                  | AnnDef t-                  | AnnRDf t-                  | AnnLoc SrcSpan--instance Monoid (AnnInfo a) where-  mempty                  = AI M.empty-  mappend (AI m1) (AI m2) = AI $ M.unionWith (++) m1 m2--instance Functor AnnInfo where-  fmap f (AI m) = AI (fmap (fmap (\(x, y) -> (x, f y))  ) m)---instance NFData a => NFData (AnnInfo a) where-  rnf (AI _) = ()--instance NFData (Annot a) where-  rnf (AnnDef _) = ()-  rnf (AnnRDf _) = ()-  rnf (AnnUse _) = ()-  rnf (AnnLoc _) = ()----------------------------------------------------------------------------- | Output ---------------------------------------------------------------------------------------------------------------------------------------data Output a = O { o_vars   :: Maybe [String]-                  , o_errors :: ! [Error]-                  , o_types  :: !(AnnInfo a)-                  , o_templs :: !(AnnInfo a)-                  , o_bots   :: ![SrcSpan]-                  , o_result :: FixResult Error-                  } deriving (Generic)--emptyOutput = O Nothing [] mempty mempty [] mempty--instance Monoid (Output a) where-  mempty        = emptyOutput-  mappend o1 o2 = O { o_vars   = sortNub <$> mappend (o_vars   o1) (o_vars   o2)-                    , o_errors = sortNub  $  mappend (o_errors o1) (o_errors o2)-                    , o_types  =             mappend (o_types  o1) (o_types  o2)-                    , o_templs =             mappend (o_templs o1) (o_templs o2)-                    , o_bots   = sortNub  $  mappend (o_bots o1)   (o_bots   o2)-                    , o_result =             mappend (o_result o1) (o_result o2)-                    }---------------------------------------------------------------- | KVar Profile -------------------------------------------------------------------------------------------------------data KVKind-  = RecBindE-  | NonRecBindE-  | TypeInstE-  | PredInstE-  | LamE-  | CaseE-  | LetE-  deriving (Generic, Eq, Ord, Show, Enum, Data, Typeable)--instance Hashable KVKind where-  hashWithSalt i = hashWithSalt i. fromEnum--newtype KVProf = KVP (M.HashMap KVKind Int)--emptyKVProf :: KVProf-emptyKVProf = KVP M.empty--updKVProf :: KVKind -> [KVar] -> KVProf -> KVProf-updKVProf k kvs (KVP m) = KVP $ M.insert k (kn + length kvs) m-  where-    kn                  = M.lookupDefault 0 k m--instance NFData KVKind where-  rnf z = z `seq` ()--instance PPrint KVKind where-  pprint = text . show--instance PPrint KVProf where-  pprint (KVP m) = pprint $ M.toList m--instance NFData KVProf where-  rnf (KVP m) = rnf m `seq` ()---- hasHole (toReft -> (Reft (_, rs))) = any isHole rs--hole :: Pred-hole = PKVar "HOLE" mempty--isHole :: Pred -> Bool-isHole (PKVar ("HOLE") _) = True-isHole _                  = False--hasHole :: Reftable r => r -> Bool-hasHole = any isHole . conjuncts . reftPred . toReft----- isHole :: KVar -> Bool--- isHole "HOLE" = True--- isHole _      = False----- classToRApp :: SpecType -> SpecType--- classToRApp (RCls cl ts)---   = RApp (RTyCon (classTyCon cl) def def) ts mempty mempty--instance Symbolic DataCon where-  symbol = symbol . dataConWorkId---instance PPrint DataCon where-  pprint = text . showPpr--instance Show DataCon where-  show = showpp---liquidBegin :: String-liquidBegin = ['{', '-', '@']--liquidEnd :: String-liquidEnd = ['@', '-', '}']+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE TypeSynonymInstances       #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE TemplateHaskell            #-}++-- | This module should contain all the global type definitions and basic instances.++module Language.Haskell.Liquid.Types (++  -- * Options+    Config (..)+  , HasConfig (..)+  , hasOpt++  -- * Ghc Information+  , GhcInfo (..)+  , GhcSpec (..)+  , TargetVars (..)++  -- * Located Things+  , Located (..)+  , dummyLoc++  -- * Symbols+  , LocSymbol+  , LocText++  -- * Default unknown name+  , dummyName, isDummy++  -- * Refined Type Constructors+  , RTyCon (RTyCon, rtc_tc, rtc_info)+  , TyConInfo(..), defaultTyConInfo+  , rTyConPVs+  , rTyConPropVs+  , isClassRTyCon, isClassType, isEqType++  -- * Refinement Types+  , RType (..), Ref(..), RTProp, rPropP+  , RTyVar (..)+  , RTAlias (..)++  -- * Worlds+  , HSeg (..)+  , World (..)++  -- * Classes describing operations on `RTypes`+  , TyConable (..)+  , RefTypable (..)+  , SubsTy (..)++  -- * Predicate Variables+  , PVar (PV, pname, parg, ptype, pargs), isPropPV, pvType+  , PVKind (..)+  , Predicate (..)++  -- * Refinements+  , UReft(..)++  -- * Parse-time entities describing refined data types+  , DataDecl (..)+  , DataConP (..)+  , TyConP (..)++  -- * Pre-instantiated RType+  , RRType, BRType, RRProp+  , BSort, BPVar++  -- * Instantiated RType+  , BareType, PrType+  , SpecType, SpecProp+  , RSort+  , UsedPVar, RPVar, RReft+  , REnv (..)++  -- * Constructing & Destructing RTypes+  , RTypeRep(..), fromRTypeRep, toRTypeRep+  , mkArrow, bkArrowDeep, bkArrow, safeBkArrow+  , mkUnivs, bkUniv, bkClass+  , rFun, rCls, rRCls++  -- * Manipulating `Predicates`+  , pvars, pappSym, pApp++  -- * Some tests on RTypes+  , isBase+  , isFunTy+  , isTrivial++  -- * Traversing `RType`+  , efoldReft, foldReft, foldReft'+  , mapReft, mapReftM+  , mapBot, mapBind++  -- * ???+  , Oblig(..)+  , ignoreOblig+  , addInvCond+++  -- * Inferred Annotations+  , AnnInfo (..)+  , Annot (..)++  -- * Overall Output+  , Output (..)++  -- * Refinement Hole+  , hole, isHole, hasHole++  -- * Converting To and From Sort+  , ofRSort, toRSort+  , rTypeValueVar+  , rTypeReft+  , stripRTypeBase++  -- * Class for values that can be pretty printed+  , PPrint (..), pprint+  , showpp++  -- * Printer Configuration+  , PPEnv (..)+  , ppEnv+  , ppEnvShort++  -- * Modules and Imports+  , ModName (..), ModType (..)+  , isSrcImport, isSpecImport+  , getModName, getModString++  -- * Refinement Type Aliases+  , RTEnv (..)+  , mapRT, mapRE++  -- * Errors and Error Messages+  , module Language.Haskell.Liquid.Types.Errors+  , Error+  , ErrorResult++  -- * Source information (associated with constraints)+  , Cinfo (..)++  -- * Measures+  , Measure (..)+  , CMeasure (..)+  , Def (..)+  , Body (..)+  , MSpec (..)++  -- * Type Classes+  , RClass (..)++  -- * KV Profiling+  , KVKind (..)   -- types of kvars+  , KVProf        -- profile table+  , emptyKVProf   -- empty profile+  , updKVProf     -- extend profile++  -- * Misc+  , mapRTAVars+  , insertsSEnv++  -- * Strata+  , Stratum(..), Strata+  , isSVar+  , getStrata+  , makeDivType, makeFinType++  -- * CoreToLogic+  , LogicMap(..), toLogicMap, eAppWithMap, LMap(..)++  -- * Refined Instances+  , RDEnv, DEnv(..), RInstance(..)++  -- * Ureftable Instances+  , UReftable(..)++  -- * String Literals+  , liquidBegin, liquidEnd++  , Axiom(..), HAxiom, LAxiom+  )+  where++import Prelude                          hiding  (error)+import SrcLoc                                   (SrcSpan)+import TyCon+import DataCon+import NameSet+import Module                                   (moduleNameFS)+import TypeRep                          hiding  (maybeParen, pprArrowChain)+import Var+import GHC                                      (HscEnv, ModuleName, moduleNameString)+import GHC.Generics+import Class+import CoreSyn (CoreBind, CoreExpr)+import PrelInfo         (isNumericClass)+import Type             (getClassPredTys_maybe)+import TysPrim          (eqPrimTyCon)+import TysWiredIn                               (listTyCon)+++import            Control.Monad                            (liftM, liftM2, liftM3, liftM4)+++import            Control.DeepSeq++import            Data.Bifunctor+import            Data.Bifunctor.TH+import            Data.Typeable                            (Typeable)+import            Data.Generics                            (Data)+++++import qualified  Data.Foldable as F+import            Data.Hashable+import qualified  Data.HashMap.Strict as M+import qualified  Data.HashSet as S+import            Data.Maybe                   (fromMaybe, mapMaybe)++import            Data.List                    (nub)+import            Data.Text                    (Text)+import qualified  Data.Text                    as T+++import            Text.PrettyPrint.HughesPJ    hiding (first)+import            Text.Printf++import           Language.Fixpoint.Misc+import           Language.Fixpoint.Types      hiding (Error, SrcSpan, Result, Predicate, R)+++++import Language.Haskell.Liquid.GHC.Misc+import Language.Haskell.Liquid.Types.Variance+import Language.Haskell.Liquid.Types.Errors+import Language.Haskell.Liquid.Misc+import Language.Haskell.Liquid.UX.Config+import Data.Default++-----------------------------------------------------------------------------+-- | Printer ----------------------------------------------------------------+-----------------------------------------------------------------------------++data PPEnv+  = PP { ppPs    :: Bool+       , ppTyVar :: Bool -- TODO if set to True all Bare fails+       , ppSs    :: Bool+       , ppShort :: Bool+       }++ppEnv           = ppEnvCurrent+ppEnvCurrent    = PP False False False False+_ppEnvPrintPreds = PP False False False False+ppEnvShort pp   = pp { ppShort = True }++++------------------------------------------------------------------+-- | GHC Information :  Code & Spec ------------------------------+------------------------------------------------------------------++data GhcInfo = GI {+    target   :: !FilePath+  , env      :: !HscEnv+  , cbs      :: ![CoreBind]+  , derVars  :: ![Var]+  , impVars  :: ![Var]+  , defVars  :: ![Var]+  , useVars  :: ![Var]+  , hqFiles  :: ![FilePath]+  , imports  :: ![String]+  , includes :: ![FilePath]+  , spec     :: !GhcSpec+  }++instance HasConfig GhcInfo where+  getConfig = getConfig . spec+++-- | The following is the overall type for /specifications/ obtained from+-- parsing the target source and dependent libraries++data GhcSpec = SP {+    tySigs     :: ![(Var, Located SpecType)]     -- ^ Asserted Reftypes+                                                 -- eg.  see include/Prelude.spec+  , asmSigs    :: ![(Var, Located SpecType)]     -- ^ Assumed Reftypes+  , inSigs     :: ![(Var, Located SpecType)]     -- ^ Auto generated Signatures +  , ctors      :: ![(Var, Located SpecType)]     -- ^ Data Constructor Measure Sigs+                                                 -- eg.  (:) :: a -> xs:[a] -> {v: Int | v = 1 + len(xs) }+  , meas       :: ![(Symbol, Located SpecType)]  -- ^ Measure Types+                                                 -- eg.  len :: [a] -> Int+  , invariants :: ![Located SpecType]            -- ^ Data Type Invariants+                                                 -- eg.  forall a. {v: [a] | len(v) >= 0}+  , ialiases   :: ![(Located SpecType, Located SpecType)] -- ^ Data Type Invariant Aliases+  , dconsP     :: ![(DataCon, DataConP)]         -- ^ Predicated Data-Constructors+                                                 -- e.g. see tests/pos/Map.hs+  , tconsP     :: ![(TyCon, TyConP)]             -- ^ Predicated Type-Constructors+                                                 -- eg.  see tests/pos/Map.hs+  , freeSyms   :: ![(Symbol, Var)]               -- ^ List of `Symbol` free in spec and corresponding GHC var+                                                 -- eg. (Cons, Cons#7uz) from tests/pos/ex1.hs+  , tcEmbeds   :: TCEmb TyCon                    -- ^ How to embed GHC Tycons into fixpoint sorts+                                                 -- e.g. "embed Set as Set_set" from include/Data/Set.spec+  , qualifiers :: ![Qualifier]                   -- ^ Qualifiers in Source/Spec files+                                                 -- e.g tests/pos/qualTest.hs+  , tgtVars    :: ![Var]                         -- ^ Top-level Binders To Verify (empty means ALL binders)+  , decr       :: ![(Var, [Int])]                -- ^ Lexicographically ordered size witnesses for termination+  , texprs     :: ![(Var, [Expr])]               -- ^ Lexicographically ordered expressions for termination+  , lvars      :: !(S.HashSet Var)               -- ^ Variables that should be checked in the environment they are used+  , lazy       :: !(S.HashSet Var)             -- ^ Binders to IGNORE during termination checking+  , autosize   :: !(S.HashSet TyCon)             -- ^ Binders to IGNORE during termination checking+  , config     :: !Config                        -- ^ Configuration Options+  , exports    :: !NameSet                       -- ^ `Name`s exported by the module being verified+  , measures   :: [Measure SpecType DataCon]+  , tyconEnv   :: M.HashMap TyCon RTyCon+  , dicts      :: DEnv Var SpecType              -- ^ Dictionary Environment+  , axioms     :: [HAxiom]                       -- Axioms from axiomatized functions+  , logicMap   :: LogicMap+  , proofType  :: Maybe Type+  }++instance HasConfig GhcSpec where+  getConfig = config++data LogicMap = LM { logic_map :: M.HashMap Symbol LMap+                   , axiom_map :: M.HashMap Var Symbol+                   } deriving (Show)++instance Monoid LogicMap where+  mempty                        = LM M.empty M.empty+  mappend (LM x1 x2) (LM y1 y2) = LM (M.union x1 y1) (M.union x2 y2)++data LMap = LMap { lvar  :: Symbol+                 , largs :: [Symbol]+                 , lexpr :: Expr+                 }++instance Show LMap where+  show (LMap x xs e) = show x ++ " " ++ show xs ++ "\t|->\t" ++ show e+++toLogicMap ls = mempty {logic_map = M.fromList $ map toLMap ls}+  where+    toLMap (x, xs, e) = (x, LMap {lvar = x, largs = xs, lexpr = e})++eAppWithMap lmap f es def+  | Just (LMap _ xs e) <- M.lookup (val f) (logic_map lmap), length xs == length es +  = subst (mkSubst $ zip xs es) e+  | Just (LMap _ xs e) <- M.lookup (val f) (logic_map lmap), isApp e  +  = subst (mkSubst $ zip xs es) $ dropApp e (length xs - length es)+  | otherwise+  = def++dropApp e i | i <= 0 = e +dropApp (EApp e _) i = dropApp e (i-1)+dropApp _ _          = errorstar "impossible"+ +isApp (EApp (EVar _) (EVar _)) = True +isApp (EApp e (EVar _))        = isApp e +isApp _                        = False++data TyConP = TyConP { freeTyVarsTy :: ![RTyVar]+                     , freePredTy   :: ![PVar RSort]+                     , freeLabelTy  :: ![Symbol]+                     , varianceTs   :: !VarianceInfo+                     , variancePs   :: !VarianceInfo+                     , sizeFun      :: !(Maybe (Symbol -> Expr))+                     } deriving (Generic, Data, Typeable)++data DataConP = DataConP { dc_loc     :: !SourcePos+                         , freeTyVars :: ![RTyVar]+                         , freePred   :: ![PVar RSort]+                         , freeLabels :: ![Symbol]+                         , tyConsts   :: ![SpecType] -- FIXME: WHAT IS THIS??+                         , tyArgs     :: ![(Symbol, SpecType)] -- FIXME: These are backwards, why??+                         , tyRes      :: !SpecType+                         , dc_locE    :: !SourcePos+                         } deriving (Generic, Data, Typeable)+++-- | Which Top-Level Binders Should be Verified+data TargetVars = AllVars | Only ![Var]+++--------------------------------------------------------------------+-- | Abstract Predicate Variables ----------------------------------+--------------------------------------------------------------------++data PVar t = PV+  { pname :: !Symbol+  , ptype :: !(PVKind t)+  , parg  :: !Symbol+  , pargs :: ![(t, Symbol, Expr)]+  } deriving (Generic, Data, Typeable, Show, Functor)++instance Eq (PVar t) where+  pv == pv' = pname pv == pname pv' {- UNIFY: What about: && eqArgs pv pv' -}++instance Ord (PVar t) where+  compare (PV n _ _ _)  (PV n' _ _ _) = compare n n'++instance NFData t => NFData (PVar t)++instance Hashable (PVar a) where+  hashWithSalt i (PV n _ _ _) = hashWithSalt i n++pvType :: PVar t -> t+pvType p = case ptype p of+             PVProp t -> t+             PVHProp  -> panic Nothing "pvType on HProp-PVar"++data PVKind t+  = PVProp t+  | PVHProp+  deriving (Generic, Data, Typeable, Functor, F.Foldable, Traversable, Show)++instance NFData a => NFData (PVKind a)+++--------------------------------------------------------------------+------------------ Predicates --------------------------------------+--------------------------------------------------------------------++type UsedPVar      = PVar ()+newtype Predicate  = Pr [UsedPVar] deriving (Generic, Data, Typeable)++instance NFData Predicate where+  rnf _ = ()++instance Monoid Predicate where+  mempty       = pdTrue+  mappend p p' = pdAnd [p, p']++instance (Monoid a) => Monoid (UReft a) where+  mempty                         = MkUReft mempty mempty mempty+  mappend (MkUReft x y z) (MkUReft x' y' z') = MkUReft (mappend x x') (mappend y y') (mappend z z')+++pdTrue         = Pr []+pdAnd ps       = Pr (nub $ concatMap pvars ps)+pvars (Pr pvs) = pvs++instance Subable UsedPVar where+  syms pv         = [ y | (_, x, EVar y) <- pargs pv, x /= y ]+  subst s pv      = pv { pargs = mapThd3 (subst s)  <$> pargs pv }+  substf f pv     = pv { pargs = mapThd3 (substf f) <$> pargs pv }+  substa f pv     = pv { pargs = mapThd3 (substa f) <$> pargs pv }+++instance Subable Predicate where+  syms (Pr pvs)     = concatMap syms pvs+  subst s (Pr pvs)  = Pr (subst s <$> pvs)+  substf f (Pr pvs) = Pr (substf f <$> pvs)+  substa f (Pr pvs) = Pr (substa f <$> pvs)++instance Subable Qualifier where+  syms   = syms . q_body+  subst  = mapQualBody . subst+  substf = mapQualBody . substf+  substa = mapQualBody . substa++mapQualBody f q = q { q_body = f (q_body q) }++instance NFData r => NFData (UReft r)++instance NFData RTyVar+++-- MOVE TO TYPES+newtype RTyVar = RTV TyVar deriving (Generic, Data, Typeable)++instance Symbolic RTyVar where+  symbol (RTV tv) = symbol . T.pack . showPpr $ tv+++data RTyCon = RTyCon+  { rtc_tc    :: TyCon         -- ^ GHC Type Constructor+  , rtc_pvars :: ![RPVar]      -- ^ Predicate Parameters+  , rtc_info  :: !TyConInfo    -- ^ TyConInfo+  }+  deriving (Generic, Data, Typeable)++instance NFData RTyCon++-- | Accessors for @RTyCon@+++isClassRTyCon = isClassTyCon . rtc_tc+rTyConPVs     = rtc_pvars+rTyConPropVs  = filter isPropPV . rtc_pvars+isPropPV      = isProp . ptype++isEqType (RApp c _ _ _) = isEqual c+isEqType _              = False+++isClassType (RApp c _ _ _) = isClass c+isClassType _              = False++-- rTyConPVHPs = filter isHPropPV . rtc_pvars+-- isHPropPV   = not . isPropPV++isProp (PVProp _) = True+isProp _          = False+++defaultTyConInfo = TyConInfo [] [] Nothing++instance Default TyConInfo where+  def = defaultTyConInfo+++-----------------------------------------------------------------------+-- | Co- and Contra-variance for TyCon --------------------------------+-----------------------------------------------------------------------++-- | Indexes start from 0 and type or predicate arguments can be both+--   covariant and contravaariant e.g., for the below Foo dataType+--+--     data Foo a b c d <p :: b -> Prop, q :: Int -> Prop, r :: a -> Prop>+--       = F (a<r> -> b<p>) | Q (c -> a) | G (Int<q> -> a<r>)+--+--  there will be:+--+--    varianceTyArgs     = [Bivariant , Covariant, Contravatiant, Invariant]+--    variancePsArgs     = [Covariant, Contravatiant, Bivariant]+--++data TyConInfo = TyConInfo+  { varianceTyArgs  :: !VarianceInfo             -- ^ variance info for type variables+  , variancePsArgs  :: !VarianceInfo             -- ^ variance info for predicate variables+  , sizeFunction    :: !(Maybe (Symbol -> Expr)) -- ^ logical function that computes the size of the structure+  } deriving (Generic, Data, Typeable)++instance NFData TyConInfo++instance Show TyConInfo where+  show (TyConInfo x y _) = show x ++ "\n" ++ show y++--------------------------------------------------------------------+---- Unified Representation of Refinement Types --------------------+--------------------------------------------------------------------++-- MOVE TO TYPES+data RType c tv r+  = RVar {+      rt_var    :: !tv+    , rt_reft   :: !r+    }++  | RFun  {+      rt_bind   :: !Symbol+    , rt_in     :: !(RType c tv r)+    , rt_out    :: !(RType c tv r)+    , rt_reft   :: !r+    }++  | RAllT {+      rt_tvbind :: !tv+    , rt_ty     :: !(RType c tv r)+    }++  | RAllP {+      rt_pvbind :: !(PVar (RType c tv ()))+    , rt_ty     :: !(RType c tv r)+    }++  | RAllS {+      rt_sbind  :: !(Symbol)+    , rt_ty     :: !(RType c tv r)+    }++  | RApp  {+      rt_tycon  :: !c+    , rt_args   :: ![RType  c tv r]+    , rt_pargs  :: ![RTProp c tv r]+    , rt_reft   :: !r+    }++  | RAllE {+      rt_bind   :: !Symbol+    , rt_allarg :: !(RType c tv r)+    , rt_ty     :: !(RType c tv r)+    }++  | REx {+      rt_bind   :: !Symbol+    , rt_exarg  :: !(RType c tv r)+    , rt_ty     :: !(RType c tv r)+    }++  | RExprArg (Located Expr)                     -- ^ For expression arguments to type aliases+                                                --   see tests/pos/vector2.hs+  | RAppTy{+      rt_arg   :: !(RType c tv r)+    , rt_res   :: !(RType c tv r)+    , rt_reft  :: !r+    }++  | RRTy  {+      rt_env   :: ![(Symbol, RType c tv r)]+    , rt_ref   :: !r+    , rt_obl   :: !Oblig+    , rt_ty    :: !(RType c tv r)+    }++  | RHole r -- ^ let LH match against the Haskell type and add k-vars, e.g. `x:_`+            --   see tests/pos/Holes.hs+  deriving (Generic, Data, Typeable, Functor)++instance (NFData c, NFData tv, NFData r) => NFData (RType c tv r)++ignoreOblig (RRTy _ _ _ t) = t+ignoreOblig t              = t+++-- | @Ref@ describes `Prop τ` and `HProp` arguments applied to type constructors.+--   For example, in [a]<{\h -> v > h}>, we apply (via `RApp`)+--   * the `RProp`  denoted by `{\h -> v > h}` to+--   * the `RTyCon` denoted by `[]`.+--   Thus, @Ref@ is used for abstract-predicate (arguments) that are associated+--   with _type constructors_ i.e. whose semantics are _dependent upon_ the data-type.+--   In contrast, the `Predicate` argument in `ur_pred` in the @UReft@ applies+--   directly to any type and has semantics _independent of_ the data-type.++data Ref τ t = RProp+  { rf_args :: [(Symbol, τ)]+  , rf_body :: t -- ^ Abstract refinement associated with `RTyCon`+  } deriving (Generic, Data, Typeable, Functor)++instance (NFData τ, NFData t) => NFData (Ref τ t)++rPropP τ r = RProp τ (RHole r)++-- | @RTProp@ is a convenient alias for @Ref@ that will save a bunch of typing.+--   In general, perhaps we need not expose @Ref@ directly at all.+type RTProp c tv r = Ref (RType c tv ()) (RType c tv r)+++-- | A @World@ is a Separation Logic predicate that is essentially a sequence of binders+--   that satisfies two invariants (TODO:LIQUID):+--   1. Each `hs_addr :: Symbol` appears at most once,+--   2. There is at most one `HVar` in a list.++newtype World t = World [HSeg t]+                deriving (Generic, Data, Typeable)++data    HSeg  t = HBind {hs_addr :: !Symbol, hs_val :: t}+                | HVar UsedPVar+                deriving (Generic, Data, Typeable)++data UReft r+  = MkUReft { ur_reft   :: !r+            , ur_pred   :: !Predicate+            , ur_strata :: !Strata+            }+    deriving (Generic, Data, Typeable, Functor)++type BRType     = RType LocSymbol Symbol+type RRType     = RType RTyCon    RTyVar++type BSort      = BRType    ()+type RSort      = RRType    ()++type BPVar      = PVar      BSort+type RPVar      = PVar      RSort++type RReft      = UReft     Reft+type PrType     = RRType    Predicate+type BareType   = BRType    RReft+type SpecType   = RRType    RReft+type SpecProp   = RRProp    RReft+type RRProp r   = Ref       RSort (RRType r)+++data Stratum    = SVar Symbol | SDiv | SWhnf | SFin+                  deriving (Generic, Data, Typeable, Eq)+instance NFData Stratum++type Strata = [Stratum]++isSVar (SVar _) = True+isSVar _        = False++instance {-# OVERLAPPING #-} Monoid Strata where+  mempty        = []+  mappend s1 s2 = nub $ s1 ++ s2++class SubsTy tv ty a where+  subt :: (tv, ty) -> a -> a++class (Eq c) => TyConable c where+  isFun    :: c -> Bool+  isList   :: c -> Bool+  isTuple  :: c -> Bool+  ppTycon  :: c -> Doc+  isClass  :: c -> Bool+  isEqual  :: c -> Bool++  isNumCls  :: c -> Bool+  isFracCls :: c -> Bool++  isClass   = const False+  isEqual   = const False+  isNumCls  = const False+  isFracCls = const False++class ( TyConable c+      , Eq c, Eq tv+      , Hashable tv+      , Reftable r+      , PPrint r+      ) => RefTypable c tv r+  where+    ppRType  :: Prec -> RType c tv r -> Doc++++-------------------------------------------------------------------------------+-- | TyConable Instances -------------------------------------------------------+-------------------------------------------------------------------------------++-- MOVE TO TYPES+instance TyConable RTyCon where+  isFun      = isFunTyCon . rtc_tc+  isList     = (listTyCon ==) . rtc_tc+  isTuple    = TyCon.isTupleTyCon   . rtc_tc+  isClass    = isClassRTyCon+  isEqual    = (eqPrimTyCon ==) . rtc_tc+  ppTycon    = toFix++  isNumCls c  = maybe False (isClassOrSubClass isNumericClass)+                (tyConClass_maybe $ rtc_tc c)+  isFracCls c = maybe False (isClassOrSubClass isFractionalClass)+                (tyConClass_maybe $ rtc_tc c)++isClassOrSubClass p cls+  = p cls || any (isClassOrSubClass p . fst)+                 (mapMaybe getClassPredTys_maybe (classSCTheta cls))++-- MOVE TO TYPES+instance TyConable Symbol where+  isFun   s = funConName == s+  isList  s = listConName == s+  isTuple s = tupConName == s+  ppTycon   = text . symbolString++instance TyConable LocSymbol where+  isFun   = isFun . val+  isList  = isList . val+  isTuple = isTuple . val+  ppTycon = ppTycon . val+++instance Eq RTyCon where+  x == y = rtc_tc x == rtc_tc y++instance Fixpoint RTyCon where+  toFix (RTyCon c _ _) = text $ showPpr c -- <+> text "\n<<" <+> hsep (map toFix ts) <+> text ">>\n"++instance Fixpoint Cinfo where+  toFix = text . showPpr . ci_loc++instance PPrint RTyCon where+  pprintTidy _ = text . showPpr . rtc_tc+++instance Show RTyCon where+  show = showpp++--------------------------------------------------------------------------+-- | Refined Instances ---------------------------------------------------+--------------------------------------------------------------------------++data RInstance t = RI+  { riclass :: LocSymbol+  , ritype  :: t+  , risigs  :: [(LocSymbol, t)]+  } deriving Functor++newtype DEnv x ty = DEnv (M.HashMap x (M.HashMap Symbol ty)) deriving (Monoid)++type RDEnv = DEnv Var SpecType+++--------------------------------------------------------------------------+-- | Values Related to Specifications ------------------------------------+--------------------------------------------------------------------------++data Axiom b s e = Axiom { aname  :: (Var, Maybe DataCon)+                         , abinds :: [b]+                         , atypes :: [s]+                         , alhs   :: e+                         , arhs   :: e+                         }+type HAxiom = Axiom Var Type CoreExpr+type LAxiom = Axiom Symbol Sort Expr+++instance Show (Axiom Var Type CoreExpr) where+  show (Axiom (n, c) bs _ts lhs rhs) = "Axiom : " +++                                       "\nFun Name: " ++ (showPpr n) +++                                       "\nData Con: " ++ (showPpr c) +++                                       "\nArguments:" ++ (showPpr bs)  +++                                       -- "\nTypes    :" ++ (showPpr ts)  +++                                       "\nLHS      :" ++ (showPpr lhs) +++                                       "\nRHS      :" ++ (showPpr rhs)++--------------------------------------------------------------------------+-- | Values Related to Specifications ------------------------------------+--------------------------------------------------------------------------+++-- | Data type refinements+data DataDecl   = D { tycName   :: LocSymbol+                                -- ^ Type  Constructor Name+                    , tycTyVars :: [Symbol]+                                -- ^ Tyvar Parameters+                    , tycPVars  :: [PVar BSort]+                                -- ^ PVar  Parameters+                    , tycTyLabs :: [Symbol]+                                -- ^ PLabel  Parameters+                    , tycDCons  :: [(LocSymbol, [(Symbol, BareType)])]+                                -- ^ [DataCon, [(fieldName, fieldType)]]+                    , tycSrcPos :: !SourcePos+                                -- ^ Source Position+                    , tycSFun   :: (Maybe (Symbol -> Expr))+                                -- ^ Measure that should decrease in recursive calls+                    }+     --              deriving (Show)+++instance Eq DataDecl where+   d1 == d2 = tycName d1 == tycName d2++instance Ord DataDecl where+   compare d1 d2 = compare (tycName d1) (tycName d2)++-- | For debugging.+instance Show DataDecl where+  show dd = printf "DataDecl: data = %s, tyvars = %s"+              (show $ tycName   dd)+              (show $ tycTyVars dd)++-- | Refinement Type Aliases++data RTAlias tv ty+  = RTA { rtName  :: Symbol+        , rtTArgs :: [tv]+        , rtVArgs :: [tv]+        , rtBody  :: ty+        , rtPos   :: SourcePos+        , rtPosE  :: SourcePos+        }++mapRTAVars f rt = rt { rtTArgs = f <$> rtTArgs rt+                     , rtVArgs = f <$> rtVArgs rt+                     }++------------------------------------------------------------------------+-- | Constructor and Destructors for RTypes ----------------------------+------------------------------------------------------------------------++data RTypeRep c tv r+  = RTypeRep { ty_vars   :: [tv]+             , ty_preds  :: [PVar (RType c tv ())]+             , ty_labels :: [Symbol]+             , ty_binds  :: [Symbol]+             , ty_refts  :: [r]+             , ty_args   :: [RType c tv r]+             , ty_res    :: (RType c tv r)+             }++fromRTypeRep (RTypeRep {..})+  = mkArrow ty_vars ty_preds ty_labels arrs ty_res+  where+    arrs = safeZip3WithError ("fromRTypeRep: " ++ show (length ty_binds, length ty_args, length ty_refts)) ty_binds ty_args ty_refts++toRTypeRep           :: RType c tv r -> RTypeRep c tv r+toRTypeRep t         = RTypeRep αs πs ls xs rs ts t''+  where+    (αs, πs, ls, t')  = bkUniv  t+    (xs, ts, rs, t'') = bkArrow t'++mkArrow αs πs ls xts = mkUnivs αs πs ls . mkArrs xts+  where+    mkArrs xts t  = foldr (\(b,t1,r) t2 -> RFun b t1 t2 r) t xts++bkArrowDeep (RAllT _ t)     = bkArrowDeep t+bkArrowDeep (RAllP _ t)     = bkArrowDeep t+bkArrowDeep (RAllS _ t)     = bkArrowDeep t+bkArrowDeep (RFun x t t' r) = let (xs, ts, rs, t'') = bkArrowDeep t'  in (x:xs, t:ts, r:rs, t'')+bkArrowDeep t               = ([], [], [], t)++bkArrow (RFun x t t' r) = let (xs, ts, rs, t'') = bkArrow t'  in (x:xs, t:ts, r:rs, t'')+bkArrow t               = ([], [], [], t)++safeBkArrow (RAllT _ _) = panic Nothing "safeBkArrow on RAllT"+safeBkArrow (RAllP _ _) = panic Nothing "safeBkArrow on RAllP"+safeBkArrow (RAllS _ t) = safeBkArrow t+safeBkArrow t           = bkArrow t++mkUnivs αs πs ls t = foldr RAllT (foldr RAllP (foldr RAllS t ls) πs) αs++bkUniv :: RType t1 a t2 -> ([a], [PVar (RType t1 a ())], [Symbol], RType t1 a t2)+bkUniv (RAllT α t)      = let (αs, πs, ls, t') = bkUniv t in  (α:αs, πs, ls, t')+bkUniv (RAllP π t)      = let (αs, πs, ls, t') = bkUniv t in  (αs, π:πs, ls, t')+bkUniv (RAllS s t)      = let (αs, πs, ss, t') = bkUniv t in  (αs, πs, s:ss, t')+bkUniv t                = ([], [], [], t)++bkClass (RFun _ (RApp c t _ _) t' _)+  | isClass c+  = let (cs, t'') = bkClass t' in ((c, t):cs, t'')+bkClass (RRTy e r o t)+  = let (cs, t') = bkClass t in (cs, RRTy e r o t')+bkClass t+  = ([], t)++rFun b t t' = RFun b t t' mempty+rCls c ts   = RApp (RTyCon c [] defaultTyConInfo) ts [] mempty+rRCls rc ts = RApp rc ts [] mempty++addInvCond :: SpecType -> RReft -> SpecType+addInvCond t r'+  | isTauto $ ur_reft r' -- null rv+  = t+  | otherwise+  = fromRTypeRep $ trep {ty_res = RRTy [(x', tbd)] r OInv tbd}+  where+    trep = toRTypeRep t+    tbd  = ty_res trep+    r    = r' {ur_reft = Reft (v, rx)}+    su   = (v, EVar x')+    x'   = "xInv"+    rx   = PIff (EVar v) $ subst1 rv su+    Reft(v, rv) = ur_reft r'++-------------------------------------------++instance Subable Stratum where+  syms (SVar s) = [s]+  syms _        = []+  subst su (SVar s) = SVar $ subst su s+  subst _ s         = s+  substf f (SVar s) = SVar $ substf f s+  substf _ s        = s+  substa f (SVar s) = SVar $ substa f s+  substa _ s        = s++instance Reftable Strata where+  isTauto []         = True+  isTauto _          = False++  ppTy _             = panic Nothing "ppTy on Strata"+  toReft _           = mempty+  params s           = [l | SVar l <- s]+  bot _              = []+  top _              = []++  ofReft = todo Nothing "TODO: Strata.ofReft"+++class Reftable r => UReftable r where+  ofUReft :: UReft Reft -> r+  ofUReft (MkUReft r _ _) = ofReft r+++instance UReftable (UReft Reft) where+   ofUReft r = r++instance UReftable () where+   ofUReft _ = mempty++instance (PPrint r, Reftable r) => Reftable (UReft r) where+  isTauto            = isTauto_ureft+  ppTy               = ppTy_ureft+  toReft (MkUReft r ps _)  = toReft r `meet` toReft ps+  params (MkUReft r _ _)   = params r+  bot (MkUReft r _ s)      = MkUReft (bot r) (Pr []) (bot s)+  top (MkUReft r p s)      = MkUReft (top r) (top p) s++  ofReft r = MkUReft (ofReft r) mempty mempty++isTauto_ureft u      = isTauto (ur_reft u) && isTauto (ur_pred u) -- && (isTauto $ ur_strata u)++ppTy_ureft u@(MkUReft r p s) d+  | isTauto_ureft  u  = d+  | otherwise         = ppr_reft r (ppTy p d) s++ppr_reft r d s       = braces (pprint v <+> colon <+> d <> ppr_str s <+> text "|" <+> pprint r')+  where+    r'@(Reft (v, _)) = toReft r++ppr_str [] = empty+ppr_str s  = text "^" <> pprint s++instance Subable r => Subable (UReft r) where+  syms (MkUReft r p _)     = syms r ++ syms p+  subst s (MkUReft r z l)  = MkUReft (subst s r) (subst s z) (subst s l)+  substf f (MkUReft r z l) = MkUReft (substf f r) (substf f z) (substf f l)+  substa f (MkUReft r z l) = MkUReft (substa f r) (substa f z) (substa f l)++instance (Reftable r, RefTypable c tv r) => Subable (RTProp c tv r) where+  syms (RProp  ss r)     = (fst <$> ss) ++ syms r++  subst su (RProp ss (RHole r)) = RProp ss (RHole (subst su r))+  subst su (RProp  ss t) = RProp ss (subst su <$> t)++  substf f (RProp ss (RHole r)) = RProp ss (RHole (substf f r))+  substf f (RProp  ss t) = RProp ss (substf f <$> t)++  substa f (RProp ss (RHole r)) = RProp ss (RHole (substa f r))+  substa f (RProp  ss t) = RProp ss (substa f <$> t)+++instance (Subable r, RefTypable c tv r) => Subable (RType c tv r) where+  syms        = foldReft (\_ r acc -> syms r ++ acc) []+  substa f    = mapReft (substa f)+  substf f    = emapReft (substf . substfExcept f) []+  subst su    = emapReft (subst  . substExcept su) []+  subst1 t su = emapReft (\xs r -> subst1Except xs r su) [] t+++++instance Reftable Predicate where+  isTauto (Pr ps)      = null ps++  bot (Pr _)           = panic Nothing "No BOT instance for Predicate"+  -- NV: This does not print abstract refinements....+  -- HACK: Hiding to not render types in WEB DEMO. NEED TO FIX.+  ppTy r d | isTauto r        = d+           | not (ppPs ppEnv) = d+           | otherwise        = d <> (angleBrackets $ pprint r)++  toReft (Pr ps@(p:_))        = Reft (parg p, pAnd $ pToRef <$> ps)+  toReft _                    = mempty+  params                      = todo Nothing "TODO: instance of params for Predicate"++  ofReft = todo Nothing "TODO: Predicate.ofReft"++pToRef p = pApp (pname p) $ (EVar $ parg p) : (thd3 <$> pargs p)++pApp      :: Symbol -> [Expr] -> Expr+pApp p es = mkEApp (dummyLoc $ pappSym $ length es) (EVar p:es)++pappSym n  = symbol $ "papp" ++ show n++---------------------------------------------------------------+--------------------------- Visitors --------------------------+---------------------------------------------------------------++isTrivial t = foldReft (\_ r b -> isTauto r && b) True t++mapReft ::  (r1 -> r2) -> RType c tv r1 -> RType c tv r2+mapReft f = emapReft (\_ -> f) []++emapReft ::  ([Symbol] -> r1 -> r2) -> [Symbol] -> RType c tv r1 -> RType c tv r2++emapReft f γ (RVar α r)          = RVar  α (f γ r)+emapReft f γ (RAllT α t)         = RAllT α (emapReft f γ t)+emapReft f γ (RAllP π t)         = RAllP π (emapReft f γ t)+emapReft f γ (RAllS p t)         = RAllS p (emapReft f γ t)+emapReft f γ (RFun x t t' r)     = RFun  x (emapReft f γ t) (emapReft f (x:γ) t') (f γ r)+emapReft f γ (RApp c ts rs r)    = RApp  c (emapReft f γ <$> ts) (emapRef f γ <$> rs) (f γ r)+emapReft f γ (RAllE z t t')      = RAllE z (emapReft f γ t) (emapReft f γ t')+emapReft f γ (REx z t t')        = REx   z (emapReft f γ t) (emapReft f γ t')+emapReft _ _ (RExprArg e)        = RExprArg e+emapReft f γ (RAppTy t t' r)     = RAppTy (emapReft f γ t) (emapReft f γ t') (f γ r)+emapReft f γ (RRTy e r o t)      = RRTy  (mapSnd (emapReft f γ) <$> e) (f γ r) o (emapReft f γ t)+emapReft f γ (RHole r)           = RHole (f γ r)++emapRef :: ([Symbol] -> t -> s) ->  [Symbol] -> RTProp c tv t -> RTProp c tv s+emapRef  f γ (RProp s (RHole r))  = RProp s $ RHole (f γ r)+emapRef  f γ (RProp  s t)         = RProp s $ emapReft f γ t++------------------------------------------------------------------------------------------------------+-- isBase' x t = traceShow ("isBase: " ++ showpp x) $ isBase t+-- same as GhcMisc isBaseType++-- isBase :: RType a -> Bool++-- set all types to basic types, haskell `tx -> t` is translated to Arrow tx t+-- isBase _ = True++isBase (RAllT _ t)      = isBase t+isBase (RAllP _ t)      = isBase t+isBase (RVar _ _)       = True+isBase (RApp _ ts _ _)  = all isBase ts+isBase (RFun _ _ _ _)   = False+isBase (RAppTy t1 t2 _) = isBase t1 && isBase t2+isBase (RRTy _ _ _ t)   = isBase t+isBase (RAllE _ _ t)    = isBase t+isBase _                = False++isFunTy (RAllE _ _ t)    = isFunTy t+isFunTy (RAllS _ t)      = isFunTy t+isFunTy (RAllT _ t)      = isFunTy t+isFunTy (RAllP _ t)      = isFunTy t+isFunTy (RFun _ _ _ _)   = True+isFunTy _                = False+++mapReftM :: (Monad m) => (r1 -> m r2) -> RType c tv r1 -> m (RType c tv r2)+mapReftM f (RVar α r)         = liftM   (RVar  α)   (f r)+mapReftM f (RAllT α t)        = liftM   (RAllT α)   (mapReftM f t)+mapReftM f (RAllP π t)        = liftM   (RAllP π)   (mapReftM f t)+mapReftM f (RAllS s t)        = liftM   (RAllS s)   (mapReftM f t)+mapReftM f (RFun x t t' r)    = liftM3  (RFun x)    (mapReftM f t)          (mapReftM f t')       (f r)+mapReftM f (RApp c ts rs r)   = liftM3  (RApp  c)   (mapM (mapReftM f) ts)  (mapM (mapRefM f) rs) (f r)+mapReftM f (RAllE z t t')     = liftM2  (RAllE z)   (mapReftM f t)          (mapReftM f t')+mapReftM f (REx z t t')       = liftM2  (REx z)     (mapReftM f t)          (mapReftM f t')+mapReftM _ (RExprArg e)       = return  $ RExprArg e+mapReftM f (RAppTy t t' r)    = liftM3  RAppTy (mapReftM f t) (mapReftM f t') (f r)+mapReftM f (RHole r)          = liftM   RHole       (f r)+mapReftM f (RRTy xts r o t)   = liftM4  RRTy (mapM (mapSndM (mapReftM f)) xts) (f r) (return o) (mapReftM f t)++mapRefM  :: (Monad m) => (t -> m s) -> (RTProp c tv t) -> m (RTProp c tv s)+mapRefM  f (RProp s t)         = liftM   (RProp s)      (mapReftM f t)+++--------------------------------------------------------------------------------+-- foldReft :: (Reftable r, TyConable c) => (r -> a -> a) -> a -> RType c tv r -> a+--------------------------------------------------------------------------------+-- foldReft f = efoldReft (\_ _ -> []) (\_ -> ()) (\_ _ -> f) (\_ γ -> γ) emptySEnv++--------------------------------------------------------------------------------+foldReft :: (Reftable r, TyConable c) => (SEnv (RType c tv r) -> r -> a -> a) -> a -> RType c tv r -> a+--------------------------------------------------------------------------------+foldReft f = foldReft' id (\γ _ -> f γ)++--------------------------------------------------------------------------------+foldReft' :: (Reftable r, TyConable c)+          => (RType c tv r -> b)+          -> (SEnv b -> Maybe (RType c tv r) -> r -> a -> a)+          -> a -> RType c tv r -> a+--------------------------------------------------------------------------------+foldReft' g f = efoldReft (\_ _ -> []) g (\γ t r z -> f γ t r z) (\_ γ -> γ) emptySEnv++++-- efoldReft :: Reftable r =>(p -> [RType c tv r] -> [(Symbol, a)])-> (RType c tv r -> a)-> (SEnv a -> Maybe (RType c tv r) -> r -> c1 -> c1)-> SEnv a-> c1-> RType c tv r-> c1+efoldReft cb g f fp = go+  where+    -- folding over RType+    go γ z me@(RVar _ r)                = f γ (Just me) r z+    go γ z (RAllT _ t)                  = go γ z t+    go γ z (RAllP p t)                  = go (fp p γ) z t+    go γ z (RAllS _ t)                  = go γ z t+    go γ z me@(RFun _ (RApp c ts _ _) t' r)+       | isClass c                      = f γ (Just me) r (go (insertsSEnv γ (cb c ts)) (go' γ z ts) t')+    go γ z me@(RFun x t t' r)           = f γ (Just me) r (go (insertSEnv x (g t) γ) (go γ z t) t')+--     go γ z me@(RFun _ t t' r)           = f γ (Just me) r (go γ (go γ z t) t')+    go γ z me@(RApp _ ts rs r)          = f γ (Just me) r (ho' γ (go' (insertSEnv (rTypeValueVar me) (g me) γ) z ts) rs)++    go γ z (RAllE x t t')               = go (insertSEnv x (g t) γ) (go γ z t) t'+    go γ z (REx x t t')                 = go (insertSEnv x (g t) γ) (go γ z t) t'+    go γ z me@(RRTy [] r _ t)          = f γ (Just me) r (go γ z t)+    go γ z me@(RRTy xts r _ t)          = f γ (Just me) r (go γ (go γ z (envtoType xts)) t)+    go γ z me@(RAppTy t t' r)           = f γ (Just me) r (go γ (go γ z t) t')+    go _ z (RExprArg _)                 = z+    go γ z me@(RHole r)                 = f γ (Just me) r z++    -- folding over Ref+    ho  γ z (RProp ss (RHole r))       = f (insertsSEnv γ (mapSnd (g . ofRSort) <$> ss)) Nothing r z+    ho  γ z (RProp ss t)               = go (insertsSEnv γ ((mapSnd (g . ofRSort)) <$> ss)) z t++    -- folding over [RType]+    go' γ z ts                 = foldr (flip $ go γ) z ts++    -- folding over [Ref]+    ho' γ z rs                 = foldr (flip $ ho γ) z rs++    envtoType xts = foldr (\(x,t1) t2 -> rFun x t1 t2) (snd $ last xts) (init xts)++mapBot f (RAllT α t)       = RAllT α (mapBot f t)+mapBot f (RAllP π t)       = RAllP π (mapBot f t)+mapBot f (RAllS s t)       = RAllS s (mapBot f t)+mapBot f (RFun x t t' r)   = RFun x (mapBot f t) (mapBot f t') r+mapBot f (RAppTy t t' r)   = RAppTy (mapBot f t) (mapBot f t') r+mapBot f (RApp c ts rs r)  = f $ RApp c (mapBot f <$> ts) (mapBotRef f <$> rs) r+mapBot f (REx b t1 t2)     = REx b  (mapBot f t1) (mapBot f t2)+mapBot f (RAllE b t1 t2)   = RAllE b  (mapBot f t1) (mapBot f t2)+mapBot f (RRTy e r o t)    = RRTy (mapSnd (mapBot f) <$> e) r o (mapBot f t)+mapBot f t'                = f t'+mapBotRef _ (RProp s (RHole r)) = RProp s $ RHole r+mapBotRef f (RProp s t)    = RProp  s $ mapBot f t++mapBind f (RAllT α t)      = RAllT α (mapBind f t)+mapBind f (RAllP π t)      = RAllP π (mapBind f t)+mapBind f (RAllS s t)      = RAllS s (mapBind f t)+mapBind f (RFun b t1 t2 r) = RFun (f b)  (mapBind f t1) (mapBind f t2) r+mapBind f (RApp c ts rs r) = RApp c (mapBind f <$> ts) (mapBindRef f <$> rs) r+mapBind f (RAllE b t1 t2)  = RAllE  (f b) (mapBind f t1) (mapBind f t2)+mapBind f (REx b t1 t2)    = REx    (f b) (mapBind f t1) (mapBind f t2)+mapBind _ (RVar α r)       = RVar α r+mapBind _ (RHole r)        = RHole r+mapBind f (RRTy e r o t)   = RRTy e r o (mapBind f t)+mapBind _ (RExprArg e)     = RExprArg e+mapBind f (RAppTy t t' r)  = RAppTy (mapBind f t) (mapBind f t') r++mapBindRef f (RProp s (RHole r)) = RProp (mapFst f <$> s) (RHole r)+mapBindRef f (RProp s t)         = RProp (mapFst f <$> s) $ mapBind f t+++--------------------------------------------------+ofRSort ::  Reftable r => RType c tv () -> RType c tv r+ofRSort = fmap mempty++toRSort :: RType c tv r -> RType c tv ()+toRSort = stripAnnotations . mapBind (const dummySymbol) . fmap (const ())++stripAnnotations (RAllT α t)      = RAllT α (stripAnnotations t)+stripAnnotations (RAllP _ t)      = stripAnnotations t+stripAnnotations (RAllS _ t)      = stripAnnotations t+stripAnnotations (RAllE _ _ t)    = stripAnnotations t+stripAnnotations (REx _ _ t)      = stripAnnotations t+stripAnnotations (RFun x t t' r)  = RFun x (stripAnnotations t) (stripAnnotations t') r+stripAnnotations (RAppTy t t' r)  = RAppTy (stripAnnotations t) (stripAnnotations t') r+stripAnnotations (RApp c ts rs r) = RApp c (stripAnnotations <$> ts) (stripAnnotationsRef <$> rs) r+stripAnnotations (RRTy _ _ _ t)   = stripAnnotations t+stripAnnotations t                = t+stripAnnotationsRef (RProp s (RHole r)) = RProp s (RHole r)+stripAnnotationsRef (RProp s t)         = RProp s $ stripAnnotations t+++insertsSEnv  = foldr (\(x, t) γ -> insertSEnv x t γ)++rTypeValueVar :: (Reftable r) => RType c tv r -> Symbol+rTypeValueVar t = vv where Reft (vv,_) =  rTypeReft t++rTypeReft :: (Reftable r) => RType c tv r -> Reft+rTypeReft = fromMaybe trueReft . fmap toReft . stripRTypeBase++  +-- stripRTypeBase ::  RType a -> Maybe a+stripRTypeBase (RApp _ _ _ x)+  = Just x+stripRTypeBase (RVar _ x)+  = Just x+stripRTypeBase (RFun _ _ _ x)+  = Just x+stripRTypeBase (RAppTy _ _ x)+  = Just x+stripRTypeBase _+  = Nothing++mapRBase f (RApp c ts rs r) = RApp c ts rs $ f r+mapRBase f (RVar a r)       = RVar a $ f r+mapRBase f (RFun x t1 t2 r) = RFun x t1 t2 $ f r+mapRBase f (RAppTy t1 t2 r) = RAppTy t1 t2 $ f r+mapRBase _ t                = t++++makeLType :: Stratum -> SpecType -> SpecType+makeLType l t = fromRTypeRep trep{ty_res = mapRBase f $ ty_res trep}+  where trep = toRTypeRep t+        f (MkUReft r p _) = MkUReft r p [l]+++makeDivType = makeLType SDiv+makeFinType = makeLType SFin++getStrata = maybe [] ur_strata . stripRTypeBase++-----------------------------------------------------------------------------+-- | PPrint -----------------------------------------------------------------+-----------------------------------------------------------------------------++instance Show Stratum where+  show SFin = "Fin"+  show SDiv = "Div"+  show SWhnf = "Whnf"+  show (SVar s) = show s++instance PPrint Stratum where+  pprintTidy _ = text . show++instance {-# OVERLAPPING #-} PPrint Strata where+  pprintTidy _ [] = empty+  pprintTidy k ss = hsep (pprintTidy k <$> nub ss)++instance PPrint (PVar a) where+  pprintTidy _ = ppr_pvar++ppr_pvar :: PVar a -> Doc+ppr_pvar (PV s _ _ xts) = pprint s <+> hsep (pprint <$> dargs xts)+  where+    dargs               = map thd3 . takeWhile (\(_, x, y) -> EVar x /= y)+++instance PPrint Predicate where+  pprintTidy _ (Pr [])       = text "True"+  pprintTidy k (Pr pvs)      = hsep $ punctuate (text "&") (map (pprintTidy k) pvs)+++-- | The type used during constraint generation, used+--   also to define contexts for errors, hence in this+--   file, and NOT in elsewhere. **DO NOT ATTEMPT TO MOVE**+--   Am splitting into+--   + global : many bindings, shared across all constraints+--   + local  : few bindings, relevant to particular constraints++data REnv = REnv+  { reGlobal :: M.HashMap Symbol SpecType -- ^ the "global" names for module+  , reLocal  :: M.HashMap Symbol SpecType -- ^ the "local" names for sub-exprs+  }++instance NFData REnv where+  rnf (REnv {}) = ()++------------------------------------------------------------------------+-- | Error Data Type ---------------------------------------------------+------------------------------------------------------------------------++type ErrorResult = FixResult UserError+type Error       = TError SpecType++instance NFData a => NFData (TError a)++------------------------------------------------------------------------+-- | Source Information Associated With Constraints --------------------+------------------------------------------------------------------------++data Cinfo    = Ci { ci_loc :: !SrcSpan+                   , ci_err :: !(Maybe Error)+                   }+                deriving (Eq, Ord, Generic)++instance NFData Cinfo++--------------------------------------------------------------------------------+--- Module Names+--------------------------------------------------------------------------------++data ModName = ModName !ModType !ModuleName deriving (Eq,Ord)++instance Show ModName where+  show = getModString++instance Symbolic ModName where+  symbol (ModName _ m) = symbol m++instance Symbolic ModuleName where+  symbol = symbol . moduleNameFS++data ModType = Target | SrcImport | SpecImport deriving (Eq,Ord)++isSrcImport (ModName SrcImport _) = True+isSrcImport _                     = False++isSpecImport (ModName SpecImport _) = True+isSpecImport _                      = False++getModName (ModName _ m) = m++getModString = moduleNameString . getModName+++-------------------------------------------------------------------------------+----------- Refinement Type Aliases -------------------------------------------+-------------------------------------------------------------------------------++data RTEnv   = RTE { typeAliases :: M.HashMap Symbol (RTAlias RTyVar SpecType)+                   , exprAliases :: M.HashMap Symbol (RTAlias Symbol Expr)+                   }++instance Monoid RTEnv where+  (RTE ta1 ea1) `mappend` (RTE ta2 ea2)+    = RTE (ta1 `M.union` ta2) (ea1 `M.union` ea2)+  mempty = RTE M.empty M.empty++mapRT f e = e { typeAliases = f $ typeAliases e }+mapRE f e = e { exprAliases = f $ exprAliases e }+++--------------------------------------------------------------------------------+--- Measures+--------------------------------------------------------------------------------+data Body+  = E Expr          -- ^ Measure Refinement: {v | v = e }+  | P Expr          -- ^ Measure Refinement: {v | (? v) <=> p }+  | R Symbol Expr   -- ^ Measure Refinement: {v | p}+  deriving (Show, Data, Typeable, Generic, Eq)++data Def ty ctor = Def+  { measure :: LocSymbol+  , dparams :: [(Symbol, ty)]+  , ctor    :: ctor+  , dsort   :: Maybe ty+  , binds   :: [(Symbol, Maybe ty)]+  , body    :: Body+  } deriving (Show, Data, Typeable, Generic, Eq, Functor)++data Measure ty ctor = M+  { name :: LocSymbol+  , sort :: ty+  , eqns :: [Def ty ctor]+  } deriving (Data, Typeable, Generic, Functor)++deriveBifunctor ''Def+deriveBifunctor ''Measure++data CMeasure ty = CM+  { cName :: LocSymbol+  , cSort :: ty+  } deriving (Data, Typeable, Generic, Functor)++instance PPrint Body where+  pprintTidy k (E e)   = pprintTidy k e+  pprintTidy k (P p)   = pprintTidy k p+  pprintTidy k (R v p) = braces (pprintTidy k v <+> text "|" <+> pprintTidy k p)++instance PPrint a => PPrint (Def t a) where+  pprintTidy k (Def m p c _ bs body) = pprintTidy k m <+> pprintTidy k (fst <$> p) <+> cbsd <> text " = " <> pprintTidy k body+    where cbsd = parens (pprintTidy k c <> hsep (pprintTidy k `fmap` (fst <$> bs)))++instance (PPrint t, PPrint a) => PPrint (Measure t a) where+  pprintTidy k (M n s eqs) =  pprintTidy k n <> text " :: " <> pprintTidy k s+                     $$ vcat (pprintTidy k `fmap` eqs)++instance PPrint (Measure t a) => Show (Measure t a) where+  show = showpp++instance PPrint t => PPrint (CMeasure t) where+  pprintTidy k (CM n s) =  pprintTidy k n <> text " :: " <> pprintTidy k s++instance PPrint (CMeasure t) => Show (CMeasure t) where+  show = showpp+++instance Subable (Measure ty ctor) where+  syms (M _ _ es)      = concatMap syms es+  substa f  (M n s es) = M n s $ substa f  <$> es+  substf f  (M n s es) = M n s $ substf f  <$> es+  subst  su (M n s es) = M n s $ subst  su <$> es++instance Subable (Def ty ctor) where+  syms (Def _ sp _ _ sb bd)  = (fst <$> sp) ++ (fst <$> sb) ++ syms bd+  substa f  (Def m p c t b bd) = Def m p c t b $ substa f  bd+  substf f  (Def m p c t b bd) = Def m p c t b $ substf f  bd+  subst  su (Def m p c t b bd) = Def m p c t b $ subst  su bd++instance Subable Body where+  syms (E e)       = syms e+  syms (P e)       = syms e+  syms (R s e)     = s:syms e++  substa f (E e)   = E $ substa f e+  substa f (P e)   = P $ substa f e+  substa f (R s e) = R s $ substa f e++  substf f (E e)   = E $ substf f e+  substf f (P e)   = P $ substf f e+  substf f (R s e) = R s $ substf f e++  subst su (E e)   = E $ subst su e+  subst su (P e)   = P $ subst su e+  subst su (R s e) = R s $ subst su e++++data RClass ty+  = RClass { rcName    :: LocSymbol+           , rcSupers  :: [ty]+           , rcTyVars  :: [Symbol]+           , rcMethods :: [(LocSymbol,ty)]+           } deriving (Show, Functor)+++------------------------------------------------------------------------+-- | Annotations -------------------------------------------------------+------------------------------------------------------------------------++newtype AnnInfo a = AI (M.HashMap SrcSpan [(Maybe Text, a)])+                    deriving (Data, Typeable, Generic, Functor)++data Annot t+  = AnnUse t+  | AnnDef t+  | AnnRDf t+  | AnnLoc SrcSpan+  deriving (Data, Typeable, Generic, Functor)++instance Monoid (AnnInfo a) where+  mempty                  = AI M.empty+  mappend (AI m1) (AI m2) = AI $ M.unionWith (++) m1 m2++instance NFData a => NFData (AnnInfo a)++instance NFData a => NFData (Annot a)++--------------------------------------------------------------------------------+-- | Output --------------------------------------------------------------------+--------------------------------------------------------------------------------++data Output a = O+  { o_vars   :: Maybe [String]+  , o_errors :: ![UserError]+  , o_types  :: !(AnnInfo a)+  , o_templs :: !(AnnInfo a)+  , o_bots   :: ![SrcSpan]+  , o_result :: ErrorResult+  } deriving (Typeable, Generic, Functor)++emptyOutput = O Nothing [] mempty mempty [] mempty++instance Monoid (Output a) where+  mempty        = emptyOutput+  mappend o1 o2 = O { o_vars   = sortNub <$> mappend (o_vars   o1) (o_vars   o2)+                    , o_errors = sortNub  $  mappend (o_errors o1) (o_errors o2)+                    , o_types  =             mappend (o_types  o1) (o_types  o2)+                    , o_templs =             mappend (o_templs o1) (o_templs o2)+                    , o_bots   = sortNub  $  mappend (o_bots o1)   (o_bots   o2)+                    , o_result =             mappend (o_result o1) (o_result o2)+                    }++--------------------------------------------------------------------------------+-- | KVar Profile --------------------------------------------------------------+--------------------------------------------------------------------------------++data KVKind+  = RecBindE+  | NonRecBindE+  | TypeInstE+  | PredInstE+  | LamE+  | CaseE+  | LetE+  deriving (Generic, Eq, Ord, Show, Enum, Data, Typeable)++instance Hashable KVKind++newtype KVProf = KVP (M.HashMap KVKind Int) deriving (Generic)++emptyKVProf :: KVProf+emptyKVProf = KVP M.empty++updKVProf :: KVKind -> Kuts -> KVProf -> KVProf+updKVProf k kvs (KVP m) = KVP $ M.insert k (kn + n) m+  where+    kn                  = M.lookupDefault 0 k m+    n                   = S.size $ ksVars kvs+++instance NFData KVKind++instance PPrint KVKind where+  pprintTidy _ = text . show++instance PPrint KVProf where+  pprintTidy k (KVP m) = pprintTidy k $ M.toList m++instance NFData KVProf++hole :: Expr+hole = PKVar "HOLE" mempty++isHole :: Expr -> Bool+isHole (PKVar ("HOLE") _) = True+isHole _                  = False++hasHole :: Reftable r => r -> Bool+hasHole = any isHole . conjuncts . reftPred . toReft++-- classToRApp :: SpecType -> SpecType+-- classToRApp (RCls cl ts)+--   = RApp (RTyCon (classTyCon cl) def def) ts mempty mempty++instance Symbolic DataCon where+  symbol = symbol . dataConWorkId+++instance PPrint DataCon where+  pprintTidy _ = text . showPpr++instance Show DataCon where+  show = showpp+++liquidBegin :: String+liquidBegin = ['{', '-', '@']++liquidEnd :: String+liquidEnd = ['@', '-', '}']++data MSpec ty ctor = MSpec+  { ctorMap  :: M.HashMap Symbol [Def ty ctor]+  , measMap  :: M.HashMap LocSymbol (Measure ty ctor)+  , cmeasMap :: M.HashMap LocSymbol (Measure ty ())+  , imeas    :: ![Measure ty ctor]+  } deriving (Data, Typeable, Generic, Functor)++instance Bifunctor MSpec   where+  first f (MSpec c m cm im) = MSpec (fmap (fmap (first f)) c)+                                    (fmap (first f) m)+                                    (fmap (first f) cm)+                                    (fmap (first f) im)+  second                    = fmap++instance (PPrint t, PPrint a) => PPrint (MSpec t a) where+  pprintTidy k =  vcat . fmap (pprintTidy k) . fmap snd . M.toList . measMap++instance (Show ty, Show ctor, PPrint ctor, PPrint ty) => Show (MSpec ty ctor) where+  show (MSpec ct m cm im)+    = "\nMSpec:\n" +++      "\nctorMap:\t "  ++ show ct +++      "\nmeasMap:\t "  ++ show m  +++      "\ncmeasMap:\t " ++ show cm +++      "\nimeas:\t "    ++ show im +++      "\n"++instance Eq ctor => Monoid (MSpec ty ctor) where+  mempty = MSpec M.empty M.empty M.empty []++  (MSpec c1 m1 cm1 im1) `mappend` (MSpec c2 m2 cm2 im2)+    | null dups+    = MSpec (M.unionWith (++) c1 c2) (m1 `M.union` m2)+           (cm1 `M.union` cm2) (im1 ++ im2)+    | otherwise+    = panic Nothing $ err (head dups)+    where dups = [(k1, k2) | k1 <- M.keys m1 , k2 <- M.keys m2, val k1 == val k2]+          err (k1, k2) = printf "\nDuplicate Measure Definitions for %s\n%s" (showpp k1) (showpp $ map loc [k1, k2])++--------------------------------------------------------------------------------+-- Nasty PP stuff+--------------------------------------------------------------------------------++instance PPrint RTyVar where+  pprintTidy _k (RTV α)+   | ppTyVar ppEnv = ppr_tyvar α+   | otherwise     = ppr_tyvar_short α++ppr_tyvar       = text . tvId+ppr_tyvar_short = text . showPpr++instance (PPrint r, Reftable r, PPrint t, PPrint (RType c tv r)) => PPrint (Ref t (RType c tv r)) where+  pprintTidy k (RProp ss s) = ppRefArgs (fst <$> ss) <+> pprintTidy k s+  -- pprint (RProp ss (RHole s)) = ppRefArgs (fst <$> ss) <+> pprint s+  -- pprint (RProp ss s) = ppRefArgs (fst <$> ss) <+> pprint (fromMaybe mempty (stripRTypeBase s))+++ppRefArgs :: [Symbol] -> Doc+ppRefArgs [] = empty+ppRefArgs ss = text "\\" <> hsep (ppRefSym <$> ss ++ [vv Nothing]) <+> text "->"++ppRefSym "" = text "_"+ppRefSym s  = pprint s
+ src/Language/Haskell/Liquid/Types/Bounds.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-}++module Language.Haskell.Liquid.Types.Bounds (++    Bound(..),++    RBound, RRBound,++    RBEnv, RRBEnv,++    makeBound,++    ) where++import Prelude hiding (error)+import Text.PrettyPrint.HughesPJ++import Data.List (partition)+import Data.Maybe+import Data.Hashable+-- import Data.Monoid+import Data.Bifunctor++import qualified Data.HashMap.Strict as M+-- import Control.Applicative           ((<$>))++import Language.Fixpoint.Types++import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.Misc  (mapFst, mapSnd)+import Language.Haskell.Liquid.Types.RefType+++data Bound t e+  = Bound { bname   :: LocSymbol         -- ^ The name of the bound+          , tyvars  :: [t]               -- ^ Type variables that appear in the bounds+          , bparams :: [(LocSymbol, t)]  -- ^ These are abstract refinements, for now+          , bargs   :: [(LocSymbol, t)]  -- ^ These are value variables+          , bbody   :: e                 -- ^ The body of the bound+          }++type RBound        = RRBound RSort+type RRBound tv    = Bound tv Expr++type RBEnv         = M.HashMap LocSymbol RBound+type RRBEnv tv     = M.HashMap LocSymbol (RRBound tv)+++instance Hashable (Bound t e) where+        hashWithSalt i = hashWithSalt i . bname++instance Eq (Bound t e) where+  b1 == b2 = (bname b1) == (bname b2)++instance (PPrint e, PPrint t) => (Show (Bound t e)) where+        show = showpp+++instance (PPrint e, PPrint t) => (PPrint (Bound t e)) where+        pprintTidy k (Bound s vs ps xs e) =   text "bound" <+> pprintTidy k s <+>+                                        text "forall" <+> pprintTidy k vs <+> text "." <+>+                                        pprintTidy k (fst <$> ps) <+> text "=" <+>+                                        pprint_bsyms k (fst <$> xs) <+> pprintTidy k e++pprint_bsyms _ [] = text ""+pprint_bsyms k xs = text "\\" <+> pprintTidy k xs <+> text "->"++instance Bifunctor Bound where+        first  f (Bound s vs ps xs e) = Bound s (f <$> vs) (mapSnd f <$> ps) (mapSnd f <$> xs) e+        second f (Bound s vs ps xs e) = Bound s vs ps xs (f e)+++makeBound :: (PPrint r, UReftable r)+          => RRBound RSort -> [RRType r] -> [Symbol] -> (RRType r) -> (RRType r)+makeBound (Bound _  vs ps xs p) ts qs t+  = RRTy cts mempty OCons t+  where+    cts  = (\(x, t) -> (x, foldr subsTyVar_meet t su)) <$> cts'++    cts' = makeBoundType penv rs xs++    penv = zip (val . fst <$> ps) qs+    rs   = bkImp [] p++    bkImp acc (PImp p q) = bkImp (p:acc) q+    bkImp acc p          = p:acc++    su  = [(α, toRSort t, t) | (RVar α _, t) <-  zip vs ts ]++makeBoundType :: (PPrint r, UReftable r)+              => [(Symbol, Symbol)]+              -> [Expr]+              -> [(LocSymbol, RSort)]+              -> [(Symbol, RRType r)]+makeBoundType penv (q:qs) xts = go xts+  where+    -- NV TODO: Turn this into a proper error+    go [] = panic Nothing "Bound with empty symbols"++    go [(x, t)]      = [(dummySymbol, tp t x), (dummySymbol, tq t x)]+    go ((x, t):xtss) = (val x, mkt t x):(go xtss)++    mkt t x = ofRSort t `strengthen` ofUReft (MkUReft (Reft (val x, mempty))+                                                (Pr $ M.lookupDefault [] (val x) ps) mempty)+    tp t x  = ofRSort t `strengthen` ofUReft (MkUReft (Reft (val x, pAnd rs))+                                                (Pr $ M.lookupDefault [] (val x) ps) mempty)+    tq t x  = ofRSort t `strengthen` makeRef penv x q++    (ps, rs) = partitionPs penv qs+++-- NV TODO: Turn this into a proper error+makeBoundType _ _ _           = panic Nothing "Bound with empty predicates"+++partitionPs :: [(Symbol, Symbol)] -> [Expr] -> (M.HashMap Symbol [UsedPVar], [Expr])+partitionPs penv qs = mapFst makeAR $ partition (isPApp penv) qs+  where+    makeAR ps       = M.fromListWith (++) $ map (toUsedPVars penv) ps++isPApp penv (EApp (EVar p) _)  = isJust $ lookup p penv+isPApp penv (EApp e _)         = isPApp penv e +isPApp _    _                  = False++toUsedPVars penv q@(EApp _ e) = (x, [toUsedPVar penv q])+  where+    -- NV : TODO make this a better error+    x = case unProp e of {EVar x -> x; e -> todo Nothing ("Bound fails in " ++ show e) }+toUsedPVars _ _ = impossible Nothing "This cannot happen"++unProp (EApp (EVar f) e)+  | f == propConName+  = e+unProp e+  = e++toUsedPVar penv ee@(EApp _ _)+  = PV q (PVProp ()) e (((), dummySymbol,) <$> es')+   where+     EVar e = unProp $ last es+     es'    = init es+     Just q = lookup p penv+     (EVar p, es) = splitEApp ee ++toUsedPVar _ _ = impossible Nothing "This cannot happen"++-- `makeRef` is used to make the refinement of the last implication,+-- thus it can contain both concrete and abstract refinements++makeRef :: (UReftable r) => [(Symbol, Symbol)] -> LocSymbol -> Expr -> r+makeRef penv v (PAnd rs) = ofUReft (MkUReft (Reft (val v, pAnd rrs)) r mempty)+  where+    r                    = Pr  (toUsedPVar penv <$> pps)+    (pps, rrs)           = partition (isPApp penv) rs++makeRef penv v rr+  | isPApp penv rr       = ofUReft (MkUReft (Reft(val v, mempty)) r mempty)+  where+    r                    = Pr [toUsedPVar penv rr]++makeRef _    v p         = ofReft (Reft(val v, p))
+ src/Language/Haskell/Liquid/Types/Dictionaries.hs view
@@ -0,0 +1,65 @@+module Language.Haskell.Liquid.Types.Dictionaries (+    makeDictionaries+  , makeDictionary++  , dfromList+  , dmapty+  , dmap+  , dinsert+  , dlookup+  , dhasinfo+  ) where++import Prelude hiding (error)++import Var++++import Language.Fixpoint.Types++import Language.Haskell.Liquid.GHC.Misc (dropModuleNames)+import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.Misc (mapFst)++import qualified Data.HashMap.Strict as M+import Language.Haskell.Liquid.Types.PrettyPrint ()++makeDictionaries :: [RInstance SpecType] -> DEnv Symbol SpecType+makeDictionaries = DEnv . M.fromList . map makeDictionary+++makeDictionary :: RInstance SpecType -> (Symbol, M.HashMap Symbol SpecType)+makeDictionary (RI c t xts) = (makeDictionaryName c t, M.fromList (mapFst val <$> xts))++makeDictionaryName :: Located Symbol -> SpecType -> Symbol+makeDictionaryName t (RApp c _ _ _) = symbol ("$f" ++ symbolString (val t) ++ c')+  where+        c' = symbolString (dropModuleNames $ symbol $ rtc_tc c)++makeDictionaryName _ _              = panic Nothing "makeDictionaryName: called with invalid type"++------------------------------------------------------------------------------+------------------------------------------------------------------------------+------------------------ Dictionay Environment -------------------------------+------------------------------------------------------------------------------+------------------------------------------------------------------------------+++dfromList :: [(Var, M.HashMap Symbol t)] -> DEnv Var t+dfromList = DEnv . M.fromList++dmapty :: (a -> b) -> DEnv v a -> DEnv v b+dmapty f (DEnv e) = DEnv (M.map (M.map f) e)++dmap f xts = M.map f xts++dinsert (DEnv denv) x xts = DEnv $ M.insert x xts denv++dlookup (DEnv denv) x     = M.lookup x denv+++dhasinfo Nothing _    = Nothing+dhasinfo (Just xts) x = M.lookup x' xts+  where+     x' = (dropModuleNames $ symbol $ show x)
+ src/Language/Haskell/Liquid/Types/Errors.hs view
@@ -0,0 +1,674 @@+{-# LANGUAGE ImplicitParams      #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE OverloadedStrings   #-}++-- | This module contains the *types* related creating Errors.+--   It depends only on Fixpoint and basic haskell libraries,+--   and hence, should be importable everywhere.++module Language.Haskell.Liquid.Types.Errors (+  -- * Generic Error Type+    TError (..)++  -- * Error with Source Context+  , CtxError (..)+  , errorWithContext++  -- * Subtyping Obligation Type+  , Oblig (..)++  -- * Panic (unexpected failures)+  , UserError+  --, HiddenType (..)+  , panic+  , panicDoc+  , todo+  , impossible+  , uError++  -- * Printing Errors+  , ppError+  , ppError'++  -- * SrcSpan Helpers+  , realSrcSpan+  , unpackRealSrcSpan+  ) where++import           Prelude                      hiding (error)++import           SrcLoc                      -- (SrcSpan (..), noSrcSpan)+import           FastString+import           GHC.Generics+import           Control.DeepSeq+import           Data.Typeable                (Typeable)+import           Data.Generics                (Data)+import           Data.Maybe+import           Text.PrettyPrint.HughesPJ+import           Data.Aeson hiding (Result)+import qualified Data.HashMap.Strict as M+import           Language.Fixpoint.Types      (showpp, Tidy (..), PPrint (..), pprint, Symbol, Expr)+import           Language.Fixpoint.Misc (dcolon)+import           Language.Haskell.Liquid.Misc (intToString)+import           Text.Parsec.Error            (ParseError)+import qualified Control.Exception as Ex+import           System.Directory+import           System.FilePath+import Data.List    (intersperse )+import           Text.Parsec.Error (errorMessages, showErrorMessages)++++instance PPrint ParseError where+  pprintTidy _ e = vcat $ tail $ map text ls+    where+      ls = lines $ showErrorMessages "or" "unknown parse error"+                                     "expecting" "unexpected" "end of input"+                                     (errorMessages e)++--------------------------------------------------------------------------------+-- | Context information for Error Messages ------------------------------------+--------------------------------------------------------------------------------+data CtxError t = CtxError+  { ctErr :: TError t+  , ctCtx :: Doc+  } deriving (Functor)++instance Eq (CtxError t) where+  e1 == e2 = ctErr e1 == ctErr e2++instance Ord (CtxError t) where+  e1 <= e2 = ctErr e1 <= ctErr e2++--------------------------------------------------------------------------------+errorWithContext :: TError t -> IO (CtxError t)+--------------------------------------------------------------------------------+errorWithContext e = CtxError e <$> srcSpanContext (pos e)++srcSpanContext :: SrcSpan -> IO Doc+srcSpanContext sp+  | Just (f, l, c, c') <- srcSpanInfo sp+  = maybe empty (makeContext l c c') <$> getFileLine f l+  | otherwise+  = return empty++srcSpanInfo :: SrcSpan -> Maybe (FilePath, Int, Int, Int)+srcSpanInfo (RealSrcSpan s)+  | l == l'           = Just (f, l, c, c')+  | otherwise         = Nothing+  where+     f  = unpackFS $ srcSpanFile s+     l  = srcSpanStartLine s+     c  = srcSpanStartCol  s+     l' = srcSpanEndLine   s+     c' = srcSpanEndCol    s+srcSpanInfo _         = Nothing++getFileLine :: FilePath -> Int -> IO (Maybe String)+getFileLine f i = do+  b <- doesFileExist f+  if b+    then getNth (i - 1) . lines <$> readFile f+    else return Nothing++getNth :: Int -> [a] -> Maybe a+getNth i xs+  | i < length xs = Just (xs !! i)+  | otherwise     = Nothing++makeContext :: Int -> Int -> Int -> String -> Doc+makeContext l c c' s = vcat [ text ""+                            , lnum l <+> (text s $+$ cursor)+                            , text ""+                            ]+  where+    lnum n           = text (show n) <+> text "|"+    cursor           = blanks (c - 1) <> pointer (c' - c)+    blanks n         = text $ replicate n ' '+    pointer n        = text $ replicate n '^'++--------------------------------------------------------------------------------+-- | Different kinds of Check "Obligations" ------------------------------------+--------------------------------------------------------------------------------++data Oblig+  = OTerm -- ^ Obligation that proves termination+  | OInv  -- ^ Obligation that proves invariants+  | OCons -- ^ Obligation that proves subtyping constraints+  deriving (Generic, Data, Typeable)++instance Show Oblig where+  show OTerm = "termination-condition"+  show OInv  = "invariant-obligation"+  show OCons = "constraint-obligation"++instance NFData Oblig++instance PPrint Oblig where+  pprintTidy _ = ppOblig++ppOblig :: Oblig -> Doc+ppOblig OCons = text "Constraint Check"+ppOblig OTerm = text "Termination Check"+ppOblig OInv  = text "Invariant Check"++--------------------------------------------------------------------------------+-- | Generic Type for Error Messages -------------------------------------------+--------------------------------------------------------------------------------++-- | INVARIANT : all Error constructors should have a pos field++data TError t =+    ErrSubType { pos  :: !SrcSpan+               , msg  :: !Doc+               , ctx  :: !(M.HashMap Symbol t)+               , tact :: !t+               , texp :: !t+               } -- ^ liquid type error++  | ErrFCrash  { pos  :: !SrcSpan+               , msg  :: !Doc+               , ctx  :: !(M.HashMap Symbol t)+               , tact :: !t+               , texp :: !t+               } -- ^ liquid type error++  | ErrAssType { pos  :: !SrcSpan+               , obl  :: !Oblig+               , msg  :: !Doc+               , ctx  :: !(M.HashMap Symbol t)+               , cond :: t+               } -- ^ condition failure error++  | ErrParse    { pos  :: !SrcSpan+                , msg  :: !Doc+                , pErr :: !ParseError+                } -- ^ specification parse error++  | ErrTySpec   { pos :: !SrcSpan+                , var :: !Doc+                , typ :: !t+                , msg :: !Doc+                } -- ^ sort error in specification++  | ErrTermSpec { pos :: !SrcSpan+                , var :: !Doc+                , exp :: !Expr+                , msg :: !Doc+                } -- ^ sort error in specification++  | ErrDupAlias { pos  :: !SrcSpan+                , var  :: !Doc+                , kind :: !Doc+                , locs :: ![SrcSpan]+                } -- ^ multiple alias with same name error++  | ErrDupSpecs { pos :: !SrcSpan+                , var :: !Doc+                , locs:: ![SrcSpan]+                } -- ^ multiple specs for same binder error++  | ErrDupMeas  { pos :: !SrcSpan+                , var :: !Doc+                , tycon :: !Doc+                , locs:: ![SrcSpan]+                } -- ^ multiple definitions of the same measure+++  | ErrBadData  { pos :: !SrcSpan+                , var :: !Doc+                , msg :: !Doc+                } -- ^ bad data type specification (?)++  | ErrDataCon  { pos :: !SrcSpan+                , var :: !Doc+                , msg :: !Doc+                } -- ^ refined datacon mismatches haskell datacon++  | ErrInvt     { pos :: !SrcSpan+                , inv :: !t+                , msg :: !Doc+                } -- ^ Invariant sort error++  | ErrIAl      { pos :: !SrcSpan+                , inv :: !t+                , msg :: !Doc+                } -- ^ Using  sort error++  | ErrIAlMis   { pos :: !SrcSpan+                , tAs :: !t+                , tUs :: !t+                , msg :: !Doc+                } -- ^ Incompatible using error++  | ErrMeas     { pos :: !SrcSpan+                , ms  :: !Doc+                , msg :: !Doc+                } -- ^ Measure sort error++  | ErrHMeas    { pos :: !SrcSpan+                , ms  :: !Doc+                , msg :: !Doc+                } -- ^ Haskell bad Measure error++  | ErrUnbound  { pos :: !SrcSpan+                , var :: !Doc+                } -- ^ Unbound symbol in specification++  | ErrGhc      { pos :: !SrcSpan+                , msg :: !Doc+                } -- ^ GHC error: parsing or type checking++  | ErrMismatch { pos   :: !SrcSpan -- ^ haskell type location+                , var   :: !Doc+                , hs    :: !Doc+                , lq    :: !Doc+                , lqPos :: !SrcSpan -- ^ lq type location+                } -- ^ Mismatch between Liquid and Haskell types++  | ErrPartPred { pos  :: !SrcSpan+                , ectr :: !Doc+                , var  :: !Doc+                , argN :: !Int+                , expN :: !Int+                , actN :: !Int+                } -- ^ Mismatch in expected/actual args of abstract refinement++  | ErrAliasCycle { pos    :: !SrcSpan+                  , acycle :: ![(SrcSpan, Doc)]+                  } -- ^ Cyclic Refined Type Alias Definitions++  | ErrIllegalAliasApp { pos   :: !SrcSpan+                       , dname :: !Doc+                       , dpos  :: !SrcSpan+                       } -- ^ Illegal RTAlias application (from BSort, eg. in PVar)++  | ErrAliasApp { pos   :: !SrcSpan+                , nargs :: !Int+                , dname :: !Doc+                , dpos  :: !SrcSpan+                , dargs :: !Int+                }++  | ErrSaved    { pos :: !SrcSpan+                , msg :: !Doc+                } -- ^ Previously saved error, that carries over after DiffCheck++  | ErrTermin   { pos  :: !SrcSpan+                , bind :: ![Doc]+                , msg  :: !Doc+                } -- ^ Termination Error++  | ErrRClass   { pos   :: !SrcSpan+                , cls   :: !Doc+                , insts :: ![(SrcSpan, Doc)]+                } -- ^ Refined Class/Interfaces Conflict++  | ErrBadQual  { pos   :: !SrcSpan+                , qname :: !Doc+                , msg   :: !Doc+                } -- ^ Non well sorted Qualifier++  | ErrOther    { pos   :: SrcSpan+                , msg   :: !Doc+                } -- ^ Sigh. Other.++  deriving (Typeable, Generic, Functor)++instance NFData ParseError where+  rnf t = seq t ()++-- FIXME ES: this is very suspicious, why can't we have multiple errors+-- arising from the same span?++instance Eq (TError a) where+  e1 == e2 = errSpan e1 == errSpan e2++instance Ord (TError a) where+  e1 <= e2 = errSpan e1 <= errSpan e2+++errSpan :: TError a -> SrcSpan+errSpan =  pos++--------------------------------------------------------------------------------+-- | Simple unstructured type for panic ----------------------------------------+--------------------------------------------------------------------------------+type UserError  = TError Doc++instance PPrint SrcSpan where+  pprintTidy _ = pprSrcSpan++pprSrcSpan :: SrcSpan -> Doc+pprSrcSpan (UnhelpfulSpan s) = text $ unpackFS s+pprSrcSpan (RealSrcSpan s)   = pprRealSrcSpan s++pprRealSrcSpan :: RealSrcSpan -> Doc+pprRealSrcSpan span+  | sline == eline && scol == ecol =+    hcat [ pathDoc <> colon+         , int sline <> colon+         , int scol+         ]+  | sline == eline =+    hcat $ [ pathDoc <> colon+           , int sline <> colon+           , int scol+           ] ++ if ecol - scol <= 1 then [] else [char '-' <> int (ecol - 1)]+  | otherwise =+    hcat [ pathDoc <> colon+         , parens (int sline <> comma <> int scol)+         , char '-'+         , parens (int eline <> comma <> int ecol')+         ]+ where+   path  = srcSpanFile      span+   sline = srcSpanStartLine span+   eline = srcSpanEndLine   span+   scol  = srcSpanStartCol  span+   ecol  = srcSpanEndCol    span++   pathDoc = text $ normalise $ unpackFS path+   ecol'   = if ecol == 0 then ecol else ecol - 1++instance PPrint UserError where+  pprintTidy k = ppError k empty . fmap pprint++instance Show UserError where+  show = showpp++instance Ex.Exception UserError++-- | Construct and show an Error, then crash+uError :: UserError -> a+uError = Ex.throw++-- | Construct and show an Error, then crash+panicDoc :: {- (?callStack :: CallStack) => -} SrcSpan -> Doc -> a+panicDoc sp d = Ex.throw (ErrOther sp d :: UserError)++-- | Construct and show an Error, then crash+panic :: {- (?callStack :: CallStack) => -} Maybe SrcSpan -> String -> a+panic sp d = panicDoc (sspan sp) (text d)+  where+    sspan  = fromMaybe noSrcSpan++-- | Construct and show an Error with an optional SrcSpan, then crash+--   This function should be used to mark unimplemented functionality+todo :: {- (?callStack :: CallStack) => -} Maybe SrcSpan -> String -> a+todo s m  = panic s $ unlines+            [ "This functionality is currently unimplemented. "+            , "If this functionality is critical to you, please contact us at: "+            , "https://github.com/ucsd-progsys/liquidhaskell/issues"+            , m+            ]++-- | Construct and show an Error with an optional SrcSpan, then crash+--   This function should be used to mark impossible-to-reach codepaths+impossible :: {- (?callStack :: CallStack) => -} Maybe SrcSpan -> String -> a+impossible s m = panic s $ unlines msg ++ m+   where+      msg = [ "This should never happen! If you are seeing this message, "+            , "please submit a bug report at "+            , "https://github.com/ucsd-progsys/liquidhaskell/issues "+            , "with this message and the source file that caused this error."+            , ""+            ]++++-- type CtxError = Error+--------------------------------------------------------------------------------+ppError :: (PPrint a, Show a) => Tidy -> Doc -> TError a -> Doc+--------------------------------------------------------------------------------+ppError k dCtx e = ppError' k dSp dCtx e+  where+    dSp          = pprint (pos e) <> text ": Error:"++nests n      = foldr (\d acc -> nest n (d $+$ acc)) empty+sepVcat d ds = vcat $ intersperse d ds+blankLine    = sizedText 5 " "++ppFull :: Tidy -> Doc -> Doc+ppFull Full  d = d+ppFull Lossy _ = empty++ppReqInContext :: (PPrint t, PPrint c) => t -> t -> c -> Doc+ppReqInContext tA tE c+  = sepVcat blankLine+      [ nests 2 [ text "Inferred type"+                , text "VV :" <+> pprint tA]+      , nests 2 [ text "not a subtype of Required type"+                , text "VV :" <+> pprint tE]+      , nests 2 [ text "In Context"+                , pprint c                 ]]+++ppPropInContext :: (PPrint p, PPrint c) => p -> c -> Doc+ppPropInContext p c+  = sepVcat blankLine+      [ nests 2 [ text "Property"+                , pprint p]+      , nests 2 [ text "Not provable in context"+                , pprint c                 ]]++instance ToJSON RealSrcSpan where+  toJSON sp = object [ "filename"  .= f+                     , "startLine" .= l1+                     , "startCol"  .= c1+                     , "endLine"   .= l2+                     , "endCol"    .= c2+                     ]+    where+      (f, l1, c1, l2, c2) = unpackRealSrcSpan sp++unpackRealSrcSpan rsp = (f, l1, c1, l2, c2)+  where+    f                 = unpackFS $ srcSpanFile rsp+    l1                = srcSpanStartLine rsp+    c1                = srcSpanStartCol  rsp+    l2                = srcSpanEndLine   rsp+    c2                = srcSpanEndCol    rsp+++instance FromJSON RealSrcSpan where+  parseJSON (Object v) = realSrcSpan <$> v .: "filename"+                                     <*> v .: "startLine"+                                     <*> v .: "startCol"+                                     <*> v .: "endLine"+                                     <*> v .: "endCol"+  parseJSON _          = mempty++realSrcSpan :: FilePath -> Int -> Int -> Int -> Int -> RealSrcSpan+realSrcSpan f l1 c1 l2 c2 = mkRealSrcSpan loc1 loc2+  where+    loc1                  = mkRealSrcLoc (fsLit f) l1 c1+    loc2                  = mkRealSrcLoc (fsLit f) l2 c2++instance ToJSON SrcSpan where+  toJSON (RealSrcSpan rsp) = object [ "realSpan" .= True, "spanInfo" .= rsp ]+  toJSON (UnhelpfulSpan _) = object [ "realSpan" .= False ]++instance FromJSON SrcSpan where+  parseJSON (Object v) = do tag <- v .: "realSpan"+                            case tag of+                              False -> return noSrcSpan+                              True  -> RealSrcSpan <$> v .: "spanInfo"+  parseJSON _          = mempty++instance (PPrint a, Show a) => ToJSON (TError a) where+  toJSON e = object [ "pos" .= (pos e)+                    , "msg" .= (render $ ppError' Full empty empty e)+                    ]++instance FromJSON (TError a) where+  parseJSON (Object v) = errSaved <$> v .: "pos"+                                  <*> v .: "msg"+  parseJSON _          = mempty++errSaved :: SrcSpan -> String -> TError a+errSaved x = ErrSaved x . text++--------------------------------------------------------------------------------+ppError' :: (PPrint a, Show a) => Tidy -> Doc -> Doc -> TError a -> Doc+--------------------------------------------------------------------------------+ppError' td dSp dCtx (ErrAssType _ o _ c p)+  = dSp <+> pprint o+        $+$ dCtx+        $+$ (ppFull td $ ppPropInContext p c)++ppError' td dSp dCtx (ErrSubType _ _ c tA tE)+  = dSp <+> text "Liquid Type Mismatch"+        $+$ dCtx+        $+$ (ppFull td $ ppReqInContext tA tE c)++ppError' td  dSp dCtx (ErrFCrash _ _ c tA tE)+  = dSp <+> text "Fixpoint Crash on Constraint"+        $+$ dCtx+        $+$ (ppFull td $ ppReqInContext tA tE c)++ppError' _ dSp dCtx (ErrParse _ _ e)+  = dSp <+> text "Cannot parse specification:"+        $+$ dCtx+        $+$ (nest 4 $ pprint e)++ppError' _ dSp _ (ErrTySpec _ v t s)+  = dSp <+> text "Bad Type Specification"+        $+$ (pprint v <+> dcolon <+> pprint t)+        $+$ (nest 4 $ pprint s)++ppError' _ dSp _ (ErrBadData _ v s)+  = dSp <+> text "Bad Data Specification"+        $+$ (pprint v <+> dcolon <+> pprint s)++ppError' _ dSp dCtx (ErrDataCon _ d s)+  = dSp <+> "Malformed refined data constructor" <+> pprint d+        $+$ dCtx+        $+$ s++ppError' _ dSp dCtx (ErrBadQual _ n d)+  = dSp <+> text "Bad Qualifier Specification for" <+> n+        $+$ dCtx+        $+$ (pprint d)++ppError' _ dSp _ (ErrTermSpec _ v e s)+  = dSp <+> text "Bad Termination Specification"+        $+$ (pprint v <+> dcolon <+> pprint e)+        $+$ (nest 4 $ pprint s)++ppError' _ dSp _ (ErrInvt _ t s)+  = dSp <+> text "Bad Invariant Specification"+        $+$ (nest 4 $ text "invariant " <+> pprint t $+$ pprint s)++ppError' _ dSp _ (ErrIAl _ t s)+  = dSp <+> text "Bad Using Specification"+        $+$ (nest 4 $ text "as" <+> pprint t $+$ pprint s)++ppError' _ dSp _ (ErrIAlMis _ t1 t2 s)+  = dSp <+> text "Incompatible Using Specification"+        $+$ (nest 4 $ (text "using" <+> pprint t1 <+> text "as" <+> pprint t2) $+$ pprint s)++ppError' _ dSp _ (ErrMeas _ t s)+  = dSp <+> text "Bad Measure Specification"+        $+$ (nest 4 $ text "measure " <+> pprint t $+$ pprint s)++ppError' _ dSp _ (ErrHMeas _ t s)+  = dSp <+> text "Cannot promote Haskell function" <+> pprint t <+> text "to logic"+        $+$ (nest 4 $ pprint s)++ppError' _ dSp _ (ErrDupSpecs _ v ls)+  = dSp <+> text "Multiple Specifications for" <+> pprint v <> colon+        $+$ (nest 4 $ vcat $ pprint <$> ls)++ppError' _ dSp _ (ErrDupMeas _ v t ls)+  = dSp <+> text "Multiple Instance Measures for" <+> pprint v+        <+> text "and" <+> pprint t+        <> colon+        $+$ (nest 4 $ vcat $ pprint <$> ls)++ppError' _ dSp _ (ErrDupAlias _ k v ls)+  = dSp <+> text "Multiple Declarations! "+    $+$ (nest 2 $ text "Multiple Declarations of" <+> pprint k <+> ppVar v $+$ text "Declared at:")+    <+> (nest 4 $ vcat $ pprint <$> ls)++ppError' _ dSp dCtx (ErrUnbound _ x)+  = dSp <+> text "Unbound variable" <+> pprint x+        $+$ dCtx++ppError' _ dSp dCtx (ErrGhc _ s)+  = dSp <+> text "GHC Error"+        $+$ dCtx+        $+$ (nest 4 $ pprint s)++ppError' _ dSp dCtx (ErrPartPred _ c p i eN aN)+  = dSp <+> text "Malformed Predicate Application"+        $+$ dCtx+        $+$ (nest 4 $ vcat [ "The" <+> text (intToString i) <+> "argument of" <+> c <+> "is predicate" <+> p+                           , "which expects" <+> pprint eN <+> "arguments" <+> "but is given only" <+> pprint aN+                           , "Abstract predicates cannot be partially applied, see "+                           , nest 2 "https://github.com/ucsd-progsys/liquidhaskell/issues/594"+                           , "for possible fix."+                           ])++ppError' _ dSp dCtx (ErrMismatch _ x τ t hsSp)+  = dSp <+> "Specified Type Does Not Refine Haskell Type for" <+> pprint x+        $+$ dCtx+        $+$ (sepVcat blankLine+              [ "The Liquid type"+              , nest 4 t+              , "is inconsistent with the Haskell type"+              , nest 4 τ+              , "defined at" <+> pprint hsSp+              ])++ppError' _ dSp _ (ErrAliasCycle _ acycle)+  = dSp <+> text "Cyclic Alias Definitions"+        $+$ text "The following alias definitions form a cycle:"+        $+$ (nest 4 $ sepVcat blankLine $ map describe acycle)+  where+    describe (p, n)+      =   text "Type alias:" <+> pprint n+      $+$ text "Defined at:" <+> pprint p++ppError' _ dSp dCtx (ErrIllegalAliasApp _ dn dl)+  = dSp <+> text "Refinement Type Alias cannot be used in this context"+        $+$ dCtx+        $+$ text "Type alias:" <+> pprint dn+        $+$ text "Defined at:" <+> pprint dl++ppError' _ dSp dCtx (ErrAliasApp _ n name dl dn)+  = dSp <+> text "Malformed Type Alias Application"+        $+$ dCtx+        $+$ text "Type alias:" <+> pprint name+        $+$ text "Defined at:" <+> pprint dl+        $+$ text "Expects"     <+> pprint dn <+> text "arguments, but is given" <+> pprint n++ppError' _ dSp _ (ErrSaved _ s)+  = dSp <+> s++ppError' _ dSp dCtx (ErrOther _ s)+  = dSp <+> text "Uh oh."+        $+$ dCtx+        $+$ nest 4 s++ppError' _ dSp _ (ErrTermin _ xs s)+  = dSp <+> text "Termination Error"+        <+> (hsep $ intersperse comma xs) $+$ s++ppError' _ dSp _ (ErrRClass p0 c is)+  = dSp <+> text "Refined classes cannot have refined instances"+    $+$ (nest 4 $ sepVcat blankLine $ describeCls : map describeInst is)+  where+    describeCls+      =   text "Refined class definition for:" <+> c+      $+$ text "Defined at:" <+> pprint p0+    describeInst (p, t)+      =   text "Refined instance for:" <+> t+      $+$ text "Defined at:" <+> pprint p++ppVar v = text "`" <> pprint v <> text "'"
+ src/Language/Haskell/Liquid/Types/Literals.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}++module Language.Haskell.Liquid.Types.Literals (+         literalFRefType+       , literalFReft+       , literalConst+       ) where++import Prelude hiding (error)+import TypeRep+import Literal+import qualified TyCon  as TC+import Language.Haskell.Liquid.Measure+import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.Types.RefType+import Language.Haskell.Liquid.Transforms.CoreToLogic (mkLit)+++import qualified Language.Fixpoint.Types as F++import qualified Data.Text as T+++++---------------------------------------------------------------+----------------------- Typing Literals -----------------------+---------------------------------------------------------------++makeRTypeBase (TyVarTy α)    x+  = RVar (rTyVar α) x+makeRTypeBase (TyConApp c ts) x+  = rApp c ((`makeRTypeBase` mempty) <$> ts) [] x+makeRTypeBase _              _+  = panic Nothing "RefType : makeRTypeBase"++literalFRefType l+  = makeRTypeBase (literalType l) (literalFReft l)++literalFReft l = maybe mempty mkReft $ mkLit l++mkReft e = case e of+            F.ESym (F.SL str) ->+              -- FIXME: unsorted equality is shady, better to not embed Add# as int..+              F.meet (F.uexprReft e)+                     (F.reft "v" (F.PAtom F.Eq+                                  (F.mkEApp (name strLen) [F.EVar "v"])+                                  (F.ECon (F.I (fromIntegral (T.length str))))))+            _ -> F.exprReft e++-- | `literalConst` returns `Nothing` for unhandled lits because+--    otherwise string-literals show up as global int-constants+--    which blow up qualifier instantiation.++literalConst :: F.TCEmb TC.TyCon -> Literal -> (F.Sort, Maybe F.Expr)+literalConst tce l = (t, mkLit l)+  where+    t              = typeSort tce $ literalType l
+ src/Language/Haskell/Liquid/Types/Meet.hs view
@@ -0,0 +1,28 @@+-- | This code has various wrappers around `meet` and `strengthen`+--   that are here so that we can throw decent error messages if+--   they fail. The module depends on `RefType` and `UX.Tidy`.++module Language.Haskell.Liquid.Types.Meet+     ( meetVarTypes ) where++import           SrcLoc+import           Text.PrettyPrint.HughesPJ (Doc)+import qualified Language.Fixpoint.Types as F+import           Language.Haskell.Liquid.Types++import           Language.Haskell.Liquid.Types.RefType+import           Language.Haskell.Liquid.UX.Tidy++meetVarTypes :: Doc -> (SrcSpan, SpecType) -> (SrcSpan, SpecType) -> SpecType+meetVarTypes v hs lq = meetError err hsT lqT+  where+    (hsSp, hsT)      = hs+    (lqSp, lqT)      = lq+    err              = ErrMismatch lqSp v hsD lqD hsSp+    hsD              = pprint (toRSort hsT)+    lqD              = pprint (toRSort lqT)++meetError :: Error -> SpecType -> SpecType -> SpecType+meetError e t t'+  | meetable t t' = t `F.meet` t'+  | otherwise     = panicError e
+ src/Language/Haskell/Liquid/Types/Names.hs view
@@ -0,0 +1,6 @@+module Language.Haskell.Liquid.Types.Names where++import Language.Fixpoint.Types+++lenLocSymbol = dummyLoc $ symbol ("autolen" :: String)
+ src/Language/Haskell/Liquid/Types/PredType.hs view
@@ -0,0 +1,355 @@+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE TupleSections        #-}+{-# LANGUAGE UndecidableInstances #-}++module Language.Haskell.Liquid.Types.PredType (+    PrType+  , TyConP (..), DataConP (..)+  , dataConTy+  , dataConPSpecType+  , makeTyConInfo+  , replacePreds++  , replacePredsWithRefs+  , pVartoRConc++  -- * Dummy `Type` that represents _all_ abstract-predicates+  , predType++  -- * Compute @RType@ of a given @PVar@+  , pvarRType++  , substParg+  , pApp+  , pappSort, pappArity+  ) where++import           Prelude                         hiding (error)+import           DataCon+import           Text.PrettyPrint.HughesPJ+import qualified TyCon                           as TC+import           Type+import           TypeRep++import qualified Data.HashMap.Strict             as M+import           Data.List                       (foldl', partition)++import           Language.Fixpoint.Misc++import           Language.Fixpoint.Types         hiding (Expr, Predicate)+import qualified Language.Fixpoint.Types         as F+import           Language.Haskell.Liquid.GHC.Misc+import           Language.Haskell.Liquid.Misc+import           Language.Haskell.Liquid.Types.RefType hiding (generalize)+import           Language.Haskell.Liquid.Types+++import           Data.List                       (nub)+++import           Data.Default++makeTyConInfo = hashMapMapWithKey mkRTyCon . M.fromList++mkRTyCon ::  TC.TyCon -> TyConP -> RTyCon+mkRTyCon tc (TyConP αs' ps _ tyvariance predvariance size) = RTyCon tc pvs' (mkTyConInfo tc tyvariance predvariance size)+  where τs   = [rVar α :: RSort |  α <- tyConTyVarsDef tc]+        pvs' = subts (zip αs' τs) <$> ps++dataConPSpecType :: DataCon -> DataConP -> SpecType+dataConPSpecType dc (DataConP _ vs ps ls cs yts rt _) = mkArrow vs ps ls ts' rt'+  where+    (xs, ts) = unzip $ reverse yts+    -- mkDSym   = (`mappend` symbol dc) . (`mappend` "_") . symbol+    mkDSym z = (symbol z) `suffixSymbol` (symbol dc)+    ys       = mkDSym <$> xs+    tx _  []     []     []     = []+    tx su (x:xs) (y:ys) (t:ts) = (y, subst (F.mkSubst su) t, mempty)+                               : tx ((x, F.EVar y):su) xs ys ts+    tx _ _ _ _ = panic Nothing "PredType.dataConPSpecType.tx called on invalid inputs"+    yts'     = tx [] xs ys ts+    ts'      = map ("" , , mempty) cs ++ yts'+    su       = F.mkSubst [(x, F.EVar y) | (x, y) <- zip xs ys]+    rt'      = subst su rt++instance PPrint TyConP where+  pprintTidy k (TyConP vs ps ls _ _ _)+    = (parens $ hsep (punctuate comma (map (pprintTidy k) vs))) <+>+      (parens $ hsep (punctuate comma (map (pprintTidy k) ps))) <+>+      (parens $ hsep (punctuate comma (map (pprintTidy k) ls)))++instance Show TyConP where+ show = showpp -- showSDoc . ppr++instance PPrint DataConP where+  pprintTidy k (DataConP _ vs ps ls cs yts t _)+     = (parens $ hsep (punctuate comma (map (pprintTidy k) vs))) <+>+       (parens $ hsep (punctuate comma (map (pprintTidy k) ps))) <+>+       (parens $ hsep (punctuate comma (map (pprintTidy k) ls))) <+>+       (parens $ hsep (punctuate comma (map (pprintTidy k) cs))) <+>+       (parens $ hsep (punctuate comma (map (pprintTidy k) yts))) <+>+       pprintTidy k t++instance Show DataConP where+  show = showpp++dataConTy m (TyVarTy v)+  = M.lookupDefault (rVar v) (RTV v) m+dataConTy m (FunTy t1 t2)+  = rFun dummySymbol (dataConTy m t1) (dataConTy m t2)+dataConTy m (ForAllTy α t)+  = RAllT (rTyVar α) (dataConTy m t)+dataConTy m (TyConApp c ts)+  = rApp c (dataConTy m <$> ts) [] mempty+dataConTy _ _+  = panic Nothing "ofTypePAppTy"++----------------------------------------------------------------------------+----- Interface: Replace Predicate With Uninterprented Function Symbol -----+----------------------------------------------------------------------------++replacePredsWithRefs (p, r) (MkUReft (Reft(v, rs)) (Pr ps) s)+  = MkUReft (Reft (v, rs'')) (Pr ps2) s+  where+    rs''             = mconcat $ rs : rs'+    rs'              = r . (v,) . pargs <$> ps1+    (ps1, ps2)       = partition (== p) ps++pVartoRConc p (v, args) | length args == length (pargs p)+  = pApp (pname p) $ EVar v : (thd3 <$> args)++pVartoRConc p (v, args)+  = pApp (pname p) $ EVar v : args'+  where+    args' = (thd3 <$> args) ++ (drop (length args) (thd3 <$> pargs p))++-----------------------------------------------------------------------+-- | @pvarRType π@ returns a trivial @RType@ corresponding to the+--   function signature for a @PVar@ @π@. For example, if+--      @π :: T1 -> T2 -> T3 -> Prop@+--   then @pvarRType π@ returns an @RType@ with an @RTycon@ called+--   @predRTyCon@ `RApp predRTyCon [T1, T2, T3]`+-----------------------------------------------------------------------+pvarRType :: (PPrint r, Reftable r) => PVar RSort -> RRType r+-----------------------------------------------------------------------+pvarRType (PV _ k {- (PVProp τ) -} _ args) = rpredType k (fst3 <$> args) -- (ty:tys)+  -- where+  --   ty  = uRTypeGen τ+  --   tys = uRTypeGen . fst3 <$> args+++-- rpredType    :: (PPrint r, Reftable r) => PVKind (RRType r) -> [RRType r] -> RRType r+rpredType (PVProp t) ts = RApp predRTyCon  (uRTypeGen <$> t : ts) [] mempty+rpredType PVHProp    ts = RApp wpredRTyCon (uRTypeGen <$>     ts) [] mempty++predRTyCon   :: RTyCon+predRTyCon   = symbolRTyCon predName++wpredRTyCon   :: RTyCon+wpredRTyCon   = symbolRTyCon wpredName++symbolRTyCon   :: Symbol -> RTyCon+symbolRTyCon n = RTyCon (stringTyCon 'x' 42 $ symbolString n) [] def++-------------------------------------------------------------------------------------+-- | Instantiate `PVar` with `RTProp` -----------------------------------------------+-------------------------------------------------------------------------------------+-- | @replacePreds@ is the main function used to substitute an (abstract)+--   predicate with a concrete Ref, that is either an `RProp` or `RHProp`+--   type. The substitution is invoked to obtain the `SpecType` resulting+--   at /predicate application/ sites in 'Language.Haskell.Liquid.Constraint'.+--   The range of the `PVar` substitutions are /fresh/ or /true/ `RefType`.+--   That is, there are no further _quantified_ `PVar` in the target.+-------------------------------------------------------------------------------------+replacePreds                 :: String -> SpecType -> [(RPVar, SpecProp)] -> SpecType+-------------------------------------------------------------------------------------+replacePreds msg             = foldl' go+  where+     go _ (_, RProp _ (RHole _)) = panic Nothing "replacePreds on RProp _ (RHole _)"+     go z (π, t) = substPred msg   (π, t)     z+++-- TODO: replace `replacePreds` with+-- instance SubsTy RPVar (Ref RReft SpecType) SpecType where+--   subt (pv, r) t = replacePreds "replacePred" t (pv, r)++-- replacePreds :: String -> SpecType -> [(RPVar, Ref Reft RefType)] -> SpecType+-- replacePreds msg       = foldl' go+--   where go z (π, RProp t) = substPred msg   (π, t)     z+--         go z (π, RPropP r) = replacePVarReft (π, r) <$> z++-------------------------------------------------------------------------------+substPred :: String -> (RPVar, SpecProp) -> SpecType -> SpecType+-------------------------------------------------------------------------------++substPred _   (π, RProp ss (RVar a1 r1)) t@(RVar a2 r2)+  | isPredInReft && a1 == a2    = RVar a1 $ meetListWithPSubs πs ss r1 r2'+  | isPredInReft                = panic Nothing ("substPred RVar Var Mismatch" ++ show (a1, a2))+  | otherwise                   = t+  where+    (r2', πs)                   = splitRPvar π r2+    isPredInReft                = not $ null πs++substPred msg su@(π, _ ) (RApp c ts rs r)+  | null πs                     = t'+  | otherwise                   = substRCon msg su t' πs r2'+  where+    t'                          = RApp c (substPred msg su <$> ts) (substPredP msg su <$> rs) r+    (r2', πs)                   = splitRPvar π r++substPred msg (p, tp) (RAllP (q@(PV _ _ _ _)) t)+  | p /= q                      = RAllP q $ substPred msg (p, tp) t+  | otherwise                   = RAllP q t++substPred msg su (RAllT a t)    = RAllT a (substPred msg su t)++substPred msg su@(π,_ ) (RFun x t t' r)+  | null πs                     = RFun x (substPred msg su t) (substPred msg su t') r+  | otherwise                   = {-meetListWithPSubs πs πt -}(RFun x t t' r')+  where (r', πs)                = splitRPvar π r++substPred msg su (RRTy e r o t) = RRTy (mapSnd (substPred msg su) <$> e) r o (substPred msg su t)+substPred msg su (RAllE x t t') = RAllE x (substPred msg su t) (substPred msg su t')+substPred msg su (REx x t t')   = REx   x (substPred msg su t) (substPred msg su t')+substPred _   _  t              = t++-- | Requires: @not $ null πs@+-- substRCon :: String -> (RPVar, SpecType) -> SpecType -> SpecType++substRCon msg (_, RProp ss t1@(RApp c1 ts1 rs1 r1)) t2@(RApp c2 ts2 rs2 _) πs r2'+  | rtc_tc c1 == rtc_tc c2 = RApp c1 ts rs $ meetListWithPSubs πs ss r1 r2'+  where+    ts                     = subst su $ safeZipWith (msg ++ ": substRCon")  strSub  ts1  ts2+    rs                     = subst su $ safeZipWith (msg ++ ": substRCon2") strSubR rs1' rs2'+    (rs1', rs2')           = pad "substRCon" top rs1 rs2+    strSub r1 r2           = meetListWithPSubs πs ss r1 r2+    strSubR r1 r2          = meetListWithPSubsRef πs ss r1 r2++    su = mkSubst $ zipWith (\s1 s2 -> (s1, EVar s2)) (rvs t1) (rvs t2)++    rvs      = foldReft (\_ r acc -> rvReft r : acc) []+    rvReft r = let Reft(s,_) = toReft r in s++substRCon msg su t _ _        = panic Nothing $ msg ++ " substRCon " ++ showpp (su, t)++pad _ f [] ys   = (f <$> ys, ys)+pad _ f xs []   = (xs, f <$> xs)+pad msg _ xs ys+  | nxs == nys  = (xs, ys)+  | otherwise   = panic Nothing $ "pad: " ++ msg+  where+    nxs         = length xs+    nys         = length ys++substPredP _ su p@(RProp _ (RHole _))+  = panic Nothing ("PredType.substPredP1 called on invalid inputs: " ++ showpp (su, p))+substPredP msg su@(p, RProp ss _) (RProp s t)+  = RProp ss' $ substPred (msg ++ ": substPredP") su t+ where+   ss' = drop n ss ++  s+   n   = length ss - length (freeArgsPs p t)+++splitRPvar pv (MkUReft x (Pr pvs) s) = (MkUReft x (Pr pvs') s, epvs)+  where+    (epvs, pvs')               = partition (uPVar pv ==) pvs++-- TODO: rewrite using foldReft+freeArgsPs p (RVar _ r)+  = freeArgsPsRef p r+freeArgsPs p (RFun _ t1 t2 r)+  = nub $  freeArgsPsRef p r ++ freeArgsPs p t1 ++ freeArgsPs p t2+freeArgsPs p (RAllT _ t)+  = freeArgsPs p t+freeArgsPs p (RAllS _ t)+  = freeArgsPs p t+freeArgsPs p (RAllP p' t)+  | p == p'   = []+  | otherwise = freeArgsPs p t+freeArgsPs p (RApp _ ts _ r)+  = nub $ freeArgsPsRef p r ++ concatMap (freeArgsPs p) ts+freeArgsPs p (RAllE _ t1 t2)+  = nub $ freeArgsPs p t1 ++ freeArgsPs p t2+freeArgsPs p (REx _ t1 t2)+  = nub $ freeArgsPs p t1 ++ freeArgsPs p t2+freeArgsPs p (RAppTy t1 t2 r)+  = nub $ freeArgsPsRef p r ++ freeArgsPs p t1 ++ freeArgsPs p t2+freeArgsPs _ (RExprArg _)+  = []+freeArgsPs p (RHole r)+  = freeArgsPsRef p r+freeArgsPs p (RRTy env r _ t)+  = nub $ concatMap (freeArgsPs p) (snd <$> env) ++ freeArgsPsRef p r ++ freeArgsPs p t++freeArgsPsRef p (MkUReft _ (Pr ps) _) = [x | (_, x, w) <- (concatMap pargs ps'),  (EVar x) == w]+  where+   ps' = f <$> filter (uPVar p ==) ps+   f q = q {pargs = pargs q ++ drop (length (pargs q)) (pargs $ uPVar p)}++meetListWithPSubs πs ss r1 r2    = foldl' (meetListWithPSub ss r1) r2 πs++meetListWithPSubsRef πs ss r1 r2 = foldl' ((meetListWithPSubRef ss) r1) r2 πs++meetListWithPSub ::  (Reftable r, PPrint t) => [(Symbol, RSort)]-> r -> r -> PVar t -> r+meetListWithPSub ss r1 r2 π+  | all (\(_, x, EVar y) -> x == y) (pargs π)+  = r2 `meet` r1+  | all (\(_, x, EVar y) -> x /= y) (pargs π)+  = r2 `meet` (subst su r1)+  | otherwise+  = panic Nothing $ "PredType.meetListWithPSub partial application to " ++ showpp π+  where+    su  = mkSubst [(x, y) | (x, (_, _, y)) <- zip (fst <$> ss) (pargs π)]++meetListWithPSubRef _ (RProp _ (RHole _)) _ _ -- TODO: Is this correct?+  = panic Nothing "PredType.meetListWithPSubRef called with invalid input"+meetListWithPSubRef _ _ (RProp _ (RHole _)) _+  = panic Nothing "PredType.meetListWithPSubRef called with invalid input"+meetListWithPSubRef ss (RProp s1 r1) (RProp s2 r2) π+  | all (\(_, x, EVar y) -> x == y) (pargs π)+  = RProp s1 $ (subst su' r2) `meet` r1+  | all (\(_, x, EVar y) -> x /= y) (pargs π)+  = RProp s2 $ r2 `meet` (subst su r1)+  | otherwise+  = panic Nothing $ "PredType.meetListWithPSubRef partial application to " ++ showpp π+  where+    su  = mkSubst [(x, y) | (x, (_, _, y)) <- zip (fst <$> ss) (pargs π)]+    su' = mkSubst [(x, EVar y) | (x, y) <- zip (fst <$> s2) (fst <$> s1)]+++----------------------------------------------------------------------------+-- | Interface: Modified CoreSyn.exprType due to predApp -------------------+----------------------------------------------------------------------------+predType   :: Type+predType   = symbolType predName++wpredName, predName   :: Symbol+predName   = "Pred"+wpredName  = "WPred"++symbolType = TyVarTy . symbolTyVar+++substParg :: Functor f => (Symbol, F.Expr) -> f Predicate -> f Predicate+substParg (x, y) = fmap fp+  where+    fxy s        = if (s == EVar x) then y else s+    fp           = subvPredicate (\pv -> pv { pargs = mapThd3 fxy <$> pargs pv })++-------------------------------------------------------------------------------+-----------------------------  Predicate Application --------------------------+-------------------------------------------------------------------------------+pappArity :: Int+pappArity  = 7++pappSort :: Int -> Sort+pappSort n = mkFFunc (2 * n) $ [ptycon] ++ args ++ [boolSort]+  where+    ptycon = fAppTC predFTyCon $ FVar <$> [0..n-1]+    args   = FVar <$> [n..(2*n-1)]+++predFTyCon = symbolFTycon $ dummyLoc predName
+ src/Language/Haskell/Liquid/Types/PrettyPrint.hs view
@@ -0,0 +1,331 @@+-- | This module contains a single function that converts a RType -> Doc+--   without using *any* simplifications.++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ConstraintKinds   #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE TupleSections     #-}++module Language.Haskell.Liquid.Types.PrettyPrint+  ( -- * Printable RTypes+    OkRT+    -- * Printers+  , rtypeDoc+  , ppr_rtype++  -- * Printing Lists (TODO: move to fixpoint)+  , pprManyOrdered+  , pprintLongList+  , pprintSymbol++  ) where++import           Prelude hiding (error)+import           TypeRep hiding (maybeParen)+import           ErrUtils                         (ErrMsg)+import           HscTypes                         (SourceError)+import           SrcLoc+import           GHC                              (Name, Class)+import           Var              (Var)+import           TyCon            (TyCon)+import qualified Data.List    as L -- (sort)+import qualified Data.HashMap.Strict as M+import           Text.PrettyPrint.HughesPJ+import           Language.Fixpoint.Misc+import           Language.Haskell.Liquid.Misc+import           Language.Haskell.Liquid.GHC.Misc+import           Language.Fixpoint.Types       hiding (Error, SrcSpan, Predicate)+import           Language.Haskell.Liquid.Types hiding (sort)++--------------------------------------------------------------------------------+pprManyOrdered :: (PPrint a, Ord a) => Tidy -> String -> [a] -> [Doc]+--------------------------------------------------------------------------------+pprManyOrdered k msg = map ((text msg <+>) . pprintTidy k) . L.sort++--------------------------------------------------------------------------------+pprintLongList :: PPrint a => [a] -> Doc+--------------------------------------------------------------------------------+pprintLongList = brackets . vcat . map pprint+++--------------------------------------------------------------------------------+pprintSymbol :: Symbol -> Doc+--------------------------------------------------------------------------------+pprintSymbol x = char '‘' <> pprint x <> char '’'+++--------------------------------------------------------------------------------+-- | A whole bunch of PPrint instances follow ----------------------------------+--------------------------------------------------------------------------------+instance PPrint ErrMsg where+  pprintTidy _ = text . show++instance PPrint SourceError where+  pprintTidy _ = text . show++instance PPrint Var where+  pprintTidy _ = pprDoc++instance PPrint Name where+  pprintTidy _ = pprDoc++instance PPrint TyCon where+  pprintTidy _ = pprDoc++instance PPrint Type where+  pprintTidy _ = pprDoc -- . tidyType emptyTidyEnv -- WHY WOULD YOU DO THIS???++instance PPrint Class where+  pprintTidy _ = pprDoc++instance Show Predicate where+  show = showpp++instance (PPrint t) => PPrint (Annot t) where+  pprintTidy k (AnnUse t) = text "AnnUse" <+> pprintTidy k t+  pprintTidy k (AnnDef t) = text "AnnDef" <+> pprintTidy k t+  pprintTidy k (AnnRDf t) = text "AnnRDf" <+> pprintTidy k t+  pprintTidy _ (AnnLoc l) = text "AnnLoc" <+> pprDoc l++instance PPrint a => PPrint (AnnInfo a) where+  pprintTidy _ (AI m) = vcat $ map pprAnnInfoBinds $ M.toList m++instance PPrint a => Show (AnnInfo a) where+  show = showpp++pprAnnInfoBinds (l, xvs)+  = vcat $ map (pprAnnInfoBind . (l,)) xvs++pprAnnInfoBind (RealSrcSpan k, xv)+  = xd $$ pprDoc l $$ pprDoc c $$ pprint n $$ vd $$ text "\n\n\n"+    where+      l        = srcSpanStartLine k+      c        = srcSpanStartCol k+      (xd, vd) = pprXOT xv+      n        = length $ lines $ render vd++pprAnnInfoBind (_, _)+  = empty++pprXOT (x, v) = (xd, pprint v)+  where+    xd = maybe (text "unknown") pprint x+--------------------------------------------------------------------------------+-- | Pretty Printing RefType ---------------------------------------------------+--------------------------------------------------------------------------------++-- Should just make this a @Pretty@ instance but its too damn tedious+-- to figure out all the constraints.++type OkRT c tv r = ( TyConable c+                   , PPrint tv+                   , PPrint c+                   , PPrint r+                   , Reftable r+                   , Reftable (RTProp c tv ())+                   , Reftable (RTProp c tv r)+                   , RefTypable c tv ()+                   , RefTypable c tv r+                   , PPrint (RType c tv r)+                   , PPrint (RType c tv ())+                   )++--------------------------------------------------------------------------------+rtypeDoc :: (OkRT c tv r) => Tidy -> RType c tv r -> Doc+--------------------------------------------------------------------------------+rtypeDoc k    = ppr_rtype (ppE k) TopPrec+  where+    ppE Lossy = ppEnvShort ppEnv+    ppE Full  = ppEnv++--------------------------------------------------------------------------------+ppr_rtype :: (OkRT c tv r) => PPEnv -> Prec -> RType c tv r -> Doc+--------------------------------------------------------------------------------+ppr_rtype bb p t@(RAllT _ _)+  = ppr_forall bb p t+ppr_rtype bb p t@(RAllP _ _)+  = ppr_forall bb p t+ppr_rtype bb p t@(RAllS _ _)+  = ppr_forall bb p t+ppr_rtype _ _ (RVar a r)+  = ppTy r $ pprint a+ppr_rtype bb p t@(RFun _ _ _ r)+  = ppTy r $ maybeParen p FunPrec $ ppr_rty_fun bb empty t+ppr_rtype bb p (RApp c [t] rs r)+  | isList c+  = ppTy r $ brackets (ppr_rtype bb p t) <> ppReftPs bb p rs+ppr_rtype bb p (RApp c ts rs r)+  | isTuple c+  = ppTy r $ parens (intersperse comma (ppr_rtype bb p <$> ts)) <> ppReftPs bb p rs+ppr_rtype bb p (RApp c ts rs r)+  | isEmpty rsDoc && isEmpty tsDoc+  = ppTy r $ ppT c+  | otherwise+  = ppTy r $ parens $ ppT c <+> rsDoc <+> tsDoc+  where+    rsDoc            = ppReftPs bb p rs+    tsDoc            = hsep (ppr_rtype bb p <$> ts)+    ppT              = ppTyConB bb++ppr_rtype bb p t@(REx _ _ _)+  = ppExists bb p t+ppr_rtype bb p t@(RAllE _ _ _)+  = ppAllExpr bb p t+ppr_rtype _ _ (RExprArg e)+  = braces $ pprint e+ppr_rtype bb p (RAppTy t t' r)+  = 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]+  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)+  = ppTy r $ text "_"++ppTyConB bb+  | ppShort bb = text . symbolString . dropModuleNames . symbol . render . ppTycon+  | otherwise  = ppTycon++ppr_rsubtype bb p e+  = pprint_env <+> text "|-" <+> ppr_rtype bb p tl <+> "<:" <+> ppr_rtype 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+    pprint_env         = hsep $ punctuate comma (pprint_bind <$> env)++{- NUKE?+ppSpine (RAllT _ t)      = text "RAllT" <+> parens (ppSpine t)+ppSpine (RAllP _ t)      = text "RAllP" <+> parens (ppSpine t)+ppSpine (RAllS _ t)      = text "RAllS" <+> parens (ppSpine t)+ppSpine (RAllE _ _ t)    = text "RAllE" <+> parens (ppSpine t)+ppSpine (REx _ _ t)      = text "REx" <+> parens (ppSpine t)+ppSpine (RFun _ i o _)   = ppSpine i <+> text "->" <+> ppSpine o+ppSpine (RAppTy t t' _)  = text "RAppTy" <+> parens (ppSpine t) <+> parens (ppSpine t')+ppSpine (RHole _)        = text "RHole"+ppSpine (RApp c _ _ _)   = text "RApp" <+> parens (pprint c)+ppSpine (RVar _ _)       = text "RVar"+ppSpine (RExprArg _)     = text "RExprArg"+ppSpine (RRTy _ _ _ _)   = text "RRTy"++-}++-- | From GHC: TypeRep+maybeParen :: Prec -> Prec -> Doc -> Doc+maybeParen ctxt_prec inner_prec pretty+  | ctxt_prec < inner_prec = pretty+  | otherwise                  = parens pretty++-- ppExists :: (RefTypable p c tv (), RefTypable p c tv r) => Bool -> Prec -> RType p 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'+    where (zs,  t')               = split [] t+          split zs (REx x t t')   = split ((x,t):zs) t'+          split zs t                = (reverse zs, t)++-- ppAllExpr :: (RefTypable p c tv (), RefTypable p c tv r) => Bool -> Prec -> RType p c tv r -> Doc+ppAllExpr bb p t+  = text "forall" <+> brackets (intersperse comma [ppr_dbind bb TopPrec x t | (x, t) <- zs]) <> dot <> ppr_rtype bb p t'+    where (zs,  t')               = split [] t+          split zs (RAllE x t t') = split ((x,t):zs) t'+          split zs t                = (reverse zs, t)++ppReftPs _ _ rs+  | all isTauto rs   = empty+  | not (ppPs ppEnv) = empty+  | otherwise        = angleBrackets $ hsep $ punctuate comma $ ppr_ref <$> rs++-- ppr_dbind :: (RefTypable p c tv (), RefTypable p c tv r) => Bool -> Prec -> Symbol -> RType p c tv r -> Doc+ppr_dbind bb p x t+  | isNonSymbol x || (x == dummySymbol)+  = ppr_rtype bb p t+  | otherwise+  = pprint x <> colon <> ppr_rtype bb p t+++ppr_rty_fun bb prefix t+  = prefix <+> ppr_rty_fun' bb t++ppr_rty_fun' bb (RFun b t t' _)+  = ppr_dbind bb FunPrec b t <+> ppr_rty_fun bb arrow t'+ppr_rty_fun' bb t+  = ppr_rtype bb TopPrec t+++-- ppr_forall :: (RefTypable p c tv (), RefTypable p c tv r) => Bool -> Prec -> RType p c tv r -> Doc+ppr_forall :: (OkRT c tv r) => PPEnv -> Prec -> RType c tv r -> Doc+ppr_forall bb p t = maybeParen p FunPrec $ sep [+                      ppr_foralls (ppPs bb) (ty_vars trep) (ty_preds trep) (ty_labels trep)+                    , ppr_clss cls+                    , ppr_rtype bb TopPrec t'+                    ]+  where+    trep          = toRTypeRep t+    (cls, t')     = bkClass $ fromRTypeRep $ trep {ty_vars = [], ty_preds = [], ty_labels = []}++    ppr_foralls False _ _  _  = empty+    ppr_foralls _    [] [] [] = empty+    ppr_foralls True αs πs ss = text "forall" <+> dαs αs <+> dπs (ppPs bb) πs <+> ppr_symbols ss <> dot++    ppr_clss []               = empty+    ppr_clss cs               = (parens $ hsep $ punctuate comma (uncurry (ppr_cls bb p) <$> cs)) <+> text "=>"++    dαs αs                    = sep $ pprint <$> α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++ppr_symbols :: [Symbol] -> Doc+ppr_symbols [] = empty+ppr_symbols ss = angleBrackets $ intersperse comma $ pprint <$> ss++ppr_cls bb p c ts+  = pp c <+> hsep (map (ppr_rtype bb p) ts)+  where+    pp | ppShort bb = text . symbolString . dropModuleNames . 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+  where+    dargs = [ppr_pvar_sort 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 propConName+ppr_pvar_kind _ _ (PVHProp)   = ppr_name hpropConName+ppr_name                      = text . symbolString++ppr_pvar_sort :: (OkRT c tv ()) => PPEnv -> Prec -> RType c tv () -> Doc+ppr_pvar_sort bb p t = ppr_rtype 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))++ppRefArgs :: [Symbol] -> Doc+ppRefArgs [] = empty+ppRefArgs ss = text "\\" <> hsep (ppRefSym <$> ss ++ [vv Nothing]) <+> text "->"++ppRefSym "" = text "_"+ppRefSym s  = pprint s++dot                = char '.'++instance (PPrint r, Reftable r) => PPrint (UReft r) where+  pprintTidy k (MkUReft r p _)+    --- | isTauto r  = pprintTidy k p+    --- | isTauto p  = pprintTidy k r+    | otherwise  = pprintTidy k p <> text " & " <> pprintTidy k r++--------------------------------------------------------------------------------
+ src/Language/Haskell/Liquid/Types/RefType.hs view
@@ -0,0 +1,1145 @@+{-# LANGUAGE IncoherentInstances       #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE UndecidableInstances      #-}+{-# LANGUAGE TypeSynonymInstances      #-}+{-# LANGUAGE TupleSections             #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE PatternGuards             #-}++-- | Refinement Types. Mostly mirroring the GHC Type definition, but with+--   room for refinements of various sorts.++-- TODO: Desperately needs re-organization.+module Language.Haskell.Liquid.Types.RefType (++  -- * Functions for lifting Reft-values to Spec-values+    uTop, uReft, uRType, uRType', uRTypeGen, uPVar++  -- * Applying a solution to a SpecType+  , applySolution++  -- * Functions for decreasing arguments+  , isDecreasing, makeDecrType, makeNumEnv+  , makeLexRefa++  -- * Functions for manipulating `Predicate`s+  , pdVar+  , findPVar+  , freeTyVars, tyClasses, tyConName++  -- TODO: categorize these!+  , ofType, toType+  , rTyVar, rVar, rApp, rEx+  , symbolRTyVar+  , addTyConInfo+  , appRTyCon+  , typeSort, typeUniqueSymbol+  , strengthen+  , generalize, normalizePds+  , subts, subvPredicate, subvUReft+  , subsTyVar_meet, subsTyVar_meet', subsTyVar_nomeet+  , subsTyVars_nomeet, subsTyVars_meet+  , dataConMsReft, dataConReft+  , classBinds++  , isSizeable++  -- * Manipulating Refinements in RTypes+  , rTypeSortedReft+  , rTypeSort+  , shiftVV++  , mkDataConIdsTy+  , mkTyConInfo++  , meetable+  , strengthenRefTypeGen+  , strengthenDataConType++  , isBaseTy++  ) where++import Prelude hiding (error)+import WwLib+import FamInstEnv (emptyFamInstEnv)+import Var+import Kind+import GHC              hiding (Located)+import DataCon+import qualified TyCon  as TC+import TypeRep          hiding (maybeParen, pprArrowChain)+import Type             (splitFunTys, expandTypeSynonyms, substTyWith, isClassPred)+import TysWiredIn       (listTyCon, intDataCon, trueDataCon, falseDataCon,+                         intTyCon, charTyCon)++-- import           Data.Monoid      hiding ((<>))+import           Data.Maybe               (fromMaybe, isJust, fromJust)+import           Data.Hashable+import qualified Data.HashMap.Strict  as M+import qualified Data.HashSet         as S+import qualified Data.List as L++import Control.Monad  (void)+import Text.Printf+import Text.PrettyPrint.HughesPJ++import Language.Haskell.Liquid.Types.Errors+import Language.Haskell.Liquid.Types.PrettyPrint+import qualified Language.Fixpoint.Types as F+import Language.Fixpoint.Types hiding (shiftVV, Predicate)+import Language.Fixpoint.Types.Visitor (mapKVars)+import Language.Haskell.Liquid.Types hiding (R, DataConP (..), sort)++import Language.Haskell.Liquid.Types.Variance++import Language.Haskell.Liquid.Misc+import Language.Haskell.Liquid.Types.Names+import Language.Fixpoint.Misc+import Language.Haskell.Liquid.GHC.Misc (typeUniqueString, tvId, showPpr, stringTyVar, tyConTyVarsDef)++import Data.List (sort, foldl')+++strengthenDataConType (x, t) = (x, fromRTypeRep trep{ty_res = tres})+    where+      trep = toRTypeRep t+      tres = ty_res trep `strengthen` MkUReft (exprReft expr) mempty mempty+      xs   = ty_binds trep+      as   = ty_vars  trep+      x'   = symbol x+      expr | null xs && null as = EVar x'+           | null xs            = mkEApp (dummyLoc x') []+           | otherwise          = mkEApp (dummyLoc x') (EVar <$> xs)++pdVar v        = Pr [uPVar v]++findPVar :: [PVar (RType c tv ())] -> UsedPVar -> PVar (RType c tv ())+findPVar ps p+  = PV name ty v (zipWith (\(_, _, e) (t, s, _) -> (t, s, e)) (pargs p) args)+  where PV name ty v args = fromMaybe (msg p) $ L.find ((== pname p) . pname) ps+        msg p = panic Nothing $ "RefType.findPVar" ++ showpp p ++ "not found"++-- | Various functions for converting vanilla `Reft` to `Spec`++uRType          ::  RType c tv a -> RType c tv (UReft a)+uRType          = fmap uTop++uRType'         ::  RType c tv (UReft a) -> RType c tv a+uRType'         = fmap ur_reft++uRTypeGen       :: Reftable b => RType c tv a -> RType c tv b+uRTypeGen       = fmap $ const mempty++uPVar           :: PVar t -> UsedPVar+uPVar           = void++uReft           :: (Symbol, Expr) -> UReft Reft+uReft           = uTop . Reft++uTop            ::  r -> UReft r+uTop r          = MkUReft r mempty mempty++--------------------------------------------------------------------+-------------- (Class) Predicates for Valid Refinement Types -------+--------------------------------------------------------------------+++-- Monoid Instances ---------------------------------------------------------++instance ( SubsTy tv (RType c tv ()) (RType c tv ())+         , SubsTy tv (RType c tv ()) c+         , RefTypable c tv ()+         , RefTypable c tv r+         , OkRT c tv r+         , FreeVar c tv+         )+        => Monoid (RType c tv r)  where+  mempty  = panic Nothing "mempty: RType"+  mappend = strengthenRefType+++-- MOVE TO TYPES+instance ( SubsTy tv (RType c tv ()) c+         , OkRT c tv r+         , RefTypable c tv r+         , RefTypable c tv ()+         , FreeVar c tv+         , SubsTy tv (RType c tv ()) (RType c tv ()))+         => Monoid (RTProp c tv r) where+  mempty         = panic Nothing "mempty: RTProp"++  mappend (RProp s1 (RHole r1)) (RProp s2 (RHole r2))+    | isTauto r1 = RProp s2 (RHole r2)+    | isTauto r2 = RProp s1 (RHole r1)+    | otherwise  = RProp s1 $ RHole $ r1 `meet`+                               (subst (mkSubst $ zip (fst <$> s2) (EVar . fst <$> s1)) r2)++  mappend (RProp s1 t1) (RProp s2 t2)+    | isTrivial t1 = RProp s2 t2+    | isTrivial t2 = RProp s1 t1+    | otherwise    = RProp s1 $ t1  `strengthenRefType`+                                (subst (mkSubst $ zip (fst <$> s2) (EVar . fst <$> s1)) t2)++instance ( OkRT c tv r+         , RefTypable c tv r+         , RefTypable c tv ()+         , FreeVar c tv+         , SubsTy tv (RType c tv ()) (RType c tv ())+         , SubsTy tv (RType c tv ()) c) => Reftable (RTProp c tv r) where+  isTauto (RProp _ (RHole r)) = isTauto r+  isTauto (RProp _ t)         = isTrivial t+  top (RProp _ (RHole _))     = panic Nothing "RefType: Reftable top called on (RProp _ (RHole _))"+  top (RProp xs t)            = RProp xs $ mapReft top t+  ppTy (RProp _ (RHole r)) d  = ppTy r d+  ppTy (RProp _ _) _          = panic Nothing "RefType: Reftable ppTy in RProp"+  toReft                      = panic Nothing "RefType: Reftable toReft"+  params                      = panic Nothing "RefType: Reftable params for Ref"+  bot                         = panic Nothing "RefType: Reftable bot    for Ref"+  ofReft                      = panic Nothing "RefType: Reftable ofReft for Ref"+++----------------------------------------------------------------------------+-- | Subable Instances -----------------------------------------------------+----------------------------------------------------------------------------++instance Subable (RRProp Reft) where+  syms (RProp ss (RHole r)) = (fst <$> ss) ++ syms r+  syms (RProp ss t)      = (fst <$> ss) ++ syms t+++  subst su (RProp ss (RHole r)) = RProp (mapSnd (subst su) <$> ss) $ RHole $ subst su r+  subst su (RProp ss r)  = RProp  (mapSnd (subst su) <$> ss) $ subst su r+++  substf f (RProp ss (RHole r)) = RProp (mapSnd (substf f) <$> ss) $ RHole $ substf f r+  substf f (RProp ss r) = RProp  (mapSnd (substf f) <$> ss) $ substf f r++  substa f (RProp ss (RHole r)) = RProp (mapSnd (substa f) <$> ss) $ RHole $ substa f r+  substa f (RProp ss r) = RProp  (mapSnd (substa f) <$> ss) $ substa f r+++-------------------------------------------------------------------------------+-- | Reftable Instances -------------------------------------------------------+-------------------------------------------------------------------------------++instance (PPrint r, Reftable r) => Reftable (RType RTyCon RTyVar r) where+  isTauto     = isTrivial+  ppTy        = panic Nothing "ppTy RProp Reftable"+  toReft      = panic Nothing "toReft on RType"+  params      = panic Nothing "params on RType"+  bot         = panic Nothing "bot on RType"+  ofReft      = panic Nothing "ofReft on RType"++++-------------------------------------------------------------------------------+-- | RefTypable Instances -----------------------------------------------------+-------------------------------------------------------------------------------++-- MOVE TO TYPES+instance Fixpoint String where+  toFix = text++-- MOVE TO TYPES+instance Fixpoint Class where+  toFix = text . showPpr++-- MOVE TO TYPES+class FreeVar a v where+  freeVars :: a -> [v]++-- MOVE TO TYPES+instance FreeVar RTyCon RTyVar where+  freeVars = (RTV <$>) . tyConTyVarsDef . rtc_tc++-- MOVE TO TYPES+instance FreeVar LocSymbol Symbol where+  freeVars _ = []++-- Eq Instances ------------------------------------------------------++-- MOVE TO TYPES+instance (RefTypable c tv ()) => Eq (RType c tv ()) where+  (==) = eqRSort M.empty++eqRSort m (RAllP _ t) (RAllP _ t')+  = eqRSort m t t'+eqRSort m (RAllS _ t) (RAllS _ t')+  = eqRSort m t t'+eqRSort m (RAllP _ t) t'+  = eqRSort m t t'+eqRSort m (RAllT a t) (RAllT a' t')+  | a == a'+  = eqRSort m t t'+  | otherwise+  = eqRSort (M.insert a' a m) t t'+eqRSort m (RAllT _ t) t'+  = eqRSort m t t'+eqRSort m t (RAllT _ t')+  = eqRSort m t t'+eqRSort m (RFun _ t1 t2 _) (RFun _ t1' t2' _)+  = eqRSort m t1 t1' && eqRSort m t2 t2'+eqRSort m (RAppTy t1 t2 _) (RAppTy t1' t2' _)+  = eqRSort m t1 t1' && eqRSort m t2 t2'+eqRSort m (RApp c ts _ _) (RApp c' ts' _ _)+  = c == c' && length ts == length ts' && and (zipWith (eqRSort m) ts ts')+eqRSort m (RVar a _) (RVar a' _)+  = a == M.lookupDefault a' a' m+eqRSort _ (RHole _) _+  = True+eqRSort _ _         (RHole _)+  = True+eqRSort _ _ _+  = False++--------------------------------------------------------------------+-- | Wrappers for GHC Type Elements --------------------------------+--------------------------------------------------------------------++instance Eq Predicate where+  (==) = eqpd++eqpd (Pr vs) (Pr ws)+  = and $ (length vs' == length ws') : [v == w | (v, w) <- zip vs' ws']+    where vs' = sort vs+          ws' = sort ws+++instance Eq RTyVar where+  RTV α == RTV α' = tvId α == tvId α'++instance Ord RTyVar where+  compare (RTV α) (RTV α') = compare (tvId α) (tvId α')++instance Hashable RTyVar where+  hashWithSalt i (RTV α) = hashWithSalt i α++instance Ord RTyCon where+  compare x y = compare (rtc_tc x) (rtc_tc y)++instance Hashable RTyCon where+  hashWithSalt i = hashWithSalt i . rtc_tc++--------------------------------------------------------------------+---------------------- Helper Functions ----------------------------+--------------------------------------------------------------------++rVar        = (`RVar` mempty) . RTV+rTyVar      = RTV++symbolRTyVar = rTyVar . stringTyVar . symbolString++normalizePds t = addPds ps t'+  where (t', ps) = nlzP [] t++rPred     = RAllP+rEx xts t = foldr (\(x, tx) t -> REx x tx t) t xts+rApp c    = RApp (RTyCon c [] (mkTyConInfo c [] [] Nothing))++--- NV TODO : remove this code!!!++addPds ps (RAllT v t) = RAllT v $ addPds ps t+addPds ps t           = foldl' (flip rPred) t ps++nlzP ps t@(RVar _ _ )+ = (t, ps)+nlzP ps (RFun b t1 t2 r)+ = (RFun b t1' t2' r, ps ++ ps1 ++ ps2)+  where (t1', ps1) = nlzP [] t1+        (t2', ps2) = nlzP [] t2+nlzP ps (RAppTy t1 t2 r)+ = (RAppTy t1' t2' r, ps ++ ps1 ++ ps2)+  where (t1', ps1) = nlzP [] t1+        (t2', ps2) = nlzP [] t2+nlzP ps (RAllT v t )+ = (RAllT v t', ps ++ ps')+  where (t', ps') = nlzP [] t+nlzP ps t@(RApp _ _ _ _)+ = (t, ps)+nlzP ps (RAllS _ t)+ = (t, ps)+nlzP ps (RAllP p t)+ = (t', [p] ++ ps ++ ps')+  where (t', ps') = nlzP [] t+nlzP ps t@(REx _ _ _)+ = (t, ps)+nlzP ps t@(RRTy _ _ _ t')+ = (t, ps ++ ps')+ where ps' = snd $ nlzP [] t'+nlzP ps t@(RAllE _ _ _)+ = (t, ps)+nlzP _ t+ = panic Nothing $ "RefType.nlzP: cannot handle " ++ show t++strengthenRefTypeGen, strengthenRefType ::+         ( RefTypable c tv ()+         , RefTypable c tv r+         , OkRT c tv r+         , FreeVar c tv+         , SubsTy tv (RType c tv ()) (RType c tv ())+         , SubsTy tv (RType c tv ()) c+         ) => RType c tv r -> RType c tv r -> RType c tv r++strengthenRefType_ ::+         ( RefTypable c tv ()+         , RefTypable c tv r+         -- , PPrint (RType c tv r)+         , OkRT c tv r+         , FreeVar c tv+         , SubsTy tv (RType c tv ()) (RType c tv ())+         , SubsTy tv (RType c tv ()) c+         ) => (RType c tv r -> RType c tv r -> RType c tv r)+           ->  RType c tv r -> RType c tv r -> RType c tv r++strengthenRefTypeGen t1 t2 = strengthenRefType_ f t1 t2+  where+    f (RVar v1 r1) t  = RVar v1 (r1 `meet` fromMaybe mempty (stripRTypeBase t))+    f t (RVar v1 r1)  = RVar v1 (r1 `meet` fromMaybe mempty (stripRTypeBase t))+    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))++pprt_raw :: (OkRT c tv r) => RType c tv r -> String+pprt_raw = render . rtypeDoc Full++-- NEWISH: with unifying type variables: causes big problems with TUPLES?+--strengthenRefType t1 t2 = maybe (errorstar msg) (strengthenRefType_ t1) (unifyShape t1 t2)+--  where msg = printf "strengthen on differently shaped reftypes \nt1 = %s [shape = %s]\nt2 = %s [shape = %s]"+--                 (render t1) (render (toRSort t1)) (render t2) (render (toRSort t2))++-- OLD: without unifying type variables, but checking α-equivalence+strengthenRefType t1 t2+  | 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 :: (OkRT c tv r) => RType c tv r -> RType c tv r -> Bool+meetable t1 t2 = toRSort t1 == toRSort t2++strengthenRefType_ f (RAllT a1 t1) (RAllT a2 t2)+  = RAllT a1 $ strengthenRefType_ f t1 (subsTyVar_meet (a2, toRSort t, t) t2)+  where t = RVar a1 mempty++strengthenRefType_ f (RAllT a t1) t2+  = RAllT a $ strengthenRefType_ f t1 t2++strengthenRefType_ f t1 (RAllT a t2)+  = RAllT a $ strengthenRefType_ f t1 t2++strengthenRefType_ f (RAllP p1 t1) (RAllP _ t2)+  = RAllP p1 $ strengthenRefType_ f t1 t2++strengthenRefType_ f (RAllP p t1) t2+  = RAllP p $ strengthenRefType_ f t1 t2++strengthenRefType_ f t1 (RAllP p t2)+  = RAllP p $ strengthenRefType_ f t1 t2++strengthenRefType_ f (RAllS s t1) t2+  = RAllS s $ strengthenRefType_ f t1 t2++strengthenRefType_ f t1 (RAllS s t2)+  = RAllS s $ strengthenRefType_ f t1 t2++strengthenRefType_ f (RAllE x tx t1) (RAllE y ty t2) | x == y+  = RAllE x (strengthenRefType_ f tx ty) $ strengthenRefType_ f t1 t2++strengthenRefType_ f (RAllE x tx t1) t2+  = RAllE x tx $ strengthenRefType_ f t1 t2++strengthenRefType_ f t1 (RAllE x tx t2)+  = RAllE x tx $ strengthenRefType_ f t1 t2++strengthenRefType_ f (RAppTy t1 t1' r1) (RAppTy t2 t2' r2)+  = RAppTy t t' (r1 `meet` r2)+    where t  = strengthenRefType_ f t1 t2+          t' = strengthenRefType_ f t1' t2'++strengthenRefType_ f (RFun x1 t1 t1' r1) (RFun x2 t2 t2' r2)+  = RFun x2 t t' (r1 `meet` r2)+    where t  = strengthenRefType_ f t1 t2+          t' = strengthenRefType_ f (subst1 t1' (x1, EVar x2)) t2'++strengthenRefType_ f (RApp tid t1s rs1 r1) (RApp _ t2s rs2 r2)+  = RApp tid ts rs (r1 `meet` r2)+    where ts  = zipWith (strengthenRefType_ f) t1s t2s+          rs  = meets rs1 rs2+++strengthenRefType_ _ (RVar v1 r1)  (RVar v2 r2) | v1 == v2+  = RVar v1 (r1 `meet` r2)+strengthenRefType_ f t1 t2+  = f t1 t2++meets :: (F.Reftable r) => [r] -> [r] -> [r]+meets [] rs                 = rs+meets rs []                 = rs+meets rs rs'+  | length rs == length rs' = zipWith meet rs rs'+  | otherwise               = panic Nothing "meets: unbalanced rs"+++strengthen :: Reftable r => RType c tv r -> r -> RType c tv r+strengthen (RApp c ts rs r) r'  = RApp c ts rs (r `meet` r')+strengthen (RVar a r) r'        = RVar a       (r `meet` r')+strengthen (RFun b t1 t2 r) r'  = RFun b t1 t2 (r `meet` r')+strengthen (RAppTy t1 t2 r) r'  = RAppTy t1 t2 (r `meet` r')+strengthen t _                  = t++++-------------------------------------------------------------------------+addTyConInfo :: (PPrint r, Reftable r)+             => (M.HashMap TyCon FTycon)+             -> (M.HashMap TyCon RTyCon)+             -> RRType r+             -> RRType r+-------------------------------------------------------------------------+addTyConInfo tce tyi = mapBot (expandRApp tce tyi)++-------------------------------------------------------------------------+expandRApp :: (PPrint r, Reftable r)+           => (M.HashMap TyCon FTycon)+           -> (M.HashMap TyCon RTyCon)+           -> RRType r+           -> RRType r+-------------------------------------------------------------------------+expandRApp tce tyi t@(RApp {}) = RApp rc' ts rs' r+  where+    RApp rc ts rs r            = t+    rc'                        = appRTyCon tce tyi rc as+    pvs                        = rTyConPVs rc'+    rs'                        = applyNonNull rs0 (rtPropPV rc pvs) rs+    rs0                        = rtPropTop <$> pvs+    n                          = length fVs+    fVs                        = tyConTyVarsDef $ rtc_tc rc+    as                         = choosen n ts (rVar <$> fVs)++    choosen 0 _ _           = []+    choosen i (x:xs) (_:ys) = x:choosen (i-1) xs ys+    choosen i []     (y:ys) = y:choosen (i-1) [] ys+    choosen _ _ _           = impossible Nothing "choosen: this cannot happen"++expandRApp _ _ t               = t++rtPropTop pv = case ptype pv of+                 PVProp t -> RProp xts $ ofRSort t+                 PVHProp  -> RProp xts $ mempty+               where+                 xts      =  pvArgs pv++rtPropPV rc = safeZipWith msg mkRTProp+  where+    msg     = "appRefts: " ++ showFix rc++mkRTProp pv (RProp ss (RHole r))+  = RProp ss $ (ofRSort $ pvType pv) `strengthen` r++mkRTProp pv (RProp ss t)+  | length (pargs pv) == length ss+  = RProp ss t+  | otherwise+  = RProp (pvArgs pv) t++pvArgs pv = [(s, t) | (t, s, _) <- pargs pv]+++appRTyCon tce tyi rc ts = RTyCon c ps' (rtc_info rc'')+  where+    c    = rtc_tc rc+    ps'  = subts (zip (RTV <$> αs) ts') <$> rTyConPVs rc'+    ts'  = if null ts then rVar <$> βs else toRSort <$> ts+    rc'  = M.lookupDefault rc c tyi+    αs   = tyConTyVarsDef $ rtc_tc rc'+    βs   = tyConTyVarsDef c+    rc'' = if isNumeric tce rc' then addNumSizeFun rc' else rc'+++-- RJ: The code of `isNumeric` is incomprehensible.+-- Please fix it to use intSort instead of intFTyCon+isNumeric tce c+  =  fromMaybe+       (symbolFTycon . dummyLoc $ tyConName (rtc_tc c))+       (M.lookup (rtc_tc c) tce) == F.intFTyCon++addNumSizeFun c+  = c {rtc_info = (rtc_info c) {sizeFunction = Just EVar} }+++generalize :: (RefTypable c tv r) => RType c tv r -> RType c tv r+generalize t = mkUnivs (freeTyVars t) [] [] t++freeTyVars (RAllP _ t)     = freeTyVars t+freeTyVars (RAllS _ t)     = freeTyVars t+freeTyVars (RAllT α t)     = freeTyVars t L.\\ [α]+freeTyVars (RFun _ t t' _) = freeTyVars t `L.union` freeTyVars t'+freeTyVars (RApp _ ts _ _) = L.nub $ concatMap freeTyVars ts+freeTyVars (RVar α _)      = [α]+freeTyVars (RAllE _ tx t)  = freeTyVars tx `L.union` freeTyVars t+freeTyVars (REx _ tx t)    = freeTyVars tx `L.union` freeTyVars t+freeTyVars (RExprArg _)    = []+freeTyVars (RAppTy t t' _) = freeTyVars t `L.union` freeTyVars t'+freeTyVars (RHole _)       = []+freeTyVars (RRTy e _ _ t)  = L.nub $ concatMap freeTyVars (t:(snd <$> e))+++tyClasses (RAllP _ t)     = tyClasses t+tyClasses (RAllS _ t)     = tyClasses t+tyClasses (RAllT _ t)     = tyClasses t+tyClasses (RAllE _ _ t)   = tyClasses t+tyClasses (REx _ _ t)     = tyClasses t+tyClasses (RFun _ t t' _) = tyClasses t ++ tyClasses t'+tyClasses (RAppTy t t' _) = tyClasses t ++ tyClasses t'+tyClasses (RApp c ts _ _)+  | Just cl <- tyConClass_maybe $ rtc_tc c+  = [(cl, ts)]+  | otherwise+  = []+tyClasses (RVar _ _)      = []+tyClasses (RRTy _ _ _ t)  = tyClasses t+tyClasses (RHole _)       = []+tyClasses t               = panic Nothing ("RefType.tyClasses cannot handle" ++ show t)+++--------------------------------------------------------------------------------+-- TODO: Rewrite subsTyvars with Traversable+--------------------------------------------------------------------------------++subsTyVars_meet        = subsTyVars True+subsTyVars_nomeet      = subsTyVars False+subsTyVar_nomeet       = subsTyVar False+subsTyVar_meet         = subsTyVar True+subsTyVar_meet' (α, t) = subsTyVar_meet (α, toRSort t, t)++subsTyVars meet ats t = foldl' (flip (subsTyVar meet)) t ats+subsTyVar meet        = subsFree meet S.empty++subsFree m s z (RAllS l t)+  = RAllS l (subsFree m s z t)+subsFree m s z@(α, τ,_) (RAllP π t)+  = RAllP (subt (α, τ) π) (subsFree m s z t)+subsFree m s z (RAllT α t)+  = RAllT α $ subsFree m (α `S.insert` s) z t+subsFree m s z@(_, _, _) (RFun x t t' r)+  = RFun x (subsFree m s z t) (subsFree m s z t') r+subsFree m s z@(α, τ, _) (RApp c ts rs r)+  = RApp (subt z' c) (subsFree m s z <$> ts) (subsFreeRef m s z <$> rs) r+    where z' = (α, τ) -- UNIFY: why instantiating INSIDE parameters?+subsFree meet s (α', _, t') t@(RVar α r)+  | α == α' && not (α `S.member` s)+  = if meet then t' `strengthen` r else t'+  | otherwise+  = t+subsFree m s z (RAllE x t t')+  = RAllE x (subsFree m s z t) (subsFree m s z t')+subsFree m s z (REx x t t')+  = REx x (subsFree m s z t) (subsFree m s z t')+subsFree m s z@(_, _, _) (RAppTy t t' r)+  = subsFreeRAppTy m s (subsFree m s z t) (subsFree m s z t') r+subsFree _ _ _ t@(RExprArg _)+  = t+subsFree m s z (RRTy e r o t)+  = RRTy (mapSnd (subsFree m s z) <$> e) r o (subsFree m s z t)+subsFree _ _ _ t@(RHole _)+  = t++subsFrees m s zs t = foldl' (flip(subsFree m s)) t zs++-- GHC INVARIANT: RApp is Type Application to something other than TYCon+subsFreeRAppTy m s (RApp c ts rs r) t' r'+  = mkRApp m s c (ts ++ [t']) rs r r'+subsFreeRAppTy _ _ t t' r'+  = RAppTy t t' r'++mkRApp m s c ts rs r r'+  | isFun c, [t1, t2] <- ts+  = RFun dummySymbol t1 t2 $ refAppTyToFun r'+  | otherwise+  = subsFrees m s zs $ RApp c ts rs $ r `meet` r' -- (refAppTyToApp r')+  where+    zs = [(tv, toRSort t, t) | (tv, t) <- zip (freeVars c) ts]++refAppTyToFun r+  | isTauto r = r+  | otherwise = panic Nothing "RefType.refAppTyToFun"++subsFreeRef _ _ (α', τ', _) (RProp ss (RHole r))+  = RProp (mapSnd (subt (α', τ')) <$> ss) (RHole r)+subsFreeRef m s (α', τ', t')  (RProp ss t)+  = RProp (mapSnd (subt (α', τ')) <$> ss) $ subsFree m s (α', τ', fmap top t') t+++-------------------------------------------------------------------+------------------- Type Substitutions ----------------------------+-------------------------------------------------------------------++subts = flip (foldr subt)++instance SubsTy tv ty ()   where+  subt _ = id++instance SubsTy tv ty Reft where+  subt _ = id++instance (SubsTy tv ty ty) => SubsTy tv ty (PVKind ty) where+  subt su (PVProp t) = PVProp (subt su t)+  subt _   PVHProp   = PVHProp++instance (SubsTy tv ty ty) => SubsTy tv ty (PVar ty) where+  subt su (PV n t v xts) = PV n (subt su t) v [(subt su t, x, y) | (t,x,y) <- xts]++instance SubsTy RTyVar RSort RTyCon where+   subt z c = RTyCon tc ps' i+     where+       tc   = rtc_tc c+       ps'  = subt z <$> rTyConPVs c+       i    = rtc_info c++-- NOTE: This DOES NOT substitute at the binders+instance SubsTy RTyVar RSort PrType where+  subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ)++instance SubsTy RTyVar RSort SpecType where+  subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ)++instance SubsTy RTyVar RTyVar SpecType where+  subt (α, a) = subt (α, RVar a () :: RSort)+++instance SubsTy RTyVar RSort RSort where+  subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ)++-- Here the "String" is a Bare-TyCon. TODO: wrap in newtype+instance SubsTy Symbol BSort LocSymbol where+  subt _ t = t++instance SubsTy Symbol BSort BSort where+  subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ)++instance (SubsTy tv ty (UReft r), SubsTy tv ty (RType c tv ())) => SubsTy tv ty (RTProp c tv (UReft r))  where+  subt m (RProp ss (RHole p)) = RProp ((mapSnd (subt m)) <$> ss) $ RHole $ subt m p+  subt m (RProp ss t) = RProp ((mapSnd (subt m)) <$> ss) $ fmap (subt m) t++subvUReft     :: (UsedPVar -> UsedPVar) -> UReft Reft -> UReft Reft+subvUReft f (MkUReft r p s) = MkUReft r (subvPredicate f p) s++subvPredicate :: (UsedPVar -> UsedPVar) -> Predicate -> Predicate+subvPredicate f (Pr pvs) = Pr (f <$> pvs)++---------------------------------------------------------------++ofType = ofType_ . expandTypeSynonyms++ofType_ (TyVarTy α)+  = rVar α+ofType_ (FunTy τ τ')+  = rFun dummySymbol (ofType_ τ) (ofType_ τ')+ofType_ (ForAllTy α τ)+  | isKindVar α+  = ofType_ τ+  | otherwise+  = RAllT (rTyVar α) $ ofType_ τ+ofType_ (TyConApp c τs)+  | Just (αs, τ) <- TC.synTyConDefn_maybe c+  = ofType_ $ substTyWith αs τs τ+  | otherwise+  = rApp c (ofType_ <$> filter (not . isKind) τs) [] mempty+ofType_ (AppTy t1 t2)+  = RAppTy (ofType_ t1) (ofType t2) mempty+ofType_ (LitTy x)+  = fromTyLit x+  where+    fromTyLit (NumTyLit _) = rApp intTyCon [] [] mempty+    fromTyLit (StrTyLit _) = rApp listTyCon [rApp charTyCon [] [] mempty] [] mempty++--------------------------------------------------------------------------------+-- | Converting to Fixpoint ----------------------------------------------------+--------------------------------------------------------------------------------+++instance Expression Var where+  expr   = eVar++-- TODO: turn this into a map lookup?+dataConReft ::  DataCon -> [Symbol] -> Reft+dataConReft c []+  | c == trueDataCon+  = predReft $ eProp vv_+  | c == falseDataCon+  = predReft $ PNot $ eProp vv_++dataConReft c [x]+  | c == intDataCon+  = symbolReft x -- OLD (vv_, [RConc (PAtom Eq (EVar vv_) (EVar x))])+dataConReft c _+  | not $ isBaseDataCon c+  = mempty+dataConReft c xs+  = exprReft dcValue -- OLD Reft (vv_, [RConc (PAtom Eq (EVar vv_) dcValue)])+  where+    dcValue+      | null xs && null (dataConUnivTyVars c)+      = EVar $ symbol c+      | otherwise+      = mkEApp (dummyLoc $ symbol c) (eVar <$> xs)++isBaseDataCon c = and $ isBaseTy <$> dataConOrigArgTys c ++ dataConRepArgTys c++isBaseTy (TyVarTy _)     = True+isBaseTy (AppTy _ _)     = False+isBaseTy (TyConApp _ ts) = and $ isBaseTy <$> ts+isBaseTy (FunTy _ _)     = False+isBaseTy (ForAllTy _ _)  = False+isBaseTy (LitTy _)       = True+++dataConMsReft ty ys  = subst su (rTypeReft (ignoreOblig $ ty_res trep))+  where+    trep = toRTypeRep ty+    xs   = ty_binds trep+    ts   = ty_args  trep+    su   = mkSubst $ [(x, EVar y) | ((x, _), y) <- zip (zip xs ts) ys]++---------------------------------------------------------------+---------------------- Embedding RefTypes ---------------------+---------------------------------------------------------------+-- TODO: remove toType, generalize typeSort+toType  :: (Reftable r, PPrint r) => RRType r -> Type+toType (RFun _ t t' _)+  = FunTy (toType t) (toType t')+toType (RAllT (RTV α) t)+  = ForAllTy α (toType t)+toType (RAllP _ t)+  = toType t+toType (RAllS _ t)+  = toType t+toType (RVar (RTV α) _)+  = TyVarTy α+toType (RApp (RTyCon {rtc_tc = c}) ts _ _)+  = TyConApp c (toType <$> filter notExprArg ts)+  where+  notExprArg (RExprArg _) = False+  notExprArg _            = True+toType (RAllE _ _ t)+  = toType t+toType (REx _ _ t)+  = toType t+toType (RAppTy t (RExprArg _) _)+  = toType t+toType (RAppTy t t' _)+  = AppTy (toType t) (toType t')+toType t@(RExprArg _)+  = impossible Nothing $ "CANNOT HAPPEN: RefType.toType called with: " ++ show t+toType (RRTy _ _ _ t)+  = toType t+toType t+  = impossible Nothing $ "RefType.toType cannot handle: " ++ show t+++--------------------------------------------------------------------------------+-- | Annotations and Solutions -------------------------------------------------+--------------------------------------------------------------------------------++rTypeSortedReft ::  (PPrint r, Reftable r) => TCEmb TyCon -> RRType r -> SortedReft+rTypeSortedReft emb t = RR (rTypeSort emb t) (rTypeReft t)++rTypeSort     ::  (PPrint r, Reftable r) => TCEmb TyCon -> RRType r -> Sort+rTypeSort tce = typeSort tce . toType++-------------------------------------------------------------------------------+applySolution :: (Functor f) => FixSolution -> f SpecType -> f SpecType+-------------------------------------------------------------------------------+applySolution = fmap . fmap . mapReft . appSolRefa+  where+    mapReft f (MkUReft (Reft (x, z)) p s) = MkUReft (Reft (x, f z)) p s+-- OLD    appSolRefa _ ra@(RConc _)        = ra+-- OLD    appSolRefa s (RKvar k su)        = RConc $ subst su $ M.lookupDefault PTop k s++appSolRefa s p = mapKVars f p+  where+    f k        = Just $ M.lookupDefault PTop k s++-------------------------------------------------------------------------------+shiftVV :: SpecType -> Symbol -> SpecType+-------------------------------------------------------------------------------+shiftVV t@(RApp _ ts rs r) vv'+  = t { rt_args  = subst1 ts (rTypeValueVar t, EVar vv') }+      { rt_pargs = subst1 rs (rTypeValueVar t, EVar vv') }+      { rt_reft  = (`F.shiftVV` vv') <$> r }++shiftVV t@(RFun _ _ _ r) vv'+  = t { rt_reft = (`F.shiftVV` vv') <$> r }++shiftVV t@(RAppTy _ _ r) vv'+  = t { rt_reft = (`F.shiftVV` vv') <$> r }++shiftVV t@(RVar _ r) vv'+  = t { rt_reft = (`F.shiftVV` vv') <$> r }++shiftVV t _+  = t -- errorstar $ "shiftVV: cannot handle " ++ showpp t+++------------------------------------------------------------------------+---------------- Auxiliary Stuff Used Elsewhere ------------------------+------------------------------------------------------------------------++-- MOVE TO TYPES+instance (Show tv, Show ty) => Show (RTAlias tv ty) where+  show (RTA n as xs t p _) =+    printf "type %s %s %s = %s -- defined at %s" (symbolString n)+      (unwords (show <$> as))+      (unwords (show <$> xs))+      (show t) (show p)++----------------------------------------------------------------+------------ From Old Fixpoint ---------------------------------+----------------------------------------------------------------++typeUniqueSymbol :: Type -> Symbol+typeUniqueSymbol = symbol . typeUniqueString++typeSort :: TCEmb TyCon -> Type -> Sort+typeSort tce τ@(ForAllTy _ _)+  = typeSortForAll tce τ+typeSort tce t@(FunTy _ _)+  = typeSortFun tce t+typeSort tce (TyConApp c τs)+  = fAppTC (tyConFTyCon tce c) (typeSort tce <$> τs)+typeSort tce (AppTy t1 t2)+  = fApp (typeSort tce t1) [typeSort tce t2]+typeSort _ τ+  = FObj $ typeUniqueSymbol τ++tyConFTyCon tce c    = fromMaybe (symbolFTycon $ dummyLoc $ tyConName c) (M.lookup c tce)++typeSortForAll tce τ+  = genSort $ typeSort tce tbody+  where genSort t           = foldl (flip FAbs) (sortSubst su t) [0..n-1]+        (as, tbody)         = splitForAllTys τ+        su                  = M.fromList $ zip sas (FVar <$>  [0..])+        sas                 = (typeUniqueSymbol . TyVarTy) <$> as+        n                   = length as++tyConName c+  | listTyCon == c    = listConName+  | TC.isTupleTyCon c = tupConName+  | otherwise         = symbol c++typeSortFun tce t -- τ1 τ2+  = mkFFunc 0  sos+  where sos  = typeSort tce <$> τs+        τs   = grabArgs [] t++grabArgs τs (FunTy τ1 τ2)+  | not $ isClassPred τ1 = grabArgs (τ1:τs) τ2+  | otherwise            = grabArgs τs τ2+grabArgs τs τ            = reverse (τ:τs)+++mkDataConIdsTy (dc, t) = [ expandProductType x t | x <- dataConImplicitIds dc]++expandProductType x t+  | ofType (varType x) == toRSort t = (x, t)+  | otherwise                       = (x, t')+     where t'         = fromRTypeRep $ trep {ty_binds = xs', ty_args = ts', ty_refts = rs'}+           τs         = fst $ splitFunTys $ toType t+           trep       = toRTypeRep t+           (xs', ts', rs') = unzip3 $ concatMap mkProductTy $ zip4 τs (ty_binds trep) (ty_args trep) (ty_refts trep)++mkProductTy (τ, x, t, r) = maybe [(x, t, r)] f $ deepSplitProductType_maybe menv τ+  where f    = ((<$>) ((dummySymbol, , mempty) . ofType)) . third4+        menv = (emptyFamInstEnv, emptyFamInstEnv)++-----------------------------------------------------------------------------------------+-- | Binders generated by class predicates, typically for constraining tyvars (e.g. FNum)+-----------------------------------------------------------------------------------------++classBinds (RApp c ts _ _)+   | isFracCls c+   = [(rTyVarSymbol a, trueSortedReft FFrac) | (RVar a _) <- ts]+   | isNumCls c+   = [(rTyVarSymbol a, trueSortedReft FNum) | (RVar a _) <- ts]+classBinds _+  = []++rTyVarSymbol (RTV α) = typeUniqueSymbol $ TyVarTy α++-----------------------------------------------------------------------------------------+--------------------------- Termination Predicates --------------------------------------+-----------------------------------------------------------------------------------------++makeNumEnv = concatMap go+  where+    go (RApp c ts _ _) | isNumCls c || isFracCls c = [ a | (RVar a _) <- ts]+    go _ = []++isDecreasing autoenv  _ (RApp c _ _ _)+  =  isJust (sizeFunction (rtc_info c)) -- user specified size or+  || isSizeable autoenv tc+  where tc = rtc_tc c+isDecreasing _ cenv (RVar v _)+  = v `elem` cenv+isDecreasing _ _ _+  = False++makeDecrType autoenv = mkDType autoenv [] []++mkDType autoenv xvs acc [(v, (x, t))]+  = (x, ) $ t `strengthen` tr+  where+    tr = uTop $ Reft (vv, pOr (r:acc))+    r  = cmpLexRef xvs (v', vv, f)+    v' = symbol v+    f  = mkDecrFun autoenv  t+    vv = "vvRec"++mkDType autoenv xvs acc ((v, (x, t)):vxts)+  = mkDType autoenv ((v', x, f):xvs) (r:acc) vxts+  where+    r  = cmpLexRef xvs  (v', x, f)+    v' = symbol v+    f  = mkDecrFun autoenv t+++mkDType _ _ _ _+  = panic Nothing "RefType.mkDType called on invalid input"++isSizeable  :: S.HashSet TyCon -> TyCon -> Bool+isSizeable autoenv tc =  S.member tc autoenv --   TC.isAlgTyCon tc -- && TC.isRecursiveTyCon tc++mkDecrFun autoenv (RApp c _ _ _)+  | Just f <- sizeFunction $ rtc_info c+  = f+  | isSizeable autoenv $ rtc_tc c+  = \v -> F.mkEApp lenLocSymbol [F.EVar v]+mkDecrFun _ (RVar _ _)+  = EVar+mkDecrFun _ _+  = panic Nothing "RefType.mkDecrFun called on invalid input"++cmpLexRef vxs (v, x, g)+  = pAnd $  (PAtom Lt (g x) (g v)) : (PAtom Ge (g x) zero)+         :  [PAtom Eq (f y) (f z) | (y, z, f) <- vxs]+         ++ [PAtom Ge (f y) zero  | (y, _, f) <- vxs]+  where zero = ECon $ I 0++makeLexRefa es' es = uTop $ Reft (vv, PIff (EVar vv) $ pOr rs)+  where+    rs = makeLexReft [] [] es es'+    vv = "vvRec"++makeLexReft _ acc [] []+  = acc+makeLexReft old acc (e:es) (e':es')+  = makeLexReft ((e,e'):old) (r:acc) es es'+  where+    r    = pAnd $  (PAtom Lt e' e)+                :  (PAtom Ge e' zero)+                :  [PAtom Eq o' o    | (o,o') <- old]+                ++ [PAtom Ge o' zero | (_,o') <- old]+    zero = ECon $ I 0+makeLexReft _ _ _ _+  = panic Nothing "RefType.makeLexReft on invalid input"++--------------------------------------------------------------------------------+mkTyConInfo :: TyCon -> VarianceInfo -> VarianceInfo -> (Maybe (Symbol -> Expr)) -> TyConInfo+mkTyConInfo c usertyvar userprvariance f+  = TyConInfo (if null usertyvar then defaulttyvar else usertyvar) userprvariance f+  where+        defaulttyvar      = makeTyConVariance c+++makeTyConVariance :: TyCon -> VarianceInfo+makeTyConVariance c = varSignToVariance <$> tvs+  where+    tvs = tyConTyVarsDef c++    varsigns = if TC.isTypeSynonymTyCon c+                  then go True (fromJust $ TC.synTyConRhs_maybe c)+                  else L.nub $ concatMap goDCon $ TC.tyConDataCons c++    varSignToVariance v = case filter (\p -> showPpr (fst p) == showPpr v) varsigns of+                            []       -> Invariant+                            [(_, b)] -> if b then Covariant else Contravariant+                            _        -> Bivariant+++    goDCon dc = concatMap (go True) (DataCon.dataConOrigArgTys dc)++    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'+       = concat $ zipWith (goTyConApp pos) (repeat Bivariant) ts+       | otherwise+       = concat $ zipWith (goTyConApp pos) (makeTyConVariance c') ts++    go pos (FunTy t1 t2)   = go (not pos) t1 ++ go pos t2+    go _   (LitTy _)       = []++    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 c = mconcat $ go <$> [t | dc <- TC.tyConDataCons c, t <- DataCon.dataConOrigArgTys dc]+  where+    go (ForAllTy _ t)  = go t+    go (TyVarTy _)     = S.empty+    go (AppTy t1 t2)   = go t1 `S.union` go t2+    go (TyConApp c ts) = S.insert c $ mconcat $ go <$> ts+    go (FunTy t1 t2)   = go t1 `S.union` go t2+    go (LitTy _)       = S.empty++--------------------------------------------------------------------------------+-- | Printing Refinement Types -------------------------------------------------+--------------------------------------------------------------------------------++-- MOVE TO TYPES+instance (SubsTy Symbol (RType c Symbol ()) c, TyConable c, Reftable r, PPrint r, PPrint c, FreeVar c Symbol, SubsTy Symbol (RType c Symbol ()) (RType c Symbol ())) => RefTypable c Symbol r where+  ppRType = ppr_rtype ppEnv++-- MOVE TO TYPES+instance (Reftable r, PPrint r) => RefTypable RTyCon RTyVar r where+  ppRType = ppr_rtype ppEnv++instance Show RTyVar where+  show = showpp++instance PPrint (UReft r) => Show (UReft r) where+  show = showpp++instance (RefTypable c tv r) => PPrint (RType c tv r) where+  pprintTidy _ = ppRType TopPrec++instance PPrint (RType c tv r) => Show (RType c tv r) where+  show = showpp++instance PPrint (RTProp c tv r) => Show (RTProp c tv r) where+  show = showpp++instance PPrint REnv where+  pprintTidy k re = text "RENV" $+$+              pprintTidy k (reLocal re)
+ src/Language/Haskell/Liquid/Types/Specifications.hs view
@@ -0,0 +1,10 @@+-- | This module contains the LH specifications (assumes) for+--   various imported modules.++module Language.Haskell.Liquid.Types.Specifications (specAnchor) where++++-- | Gross hack, to force dependency and loading of module.+specAnchor :: Int+specAnchor = 7
+ src/Language/Haskell/Liquid/Types/Strata.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE TypeSynonymInstances      #-}+{-# LANGUAGE FlexibleInstances         #-}++module Language.Haskell.Liquid.Types.Strata (+    SubStratum(..)+  , solveStrata+  , (<:=)+  ) where++import Prelude hiding (error)+++import Language.Fixpoint.Types (Symbol)+import Language.Haskell.Liquid.Types hiding (Def, Loc)++s1 <:= s2+  | any (==SDiv) s1 && any (==SFin) s2 = False+  | otherwise                          = True++solveStrata = go True [] []+  where go False solved _   [] = solved+        go True  solved acc [] = go False solved [] $ {-traceShow ("OLD \n" ++ showMap solved acc ) $ -} subsS solved <$> acc+        go mod   solved acc (([], _):ls) = go mod solved acc ls+        go mod   solved acc ((_, []):ls) = go mod solved acc ls+        go mod   solved acc (l:ls) | allSVars l  = go mod solved (l:acc) ls+                                   | noSVar   l  = go mod solved acc ls+                                   | noUpdate l  = go mod solved (l:acc) ls+                                   | otherwise   = go True (solve l ++ solved) (l:acc) ls+++allSVars (xs, ys) = all isSVar $ xs ++ ys+noSVar   (xs, ys) = all (not . isSVar) (xs ++ ys)+noUpdate (xs, ys) = (not $ updateFin(xs, ys)) && (not $ updateDiv (xs, ys))++updateFin (xs, ys) = any (==SFin) ys && any isSVar   xs+updateDiv (xs, ys) = any isSVar   ys && any (==SDiv) xs++solve (xs, ys)+  | any (== SDiv) xs = [(l, SDiv) | SVar l <- ys]+  | any (== SFin) ys = [(l, SFin) | SVar l <- xs]+  | otherwise        = []+++class SubStratum a where+  subS  :: (Symbol, Stratum) -> a -> a+  subsS :: [(Symbol, Stratum)] -> a -> a++  subsS su x = foldr subS x su++instance SubStratum Stratum where+  subS (x, s) (SVar y) | x == y    = s+                       | otherwise = (SVar y)+  subS _      s        = s+++instance (SubStratum a, SubStratum b) => SubStratum (a, b) where+  subS su (x, y) = (subS su x, subS su y)++instance (SubStratum a) => SubStratum [a] where+  subS su xs = subS su <$> xs++instance SubStratum (Annot SpecType) where+  subS su (AnnUse t) = AnnUse $ subS su t+  subS su (AnnDef t) = AnnDef $ subS su t+  subS su (AnnRDf t) = AnnRDf $ subS su t+  subS _  (AnnLoc s) = AnnLoc s++instance SubStratum SpecType where+  subS su t = (\r -> r {ur_strata = subS su (ur_strata r)}) <$> t
+ src/Language/Haskell/Liquid/Types/Variance.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-}++module Language.Haskell.Liquid.Types.Variance ( Variance(..), VarianceInfo ) where++import Prelude hiding (error)+import Control.DeepSeq+import Data.Typeable+import Data.Data+import GHC.Generics++type VarianceInfo = [Variance]+data Variance = Invariant | Bivariant | Contravariant | Covariant+              deriving (Data, Typeable, Show, Generic)++instance NFData Variance
+ src/Language/Haskell/Liquid/Types/Visitors.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TypeSynonymInstances      #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE TupleSections             #-}+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE ScopedTypeVariables       #-}+++module Language.Haskell.Liquid.Types.Visitors (++  -- * visitors+  CBVisitable (..)++  ) where++import Prelude hiding (error)+import DataCon+import Literal+import CoreSyn++import Var++import Data.List (foldl', (\\), delete)++import qualified Data.HashSet        as S+import Language.Fixpoint.Misc+import Language.Haskell.Liquid.GHC.Misc ()+++------------------------------------------------------------------------------+-------------------------------- A CoreBind Visitor --------------------------+------------------------------------------------------------------------------++-- TODO: syb-shrinkage++class CBVisitable a where+  freeVars :: S.HashSet Var -> a -> [Var]+  readVars :: a -> [Var]+  letVars  :: a -> [Var]+  literals :: a -> [Literal]++instance CBVisitable [CoreBind] where+  freeVars env cbs = (sortNub xs) \\ ys+    where xs = concatMap (freeVars env) cbs+          ys = concatMap bindings cbs++  readVars = concatMap readVars+  letVars  = concatMap letVars+  literals = concatMap literals++instance CBVisitable CoreBind where+  freeVars env (NonRec x e) = freeVars (extendEnv env [x]) e+  freeVars env (Rec xes)    = concatMap (freeVars env') es+                              where (xs,es) = unzip xes+                                    env'    = extendEnv env xs++  readVars (NonRec _ e)     = readVars e+  readVars (Rec xes)        = concat [x `delete` nubReadVars e |(x, e) <- xes]+    where nubReadVars = sortNub . readVars++  letVars (NonRec x e)      = x : letVars e+  letVars (Rec xes)         = xs ++ concatMap letVars es+    where+      (xs, es)              = unzip xes++  literals (NonRec _ e)      = literals e+  literals (Rec xes)         = concatMap literals $ map snd xes++instance CBVisitable (Expr Var) where+  freeVars = exprFreeVars+  readVars = exprReadVars+  letVars  = exprLetVars+  literals = exprLiterals++exprFreeVars = go+  where+    go env (Var x)         = if x `S.member` env then [] else [x]+    go env (App e a)       = (go env e) ++ (go env a)+    go env (Lam x e)       = go (extendEnv env [x]) e+    go env (Let b e)       = (freeVars env b) ++ (go (extendEnv env (bindings b)) e)+    go env (Tick _ e)      = go env e+    go env (Cast e _)      = go env e+    go env (Case e x _ cs) = (go env e) ++ (concatMap (freeVars (extendEnv env [x])) cs)+    go _   _               = []++exprReadVars = go+  where+    go (Var x)             = [x]+    go (App e a)           = concatMap go [e, a]+    go (Lam _ e)           = go e+    go (Let b e)           = readVars b ++ go e+    go (Tick _ e)          = go e+    go (Cast e _)          = go e+    go (Case e _ _ cs)     = (go e) ++ (concatMap readVars cs)+    go _                   = []++exprLetVars = go+  where+    go (Var _)             = []+    go (App e a)           = concatMap go [e, a]+    go (Lam x e)           = x : go e+    go (Let b e)           = letVars b ++ go e+    go (Tick _ e)          = go e+    go (Cast e _)          = go e+    go (Case e x _ cs)     = x : go e ++ concatMap letVars cs+    go _                   = []++exprLiterals = go+  where+    go (Lit l)             = [l]+    go (App e a)           = concatMap go [e, a]+    go (Let b e)           = literals b ++ go e+    go (Lam _ e)           = go e+    go (Tick _ e)          = go e+    go (Cast e _)          = go e+    go (Case e _ _ cs)     = (go e) ++ (concatMap literals cs)+    go _                   = []+++instance CBVisitable (Alt Var) where+  freeVars env (a, xs, e) = freeVars env a ++ freeVars (extendEnv env xs) e+  readVars (_,_, e)       = readVars e+  letVars  (_,xs,e)       = xs ++ letVars e+  literals (c,_, e)       = literals c ++ literals e+++instance CBVisitable AltCon where+  freeVars _ (DataAlt dc) = dataConImplicitIds dc+  freeVars _ _            = []+  readVars _              = []+  letVars  _              = []+  literals (LitAlt l)     = [l]+  literals _              = []++++extendEnv = foldl' (flip S.insert)++bindings (NonRec x _)+  = [x]+bindings (Rec  xes  )+  = map fst xes
+ src/Language/Haskell/Liquid/UX/ACSS.hs view
@@ -0,0 +1,267 @@+-- | Formats Haskell source code as HTML with CSS and Mouseover Type Annotations+module Language.Haskell.Liquid.UX.ACSS (+    hscolour+  , hsannot+  , AnnMap (..)+  , breakS+  , srcModuleName+  , Status (..)+  ) where++import Prelude hiding (error)++import Language.Haskell.HsColour.Anchors+import Language.Haskell.HsColour.Classify as Classify+import Language.Haskell.HsColour.HTML (renderAnchors, escape)+import qualified Language.Haskell.HsColour.CSS as CSS++import Data.Either (partitionEithers)+import Data.Maybe  (fromMaybe)+import qualified Data.HashMap.Strict as M+import Data.List   (find, isPrefixOf, findIndex, elemIndices, intercalate)+import Data.Char   (isSpace)+import Text.Printf+import Language.Haskell.Liquid.GHC.Misc+import Language.Haskell.Liquid.Types.Errors (panic, impossible)++data AnnMap  = Ann {+    types  :: M.HashMap Loc (String, String) -- ^ Loc -> (Var, Type)+  , errors :: [(Loc, Loc, String)]           -- ^ List of error intervals+  , status :: !Status+  }++data Status = Safe | Unsafe | Error | Crash+              deriving (Eq, Ord, Show)++data Annotation = A {+    typ :: Maybe String         -- ^ type  string+  , err :: Maybe String         -- ^ error string+  , lin :: Maybe (Int, Int)     -- ^ line number, total width of lines i.e. max (length (show lineNum))+  } deriving (Show)+++-- | Formats Haskell source code using HTML and mouse-over annotations+hscolour :: Bool     -- ^ Whether to include anchors.+         -> Bool     -- ^ Whether input document is literate haskell or not+         -> String   -- ^ Haskell source code, Annotations as comments at end+         -> String   -- ^ Coloured Haskell source code.++hscolour anchor lhs = hsannot anchor Nothing lhs . splitSrcAndAnns++type CommentTransform = Maybe (String -> [(TokenType, String)])++-- | Formats Haskell source code using HTML and mouse-over annotations+hsannot  :: Bool             -- ^ Whether to include anchors.+         -> CommentTransform -- ^ Function to refine comment tokens+         -> Bool             -- ^ Whether input document is literate haskell or not+         -> (String, AnnMap) -- ^ Haskell Source, Annotations+         -> String           -- ^ Coloured Haskell source code.++hsannot anchor tx False z     = hsannot' Nothing anchor tx z+hsannot anchor tx True (s, m) = concatMap chunk $ litSpans $ joinL $ classify $ inlines s+  where chunk (Code c, l)     = hsannot' (Just l) anchor tx (c, m)+        chunk (Lit c , _)     = c++litSpans :: [Lit] -> [(Lit, Loc)]+litSpans lits = zip lits $ spans lits+  where spans = tokenSpans Nothing . map unL++hsannot' baseLoc anchor tx =+    CSS.pre+    . (if anchor then concatMap (renderAnchors renderAnnotToken)+                      . insertAnnotAnchors+                 else concatMap renderAnnotToken)+    . annotTokenise baseLoc tx++-- | annotTokenise is absurdly slow: O(#tokens x #errors)++annotTokenise :: Maybe Loc -> CommentTransform -> (String, AnnMap) -> [(TokenType, String, Annotation)]+annotTokenise baseLoc tx (src, annm) = zipWith (\(x,y) z -> (x,y,z)) toks annots+  where+    toks       = tokeniseWithCommentTransform tx src+    spans      = tokenSpans baseLoc $ map snd toks+    annots     = fmap (spanAnnot linWidth annm) spans+    linWidth   = length $ show $ length $ lines src++spanAnnot 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]+    b = spanLine w span++spanLine w (L (l, c))+  | c == 1    = Just (l, w)+  | otherwise = Nothing++inRange (L (l0, c0)) (L (l, c), L (l', c'))+  = l <= l0 && c <= c0 && l0 <= l' && c0 < c'++tokeniseWithCommentTransform :: Maybe (String -> [(TokenType, String)]) -> String -> [(TokenType, String)]+tokeniseWithCommentTransform Nothing  = tokenise+tokeniseWithCommentTransform (Just f) = concatMap (expand f) . tokenise+  where expand f (Comment, s) = f s+        expand _ z            = [z]++tokenSpans :: Maybe Loc -> [String] -> [Loc]+tokenSpans = scanl plusLoc . fromMaybe (L (1, 1))++plusLoc :: Loc -> String -> Loc+plusLoc (L (l, c)) s+  = case '\n' `elemIndices` s of+      [] -> L (l, (c + n))+      is -> L ((l + length is), (n - maximum is))+    where n = length s++renderAnnotToken :: (TokenType, String, Annotation) -> String+renderAnnotToken (x, y, a)  = renderLinAnnot (lin a)+                            $ renderErrAnnot (err a)+                            $ renderTypAnnot (typ a)+                            $ CSS.renderToken (x, y)++++renderTypAnnot (Just ann) s = printf "<a class=annot href=\"#\"><span class=annottext>%s</span>%s</a>" (escape ann) s+renderTypAnnot Nothing    s = s++renderErrAnnot (Just _) s   = printf "<span class=hs-error>%s</span>" s+renderErrAnnot Nothing  s   = s++renderLinAnnot (Just d) s   = printf "<span class=hs-linenum>%s: </span>%s" (lineString d) s+renderLinAnnot Nothing  s   = s++lineString (i, w) = (replicate (w - (length is)) ' ') ++ is+  where is        = show i++{- Example Annotation:+<a class=annot href="#"><span class=annottext>x#agV:Int -&gt; {VV_int:Int | (0 &lt;= VV_int),(x#agV &lt;= VV_int)}</span>+<span class='hs-definition'>NOWTRYTHIS</span></a>+-}+++insertAnnotAnchors :: [(TokenType, String, a)] -> [Either String (TokenType, String, a)]+insertAnnotAnchors toks+  = stitch (zip toks' toks) $ insertAnchors toks'+  where toks' = [(x,y) | (x,y,_) <- toks]++stitch ::  Eq b => [(b, c)] -> [Either a b] -> [Either a c]+stitch xys ((Left a) : rest)+  = (Left a) : stitch xys rest+stitch ((x,y):xys) ((Right x'):rest)+  | x == x'+  = (Right y) : stitch xys rest+  | otherwise+  = panic Nothing "stitch"+stitch _ []+  = []+stitch _ _+  = impossible Nothing "stitch: cannot happen"++splitSrcAndAnns ::  String -> (String, AnnMap)+splitSrcAndAnns s =+  let ls = lines s in+  case findIndex (breakS ==) ls of+    Nothing -> (s, Ann M.empty [] Safe)+    Just i  -> (src, ann)+               where (codes, _:mname:annots) = splitAt i ls+                     ann   = annotParse mname $ dropWhile isSpace $ unlines annots+                     src   = unlines codes++srcModuleName :: String -> String+srcModuleName = fromMaybe "Main" . tokenModule . tokenise++tokenModule toks+  = do i <- findIndex ((Keyword, "module") ==) toks+       let (_, toks')  = splitAt (i+2) toks+       j <- findIndex ((Space ==) . fst) toks'+       let (toks'', _) = splitAt j toks'+       return $ concatMap snd toks''++breakS = "MOUSEOVER ANNOTATIONS"++annotParse :: String -> String -> AnnMap+annotParse mname s = Ann (M.fromList ts) [(x,y,"") | (x,y) <- es] Safe+  where+    (ts, es)       = partitionEithers $ parseLines mname 0 $ lines s+++parseLines _ _ []+  = []++parseLines mname i ("":ls)+  = parseLines mname (i+1) ls++parseLines mname i (_:_:l:c:"0":l':c':rest')+  = Right (L (line, col), L (line', col')) : parseLines mname (i + 7) rest'+    where line  = (read l)  :: Int+          col   = (read c)  :: Int+          line' = (read l') :: Int+          col'  = (read c') :: Int++parseLines mname i (x:f:l:c:n:rest)+  | f /= mname+  = parseLines mname (i + 5 + num) rest'+  | otherwise+  = Left (L (line, col), (x, anns)) : parseLines mname (i + 5 + num) rest'+    where line  = (read l) :: Int+          col   = (read c) :: Int+          num   = (read n) :: Int+          anns  = intercalate "\n" $ take num rest+          rest' = drop num rest++parseLines _ i _+  = panic Nothing $ "Error Parsing Annot Input on Line: " ++ show i++instance Show AnnMap where+  show (Ann ts es _ ) =  "\n\n" ++ (concatMap ppAnnotTyp $ M.toList ts)+                                ++ (concatMap ppAnnotErr [(x,y) | (x,y,_) <- es])++ppAnnotTyp (L (l, c), (x, s))     = printf "%s\n%d\n%d\n%d\n%s\n\n\n" x l c (length $ lines s) s+ppAnnotErr (L (l, c), L (l', c')) = printf " \n%d\n%d\n0\n%d\n%d\n\n\n\n" l c l' c'+++---------------------------------------------------------------------------------+---- Code for Dealing With LHS, stolen from Language.Haskell.HsColour.HsColour --+---------------------------------------------------------------------------------++-- | Separating literate files into code\/comment chunks.+data Lit = Code {unL :: String} | Lit {unL :: String} deriving (Show)++-- Re-implementation of 'lines', for better efficiency (but decreased laziness).+-- Also, importantly, accepts non-standard DOS and Mac line ending characters.+-- And retains the trailing '\n' character in each resultant string.+inlines :: String -> [String]+inlines s = lines' s id+  where+  lines' []             acc = [acc []]+  lines' ('\^M':'\n':s) acc = acc ['\n'] : lines' s id  -- DOS+  lines' ('\n':s)       acc = acc ['\n'] : lines' s id  -- Unix+  lines' (c:s)          acc = lines' s (acc . (c:))+++-- | The code for classify is largely stolen from Language.Preprocessor.Unlit.+classify ::  [String] -> [Lit]+classify []             = []+classify (x:xs) | "\\begin{code}"`isPrefixOf`x+                        = Lit x: allProg "code" xs+classify (x:xs) | "\\begin{spec}"`isPrefixOf`x+                        = Lit x: allProg "spec" xs+classify (('>':x):xs)   = Code ('>':x) : classify xs+classify (x:xs)         = Lit x: classify xs+++allProg name  = go+  where+    end       = "\\end{" ++ name ++ "}"+    go []     = []  -- Should give an error message,+                    -- but I have no good position information.+    go (x:xs) | end `isPrefixOf `x+              = Lit x: classify xs+    go (x:xs) = Code x: go xs+++-- | Join up chunks of code\/comment that are next to each other.+joinL :: [Lit] -> [Lit]+joinL []                  = []+joinL (Code c:Code c2:xs) = joinL (Code (c++c2):xs)+joinL (Lit c :Lit c2 :xs) = joinL (Lit  (c++c2):xs)+joinL (any:xs)            = any: joinL xs
+ src/Language/Haskell/Liquid/UX/Annotate.hs view
@@ -0,0 +1,451 @@+{-# LANGUAGE FlexibleContexts         #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE TypeSynonymInstances       #-}+{-# LANGUAGE FlexibleInstances          #-}++{- LIQUID "--diffcheck" @-}++---------------------------------------------------------------------------+-- | This module contains the code that uses the inferred types to generate+-- 1. HTMLized source with Inferred Types in mouseover annotations.+-- 2. Annotations files (e.g. for vim/emacs)+-- 3. JSON files for the web-demo etc.+---------------------------------------------------------------------------+++module Language.Haskell.Liquid.UX.Annotate (specAnchor, mkOutput, annotate) where++import           Prelude                  hiding (error)+import           GHC                      ( SrcSpan (..)+                                          , srcSpanStartCol+                                          , srcSpanEndCol+                                          , srcSpanStartLine+                                          , srcSpanEndLine)+import           Text.PrettyPrint.HughesPJ hiding (first)+import           GHC.Exts                 (groupWith, sortWith)++import           Data.Char                (isSpace)+import           Data.Function            (on)+import           Data.List                (sortBy)+import           Data.Maybe               (mapMaybe)++import           Data.Aeson+import           Control.Arrow            hiding ((<+>))+-- import           Control.Applicative      ((<$>))+import           Control.Monad            (when, forM_)++import           System.Exit                      (ExitCode (..))+import           System.FilePath          (takeFileName, dropFileName, (</>))+import           System.Directory         (findExecutable, copyFile)+import           Text.Printf              (printf)+import qualified Data.List              as L+import qualified Data.Vector            as V+import qualified Data.ByteString.Lazy   as B+import qualified Data.Text              as T+import qualified Data.HashMap.Strict    as M+import qualified Language.Haskell.Liquid.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           Language.Fixpoint.Types hiding (Error, Loc, Constant (..), Located (..))+import           Language.Haskell.Liquid.Misc+import           Language.Haskell.Liquid.Types.PrettyPrint+import           Language.Haskell.Liquid.Types.RefType++import           Language.Haskell.Liquid.UX.Errors ()+import           Language.Haskell.Liquid.UX.Tidy+import           Language.Haskell.Liquid.Types hiding (Located(..), Def(..))+import           Language.Haskell.Liquid.Types.Specifications++++-- | @output@ creates the pretty printed output+--------------------------------------------------------------------------------------------+mkOutput :: Config -> ErrorResult -> FixSolution -> AnnInfo (Annot SpecType) -> Output Doc+--------------------------------------------------------------------------------------------+mkOutput cfg res sol anna+  = O { o_vars   = Nothing+      , o_errors = []+      , o_types  = toDoc <$> annTy+      , o_templs = toDoc <$> annTmpl+      , o_bots   = mkBots    annTy+      , o_result = res+      }+  where+    annTmpl      = closeAnnots anna+    annTy        = tidySpecType Lossy <$> applySolution sol annTmpl+    toDoc        = rtypeDoc tidy+    tidy         = if shortNames cfg then Lossy else Full++-- | @annotate@ actually renders the output to files+-------------------------------------------------------------------+annotate :: Config -> FilePath -> Output Doc -> IO ()+-------------------------------------------------------------------+annotate cfg srcF out+  = do generateHtml srcF tpHtmlF tplAnnMap+       generateHtml srcF tyHtmlF typAnnMap+       writeFile         vimF  $ vimAnnot cfg annTyp+       B.writeFile       jsonF $ encode typAnnMap+       when showWarns $ forM_ bots (printf "WARNING: Found false in %s\n" . showPpr)+    where+       tplAnnMap  = mkAnnMap cfg res annTpl+       typAnnMap  = mkAnnMap cfg res annTyp+       annTpl     = o_templs out+       annTyp     = o_types  out+       res        = o_result out+       bots       = o_bots   out+       tyHtmlF    = extFileName Html                   srcF+       tpHtmlF    = extFileName Html $ extFileName Cst srcF+       _annF      = extFileName Annot srcF+       jsonF      = extFileName Json  srcF+       vimF       = extFileName Vim   srcF+       showWarns  = not $ nowarnings cfg++mkBots (AI m) = [ src | (src, (Just _, t) : _) <- sortBy (compare `on` fst) $ M.toList m+                      , isFalse (rTypeReft t) ]++writeFilesOrStrings :: FilePath -> [Either FilePath String] -> IO ()+writeFilesOrStrings tgtFile = mapM_ $ either (`copyFile` tgtFile) (tgtFile `appendFile`)++generateHtml srcF htmlF annm+  = do src     <- readFile srcF+       let lhs  = isExtFile LHs srcF+       let body = {-# SCC "hsannot" #-} ACSS.hsannot False (Just tokAnnot) lhs (src, annm)+       cssFile <- getCssPath+       copyFile cssFile (dropFileName htmlF </> takeFileName cssFile)+       renderHtml lhs htmlF srcF (takeFileName cssFile) body++renderHtml True  = renderPandoc+renderHtml False = renderDirect++-------------------------------------------------------------------------+-- | Pandoc HTML Rendering (for lhs + markdown source) ------------------+-------------------------------------------------------------------------++renderPandoc htmlFile srcFile css body+  = do renderFn <- maybe renderDirect renderPandoc' <$> findExecutable "pandoc"+       renderFn htmlFile srcFile css body++renderPandoc' pandocPath htmlFile srcFile css body+  = do _  <- writeFile mdFile $ pandocPreProc body+       ec <- executeShellCommand "pandoc" cmd+       writeFilesOrStrings htmlFile [Right (cssHTML css)]+       checkExitCode cmd ec+    where mdFile = extFileName Mkdn srcFile+          cmd    = pandocCmd pandocPath mdFile htmlFile++checkExitCode _   (ExitSuccess)   = return ()+checkExitCode cmd (ExitFailure n) = panic Nothing $ "cmd: " ++ cmd ++ " failure code " ++ show n++pandocCmd pandocPath mdFile htmlFile+  = printf "%s -f markdown -t html %s > %s" pandocPath mdFile htmlFile++pandocPreProc  = T.unpack+               . strip beg code+               . strip end code+               . strip beg spec+               . strip end spec+               . T.pack+  where+    beg, end, code, spec :: String+    beg        = "begin"+    end        = "end"+    code       = "code"+    spec       = "spec"+    strip x y  = T.replace (T.pack $ printf "\\%s{%s}" x y) T.empty+    -- stripBcode = T.replace (T.pack "\\begin{code}") T.empty+    -- stripEcode = T.replace (T.pack "\\end{code}")   T.empty+    -- stripBspec = T.replace (T.pack "\\begin{code}") T.empty+    -- stripEspec = T.replace (T.pack "\\end{code}")   T.empty+++++-------------------------------------------------------------------------+-- | Direct HTML Rendering (for non-lhs/markdown source) ----------------+-------------------------------------------------------------------------++-- More or less taken from hscolour++renderDirect htmlFile srcFile css body+  = writeFile htmlFile $! (top'n'tail full srcFile css $! body)+    where full = True -- False  -- TODO: command-line-option++-- | @top'n'tail True@ is used for standalone HTML,+--   @top'n'tail False@ for embedded HTML++top'n'tail True  title css = (htmlHeader title css ++) . (++ htmlClose)+top'n'tail False _    _    = id++-- Use this for standalone HTML++htmlHeader title css = unlines+  [ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">"+  , "<html>"+  , "<head>"+  , "<title>" ++ title ++ "</title>"+  , "</head>"+  , cssHTML css+  , "<body>"+  , "<hr>"+  , "Put mouse over identifiers to see inferred types"+  ]++htmlClose  = "\n</body>\n</html>"++cssHTML css = unlines+  [ "<head>"+  , "<link type='text/css' rel='stylesheet' href='"++ css ++ "' />"+  , "</head>"+  ]++------------------------------------------------------------------------------+-- | Building Annotation Maps ------------------------------------------------+------------------------------------------------------------------------------++-- | This function converts our annotation information into that which+--   is required by `Language.Haskell.Liquid.ACSS` to generate mouseover+--   annotations.++mkAnnMap :: Config -> ErrorResult -> AnnInfo Doc -> ACSS.AnnMap+mkAnnMap cfg res ann     = ACSS.Ann (mkAnnMapTyp cfg ann) (mkAnnMapErr res) (mkStatus res)++mkStatus (Safe)          = ACSS.Safe+mkStatus (Unsafe _)      = ACSS.Unsafe+mkStatus (Crash _ _)     = ACSS.Error++++mkAnnMapErr (Unsafe ls)  = mapMaybe cinfoErr ls+mkAnnMapErr (Crash ls _) = mapMaybe cinfoErr ls+mkAnnMapErr _            = []++cinfoErr e = case pos e of+               RealSrcSpan l -> Just (srcSpanStartLoc l, srcSpanEndLoc l, showpp e)+               _             -> Nothing+++-- mkAnnMapTyp :: (RefTypable a c tv r, RefTypable a c tv (), PPrint tv, PPrint a) =>Config-> AnnInfo (RType a c tv r) -> M.HashMap Loc (String, String)+mkAnnMapTyp cfg z = M.fromList $ map (first srcSpanStartLoc) $ mkAnnMapBinders cfg z++mkAnnMapBinders cfg (AI m)+  = map (second bindStr . head . sortWith (srcSpanEndCol . fst))+  $ groupWith (lineCol . fst) locBinds+  where+    locBinds       = [ (l, x) | (RealSrcSpan l, x:_) <- M.toList m, oneLine l]+    bindStr (x, v) = (maybe "_" (symbolString . shorten . symbol) x, render v)+    shorten        = if shortNames cfg then dropModuleNames else id++closeAnnots :: AnnInfo (Annot SpecType) -> AnnInfo SpecType+closeAnnots = closeA . filterA . collapseA++closeA a@(AI m)   = cf <$> a+  where+    cf (AnnLoc l)  = case m `mlookup` l of+                      [(_, AnnUse t)] -> t+                      [(_, AnnDef t)] -> t+                      [(_, AnnRDf t)] -> t+                      _               -> panic Nothing $ "malformed AnnInfo: " ++ showPpr l+    cf (AnnUse t) = t+    cf (AnnDef t) = t+    cf (AnnRDf t) = t++filterA (AI m) = AI (M.filter ff m)+  where+    ff [(_, AnnLoc l)] = l `M.member` m+    ff _               = True++collapseA (AI m) = AI (fmap pickOneA m)++pickOneA xas = case (rs, ds, ls, us) of+                 (x:_, _, _, _) -> [x]+                 (_, x:_, _, _) -> [x]+                 (_, _, x:_, _) -> [x]+                 (_, _, _, x:_) -> [x]+                 (_, _, _, _  ) -> [ ]+  where+    rs = [x | x@(_, AnnRDf _) <- xas]+    ds = [x | x@(_, AnnDef _) <- xas]+    ls = [x | x@(_, AnnLoc _) <- xas]+    us = [x | x@(_, AnnUse _) <- xas]++------------------------------------------------------------------------------+-- | Tokenizing Refinement Type Annotations in @-blocks ----------------------+------------------------------------------------------------------------------++-- | The token used for refinement symbols inside the highlighted types in @-blocks.+refToken = Keyword++-- | The top-level function for tokenizing @-block annotations. Used to+-- tokenize comments by ACSS.+tokAnnot s+  = case trimLiquidAnnot s of+      Just (l, body, r) -> [(refToken, l)] ++ tokBody body ++ [(refToken, r)]+      Nothing           -> [(Comment, s)]++trimLiquidAnnot ('{':'-':'@':ss)+  | drop (length ss - 3) ss == "@-}"+  = Just (liquidBegin, take (length ss - 3) ss, liquidEnd)+trimLiquidAnnot _+  = Nothing++tokBody s+  | isData s  = tokenise s+  | isType s  = tokenise s+  | isIncl s  = tokenise s+  | isMeas s  = tokenise s+  | otherwise = tokeniseSpec s++isMeas = spacePrefix "measure"+isData = spacePrefix "data"+isType = spacePrefix "type"+isIncl = spacePrefix "include"++{-@ spacePrefix :: String -> s:String -> Bool / [len s] @-}+spacePrefix :: String -> String -> Bool+spacePrefix str s@(c:cs)+  | isSpace c   = spacePrefix str cs+  | otherwise   = take (length str) s == str+spacePrefix _ _ = False+++tokeniseSpec       ::  String -> [(TokenType, String)]+tokeniseSpec str   = {- traceShow ("tokeniseSpec: " ++ str) $ -} tokeniseSpec' str++tokeniseSpec'      = tokAlt . chopAltDBG -- [('{', ':'), ('|', '}')]+  where+    tokAlt (s:ss)  = tokenise s ++ tokAlt' ss+    tokAlt _       = []+    tokAlt' (s:ss) = (refToken, s) : tokAlt ss+    tokAlt' _      = []++chopAltDBG y = {- traceShow ("chopAlts: " ++ y) $ -}+  filter (/= "") $ concatMap (chopAlts [("{", ":"), ("|", "}")])+  $ chopAlts [("<{", "}>"), ("{", "}")] y+++++------------------------------------------------------------------------+-- | JSON: Annotation Data Types ---------------------------------------+------------------------------------------------------------------------++data Assoc k a = Asc (M.HashMap k a)+type AnnTypes  = Assoc Int (Assoc Int Annot1)+type AnnErrors = [(Loc, Loc, String)]+data Annot1    = A1  { ident :: String+                     , ann   :: String+                     , row   :: Int+                     , col   :: Int+                     }++------------------------------------------------------------------------+-- | Creating Vim Annotations ------------------------------------------+------------------------------------------------------------------------++vimAnnot     :: Config -> AnnInfo Doc -> String+vimAnnot cfg = L.intercalate "\n" . map vimBind . mkAnnMapBinders cfg++vimBind (sp, (v, ann)) = printf "%d:%d-%d:%d::%s" l1 c1 l2 c2 (v ++ " :: " ++ show ann)+  where+    l1  = srcSpanStartLine sp+    c1  = srcSpanStartCol  sp+    l2  = srcSpanEndLine   sp+    c2  = srcSpanEndCol    sp++------------------------------------------------------------------------+-- | JSON Instances ----------------------------------------------------+------------------------------------------------------------------------++instance ToJSON ACSS.Status where+  toJSON ACSS.Safe   = "safe"+  toJSON ACSS.Unsafe = "unsafe"+  toJSON ACSS.Error  = "error"+  toJSON ACSS.Crash  = "crash"++instance ToJSON Annot1 where+  toJSON (A1 i a r c) = object [ "ident" .= i+                               , "ann"   .= a+                               , "row"   .= r+                               , "col"   .= c+                               ]++instance ToJSON Loc where+  toJSON (L (l, c)) = object [ "line"     .= toJSON l+                             , "column"   .= toJSON c ]++instance ToJSON AnnErrors where+  toJSON errs      = Array $ V.fromList $ fmap toJ errs+    where+      toJ (l,l',s) = object [ "start"   .= toJSON l+                            , "stop"    .= toJSON l'+                            , "message" .= toJSON s  ]++instance (Show k, ToJSON a) => ToJSON (Assoc k a) where+  toJSON (Asc kas) = object [ tshow k .= toJSON a | (k, a) <- M.toList kas ]+    where+      tshow        = T.pack . show++instance ToJSON ACSS.AnnMap where+  toJSON a = object [ "types"  .= toJSON (annTypes    a)+                    , "errors" .= toJSON (ACSS.errors a)+                    , "status" .= toJSON (ACSS.status a)+                    ]++annTypes         :: ACSS.AnnMap -> AnnTypes+annTypes a       = grp [(l, c, ann1 l c x s) | (l, c, x, s) <- binders]+  where+    ann1 l c x s = A1 x s l c+    grp          = L.foldl' (\m (r,c,x) -> ins r c x m) (Asc M.empty)+    binders      = [(l, c, x, s) | (L (l, c), (x, s)) <- M.toList $ ACSS.types a]++ins r c x (Asc m)  = Asc (M.insert r (Asc (M.insert c x rm)) m)+  where+    Asc rm         = M.lookupDefault (Asc M.empty) r m++--------------------------------------------------------------------------------+-- | LH Related Stuff ----------------------------------------------------------+--------------------------------------------------------------------------------++{-@ LIQUID "--diffcheck" @-}++{-@ type ListNE a    = {v:[a] | 0 < len v}  @-}+{-@ type ListN  a N  = {v:[a] | len v == N} @-}+{-@ type ListXs a Xs = ListN a {len Xs}     @-}++{-@ assume GHC.Exts.sortWith :: Ord b => (a -> b) -> xs:[a] -> ListXs a xs @-}+{-@ assume GHC.Exts.groupWith :: Ord b => (a -> b) -> [a] -> [ListNE a] @-}++{- junkProp :: ListNE Int @-}+-- junkProp :: [Int]+-- junkProp = [ 8 ]++--------------------------------------------------------------------------------+-- | A Little Unit Test --------------------------------------------------------+--------------------------------------------------------------------------------++_anns :: AnnTypes+_anns = i [(5,   i [( 14, A1 { ident = "foo"+                            , ann   = "int -> int"+                            , row   = 5+                            , col   = 14+                            })+                  ]+          )+         ,(9,   i [( 22, A1 { ident = "map"+                            , ann   = "(a -> b) -> [a] -> [b]"+                            , row   = 9+                            , col   = 22+                            })+                  ,( 28, A1 { ident = "xs"+                            , ann   = "[b]"+                            , row   = 9+                            , col   = 28+                            })+                  ])+         ]++i = Asc . M.fromList
+ src/Language/Haskell/Liquid/UX/CTags.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE TupleSections #-}+-- | This module contains the code for generating "tags" for constraints+-- based on their source, i.e. the top-level binders under which the+-- constraint was generated. These tags are used by fixpoint to+-- prioritize constraints by the "source-level" function.++module Language.Haskell.Liquid.UX.CTags (+    -- * Type for constraint tags+    TagKey, TagEnv++    -- * Default tag value+  , defaultTag++    -- * Constructing @TagEnv@+  , makeTagEnv++    -- * Accessing @TagEnv@+  , getTag, memTagEnv++) where++import Var+import CoreSyn+import Prelude hiding (error)++import qualified Data.HashSet           as S+import qualified Data.HashMap.Strict    as M+import qualified Data.Graph             as G++import Language.Fixpoint.Types          (Tag)+import Language.Haskell.Liquid.Types.Visitors (freeVars)+import Language.Haskell.Liquid.Misc     (mapSnd)++-- | The @TagKey@ is the top-level binder, and @Tag@ is a singleton Int list++type TagKey = Var+type TagEnv = M.HashMap TagKey Tag++-- TODO: use the "callgraph" SCC to do this numbering.++defaultTag :: Tag+defaultTag = [0]++memTagEnv :: TagKey -> TagEnv -> Bool+memTagEnv = M.member++makeTagEnv :: [CoreBind] -> TagEnv+makeTagEnv = M.map (:[]) . callGraphRanks . makeCallGraph++-- makeTagEnv = M.fromList . (`zip` (map (:[]) [1..])). L.sort . map fst . concatMap bindEqns++getTag :: TagKey -> TagEnv -> Tag+getTag = M.lookupDefault defaultTag++------------------------------------------------------------------------------------------------------++type CallGraph = [(Var, [Var])] -- caller-callee pairs++callGraphRanks :: CallGraph -> M.HashMap Var Int+-- callGraphRanks cg = traceShow ("CallGraph Ranks: " ++ show cg) $ callGraphRanks' cg++callGraphRanks  = M.fromList . concat . index . mkScc+  where mkScc cg = G.stronglyConnComp [(u, u, vs) | (u, vs) <- cg]+        index    = zipWith (\i -> map (, i) . G.flattenSCC) [1..]++makeCallGraph :: [CoreBind] -> CallGraph+makeCallGraph cbs = mapSnd calls `fmap` xes+  where xes       = concatMap bindEqns cbs+        xs        = S.fromList $ map fst xes+        calls     = filter (`S.member` xs) . freeVars S.empty++bindEqns (NonRec x e) = [(x, e)]+bindEqns (Rec xes)    = xes
+ src/Language/Haskell/Liquid/UX/CmdLine.hs view
@@ -0,0 +1,433 @@+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TupleSections             #-}+{-# LANGUAGE TypeSynonymInstances      #-}+{-# OPTIONS_GHC -fno-cse #-}++{-@ LIQUID "--diff"     @-}++-- | This module contains all the code needed to output the result which+--   is either: `SAFE` or `WARNING` with some reasonable error message when+--   something goes wrong. All forms of errors/exceptions should go through+--   here. The idea should be to report the error, the source position that+--   causes it, generate a suitable .json file and then exit.++module Language.Haskell.Liquid.UX.CmdLine (+   -- * Get Command Line Configuration+     getOpts, mkOpts, defConfig++   -- * Update Configuration With Pragma+   , withPragmas++   -- * Exit Function+   , exitWithResult++   -- * Diff check mode+   , diffcheck++) where++import Prelude hiding (error)++import Control.Monad+import Data.Maybe++import System.Directory+import System.Exit+import System.Environment++import System.Console.CmdArgs.Explicit+import System.Console.CmdArgs.Implicit     hiding (Loud)+import System.Console.CmdArgs.Text++import Data.List                           (nub)+++import System.FilePath                     (dropFileName, isAbsolute,+                                            takeDirectory, (</>))++import Language.Fixpoint.Types.Config      hiding (Config, linear, elimStats,+                                              getOpts, cores, minPartSize,+                                              maxPartSize, newcheck, eliminate)+import Language.Fixpoint.Utils.Files+import Language.Fixpoint.Misc+import Language.Fixpoint.Types.Names+import Language.Fixpoint.Types             hiding (Error, Result, saveQuery)+import Language.Haskell.Liquid.UX.Annotate+import Language.Haskell.Liquid.GHC.Misc+import Language.Haskell.Liquid.Misc+import Language.Haskell.Liquid.Types.PrettyPrint+import Language.Haskell.Liquid.Types       hiding (config, name, typ)++++import Text.Parsec.Pos                     (newPos)+import Text.PrettyPrint.HughesPJ           hiding (Mode)++++---------------------------------------------------------------------------------+-- Config Magic Numbers----------------------------------------------------------+---------------------------------------------------------------------------------++defaultMaxParams :: Int+defaultMaxParams = 2++---------------------------------------------------------------------------------+-- Parsing Command Line----------------------------------------------------------+---------------------------------------------------------------------------------+config :: Mode (CmdArgs Config)+config = cmdArgsMode $ Config {+   files+    = def &= typ "TARGET"+          &= args+          &= typFile++ , idirs+    = def &= typDir+          &= help "Paths to Spec Include Directory "++ , fullcheck+     = def+           &= help "Full Checking: check all binders (DEFAULT)"++ , diffcheck+    = def+          &= help "Incremental Checking: only check changed binders"++ , higherorder+    = def+          &= help "Allow higher order binders into the logic"++ , linear+    = def+          &= help "Use uninterpreted integer multiplication and division"++ , saveQuery+    = def &= help "Save fixpoint query to file (slow)"++ , binders+    = def &= help "Check a specific set of binders"++ , noPrune+    = def &= help "Disable prunning unsorted Predicates"+          &= name "no-prune-unsorted"++ , notermination+    = def &= help "Disable Termination Check"+          &= name "no-termination-check"++ , autoproofs+    = def &= help "Automatically construct proofs from axioms"+          &= name "auto-proofs"++ , nowarnings+    = def &= help "Don't display warnings, only show errors"+          &= name "no-warnings"++ , trustinternals+    = def &= help "Trust all ghc auto generated code"+          &= name "trust-internals"++ , nocaseexpand+    = def &= help "Don't expand the default case in a case-expression"+          &= name "no-case-expand"+ , strata+    = def &= help "Enable Strata Analysis"++ , notruetypes+    = def &= help "Disable Trueing Top Level Types"+          &= name "no-true-types"++ , totality+    = def &= help "Check totality"++ , cores+    = def &= help "Use m cores to solve logical constraints"++ , minPartSize+    = defaultMinPartSize &= help "If solving on multiple cores, ensure that partitions are of at least m size"++ , maxPartSize+    = defaultMaxPartSize &= help ("If solving on multiple cores, once there are as many partitions " +++                                  "as there are cores, don't merge partitions if they will exceed this " +++                                  "size. Overrides the minpartsize option.")++ , smtsolver+    = def &= help "Name of SMT-Solver"++ , newcheck+    = True &= help "New fixpoint check"++ , noCheckUnknown+    = def &= explicit+          &= name "no-check-unknown"+          &= help "Don't complain about specifications for unexported and unused values "++ , maxParams+    = defaultMaxParams &= help "Restrict qualifier mining to those taking at most `m' parameters (2 by default)"++ , shortNames+    = def &= name "short-names"+          &= help "Print shortened names, i.e. drop all module qualifiers."++ , shortErrors+    = def &= name "short-errors"+          &= help "Don't show long error messages, just line numbers."++ , cabalDir+    = def &= name "cabal-dir"+          &= help "Find and use .cabal to add paths to sources for imported files"++ , ghcOptions+    = def &= name "ghc-option"+          &= typ "OPTION"+          &= help "Pass this option to GHC"++ , cFiles+    = def &= name "c-files"+          &= typ "OPTION"+          &= help "Tell GHC to compile and link against these files"++ , eliminate+    = def &= name "eliminate"+          &= help "Use experimental 'eliminate' feature"++ , port+     = defaultPort+          &= name "port"+          &= help "Port at which lhi should listen"++ , exactDC+    = def &= help "Exact Type for Data Constructors"+          &= name "exact-data-cons"++ , scrapeImports+    = False &= help "Scrape qualifiers from imported specifications"+            &= name "scrape-imports"+            &= explicit++ , scrapeUsedImports+    = False &= help "Scrape qualifiers from used, imported specifications"+            &= name "scrape-used-imports"+            &= explicit++ , elimStats+    = False &= name "elimStats"+            &= help "Print eliminate stats"++ } &= verbosity+   &= program "liquid"+   &= help    "Refinement Types for Haskell"+   &= summary copyright+   &= details [ "LiquidHaskell is a Refinement Type based verifier for Haskell"+              , ""+              , "To check a Haskell file foo.hs, type:"+              , "  liquid foo.hs "+              ]++defaultPort :: Int+defaultPort = 3000++getOpts :: [String] -> IO Config+getOpts as = do+  cfg0   <- envCfg+  cfg1   <- mkOpts =<< cmdArgsRun'+                         config { modeValue = (modeValue config) { cmdArgsValue = cfg0 } }+                         as+  cfg    <- fixConfig cfg1+  whenNormal $ putStrLn copyright+  withSmtSolver cfg+++cmdArgsRun' :: Mode (CmdArgs a) -> [String] -> IO a+cmdArgsRun' md as+  = case parseResult of+      Left e  -> putStrLn (helpMsg e) >> exitFailure+      Right a -> cmdArgsApply a+    where+      helpMsg e = showText defaultWrap $ helpText [e] HelpFormatDefault md+      parseResult = process md as -- <$> getArgs++--------------------------------------------------------------------------------+withSmtSolver :: Config -> IO Config+--------------------------------------------------------------------------------+withSmtSolver cfg =+  case smtsolver cfg of+    Just _  -> return cfg+    Nothing -> do smts <- mapM findSmtSolver [Z3, Cvc4, Mathsat]+                  case catMaybes smts of+                    (s:_) -> return (cfg {smtsolver = Just s})+                    _     -> panic Nothing noSmtError+  where+    noSmtError = "LiquidHaskell requires an SMT Solver, i.e. z3, cvc4, or mathsat to be installed."++findSmtSolver :: SMTSolver -> IO (Maybe SMTSolver)+findSmtSolver smt = maybe Nothing (const $ Just smt) <$> findExecutable (show smt)++fixConfig :: Config -> IO Config+fixConfig cfg = do+  pwd <- getCurrentDirectory+  cfg <- canonicalizePaths pwd cfg+  return $ fixDiffCheck cfg++-- | Attempt to canonicalize all `FilePath's in the `Config' so we don't have+--   to worry about relative paths.+canonicalizePaths :: FilePath -> Config -> IO Config+canonicalizePaths pwd cfg = do+  tgt   <- canonicalizePath pwd+  isdir <- doesDirectoryExist tgt+  is    <- mapM (canonicalize tgt isdir) $ idirs cfg+  cs    <- mapM (canonicalize tgt isdir) $ cFiles cfg+  return $ cfg { idirs = is, cFiles = cs }++canonicalize :: FilePath -> Bool -> FilePath -> IO FilePath+canonicalize tgt isdir f+  | isAbsolute f = return f+  | isdir        = canonicalizePath (tgt </> f)+  | otherwise    = canonicalizePath (takeDirectory tgt </> f)++fixDiffCheck :: Config -> Config+fixDiffCheck cfg = cfg { diffcheck = diffcheck cfg && not (fullcheck cfg) }++envCfg = do so <- lookupEnv "LIQUIDHASKELL_OPTS"+            case so of+              Nothing -> return defConfig+              Just s  -> parsePragma $ envLoc s+         where+            envLoc  = Loc l l+            l       = newPos "ENVIRONMENT" 0 0++copyright = "LiquidHaskell Copyright 2009-15 Regents of the University of California. All Rights Reserved.\n"++mkOpts :: Config -> IO Config+mkOpts cfg+  = do let files' = sortNub $ files cfg+       id0 <- getIncludeDir+       return  $ cfg { files = files' }+                     { idirs = -- NOTE: not convinced we should add the file's directory+                               -- to the search path+                               (dropFileName <$> files') +++                               [id0 </> gHC_VERSION, id0] ++ idirs cfg }+                              -- tests fail if you flip order of idirs'++---------------------------------------------------------------------------------------+-- | Updating options+---------------------------------------------------------------------------------------++---------------------------------------------------------------------------------------+withPragmas :: Config -> FilePath -> [Located String] -> IO Config+---------------------------------------------------------------------------------------+withPragmas cfg fp ps = foldM withPragma cfg ps >>= canonicalizePaths fp++withPragma :: Config -> Located String -> IO Config+withPragma c s = withArgs [val s] $ cmdArgsRun+          config { modeValue = (modeValue config) { cmdArgsValue = c } }+   --(c `mappend`) <$> parsePragma s++parsePragma   :: Located String -> IO Config+parsePragma = withPragma defConfig+   --withArgs [val s] $ cmdArgsRun config++defConfig :: Config+defConfig = Config { files          = def+                   , idirs          = def+                   , newcheck       = True+                   , fullcheck      = def+                   , linear         = def+                   , higherorder    = def+                   , diffcheck      = def+                   , saveQuery      = def+                   , binders        = def+                   , noCheckUnknown = def+                   , notermination  = def+                   , autoproofs     = def+                   , nowarnings     = def+                   , trustinternals = def+                   , nocaseexpand   = def+                   , strata         = def+                   , notruetypes    = def+                   , totality       = def+                   , noPrune        = def+                   , exactDC        = def+                   , cores          = def+                   , minPartSize    = defaultMinPartSize+                   , maxPartSize    = defaultMaxPartSize+                   , maxParams      = defaultMaxParams+                   , smtsolver      = def+                   , shortNames     = def+                   , shortErrors    = def+                   , cabalDir       = def+                   , ghcOptions     = def+                   , cFiles         = def+                   , eliminate      = def+                   , port           = defaultPort+                   , scrapeImports  = False+                   , scrapeUsedImports  = False+                   , elimStats      = False+                   }+++------------------------------------------------------------------------+-- | Exit Function -----------------------------------------------------+------------------------------------------------------------------------++------------------------------------------------------------------------+exitWithResult :: Config -> FilePath -> Output Doc -> IO (Output Doc)+------------------------------------------------------------------------+exitWithResult cfg target out+  = do {-# SCC "annotate" #-} annotate cfg target out+       donePhase Loud "annotate"+       writeCheckVars $ o_vars  out+       cr <- resultWithContext r+       writeResult cfg (colorResult r) cr+       writeFile   (extFileName Result target) (showFix cr)+       return $ out { o_result = r }+    where+       r         = o_result out `addErrors` o_errors out+++resultWithContext :: ErrorResult -> IO (FixResult CError)+resultWithContext = mapM errorWithContext+++writeCheckVars Nothing     = return ()+writeCheckVars (Just [])   = colorPhaseLn Loud "Checked Binders: None" ""+writeCheckVars (Just ns)   = colorPhaseLn Loud "Checked Binders:" "" >> forM_ ns (putStrLn . symbolString . dropModuleNames . symbol)++type CError = CtxError Doc -- SpecType++writeResult :: Config -> Moods -> FixResult CError -> IO ()+writeResult cfg c          = mapM_ (writeDoc c) . zip [0..] . resDocs tidy+  where+    tidy                   = if shortErrors cfg then Lossy else Full+    writeDoc c (i, d)      = writeBlock c i $ lines $ render d+    writeBlock _ _ []      = return ()+    writeBlock c 0 ss      = forM_ ss (colorPhaseLn c "")+    writeBlock _  _ ss     = forM_ ("\n" : ss) putStrLn+++resDocs :: Tidy -> FixResult CError -> [Doc]+resDocs _ Safe             = [text "RESULT: SAFE"]+resDocs k (Crash xs s)     = text "RESULT: ERROR"  : text s : pprManyOrdered k "" (errToFCrash <$> xs)+resDocs k (Unsafe xs)      = text "RESULT: UNSAFE" : pprManyOrdered k "" (nub xs)++errToFCrash :: CtxError a -> CtxError a+errToFCrash ce = ce { ctErr    = tx $ ctErr ce}+  where+    tx (ErrSubType l m g t t') = ErrFCrash l m g t t'+    tx e                       = e++{-+   TODO: Never used, do I need to exist?+reportUrl = text "Please submit a bug report at: https://github.com/ucsd-progsys/liquidhaskell" -}+++addErrors r []             = r+addErrors Safe errs        = Unsafe errs+addErrors (Unsafe xs) errs = Unsafe (xs ++ errs)+addErrors r  _             = r++instance Fixpoint (FixResult CError) where+  toFix = vcat . resDocs Full
+ src/Language/Haskell/Liquid/UX/Config.hs view
@@ -0,0 +1,75 @@+-----------------------------------------------------------------------------+-- | Command Line Config Options --------------------------------------------+-----------------------------------------------------------------------------+++{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveGeneric #-}++module Language.Haskell.Liquid.UX.Config (++   -- * Configuration Options+     Config (..)+   , HasConfig (..)+   , hasOpt+   ) where++import Prelude hiding (error)++import Data.Serialize ( Serialize )+import Language.Fixpoint.Types.Config hiding (Config)+import Data.Typeable  (Typeable)+import Data.Generics  (Data)+import GHC.Generics++-- NOTE: adding strictness annotations breaks the help message+data Config = Config {+    files          :: [FilePath] -- ^ source files to check+  , idirs          :: [FilePath] -- ^ path to directory for including specs+  , newcheck       :: Bool       -- ^ new liquid-fixpoint sort check+  , diffcheck      :: Bool       -- ^ check subset of binders modified (+ dependencies) since last check+  , linear         :: Bool       -- ^ uninterpreted integer multiplication and division+  , higherorder    :: Bool       -- ^ allow higher order binders into the logic+  , fullcheck      :: Bool       -- ^ check all binders (overrides diffcheck)+  , saveQuery      :: Bool       -- ^ save fixpoint query+  , binders        :: [String]   -- ^ set of binders to check+  , noCheckUnknown :: Bool       -- ^ whether to complain about specifications for unexported and unused values+  , notermination  :: Bool       -- ^ disable termination check+  , autoproofs     :: Bool       -- ^ automatically construct proofs from axioms+  , nowarnings     :: Bool       -- ^ disable warnings output (only show errors)+  , trustinternals :: Bool       -- ^ type all internal variables with true+  , nocaseexpand   :: Bool       -- ^ disable case expand+  , strata         :: Bool       -- ^ enable strata analysis+  , notruetypes    :: Bool       -- ^ disable truing top level types+  , totality       :: Bool       -- ^ check totality in definitions+  , noPrune        :: Bool       -- ^ disable prunning unsorted Refinements+  , cores          :: Maybe Int  -- ^ number of cores used to solve constraints+  , minPartSize    :: Int        -- ^ Minimum size of a partition+  , maxPartSize    :: Int        -- ^ Maximum size of a partition. Overrides minPartSize+  , maxParams      :: Int        -- ^ the maximum number of parameters to accept when mining qualifiers+  , smtsolver      :: Maybe SMTSolver  -- ^ name of smtsolver to use [default: try z3, cvc4, mathsat in order]+  , shortNames     :: Bool       -- ^ drop module qualifers from pretty-printed names.+  , shortErrors    :: Bool       -- ^ don't show subtyping errors and contexts.+  , cabalDir       :: Bool       -- ^ find and use .cabal file to include paths to sources for imported modules+  , ghcOptions     :: [String]   -- ^ command-line options to pass to GHC+  , cFiles         :: [String]   -- ^ .c files to compile and link against (for GHC)+  , eliminate      :: Bool+  , port           :: Int        -- ^ port at which lhi should listen+  , exactDC        :: Bool       -- ^ Automatically generate singleton types for data constructors+  , scrapeImports  :: Bool       -- ^ scrape qualifiers from imported specifications+  , scrapeUsedImports  :: Bool   -- ^ scrape qualifiers from used, imported specifications+  , elimStats      :: Bool       -- ^ print eliminate stats+  } deriving (Generic, Data, Typeable, Show, Eq)++instance Serialize SMTSolver+instance Serialize Config+++class HasConfig t where+  getConfig :: t -> Config++hasOpt :: HasConfig t => t -> (Config -> Bool) -> Bool+hasOpt t f = f (getConfig t)++instance HasConfig Config where+  getConfig = id
+ src/Language/Haskell/Liquid/UX/DiffCheck.hs view
@@ -0,0 +1,488 @@+-- | This module contains the code for Incremental checking, which finds the+--   part of a target file (the subset of the @[CoreBind]@ that have been+--   modified since it was last checked, as determined by a diff against+--   a saved version of the file.++{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}++module Language.Haskell.Liquid.UX.DiffCheck (++   -- * Changed binders + Unchanged Errors+     DiffCheck (..)++   -- * Use previously saved info to generate DiffCheck target+   , slice++   -- * Use target binders to generate DiffCheck target+   , thin++   -- * Save current information for next time+   , saveResult++   )+   where++import            Prelude                       hiding (error)++import            Data.Aeson+import qualified  Data.Text as T+import            Data.Algorithm.Diff++import            Data.Maybe                    (listToMaybe, mapMaybe, fromMaybe)+import            Data.Hashable+import qualified  Data.IntervalMap.FingerTree as IM+import            CoreSyn                       hiding (sourceName)+import            Name+import            SrcLoc hiding (Located)+import            Var+import qualified  Data.HashSet                  as S+import qualified  Data.HashMap.Strict           as M+import qualified  Data.List                     as L+import            System.Directory                (copyFile, doesFileExist)+import            Language.Fixpoint.Types         (FixResult (..), Located (..))+import            Language.Fixpoint.Utils.Files+import            Language.Haskell.Liquid.Types   (ErrorResult, SpecType, GhcSpec (..), AnnInfo (..), DataConP (..), Output (..))+import            Language.Haskell.Liquid.Misc    (mkGraph)+import            Language.Haskell.Liquid.GHC.Misc+import            Language.Haskell.Liquid.Types.Visitors+import            Language.Haskell.Liquid.UX.Errors   ()+import            Text.Parsec.Pos                  (sourceName, sourceLine, sourceColumn, SourcePos, newPos)+import            Text.PrettyPrint.HughesPJ        (text, render, Doc)+import            Language.Haskell.Liquid.Types.Errors++import qualified  Data.ByteString               as B+import qualified  Data.ByteString.Lazy          as LB+++-------------------------------------------------------------------------+-- Data Types -----------------------------------------------------------+-------------------------------------------------------------------------++-- | Main type of value returned for diff-check.+data DiffCheck = DC { newBinds  :: [CoreBind]+                    , oldOutput :: !(Output Doc)+                    , newSpec   :: !GhcSpec+                    }++-- | Variable definitions+data Def  = D { start  :: Int -- ^ line at which binder definition starts+              , end    :: Int -- ^ line at which binder definition ends+              , binder :: Var -- ^ name of binder+              }+            deriving (Eq, Ord)++-- | Variable dependencies "call-graph"+type Deps = M.HashMap Var (S.HashSet Var)++-- | Map from saved-line-num ---> current-line-num+type LMap   = IM.IntervalMap Int Int++-- | Intervals of line numbers that have been re-checked+type ChkItv = IM.IntervalMap Int ()++instance Show Def where+  show (D i j x) = showPpr x ++ " start: " ++ show i ++ " end: " ++ show j++++-------------------------------------------------------------------------+-- | `slice` returns a subset of the @[CoreBind]@ of the input `target`+--    file which correspond to top-level binders whose code has changed+--    and their transitive dependencies.+-------------------------------------------------------------------------+slice :: FilePath -> [CoreBind] -> GhcSpec -> IO (Maybe DiffCheck)+-------------------------------------------------------------------------+slice target cbs sp = ifM (doesFileExist savedFile)+                          doDiffCheck+                          (return Nothing)+  where+    savedFile       = extFileName Saved target+    doDiffCheck     = sliceSaved target savedFile cbs sp++sliceSaved :: FilePath -> FilePath -> [CoreBind] -> GhcSpec -> IO (Maybe DiffCheck)+sliceSaved target savedFile coreBinds spec+  = do (is, lm) <- lineDiff target savedFile+       result   <- loadResult target+       return    $ sliceSaved' is lm (DC coreBinds result spec)++sliceSaved' :: [Int] -> LMap -> DiffCheck -> Maybe DiffCheck+sliceSaved' is lm (DC coreBinds result spec)+  | globalDiff is spec = Nothing+  | otherwise          = Just $ DC cbs' res' sp'+  where+    cbs'             = thinWith sigs coreBinds $ diffVars is dfs+    sigs             = S.fromList $ M.keys sigm+    sigm             = sigVars is spec+    res'             = adjustOutput lm cm result+    cm               = checkedItv chDfs+    dfs              = coreDefs coreBinds ++ specDefs spec+    chDfs            = coreDefs cbs'+    sp'              = assumeSpec sigm spec++-- Add the specified signatures for vars-with-preserved-sigs,+-- whose bodies have been pruned from [CoreBind] into the "assumes"+assumeSpec :: M.HashMap Var (Located SpecType) -> GhcSpec -> GhcSpec+assumeSpec sigm sp = sp { asmSigs = M.toList $ M.union sigm assm }+  where+    assm           = M.fromList $ asmSigs sp+    -- sigm'       = trace ("INCCHECK: sigm = " ++ show zs) sigm+    -- zs          = M.keys sigm++diffVars :: [Int] -> [Def] -> [Var]+diffVars ls defs'    = -- tracePpr ("INCCHECK: diffVars lines = " ++ show ls ++ " defs= " ++ show defs) $+                       go (L.sort ls) defs+  where+    defs             = L.sort defs'+    go _      []     = []+    go []     _      = []+    go (i:is) (d:ds)+      | i < start d  = go is (d:ds)+      | i > end d    = go (i:is) ds+      | otherwise    = binder d : go (i:is) ds++sigVars :: [Int] -> GhcSpec -> M.HashMap Var (Located SpecType)+sigVars ls sp = M.fromList $ filter (ok . snd) $ specSigs sp+  where+    ok        = not . isDiff ls++globalDiff :: [Int] -> GhcSpec -> Bool+globalDiff lines spec = measDiff || invsDiff || dconsDiff+  where+    measDiff  = any (isDiff lines) (snd <$> meas spec)+    invsDiff  = any (isDiff lines) (invariants spec)+    dconsDiff = any (isDiff lines) (dloc . snd <$> dconsP spec)+    dloc dc   = Loc (dc_loc dc) (dc_locE dc) ()++isDiff :: [Int] -> Located a -> Bool+isDiff lines x = any hits lines+  where+    hits i = line x <= i && i <= lineE x++-------------------------------------------------------------------------+-- | @thin@ returns a subset of the @[CoreBind]@ given which correspond+--   to those binders that depend on any of the @Var@s provided.+-------------------------------------------------------------------------+thin :: [CoreBind] -> [Var] -> [CoreBind]+-------------------------------------------------------------------------+thin = thinWith S.empty++thinWith :: S.HashSet Var -> [CoreBind] -> [Var] -> [CoreBind]+thinWith sigs cbs xs = filterBinds cbs ys+  where+     ys       = calls `S.union` calledBy+     calls    = txClosure (coreDeps cbs) sigs (S.fromList xs)+     calledBy = dependsOn (coreDeps cbs) xs++coreDeps    :: [CoreBind] -> Deps+coreDeps bs = mkGraph $ calls ++ calls'+  where+    calls   = concatMap deps bs+    calls'  = [(y, x) | (x, y) <- calls]+    deps b  = [(x, y) | x <- bindersOf b+                      , y <- freeVars S.empty b]+-- Given a call graph, and a list of vars, this function checks all functions+-- to see if they call any of the functions in the vars list. If any do, then+-- they must also be rechecked.+dependsOn :: Deps -> [Var] -> S.HashSet Var+dependsOn cg vars = S.fromList results+   where+      preds = map S.member vars+      filteredMaps = M.filter <$> preds <*> pure cg+      results = map fst $ M.toList $ M.unions filteredMaps++txClosure :: Deps -> S.HashSet Var -> S.HashSet Var -> S.HashSet Var+txClosure d sigs xs = go S.empty xs+  where+    next           = S.unions . fmap deps . S.toList+    deps x         = M.lookupDefault S.empty x d+    go seen new+      | S.null new = seen+      | otherwise  = let seen' = S.union seen new+                         new'  = next new `S.difference` seen'+                         new'' = new'  `S.difference` sigs+                     in go seen' new''++++-------------------------------------------------------------------------+filterBinds        :: [CoreBind] -> S.HashSet Var -> [CoreBind]+-------------------------------------------------------------------------+filterBinds cbs ys = filter f cbs+  where+    f (NonRec x _) = x `S.member` ys+    f (Rec xes)    = any (`S.member` ys) $ fst <$> xes+++-------------------------------------------------------------------------+specDefs :: GhcSpec -> [Def]+-------------------------------------------------------------------------+specDefs       = map def . specSigs+  where+    def (x, t) = D (line t) (lineE t) x++specSigs :: GhcSpec -> [(Var, Located SpecType)]+specSigs sp = tySigs sp ++ asmSigs sp ++ ctors sp++-------------------------------------------------------------------------+coreDefs     :: [CoreBind] -> [Def]+-------------------------------------------------------------------------+coreDefs cbs = L.sort [D l l' x | b <- cbs+                                , x <- bindersOf b+                                , isGoodSrcSpan (getSrcSpan x)+                                , (l, l') <- coreDef b]+coreDef b    = meetSpans b eSp vSp+  where+    eSp      = lineSpan b $ catSpans b $ bindSpans b+    vSp      = lineSpan b $ catSpans b $ getSrcSpan <$> bindersOf b+++-------------------------------------------------------------------------+-- | `meetSpans` cuts off the start-line to be no less than the line at which+--   the binder is defined. Without this, i.e. if we ONLY use the ticks and+--   spans appearing inside the definition of the binder (i.e. just `eSp`)+--   then the generated span can be WAY before the actual definition binder,+--   possibly due to GHC INLINE pragmas or dictionaries OR ...+--   for an example: see the "INCCHECK: Def" generated by+--      liquid -d benchmarks/bytestring-0.9.2.1/Data/ByteString.hs+--   where `spanEnd` is a single line function around 1092 but where+--   the generated span starts mysteriously at 222 where Data.List is imported.++meetSpans _ Nothing       _+  = []+meetSpans _ (Just (l,l')) Nothing+  = [(l, l')]+meetSpans _ (Just (l,l')) (Just (m,_))+  = [(max l m, l')]++lineSpan _ (RealSrcSpan sp) = Just (srcSpanStartLine sp, srcSpanEndLine sp)+lineSpan _ _                = Nothing++catSpans b []               = panic Nothing $ "DIFFCHECK: catSpans: no spans found for " ++ showPpr b+catSpans b xs               = foldr combineSrcSpans noSrcSpan [x | x@(RealSrcSpan z) <- xs, bindFile b == srcSpanFile z]++bindFile (NonRec x _) = varFile x+bindFile (Rec xes)    = varFile $ fst $ head xes++varFile b = case getSrcSpan b of+              RealSrcSpan z -> srcSpanFile z+              _             -> panic Nothing $ "DIFFCHECK: getFile: no file found for: " ++ showPpr b+++bindSpans (NonRec x e)    = getSrcSpan x : exprSpans e+bindSpans (Rec    xes)    = map getSrcSpan xs ++ concatMap exprSpans es+  where+    (xs, es)              = unzip xes++exprSpans (Tick t e)+  | isJunkSpan sp         = exprSpans e+  | otherwise             = [sp]+  where+    sp                    = tickSrcSpan t++exprSpans (Var x)         = [getSrcSpan x]+exprSpans (Lam x e)       = getSrcSpan x : exprSpans e+exprSpans (App e a)       = exprSpans e ++ exprSpans a+exprSpans (Let b e)       = bindSpans b ++ exprSpans e+exprSpans (Cast e _)      = exprSpans e+exprSpans (Case e x _ cs) = getSrcSpan x : exprSpans e ++ concatMap altSpans cs+exprSpans _               = []++altSpans (_, xs, e)       = map getSrcSpan xs ++ exprSpans e++isJunkSpan (RealSrcSpan _) = False+isJunkSpan _               = True++-------------------------------------------------------------------------+-- | Diff Interface -----------------------------------------------------+-------------------------------------------------------------------------+++-- | `lineDiff new old` compares the contents of `src` with `dst`+--   and returns the lines of `src` that are different.+-------------------------------------------------------------------------+lineDiff :: FilePath -> FilePath -> IO ([Int], LMap)+-------------------------------------------------------------------------+lineDiff new old  = lineDiff' <$> getLines new <*> getLines old+  where+    getLines      = fmap lines . readFile++lineDiff' :: [String] -> [String] -> ([Int], LMap)+lineDiff' new old = (changedLines, lm)+  where+    changedLines  = diffLines 1 diffLineCount+    lm            = foldr setShift IM.empty $ diffShifts diffLineCount+    diffLineCount = fmap length <$> getGroupedDiff new old++-- | Identifies lines that have changed+diffLines :: Int -- ^ Starting line+             -> [Diff Int] -- ^ List of lengths of diffs+             -> [Int] -- ^ List of changed line numbers+diffLines _ []                        = []+diffLines curr (Both lnsUnchgd _ : d) = diffLines toSkip d+   where toSkip = curr + lnsUnchgd+diffLines curr (First lnsChgd : d)    = [curr..(toTake-1)] ++ diffLines toTake d+   where toTake = curr + lnsChgd+diffLines curr (_ : d)                = diffLines curr d++diffShifts :: [Diff Int] -> [(Int, Int, Int)]+diffShifts = go 1 1+  where+    go old new (Both n _ : d) = (old, old + n - 1, new - old) : go (old + n)+                                                                   (new + n)+                                                                   d+    go old new (Second n : d) = go (old + n) new d+    go old new (First n  : d) = go old (new + n) d+    go _   _   []             = []++instance Functor Diff where+  fmap f (First x)  = First (f x)+  fmap f (Second x) = Second (f x)+  fmap f (Both x y) = Both (f x) (f y)++-- | @save@ creates an .saved version of the @target@ file, which will be+--    used to find what has changed the /next time/ @target@ is checked.+-------------------------------------------------------------------------+saveResult :: FilePath -> Output Doc -> IO ()+-------------------------------------------------------------------------+saveResult target res+  = do copyFile target saveF+       B.writeFile errF $ LB.toStrict $ encode res+    where+       saveF = extFileName Saved  target+       errF  = extFileName Cache  target++-------------------------------------------------------------------------+loadResult   :: FilePath -> IO (Output Doc)+-------------------------------------------------------------------------+loadResult f = ifM (doesFileExist jsonF) out (return mempty)+  where+    jsonF    = extFileName Cache f+    out      = (fromMaybe mempty . decode . LB.fromStrict) <$> B.readFile jsonF++-------------------------------------------------------------------------+adjustOutput :: LMap -> ChkItv -> Output Doc -> Output Doc+-------------------------------------------------------------------------+adjustOutput lm cm o  = mempty { o_types  = adjustTypes  lm cm (o_types  o) }+                               { o_result = adjustResult lm cm (o_result o) }++adjustTypes :: LMap -> ChkItv -> AnnInfo a -> AnnInfo a+adjustTypes lm cm (AI m)          = AI $ M.fromList+                                    [(sp', v) | (sp, v)  <- M.toList m+                                              , Just sp' <- [adjustSrcSpan lm cm sp]]++adjustResult :: LMap -> ChkItv -> ErrorResult -> ErrorResult+adjustResult lm cm (Unsafe es)    = errorsResult Unsafe      $ adjustErrors lm cm es+adjustResult lm cm (Crash es z)   = errorsResult (`Crash` z) $ adjustErrors lm cm es+adjustResult _  _  r              = r++errorsResult :: ([a] -> FixResult b) -> [a] -> FixResult b+errorsResult _ []                 = Safe+errorsResult f es                 = f es++adjustErrors :: LMap -> ChkItv -> [TError a] -> [TError a]+adjustErrors lm cm                = mapMaybe adjustError+  where+    adjustError (ErrSaved sp m)   =  (`ErrSaved` m) <$> adjustSrcSpan lm cm sp+    adjustError e                 = Just e++-------------------------------------------------------------------------+adjustSrcSpan :: LMap -> ChkItv -> SrcSpan -> Maybe SrcSpan+-------------------------------------------------------------------------+adjustSrcSpan lm cm sp+  = do sp' <- adjustSpan lm sp+       if isCheckedSpan cm sp'+         then Nothing+         else Just sp'++isCheckedSpan cm (RealSrcSpan sp) = isCheckedRealSpan cm sp+isCheckedSpan _  _                = False+isCheckedRealSpan cm              = not . null . (`IM.search` cm) . srcSpanStartLine++adjustSpan lm (RealSrcSpan rsp)   = RealSrcSpan <$> adjustReal lm rsp+adjustSpan _  sp                  = Just sp+adjustReal lm rsp+  | Just δ <- getShift l1 lm      = Just $ realSrcSpan f (l1 + δ) c1 (l2 + δ) c2+  | otherwise                     = Nothing+  where+    (f, l1, c1, l2, c2)           = unpackRealSrcSpan rsp+    ++-- | @getShift lm old@ returns @Just δ@ if the line number @old@ shifts by @δ@+-- in the diff and returns @Nothing@ otherwise.+getShift     :: Int -> LMap -> Maybe Int+getShift old = fmap snd . listToMaybe . IM.search old++-- | @setShift (lo, hi, δ) lm@ updates the interval map @lm@ appropriately+setShift             :: (Int, Int, Int) -> LMap -> LMap+setShift (l1, l2, δ) = IM.insert (IM.Interval l1 l2) δ+++checkedItv :: [Def] -> ChkItv+checkedItv chDefs = foldr (`IM.insert` ()) IM.empty is+  where+    is            = [IM.Interval l1 l2 | D l1 l2 _ <- chDefs]+++-------------------------------------------------------------------------+-- | Aeson instances ----------------------------------------------------+-------------------------------------------------------------------------++instance ToJSON SourcePos where+  toJSON p = object [   "sourceName"   .= f+                      , "sourceLine"   .= l+                      , "sourceColumn" .= c+                      ]+             where+               f    = sourceName   p+               l    = sourceLine   p+               c    = sourceColumn p++instance FromJSON SourcePos where+  parseJSON (Object v) = newPos <$> v .: "sourceName"+                                <*> v .: "sourceLine"+                                <*> v .: "sourceColumn"+  parseJSON _          = mempty++instance ToJSON ErrorResult where+  toJSON = genericToJSON defaultOptions+  toEncoding = genericToEncoding defaultOptions+instance FromJSON ErrorResult++instance ToJSON Doc where+  toJSON = String . T.pack . render++instance FromJSON Doc where+  parseJSON (String s) = return $ text $ T.unpack s+  parseJSON _          = mempty++instance (ToJSON k, ToJSON v) => ToJSON (M.HashMap k v) where+  toJSON = toJSON . M.toList++instance (Eq k, Hashable k, FromJSON k, FromJSON v) => FromJSON (M.HashMap k v) where+  parseJSON = fmap M.fromList . parseJSON++instance ToJSON a => ToJSON (AnnInfo a) where+  toJSON = genericToJSON defaultOptions+  toEncoding = genericToEncoding defaultOptions+instance FromJSON a => FromJSON (AnnInfo a)++instance ToJSON (Output Doc) where+  toJSON = genericToJSON defaultOptions+  toEncoding = genericToEncoding defaultOptions+instance FromJSON (Output Doc)+++line :: Located a -> Int+line  = sourceLine . loc++lineE :: Located a -> Int+lineE = sourceLine . locE++-------------------------------------------------------------------------+---- Helper functions ---------------------------------------------------+-------------------------------------------------------------------------++ifM :: (Monad m) => m Bool -> m b -> m b -> m b+ifM b x y = b >>= \z -> if z then x else y
+ src/Language/Haskell/Liquid/UX/Errors.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++-- | This module contains the functions related to @Error@ type,+-- in particular, to @tidyError@ using a solution, and @pprint@ errors.++-- TODO: move this into Tidy.++module Language.Haskell.Liquid.UX.Errors+  ( -- * Cleanup an Error+    tidyError+ ) where++import           Control.Arrow                       (second)+import qualified Data.HashMap.Strict                 as M+import qualified Data.HashSet                        as S+import           Data.Hashable+import           Data.Maybe                          (maybeToList)+import           Language.Fixpoint.Types             hiding (Error, SrcSpan, shiftVV)+import           Language.Haskell.Liquid.Types.RefType+import           Language.Haskell.Liquid.Transforms.Simplify+import           Language.Haskell.Liquid.UX.Tidy+import           Language.Haskell.Liquid.Types+import           Language.Haskell.Liquid.Misc        (single)++type Ctx = M.HashMap Symbol SpecType++------------------------------------------------------------------------+tidyError :: FixSolution -> Error -> Error+------------------------------------------------------------------------+tidyError sol+  = fmap (tidySpecType Full)+  . tidyErrContext sol+  . applySolution sol++tidyErrContext :: FixSolution -> Error -> Error+tidyErrContext _ e@(ErrSubType {})+  = e { ctx = c', tact = subst θ tA, texp = subst θ tE }+    where+      (θ, c') = tidyCtx xs $ ctx e+      xs      = syms tA ++ syms tE+      tA      = tact e+      tE      = texp e++tidyErrContext _ e@(ErrAssType {})+  = e { ctx = c', cond = subst θ p }+    where+      m       = ctx e+      (θ, c') = tidyCtx xs m+      xs      = syms p+      p       = cond e++tidyErrContext _ e+  = e++--------------------------------------------------------------------------------+tidyCtx       :: [Symbol] -> Ctx -> (Subst, Ctx)+--------------------------------------------------------------------------------+tidyCtx xs m  = (θ, M.fromList yts)+  where+    yts       = [tBind x t | (x, t) <- xts]+    (θ, xts)  = tidyTemps $ second stripReft <$> tidyREnv xs m+    tBind x t = (x', shiftVV t x') where x' = tidySymbol x+++stripReft     :: SpecType -> SpecType+stripReft t   = maybe t' (strengthen t') ro+  where+    (t', ro)  = stripRType t++stripRType    :: SpecType -> (SpecType, Maybe RReft)+stripRType st = (t', ro)+  where+    t'        = fmap (const (uTop mempty)) t+    ro        = stripRTypeBase  t+    t         = simplifyBounds st++tidyREnv      :: [Symbol] -> Ctx -> [(Symbol, SpecType)]+tidyREnv xs m = [(x, t) | x <- xs', t <- maybeToList (M.lookup x m), ok t]+  where+    xs'       = expandFix deps xs+    deps y    = maybe [] (syms . rTypeReft) (M.lookup y m)+    ok        = not . isFunTy++expandFix :: (Eq a, Hashable a) => (a -> [a]) -> [a] -> [a]+expandFix f               = S.toList . go S.empty+  where+    go seen []            = seen+    go seen (x:xs)+      | x `S.member` seen = go seen xs+      | otherwise         = go (S.insert x seen) (f x ++ xs)++tidyTemps     :: (Subable t) => [(Symbol, t)] -> (Subst, [(Symbol, t)])+tidyTemps xts = (θ, [(txB x, txTy t) | (x, t) <- xts])+  where+    txB  x    = M.lookupDefault x x m+    txTy      = subst θ+    m         = M.fromList yzs+    θ         = mkSubst [(y, EVar z) | (y, z) <- yzs]+    yzs       = zip ys niceTemps+    ys        = [ x | (x,_) <- xts, isTmpSymbol x]++niceTemps     :: [Symbol]+niceTemps     = mkSymbol <$> xs ++ ys+  where+    mkSymbol  = symbol . ('?' :)+    xs        = single   <$> ['a' .. 'z']+    ys        = ("a" ++) <$> [show n | n <- [0 ..]]
+ src/Language/Haskell/Liquid/UX/Tidy.hs view
@@ -0,0 +1,228 @@++{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}++---------------------------------------------------------------------+-- | This module contains functions for cleaning up types before+--   they are rendered, e.g. in error messages or annoations,+--   and also some PPrint instances that rely upon tidying.+---------------------------------------------------------------------++module Language.Haskell.Liquid.UX.Tidy (++    -- * Tidying functions+    tidySpecType+  , tidySymbol++    -- * Tidyness tests+  , isTmpSymbol++    -- * Panic and Exit+  , panicError++    -- * Final result+  , Result (..)++    -- * MOVE TO TYPES+  , cinfoError+  ) where++import           Prelude             hiding (error)++import qualified Data.HashMap.Strict as M+import qualified Data.HashSet        as S+import qualified Data.List           as L+import qualified Data.Text           as T+++import qualified Control.Exception  as Ex++import Language.Haskell.Liquid.GHC.Misc      (showPpr, stringTyVar)++import Language.Fixpoint.Types      hiding (Result, SrcSpan, Error)+import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.Types.RefType (rVar, subsTyVars_meet)+import Language.Haskell.Liquid.Types.PrettyPrint++++++import Data.Generics                       (everywhere, mkT)+import Text.PrettyPrint.HughesPJ+++------------------------------------------------------------------------+-- | Converting Results To Answers -------------------------------------+------------------------------------------------------------------------++class Result a where+  result :: a -> FixResult UserError++instance Result UserError where+  result e = Crash [e] ""++instance Result [Error] where+  result es = Crash (e2u <$> es) ""++instance Result Error where+  result e  = result [e] --  Crash [pprint e] ""++instance Result (FixResult Cinfo) where+  result = fmap (e2u . cinfoError)++e2u :: Error -> UserError+e2u = fmap ppSpecTypeErr++-- TODO: move to Types.hs+cinfoError :: Cinfo -> Error+cinfoError (Ci _ (Just e)) = e+cinfoError (Ci l _)        = ErrOther l (text $ "Cinfo:" ++ showPpr l)++-------------------------------------------------------------------------+isTmpSymbol    :: Symbol -> Bool+-------------------------------------------------------------------------+isTmpSymbol x  = any (`isPrefixOfSym` x) [anfPrefix, tempPrefix, "ds_"]++-------------------------------------------------------------------------+tidySpecType :: Tidy -> SpecType -> SpecType+-------------------------------------------------------------------------+tidySpecType k = tidyValueVars+               . tidyDSymbols+               . tidySymbols+               . tidyLocalRefas k+               . tidyFunBinds+               . tidyTyVars++tidyValueVars :: SpecType -> SpecType+tidyValueVars = mapReft $ \u -> u { ur_reft = tidyVV $ ur_reft u }++tidyVV r@(Reft (va,_))+  | isJunk va = shiftVV r v'+  | otherwise = r+  where+    v'        = if v `elem` xs then symbol ("v'" :: T.Text) else v+    v         = symbol ("v" :: T.Text)+    xs        = syms r+    isJunk    = isPrefixOfSym "x"++tidySymbols :: SpecType -> SpecType+tidySymbols t = substa tidySymbol $ mapBind dropBind t+  where+    xs         = S.fromList (syms t)+    dropBind x = if x `S.member` xs then tidySymbol x else nonSymbol+++tidyLocalRefas   :: Tidy -> SpecType -> SpecType+tidyLocalRefas k = mapReft (txStrata . txReft' k)+  where+    txReft' Full                  = id+    txReft' Lossy                 = txReft+    txStrata (MkUReft r p l)      = MkUReft r p (txStr l)+    txReft u                      = u { ur_reft = mapPredReft dropLocals $ ur_reft u }+    dropLocals                    = pAnd . filter (not . any isTmp . syms) . conjuncts+    isTmp x                       = any (`isPrefixOfSym` x) [anfPrefix, "ds_"]+    txStr                         = filter (not . isSVar)++tidyDSymbols :: SpecType -> SpecType+tidyDSymbols t = mapBind tx $ substa tx t+  where+    tx         = bindersTx [x | x <- syms t, isTmp x]+    isTmp      = (tempPrefix `isPrefixOfSym`)++tidyFunBinds :: SpecType -> SpecType+tidyFunBinds t = mapBind tx $ substa tx t+  where+    tx         = bindersTx $ filter isTmpSymbol $ funBinds t++tidyTyVars :: SpecType -> SpecType+tidyTyVars t = subsTyVarsAll αβs t+  where+    αβs  = zipWith (\α β -> (α, toRSort β, β)) αs βs+    αs   = L.nub (tyVars t)+    βs   = map (rVar . stringTyVar) pool+    pool = [[c] | c <- ['a'..'z']] ++ [ "t" ++ show i | i <- [1..]]+++bindersTx ds   = \y -> M.lookupDefault y y m+  where+    m          = M.fromList $ zip ds $ var <$> [1..]+    var        = symbol . ('x' :) . show+++tyVars (RAllP _ t)     = tyVars t+tyVars (RAllS _ t)     = tyVars t+tyVars (RAllT α t)     = α : tyVars t+tyVars (RFun _ t t' _) = tyVars t ++ tyVars t'+tyVars (RAppTy t t' _) = tyVars t ++ tyVars t'+tyVars (RApp _ ts _ _) = concatMap tyVars ts+tyVars (RVar α _)      = [α]+tyVars (RAllE _ _ t)   = tyVars t+tyVars (REx _ _ t)     = tyVars t+tyVars (RExprArg _)    = []+tyVars (RRTy _ _ _ t)  = tyVars t+tyVars (RHole _)       = []++subsTyVarsAll ats = go+  where+    abm            = M.fromList [(a, b) | (a, _, RVar b _) <- ats]+    go (RAllT a t) = RAllT (M.lookupDefault a a abm) (go t)+    go t           = subsTyVars_meet ats t+++funBinds (RAllT _ t)      = funBinds t+funBinds (RAllP _ t)      = funBinds t+funBinds (RAllS _ t)      = funBinds t+funBinds (RFun b t1 t2 _) = b : funBinds t1 ++ funBinds t2+funBinds (RApp _ ts _ _)  = concatMap funBinds ts+funBinds (RAllE b t1 t2)  = b : funBinds t1 ++ funBinds t2+funBinds (REx b t1 t2)    = b : funBinds t1 ++ funBinds t2+funBinds (RVar _ _)       = []+funBinds (RRTy _ _ _ t)   = funBinds t+funBinds (RAppTy t1 t2 _) = funBinds t1 ++ funBinds t2+funBinds (RExprArg _)     = []+funBinds (RHole _)        = []+++--------------------------------------------------------------------------------+-- | Show an Error, then crash+--------------------------------------------------------------------------------+panicError :: {-(?callStack :: CallStack) =>-} Error -> a+--------------------------------------------------------------------------------+panicError = Ex.throw++-- ^ This function is put in this module as+--   it depends on the Exception instance,+--   which depends on the PPrint instance,+--   which depends on tidySpecType.++--------------------------------------------------------------------------------+-- | Pretty Printing Error Messages --------------------------------------------+--------------------------------------------------------------------------------++-- | Need to put @PPrint Error@ instance here (instead of in Types),+--   as it depends on @PPrint SpecTypes@, which lives in this module.++instance PPrint (CtxError Doc) where+  pprintTidy k ce = ppError k (ctCtx ce) $ ctErr ce++instance PPrint (CtxError SpecType) where+  pprintTidy k ce = ppError k (ctCtx ce) $ ppSpecTypeErr <$> ctErr ce++instance PPrint Error where+  pprintTidy k = ppError k empty . fmap ppSpecTypeErr++ppSpecTypeErr :: SpecType -> Doc+ppSpecTypeErr = rtypeDoc     Lossy+              . tidySpecType Lossy+              . fmap (everywhere (mkT noCasts))+  where+    noCasts (ECst x _) = x+    noCasts e          = e++instance Show Error where+  show = showpp++instance Ex.Exception Error+instance Ex.Exception [Error]
− src/Language/Haskell/Liquid/Variance.hs 
@@ -1,11 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--module Language.Haskell.Liquid.Variance (-    Variance(..), VarianceInfo-        ) where--import Data.Typeable-import Data.Data--type VarianceInfo = [Variance]-data Variance = Invariant | Bivariant | Contravariant | Covariant deriving (Data, Typeable, Show)
− src/Language/Haskell/Liquid/Visitors.hs 
@@ -1,143 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE TypeSynonymInstances      #-} -{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE DeriveDataTypeable        #-}-{-# LANGUAGE ScopedTypeVariables       #-}---module Language.Haskell.Liquid.Visitors (-  -  -- * visitors -  CBVisitable (..) --  ) where---import DataCon-import Literal-import CoreSyn--import Var--import Data.List (foldl', (\\), delete)--import qualified Data.HashSet        as S-import Language.Fixpoint.Misc-import Language.Haskell.Liquid.GhcMisc ()------------------------------------------------------------------------------------------------------------------ A CoreBind Visitor ------------------------------------------------------------------------------------------------------------- TODO: syb-shrinkage--class CBVisitable a where-  freeVars :: S.HashSet Var -> a -> [Var]-  readVars :: a -> [Var] -  letVars  :: a -> [Var] -  literals :: a -> [Literal]--instance CBVisitable [CoreBind] where-  freeVars env cbs = (sortNub xs) \\ ys -    where xs = concatMap (freeVars env) cbs -          ys = concatMap bindings cbs-  -  readVars = concatMap readVars-  letVars  = concatMap letVars -  literals = concatMap literals--instance CBVisitable CoreBind where-  freeVars env (NonRec x e) = freeVars (extendEnv env [x]) e -  freeVars env (Rec xes)    = concatMap (freeVars env') es -                              where (xs,es) = unzip xes -                                    env'    = extendEnv env xs --  readVars (NonRec _ e)     = readVars e-  readVars (Rec xes)        = concat [x `delete` nubReadVars e |(x, e) <- xes]-    where nubReadVars = sortNub . readVars--  letVars (NonRec x e)      = x : letVars e-  letVars (Rec xes)         = xs ++ concatMap letVars es-    where -      (xs, es)              = unzip xes--  literals (NonRec _ e)      = literals e-  literals (Rec xes)         = concatMap literals $ map snd xes--instance CBVisitable (Expr Var) where-  freeVars = exprFreeVars-  readVars = exprReadVars-  letVars  = exprLetVars-  literals = exprLiterals--exprFreeVars = go -  where -    go env (Var x)         = if x `S.member` env then [] else [x]  -    go env (App e a)       = (go env e) ++ (go env a)-    go env (Lam x e)       = go (extendEnv env [x]) e-    go env (Let b e)       = (freeVars env b) ++ (go (extendEnv env (bindings b)) e)-    go env (Tick _ e)      = go env e-    go env (Cast e _)      = go env e-    go env (Case e x _ cs) = (go env e) ++ (concatMap (freeVars (extendEnv env [x])) cs) -    go _   _               = []--exprReadVars = go-  where-    go (Var x)             = [x]-    go (App e a)           = concatMap go [e, a] -    go (Lam _ e)           = go e-    go (Let b e)           = readVars b ++ go e -    go (Tick _ e)          = go e-    go (Cast e _)          = go e-    go (Case e _ _ cs)     = (go e) ++ (concatMap readVars cs) -    go _                   = []--exprLetVars = go-  where-    go (Var _)             = []-    go (App e a)           = concatMap go [e, a] -    go (Lam x e)           = x : go e-    go (Let b e)           = letVars b ++ go e -    go (Tick _ e)          = go e-    go (Cast e _)          = go e-    go (Case e x _ cs)     = x : go e ++ concatMap letVars cs-    go _                   = []--exprLiterals = go-  where-    go (Lit l)             = [l]-    go (App e a)           = concatMap go [e, a] -    go (Let b e)           = literals b ++ go e -    go (Lam _ e)           = go e-    go (Tick _ e)          = go e-    go (Cast e _)          = go e-    go (Case e _ _ cs)     = (go e) ++ (concatMap literals cs) -    go _                   = []---instance CBVisitable (Alt Var) where-  freeVars env (a, xs, e) = freeVars env a ++ freeVars (extendEnv env xs) e-  readVars (_,_, e)       = readVars e-  letVars  (_,xs,e)       = xs ++ letVars e-  literals (c,_, e)       = literals c ++ literals e---instance CBVisitable AltCon where-  freeVars _ (DataAlt dc) = dataConImplicitIds dc-  freeVars _ _            = []-  readVars _              = []-  letVars  _              = []-  literals (LitAlt l)     = [l]-  literals _              = []----extendEnv = foldl' (flip S.insert)--bindings (NonRec x _) -  = [x]-bindings (Rec  xes  ) -  = map fst xes
src/Language/Haskell/Liquid/WiredIn.hs view
@@ -1,33 +1,78 @@-{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE OverloadedStrings #-} -module Language.Haskell.Liquid.WiredIn where+module Language.Haskell.Liquid.WiredIn+       ( propType+       , propTyCon+       , hpropTyCon+       , pdVarReft+       , wiredTyCons, wiredDataCons+       , wiredSortedSyms +       -- | Constants for automatic proofs+       , dictionaryVar, dictionaryTyVar, dictionaryBind+       , proofTyConName, combineProofsName+       ) where++import Prelude hiding (error)+ import Language.Haskell.Liquid.Types-import Language.Haskell.Liquid.RefType-import Language.Haskell.Liquid.GhcMisc-import Language.Haskell.Liquid.Variance+import Language.Haskell.Liquid.Misc (mapSnd)+import Language.Haskell.Liquid.Types.RefType+import Language.Haskell.Liquid.GHC.Misc+import Language.Haskell.Liquid.Types.Variance+import Language.Haskell.Liquid.Types.PredType -import Language.Fixpoint.Names                  (hpropConName, propConName)++ import Language.Fixpoint.Types-import Language.Fixpoint.Misc                   (mapSnd)  import BasicTypes import DataCon import TyCon import TysWiredIn -import Data.Monoid-import Control.Applicative+import TypeRep+import CoreSyn +++wiredSortedSyms = [(pappSym n, pappSort n) | n <- [1..pappArity]]+ ----------------------------------------------------------------------- -- | LH Primitive TyCons ---------------------------------------------- ----------------------------------------------------------------------- +dictionaryVar   = stringVar "tmp_dictionary_var" (ForAllTy dictionaryTyVar $ TyVarTy dictionaryTyVar)+dictionaryTyVar = stringTyVar "da"+dictionaryBind = Rec [(v, Lam a $ App (Var v) (Type $ TyVarTy a))]+  where+   v = dictionaryVar+   a = dictionaryTyVar++++-----------------------------------------------------------------------+-- | LH Primitive TyCons ----------------------------------------------+-----------------------------------------------------------------------+++combineProofsName :: String+combineProofsName = "combineProofs"++proofTyConName :: Symbol+proofTyConName = "Proof"+ propTyCon, hpropTyCon :: TyCon-propTyCon  = symbolTyCon 'w' 24 propConName-hpropTyCon = symbolTyCon 'w' 24 hpropConName  +{- ATTENTION: Uniques should be different when defining TyCons+   otherwise the TyCons are equal and they will all resolve to+   bool in fixpoint, as propTyCon is a bool+ -}++propTyCon  = symbolTyCon 'w' 25 propConName+hpropTyCon = symbolTyCon 'w' 26 hpropConName+ ----------------------------------------------------------------------- -- | LH Primitive Types ---------------------------------------------- -----------------------------------------------------------------------@@ -35,8 +80,6 @@ propType :: Reftable r => RRType r propType = RApp (RTyCon propTyCon [] defaultTyConInfo) [] [] mempty -- -------------------------------------------------------------------- ------ Predicate Types for WiredIns -------------------------------- --------------------------------------------------------------------@@ -50,13 +93,12 @@ wiredTyDataCons :: ([(TyCon, TyConP)] , [(DataCon, Located DataConP)]) wiredTyDataCons = (concat tcs, mapSnd dummyLoc <$> concat dcs)   where-    (tcs, dcs)  = unzip l-    l           = [listTyDataCons] ++ map tupleTyDataCons [2..maxArity]+    (tcs, dcs)  = unzip $ listTyDataCons : map tupleTyDataCons [2..maxArity]  listTyDataCons :: ([(TyCon, TyConP)] , [(DataCon, DataConP)])-listTyDataCons   = ( [(c, TyConP [(RTV tyv)] [p] [] [Covariant] [Covariant] (Just fsize))]-                   , [(nilDataCon, DataConP l0 [(RTV tyv)] [p] [] [] [] lt l0)-                   , (consDataCon, DataConP l0 [(RTV tyv)] [p] [] [] cargs  lt l0)])+listTyDataCons   = ( [(c, TyConP [RTV tyv] [p] [] [Covariant] [Covariant] (Just fsize))]+                   , [(nilDataCon, DataConP l0 [RTV tyv] [p] [] [] [] lt l0)+                   , (consDataCon, DataConP l0 [RTV tyv] [p] [] [] cargs  lt l0)])     where       l0         = dummyPos "LH.Bare.listTyDataCons"       c          = listTyCon@@ -67,11 +109,11 @@       xs         = "xsListSelector"       p          = PV "p" (PVProp t) (vv Nothing) [(t, fld, EVar fld)]       px         = pdVarReft $ PV "p" (PVProp t) (vv Nothing) [(t, fld, EVar x)]-      lt         = rApp c [xt] [RPropP [] $ pdVarReft p] mempty+      lt         = rApp c [xt] [rPropP [] $ pdVarReft p] mempty       xt         = rVar tyv-      xst        = rApp c [RVar (RTV tyv) px] [RPropP [] $ pdVarReft p] mempty+      xst        = rApp c [RVar (RTV tyv) px] [rPropP [] $ pdVarReft p] mempty       cargs      = [(xs, xst), (x, xt)]-      fsize      = \x -> EApp (dummyLoc "len") [EVar x]+      fsize z    = mkEApp (dummyLoc "len") [EVar z]  tupleTyDataCons :: Int -> ([(TyCon, TyConP)] , [(DataCon, DataConP)]) tupleTyDataCons n = ( [(c, TyConP (RTV <$> tyvs) ps [] tyvarinfo pdvarinfo Nothing)]@@ -87,25 +129,25 @@     flds          = mks "fld_Tuple"     fld           = "fld_Tuple"     x1:xs         = mks ("x_Tuple" ++ show n)-    ps            = mkps pnames (ta:ts) ((fld, EVar fld):(zip flds (EVar <$>flds)))+    ps            = mkps pnames (ta:ts) ((fld, EVar fld) : zip flds (EVar <$> flds))     ups           = uPVar <$> ps-    pxs           = mkps pnames (ta:ts) ((fld, EVar x1):(zip flds (EVar <$> xs)))-    lt            = rApp c (rVar <$> tyvs) (RPropP [] . pdVarReft <$> ups) mempty+    pxs           = mkps pnames (ta:ts) ((fld, EVar x1) : zip flds (EVar <$> xs))+    lt            = rApp c (rVar <$> tyvs) (rPropP [] . pdVarReft <$> ups) mempty     xts           = zipWith (\v p -> RVar (RTV v) (pdVarReft p)) tvs pxs-    cargs         = reverse $ (x1, rVar tv) : (zip xs xts)+    cargs         = reverse $ (x1, rVar tv) : zip xs xts     pnames        = mks_ "p"     mks  x        = (\i -> symbol (x++ show i)) <$> [1..n]     mks_ x        = (\i -> symbol (x++ show i)) <$> [2..n]  -pdVarReft = (\p -> U mempty p mempty) . pdVar+pdVarReft = (\p -> MkUReft mempty p mempty) . pdVar  mkps ns (t:ts) ((f,x):fxs) = reverse $ mkps_ ns ts fxs [(t, f, x)] []-mkps _  _      _           = error "Bare : mkps"+mkps _  _      _           = panic Nothing "Bare : mkps"  mkps_ []     _       _          _    ps = ps mkps_ (n:ns) (t:ts) ((f, x):xs) args ps = mkps_ ns ts xs (a:args) (p:ps)   where     p                                   = PV n (PVProp t) (vv Nothing) args     a                                   = (t, f, x)-mkps_ _     _       _          _    _ = error "Bare : mkps_"+mkps_ _     _       _          _    _ = panic Nothing "Bare : mkps_"
− src/Language/Haskell/Liquid/World.hs 
@@ -1,23 +0,0 @@--- | This module contains various functions for operating on the @World@ type defined in---   Language.Haskell.Liquid.Types--module Language.Haskell.Liquid.World (-  -- * Empty world-  empty-  ) where--import Data.Monoid-import Language.Haskell.Liquid.Types-import Language.Fixpoint.Misc--empty   :: World t-empty   = World []--sepConj :: World t -> World t -> World t-sepConj = errorstar "TODO:EFFECTS"--instance Monoid (World t) where-  mempty        = empty-  mappend w1 w2 = sepConj w1 w2--
+ src/Liquid.hs view
@@ -0,0 +1,5 @@+import Language.Haskell.Liquid.Liquid (liquid)+import System.Environment             (getArgs)++main :: IO a+main = liquid =<< getArgs
+ tests/crash/Assume.hs view
@@ -0,0 +1,5 @@+module Assume where++{-@ assume incr :: Int -> {v : Int | v == x} @-}+incr :: Int -> Int+incr x = x + 1
+ tests/crash/Assume1.hs view
@@ -0,0 +1,15 @@+a :: Int+a = 0++{-@ assume b :: { b : Int | a < b } @-}+b :: Int+b = 1++{-@+f :: a : Int -> { b : Int | a < b } -> ()+@-}+f :: Int -> Int -> ()+f _ _ = ()++g :: ()+g = f a b
+ tests/crash/Ast.hs view
@@ -0,0 +1,61 @@+-- FAILING TEST: this test SHOULD FAIL BUT DOESN'T+-- issue #519++{-# LANGUAGE DeriveFunctor #-}+module Main where++data AstIndex = IxExpr | IxType++{-@ measure isExprIndex @-}+isExprIndex :: AstIndex -> Bool+isExprIndex IxExpr = True+isExprIndex _      = False++{-@ measure isTypeIndex @-}+isTypeIndex :: AstIndex -> Bool+isTypeIndex IxType = True+isTypeIndex _      = False++data AstF f = Lit Int    AstIndex+            | Var String AstIndex+            | App f f+            | Paren f++{-@+  data AstF f <ix :: AstIndex -> Prop>+    = Lit Int    (i :: AstIndex<ix>)+    | Var String (i :: AstIndex<ix>)+    | App (fn :: f) (arg :: f)+    | Paren (ast :: f)+  @-}++{-@ type AstFE = AstF <{\ix -> isExprIndex ix}> @-}+{-@ type AstFT = AstF <{\ix -> isTypeIndex ix}> @-}+++-- Now lets tie the knot!++newtype Fix f = In { out :: f (Fix f) }++type Ast = Fix AstF++{-@ type AstE = Fix AstFE @-}+{-@ type AstT = Fix AstFT @-}++{-@ astExpr :: AstE  @-}+astExpr :: Ast+astExpr = In (Lit 10 IxExpr) ++{-@ astType :: AstT @-}+astType :: Ast +astType = In (Lit 10 IxType)++{-@ app :: forall <p :: AstIndex -> Prop>. Fix (AstF p) -> Fix (AstF p) -> Fix (AstF p) @-}+app f x = In $ App f x++{-@ id1 :: forall <p :: AstIndex -> Prop>. Fix (AstF p) -> Fix (AstF p)  @-}+id1 :: Fix AstF -> Fix AstF+id1 z = z++{-@ wrong :: AstT @-}+wrong = id1 astExpr
tests/crash/CyclicExprAlias2.hs view
@@ -1,6 +1,6 @@ module Test3 () where -{-@ expression CyclicC1 Q = (CyclicC2 Q) / (CyclicC3 Q) @-}+{-@ expression CyclicC1 Q = (CyclicC2 Q) && (CyclicC3 Q) @-} {-@ expression CyclicC2 Q = CyclicC1 Q @-} {-@ expression CyclicC3 Q = CyclicC1 Q @-}
+ tests/crash/Qualif.hs view
@@ -0,0 +1,10 @@+module RG where+data RGRef a+{-@ measure tv :: RGRef a -> a @-}+{-@ qualif TERMINALVALUE(r:RGRef a): (tv r) @-}+++data A+data B++{-@ qualif Foo(x:A, y:B): (x == y) @-}
+ tests/crash/T649.hs view
@@ -0,0 +1,34 @@+module Blank where++import Data.Word+import GHC.Ptr++{-@ class measure sizeOf :: forall a . Ptr a -> Int @-}+{-@+instance measure sizeOf :: (Ptr Data.Word.Word16) -> Int+sizeOf (Ptr x) = 2+@-}+{-@+instance measure sizeOf :: (Ptr Data.Word.Word32) -> Int+sizeOf (Ptr y) = 4+@-}++{- measure sizeOf :: forall a . Ptr a -> Int @-}++{- invariant {v:Ptr Word16 | sizeOf v = 2} @-}+{- invariant {v:Ptr Word32 | sizeOf v = 4} @-}++{-@+bar :: { p : Ptr Word32 | plen p >= (sizeOf p) }+    -> ()+@-}+bar :: Ptr Word32 -> ()+bar (Ptr unused) = ()++{-@+qux :: { p : Ptr Word32 | plen p >= 0 }+    -> ()+@-}+qux :: Ptr Word32 -> ()+qux (Ptr addr) = let x = Ptr addr in bar x+
+ tests/crash/errmsg-dc-num.hs view
@@ -0,0 +1,6 @@+module Boo where++{-@ data T = C { fldX :: Int } @-}+++data T = C { fldX :: Int, fldY :: Int }
+ tests/crash/errmsg-dc-type.hs view
@@ -0,0 +1,5 @@+module Boo where++{-@ data T = C { fldX :: Int, fldY :: Bool } @-}++data T = C { fldX :: Int, fldY :: Int }
+ tests/crash/errmsg-mismatch.hs view
@@ -0,0 +1,5 @@+module Boo where++{-@ incr :: Int -> Bool @-}+incr :: Int -> Int +incr x = x + 1
+ tests/crash/issue594.hs view
@@ -0,0 +1,7 @@+module Boo where++{-@ data X <q :: Int -> Int -> Prop> = X (x0 :: Int) (x1 :: Int<q x0>) @-}  +data X = X Int Int  ++{-@ data T <p :: Int -> Int -> Int -> Int -> Prop> = C { x :: Int, y :: Int, z :: X<p x y> } @-}+data T = C { x :: Int, y :: Int, z :: X }
+ tests/crash/predparams.hs view
@@ -0,0 +1,10 @@++-- ISSUE: this "crashes" without a decent source location+-- You can fix this with the signature `ide :: forall <p :: a -> Prop>. a<p> -> a<p>`+-- but it would be nice to have an error message that pinpoints the location.+-- https://github.com/ucsd-progsys/liquidhaskell/issues/655++module Ide where++{-@ ide :: a<p> -> a<p> @-}+ide x = x
+ tests/neg/AbsApp.hs view
@@ -0,0 +1,16 @@+-- FAILING TEST: This should be rejected if we wish to disallow applying+-- concrete refinements to non-refined types (e.g. Int) where they are currently+-- silently dropped.+-- issue #519++module Main where++{-@ id2 :: forall <p :: Int -> Prop>. Int<p> -> Int<p> @-}+id2 :: Int -> Int+id2 x = x++{-@ type Neg = Int<{\x -> x < 0}> @-}++{-@ three :: Neg @-}+three = id2 3+
+ tests/neg/Ast.hs view
@@ -0,0 +1,54 @@+-- FAILING TEST: this test SHOULD FAIL BUT DOESN'T+-- issue #519++{-# LANGUAGE DeriveFunctor #-}+module Main where++data AstIndex = IxExpr | IxType++{-@ measure isExprIndex @-}+isExprIndex :: AstIndex -> Bool+isExprIndex IxExpr = True+isExprIndex _      = False++{-@ measure isTypeIndex @-}+isTypeIndex :: AstIndex -> Bool+isTypeIndex IxType = True+isTypeIndex _      = False++data AstF f = Lit Int    AstIndex+            | Var String AstIndex+            | App f f+            | Paren f++{-@+  data AstF f <ix :: AstIndex -> Prop>+    = Lit Int    (i :: AstIndex<ix>)+    | Var String (i :: AstIndex<ix>)+    | App (fn :: f) (arg :: f)+    | Paren (ast :: f)+  @-}++{-@ type AstFE = AstF <{\ix -> isExprIndex ix}> @-}+{-@ type AstFT = AstF <{\ix -> isTypeIndex ix}> @-}+++-- Now lets tie the knot!++newtype Fix f = In { out :: f (Fix f) }++type Ast = Fix AstF++{-@ type AstE = Fix AstFE @-}+{-@ type AstT = Fix AstFT @-}++{-@ astExpr :: Fix (AstF <{\ix -> isExprIndex ix}>)  @-}+astExpr :: Ast+astExpr = undefined ++{-@ id1 :: forall <p :: AstIndex -> Prop>. Fix (AstF <p>) -> Fix (AstF <p>)  @-}+id1 :: Fix AstF -> Fix AstF+id1 z = z++{-@ wrong :: AstT @-}+wrong = id1 astExpr
+ tests/neg/BadHMeas.hs view
@@ -0,0 +1,5 @@++{-@ measure foo @-}+foo :: [(Int,Int)] -> Int+foo [] = 0+foo (a:as) = fst a + foo as
+ tests/neg/BigNum.hs view
@@ -0,0 +1,7 @@+module BigNum where++{-@ type Foo = { v : Integer | 0 <= v && v < 4611686018427387903 * 8 } @-}++{-@ f :: i : Foo -> { o : Foo | i < o } @-}+f :: Integer -> Integer+f i = i * 2
+ tests/neg/Books.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE CPP #-}++#define DISCOUNT_PERCENTAGE   2+#define BOOK_THRESHOLD        2++module Books where++calculateDiscount' :: Customer -> Int -> Int++---------------------------------------------------------------------------------------+-- 1. Define: Types of customers+---------------------------------------------------------------------------------------++data Customer = Vip | Reg deriving (Eq)++---------------------------------------------------------------------------------------+-- 2. Define: Discountable Customers and Discounts+---------------------------------------------------------------------------------------++{-@ inline customerGetsDiscount @-}+customerGetsDiscount :: Customer -> Int -> Bool+customerGetsDiscount c i = c == Vip && i >= BOOK_THRESHOLD++{-@ inline discount @-}+discount :: Int -> Int+discount bookCount = (bookCount - BOOK_THRESHOLD) * DISCOUNT_PERCENTAGE++{-@ type Discount i = {v:Int | v == discount i} @-}++---------------------------------------------------------------------------------------+-- 3. Policy: Only compute discounts for discountable customers+---------------------------------------------------------------------------------------++{-@ calculateDiscount' :: c:Customer -> i:{Int | customerGetsDiscount c i} -> Discount i @-}+calculateDiscount' c i = discount i++---------------------------------------------------------------------------------------+-- 4. Implement: Code to compute discounts, if suitable, is accepted+---------------------------------------------------------------------------------------++{-@ calculateDiscount :: Int -> Nat -> Nat @-}+calculateDiscount userId bookCount+  | getsDiscount = calculateDiscount' c bookCount+  | otherwise    = 0+  where+    getsDiscount = customerGetsDiscount c bookCount+    c            = customerType userId++---------------------------------------------------------------------------------------+-- 5. Buggy Implementation, with wrong check, is rejected+---------------------------------------------------------------------------------------++{-@ misCalculateDiscount :: Int -> Nat -> Nat @-}+misCalculateDiscount userId bookCount+  | getsDiscount = calculateDiscount' c bookCount+  | otherwise    = 0+  where+    getsDiscount = c == Vip+    c            = customerType userId++customerType :: Int -> Customer+customerType = undefined
+ tests/neg/FunSoundness.hs view
@@ -0,0 +1,9 @@+module FunSoundness where+++{-@ deadfun :: {v:a | false} -> a @-}+deadfun :: a -> a+deadfun x = x++bad = deadfun f +  where f x = x
+ tests/neg/GADTs.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}++module Blank where++data Some :: * -> * where+  SomeBool  :: Bool -> Some Int+  SomeInt   :: Int  -> Some Int++{-@ measure isBool @-}+isBool :: Some Int -> Bool+isBool (SomeBool  _) = True+isBool (SomeInt   _) = False++{-@ type SomeBool = { v: Some Int | isBool v } @-}++{-@ a :: SomeBool @-}+a = SomeBool True++{-@ b :: SomeBool @-}+b = SomeInt 5
+ tests/neg/Gradual.hs view
@@ -0,0 +1,15 @@+module Gradual where+++{-@ unsafe :: {v:Int | ?? } -> Int  -> (Int, Int) @-}+unsafe :: Int -> Int -> (Int, Int)+unsafe _ x = (bar1 x, bar2 x)+++{-@ bar1 :: {v:Int | v < 0} -> Int @-}+bar1 :: Int -> Int +bar1 x = x ++{-@ bar2 :: {v:Int | v = 0} -> Int @-}+bar2 :: Int -> Int +bar2 x = x
− tests/neg/PairMeasure0.hs 
@@ -1,20 +0,0 @@-module Foo () where--{-@ measure getfst :: (a, b) -> a-    getfst (x, y) = x-  @-}--{-@ type Pair a b   = {v0 : ({v:a | v = (getfst v0)}, b) | true } @-}-{-@ type OPList a b = [(Pair a b)]<\h -> {v: (Pair a b) | (getfst v) >= (getfst h)}> @-}-{-@ type OList a    = [a]<\h -> {v: a | (v >= h)}> @-}----- This is Unsafe, as refinements in Predicate parameters (i.e., Pair a b)--- are lost, so application `getFsts` cannot be proven safe-{-@ getFsts          :: OPList a b -> OList a @-}-getFsts :: [(a, b)] -> [a]-getFsts []           = [] -getFsts ((x,_) : xs) = x : getFsts xs---
tests/neg/Propability.hs view
@@ -1,7 +1,5 @@ module Propability where -{-@ LIQUID "--real" @-}- {-@ type Propability = {v:Double | ((0.0 <= v) && (v <= 1.0)) } @-}  {-@ p :: Propability @-}
tests/neg/Propability0.hs view
@@ -7,8 +7,6 @@    snd :: Int -> Real  -} -{-@ LIQUID "--real" @-}- {-@ type Propability = {v:Double | ((0.0 <= v) && (v <= 1.0)) } @-}  {-@ p :: Propability @-}
tests/neg/StateConstraints.hs view
@@ -5,7 +5,7 @@  data ST s = ST {runState :: s -> s} -{-@ data ST s t <p :: s -> Prop, q :: s -> s -> Prop> = ST (runState :: x:s<p> -> s<q x>) @-}+{-@ data ST s <p :: s -> Prop, q :: s -> s -> Prop> = ST (runState :: x:s<p> -> s<q x>) @-}   {-@ runState :: forall <p :: s -> Prop, q :: s -> s -> Prop>. ST <p, q> s -> x:s<p> -> s<q x> @-}
+ tests/neg/T602.hs view
@@ -0,0 +1,22 @@+module T602 where++-- UNSOUNDLY SAFE+{-@+class Fractional a => Foo a where+    foo :: { x : a | x /= 0 } -> a+@-}++-- UNSAFE+{-+class Fractional a => Foo a where+    foo :: { x : a | x /= 0.0 } -> a+@-}++class Fractional a => Foo a where+    foo :: a -> a++instance Foo Double where+    foo = id++example :: Double+example = foo 0.0
+ tests/neg/TermReal.hs view
@@ -0,0 +1,5 @@+module Main where++{-@ search :: { hi : Int | 0 < hi } -> Int @-}+search :: Int -> Int+search hi = search (hi `div` 2)
+ tests/neg/Variance1.hs view
@@ -0,0 +1,11 @@+import Data.Binary+++{-@+error :: { x : String | false } -> a+@-}++example :: Get ()+example = do+    _ <- return ()+    error "URK"
+ tests/neg/listne.hs view
@@ -0,0 +1,7 @@++{-@ type ListNE a = {v:[a] | 0 < len v} @-}++{-@ junkProp :: ListNE Int @-}+junkProp :: [Int]+junkProp = []+
tests/pos/Abs.hs view
@@ -3,10 +3,10 @@ absN ::  (Num a, Ord a) => a -> a absN x = if x > 0 then x else (-x) -absI ::  Int -> Int +absI ::  Int -> Int absI x = if x > 0 then x else (-x) ---incI ::  Int -> Int +--incI ::  Int -> Int --incI = (+) 1  x0 = absN 4
tests/pos/Avg.hs view
@@ -1,8 +1,5 @@ module Avg where --{-@ LIQUID "--real" @-}- {-@ measure sumD :: [Double] -> Double     sumD([]) = 0.0     sumD(x:xs) = x + (sumD xs)
+ tests/pos/Bar.hs view
@@ -0,0 +1,5 @@+module Bar where++import Foo++foo = bar
+ tests/pos/BinarySearch.hs view
@@ -0,0 +1,43 @@+{- | By Gabriel Gonzalez, from:+     http://www.haskellforall.com/2015/12/compile-time-memory-safety-using-liquid.html+-}++module BinarySearch (binarySearch) where++import Data.Vector as Vector++binarySearch :: Ord a => a -> Vector a -> Maybe Int+binarySearch x v =+    if Vector.length v == 0+    then Nothing+    else loop x v 0 (Vector.length v - 1)++midpoint :: Int -> Int -> Int+midpoint lo hi = (lo + hi) `div` 2++{-@+loop+    :: Ord a+    => x  : a+    -> v  : Vector a+    -> lo : { lo : Int | 0  <= lo && lo < vlen v }+    -> hi : { hi : Int | lo <= hi && hi < vlen v }+    -> Maybe Int+    / [hi - lo]+@-}+loop :: Ord a => a -> Vector a -> Int -> Int -> Maybe Int+loop x v lo hi = do+    let mid = lo + ((hi - lo) `div` 2) -- midpoint lo hi+    if x < v ! mid+    then do+        let hi' = mid - 1+        if lo <= hi'+        then loop x v lo hi'+        else Nothing+    else if v ! mid < x+    then do+        let lo' = mid + 1+        if lo' <= hi+        then loop x v lo' hi+        else Nothing+    else Just mid
+ tests/pos/Books.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE CPP #-}++#define DISCOUNT_PERCENTAGE   2+#define BOOK_THRESHOLD        2++module Books where++calculateDiscount' :: Customer -> Int -> Int++---------------------------------------------------------------------------------------+-- 1. Define: Types of customers+---------------------------------------------------------------------------------------++data Customer = Vip | Reg deriving (Eq)++---------------------------------------------------------------------------------------+-- 2. Define: Discountable Customers and Discounts+---------------------------------------------------------------------------------------++{-@ inline customerGetsDiscount @-}+customerGetsDiscount :: Customer -> Int -> Bool+customerGetsDiscount c i = c == Vip && i >= BOOK_THRESHOLD++{-@ inline discount @-}+discount :: Int -> Int+discount bookCount = (bookCount - BOOK_THRESHOLD) * DISCOUNT_PERCENTAGE++{-@ type Discount i = {v:Int | v == discount i} @-}++---------------------------------------------------------------------------------------+-- 3. Policy: Only compute discounts for discountable customers+---------------------------------------------------------------------------------------++{-@ calculateDiscount' :: c:Customer -> i:{Int | customerGetsDiscount c i} -> Discount i @-}+calculateDiscount' c i = discount i++---------------------------------------------------------------------------------------+-- 4. Implement: Code to compute discounts, if suitable, is accepted+---------------------------------------------------------------------------------------++{-@ calculateDiscount :: Int -> Nat -> Nat @-}+calculateDiscount userId bookCount+  | getsDiscount = calculateDiscount' c bookCount+  | otherwise    = 0+  where+    getsDiscount = customerGetsDiscount c bookCount+    c            = customerType userId++customerType :: Int -> Customer+customerType = undefined
tests/pos/Class.hs view
@@ -6,36 +6,45 @@ import Prelude hiding (sum, length, (!!), Functor(..)) import qualified Prelude as P -{-@ qualif Size(v:int, xs:a): v = (size xs) @-}+{-@ qualif Size(v:Int, xs:a): v = size xs @-} -{-@ data List a = Nil | Cons (hd::a) (tl::(List a)) @-}-data List a = Nil | Cons a (List a)+{-@ qualif Size(v:Int, xs:MList a): v = size xs @-} -{-@ length :: xs:List a -> {v:Nat | v = (size xs)} @-}-length :: List a -> Int-length Nil         = 0-length (Cons x xs) = 1 + length xs+{-@ data MList a = Nil | Cons (hd::a) (tl::(MList a)) @-}+data MList a = Nil | Cons a (MList a) -{-@ (!!) :: xs:List a -> {v:Nat | v < (size xs)} -> a @-}-(!!) :: List a -> Int -> a+{-@ (!!) :: xs:MList a -> {v:Nat | v < (size xs)} -> a @-}+(!!) :: MList a -> Int -> a Nil         !! i = liquidError "impossible" (Cons x _)  !! 0 = x (Cons x xs) !! i = xs !! (i - 1)  {-@ class measure size :: forall a. a -> Int @-}+ {-@ class Sized s where-      size :: forall a. x:s a -> {v:Nat | v = (size x)}+      size :: forall a. x:s a -> {v:Nat | v = size x}   @-} class Sized s where   size :: s a -> Int -instance Sized List where-  {-@ instance measure size :: List a -> Int+instance Sized MList where+  {-@ instance measure size :: MList a -> Int       size (Nil)       = 0-      size (Cons x xs) = 1 + (size xs)+      size (Cons x xs) = 1 + size xs     @-}   size = length +{-@ length :: xs:MList a -> {v:Nat | v = size xs} @-}+length :: MList a -> Int+length Nil         = 0+length (Cons x xs) = 1 + length xs++{-@ bob :: xs:MList a -> {v:Nat | v = size xs} @-}+bob :: MList a -> Int+bob = length+++ instance Sized [] where   {-@ instance measure size :: [a] -> Int       size ([])   = 0@@ -45,13 +54,13 @@   size (x:xs) = 1 + size xs  {-@ class (Sized s) => Indexable s where-      index :: forall a. x:s a -> {v:Nat | v < (size x)} -> a+      index :: forall a. x:s a -> {v:Nat | v < size x} -> a   @-} class (Sized s) => Indexable s where   index :: s a -> Int -> a  -instance Indexable List where+instance Indexable MList where   index = (!!)  {-@ sum :: Indexable s => s Int -> Int @-}@@ -64,9 +73,9 @@       | otherwise = 0  -{-@ sumList :: List Int -> Int @-}-sumList :: List Int -> Int-sumList xs = go max 0+{-@ sumMList :: MList Int -> Int @-}+sumMList :: MList Int -> Int+sumMList xs = go max 0   where     max = size xs     go (d::Int) i@@ -74,8 +83,8 @@       | otherwise = 0  -{-@ x :: {v:List Int | (size v) = 3}  @-}-x :: List Int+{-@ x :: {v:MList Int | (size v) = 3}  @-}+x :: MList Int x = 1 `Cons` (2 `Cons` (3 `Cons` Nil))  foo = liquidAssert $ size (Cons 1 Nil) == size [1]
+ tests/pos/CountMonad.hs view
@@ -0,0 +1,70 @@+module Count () where++{-@ measure count :: Count a -> Int @-}++data Count a = Count a ++instance Functor Count where+	fmap = undefined +instance Applicative Count where+  pure  = undefined+  (<*>) = undefined	++instance Monad Count where+{-@+instance Monad Count where +  >>=    :: forall <r :: Count a -> Prop, p :: Count b -> Prop, q :: Count b -> Prop>.+            {x::Count a <<r>>, y :: Count b <<p>>  |- {v:Count b | count v == count x + count y} <: Count b <<q>>} +            Count a <<r>> -> (a -> Count b<<p>>) -> Count b <<q>> ; +  >>     :: x:Count a -> y:Count b -> {v:Count b | count v == count x + count y}; +  return :: a -> {v:Count a | count v == 0 } +@-}+  return x        = let r = Count x in assertCount 0 (Count x)  +  (Count x) >>= f = let r = f x in assertCount (getCount (Count x) + getCount r) r +  x >> y = assertCount (getCount x + getCount y) y+  fail          = error++++{-@ assume assertCount :: i:Int -> x:Count a -> {v:Count a | v == x && count v == i } @-}+assertCount :: Int -> Count a -> Count a +assertCount _ x = x ++{-@ assume getCount :: x:Count a -> {v:Int | v == count x } @-} +getCount :: Count a -> Int +getCount _ = 0 +++{-@ assume incr :: a -> {v:Count a | count v == 1 } @-}+incr :: a -> Count a +incr = Count ++{-@ assume unit :: {v:Count () | count v == 0 } @-}+unit = Count ()++{-@ foo :: a -> {v:Count a | count v == 0 }  @-}+foo :: a -> Count a +foo y = return y  ++{-@ test1 :: {v:Count () | count v == 0 } @-}+test1 :: Count ()+test1 = do +  unit+  unit+  unit++{-@ test2 :: {v:Count () | count v == 1 } @-}+test2 = do +  unit+  y <- incr ()+  unit+  foo y  +  unit++{-@ test3 :: {v:Count () | count v == 2 } @-}+test3 = do +  unit+  unit+  incr ()+  incr ()+  unit
+ tests/pos/DB00.hs view
@@ -0,0 +1,21 @@++{-@ LIQUID "--no-termination" @-}+{-@ LIQUID "totality" @-}++module DataBase (values) where++{-@ values :: forall <rr2 :: key -> val -> Prop>.+  k:key -> [Dict <rr2> key val]  -> [val<rr2 k>] @-}+values :: key -> [Dict key val]  -> [val]+values k = map (go k)+  where+    {-@ go :: forall <rr1 :: k -> v -> Prop>. +              i:k -> Dict <rr1> k v -> v<rr1 i>  @-}+    go k (D _ f) = f k++data Dict key val = D {ddom :: [key], dfun :: key -> val}++{-@ data Dict key val <rr :: key -> val -> Prop>+  = D ( ddom :: [key])+      ( dfun :: i:key -> val<rr i>)+  @-}
tests/pos/Even.hs view
@@ -1,9 +1,7 @@-module Even () where+module Even where  -{-@ isEven, isOdd :: Nat -> Bool @-}-isEven :: Int -> Bool-isEven 0 = True-isEven n = isOdd  $ n - 1+{-@ type Even = {v:Int | v mod 2 = 0} @-} -isOdd  0 = False-isOdd  m = isEven $ m - 1+{-@ notEven :: Int -> Even @-}+notEven :: Int -> Int+notEven x = x * 2
+ tests/pos/GADTs.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}++module Blank where++data Some :: * -> * where+  SomeBool  :: Bool -> Some Int+  SomeInt   :: Int  -> Some Int++{-@ measure isBool @-}+isBool :: Some Int -> Bool+isBool (SomeBool  _) = True+isBool (SomeInt   _) = False++{-@ type SomeBool = { v: Some Int | isBool v } @-}++{-@ a :: SomeBool @-}+a = SomeBool True++{-@ b :: SomeBool @-}+b = SomeBool True
tests/pos/GhcSort1.hs view
@@ -25,12 +25,12 @@       | a `compare` b /= GT = ascending b (\ys -> as (a:ys)) bs 1     ascending a as bs _     = as [a]: sequences bs 0 -    mergeAll []  = [] --this case cannot occur, though  +    mergeAll []  = [] --this case cannot occur, though     mergeAll [x] = x     mergeAll xs  = mergeAll (mergePairs xs) -{-@ mergePairs :: Ord a -               => xss:[(OList a)] +{-@ mergePairs :: Ord a+               => xss:[(OList a)]                -> {v:[(OList a)] | (if ((len xss) > 1) then ((len v) < (len xss)) else ((len v) = (len xss) ))}   @-} mergePairs :: Ord a => [[a]] -> [[a]]@@ -41,11 +41,11 @@ -- merge1 needs to be toplevel, -- to get applied transformRec tx -{-@ merge1 :: Ord a -           => xs:(OList a) -           -> ys:(OList a)-           -> {v:(OList a) | (len v) = ((len xs) + (len ys))} -           / [(len xs) + (len ys)] +{-@ merge1 :: Ord a+           => xs:OList a+           -> ys:OList a+           -> {v:OList a | len v == len xs + len ys}+           / [len xs + len ys]   @-} merge1 :: Ord a => [a] -> [a] -> [a] merge1 (a:as') (b:bs')@@ -53,5 +53,3 @@   | otherwise           = a:merge1 as' (b:bs') merge1 [] bs            = bs merge1 as []            = as--
+ tests/pos/GoodHMeas.hs view
@@ -0,0 +1,10 @@+{-@ measure foo @-}+bar, foo :: [(Int,Int)] -> Int+foo [] = 0+foo (a:as) = fst a + foo as++{-@ fst :: xs:(a, b) -> {v:a | v == fst xs} @-}+++{-@ bar :: xs:[(Int, Int)] -> {v:Int | v == foo xs } @-}+bar x = foo x
+ tests/pos/Gradual.hs view
@@ -0,0 +1,13 @@+module Gradual where++{-@ safe :: {v:Int | ?? } -> (Int, Int) @-}+safe :: Int -> (Int, Int)+safe x = (bar1 x, bar2 x)++{-@ bar1 :: {v:Int | v < 0} -> Int @-}+bar1 :: Int -> Int +bar1 x = x ++{-@ bar2 :: {v:Int | v = 0} -> Int @-}+bar2 :: Int -> Int +bar2 x = x
+ tests/pos/LambdaDeBruijn.hs view
@@ -0,0 +1,87 @@+module LambdaDeBruijn where++{- Proving Termination of Parallel Substitutions,+   see  § 3.2.2 of Dependent Types and Multi Monadic Effects in F*+ -}++import Language.Haskell.Liquid.Prelude++{-@ LIQUID "--totality" @-}++type Var = Int+{-@ type EVar = {v:Expr| isEVar v} @-}++type Subst = [(Var,Expr)]+{-@ type RenamingSubst = {su: [(Var,Expr)] | isRenaming su} @-}+++{- TODO: in the F* paper, substitutions are functions,+   can we have function representation with LH?             -}+++data Typ++data Expr = EVar Var+          | ELam Typ Expr+          | EUnit+          | EApp Expr Expr+{-@ data Expr [elen] @-}+++{-@ type MEVar E SU = {v:Expr | (isEVar E && isRenaming SU) => (isEVar v) } @-}+++{-@ sub :: su:Subst -> v:Var -> {v:Expr | (isRenaming su) => (isEVar v) } @-}+sub [] v                       = EVar v+sub ((vx, x):su) v | v == vx   = x+                   | otherwise = sub su v+++{-@ subst :: e:Expr -> su:Subst -> MEVar e su+  / [if (isEVar e) then 0 else 1, if (isRenaming su) then 0 else 1, elen e] @-}++subst EUnit        su = EUnit+subst (EVar v)     su = sub su v+subst (EApp e1 e2) su = EApp (subst e1 su) (subst e2 su)++subst (ELam t e)   su | isRenaming su =+  let su' =  toRem $ (0, EVar 0): map (\i -> (i, subst (sub su (i-1)) $ incrsubst ())) [1..]+  in ELam t $ subst e su'++subst (ELam t e)   su = -- | not $ isRenaming su+    let su' =  (0, EVar 0): map (\i -> (i, subst (sub su (i-1)) $ incrsubst ())) [1..]+    in ELam t $ subst e su'++++{-- Helper functions and measure definitions --}++{-@ toRem :: [(Var, EVar)] -> RenamingSubst @-}+toRem :: Subst -> Subst+toRem [] = []+toRem ((x, y):sus) = (x, y):toRem sus++{-@ incrsubst :: () -> RenamingSubst @-}+incrsubst :: () -> Subst+incrsubst _ = toRem $  map (\i -> (i, EVar $ i+1)) [0..]++{-@ measure isEVar @-}+isEVar :: Expr -> Bool+isEVar (EVar _) = True+isEVar _        = False++{-@ measure isRenaming @-}+isRenaming :: Subst -> Bool+isRenaming (vx:sus) = isEVar (mysnd vx) && isRenaming sus+isRenaming [] = True++{-@ measure mysnd @-}+mysnd (_,y) = y++{-@ invariant {v:Expr | elen v >= 0 } @-}+{-@ measure elen @-}+elen :: Expr -> Int+elen EUnit    = 0+elen (EVar v) = 0+elen (ELam _ e) = 1 + elen e+elen (EApp e1 e2) = 1 + elen e1 + elen e2
tests/pos/LambdaEval.hs view
@@ -46,15 +46,16 @@     elen(Snd e)      = 1 + (elen e) @-} + {-@ invariant {v:Expr | (elen v) >= 0} @-}  {-@ measure isValue      :: Expr -> Prop-isValue (Const i)    = true -isValue (Lam x e)    = true +isValue (Const i)    = true+isValue (Lam x e)    = true isValue (Var x)      = false isValue (App e1 e2)  = false-isValue (Plus e1 e2) = false +isValue (Plus e1 e2) = false isValue (Fst e)      = false isValue (Snd e)      = false isValue (Pair e1 e2) = (isValue e1) && (isValue e2)
tests/pos/ListQSort-LType.hs view
@@ -2,9 +2,9 @@  import Language.Haskell.Liquid.Prelude -{-@  -data List [llen] a <p :: x0:a -> x1:a -> Prop>  -  = Nil +{-@+data List [llen] a <p :: x0:a -> x1:a -> Prop>+  = Nil   | Cons (h :: a) (t :: List <p> (a <p h>)) @-} @@ -15,20 +15,21 @@  {-@ invariant {v:List a | (llen v) >= 0} @-} -{-@ qualif ZLLen(v:List a) : (llen(v) >= 0)@-}-{-@ qualif CmpLLen(v:List a, A:List b) : ((llen v) <= (llen A))@-}+{-@ qualif ZLLen(v:ListRange.List a) : (llen(v) >= 0)@-} +{-@ qualif CmpLLen(v:ListRange.List a, a:ListRange.List b) : (llen v <= llen a) @-}+ data List a = Nil | Cons a (List a)  append k Nil         ys = Cons k ys-append k (Cons x xs) ys = Cons x (append k xs ys) +append k (Cons x xs) ys = Cons x (append k xs ys)  takeL x Nil         = Nil takeL x (Cons y ys) = if (y<x) then Cons y (takeL x ys) else takeL x ys -{-@ takeGE :: Ord a -           => x:a -           -> xs:List a +{-@ takeGE :: Ord a+           => x:a+           -> xs:List a            -> {v: (List {v:a | v >= x}) | ((llen v) <= (llen xs))}  @-} takeGE x Nil         = Nil takeGE x (Cons y ys) = if (y>=x) then Cons y (takeGE x ys) else takeGE x ys@@ -38,13 +39,13 @@   where xsle = quicksort (takeL x xs)         xsge = quicksort (takeGE x xs) -chk y = -  case y of +chk y =+  case y of    Nil -> True-   Cons x1 xs -> case xs of +   Cons x1 xs -> case xs of                  Nil -> True                  Cons x2 xs2 -> liquidAssertB (x1 <= x2) && chk xs-																	+ bar = quicksort $ mkList [1 .. 100]  mkList :: Ord a => [a] -> List a
+ tests/pos/Merge1.hs view
@@ -0,0 +1,14 @@+module Merge1 where++{-@ merge1 :: Ord a+           => xs:[a]+           -> ys:[a]+           -> {v:[a] | len v == len xs + len ys}+           / [len xs + len ys]+  @-}+merge1 :: Ord a => [a] -> [a] -> [a]+merge1 (a:as') (b:bs')+  | a `compare` b == GT = b:merge1 (a:as')  bs'+  | otherwise           = a:merge1 as' (b:bs')+merge1 [] bs            = bs+merge1 as []            = as
tests/pos/OrdList.hs view
@@ -1,5 +1,5 @@ module OrdList (-    OrdList, +    OrdList,         nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, concatOL',         mapOL, fromOL, toOL, foldrOL, foldlOL ) where@@ -87,11 +87,12 @@ a     `appOL` One b = Snoc a b a     `appOL` b     = Two a b -{-@ qualif Go(v:List a, xs:OrdList a, ys:List a): (len v) = (olen xs) + (len ys) @-}+{-@ qualif Go(v:[a], xs:OrdList a, ys:[a]): (len v) = (olen xs) + (len ys) @-}  {-@ fromOL :: xs:OrdList a -> {v:[a] | (len v) = (olen xs)} @-} fromOL a = go a []   where+    {- go :: xs:_ -> acc:_ -> {v:[a] | len v = olen xs + len acc } -}     go None       acc = acc     go (One a)    acc = a : acc     go (Cons a b) acc = a : go b acc@@ -126,6 +127,6 @@ foldlOL k z (Two b1 b2) = foldlOL k (foldlOL k z b1) b2 foldlOL k z (Many xs)   = foldl k z xs -{-@ toOL :: xs:[a] -> OrdListN a {(len xs)} @-}+{-@ toOL :: xs:[a] -> OrdListN a {len xs} @-} toOL [] = None toOL xs = Many xs
tests/pos/PairMeasure0.hs view
@@ -1,5 +1,20 @@ module Foo () where -{-@ foo :: p:(a, b) -> {v:a | (v = (fst p))} @-}-foo (x, y) = x+{-@ measure getfst :: (a, b) -> a+    getfst (x, y) = x+  @-}++{-@ type Pair a b   = {v0 : ({v:a | v = (getfst v0)}, b) | true } @-}+{-@ type OPList a b = [(Pair a b)]<\h -> {v: (Pair a b) | (getfst v) >= (getfst h)}> @-}+{-@ type OList a    = [a]<\h -> {v: a | (v >= h)}> @-}+++-- This is Unsafe, as refinements in Predicate parameters (i.e., Pair a b)+-- are lost, so application `getFsts` cannot be proven safe+{-@ getFsts          :: OPList a b -> OList a @-}+getFsts :: [(a, b)] -> [a]+getFsts []           = [] +getFsts ((x,_) : xs) = x : getFsts xs++
tests/pos/Product.hs view
@@ -1,4 +1,3 @@-{-@ LIQUID "--real"     @-} {-@ LIQUID "--total" @-}
tests/pos/Propability.hs view
@@ -1,7 +1,5 @@ module Propability where -{-@ LIQUID "--real" @-}- {-@ type Propability = {v:Double | ((0.0 <= v) && (v <= 1.0)) } @-}  {-@ p :: Propability @-}
tests/pos/RBTree-col-height.hs view
@@ -196,8 +196,8 @@  {-@ predicate Invs V = ((Inv1 V) && (Inv2 V) && (Inv3 V))   @-} {-@ predicate Inv1 V = (((isARB V) && (IsB V)) => (isRB V)) @-}-{-@ predicate Inv2 V = ((isRB v) => (isARB v))              @-}-{-@ predicate Inv3 V = 0 <= (bh v)                          @-}+{-@ predicate Inv2 V = ((isRB V) => (isARB V))              @-}+{-@ predicate Inv3 V = 0 <= (bh V)                          @-}  {-@ invariant {v: Color | (v = R || v = B)}                 @-}
tests/pos/RBTree-color.hs view
@@ -178,7 +178,7 @@  {-@ predicate Invs V = ((Inv1 V) && (Inv2 V))               @-} {-@ predicate Inv1 V = (((isARB V) && (IsB V)) => (isRB V)) @-}-{-@ predicate Inv2 V = ((isRB v) => (isARB v))              @-}+{-@ predicate Inv2 V = ((isRB V) => (isARB V))              @-}  {-@ invariant {v: Color | (v = R || v = B)}                 @-}
tests/pos/RBTree-height.hs view
@@ -167,7 +167,7 @@  {-@ invariant {v: RBTree a | (Invs v)}        @-} {-@ predicate Invs V = (Inv3 V)               @-}-{-@ predicate Inv3 V = 0 <= (bh v)            @-}+{-@ predicate Inv3 V = 0 <= (bh V)            @-}  {-@ invariant {v: Color | (v = R || v = B)}   @-}
tests/pos/RBTree.hs view
@@ -199,8 +199,8 @@  {-@ predicate Invs V = Inv1 V && Inv2 V && Inv3 V   @-} {-@ predicate Inv1 V = (isARB V && IsB V) => isRB V @-}-{-@ predicate Inv2 V = isRB v => isARB v            @-}-{-@ predicate Inv3 V = 0 <= bh v                    @-}+{-@ predicate Inv2 V = isRB V => isARB V            @-}+{-@ predicate Inv3 V = 0 <= bh V                    @-} {-@ invariant {v: Color | v = R || v = B}           @-} {-@ invariant {v: RBTree a | Invs v}                @-}
tests/pos/RealProps.hs view
@@ -1,7 +1,6 @@-module Div where--{-@ LIQUID "--real" @-}+-- Issue overload-div-int-real #579 +module Div where  {-@ type Valid = {v:Bool | ( (Prop v) <=> true ) } @-}
tests/pos/RealProps1.hs view
@@ -1,7 +1,7 @@-module Div where -{-@ LIQUID "--real" @-}+-- Issue overload-div-int-real #579 +module Div where  {-@ type Valid = {v:Bool | ( (Prop v) <=> true ) } @-}
tests/pos/ResolvePred.hs view
@@ -1,4 +1,4 @@-module ResolvePred () where+module ResolvePred (myFold) where  {-@ data L [llen] = C (h :: Int) (t :: L) | N @-} {-@ invariant {v:L | (llen v) >= 0} @-}
+ tests/pos/StructRec.hs view
@@ -0,0 +1,18 @@+module ListLen () where++{-@ autosize OList @-}++data OList a =+     Mt+   | Ln{h :: a, t :: OList a}++{-@ data OList a =+      Mt+    | Ln{h :: a, t :: OList {v:a | h <= v}} @-}++insert :: (Ord a) => a -> OList a -> OList a+insert y Mt        = Ln y Mt+insert y (Ln x xs)+  | y <= x         = Ln y (Ln x xs)+  | otherwise      = Ln x (insert y xs)+
+ tests/pos/T531.hs view
@@ -0,0 +1,6 @@+module T531 where++{-@+data Foo = Foo { _getFoo :: Int }+@-}+data Foo = Foo { _getFoo :: Int }
+ tests/pos/T595.hs view
@@ -0,0 +1,29 @@+module Issue595 where++import Data.Vector++data Test = Test+    { vec  :: Thing+    , x0   :: Bool+    }++type Thing = [()] -- Vector ()++{-@+data Test = Test+    { vec  :: Thing+    , x0   :: { x0 : Bool | len vec < 1 ==> Prop x0 }+    }+@-}++-- The above data declaration should give us the following refined types+-- for the record selectors++{- vec :: x:Test -> {v:Thing | v = vec x} -}+{- x0  :: x:Test -> {v:Bool  | v = x0 x  && ((len (vec x) < 1) => Prop v) } -}++example :: Test -> ()+example t =+    if x0 t+    then ()+    else vec t !! 0
+ tests/pos/T595a.hs view
@@ -0,0 +1,12 @@+{-@ LIQUID "--totality" @-}++module T595a where++data Tree a = Nil | Tree { key :: a, l::Tree a, r :: Tree a}++{-@ data Tree a = Nil+                | Tree { key :: a+                       , l   :: Tree {v:a | v < key }+                       , r   :: Tree {v:a | key < v }+                       }+  @-}
+ tests/pos/T598.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE DeriveGeneric #-}++import GHC.Generics (Generic)+import Control.DeepSeq (NFData(..))++data Point = Point+    { x :: Int+    } deriving (Generic)++instance NFData Point
+ tests/pos/Words.hs view
@@ -0,0 +1,5 @@+import Data.Word++{-@ foo :: {v:Word | v = 4} @-}+foo :: Word+foo = 4
+ tests/pos/Words1.hs view
@@ -0,0 +1,3 @@+import Data.Word++main = print (quotRem (4 :: Word8) 128)
+ tests/pos/anish1.hs view
@@ -0,0 +1,13 @@+module Test1 () where++inc :: Int -> Int+inc xoooo = xoooo + 1++test1 :: Int -> Int+test1 nine = let b = 0 <= nine in+          if b then+            let a = inc nine+            in+               div nine a+          else+            1
+ tests/pos/csgordon_issue_296.hs view
@@ -0,0 +1,6 @@+module BadMeasureType where ++{-@ measure fwd_extends :: IO () -> IO () -> Prop @-}+{-@ assume fwd_extends_refl :: m:IO () -> {v:Bool | (fwd_extends m m)} @-}+fwd_extends_refl :: IO () -> Bool+fwd_extends_refl = undefined
+ tests/pos/dropwhile.hs view
@@ -0,0 +1,84 @@+{-@ LIQUID "--no-termination" @-}++module DropWhile where++import Language.Haskell.Liquid.Prelude+import Prelude hiding (head, dropWhile, (.), filter)++main :: IO ()+main =+  if head (dropWhile ((/=) 3) (1:::2:::3:::Emp)) == 3+    then return ()+    else liquidError "Not going to happen"++-------------------------------------------------------------------------------+-- | The `head` function returns a value that satisfies the abstract refinement+-------------------------------------------------------------------------------++{-@ head ::  forall <p :: a -> Prop>. List <p> a -> a<p> @-}+head (x ::: _) = x++-------------------------------------------------------------------------------+-- | A List +-------------------------------------------------------------------------------++data List a = Emp | (:::) { hd :: a+                          , tl :: List a }+infixr 5 :::++-------------------------------------------------------------------------------+-- | A list whose head satisfies an abstract refinement `p`+-------------------------------------------------------------------------------++-- in the below, `hd :: a<p>` means the "head" is a value of type `a` that+-- additionally, satisfies `p hd`.++{-@ data List a <p :: a -> Prop> = Emp+                                 | (:::) { hd :: a<p>+                                         , tl :: List a }+  @-}++-- | e.g. a list whose head equals `3`++{-@ type OneList = List <{\v -> v == 3}> Int @-}++{-@ one :: OneList @-}+one :: List Int+one = 3 ::: 2 ::: 1 ::: Emp++-------------------------------------------------------------------------------+-- | dropWhile some predicate `f` is not satisfied+-------------------------------------------------------------------------------++{-@ dropWhile :: forall <p :: a -> Prop, w :: a -> Bool -> Prop>.+                   (Witness a p w) =>+                   (x:a -> Bool<w x>) -> List a -> List <p> a+  @-}+dropWhile :: (a -> Bool) -> List a -> List a+dropWhile f (x:::xs)+  | not (f x)    = x ::: xs+  | otherwise    = dropWhile f xs+dropWhile f Emp  = Emp++-- | This `witness` bound relates the predicate used in dropWhile++{-@ bound witness @-}+witness :: Eq a => (a -> Bool) -> (a -> Bool -> Bool) -> a -> Bool -> a -> Bool+witness p w = \ y b v -> (not b) ==> w y b ==> (v == y) ==> p v++{-@ measure tail :: forall a. { es : [a] | len es >= 1 } -> [a] @-}+tail :: [a] -> [a]+tail = undefined+-------------------------------------------------------------------------------+-- | Drop elements until you hit a `3`+-------------------------------------------------------------------------------++{-@ dropUntilOne' :: List Int -> OneList @-}+dropUntilOne' :: List Int -> List Int+dropUntilOne' = dropWhile (/= 3)++-- | Currently needed for the qual; should be made redundant by `--eliminate`++{-@ eqOne :: x:Int -> {v:Bool | Prop v <=> x /= 3} @-}+eqOne :: Int -> Bool+eqOne x = x /= 3
tests/pos/gadtEval.hs view
@@ -59,13 +59,13 @@ toBool _     = liquidError "impossible"  -{-@ predicate TInt X   = ((eType X) = TInt)  @-}-{-@ predicate TBool X  = ((eType X) = TBool) @-}+{-@ predicate IsTInt X   = ((eType X) = TInt)  @-}+{-@ predicate IsTBool X  = ((eType X) = TBool) @-}   {-@ type ValidExpr     = {v: Expr | (isValid v)}                @-}-{-@ type IntExpr       = {v: Expr | ((isValue v) && (TInt  v))} @-}-{-@ type BoolExpr      = {v: Expr | ((isValue v) && (TBool v))} @-}+{-@ type IntExpr       = {v: Expr | ((isValue v) && (IsTInt  v))} @-}+{-@ type BoolExpr      = {v: Expr | ((isValue v) && (IsTBool v))} @-}   {-@ measure isValue       :: Expr -> Prop@@ -86,6 +86,6 @@     isValid (I i)         = true     isValid (B b)         = true     isValid (Equal e1 e2) = (((eType e1) = (eType e2)) && (isValid e1) && (isValid e2))-    isValid (Plus e1 e2)  = ((TInt e1) && (TInt e2) && (isValid e1) && (isValid e2))+    isValid (Plus e1 e2)  = ((IsTInt e1) && (IsTInt e2) && (isValid e1) && (isValid e2))   @-}
tests/pos/gimme.hs view
@@ -1,7 +1,8 @@ module Blank () where -{-@ qualif Gimme(v:a, n:b, acc:a): len v = n + 1 + len acc @-}+{- qualif Gimme(v:[a], n:int, acc:[a]): (len v == n + 1 + len acc) -} +{-@ gimme :: xs:[a] -> n:Int -> acc:[a] -> {v:[a] | len v = n + 1 + len acc} @-} gimme :: [a] -> Int -> [a] -> [a] gimme xs (-1) acc  = acc gimme (x:xs) n acc = gimme xs (n-1) (x : acc)
+ tests/pos/hole-fun.hs view
@@ -0,0 +1,10 @@+module Zoo (test) where++inc :: Int -> Int +inc x = x + 1++{-@ app :: _ -> Nat -> Nat @-} +app :: (Int -> Int) -> Int -> Int+app f x = f x++test = app inc 7
+ tests/pos/idNat.hs view
@@ -0,0 +1,5 @@+module IdNat where ++{-@ nat :: Nat @-}+nat :: Int+nat = id 0 -- (id (id (id (id 0))))
+ tests/pos/idNat0.hs view
@@ -0,0 +1,8 @@+module IdNat where ++{-@ nat :: Nat @-}+nat :: Int+nat = idd 0 ++idd :: a -> a+idd = undefined
+ tests/pos/listqual.hs view
@@ -0,0 +1,10 @@+module ListQual (boo) where++{-@ qualif BadAppend(v:[a], xs:[a], ys:[a]): len v = len xs + len ys @-}++append [] ys     = ys+append (x:xs) ys = x : append xs ys++{-@ boo :: {v:[Int] | len v = 2} @-}+boo :: [Int]+boo = append [1] [2]
+ tests/pos/nats.hs view
@@ -0,0 +1,5 @@+module Nats where ++{-@ nats :: [Nat] @-}+nats :: [Int]+nats = [1,2,3,4,5,6,7,8,9,10]
tests/pos/pair00.hs view
@@ -1,19 +1,28 @@-module Pair () where +module Pair () where  {-@ LIQUID "--no-termination" @-}-import Language.Haskell.Liquid.Prelude +import Language.Haskell.Liquid.Prelude -incr x = (x, [x+1])-chk (x, [y]) = liquidAssertB (x <y) +incr z = (x, [x + 1])+  where+    x  = choose z++incr z = (x, [x + 1])+  where+    x  = choose z++chk (x, [y]) = liquidAssertB (x < y)+ prop  = chk $ incr n-  where n = choose 0+  where+    n = choose 0  incr2 x = (True, 9, x, 'o', x+1)-chk2 (_, _, x, _,  y) = liquidAssertB (x <y) +chk2 (_, _, x, _,  y) = liquidAssertB (x <y) prop2  = chk2 $ incr2 n   where n = choose 0  incr3 x = (x, ( (0, x+1)))-chk3 (x, ((_, y))) = liquidAssertB (x <y) +chk3 (x, ((_, y))) = liquidAssertB (x <y) prop3  = chk3 (incr3 n)   where n = choose 0
+ tests/pos/recursion0.hs view
@@ -0,0 +1,7 @@+module Main where++{-@ total :: Nat -> Nat @-}+total :: Int -> Int +total 0 = 0+total n = 1 + total (n-1)+
+ tests/pos/repeatHigherOrder.hs view
@@ -0,0 +1,24 @@+{-@ LIQUID "--no-termination" @-}++module Repeat where++import Prelude hiding (repeat, succ)+import Language.Haskell.Liquid.Prelude++repeat :: Int -> (a -> a) -> a -> a+goal   :: Int -> Int+     +{-@ bound step @-}+step :: (a -> a -> Bool) -> (Int -> a -> Bool) -> Int -> a -> a -> Bool+step pf pr = \ i x x' -> pr (i - 1) x ==> pf x x' ==> pr i x'++{-@ repeat :: forall a <f :: a -> a -> Prop, r :: Int -> a -> Prop>.+                (Step a f r) =>+                 n:Nat -> (y:a -> a<f y>) -> a<r 0> -> a<r n>+  @-}+repeat 0 _ x = x+repeat n f x = repeat (n - 1) f (f x)++{-@ goal :: n:Nat -> {r:Nat | n <= r} @-}+goal n = repeat n (+ 1) 0+
tests/pos/scanr.hs view
@@ -1,7 +1,7 @@ module Goo () where -{-@ assert scanrr  :: forall a b. (a -> b -> b) -> b -> xs:[a] -> {v: [b] | len(v) = 1 + len(xs) } @-}-scanrr             :: (a -> b -> b) -> b -> [a] -> [b]+{-@ scanrr  :: (a -> b -> b) -> b -> xs:[a] -> {v: [b] | len v = 1 + len xs } @-}+-- scanrr             :: (a -> b -> b) -> b -> [a] -> [b] scanrr _ q0 []     =  [q0] scanrr f q0 (x:xs) =  f x q : qs                       where qs@(q:_) = scanrr f q0 xs
tests/pos/test00-int.hs view
@@ -2,10 +2,6 @@  import Language.Haskell.Liquid.Prelude -{-@ qualif Zog(v:FooBar, x:FooBar): v = x + 29 @-}--data FooBar = Foo Int- x :: Int x = choose 0
tests/pos/test00.hs view
@@ -2,10 +2,6 @@  import Language.Haskell.Liquid.Prelude -{-@ qualif Zog(v:FooBar, x:FooBar): v = x + 29 @-}--data FooBar = Foo Int- x = choose 0  prop_abs ::  Bool
tests/pos/testRec.hs view
@@ -1,35 +1,30 @@ module TestRec where -import Prelude hiding (map, foldl)+import Prelude hiding (foldl) -data L a = N | C a (L a)-{-@ -data L [llen] a = N | C (x::a) (xs::(L a))-  @-}+data L a = N | C { hd :: a+                 , tl :: L a } -{-@ measure llen :: (L a) -> Int-    llen(N) = 0-    llen(C x xs) = 1 + (llen xs)+{-@ data L [llen] a = N | C { hd :: a+                            , tl :: L a }   @-}  -{-@map :: (a -> b) -> [a] -> [b]@-}-map f []     = []-map f (x:xs) = f x : map f xs- -bar = map id [1, 2]+{-@ invariant {v:L a | 0 <= llen v} @-} -{-@ Decrease go 2 @-}-rev xs = go [] xs-  where go ack  []    = ack-        go ack (x:xs) = go (x:ack) xs+{-@ measure llen @-}+llen :: L a -> Int+llen N        = 0+llen (C x xs) = 1 + llen xs -{-@ invariant {v:(L a) | ((llen v) >= 0)}@-}+reverse :: L a -> L a+reverse xs = go N xs+  where +    {-@ go :: acc:_ -> xs:_ -> _ / [llen xs] @-}+    go acc N        = acc+    go acc (C x xs) = go (C x acc) xs  mapL f N = N mapL f (C x xs) = C (f x) (mapL f xs) --foldl f z [] = z-foldl f z (x:xs) = x `f` foldl f z xs
tests/pos/zipper0.hs view
@@ -11,7 +11,7 @@ {-@ type UListDif a N = {v:[a] | ((not (Set_mem N (listElts v))) && (Set_emp (listDup v)))} @-}  {-@-data Stack a = Stack { focus :: a   +data Stack a = Stack { focus :: a                      , up    :: UListDif a focus                      , down  :: UListDif a focus } @-}@@ -24,15 +24,15 @@  {-@ type UStack a = {v:Stack a |(Set_emp (Set_cap (listElts (getUp v)) (listElts (getDown v))))}@-} -{-@ measure getFocus :: forall a. (Stack a) -> a +{-@ measure getFocus :: forall a. (Stack a) -> a     getFocus (Stack focus up down) = focus   @-} -{-@ measure getUp :: forall a. (Stack a) -> [a] +{-@ measure getUp :: forall a. (Stack a) -> [a]     getUp (Stack focus up down) = up   @-} -{-@ measure getDown :: forall a. (Stack a) -> [a] +{-@ measure getDown :: forall a. (Stack a) -> [a]     getDown (Stack focus up down) = down   @-} @@ -50,12 +50,12 @@  {-@ focusUp :: UStack a -> UStack a @-} focusUp :: Stack a -> Stack a-focusUp (Stack t [] rs)     = Stack x xs [] where (x:xs) = reverse (t:rs)+focusUp (Stack t [] rs)     = Stack xiggety xs [] where (xiggety:xs) = reverse (t:rs) focusUp (Stack t (l:ls) rs) = Stack l ls (t:rs)  {-@ focusDown :: UStack a -> UStack a @-} focusDown :: Stack a -> Stack a-focusDown = reverseStack . focusUp . reverseStack +focusDown = reverseStack . focusUp . reverseStack  -- | reverse a stack: up becomes down and down becomes up. {-@ reverseStack :: UStack a -> UStack a @-}@@ -63,26 +63,7 @@ reverseStack (Stack t ls rs) = Stack t rs ls  - -- TODO ASSUMES {-@ reverse :: {v:[a] | (Set_emp (listDup v))} -> {v:[a]|(Set_emp (listDup v))} @-} reverse :: [a] -> [a] reverse = undefined------------------
+ tests/pos/zipper000.hs view
@@ -0,0 +1,68 @@+module Zipper () where++import Prelude hiding (reverse)++import Data.Set++data Stack a = Stack { focus  :: !a        -- focused thing in this set+                     , up     :: [a]       -- jokers to the left+                     , down   :: [a] }     -- jokers to the right++{-@ type UListDif a N = {v:[a] | ((not (Set_mem N (listElts v))) && (Set_emp (listDup v)))} @-}++{-@+data Stack a = Stack { focus :: a+                     , up    :: UListDif a focus+                     , down  :: UListDif a focus }+@-}++{-@+  measure listDup :: [a] -> (Set a)+  listDup([]) = {v | Set_emp v }+  listDup(x:xs) = {v | v = if (Set_mem x (listElts xs)) then (Set_cup (Set_sng x) (listDup xs)) else (listDup xs) }+  @-}++{-@ type UStack a = {v:Stack a |(Set_emp (Set_cap (listElts (getUp v)) (listElts (getDown v))))}@-}++{-@ measure getFocus :: forall a. (Stack a) -> a+    getFocus (Stack focus up down) = focus+  @-}++{-@ measure getUp :: forall a. (Stack a) -> [a]+    getUp (Stack focus up down) = up+  @-}++{-@ measure getDown :: forall a. (Stack a) -> [a]+    getDown (Stack focus up down) = down+  @-}++-- QUALIFIERS+{-@ q :: x:a ->  {v:[a] |(not (Set_mem x (listElts v)))} @-}+q :: a -> [a]+q = undefined+{-@ q1 :: x:a ->  {v:[a] |(Set_mem x (listElts v))} @-}+q1 :: a -> [a]+q1 = undefined+{-@ q0 :: x:a ->  {v:[a] |(Set_emp(listDup v))} @-}+q0 :: a -> [a]+q0 = undefined++{-@ focusUp :: UStack a -> UStack a @-}+focusUp :: Stack a -> Stack a+focusUp (Stack t [] rs)     = Stack xiggety xs [] where (xiggety:xs) = reverse (t:rs)+focusUp (Stack t (l:ls) rs) = Stack l ls (t:rs)++{-@ reverse :: {v:[a] | Set_emp (listDup v)} -> {v:[a]|Set_emp (listDup v)} @-}+reverse :: [a] -> [a]+reverse = undefined++{-@ focusDown :: UStack a -> UStack a @-}+focusDown :: Stack a -> Stack a+focusDown = undefined+-- focusDown = reverseStack . focusUp . reverseStack++-- | reverse a stack: up becomes down and down becomes up.+{-@ reverseStack :: UStack a -> UStack a @-}+reverseStack :: Stack a -> Stack a+reverseStack = undefined+-- reverseStack (Stack t ls rs) = Stack t rs ls
tests/test.hs view
@@ -10,7 +10,6 @@ import qualified Control.Monad.State as State import Control.Monad.Trans.Class (lift) import Data.Char-import Data.Foldable (foldMap) import qualified Data.Functor.Compose as Functor import qualified Data.IntMap as IntMap import Data.Maybe (fromMaybe)@@ -31,16 +30,21 @@ import Test.Tasty.Ingredients.Rerun import Test.Tasty.Options import Test.Tasty.Runners+import Test.Tasty.Runners.AntXML+ import Text.Printf  testRunner = rerunningTests                [ listingTests-               , combineReporters consoleTestReporter loggingTestReporter+               , combineReporters myConsoleReporter antXMLRunner+               , myConsoleReporter                ] +myConsoleReporter = combineReporters consoleTestReporter loggingTestReporter  main :: IO ()-main = run =<< tests+main = do unsetEnv "LIQUIDHASKELL_OPTS"+          run =<< tests   where     run   = defaultMainWithIngredients [                 testRunner@@ -48,8 +52,8 @@                                  , Option (Proxy :: Proxy LiquidOpts)                                  , Option (Proxy :: Proxy SmtSolver) ]               ]-     tests = group "Tests" [ unitTests, benchTests ]+    -- tests = group "Tests" [ selfTests ]  data SmtSolver = Z3 | CVC4 deriving (Show, Read, Eq, Ord, Typeable) instance IsOption SmtSolver where@@ -82,44 +86,52 @@     , testGroup "crash"       <$> dirTests "tests/crash"                          []           (ExitFailure 2)     , testGroup "parser/pos"  <$> dirTests "tests/parser/pos"                     []           ExitSuccess     , testGroup "error/crash" <$> dirTests "tests/error_messages/crash"           []           (ExitFailure 2)+    , testGroup "eq_pos"      <$> dirTests "tests/equationalproofs/pos"           ["Axiomatize.hs"]           ExitSuccess+    , testGroup "eq_neg"      <$> dirTests "tests/equationalproofs/neg"           ["Axiomatize.hs"]           (ExitFailure 1)    ]  benchTests   = group "Benchmarks" [-      testGroup "text"        <$> dirTests "benchmarks/text-0.11.2.3"             textIgnored  ExitSuccess-    , testGroup "bytestring"  <$> dirTests "benchmarks/bytestring-0.9.2.1"        []           ExitSuccess-    , testGroup "esop"        <$> dirTests "benchmarks/esop2013-submission"       ["Base0.hs"] ExitSuccess-    , testGroup "vect-algs"   <$> dirTests "benchmarks/vector-algorithms-0.5.4.2" []           ExitSuccess-    , testGroup "hscolour"    <$> dirTests "benchmarks/hscolour-1.20.0.0"         []           ExitSuccess-    , testGroup "icfp_pos"    <$> dirTests "benchmarks/icfp15/pos"                []           ExitSuccess-    , testGroup "icfp_neg"    <$> dirTests "benchmarks/icfp15/neg"                ["RIO.hs", "DataBase.hs"]           (ExitFailure 1)+      testGroup "text"        <$> dirTests "benchmarks/text-0.11.2.3"             textIgnored               ExitSuccess+    , testGroup "bytestring"  <$> dirTests "benchmarks/bytestring-0.9.2.1"        []                        ExitSuccess+    , testGroup "esop"        <$> dirTests "benchmarks/esop2013-submission"       ["Base0.hs"]              ExitSuccess+    , testGroup "vect-algs"   <$> dirTests "benchmarks/vector-algorithms-0.5.4.2" []                        ExitSuccess+    , testGroup "hscolour"    <$> dirTests "benchmarks/hscolour-1.20.0.0"         ["HsColour.hs"]           ExitSuccess+    , testGroup "icfp_pos"    <$> dirTests "benchmarks/icfp15/pos"                ["RIO.hs", "DataBase.hs"] ExitSuccess+    , testGroup "icfp_neg"    <$> dirTests "benchmarks/icfp15/neg"                ["RIO.hs", "DataBase.hs"] (ExitFailure 1)     ] +selfTests+  = group "Self" [+      testGroup "liquid"      <$> dirTests "src"  [] ExitSuccess+  ]+ --------------------------------------------------------------------------- dirTests :: FilePath -> [FilePath] -> ExitCode -> IO [TestTree] --------------------------------------------------------------------------- dirTests root ignored code   = do files    <- walkDirectory root        let tests = [ rel | f <- files, isTest f, let rel = makeRelative root f, rel `notElem` ignored ]-       return    $ mkTest code root <$> tests --  hs f code | f <- hs]+       return    $ mkTest code root <$> tests  isTest   :: FilePath -> Bool-isTest f = takeExtension f == ".hs" -- `elem` [".hs", ".lhs"]+isTest f =  takeExtension f == ".hs"+         || takeExtension f == ".lhs"  --------------------------------------------------------------------------- mkTest :: ExitCode -> FilePath -> FilePath -> TestTree --------------------------------------------------------------------------- mkTest code dir file-  = askOption $ \(smt :: SmtSolver) -> askOption $ \(opts :: LiquidOpts) -> testCase file $ do+  = askOption $ \(smt :: SmtSolver) -> askOption $ \(opts :: LiquidOpts) -> testCase file $       if test `elem` knownToFail smt       then do         printf "%s is known to fail with %s: SKIPPING" test (show smt)         assertEqual "" True True       else do         createDirectoryIfMissing True $ takeDirectory log-        liquid <- binPath "liquid"+        bin <- binPath "liquid"         withFile log WriteMode $ \h -> do-          let cmd     = testCmd liquid dir file smt opts+          let cmd     = testCmd bin dir file smt opts           (_,_,_,ph) <- createProcess $ (shell cmd) {std_out = UseHandle h, std_err = UseHandle h}           c          <- waitForProcess ph           renameFile log $ log <.> (if code == c then "pass" else "fail")@@ -130,20 +142,30 @@     test = dir </> file     log = "tests/logs/cur" </> test <.> "log" -binPath pkgName = do +binPath pkgName = do   testPath <- getExecutablePath-  return    $ (takeDirectory $ takeDirectory testPath) </> pkgName </> pkgName - -knownToFail CVC4 = [ "tests/pos/linspace.hs", "tests/pos/RealProps.hs", "tests/pos/RealProps1.hs", "tests/pos/initarray.hs"-                   , "tests/pos/maps.hs", "tests/pos/maps1.hs", "tests/neg/maps.hs"-                   , "tests/pos/Product.hs" ]-knownToFail Z3   = [ "tests/pos/linspace.hs" ]+  return    $ (takeDirectory $ takeDirectory testPath) </> pkgName </> pkgName +knownToFail CVC4 = [ "tests/pos/linspace.hs"+                   , "tests/pos/RealProps.hs"+                   , "tests/pos/RealProps1.hs"+                   , "tests/pos/initarray.hs"+                   , "tests/pos/maps.hs"+                   , "tests/pos/maps1.hs"+                   , "tests/neg/maps.hs"+                   , "tests/pos/Product.hs"+                   , "tests/pos/Gradual.hs"+                   ]++knownToFail Z3   = [ "tests/pos/linspace.hs"+                   , "tests/pos/Gradual.hs"+                   ]+ --------------------------------------------------------------------------- testCmd :: FilePath -> FilePath -> FilePath -> SmtSolver -> LiquidOpts -> String ----------------------------------------------------------------------------testCmd liquid dir file smt (LO opts)-  = printf "cd %s && %s --verbose --smtsolver %s %s %s" dir liquid (show smt) file opts+testCmd bin dir file smt (LO opts)+  = printf "cd %s && %s --smtsolver %s %s %s" dir bin (show smt) file opts   textIgnored = [ "Data/Text/Axioms.hs"@@ -188,14 +210,41 @@  group n xs = testGroup n <$> sequence xs +gitTimestamp :: IO String+gitTimestamp = do+   res <- readProcess "git" ["show", "--format=\"%ci\"", "--quiet"] []+   return $ filter notNoise res++gitEpochTimestamp :: IO String+gitEpochTimestamp = do+   res <- readProcess "git" ["show", "--format=\"%ct\"", "--quiet"] []+   return $ filter notNoise res++gitHash :: IO String+gitHash = do+   res <- readProcess "git" ["show", "--format=\"%H\"", "--quiet"] []+   return $ filter notNoise res++gitRef :: IO String+gitRef = do+   res <- readProcess "git" ["show", "--format=\"%d\"", "--quiet"] []+   return $ filter notNoise res++notNoise :: Char -> Bool+notNoise a = a /= '\"' && a /= '\n' && a /= '\r'++headerDelim :: String+headerDelim = take 80 $ repeat '-'+ ---------------------------------------------------------------------------------------- walkDirectory :: FilePath -> IO [FilePath] ---------------------------------------------------------------------------------------- walkDirectory root-  = do (ds,fs) <- partitionM doesDirectoryExist . candidates =<< (getDirectoryContents root `catchIOError` const (return []))-       (fs++) <$> concatMapM walkDirectory ds-  where-    candidates fs = [root </> f | f <- fs, not (isExtSeparator (head f))]+  = do -- RJ: delete root </> ".liquid"+       (ds,fs) <- partitionM doesDirectoryExist . candidates =<< (getDirectoryContents root `catchIOError` const (return []))+       (fs ++) <$> concatMapM walkDirectory ds+    where+       candidates fs = [root </> f | f <- fs, not (isExtSeparator (head f))]  partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a],[a]) partitionM f = go [] []@@ -209,7 +258,7 @@ -- isDirectory = fmap Posix.isDirectory . Posix.getFileStatus  concatMapM :: Applicative m => (a -> m [b]) -> [a] -> m [b]-concatMapM f []     = pure []+concatMapM _ []     = pure [] concatMapM f (x:xs) = (++) <$> f x <*> concatMapM f xs  -- | Combine two @TestReporter@s into one.@@ -221,6 +270,7 @@       f1 <- run1 opts tree       f2 <- run2 opts tree       return $ \smap -> f1 smap >> f2 smap+combineReporters _ _ = error "combineReporters needs TestReporters"  type Summary = [(String, Double, Bool)] @@ -280,10 +330,21 @@     host <- takeWhile (/='.') . takeWhile (not . isSpace) <$> readProcess "hostname" [] []     -- don't use the `time` package, major api differences between ghc 708 and 710     time <- head . lines <$> readProcess "date" ["+%Y-%m-%dT%H-%M-%S"] []+    -- build header+    ref <- gitRef+    timestamp <- gitTimestamp+    epochTime <- gitEpochTimestamp+    hash <- gitHash+    let hdr = unlines [ref ++ " : " ++ hash,+                       "Timestamp: " ++ timestamp,+                       "Epoch Timestamp: " ++ epochTime,+                       headerDelim,+                       "test, time(s), result"]+     let dir = "tests" </> "logs" </> host ++ "-" ++ time-    let path = dir </> "summary.csv"-    system $ "cp -r tests/logs/cur " ++ dir-    writeFile path $ unlines-                   $ "test, time(s), result"+    let smry = "tests" </> "logs" </> "cur" </> "summary.csv"+    writeFile smry $ unlines+                   $ hdr                    : map (\(n, t, r) -> printf "%s, %0.4f, %s" n t (show r)) summary+    system $ "cp -r tests/logs/cur " ++ dir     (==0) <$> computeFailures smap