diff --git a/Liquid.hs b/Liquid.hs
deleted file mode 100644
--- a/Liquid.hs
+++ /dev/null
@@ -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
diff --git a/Setup.hs b/Setup.hs
--- a/Setup.hs
+++ b/Setup.hs
@@ -1,5 +1,6 @@
import Distribution.Simple
+
main = defaultMain
-- main = defaultMainWithHooks fixpointHooks
diff --git a/include/708/Control/Monad.spec b/include/708/Control/Monad.spec
deleted file mode 100644
--- a/include/708/Control/Monad.spec
+++ /dev/null
@@ -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)}
diff --git a/include/CoreToLogic.lg b/include/CoreToLogic.lg
--- a/include/CoreToLogic.lg
+++ b/include/CoreToLogic.lg
@@ -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)
diff --git a/include/Data/Set.spec b/include/Data/Set.spec
--- a/include/Data/Set.spec
+++ b/include/Data/Set.spec
@@ -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)}
diff --git a/include/Data/Vector.spec b/include/Data/Vector.spec
--- a/include/Data/Vector.spec
+++ b/include/Data/Vector.spec
@@ -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 }
diff --git a/include/GHC/Real.spec b/include/GHC/Real.spec
--- a/include/GHC/Real.spec
+++ b/include/GHC/Real.spec
@@ -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
diff --git a/include/GHC/Types.spec b/include/GHC/Types.spec
--- a/include/GHC/Types.spec
+++ b/include/GHC/Types.spec
@@ -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 }
diff --git a/include/Language/Haskell/Liquid/Foreign.hs b/include/Language/Haskell/Liquid/Foreign.hs
--- a/include/Language/Haskell/Liquid/Foreign.hs
+++ b/include/Language/Haskell/Liquid/Foreign.hs
@@ -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)) } @-}
diff --git a/include/Language/Haskell/Liquid/List.hs b/include/Language/Haskell/Liquid/List.hs
--- a/include/Language/Haskell/Liquid/List.hs
+++ b/include/Language/Haskell/Liquid/List.hs
@@ -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])
-
-
diff --git a/include/Prelude.hquals b/include/Prelude.hquals
--- a/include/Prelude.hquals
+++ b/include/Prelude.hquals
@@ -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)])
+
+
+
diff --git a/liquidhaskell.cabal b/liquidhaskell.cabal
--- a/liquidhaskell.cabal
+++ b/liquidhaskell.cabal
@@ -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
diff --git a/src/LHi.hs b/src/LHi.hs
new file mode 100644
--- /dev/null
+++ b/src/LHi.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/ACSS.hs b/src/Language/Haskell/Liquid/ACSS.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/ACSS.hs
+++ /dev/null
@@ -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 "%s%s" (escape ann) s
-renderTypAnnot Nothing s = s
-
-renderErrAnnot (Just _) s = printf "%s" s
-renderErrAnnot Nothing s = s
-
-renderLinAnnot (Just d) s = printf "%s: %s" (lineString d) s
-renderLinAnnot Nothing s = s
-
-lineString (i, w) = (replicate (w - (length is)) ' ') ++ is
- where is = show i
-
-{- Example Annotation:
-x#agV:Int -> {VV_int:Int | (0 <= VV_int),(x#agV <= VV_int)}
-NOWTRYTHIS
--}
-
-
-insertAnnotAnchors :: [(TokenType, String, a)] -> [Either String (TokenType, String, a)]
-insertAnnotAnchors toks
- = stitch (zip toks' toks) $ insertAnchors toks'
- where toks' = [(x,y) | (x,y,_) <- toks]
-
-stitch :: Eq b => [(b, c)] -> [Either a b] -> [Either a c]
-stitch xys ((Left a) : rest)
- = (Left a) : stitch xys rest
-stitch ((x,y):xys) ((Right x'):rest)
- | x == x'
- = (Right y) : stitch xys rest
- | otherwise
- = 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
diff --git a/src/Language/Haskell/Liquid/ANFTransform.hs b/src/Language/Haskell/Liquid/ANFTransform.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/ANFTransform.hs
+++ /dev/null
@@ -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))
-
diff --git a/src/Language/Haskell/Liquid/Annotate.hs b/src/Language/Haskell/Liquid/Annotate.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Annotate.hs
+++ /dev/null
@@ -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
- [ ""
- , ""
- , ""
- , "" ++ title ++ ""
- , ""
- , cssHTML css
- , ""
- , ""
- , "Put mouse over identifiers to see inferred types"
- ]
-
-htmlClose = "\n\n"
-
-cssHTML css = unlines
- [ ""
- , ""
- , ""
- ]
-
-------------------------------------------------------------------------------
--- | Building Annotation Maps ------------------------------------------------
-------------------------------------------------------------------------------
-
--- | This function converts our annotation information into that which
--- is required by `Language.Haskell.Liquid.ACSS` to generate mouseover
--- annotations.
-
-mkAnnMap :: Config -> 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
diff --git a/src/Language/Haskell/Liquid/Bare.hs b/src/Language/Haskell/Liquid/Bare.hs
--- a/src/Language/Haskell/Liquid/Bare.hs
+++ b/src/Language/Haskell/Liquid/Bare.hs
@@ -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
-
diff --git a/src/Language/Haskell/Liquid/Bare/Axiom.hs b/src/Language/Haskell/Liquid/Bare/Axiom.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Bare/Axiom.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Bare/Check.hs b/src/Language/Haskell/Liquid/Bare/Check.hs
--- a/src/Language/Haskell/Liquid/Bare/Check.hs
+++ b/src/Language/Haskell/Liquid/Bare/Check.hs
@@ -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)))
diff --git a/src/Language/Haskell/Liquid/Bare/DataType.hs b/src/Language/Haskell/Liquid/Bare/DataType.hs
--- a/src/Language/Haskell/Liquid/Bare/DataType.hs
+++ b/src/Language/Haskell/Liquid/Bare/DataType.hs
@@ -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)
diff --git a/src/Language/Haskell/Liquid/Bare/Env.hs b/src/Language/Haskell/Liquid/Bare/Env.hs
--- a/src/Language/Haskell/Liquid/Bare/Env.hs
+++ b/src/Language/Haskell/Liquid/Bare/Env.hs
@@ -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: " ++)
diff --git a/src/Language/Haskell/Liquid/Bare/Existential.hs b/src/Language/Haskell/Liquid/Bare/Existential.hs
--- a/src/Language/Haskell/Liquid/Bare/Existential.hs
+++ b/src/Language/Haskell/Liquid/Bare/Existential.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Bare/Expand.hs b/src/Language/Haskell/Liquid/Bare/Expand.hs
--- a/src/Language/Haskell/Liquid/Bare/Expand.hs
+++ b/src/Language/Haskell/Liquid/Bare/Expand.hs
@@ -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)
diff --git a/src/Language/Haskell/Liquid/Bare/GhcSpec.hs b/src/Language/Haskell/Liquid/Bare/GhcSpec.hs
--- a/src/Language/Haskell/Liquid/Bare/GhcSpec.hs
+++ b/src/Language/Haskell/Liquid/Bare/GhcSpec.hs
@@ -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)
diff --git a/src/Language/Haskell/Liquid/Bare/Lookup.hs b/src/Language/Haskell/Liquid/Bare/Lookup.hs
--- a/src/Language/Haskell/Liquid/Bare/Lookup.hs
+++ b/src/Language/Haskell/Liquid/Bare/Lookup.hs
@@ -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
-
diff --git a/src/Language/Haskell/Liquid/Bare/Measure.hs b/src/Language/Haskell/Liquid/Bare/Measure.hs
--- a/src/Language/Haskell/Liquid/Bare/Measure.hs
+++ b/src/Language/Haskell/Liquid/Bare/Measure.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Bare/Misc.hs b/src/Language/Haskell/Liquid/Bare/Misc.hs
--- a/src/Language/Haskell/Liquid/Bare/Misc.hs
+++ b/src/Language/Haskell/Liquid/Bare/Misc.hs
@@ -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
-
diff --git a/src/Language/Haskell/Liquid/Bare/OfType.hs b/src/Language/Haskell/Liquid/Bare/OfType.hs
--- a/src/Language/Haskell/Liquid/Bare/OfType.hs
+++ b/src/Language/Haskell/Liquid/Bare/OfType.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Bare/Plugged.hs b/src/Language/Haskell/Liquid/Bare/Plugged.hs
--- a/src/Language/Haskell/Liquid/Bare/Plugged.hs
+++ b/src/Language/Haskell/Liquid/Bare/Plugged.hs
@@ -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
-
-
diff --git a/src/Language/Haskell/Liquid/Bare/RTEnv.hs b/src/Language/Haskell/Liquid/Bare/RTEnv.hs
--- a/src/Language/Haskell/Liquid/Bare/RTEnv.hs
+++ b/src/Language/Haskell/Liquid/Bare/RTEnv.hs
@@ -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 -> [ ]
diff --git a/src/Language/Haskell/Liquid/Bare/RefToLogic.hs b/src/Language/Haskell/Liquid/Bare/RefToLogic.hs
--- a/src/Language/Haskell/Liquid/Bare/RefToLogic.hs
+++ b/src/Language/Haskell/Liquid/Bare/RefToLogic.hs
@@ -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 -}
diff --git a/src/Language/Haskell/Liquid/Bare/Resolve.hs b/src/Language/Haskell/Liquid/Bare/Resolve.hs
--- a/src/Language/Haskell/Liquid/Bare/Resolve.hs
+++ b/src/Language/Haskell/Liquid/Bare/Resolve.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Bare/Spec.hs b/src/Language/Haskell/Liquid/Bare/Spec.hs
--- a/src/Language/Haskell/Liquid/Bare/Spec.hs
+++ b/src/Language/Haskell/Liquid/Bare/Spec.hs
@@ -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]
diff --git a/src/Language/Haskell/Liquid/Bare/SymSort.hs b/src/Language/Haskell/Liquid/Bare/SymSort.hs
--- a/src/Language/Haskell/Liquid/Bare/SymSort.hs
+++ b/src/Language/Haskell/Liquid/Bare/SymSort.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Bounds.hs b/src/Language/Haskell/Liquid/Bounds.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Bounds.hs
+++ /dev/null
@@ -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))
diff --git a/src/Language/Haskell/Liquid/CTags.hs b/src/Language/Haskell/Liquid/CTags.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/CTags.hs
+++ /dev/null
@@ -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
-
-
diff --git a/src/Language/Haskell/Liquid/Cabal.hs b/src/Language/Haskell/Liquid/Cabal.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Cabal.hs
+++ /dev/null
@@ -1,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 })
diff --git a/src/Language/Haskell/Liquid/CmdLine.hs b/src/Language/Haskell/Liquid/CmdLine.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/CmdLine.hs
+++ /dev/null
@@ -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
diff --git a/src/Language/Haskell/Liquid/Constraint/Axioms.hs b/src/Language/Haskell/Liquid/Constraint/Axioms.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Constraint/Axioms.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Constraint/Constraint.hs b/src/Language/Haskell/Liquid/Constraint/Constraint.hs
--- a/src/Language/Haskell/Liquid/Constraint/Constraint.hs
+++ b/src/Language/Haskell/Liquid/Constraint/Constraint.hs
@@ -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 [] = [[]]
diff --git a/src/Language/Haskell/Liquid/Constraint/Env.hs b/src/Language/Haskell/Liquid/Constraint/Env.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Constraint/Env.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Constraint/Fresh.hs b/src/Language/Haskell/Liquid/Constraint/Fresh.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Constraint/Fresh.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Constraint/Generate.hs b/src/Language/Haskell/Liquid/Constraint/Generate.hs
--- a/src/Language/Haskell/Liquid/Constraint/Generate.hs
+++ b/src/Language/Haskell/Liquid/Constraint/Generate.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Constraint/Monad.hs b/src/Language/Haskell/Liquid/Constraint/Monad.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Constraint/Monad.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Constraint/ProofToCore.hs b/src/Language/Haskell/Liquid/Constraint/ProofToCore.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Constraint/ProofToCore.hs
@@ -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)
diff --git a/src/Language/Haskell/Liquid/Constraint/Qualifier.hs b/src/Language/Haskell/Liquid/Constraint/Qualifier.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Constraint/Qualifier.hs
@@ -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
+-}
diff --git a/src/Language/Haskell/Liquid/Constraint/Split.hs b/src/Language/Haskell/Liquid/Constraint/Split.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Constraint/Split.hs
@@ -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)
diff --git a/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs b/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs
--- a/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs
+++ b/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Constraint/Types.hs b/src/Language/Haskell/Liquid/Constraint/Types.hs
--- a/src/Language/Haskell/Liquid/Constraint/Types.hs
+++ b/src/Language/Haskell/Liquid/Constraint/Types.hs
@@ -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))
diff --git a/src/Language/Haskell/Liquid/CoreToLogic.hs b/src/Language/Haskell/Liquid/CoreToLogic.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/CoreToLogic.hs
+++ /dev/null
@@ -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)
-
diff --git a/src/Language/Haskell/Liquid/Desugar/Check.lhs b/src/Language/Haskell/Liquid/Desugar/Check.lhs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Desugar/Check.lhs
+++ /dev/null
@@ -1,765 +0,0 @@
-%
-% (c) The University of Glasgow 2006
-% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
-%
-% Author: Juan J. Quintela
-
-\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}
diff --git a/src/Language/Haskell/Liquid/Desugar/Coverage.lhs b/src/Language/Haskell/Liquid/Desugar/Coverage.lhs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Desugar/Coverage.lhs
+++ /dev/null
@@ -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 -- 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_()`, 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}
diff --git a/src/Language/Haskell/Liquid/Desugar/Desugar.lhs b/src/Language/Haskell/Liquid/Desugar/Desugar.lhs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Desugar/Desugar.lhs
+++ /dev/null
@@ -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}
diff --git a/src/Language/Haskell/Liquid/Desugar/DsArrows.lhs b/src/Language/Haskell/Liquid/Desugar/DsArrows.lhs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Desugar/DsArrows.lhs
+++ /dev/null
@@ -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}
diff --git a/src/Language/Haskell/Liquid/Desugar/DsBinds.lhs b/src/Language/Haskell/Liquid/Desugar/DsBinds.lhs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Desugar/DsBinds.lhs
+++ /dev/null
@@ -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 =
-
-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
-
-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, 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 =
- {-# 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 = 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.
-
-
diff --git a/src/Language/Haskell/Liquid/Desugar/DsExpr.lhs b/src/Language/Haskell/Liquid/Desugar/DsExpr.lhs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Desugar/DsExpr.lhs
+++ /dev/null
@@ -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}
diff --git a/src/Language/Haskell/Liquid/Desugar/DsExpr.lhs-boot b/src/Language/Haskell/Liquid/Desugar/DsExpr.lhs-boot
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Desugar/DsExpr.lhs-boot
+++ /dev/null
@@ -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}
diff --git a/src/Language/Haskell/Liquid/Desugar/DsForeign.lhs b/src/Language/Haskell/Liquid/Desugar/DsForeign.lhs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Desugar/DsForeign.lhs
+++ /dev/null
@@ -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'' 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}
diff --git a/src/Language/Haskell/Liquid/Desugar/DsGRHSs.lhs b/src/Language/Haskell/Liquid/Desugar/DsGRHSs.lhs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Desugar/DsGRHSs.lhs
+++ /dev/null
@@ -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}
diff --git a/src/Language/Haskell/Liquid/Desugar/DsListComp.lhs b/src/Language/Haskell/Liquid/Desugar/DsListComp.lhs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Desugar/DsListComp.lhs
+++ /dev/null
@@ -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 <> TE <>
-
-(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}
diff --git a/src/Language/Haskell/Liquid/Desugar/DsMeta.hs b/src/Language/Haskell/Liquid/Desugar/DsMeta.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Desugar/DsMeta.hs
+++ /dev/null
@@ -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 : 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
diff --git a/src/Language/Haskell/Liquid/Desugar/DsUtils.lhs b/src/Language/Haskell/Liquid/Desugar/DsUtils.lhs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Desugar/DsUtils.lhs
+++ /dev/null
@@ -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}
diff --git a/src/Language/Haskell/Liquid/Desugar/HscMain.hs b/src/Language/Haskell/Liquid/Desugar/HscMain.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Desugar/HscMain.hs
+++ /dev/null
@@ -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
diff --git a/src/Language/Haskell/Liquid/Desugar/Match.lhs b/src/Language/Haskell/Liquid/Desugar/Match.lhs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Desugar/Match.lhs
+++ /dev/null
@@ -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
-in
-\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.
-
diff --git a/src/Language/Haskell/Liquid/Desugar/Match.lhs-boot b/src/Language/Haskell/Liquid/Desugar/Match.lhs-boot
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Desugar/Match.lhs-boot
+++ /dev/null
@@ -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}
diff --git a/src/Language/Haskell/Liquid/Desugar/MatchCon.lhs b/src/Language/Haskell/Liquid/Desugar/MatchCon.lhs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Desugar/MatchCon.lhs
+++ /dev/null
@@ -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.
-
diff --git a/src/Language/Haskell/Liquid/Desugar/MatchLit.lhs b/src/Language/Haskell/Liquid/Desugar/MatchLit.lhs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Desugar/MatchLit.lhs
+++ /dev/null
@@ -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
- else
-
-\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}
diff --git a/src/Language/Haskell/Liquid/Desugar710/Check.hs b/src/Language/Haskell/Liquid/Desugar710/Check.hs
--- a/src/Language/Haskell/Liquid/Desugar710/Check.hs
+++ b/src/Language/Haskell/Liquid/Desugar710/Check.hs
@@ -11,6 +11,7 @@
-- #include "HsVersions.h"
+import Prelude hiding (error)
import HsSyn
import TcHsSyn
import Language.Haskell.Liquid.Desugar710.DsUtils
diff --git a/src/Language/Haskell/Liquid/Desugar710/Coverage.hs b/src/Language/Haskell/Liquid/Desugar710/Coverage.hs
--- a/src/Language/Haskell/Liquid/Desugar710/Coverage.hs
+++ b/src/Language/Haskell/Liquid/Desugar710/Coverage.hs
@@ -7,6 +7,7 @@
module Language.Haskell.Liquid.Desugar710.Coverage (addTicksToBinds, hpcInitCode) where
+import Prelude hiding (error)
import Type
import HsSyn
import Module
diff --git a/src/Language/Haskell/Liquid/Desugar710/Desugar.hs b/src/Language/Haskell/Liquid/Desugar710/Desugar.hs
--- a/src/Language/Haskell/Liquid/Desugar710/Desugar.hs
+++ b/src/Language/Haskell/Liquid/Desugar710/Desugar.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Desugar710/DsArrows.hs b/src/Language/Haskell/Liquid/Desugar710/DsArrows.hs
--- a/src/Language/Haskell/Liquid/Desugar710/DsArrows.hs
+++ b/src/Language/Haskell/Liquid/Desugar710/DsArrows.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Desugar710/DsBinds.hs b/src/Language/Haskell/Liquid/Desugar710/DsBinds.hs
--- a/src/Language/Haskell/Liquid/Desugar710/DsBinds.hs
+++ b/src/Language/Haskell/Liquid/Desugar710/DsBinds.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Desugar710/DsCCall.hs b/src/Language/Haskell/Liquid/Desugar710/DsCCall.hs
--- a/src/Language/Haskell/Liquid/Desugar710/DsCCall.hs
+++ b/src/Language/Haskell/Liquid/Desugar710/DsCCall.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Desugar710/DsExpr.hs b/src/Language/Haskell/Liquid/Desugar710/DsExpr.hs
--- a/src/Language/Haskell/Liquid/Desugar710/DsExpr.hs
+++ b/src/Language/Haskell/Liquid/Desugar710/DsExpr.hs
@@ -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 " ++
diff --git a/src/Language/Haskell/Liquid/Desugar710/DsForeign.hs b/src/Language/Haskell/Liquid/Desugar710/DsForeign.hs
--- a/src/Language/Haskell/Liquid/Desugar710/DsForeign.hs
+++ b/src/Language/Haskell/Liquid/Desugar710/DsForeign.hs
@@ -18,7 +18,7 @@
-- #include "HsVersions.h"
import TcRnMonad -- temp
-
+import Prelude hiding (error)
import TypeRep
import CoreSyn
diff --git a/src/Language/Haskell/Liquid/Desugar710/DsGRHSs.hs b/src/Language/Haskell/Liquid/Desugar710/DsGRHSs.hs
--- a/src/Language/Haskell/Liquid/Desugar710/DsGRHSs.hs
+++ b/src/Language/Haskell/Liquid/Desugar710/DsGRHSs.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Desugar710/DsListComp.hs b/src/Language/Haskell/Liquid/Desugar710/DsListComp.hs
--- a/src/Language/Haskell/Liquid/Desugar710/DsListComp.hs
+++ b/src/Language/Haskell/Liquid/Desugar710/DsListComp.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Desugar710/DsMeta.hs b/src/Language/Haskell/Liquid/Desugar710/DsMeta.hs
--- a/src/Language/Haskell/Liquid/Desugar710/DsMeta.hs
+++ b/src/Language/Haskell/Liquid/Desugar710/DsMeta.hs
@@ -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)
diff --git a/src/Language/Haskell/Liquid/Desugar710/DsUtils.hs b/src/Language/Haskell/Liquid/Desugar710/DsUtils.hs
--- a/src/Language/Haskell/Liquid/Desugar710/DsUtils.hs
+++ b/src/Language/Haskell/Liquid/Desugar710/DsUtils.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Desugar710/HscMain.hs b/src/Language/Haskell/Liquid/Desugar710/HscMain.hs
--- a/src/Language/Haskell/Liquid/Desugar710/HscMain.hs
+++ b/src/Language/Haskell/Liquid/Desugar710/HscMain.hs
@@ -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 =
diff --git a/src/Language/Haskell/Liquid/Desugar710/Match.hs b/src/Language/Haskell/Liquid/Desugar710/Match.hs
--- a/src/Language/Haskell/Liquid/Desugar710/Match.hs
+++ b/src/Language/Haskell/Liquid/Desugar710/Match.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Desugar710/MatchCon.hs b/src/Language/Haskell/Liquid/Desugar710/MatchCon.hs
--- a/src/Language/Haskell/Liquid/Desugar710/MatchCon.hs
+++ b/src/Language/Haskell/Liquid/Desugar710/MatchCon.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Desugar710/MatchLit.hs b/src/Language/Haskell/Liquid/Desugar710/MatchLit.hs
--- a/src/Language/Haskell/Liquid/Desugar710/MatchLit.hs
+++ b/src/Language/Haskell/Liquid/Desugar710/MatchLit.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Dictionaries.hs b/src/Language/Haskell/Liquid/Dictionaries.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Dictionaries.hs
+++ /dev/null
@@ -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)
diff --git a/src/Language/Haskell/Liquid/DiffCheck.hs b/src/Language/Haskell/Liquid/DiffCheck.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/DiffCheck.hs
+++ /dev/null
@@ -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
diff --git a/src/Language/Haskell/Liquid/Errors.hs b/src/Language/Haskell/Liquid/Errors.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Errors.hs
+++ /dev/null
@@ -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
-
diff --git a/src/Language/Haskell/Liquid/Fresh.hs b/src/Language/Haskell/Liquid/Fresh.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Fresh.hs
+++ /dev/null
@@ -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
-
diff --git a/src/Language/Haskell/Liquid/GHC/Interface.hs b/src/Language/Haskell/Liquid/GHC/Interface.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/GHC/Interface.hs
@@ -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)]
+
diff --git a/src/Language/Haskell/Liquid/GHC/Misc.hs b/src/Language/Haskell/Liquid/GHC/Misc.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/GHC/Misc.hs
@@ -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 ""
+srcSpanSourcePos (RealSrcSpan s) = realSrcSpanSourcePos s
+
+srcSpanSourcePosE :: SrcSpan -> SourcePos
+srcSpanSourcePosE (UnhelpfulSpan _) = dummyPos ""
+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
+--------------------------------------------------------------------------------
diff --git a/src/Language/Haskell/Liquid/GHC/Play.hs b/src/Language/Haskell/Liquid/GHC/Play.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/GHC/Play.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/GHC/SpanStack.hs b/src/Language/Haskell/Liquid/GHC/SpanStack.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/GHC/SpanStack.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/GhcInterface.hs b/src/Language/Haskell/Liquid/GhcInterface.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/GhcInterface.hs
+++ /dev/null
@@ -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)]
diff --git a/src/Language/Haskell/Liquid/GhcMisc.hs b/src/Language/Haskell/Liquid/GhcMisc.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/GhcMisc.hs
+++ /dev/null
@@ -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
diff --git a/src/Language/Haskell/Liquid/GhcPlay.hs b/src/Language/Haskell/Liquid/GhcPlay.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/GhcPlay.hs
+++ /dev/null
@@ -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
diff --git a/src/Language/Haskell/Liquid/Interactive/Handler.hs b/src/Language/Haskell/Liquid/Interactive/Handler.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Interactive/Handler.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Interactive/Types.hs b/src/Language/Haskell/Liquid/Interactive/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Interactive/Types.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Liquid.hs b/src/Language/Haskell/Liquid/Liquid.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Liquid.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Literals.hs b/src/Language/Haskell/Liquid/Literals.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Literals.hs
+++ /dev/null
@@ -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
diff --git a/src/Language/Haskell/Liquid/Measure.hs b/src/Language/Haskell/Liquid/Measure.hs
--- a/src/Language/Haskell/Liquid/Measure.hs
+++ b/src/Language/Haskell/Liquid/Measure.hs
@@ -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)
diff --git a/src/Language/Haskell/Liquid/Misc.hs b/src/Language/Haskell/Liquid/Misc.hs
--- a/src/Language/Haskell/Liquid/Misc.hs
+++ b/src/Language/Haskell/Liquid/Misc.hs
@@ -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"
-
diff --git a/src/Language/Haskell/Liquid/Names.hs b/src/Language/Haskell/Liquid/Names.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Names.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Language.Haskell.Liquid.Names where
-
-import Language.Fixpoint.Types
-
-
-lenLocSymbol = dummyLoc $ symbol ("autolen" :: String)
diff --git a/src/Language/Haskell/Liquid/Parse.hs b/src/Language/Haskell/Liquid/Parse.hs
--- a/src/Language/Haskell/Liquid/Parse.hs
+++ b/src/Language/Haskell/Liquid/Parse.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/PredType.hs b/src/Language/Haskell/Liquid/PredType.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/PredType.hs
+++ /dev/null
@@ -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
diff --git a/src/Language/Haskell/Liquid/PrettyPrint.hs b/src/Language/Haskell/Liquid/PrettyPrint.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/PrettyPrint.hs
+++ /dev/null
@@ -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
diff --git a/src/Language/Haskell/Liquid/Prover/Constants.hs b/src/Language/Haskell/Liquid/Prover/Constants.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Prover/Constants.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Prover/Misc.hs b/src/Language/Haskell/Liquid/Prover/Misc.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Prover/Misc.hs
@@ -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)
diff --git a/src/Language/Haskell/Liquid/Prover/Names.hs b/src/Language/Haskell/Liquid/Prover/Names.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Prover/Names.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Language.Haskell.Liquid.Prover.Names where
+
+import Language.Fixpoint.Types
+
+exprToBoolSym :: Symbol
+exprToBoolSym = "exprToBool"
diff --git a/src/Language/Haskell/Liquid/Prover/Parser.hs b/src/Language/Haskell/Liquid/Prover/Parser.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Prover/Parser.hs
@@ -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 ()
+
+
+
diff --git a/src/Language/Haskell/Liquid/Prover/Pretty.hs b/src/Language/Haskell/Liquid/Prover/Pretty.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Prover/Pretty.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Prover/SMTInterface.hs b/src/Language/Haskell/Liquid/Prover/SMTInterface.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Prover/SMTInterface.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Prover/Solve.hs b/src/Language/Haskell/Liquid/Prover/Solve.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Prover/Solve.hs
@@ -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
+
+
diff --git a/src/Language/Haskell/Liquid/Prover/Types.hs b/src/Language/Haskell/Liquid/Prover/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Prover/Types.hs
@@ -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)
diff --git a/src/Language/Haskell/Liquid/Qualifier.hs b/src/Language/Haskell/Liquid/Qualifier.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Qualifier.hs
+++ /dev/null
@@ -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]
diff --git a/src/Language/Haskell/Liquid/RefSplit.hs b/src/Language/Haskell/Liquid/RefSplit.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/RefSplit.hs
+++ /dev/null
@@ -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
diff --git a/src/Language/Haskell/Liquid/RefType.hs b/src/Language/Haskell/Liquid/RefType.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/RefType.hs
+++ /dev/null
@@ -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
diff --git a/src/Language/Haskell/Liquid/Simplify.hs b/src/Language/Haskell/Liquid/Simplify.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Simplify.hs
+++ /dev/null
@@ -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
diff --git a/src/Language/Haskell/Liquid/Strata.hs b/src/Language/Haskell/Liquid/Strata.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Strata.hs
+++ /dev/null
@@ -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
-
-
diff --git a/src/Language/Haskell/Liquid/Tidy.hs b/src/Language/Haskell/Liquid/Tidy.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Tidy.hs
+++ /dev/null
@@ -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 _) = []
diff --git a/src/Language/Haskell/Liquid/TransformRec.hs b/src/Language/Haskell/Liquid/TransformRec.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/TransformRec.hs
+++ /dev/null
@@ -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)
diff --git a/src/Language/Haskell/Liquid/Transforms/ANF.hs b/src/Language/Haskell/Liquid/Transforms/ANF.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Transforms/ANF.hs
@@ -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 γ)}
diff --git a/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs b/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Transforms/CoreToLogic.hs
@@ -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)
diff --git a/src/Language/Haskell/Liquid/Transforms/Rec.hs b/src/Language/Haskell/Liquid/Transforms/Rec.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Transforms/Rec.hs
@@ -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)
diff --git a/src/Language/Haskell/Liquid/Transforms/RefSplit.hs b/src/Language/Haskell/Liquid/Transforms/RefSplit.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Transforms/RefSplit.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Transforms/Simplify.hs b/src/Language/Haskell/Liquid/Transforms/Simplify.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Transforms/Simplify.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Types.hs b/src/Language/Haskell/Liquid/Types.hs
--- a/src/Language/Haskell/Liquid/Types.hs
+++ b/src/Language/Haskell/Liquid/Types.hs
@@ -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
Prop, q :: Int -> Prop, r :: a -> Prop>
--- = F (a -> b
) | Q (c -> a) | G (Int -> a)
---
--- there will be:
---
--- varianceTyArgs = [Bivariant , Covariant, Contravatiant, Invariant]
--- variancePsArgs = [Covariant, Contravatiant, Bivariant]
---
-
-data TyConInfo = TyConInfo
- { varianceTyArgs :: !VarianceInfo -- ^ variance info for type variables
- , variancePsArgs :: !VarianceInfo -- ^ variance info for predicate variables
- , sizeFunction :: !(Maybe (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
Prop, q :: Int -> Prop, r :: a -> Prop>
+-- = F (a -> b
) | Q (c -> a) | G (Int -> a)
+--
+-- there will be:
+--
+-- varianceTyArgs = [Bivariant , Covariant, Contravatiant, Invariant]
+-- variancePsArgs = [Covariant, Contravatiant, Bivariant]
+--
+
+data TyConInfo = TyConInfo
+ { varianceTyArgs :: !VarianceInfo -- ^ variance info for type variables
+ , variancePsArgs :: !VarianceInfo -- ^ variance info for predicate variables
+ , sizeFunction :: !(Maybe (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
diff --git a/src/Language/Haskell/Liquid/Types/Bounds.hs b/src/Language/Haskell/Liquid/Types/Bounds.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Types/Bounds.hs
@@ -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))
diff --git a/src/Language/Haskell/Liquid/Types/Dictionaries.hs b/src/Language/Haskell/Liquid/Types/Dictionaries.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Types/Dictionaries.hs
@@ -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)
diff --git a/src/Language/Haskell/Liquid/Types/Errors.hs b/src/Language/Haskell/Liquid/Types/Errors.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Types/Errors.hs
@@ -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 "'"
diff --git a/src/Language/Haskell/Liquid/Types/Literals.hs b/src/Language/Haskell/Liquid/Types/Literals.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Types/Literals.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Types/Meet.hs b/src/Language/Haskell/Liquid/Types/Meet.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Types/Meet.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Types/Names.hs b/src/Language/Haskell/Liquid/Types/Names.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Types/Names.hs
@@ -0,0 +1,6 @@
+module Language.Haskell.Liquid.Types.Names where
+
+import Language.Fixpoint.Types
+
+
+lenLocSymbol = dummyLoc $ symbol ("autolen" :: String)
diff --git a/src/Language/Haskell/Liquid/Types/PredType.hs b/src/Language/Haskell/Liquid/Types/PredType.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Types/PredType.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Types/PrettyPrint.hs b/src/Language/Haskell/Liquid/Types/PrettyPrint.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Types/PrettyPrint.hs
@@ -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
+
+--------------------------------------------------------------------------------
diff --git a/src/Language/Haskell/Liquid/Types/RefType.hs b/src/Language/Haskell/Liquid/Types/RefType.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Types/RefType.hs
@@ -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)
diff --git a/src/Language/Haskell/Liquid/Types/Specifications.hs b/src/Language/Haskell/Liquid/Types/Specifications.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Types/Specifications.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Types/Strata.hs b/src/Language/Haskell/Liquid/Types/Strata.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Types/Strata.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Types/Variance.hs b/src/Language/Haskell/Liquid/Types/Variance.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Types/Variance.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/Types/Visitors.hs b/src/Language/Haskell/Liquid/Types/Visitors.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/Types/Visitors.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/UX/ACSS.hs b/src/Language/Haskell/Liquid/UX/ACSS.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/UX/ACSS.hs
@@ -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 "%s%s" (escape ann) s
+renderTypAnnot Nothing s = s
+
+renderErrAnnot (Just _) s = printf "%s" s
+renderErrAnnot Nothing s = s
+
+renderLinAnnot (Just d) s = printf "%s: %s" (lineString d) s
+renderLinAnnot Nothing s = s
+
+lineString (i, w) = (replicate (w - (length is)) ' ') ++ is
+ where is = show i
+
+{- Example Annotation:
+x#agV:Int -> {VV_int:Int | (0 <= VV_int),(x#agV <= VV_int)}
+NOWTRYTHIS
+-}
+
+
+insertAnnotAnchors :: [(TokenType, String, a)] -> [Either String (TokenType, String, a)]
+insertAnnotAnchors toks
+ = stitch (zip toks' toks) $ insertAnchors toks'
+ where toks' = [(x,y) | (x,y,_) <- toks]
+
+stitch :: Eq b => [(b, c)] -> [Either a b] -> [Either a c]
+stitch xys ((Left a) : rest)
+ = (Left a) : stitch xys rest
+stitch ((x,y):xys) ((Right x'):rest)
+ | x == x'
+ = (Right y) : stitch xys rest
+ | otherwise
+ = panic Nothing "stitch"
+stitch _ []
+ = []
+stitch _ _
+ = impossible Nothing "stitch: cannot happen"
+
+splitSrcAndAnns :: String -> (String, AnnMap)
+splitSrcAndAnns s =
+ let ls = lines s in
+ case 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
diff --git a/src/Language/Haskell/Liquid/UX/Annotate.hs b/src/Language/Haskell/Liquid/UX/Annotate.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/UX/Annotate.hs
@@ -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
+ [ ""
+ , ""
+ , ""
+ , "" ++ title ++ ""
+ , ""
+ , cssHTML css
+ , ""
+ , ""
+ , "Put mouse over identifiers to see inferred types"
+ ]
+
+htmlClose = "\n\n"
+
+cssHTML css = unlines
+ [ ""
+ , ""
+ , ""
+ ]
+
+------------------------------------------------------------------------------
+-- | Building Annotation Maps ------------------------------------------------
+------------------------------------------------------------------------------
+
+-- | This function converts our annotation information into that which
+-- is required by `Language.Haskell.Liquid.ACSS` to generate mouseover
+-- annotations.
+
+mkAnnMap :: Config -> ErrorResult -> AnnInfo Doc -> ACSS.AnnMap
+mkAnnMap cfg res ann = ACSS.Ann (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
diff --git a/src/Language/Haskell/Liquid/UX/CTags.hs b/src/Language/Haskell/Liquid/UX/CTags.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/UX/CTags.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/UX/CmdLine.hs b/src/Language/Haskell/Liquid/UX/CmdLine.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/UX/CmdLine.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/UX/Config.hs b/src/Language/Haskell/Liquid/UX/Config.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/UX/Config.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/UX/DiffCheck.hs b/src/Language/Haskell/Liquid/UX/DiffCheck.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/UX/DiffCheck.hs
@@ -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
diff --git a/src/Language/Haskell/Liquid/UX/Errors.hs b/src/Language/Haskell/Liquid/UX/Errors.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/UX/Errors.hs
@@ -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 ..]]
diff --git a/src/Language/Haskell/Liquid/UX/Tidy.hs b/src/Language/Haskell/Liquid/UX/Tidy.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Liquid/UX/Tidy.hs
@@ -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]
diff --git a/src/Language/Haskell/Liquid/Variance.hs b/src/Language/Haskell/Liquid/Variance.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Variance.hs
+++ /dev/null
@@ -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)
diff --git a/src/Language/Haskell/Liquid/Visitors.hs b/src/Language/Haskell/Liquid/Visitors.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Visitors.hs
+++ /dev/null
@@ -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
diff --git a/src/Language/Haskell/Liquid/WiredIn.hs b/src/Language/Haskell/Liquid/WiredIn.hs
--- a/src/Language/Haskell/Liquid/WiredIn.hs
+++ b/src/Language/Haskell/Liquid/WiredIn.hs
@@ -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_"
diff --git a/src/Language/Haskell/Liquid/World.hs b/src/Language/Haskell/Liquid/World.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/World.hs
+++ /dev/null
@@ -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
-
-
diff --git a/src/Liquid.hs b/src/Liquid.hs
new file mode 100644
--- /dev/null
+++ b/src/Liquid.hs
@@ -0,0 +1,5 @@
+import Language.Haskell.Liquid.Liquid (liquid)
+import System.Environment (getArgs)
+
+main :: IO a
+main = liquid =<< getArgs
diff --git a/tests/crash/Assume.hs b/tests/crash/Assume.hs
new file mode 100644
--- /dev/null
+++ b/tests/crash/Assume.hs
@@ -0,0 +1,5 @@
+module Assume where
+
+{-@ assume incr :: Int -> {v : Int | v == x} @-}
+incr :: Int -> Int
+incr x = x + 1
diff --git a/tests/crash/Assume1.hs b/tests/crash/Assume1.hs
new file mode 100644
--- /dev/null
+++ b/tests/crash/Assume1.hs
@@ -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
diff --git a/tests/crash/Ast.hs b/tests/crash/Ast.hs
new file mode 100644
--- /dev/null
+++ b/tests/crash/Ast.hs
@@ -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 Prop>
+ = Lit Int (i :: AstIndex)
+ | Var String (i :: AstIndex)
+ | App (fn :: f) (arg :: f)
+ | Paren (ast :: f)
+ @-}
+
+{-@ type AstFE = AstF <{\ix -> isExprIndex ix}> @-}
+{-@ type AstFT = AstF <{\ix -> isTypeIndex ix}> @-}
+
+
+-- Now lets tie the knot!
+
+newtype Fix f = In { out :: f (Fix f) }
+
+type Ast = Fix AstF
+
+{-@ type AstE = Fix AstFE @-}
+{-@ type AstT = Fix AstFT @-}
+
+{-@ astExpr :: AstE @-}
+astExpr :: Ast
+astExpr = In (Lit 10 IxExpr)
+
+{-@ astType :: AstT @-}
+astType :: Ast
+astType = In (Lit 10 IxType)
+
+{-@ app :: forall
Prop>. Fix (AstF p) -> Fix (AstF p) -> Fix (AstF p) @-}
+app f x = In $ App f x
+
+{-@ id1 :: forall
Prop>. Fix (AstF p) -> Fix (AstF p) @-}
+id1 :: Fix AstF -> Fix AstF
+id1 z = z
+
+{-@ wrong :: AstT @-}
+wrong = id1 astExpr
diff --git a/tests/crash/CyclicExprAlias2.hs b/tests/crash/CyclicExprAlias2.hs
--- a/tests/crash/CyclicExprAlias2.hs
+++ b/tests/crash/CyclicExprAlias2.hs
@@ -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 @-}
diff --git a/tests/crash/Qualif.hs b/tests/crash/Qualif.hs
new file mode 100644
--- /dev/null
+++ b/tests/crash/Qualif.hs
@@ -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) @-}
diff --git a/tests/crash/T649.hs b/tests/crash/T649.hs
new file mode 100644
--- /dev/null
+++ b/tests/crash/T649.hs
@@ -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
+
diff --git a/tests/crash/errmsg-dc-num.hs b/tests/crash/errmsg-dc-num.hs
new file mode 100644
--- /dev/null
+++ b/tests/crash/errmsg-dc-num.hs
@@ -0,0 +1,6 @@
+module Boo where
+
+{-@ data T = C { fldX :: Int } @-}
+
+
+data T = C { fldX :: Int, fldY :: Int }
diff --git a/tests/crash/errmsg-dc-type.hs b/tests/crash/errmsg-dc-type.hs
new file mode 100644
--- /dev/null
+++ b/tests/crash/errmsg-dc-type.hs
@@ -0,0 +1,5 @@
+module Boo where
+
+{-@ data T = C { fldX :: Int, fldY :: Bool } @-}
+
+data T = C { fldX :: Int, fldY :: Int }
diff --git a/tests/crash/errmsg-mismatch.hs b/tests/crash/errmsg-mismatch.hs
new file mode 100644
--- /dev/null
+++ b/tests/crash/errmsg-mismatch.hs
@@ -0,0 +1,5 @@
+module Boo where
+
+{-@ incr :: Int -> Bool @-}
+incr :: Int -> Int
+incr x = x + 1
diff --git a/tests/crash/issue594.hs b/tests/crash/issue594.hs
new file mode 100644
--- /dev/null
+++ b/tests/crash/issue594.hs
@@ -0,0 +1,7 @@
+module Boo where
+
+{-@ data X Int -> Prop> = X (x0 :: Int) (x1 :: Int) @-}
+data X = X Int Int
+
+{-@ data T
Int -> Int -> Int -> Prop> = C { x :: Int, y :: Int, z :: X
} @-}
+data T = C { x :: Int, y :: Int, z :: X }
diff --git a/tests/crash/predparams.hs b/tests/crash/predparams.hs
new file mode 100644
--- /dev/null
+++ b/tests/crash/predparams.hs
@@ -0,0 +1,10 @@
+
+-- ISSUE: this "crashes" without a decent source location
+-- You can fix this with the signature `ide :: forall
Prop>. a
-> a
`
+-- but it would be nice to have an error message that pinpoints the location.
+-- https://github.com/ucsd-progsys/liquidhaskell/issues/655
+
+module Ide where
+
+{-@ ide :: a
-> a
@-}
+ide x = x
diff --git a/tests/neg/AbsApp.hs b/tests/neg/AbsApp.hs
new file mode 100644
--- /dev/null
+++ b/tests/neg/AbsApp.hs
@@ -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
Prop>. Int
-> Int
@-}
+id2 :: Int -> Int
+id2 x = x
+
+{-@ type Neg = Int<{\x -> x < 0}> @-}
+
+{-@ three :: Neg @-}
+three = id2 3
+
diff --git a/tests/neg/Ast.hs b/tests/neg/Ast.hs
new file mode 100644
--- /dev/null
+++ b/tests/neg/Ast.hs
@@ -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 Prop>
+ = Lit Int (i :: AstIndex)
+ | Var String (i :: AstIndex)
+ | App (fn :: f) (arg :: f)
+ | Paren (ast :: f)
+ @-}
+
+{-@ type AstFE = AstF <{\ix -> isExprIndex ix}> @-}
+{-@ type AstFT = AstF <{\ix -> isTypeIndex ix}> @-}
+
+
+-- Now lets tie the knot!
+
+newtype Fix f = In { out :: f (Fix f) }
+
+type Ast = Fix AstF
+
+{-@ type AstE = Fix AstFE @-}
+{-@ type AstT = Fix AstFT @-}
+
+{-@ astExpr :: Fix (AstF <{\ix -> isExprIndex ix}>) @-}
+astExpr :: Ast
+astExpr = undefined
+
+{-@ id1 :: forall
Prop>. Fix (AstF
) -> Fix (AstF
) @-}
+id1 :: Fix AstF -> Fix AstF
+id1 z = z
+
+{-@ wrong :: AstT @-}
+wrong = id1 astExpr
diff --git a/tests/neg/BadHMeas.hs b/tests/neg/BadHMeas.hs
new file mode 100644
--- /dev/null
+++ b/tests/neg/BadHMeas.hs
@@ -0,0 +1,5 @@
+
+{-@ measure foo @-}
+foo :: [(Int,Int)] -> Int
+foo [] = 0
+foo (a:as) = fst a + foo as
diff --git a/tests/neg/BigNum.hs b/tests/neg/BigNum.hs
new file mode 100644
--- /dev/null
+++ b/tests/neg/BigNum.hs
@@ -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
diff --git a/tests/neg/Books.hs b/tests/neg/Books.hs
new file mode 100644
--- /dev/null
+++ b/tests/neg/Books.hs
@@ -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
diff --git a/tests/neg/FunSoundness.hs b/tests/neg/FunSoundness.hs
new file mode 100644
--- /dev/null
+++ b/tests/neg/FunSoundness.hs
@@ -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
diff --git a/tests/neg/GADTs.hs b/tests/neg/GADTs.hs
new file mode 100644
--- /dev/null
+++ b/tests/neg/GADTs.hs
@@ -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
diff --git a/tests/neg/Gradual.hs b/tests/neg/Gradual.hs
new file mode 100644
--- /dev/null
+++ b/tests/neg/Gradual.hs
@@ -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
diff --git a/tests/neg/PairMeasure0.hs b/tests/neg/PairMeasure0.hs
deleted file mode 100644
--- a/tests/neg/PairMeasure0.hs
+++ /dev/null
@@ -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
-
-
-
diff --git a/tests/neg/Propability.hs b/tests/neg/Propability.hs
--- a/tests/neg/Propability.hs
+++ b/tests/neg/Propability.hs
@@ -1,7 +1,5 @@
module Propability where
-{-@ LIQUID "--real" @-}
-
{-@ type Propability = {v:Double | ((0.0 <= v) && (v <= 1.0)) } @-}
{-@ p :: Propability @-}
diff --git a/tests/neg/Propability0.hs b/tests/neg/Propability0.hs
--- a/tests/neg/Propability0.hs
+++ b/tests/neg/Propability0.hs
@@ -7,8 +7,6 @@
snd :: Int -> Real
-}
-{-@ LIQUID "--real" @-}
-
{-@ type Propability = {v:Double | ((0.0 <= v) && (v <= 1.0)) } @-}
{-@ p :: Propability @-}
diff --git a/tests/neg/StateConstraints.hs b/tests/neg/StateConstraints.hs
--- a/tests/neg/StateConstraints.hs
+++ b/tests/neg/StateConstraints.hs
@@ -5,7 +5,7 @@
data ST s = ST {runState :: s -> s}
-{-@ data ST s t
Prop, q :: s -> s -> Prop> = ST (runState :: x:s
-> s) @-}
+{-@ data ST s
Prop, q :: s -> s -> Prop> = ST (runState :: x:s
-> s) @-}
{-@ runState :: forall
Prop, q :: s -> s -> Prop>. ST s -> x:s
-> s @-}
diff --git a/tests/neg/T602.hs b/tests/neg/T602.hs
new file mode 100644
--- /dev/null
+++ b/tests/neg/T602.hs
@@ -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
diff --git a/tests/neg/TermReal.hs b/tests/neg/TermReal.hs
new file mode 100644
--- /dev/null
+++ b/tests/neg/TermReal.hs
@@ -0,0 +1,5 @@
+module Main where
+
+{-@ search :: { hi : Int | 0 < hi } -> Int @-}
+search :: Int -> Int
+search hi = search (hi `div` 2)
diff --git a/tests/neg/Variance1.hs b/tests/neg/Variance1.hs
new file mode 100644
--- /dev/null
+++ b/tests/neg/Variance1.hs
@@ -0,0 +1,11 @@
+import Data.Binary
+
+
+{-@
+error :: { x : String | false } -> a
+@-}
+
+example :: Get ()
+example = do
+ _ <- return ()
+ error "URK"
diff --git a/tests/neg/listne.hs b/tests/neg/listne.hs
new file mode 100644
--- /dev/null
+++ b/tests/neg/listne.hs
@@ -0,0 +1,7 @@
+
+{-@ type ListNE a = {v:[a] | 0 < len v} @-}
+
+{-@ junkProp :: ListNE Int @-}
+junkProp :: [Int]
+junkProp = []
+
diff --git a/tests/pos/Abs.hs b/tests/pos/Abs.hs
--- a/tests/pos/Abs.hs
+++ b/tests/pos/Abs.hs
@@ -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
diff --git a/tests/pos/Avg.hs b/tests/pos/Avg.hs
--- a/tests/pos/Avg.hs
+++ b/tests/pos/Avg.hs
@@ -1,8 +1,5 @@
module Avg where
-
-{-@ LIQUID "--real" @-}
-
{-@ measure sumD :: [Double] -> Double
sumD([]) = 0.0
sumD(x:xs) = x + (sumD xs)
diff --git a/tests/pos/Bar.hs b/tests/pos/Bar.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/Bar.hs
@@ -0,0 +1,5 @@
+module Bar where
+
+import Foo
+
+foo = bar
diff --git a/tests/pos/BinarySearch.hs b/tests/pos/BinarySearch.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/BinarySearch.hs
@@ -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
diff --git a/tests/pos/Books.hs b/tests/pos/Books.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/Books.hs
@@ -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
diff --git a/tests/pos/Class.hs b/tests/pos/Class.hs
--- a/tests/pos/Class.hs
+++ b/tests/pos/Class.hs
@@ -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]
diff --git a/tests/pos/CountMonad.hs b/tests/pos/CountMonad.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/CountMonad.hs
@@ -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 Prop, p :: Count b -> Prop, q :: Count b -> Prop>.
+ {x::Count a <>, y :: Count b <
> |- {v:Count b | count v == count x + count y} <: Count b <>}
+ Count a <> -> (a -> Count b<
>) -> Count b <> ;
+ >> :: x:Count a -> y:Count b -> {v:Count b | count v == count x + count y};
+ return :: a -> {v:Count a | count v == 0 }
+@-}
+ return x = let r = Count x in assertCount 0 (Count x)
+ (Count x) >>= f = let r = f x in assertCount (getCount (Count x) + getCount r) r
+ x >> y = assertCount (getCount x + getCount y) y
+ 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
diff --git a/tests/pos/DB00.hs b/tests/pos/DB00.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/DB00.hs
@@ -0,0 +1,21 @@
+
+{-@ LIQUID "--no-termination" @-}
+{-@ LIQUID "totality" @-}
+
+module DataBase (values) where
+
+{-@ values :: forall val -> Prop>.
+ k:key -> [Dict key val] -> [val] @-}
+values :: key -> [Dict key val] -> [val]
+values k = map (go k)
+ where
+ {-@ go :: forall v -> Prop>.
+ i:k -> Dict k v -> v @-}
+ go k (D _ f) = f k
+
+data Dict key val = D {ddom :: [key], dfun :: key -> val}
+
+{-@ data Dict key val val -> Prop>
+ = D ( ddom :: [key])
+ ( dfun :: i:key -> val)
+ @-}
diff --git a/tests/pos/Even.hs b/tests/pos/Even.hs
--- a/tests/pos/Even.hs
+++ b/tests/pos/Even.hs
@@ -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
diff --git a/tests/pos/GADTs.hs b/tests/pos/GADTs.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/GADTs.hs
@@ -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
diff --git a/tests/pos/GhcSort1.hs b/tests/pos/GhcSort1.hs
--- a/tests/pos/GhcSort1.hs
+++ b/tests/pos/GhcSort1.hs
@@ -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
-
-
diff --git a/tests/pos/GoodHMeas.hs b/tests/pos/GoodHMeas.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/GoodHMeas.hs
@@ -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
diff --git a/tests/pos/Gradual.hs b/tests/pos/Gradual.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/Gradual.hs
@@ -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
diff --git a/tests/pos/LambdaDeBruijn.hs b/tests/pos/LambdaDeBruijn.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/LambdaDeBruijn.hs
@@ -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
diff --git a/tests/pos/LambdaEval.hs b/tests/pos/LambdaEval.hs
--- a/tests/pos/LambdaEval.hs
+++ b/tests/pos/LambdaEval.hs
@@ -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)
diff --git a/tests/pos/ListQSort-LType.hs b/tests/pos/ListQSort-LType.hs
--- a/tests/pos/ListQSort-LType.hs
+++ b/tests/pos/ListQSort-LType.hs
@@ -2,9 +2,9 @@
import Language.Haskell.Liquid.Prelude
-{-@
-data List [llen] a
x1:a -> Prop>
- = Nil
+{-@
+data List [llen] a
x1:a -> Prop>
+ = Nil
| Cons (h :: a) (t :: List
(a
))
@-}
@@ -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: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
diff --git a/tests/pos/Merge1.hs b/tests/pos/Merge1.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/Merge1.hs
@@ -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
diff --git a/tests/pos/OrdList.hs b/tests/pos/OrdList.hs
--- a/tests/pos/OrdList.hs
+++ b/tests/pos/OrdList.hs
@@ -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
diff --git a/tests/pos/PairMeasure0.hs b/tests/pos/PairMeasure0.hs
--- a/tests/pos/PairMeasure0.hs
+++ b/tests/pos/PairMeasure0.hs
@@ -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
+
+
diff --git a/tests/pos/Product.hs b/tests/pos/Product.hs
--- a/tests/pos/Product.hs
+++ b/tests/pos/Product.hs
@@ -1,4 +1,3 @@
-{-@ LIQUID "--real" @-}
{-@ LIQUID "--total" @-}
diff --git a/tests/pos/Propability.hs b/tests/pos/Propability.hs
--- a/tests/pos/Propability.hs
+++ b/tests/pos/Propability.hs
@@ -1,7 +1,5 @@
module Propability where
-{-@ LIQUID "--real" @-}
-
{-@ type Propability = {v:Double | ((0.0 <= v) && (v <= 1.0)) } @-}
{-@ p :: Propability @-}
diff --git a/tests/pos/RBTree-col-height.hs b/tests/pos/RBTree-col-height.hs
--- a/tests/pos/RBTree-col-height.hs
+++ b/tests/pos/RBTree-col-height.hs
@@ -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)} @-}
diff --git a/tests/pos/RBTree-color.hs b/tests/pos/RBTree-color.hs
--- a/tests/pos/RBTree-color.hs
+++ b/tests/pos/RBTree-color.hs
@@ -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)} @-}
diff --git a/tests/pos/RBTree-height.hs b/tests/pos/RBTree-height.hs
--- a/tests/pos/RBTree-height.hs
+++ b/tests/pos/RBTree-height.hs
@@ -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)} @-}
diff --git a/tests/pos/RBTree.hs b/tests/pos/RBTree.hs
--- a/tests/pos/RBTree.hs
+++ b/tests/pos/RBTree.hs
@@ -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} @-}
diff --git a/tests/pos/RealProps.hs b/tests/pos/RealProps.hs
--- a/tests/pos/RealProps.hs
+++ b/tests/pos/RealProps.hs
@@ -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 ) } @-}
diff --git a/tests/pos/RealProps1.hs b/tests/pos/RealProps1.hs
--- a/tests/pos/RealProps1.hs
+++ b/tests/pos/RealProps1.hs
@@ -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 ) } @-}
diff --git a/tests/pos/ResolvePred.hs b/tests/pos/ResolvePred.hs
--- a/tests/pos/ResolvePred.hs
+++ b/tests/pos/ResolvePred.hs
@@ -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} @-}
diff --git a/tests/pos/StructRec.hs b/tests/pos/StructRec.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/StructRec.hs
@@ -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)
+
diff --git a/tests/pos/T531.hs b/tests/pos/T531.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/T531.hs
@@ -0,0 +1,6 @@
+module T531 where
+
+{-@
+data Foo = Foo { _getFoo :: Int }
+@-}
+data Foo = Foo { _getFoo :: Int }
diff --git a/tests/pos/T595.hs b/tests/pos/T595.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/T595.hs
@@ -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
diff --git a/tests/pos/T595a.hs b/tests/pos/T595a.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/T595a.hs
@@ -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 }
+ }
+ @-}
diff --git a/tests/pos/T598.hs b/tests/pos/T598.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/T598.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+import GHC.Generics (Generic)
+import Control.DeepSeq (NFData(..))
+
+data Point = Point
+ { x :: Int
+ } deriving (Generic)
+
+instance NFData Point
diff --git a/tests/pos/Words.hs b/tests/pos/Words.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/Words.hs
@@ -0,0 +1,5 @@
+import Data.Word
+
+{-@ foo :: {v:Word | v = 4} @-}
+foo :: Word
+foo = 4
diff --git a/tests/pos/Words1.hs b/tests/pos/Words1.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/Words1.hs
@@ -0,0 +1,3 @@
+import Data.Word
+
+main = print (quotRem (4 :: Word8) 128)
diff --git a/tests/pos/anish1.hs b/tests/pos/anish1.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/anish1.hs
@@ -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
diff --git a/tests/pos/csgordon_issue_296.hs b/tests/pos/csgordon_issue_296.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/csgordon_issue_296.hs
@@ -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
diff --git a/tests/pos/dropwhile.hs b/tests/pos/dropwhile.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/dropwhile.hs
@@ -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
Prop>. List
a -> a
@-}
+head (x ::: _) = x
+
+-------------------------------------------------------------------------------
+-- | A List
+-------------------------------------------------------------------------------
+
+data List a = Emp | (:::) { hd :: a
+ , tl :: List a }
+infixr 5 :::
+
+-------------------------------------------------------------------------------
+-- | A list whose head satisfies an abstract refinement `p`
+-------------------------------------------------------------------------------
+
+-- in the below, `hd :: a
` means the "head" is a value of type `a` that
+-- additionally, satisfies `p hd`.
+
+{-@ data List a
Prop> = Emp
+ | (:::) { hd :: a
+ , tl :: List a }
+ @-}
+
+-- | e.g. a list whose head equals `3`
+
+{-@ type OneList = List <{\v -> v == 3}> Int @-}
+
+{-@ one :: OneList @-}
+one :: List Int
+one = 3 ::: 2 ::: 1 ::: Emp
+
+-------------------------------------------------------------------------------
+-- | dropWhile some predicate `f` is not satisfied
+-------------------------------------------------------------------------------
+
+{-@ dropWhile :: forall
Prop, w :: a -> Bool -> Prop>.
+ (Witness a p w) =>
+ (x:a -> Bool) -> List a -> List
a
+ @-}
+dropWhile :: (a -> Bool) -> List a -> List a
+dropWhile f (x:::xs)
+ | not (f x) = x ::: xs
+ | otherwise = dropWhile f xs
+dropWhile f Emp = Emp
+
+-- | This `witness` bound relates the predicate used in dropWhile
+
+{-@ bound witness @-}
+witness :: Eq a => (a -> Bool) -> (a -> Bool -> Bool) -> a -> Bool -> a -> Bool
+witness p w = \ y b v -> (not b) ==> w y b ==> (v == y) ==> p v
+
+{-@ 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
diff --git a/tests/pos/gadtEval.hs b/tests/pos/gadtEval.hs
--- a/tests/pos/gadtEval.hs
+++ b/tests/pos/gadtEval.hs
@@ -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))
@-}
diff --git a/tests/pos/gimme.hs b/tests/pos/gimme.hs
--- a/tests/pos/gimme.hs
+++ b/tests/pos/gimme.hs
@@ -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)
diff --git a/tests/pos/hole-fun.hs b/tests/pos/hole-fun.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/hole-fun.hs
@@ -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
diff --git a/tests/pos/idNat.hs b/tests/pos/idNat.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/idNat.hs
@@ -0,0 +1,5 @@
+module IdNat where
+
+{-@ nat :: Nat @-}
+nat :: Int
+nat = id 0 -- (id (id (id (id 0))))
diff --git a/tests/pos/idNat0.hs b/tests/pos/idNat0.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/idNat0.hs
@@ -0,0 +1,8 @@
+module IdNat where
+
+{-@ nat :: Nat @-}
+nat :: Int
+nat = idd 0
+
+idd :: a -> a
+idd = undefined
diff --git a/tests/pos/listqual.hs b/tests/pos/listqual.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/listqual.hs
@@ -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]
diff --git a/tests/pos/nats.hs b/tests/pos/nats.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/nats.hs
@@ -0,0 +1,5 @@
+module Nats where
+
+{-@ nats :: [Nat] @-}
+nats :: [Int]
+nats = [1,2,3,4,5,6,7,8,9,10]
diff --git a/tests/pos/pair00.hs b/tests/pos/pair00.hs
--- a/tests/pos/pair00.hs
+++ b/tests/pos/pair00.hs
@@ -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 Nat @-}
+total :: Int -> Int
+total 0 = 0
+total n = 1 + total (n-1)
+
diff --git a/tests/pos/repeatHigherOrder.hs b/tests/pos/repeatHigherOrder.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/repeatHigherOrder.hs
@@ -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 a -> Prop, r :: Int -> a -> Prop>.
+ (Step a f r) =>
+ n:Nat -> (y:a -> a) -> a -> a
+ @-}
+repeat 0 _ x = x
+repeat n f x = repeat (n - 1) f (f x)
+
+{-@ goal :: n:Nat -> {r:Nat | n <= r} @-}
+goal n = repeat n (+ 1) 0
+
diff --git a/tests/pos/scanr.hs b/tests/pos/scanr.hs
--- a/tests/pos/scanr.hs
+++ b/tests/pos/scanr.hs
@@ -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
diff --git a/tests/pos/test00-int.hs b/tests/pos/test00-int.hs
--- a/tests/pos/test00-int.hs
+++ b/tests/pos/test00-int.hs
@@ -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
diff --git a/tests/pos/test00.hs b/tests/pos/test00.hs
--- a/tests/pos/test00.hs
+++ b/tests/pos/test00.hs
@@ -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
diff --git a/tests/pos/testRec.hs b/tests/pos/testRec.hs
--- a/tests/pos/testRec.hs
+++ b/tests/pos/testRec.hs
@@ -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
diff --git a/tests/pos/zipper0.hs b/tests/pos/zipper0.hs
--- a/tests/pos/zipper0.hs
+++ b/tests/pos/zipper0.hs
@@ -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
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/pos/zipper000.hs b/tests/pos/zipper000.hs
new file mode 100644
--- /dev/null
+++ b/tests/pos/zipper000.hs
@@ -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
diff --git a/tests/test.hs b/tests/test.hs
--- a/tests/test.hs
+++ b/tests/test.hs
@@ -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