{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, MagicHash #-}
module GHC.Runtime.Heap.Inspect(
cvObtainTerm,
cvReconstructType,
improveRTTIType,
Term(..),
isFullyEvaluatedTerm,
termType, mapTermType, termTyCoVars,
foldTerm, TermFold(..),
cPprTerm, cPprTermBase,
constrClosToName
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Platform
import GHC.Runtime.Interpreter as GHCi
import GHCi.RemoteTypes
import GHC.Driver.Env
import GHCi.Message ( fromSerializableException )
import GHC.Core.DataCon
import GHC.Core.Type
import GHC.Types.RepType
import GHC.Core.Multiplicity
import qualified GHC.Core.Unify as U
import GHC.Types.Var
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.Zonk ( zonkTcTypeToTypeX, mkEmptyZonkEnv, ZonkFlexi( RuntimeUnkFlexi ) )
import GHC.Tc.Utils.Unify
import GHC.Tc.Utils.Env
import GHC.Core.TyCon
import GHC.Types.Name
import GHC.Types.Name.Occurrence as OccName
import GHC.Unit.Module
import GHC.Iface.Env
import GHC.Utils.Misc
import GHC.Types.Var.Set
import GHC.Types.Basic ( Boxity(..) )
import GHC.Builtin.Types.Prim
import GHC.Builtin.Types
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Utils.Outputable as Ppr
import GHC.Utils.Panic
import GHC.Char
import GHC.Exts.Heap
import GHC.Runtime.Heap.Layout ( roundUpTo )
import GHC.IO (throwIO)
import Control.Monad
import Data.Maybe
import Data.List ((\\))
import GHC.Exts
import qualified Data.Sequence as Seq
import Data.Sequence (viewl, ViewL(..))
import Foreign hiding (shiftL, shiftR)
import System.IO.Unsafe
data Term = Term { Term -> Type
ty :: RttiType
, Term -> Either String DataCon
dc :: Either String DataCon
, Term -> ForeignHValue
val :: ForeignHValue
, Term -> [Term]
subTerms :: [Term] }
| Prim { ty :: RttiType
, Term -> [Word]
valRaw :: [Word] }
| Suspension { Term -> ClosureType
ctype :: ClosureType
, ty :: RttiType
, val :: ForeignHValue
, Term -> Maybe Name
bound_to :: Maybe Name
}
| NewtypeWrap{
ty :: RttiType
, dc :: Either String DataCon
, Term -> Term
wrapped_term :: Term }
| RefWrap {
ty :: RttiType
, wrapped_term :: Term }
termType :: Term -> RttiType
termType :: Term -> Type
termType Term
t = Term -> Type
ty Term
t
isFullyEvaluatedTerm :: Term -> Bool
isFullyEvaluatedTerm :: Term -> Bool
isFullyEvaluatedTerm Term {subTerms :: Term -> [Term]
subTerms=[Term]
tt} = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Term -> Bool
isFullyEvaluatedTerm [Term]
tt
isFullyEvaluatedTerm Prim {} = Bool
True
isFullyEvaluatedTerm NewtypeWrap{wrapped_term :: Term -> Term
wrapped_term=Term
t} = Term -> Bool
isFullyEvaluatedTerm Term
t
isFullyEvaluatedTerm RefWrap{wrapped_term :: Term -> Term
wrapped_term=Term
t} = Term -> Bool
isFullyEvaluatedTerm Term
t
isFullyEvaluatedTerm Term
_ = Bool
False
instance Outputable (Term) where
ppr :: Term -> SDoc
ppr Term
t | Just SDoc
doc <- forall (m :: * -> *).
Monad m =>
CustomTermPrinter m -> Term -> m SDoc
cPprTerm forall (m :: * -> *). Monad m => CustomTermPrinter m
cPprTermBase Term
t = SDoc
doc
| Bool
otherwise = forall a. String -> a
panic String
"Outputable Term instance"
isThunk :: GenClosure a -> Bool
isThunk :: forall a. GenClosure a -> Bool
isThunk ThunkClosure{} = Bool
True
isThunk APClosure{} = Bool
True
isThunk APStackClosure{} = Bool
True
isThunk GenClosure a
_ = Bool
False
constrClosToName :: HscEnv -> GenClosure a -> IO (Either String Name)
constrClosToName :: forall a. HscEnv -> GenClosure a -> IO (Either String Name)
constrClosToName HscEnv
hsc_env ConstrClosure{pkg :: forall b. GenClosure b -> String
pkg=String
pkg,modl :: forall b. GenClosure b -> String
modl=String
mod,name :: forall b. GenClosure b -> String
name=String
occ} = do
let occName :: OccName
occName = NameSpace -> String -> OccName
mkOccName NameSpace
OccName.dataName String
occ
modName :: GenModule Unit
modName = forall u. u -> ModuleName -> GenModule u
mkModule (String -> Unit
stringToUnit String
pkg) (String -> ModuleName
mkModuleName String
mod)
forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` HscEnv -> GenModule Unit -> OccName -> IO Name
lookupOrigIO HscEnv
hsc_env GenModule Unit
modName OccName
occName
constrClosToName HscEnv
_hsc_env GenClosure a
clos =
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (String
"conClosToName: Expected ConstrClosure, got " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const ()) GenClosure a
clos)))
type TermProcessor a b = RttiType -> Either String DataCon -> ForeignHValue -> [a] -> b
data TermFold a = TermFold { forall a. TermFold a -> TermProcessor a a
fTerm :: TermProcessor a a
, forall a. TermFold a -> Type -> [Word] -> a
fPrim :: RttiType -> [Word] -> a
, forall a.
TermFold a
-> ClosureType -> Type -> ForeignHValue -> Maybe Name -> a
fSuspension :: ClosureType -> RttiType -> ForeignHValue
-> Maybe Name -> a
, forall a. TermFold a -> Type -> Either String DataCon -> a -> a
fNewtypeWrap :: RttiType -> Either String DataCon
-> a -> a
, forall a. TermFold a -> Type -> a -> a
fRefWrap :: RttiType -> a -> a
}
data TermFoldM m a =
TermFoldM {forall (m :: * -> *) a. TermFoldM m a -> TermProcessor a (m a)
fTermM :: TermProcessor a (m a)
, forall (m :: * -> *) a. TermFoldM m a -> Type -> [Word] -> m a
fPrimM :: RttiType -> [Word] -> m a
, forall (m :: * -> *) a.
TermFoldM m a
-> ClosureType -> Type -> ForeignHValue -> Maybe Name -> m a
fSuspensionM :: ClosureType -> RttiType -> ForeignHValue
-> Maybe Name -> m a
, forall (m :: * -> *) a.
TermFoldM m a -> Type -> Either String DataCon -> a -> m a
fNewtypeWrapM :: RttiType -> Either String DataCon
-> a -> m a
, forall (m :: * -> *) a. TermFoldM m a -> Type -> a -> m a
fRefWrapM :: RttiType -> a -> m a
}
foldTerm :: TermFold a -> Term -> a
foldTerm :: forall a. TermFold a -> Term -> a
foldTerm TermFold a
tf (Term Type
ty Either String DataCon
dc ForeignHValue
v [Term]
tt) = forall a. TermFold a -> TermProcessor a a
fTerm TermFold a
tf Type
ty Either String DataCon
dc ForeignHValue
v (forall a b. (a -> b) -> [a] -> [b]
map (forall a. TermFold a -> Term -> a
foldTerm TermFold a
tf) [Term]
tt)
foldTerm TermFold a
tf (Prim Type
ty [Word]
v ) = forall a. TermFold a -> Type -> [Word] -> a
fPrim TermFold a
tf Type
ty [Word]
v
foldTerm TermFold a
tf (Suspension ClosureType
ct Type
ty ForeignHValue
v Maybe Name
b) = forall a.
TermFold a
-> ClosureType -> Type -> ForeignHValue -> Maybe Name -> a
fSuspension TermFold a
tf ClosureType
ct Type
ty ForeignHValue
v Maybe Name
b
foldTerm TermFold a
tf (NewtypeWrap Type
ty Either String DataCon
dc Term
t) = forall a. TermFold a -> Type -> Either String DataCon -> a -> a
fNewtypeWrap TermFold a
tf Type
ty Either String DataCon
dc (forall a. TermFold a -> Term -> a
foldTerm TermFold a
tf Term
t)
foldTerm TermFold a
tf (RefWrap Type
ty Term
t) = forall a. TermFold a -> Type -> a -> a
fRefWrap TermFold a
tf Type
ty (forall a. TermFold a -> Term -> a
foldTerm TermFold a
tf Term
t)
foldTermM :: Monad m => TermFoldM m a -> Term -> m a
foldTermM :: forall (m :: * -> *) a. Monad m => TermFoldM m a -> Term -> m a
foldTermM TermFoldM m a
tf (Term Type
ty Either String DataCon
dc ForeignHValue
v [Term]
tt) = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a. Monad m => TermFoldM m a -> Term -> m a
foldTermM TermFoldM m a
tf) [Term]
tt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. TermFoldM m a -> TermProcessor a (m a)
fTermM TermFoldM m a
tf Type
ty Either String DataCon
dc ForeignHValue
v
foldTermM TermFoldM m a
tf (Prim Type
ty [Word]
v ) = forall (m :: * -> *) a. TermFoldM m a -> Type -> [Word] -> m a
fPrimM TermFoldM m a
tf Type
ty [Word]
v
foldTermM TermFoldM m a
tf (Suspension ClosureType
ct Type
ty ForeignHValue
v Maybe Name
b) = forall (m :: * -> *) a.
TermFoldM m a
-> ClosureType -> Type -> ForeignHValue -> Maybe Name -> m a
fSuspensionM TermFoldM m a
tf ClosureType
ct Type
ty ForeignHValue
v Maybe Name
b
foldTermM TermFoldM m a
tf (NewtypeWrap Type
ty Either String DataCon
dc Term
t) = forall (m :: * -> *) a. Monad m => TermFoldM m a -> Term -> m a
foldTermM TermFoldM m a
tf Term
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a.
TermFoldM m a -> Type -> Either String DataCon -> a -> m a
fNewtypeWrapM TermFoldM m a
tf Type
ty Either String DataCon
dc
foldTermM TermFoldM m a
tf (RefWrap Type
ty Term
t) = forall (m :: * -> *) a. Monad m => TermFoldM m a -> Term -> m a
foldTermM TermFoldM m a
tf Term
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. TermFoldM m a -> Type -> a -> m a
fRefWrapM TermFoldM m a
tf Type
ty
idTermFold :: TermFold Term
idTermFold :: TermFold Term
idTermFold = TermFold {
fTerm :: TermProcessor Term Term
fTerm = TermProcessor Term Term
Term,
fPrim :: Type -> [Word] -> Term
fPrim = Type -> [Word] -> Term
Prim,
fSuspension :: ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
fSuspension = ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
Suspension,
fNewtypeWrap :: Type -> Either String DataCon -> Term -> Term
fNewtypeWrap = Type -> Either String DataCon -> Term -> Term
NewtypeWrap,
fRefWrap :: Type -> Term -> Term
fRefWrap = Type -> Term -> Term
RefWrap
}
mapTermType :: (RttiType -> Type) -> Term -> Term
mapTermType :: (Type -> Type) -> Term -> Term
mapTermType Type -> Type
f = forall a. TermFold a -> Term -> a
foldTerm TermFold Term
idTermFold {
fTerm :: TermProcessor Term Term
fTerm = \Type
ty Either String DataCon
dc ForeignHValue
hval [Term]
tt -> TermProcessor Term Term
Term (Type -> Type
f Type
ty) Either String DataCon
dc ForeignHValue
hval [Term]
tt,
fSuspension :: ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
fSuspension = \ClosureType
ct Type
ty ForeignHValue
hval Maybe Name
n ->
ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
Suspension ClosureType
ct (Type -> Type
f Type
ty) ForeignHValue
hval Maybe Name
n,
fNewtypeWrap :: Type -> Either String DataCon -> Term -> Term
fNewtypeWrap= \Type
ty Either String DataCon
dc Term
t -> Type -> Either String DataCon -> Term -> Term
NewtypeWrap (Type -> Type
f Type
ty) Either String DataCon
dc Term
t,
fRefWrap :: Type -> Term -> Term
fRefWrap = \Type
ty Term
t -> Type -> Term -> Term
RefWrap (Type -> Type
f Type
ty) Term
t}
mapTermTypeM :: Monad m => (RttiType -> m Type) -> Term -> m Term
mapTermTypeM :: forall (m :: * -> *). Monad m => (Type -> m Type) -> Term -> m Term
mapTermTypeM Type -> m Type
f = forall (m :: * -> *) a. Monad m => TermFoldM m a -> Term -> m a
foldTermM TermFoldM {
fTermM :: TermProcessor Term (m Term)
fTermM = \Type
ty Either String DataCon
dc ForeignHValue
hval [Term]
tt -> Type -> m Type
f Type
ty forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type
ty' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TermProcessor Term Term
Term Type
ty' Either String DataCon
dc ForeignHValue
hval [Term]
tt,
fPrimM :: Type -> [Word] -> m Term
fPrimM = (forall (m :: * -> *) a. Monad m => a -> m a
returnforall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> [Word] -> Term
Prim,
fSuspensionM :: ClosureType -> Type -> ForeignHValue -> Maybe Name -> m Term
fSuspensionM = \ClosureType
ct Type
ty ForeignHValue
hval Maybe Name
n ->
Type -> m Type
f Type
ty forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type
ty' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
Suspension ClosureType
ct Type
ty' ForeignHValue
hval Maybe Name
n,
fNewtypeWrapM :: Type -> Either String DataCon -> Term -> m Term
fNewtypeWrapM= \Type
ty Either String DataCon
dc Term
t -> Type -> m Type
f Type
ty forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type
ty' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> Either String DataCon -> Term -> Term
NewtypeWrap Type
ty' Either String DataCon
dc Term
t,
fRefWrapM :: Type -> Term -> m Term
fRefWrapM = \Type
ty Term
t -> Type -> m Type
f Type
ty forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type
ty' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> Term -> Term
RefWrap Type
ty' Term
t}
termTyCoVars :: Term -> TyCoVarSet
termTyCoVars :: Term -> TyCoVarSet
termTyCoVars = forall a. TermFold a -> Term -> a
foldTerm TermFold {
fTerm :: TermProcessor TyCoVarSet TyCoVarSet
fTerm = \Type
ty Either String DataCon
_ ForeignHValue
_ [TyCoVarSet]
tt ->
Type -> TyCoVarSet
tyCoVarsOfType Type
ty TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` [TyCoVarSet] -> TyCoVarSet
concatVarEnv [TyCoVarSet]
tt,
fSuspension :: ClosureType -> Type -> ForeignHValue -> Maybe Name -> TyCoVarSet
fSuspension = \ClosureType
_ Type
ty ForeignHValue
_ Maybe Name
_ -> Type -> TyCoVarSet
tyCoVarsOfType Type
ty,
fPrim :: Type -> [Word] -> TyCoVarSet
fPrim = \ Type
_ [Word]
_ -> TyCoVarSet
emptyVarSet,
fNewtypeWrap :: Type -> Either String DataCon -> TyCoVarSet -> TyCoVarSet
fNewtypeWrap= \Type
ty Either String DataCon
_ TyCoVarSet
t -> Type -> TyCoVarSet
tyCoVarsOfType Type
ty TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` TyCoVarSet
t,
fRefWrap :: Type -> TyCoVarSet -> TyCoVarSet
fRefWrap = \Type
ty TyCoVarSet
t -> Type -> TyCoVarSet
tyCoVarsOfType Type
ty TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` TyCoVarSet
t}
where concatVarEnv :: [TyCoVarSet] -> TyCoVarSet
concatVarEnv = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TyCoVarSet -> TyCoVarSet -> TyCoVarSet
unionVarSet TyCoVarSet
emptyVarSet
type Precedence = Int
type TermPrinterM m = Precedence -> Term -> m SDoc
app_prec,cons_prec, max_prec ::Int
max_prec :: Int
max_prec = Int
10
app_prec :: Int
app_prec = Int
max_prec
cons_prec :: Int
cons_prec = Int
5
pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
pprTermM :: forall (m :: * -> *). Monad m => TermPrinterM m -> TermPrinterM m
pprTermM TermPrinterM m
y Int
p Term
t = SDoc -> SDoc
pprDeeper forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (m :: * -> *). Monad m => TermPrinterM m -> TermPrinterM m
ppr_termM TermPrinterM m
y Int
p Term
t
ppr_termM :: forall (m :: * -> *). Monad m => TermPrinterM m -> TermPrinterM m
ppr_termM TermPrinterM m
y Int
p Term{dc :: Term -> Either String DataCon
dc=Left String
dc_tag, subTerms :: Term -> [Term]
subTerms=[Term]
tt} = do
[SDoc]
tt_docs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TermPrinterM m
y Int
app_prec) [Term]
tt
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> SDoc -> SDoc
cparen (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Term]
tt) Bool -> Bool -> Bool
&& Int
p forall a. Ord a => a -> a -> Bool
>= Int
app_prec)
(String -> SDoc
text String
dc_tag SDoc -> SDoc -> SDoc
<+> ([SDoc] -> SDoc) -> [SDoc] -> SDoc
pprDeeperList [SDoc] -> SDoc
fsep [SDoc]
tt_docs)
ppr_termM TermPrinterM m
y Int
p Term{dc :: Term -> Either String DataCon
dc=Right DataCon
dc, subTerms :: Term -> [Term]
subTerms=[Term]
tt}
= do { [SDoc]
tt_docs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TermPrinterM m
y Int
app_prec) [Term]
tt
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc -> SDoc
ifPprDebug ([SDoc] -> SDoc
show_tm [SDoc]
tt_docs')
([SDoc] -> SDoc
show_tm (forall b a. [b] -> [a] -> [a]
dropList (DataCon -> [Type]
dataConTheta DataCon
dc) [SDoc]
tt_docs'))
}
where
show_tm :: [SDoc] -> SDoc
show_tm [SDoc]
tt_docs
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SDoc]
tt_docs = forall a. Outputable a => a -> SDoc
ppr DataCon
dc
| Bool
otherwise = Bool -> SDoc -> SDoc
cparen (Int
p forall a. Ord a => a -> a -> Bool
>= Int
app_prec) forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
sep [forall a. Outputable a => a -> SDoc
ppr DataCon
dc, Int -> SDoc -> SDoc
nest Int
2 (([SDoc] -> SDoc) -> [SDoc] -> SDoc
pprDeeperList [SDoc] -> SDoc
fsep [SDoc]
tt_docs)]
ppr_termM TermPrinterM m
y Int
p t :: Term
t@NewtypeWrap{} = forall (m :: * -> *). Monad m => TermPrinterM m -> TermPrinterM m
pprNewtypeWrap TermPrinterM m
y Int
p Term
t
ppr_termM TermPrinterM m
y Int
p RefWrap{wrapped_term :: Term -> Term
wrapped_term=Term
t} = do
SDoc
contents <- TermPrinterM m
y Int
app_prec Term
t
forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ Bool -> SDoc -> SDoc
cparen (Int
p forall a. Ord a => a -> a -> Bool
>= Int
app_prec) (String -> SDoc
text String
"GHC.Prim.MutVar#" SDoc -> SDoc -> SDoc
<+> SDoc
contents)
ppr_termM TermPrinterM m
_ Int
_ Term
t = forall (m :: * -> *). Monad m => Term -> m SDoc
ppr_termM1 Term
t
ppr_termM1 :: Monad m => Term -> m SDoc
ppr_termM1 :: forall (m :: * -> *). Monad m => Term -> m SDoc
ppr_termM1 Prim{valRaw :: Term -> [Word]
valRaw=[Word]
words, ty :: Term -> Type
ty=Type
ty} =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TyCon -> [Word] -> SDoc
repPrim (Type -> TyCon
tyConAppTyCon Type
ty) [Word]
words
ppr_termM1 Suspension{ty :: Term -> Type
ty=Type
ty, bound_to :: Term -> Maybe Name
bound_to=Maybe Name
Nothing} =
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> SDoc
char Char
'_' SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
whenPprDebug (String -> SDoc
text String
"::" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Type
ty))
ppr_termM1 Suspension{ty :: Term -> Type
ty=Type
ty, bound_to :: Term -> Maybe Name
bound_to=Just Name
n}
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ SDoc -> SDoc
parensforall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr Name
n SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"::" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Type
ty
ppr_termM1 Term{} = forall a. String -> a
panic String
"ppr_termM1 - Term"
ppr_termM1 RefWrap{} = forall a. String -> a
panic String
"ppr_termM1 - RefWrap"
ppr_termM1 NewtypeWrap{} = forall a. String -> a
panic String
"ppr_termM1 - NewtypeWrap"
pprNewtypeWrap :: forall (m :: * -> *). Monad m => TermPrinterM m -> TermPrinterM m
pprNewtypeWrap TermPrinterM m
y Int
p NewtypeWrap{ty :: Term -> Type
ty=Type
ty, wrapped_term :: Term -> Term
wrapped_term=Term
t}
| Just (TyCon
tc,[Type]
_) <- HasCallStack => Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty
, ASSERT(isNewTyCon tc) True
, Just DataCon
new_dc <- TyCon -> Maybe DataCon
tyConSingleDataCon_maybe TyCon
tc = do
SDoc
real_term <- TermPrinterM m
y Int
max_prec Term
t
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> SDoc -> SDoc
cparen (Int
p forall a. Ord a => a -> a -> Bool
>= Int
app_prec) (forall a. Outputable a => a -> SDoc
ppr DataCon
new_dc SDoc -> SDoc -> SDoc
<+> SDoc
real_term)
pprNewtypeWrap TermPrinterM m
_ Int
_ Term
_ = forall a. String -> a
panic String
"pprNewtypeWrap"
type CustomTermPrinter m = TermPrinterM m
-> [Precedence -> Term -> (m (Maybe SDoc))]
cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
cPprTerm :: forall (m :: * -> *).
Monad m =>
CustomTermPrinter m -> Term -> m SDoc
cPprTerm CustomTermPrinter m
printers_ = TermPrinterM m
go Int
0 where
printers :: [Int -> Term -> m (Maybe SDoc)]
printers = CustomTermPrinter m
printers_ TermPrinterM m
go
go :: TermPrinterM m
go Int
prec Term
t = do
let default_ :: m (Maybe SDoc)
default_ = forall a. a -> Maybe a
Just forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (m :: * -> *). Monad m => TermPrinterM m -> TermPrinterM m
pprTermM TermPrinterM m
go Int
prec Term
t
mb_customDocs :: [m (Maybe SDoc)]
mb_customDocs = [Int -> Term -> m (Maybe SDoc)
pp Int
prec Term
t | Int -> Term -> m (Maybe SDoc)
pp <- [Int -> Term -> m (Maybe SDoc)]
printers] forall a. [a] -> [a] -> [a]
++ [m (Maybe SDoc)
default_]
Maybe SDoc
mdoc <- forall {m :: * -> *} {a}. Monad m => [m (Maybe a)] -> m (Maybe a)
firstJustM [m (Maybe SDoc)]
mb_customDocs
case Maybe SDoc
mdoc of
Maybe SDoc
Nothing -> forall a. String -> a
panic String
"cPprTerm"
Just SDoc
doc -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> SDoc -> SDoc
cparen (Int
precforall a. Ord a => a -> a -> Bool
>Int
app_precforall a. Num a => a -> a -> a
+Int
1) SDoc
doc
firstJustM :: [m (Maybe a)] -> m (Maybe a)
firstJustM (m (Maybe a)
mb:[m (Maybe a)]
mbs) = m (Maybe a)
mb forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([m (Maybe a)] -> m (Maybe a)
firstJustM [m (Maybe a)]
mbs) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just)
firstJustM [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
cPprTermBase :: forall m. Monad m => CustomTermPrinter m
cPprTermBase :: forall (m :: * -> *). Monad m => CustomTermPrinter m
cPprTermBase TermPrinterM m
y =
[ (Term -> Bool) -> TermPrinterM m -> Int -> Term -> m (Maybe SDoc)
ifTerm (Type -> Bool
isTupleTyforall b c a. (b -> c) -> (a -> b) -> a -> c
.Term -> Type
ty) (\Int
_p -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (SDoc -> SDoc
parens forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
hcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TermPrinterM m
y (-Int
1))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> [Term]
subTerms)
, (Term -> Bool) -> TermPrinterM m -> Int -> Term -> m (Maybe SDoc)
ifTerm (\Term
t -> TyCon -> Type -> Bool
isTyCon TyCon
listTyCon (Term -> Type
ty Term
t) Bool -> Bool -> Bool
&& Term -> [Term]
subTerms Term
t forall a. [a] -> Int -> Bool
`lengthIs` Int
2)
TermPrinterM m
ppr_list
, (Term -> Bool)
-> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
ifTerm' (TyCon -> Type -> Bool
isTyCon TyCon
intTyCon forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Type
ty) Int -> Term -> m (Maybe SDoc)
ppr_int
, (Term -> Bool)
-> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
ifTerm' (TyCon -> Type -> Bool
isTyCon TyCon
charTyCon forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Type
ty) Int -> Term -> m (Maybe SDoc)
ppr_char
, (Term -> Bool)
-> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
ifTerm' (TyCon -> Type -> Bool
isTyCon TyCon
floatTyCon forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Type
ty) Int -> Term -> m (Maybe SDoc)
ppr_float
, (Term -> Bool)
-> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
ifTerm' (TyCon -> Type -> Bool
isTyCon TyCon
doubleTyCon forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Type
ty) Int -> Term -> m (Maybe SDoc)
ppr_double
, (Term -> Bool)
-> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
ifTerm' (TyCon -> Type -> Bool
isTyCon TyCon
integerTyCon forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Type
ty) Int -> Term -> m (Maybe SDoc)
ppr_integer
, (Term -> Bool)
-> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
ifTerm' (TyCon -> Type -> Bool
isTyCon TyCon
naturalTyCon forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Type
ty) Int -> Term -> m (Maybe SDoc)
ppr_natural
]
where
ifTerm :: (Term -> Bool)
-> (Precedence -> Term -> m SDoc)
-> Precedence -> Term -> m (Maybe SDoc)
ifTerm :: (Term -> Bool) -> TermPrinterM m -> Int -> Term -> m (Maybe SDoc)
ifTerm Term -> Bool
pred TermPrinterM m
f = (Term -> Bool)
-> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
ifTerm' Term -> Bool
pred (\Int
prec Term
t -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermPrinterM m
f Int
prec Term
t)
ifTerm' :: (Term -> Bool)
-> (Precedence -> Term -> m (Maybe SDoc))
-> Precedence -> Term -> m (Maybe SDoc)
ifTerm' :: (Term -> Bool)
-> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
ifTerm' Term -> Bool
pred Int -> Term -> m (Maybe SDoc)
f Int
prec t :: Term
t@Term{}
| Term -> Bool
pred Term
t = Int -> Term -> m (Maybe SDoc)
f Int
prec Term
t
ifTerm' Term -> Bool
_ Int -> Term -> m (Maybe SDoc)
_ Int
_ Term
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
isTupleTy :: Type -> Bool
isTupleTy Type
ty = forall a. a -> Maybe a -> a
fromMaybe Bool
False forall a b. (a -> b) -> a -> b
$ do
(TyCon
tc,[Type]
_) <- HasCallStack => Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> Bool
isBoxedTupleTyCon TyCon
tc)
isTyCon :: TyCon -> Type -> Bool
isTyCon TyCon
a_tc Type
ty = forall a. a -> Maybe a -> a
fromMaybe Bool
False forall a b. (a -> b) -> a -> b
$ do
(TyCon
tc,[Type]
_) <- HasCallStack => Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon
a_tc forall a. Eq a => a -> a -> Bool
== TyCon
tc)
ppr_int, ppr_char, ppr_float, ppr_double
:: Precedence -> Term -> m (Maybe SDoc)
ppr_int :: Int -> Term -> m (Maybe SDoc)
ppr_int Int
_ Term{subTerms :: Term -> [Term]
subTerms=[Prim{valRaw :: Term -> [Word]
valRaw=[Word
w]}]} =
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Int -> SDoc
Ppr.int (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w)))
ppr_int Int
_ Term
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
ppr_char :: Int -> Term -> m (Maybe SDoc)
ppr_char Int
_ Term{subTerms :: Term -> [Term]
subTerms=[Prim{valRaw :: Term -> [Word]
valRaw=[Word
w]}]} =
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Char -> SDoc
Ppr.pprHsChar (Int -> Char
chr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w))))
ppr_char Int
_ Term
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
ppr_float :: Int -> Term -> m (Maybe SDoc)
ppr_float Int
_ Term{subTerms :: Term -> [Term]
subTerms=[Prim{valRaw :: Term -> [Word]
valRaw=[Word
w]}]} = do
let f :: Float
f = forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr Word
p -> forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word
p Word
w forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Storable a => Ptr a -> IO a
peek (forall a b. Ptr a -> Ptr b
castPtr Ptr Word
p)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Float -> SDoc
Ppr.float Float
f))
ppr_float Int
_ Term
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
ppr_double :: Int -> Term -> m (Maybe SDoc)
ppr_double Int
_ Term{subTerms :: Term -> [Term]
subTerms=[Prim{valRaw :: Term -> [Word]
valRaw=[Word
w]}]} = do
let f :: Double
f = forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr Word
p -> forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word
p Word
w forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Storable a => Ptr a -> IO a
peek (forall a b. Ptr a -> Ptr b
castPtr Ptr Word
p)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Double -> SDoc
Ppr.double Double
f))
ppr_double Int
_ Term{subTerms :: Term -> [Term]
subTerms=[Prim{valRaw :: Term -> [Word]
valRaw=[Word
w1,Word
w2]}]} = do
let f :: Double
f = forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr Word32
p -> do
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word32
p (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w1 :: Word32)
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word32
p forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
4) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w2 :: Word32)
forall a. Storable a => Ptr a -> IO a
peek (forall a b. Ptr a -> Ptr b
castPtr Ptr Word32
p)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Double -> SDoc
Ppr.double Double
f))
ppr_double Int
_ Term
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
ppr_bignat :: Bool -> Precedence -> [Word] -> m (Maybe SDoc)
ppr_bignat :: Bool -> Int -> [Word] -> m (Maybe SDoc)
ppr_bignat Bool
sign Int
_ [Word]
ws = do
let
wordSize :: Int
wordSize = forall b. FiniteBits b => b -> Int
finiteBitSize (Word
0 :: Word)
makeInteger :: t -> Int -> [a] -> t
makeInteger t
n Int
_ [] = t
n
makeInteger t
n Int
s (a
x:[a]
xs) = t -> Int -> [a] -> t
makeInteger (t
n forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x forall a. Bits a => a -> Int -> a
`shiftL` Int
s)) (Int
s forall a. Num a => a -> a -> a
+ Int
wordSize) [a]
xs
signf :: Integer
signf = case Bool
sign of
Bool
False -> Integer
1
Bool
True -> -Integer
1
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> SDoc
Ppr.integer forall a b. (a -> b) -> a -> b
$ Integer
signf forall a. Num a => a -> a -> a
* (forall {t} {a}. (Bits t, Integral a, Num t) => t -> Int -> [a] -> t
makeInteger Integer
0 Int
0 [Word]
ws)
ppr_integer :: Precedence -> Term -> m (Maybe SDoc)
ppr_integer :: Int -> Term -> m (Maybe SDoc)
ppr_integer Int
_ Term{dc :: Term -> Either String DataCon
dc=Right DataCon
con, subTerms :: Term -> [Term]
subTerms=[Prim{valRaw :: Term -> [Word]
valRaw=[Word]
ws}]}
| DataCon
con forall a. Eq a => a -> a -> Bool
== DataCon
integerISDataCon
, [W# Word#
w] <- [Word]
ws
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Integer -> SDoc
Ppr.integer (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int# -> Int
I# (Word# -> Int#
word2Int# Word#
w)))))
ppr_integer Int
p Term{dc :: Term -> Either String DataCon
dc=Right DataCon
con, subTerms :: Term -> [Term]
subTerms=[Term{subTerms :: Term -> [Term]
subTerms=[Prim{valRaw :: Term -> [Word]
valRaw=[Word]
ws}]}]}
| DataCon
con forall a. Eq a => a -> a -> Bool
== DataCon
integerIPDataCon = Bool -> Int -> [Word] -> m (Maybe SDoc)
ppr_bignat Bool
False Int
p [Word]
ws
| DataCon
con forall a. Eq a => a -> a -> Bool
== DataCon
integerINDataCon = Bool -> Int -> [Word] -> m (Maybe SDoc)
ppr_bignat Bool
True Int
p [Word]
ws
| Bool
otherwise = forall a. String -> a
panic String
"Unexpected Integer constructor"
ppr_integer Int
_ Term
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
ppr_natural :: Precedence -> Term -> m (Maybe SDoc)
ppr_natural :: Int -> Term -> m (Maybe SDoc)
ppr_natural Int
_ Term{dc :: Term -> Either String DataCon
dc=Right DataCon
con, subTerms :: Term -> [Term]
subTerms=[Prim{valRaw :: Term -> [Word]
valRaw=[Word]
ws}]}
| DataCon
con forall a. Eq a => a -> a -> Bool
== DataCon
naturalNSDataCon
, [Word
w] <- [Word]
ws
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Integer -> SDoc
Ppr.integer (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w)))
ppr_natural Int
p Term{dc :: Term -> Either String DataCon
dc=Right DataCon
con, subTerms :: Term -> [Term]
subTerms=[Term{subTerms :: Term -> [Term]
subTerms=[Prim{valRaw :: Term -> [Word]
valRaw=[Word]
ws}]}]}
| DataCon
con forall a. Eq a => a -> a -> Bool
== DataCon
naturalNBDataCon = Bool -> Int -> [Word] -> m (Maybe SDoc)
ppr_bignat Bool
False Int
p [Word]
ws
| Bool
otherwise = forall a. String -> a
panic String
"Unexpected Natural constructor"
ppr_natural Int
_ Term
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
ppr_list :: Precedence -> Term -> m SDoc
ppr_list :: TermPrinterM m
ppr_list Int
p (Term{subTerms :: Term -> [Term]
subTerms=[Term
h,Term
t]}) = do
let elems :: [Term]
elems = Term
h forall a. a -> [a] -> [a]
: Term -> [Term]
getListTerms Term
t
isConsLast :: Bool
isConsLast = Bool -> Bool
not (Term -> Type
termType (forall a. [a] -> a
last [Term]
elems) Type -> Type -> Bool
`eqType` Term -> Type
termType Term
h)
is_string :: Bool
is_string = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Type -> Bool
isCharTy forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Type
ty) [Term]
elems
chars :: String
chars = [ Int -> Char
chr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w)
| Term{subTerms :: Term -> [Term]
subTerms=[Prim{valRaw :: Term -> [Word]
valRaw=[Word
w]}]} <- [Term]
elems ]
[SDoc]
print_elems <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TermPrinterM m
y Int
cons_prec) [Term]
elems
if Bool
is_string
then forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> SDoc
Ppr.doubleQuotes (String -> SDoc
Ppr.text String
chars))
else if Bool
isConsLast
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> SDoc -> SDoc
cparen (Int
p forall a. Ord a => a -> a -> Bool
>= Int
cons_prec)
forall a b. (a -> b) -> a -> b
$ ([SDoc] -> SDoc) -> [SDoc] -> SDoc
pprDeeperList [SDoc] -> SDoc
fsep
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate (SDoc
spaceSDoc -> SDoc -> SDoc
<>SDoc
colon) [SDoc]
print_elems
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc
brackets
forall a b. (a -> b) -> a -> b
$ ([SDoc] -> SDoc) -> [SDoc] -> SDoc
pprDeeperList [SDoc] -> SDoc
fcat
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma [SDoc]
print_elems
where getListTerms :: Term -> [Term]
getListTerms Term{subTerms :: Term -> [Term]
subTerms=[Term
h,Term
t]} = Term
h forall a. a -> [a] -> [a]
: Term -> [Term]
getListTerms Term
t
getListTerms Term{subTerms :: Term -> [Term]
subTerms=[]} = []
getListTerms t :: Term
t@Suspension{} = [Term
t]
getListTerms Term
t = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getListTerms" (forall a. Outputable a => a -> SDoc
ppr Term
t)
ppr_list Int
_ Term
_ = forall a. String -> a
panic String
"doList"
repPrim :: TyCon -> [Word] -> SDoc
repPrim :: TyCon -> [Word] -> SDoc
repPrim TyCon
t = [Word] -> SDoc
rep where
rep :: [Word] -> SDoc
rep [Word]
x
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
charPrimTyCon = String -> SDoc
text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (Int -> Char
chr (forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Int))
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
intPrimTyCon = String -> SDoc
text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Int)
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
wordPrimTyCon = String -> SDoc
text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Word)
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
floatPrimTyCon = String -> SDoc
text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Float)
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
doublePrimTyCon = String -> SDoc
text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Double)
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
int8PrimTyCon = String -> SDoc
text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Int8)
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
word8PrimTyCon = String -> SDoc
text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Word8)
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
int16PrimTyCon = String -> SDoc
text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Int16)
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
word16PrimTyCon = String -> SDoc
text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Word16)
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
int32PrimTyCon = String -> SDoc
text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Int32)
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
word32PrimTyCon = String -> SDoc
text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Word32)
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
int64PrimTyCon = String -> SDoc
text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Int64)
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
word64PrimTyCon = String -> SDoc
text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Word64)
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
addrPrimTyCon = String -> SDoc
text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (forall a. Ptr a
nullPtr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x)
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
stablePtrPrimTyCon = String -> SDoc
text String
"<stablePtr>"
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
stableNamePrimTyCon = String -> SDoc
text String
"<stableName>"
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
statePrimTyCon = String -> SDoc
text String
"<statethread>"
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
proxyPrimTyCon = String -> SDoc
text String
"<proxy>"
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
realWorldTyCon = String -> SDoc
text String
"<realworld>"
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
threadIdPrimTyCon = String -> SDoc
text String
"<ThreadId>"
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
weakPrimTyCon = String -> SDoc
text String
"<Weak>"
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
arrayPrimTyCon = String -> SDoc
text String
"<array>"
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
smallArrayPrimTyCon = String -> SDoc
text String
"<smallArray>"
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
byteArrayPrimTyCon = String -> SDoc
text String
"<bytearray>"
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
mutableArrayPrimTyCon = String -> SDoc
text String
"<mutableArray>"
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
smallMutableArrayPrimTyCon = String -> SDoc
text String
"<smallMutableArray>"
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
mutableByteArrayPrimTyCon = String -> SDoc
text String
"<mutableByteArray>"
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
mutVarPrimTyCon = String -> SDoc
text String
"<mutVar>"
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
mVarPrimTyCon = String -> SDoc
text String
"<mVar>"
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
tVarPrimTyCon = String -> SDoc
text String
"<tVar>"
| Bool
otherwise = Char -> SDoc
char Char
'<' SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr TyCon
t SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'>'
where build :: [a] -> a
build [a]
ww = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [a]
ww (forall a. Storable a => Ptr a -> IO a
peek forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Ptr a -> Ptr b
castPtr)
type RttiType = Type
type GhciType = Type
type TR a = TcM a
runTR :: HscEnv -> TR a -> IO a
runTR :: forall a. HscEnv -> TR a -> IO a
runTR HscEnv
hsc_env TR a
thing = do
Maybe a
mb_val <- forall a. HscEnv -> TR a -> IO (Maybe a)
runTR_maybe HscEnv
hsc_env TR a
thing
case Maybe a
mb_val of
Maybe a
Nothing -> forall a. HasCallStack => String -> a
error String
"unable to :print the term"
Just a
x -> forall (m :: * -> *) a. Monad m => a -> m a
return a
x
runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
runTR_maybe :: forall a. HscEnv -> TR a -> IO (Maybe a)
runTR_maybe HscEnv
hsc_env TR a
thing_inside
= do { (Messages DecoratedSDoc
_errs, Maybe a
res) <- forall a. HscEnv -> TcM a -> IO (Messages DecoratedSDoc, Maybe a)
initTcInteractive HscEnv
hsc_env TR a
thing_inside
; forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
res }
traceTR :: SDoc -> TR ()
traceTR :: SDoc -> TR ()
traceTR = forall a. TcM a -> TcM a
liftTcM forall b c a. (b -> c) -> (a -> b) -> a -> c
. DumpFlag -> SDoc -> TR ()
traceOptTcRn DumpFlag
Opt_D_dump_rtti
recoverTR :: TR a -> TR a -> TR a
recoverTR :: forall a. TR a -> TR a -> TR a
recoverTR = forall a. TR a -> TR a -> TR a
tryTcDiscardingErrs
trIO :: IO a -> TR a
trIO :: forall a. IO a -> TR a
trIO = forall a. TcM a -> TcM a
liftTcM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
liftTcM :: TcM a -> TR a
liftTcM :: forall a. TcM a -> TcM a
liftTcM = forall a. a -> a
id
newVar :: Kind -> TR TcType
newVar :: Type -> TR Type
newVar Type
kind = forall a. TcM a -> TcM a
liftTcM (do { TyVar
tv <- MetaInfo -> Type -> TcM TyVar
newAnonMetaTyVar MetaInfo
RuntimeUnkTv Type
kind
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> Type
mkTyVarTy TyVar
tv) })
newOpenVar :: TR TcType
newOpenVar :: TR Type
newOpenVar = forall a. TcM a -> TcM a
liftTcM (do { Type
kind <- TR Type
newOpenTypeKind
; Type -> TR Type
newVar Type
kind })
instTyVars :: [TyVar] -> TR (TCvSubst, [TcTyVar])
instTyVars :: [TyVar] -> TR (TCvSubst, [TyVar])
instTyVars [TyVar]
tvs
= forall a. TcM a -> TcM a
liftTcM forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints ([TyVar] -> TR (TCvSubst, [TyVar])
newMetaTyVars [TyVar]
tvs)
type RttiInstantiation = [(TcTyVar, TyVar)]
instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation)
instScheme :: QuantifiedType -> TR (Type, RttiInstantiation)
instScheme ([TyVar]
tvs, Type
ty)
= do { (TCvSubst
subst, [TyVar]
tvs') <- [TyVar] -> TR (TCvSubst, [TyVar])
instTyVars [TyVar]
tvs
; let rtti_inst :: RttiInstantiation
rtti_inst = [(TyVar
tv',TyVar
tv) | (TyVar
tv',TyVar
tv) <- [TyVar]
tvs' forall a b. [a] -> [b] -> [(a, b)]
`zip` [TyVar]
tvs]
; SDoc -> TR ()
traceTR (String -> SDoc
text String
"instScheme" SDoc -> SDoc -> SDoc
<+> (forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs'))
; forall (m :: * -> *) a. Monad m => a -> m a
return (HasCallStack => TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
ty, RttiInstantiation
rtti_inst) }
applyRevSubst :: RttiInstantiation -> TR ()
applyRevSubst :: RttiInstantiation -> TR ()
applyRevSubst RttiInstantiation
pairs = forall a. TcM a -> TcM a
liftTcM (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TyVar, TyVar) -> TR ()
do_pair RttiInstantiation
pairs)
where
do_pair :: (TyVar, TyVar) -> TR ()
do_pair (TyVar
tc_tv, TyVar
rtti_tv)
= do { Type
tc_ty <- TyVar -> TR Type
zonkTcTyVar TyVar
tc_tv
; case Type -> Maybe TyVar
tcGetTyVar_maybe Type
tc_ty of
Just TyVar
tv | TyVar -> Bool
isMetaTyVar TyVar
tv -> TyVar -> Type -> TR ()
writeMetaTyVar TyVar
tv (TyVar -> Type
mkTyVarTy TyVar
rtti_tv)
Maybe TyVar
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return () }
addConstraint :: TcType -> TcType -> TR ()
addConstraint :: Type -> Type -> TR ()
addConstraint Type
actual Type
expected = do
SDoc -> TR ()
traceTR (String -> SDoc
text String
"add constraint:" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
fsep [forall a. Outputable a => a -> SDoc
ppr Type
actual, SDoc
equals, forall a. Outputable a => a -> SDoc
ppr Type
expected])
forall a. TR a -> TR a -> TR a
recoverTR (SDoc -> TR ()
traceTR forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
fsep [String -> SDoc
text String
"Failed to unify", forall a. Outputable a => a -> SDoc
ppr Type
actual,
String -> SDoc
text String
"with", forall a. Outputable a => a -> SDoc
ppr Type
expected]) forall a b. (a -> b) -> a -> b
$
forall a. TcM a -> TR ()
discardResult forall a b. (a -> b) -> a -> b
$
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints forall a b. (a -> b) -> a -> b
$
do { (Type
ty1, Type
ty2) <- Type -> Type -> TR (Type, Type)
congruenceNewtypes Type
actual Type
expected
; Maybe SDoc -> Type -> Type -> TcM TcCoercionN
unifyType forall a. Maybe a
Nothing Type
ty1 Type
ty2 }
cvObtainTerm
:: HscEnv
-> Int
-> Bool
-> RttiType
-> ForeignHValue
-> IO Term
cvObtainTerm :: HscEnv -> Int -> Bool -> Type -> ForeignHValue -> IO Term
cvObtainTerm HscEnv
hsc_env Int
max_depth Bool
force Type
old_ty ForeignHValue
hval = forall a. HscEnv -> TR a -> IO a
runTR HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ do
let quant_old_ty :: QuantifiedType
quant_old_ty@([TyVar]
old_tvs, Type
old_tau) = Type -> QuantifiedType
quantifyType Type
old_ty
sigma_old_ty :: Type
sigma_old_ty = [TyVar] -> Type -> Type
mkInfForAllTys [TyVar]
old_tvs Type
old_tau
SDoc -> TR ()
traceTR (String -> SDoc
text String
"Term reconstruction started with initial type " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Type
old_ty)
Term
term <-
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVar]
old_tvs
then do
Term
term <- Int -> Type -> Type -> ForeignHValue -> TR Term
go Int
max_depth Type
sigma_old_ty Type
sigma_old_ty ForeignHValue
hval
Term
term' <- Term -> TR Term
zonkTerm Term
term
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Term
fixFunDictionaries forall a b. (a -> b) -> a -> b
$ Term -> Term
expandNewtypes Term
term'
else do
(Type
old_ty', RttiInstantiation
rev_subst) <- QuantifiedType -> TR (Type, RttiInstantiation)
instScheme QuantifiedType
quant_old_ty
Type
my_ty <- TR Type
newOpenVar
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (QuantifiedType -> Bool
check1 QuantifiedType
quant_old_ty) (SDoc -> TR ()
traceTR (String -> SDoc
text String
"check1 passed") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
Type -> Type -> TR ()
addConstraint Type
my_ty Type
old_ty')
Term
term <- Int -> Type -> Type -> ForeignHValue -> TR Term
go Int
max_depth Type
my_ty Type
sigma_old_ty ForeignHValue
hval
Type
new_ty <- Type -> TR Type
zonkTcType (Term -> Type
termType Term
term)
if Type -> Bool
isMonomorphic Type
new_ty Bool -> Bool -> Bool
|| QuantifiedType -> QuantifiedType -> Bool
check2 (Type -> QuantifiedType
quantifyType Type
new_ty) QuantifiedType
quant_old_ty
then do
SDoc -> TR ()
traceTR (String -> SDoc
text String
"check2 passed")
Type -> Type -> TR ()
addConstraint Type
new_ty Type
old_ty'
RttiInstantiation -> TR ()
applyRevSubst RttiInstantiation
rev_subst
Term
zterm' <- Term -> TR Term
zonkTerm Term
term
forall (m :: * -> *) a. Monad m => a -> m a
return ((Term -> Term
fixFunDictionaries forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Term
expandNewtypes) Term
zterm')
else do
SDoc -> TR ()
traceTR (String -> SDoc
text String
"check2 failed" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens
(forall a. Outputable a => a -> SDoc
ppr Term
term SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"::" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Type
new_ty))
Term
zterm' <- forall (m :: * -> *). Monad m => (Type -> m Type) -> Term -> m Term
mapTermTypeM
(\Type
ty -> case HasCallStack => Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty of
Just (TyCon
tc, Type
_:[Type]
_) | TyCon
tc forall a. Eq a => a -> a -> Bool
/= TyCon
funTyCon
-> TR Type
newOpenVar
Maybe (TyCon, [Type])
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)
Term
term
Term -> TR Term
zonkTerm Term
zterm'
SDoc -> TR ()
traceTR (String -> SDoc
text String
"Term reconstruction completed." SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"Term obtained: " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Term
term SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"Type obtained: " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr (Term -> Type
termType Term
term))
forall (m :: * -> *) a. Monad m => a -> m a
return Term
term
where
interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
go :: Int -> Type -> Type -> ForeignHValue -> TcM Term
go :: Int -> Type -> Type -> ForeignHValue -> TR Term
go Int
0 Type
my_ty Type
_old_ty ForeignHValue
a = do
SDoc -> TR ()
traceTR (String -> SDoc
text String
"Gave up reconstructing a term after" SDoc -> SDoc -> SDoc
<>
Int -> SDoc
int Int
max_depth SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" steps")
GenClosure ForeignHValue
clos <- forall a. IO a -> TR a
trIO forall a b. (a -> b) -> a -> b
$ Interp -> ForeignHValue -> IO (GenClosure ForeignHValue)
GHCi.getClosure Interp
interp ForeignHValue
a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
Suspension (StgInfoTable -> ClosureType
tipe (forall b. GenClosure b -> StgInfoTable
info GenClosure ForeignHValue
clos)) Type
my_ty ForeignHValue
a forall a. Maybe a
Nothing)
go !Int
max_depth Type
my_ty Type
old_ty ForeignHValue
a = do
let monomorphic :: Bool
monomorphic = Bool -> Bool
not(Type -> Bool
isTyVarTy Type
my_ty)
GenClosure ForeignHValue
clos <- forall a. IO a -> TR a
trIO forall a b. (a -> b) -> a -> b
$ Interp -> ForeignHValue -> IO (GenClosure ForeignHValue)
GHCi.getClosure Interp
interp ForeignHValue
a
case GenClosure ForeignHValue
clos of
GenClosure ForeignHValue
t | forall a. GenClosure a -> Bool
isThunk GenClosure ForeignHValue
t Bool -> Bool -> Bool
&& Bool
force -> do
SDoc -> TR ()
traceTR (String -> SDoc
text String
"Forcing a " SDoc -> SDoc -> SDoc
<> String -> SDoc
text (forall a. Show a => a -> String
show (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const ()) GenClosure ForeignHValue
t)))
EvalResult ()
evalRslt <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interp -> HscEnv -> ForeignHValue -> IO (EvalResult ())
GHCi.seqHValue Interp
interp HscEnv
hsc_env ForeignHValue
a
case EvalResult ()
evalRslt of
EvalSuccess ()
_ -> Int -> Type -> Type -> ForeignHValue -> TR Term
go (forall a. Enum a => a -> a
pred Int
max_depth) Type
my_ty Type
old_ty ForeignHValue
a
EvalException SerializableException
ex -> do
SDoc -> TR ()
traceTR forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Exception occured:" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (forall a. Show a => a -> String
show SerializableException
ex)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ SerializableException -> SomeException
fromSerializableException SerializableException
ex
BlackholeClosure{indirectee :: forall b. GenClosure b -> b
indirectee=ForeignHValue
ind} -> do
SDoc -> TR ()
traceTR (String -> SDoc
text String
"Following a BLACKHOLE")
GenClosure ForeignHValue
ind_clos <- forall a. IO a -> TR a
trIO (Interp -> ForeignHValue -> IO (GenClosure ForeignHValue)
GHCi.getClosure Interp
interp ForeignHValue
ind)
let return_bh_value :: TR Term
return_bh_value = forall (m :: * -> *) a. Monad m => a -> m a
return (ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
Suspension ClosureType
BLACKHOLE Type
my_ty ForeignHValue
a forall a. Maybe a
Nothing)
case GenClosure ForeignHValue
ind_clos of
BlockingQueueClosure{} -> TR Term
return_bh_value
OtherClosure StgInfoTable
info [ForeignHValue]
_ [Word]
_
| StgInfoTable -> ClosureType
tipe StgInfoTable
info forall a. Eq a => a -> a -> Bool
== ClosureType
TSO -> TR Term
return_bh_value
UnsupportedClosure StgInfoTable
info
| StgInfoTable -> ClosureType
tipe StgInfoTable
info forall a. Eq a => a -> a -> Bool
== ClosureType
TSO -> TR Term
return_bh_value
GenClosure ForeignHValue
_ -> Int -> Type -> Type -> ForeignHValue -> TR Term
go Int
max_depth Type
my_ty Type
old_ty ForeignHValue
ind
IndClosure{indirectee :: forall b. GenClosure b -> b
indirectee=ForeignHValue
ind} -> do
SDoc -> TR ()
traceTR (String -> SDoc
text String
"Following an indirection" )
Int -> Type -> Type -> ForeignHValue -> TR Term
go Int
max_depth Type
my_ty Type
old_ty ForeignHValue
ind
MutVarClosure{var :: forall b. GenClosure b -> b
var=ForeignHValue
contents}
| Just (TyCon
tycon,[Type
world,Type
contents_ty]) <- HasCallStack => Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
old_ty
-> do
SDoc -> TR ()
traceTR (String -> SDoc
text String
"Following a MutVar")
Type
contents_tv <- Type -> TR Type
newVar Type
liftedTypeKind
MASSERT(isUnliftedType my_ty)
(Type
mutvar_ty,RttiInstantiation
_) <- QuantifiedType -> TR (Type, RttiInstantiation)
instScheme forall a b. (a -> b) -> a -> b
$ Type -> QuantifiedType
quantifyType forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
mkVisFunTyMany
Type
contents_ty (TyCon -> [Type] -> Type
mkTyConApp TyCon
tycon [Type
world,Type
contents_ty])
Type -> Type -> TR ()
addConstraint (Type -> Type -> Type
mkVisFunTyMany Type
contents_tv Type
my_ty) Type
mutvar_ty
Term
x <- Int -> Type -> Type -> ForeignHValue -> TR Term
go (forall a. Enum a => a -> a
pred Int
max_depth) Type
contents_tv Type
contents_ty ForeignHValue
contents
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Term -> Term
RefWrap Type
my_ty Term
x)
ConstrClosure{ptrArgs :: forall b. GenClosure b -> [b]
ptrArgs=[ForeignHValue]
pArgs,dataArgs :: forall b. GenClosure b -> [Word]
dataArgs=[Word]
dArgs} -> do
SDoc -> TR ()
traceTR (String -> SDoc
text String
"entering a constructor " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr [Word]
dArgs SDoc -> SDoc -> SDoc
<+>
if Bool
monomorphic
then SDoc -> SDoc
parens (String -> SDoc
text String
"already monomorphic: " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Type
my_ty)
else SDoc
Ppr.empty)
Right Name
dcname <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. HscEnv -> GenClosure a -> IO (Either String Name)
constrClosToName HscEnv
hsc_env GenClosure ForeignHValue
clos
(Maybe DataCon
mb_dc, Messages DecoratedSDoc
_) <- forall a. TcRn a -> TcRn (Maybe a, Messages DecoratedSDoc)
tryTc (Name -> TcM DataCon
tcLookupDataCon Name
dcname)
case Maybe DataCon
mb_dc of
Maybe DataCon
Nothing -> do
SDoc -> TR ()
traceTR (String -> SDoc
text String
"Not constructor" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Name
dcname)
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
tag :: String
tag = forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags Name
dcname
[Type]
vars <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ForeignHValue]
pArgs)
(Type -> TR Type
newVar Type
liftedTypeKind)
[Term]
subTerms <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ForeignHValue
x Type
tv ->
Int -> Type -> Type -> ForeignHValue -> TR Term
go (forall a. Enum a => a -> a
pred Int
max_depth) Type
tv Type
tv ForeignHValue
x) [ForeignHValue]
pArgs [Type]
vars
forall (m :: * -> *) a. Monad m => a -> m a
return (TermProcessor Term Term
Term Type
my_ty (forall a b. a -> Either a b
Left (Char
'<' forall a. a -> [a] -> [a]
: String
tag forall a. [a] -> [a] -> [a]
++ String
">")) ForeignHValue
a [Term]
subTerms)
Just DataCon
dc -> do
SDoc -> TR ()
traceTR (String -> SDoc
text String
"Is constructor" SDoc -> SDoc -> SDoc
<+> (forall a. Outputable a => a -> SDoc
ppr DataCon
dc SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr Type
my_ty))
[Type]
subTtypes <- DataCon -> Type -> TR [Type]
getDataConArgTys DataCon
dc Type
my_ty
[Term]
subTerms <- (Type -> ForeignHValue -> TR Term)
-> GenClosure ForeignHValue
-> [Type]
-> IOEnv (Env TcGblEnv TcLclEnv) [Term]
extractSubTerms (\Type
ty -> Int -> Type -> Type -> ForeignHValue -> TR Term
go (forall a. Enum a => a -> a
pred Int
max_depth) Type
ty Type
ty) GenClosure ForeignHValue
clos [Type]
subTtypes
forall (m :: * -> *) a. Monad m => a -> m a
return (TermProcessor Term Term
Term Type
my_ty (forall a b. b -> Either a b
Right DataCon
dc) ForeignHValue
a [Term]
subTerms)
ArrWordsClosure{bytes :: forall b. GenClosure b -> Word
bytes=Word
b, arrWords :: forall b. GenClosure b -> [Word]
arrWords=[Word]
ws} -> do
SDoc -> TR ()
traceTR (String -> SDoc
text String
"ByteArray# closure, size " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Word
b)
forall (m :: * -> *) a. Monad m => a -> m a
return (TermProcessor Term Term
Term Type
my_ty (forall a b. a -> Either a b
Left String
"ByteArray#") ForeignHValue
a [Type -> [Word] -> Term
Prim Type
my_ty [Word]
ws])
GenClosure ForeignHValue
_ -> do
SDoc -> TR ()
traceTR (String -> SDoc
text String
"Unknown closure:" SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text (forall a. Show a => a -> String
show (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const ()) GenClosure ForeignHValue
clos)))
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
Suspension (StgInfoTable -> ClosureType
tipe (forall b. GenClosure b -> StgInfoTable
info GenClosure ForeignHValue
clos)) Type
my_ty ForeignHValue
a forall a. Maybe a
Nothing)
expandNewtypes :: Term -> Term
expandNewtypes = forall a. TermFold a -> Term -> a
foldTerm TermFold Term
idTermFold { fTerm :: TermProcessor Term Term
fTerm = TermProcessor Term Term
worker } where
worker :: TermProcessor Term Term
worker Type
ty Either String DataCon
dc ForeignHValue
hval [Term]
tt
| Just (TyCon
tc, [Type]
args) <- HasCallStack => Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty
, TyCon -> Bool
isNewTyCon TyCon
tc
, Type
wrapped_type <- TyCon -> [Type] -> Type
newTyConInstRhs TyCon
tc [Type]
args
, Just DataCon
dc' <- TyCon -> Maybe DataCon
tyConSingleDataCon_maybe TyCon
tc
, Term
t' <- TermProcessor Term Term
worker Type
wrapped_type Either String DataCon
dc ForeignHValue
hval [Term]
tt
= Type -> Either String DataCon -> Term -> Term
NewtypeWrap Type
ty (forall a b. b -> Either a b
Right DataCon
dc') Term
t'
| Bool
otherwise = TermProcessor Term Term
Term Type
ty Either String DataCon
dc ForeignHValue
hval [Term]
tt
fixFunDictionaries :: Term -> Term
fixFunDictionaries = forall a. TermFold a -> Term -> a
foldTerm TermFold Term
idTermFold {fSuspension :: ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
fSuspension = ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
worker} where
worker :: ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
worker ClosureType
ct Type
ty ForeignHValue
hval Maybe Name
n | Type -> Bool
isFunTy Type
ty = ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
Suspension ClosureType
ct (Type -> Type
dictsView Type
ty) ForeignHValue
hval Maybe Name
n
| Bool
otherwise = ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
Suspension ClosureType
ct Type
ty ForeignHValue
hval Maybe Name
n
extractSubTerms :: (Type -> ForeignHValue -> TcM Term)
-> GenClosure ForeignHValue -> [Type] -> TcM [Term]
Type -> ForeignHValue -> TR Term
recurse GenClosure ForeignHValue
clos = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b c. (a, b, c) -> c
thdOf3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> Int
-> [Type]
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
go Int
0 Int
0
where
array :: [Word]
array = forall b. GenClosure b -> [Word]
dataArgs GenClosure ForeignHValue
clos
go :: Int
-> Int
-> [Type]
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
go Int
ptr_i Int
arr_i [] = forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ptr_i, Int
arr_i, [])
go Int
ptr_i Int
arr_i (Type
ty:[Type]
tys)
| Just (TyCon
tc, [Type]
elem_tys) <- HasCallStack => Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty
, TyCon -> Bool
isUnboxedTupleTyCon TyCon
tc
= do (Int
ptr_i, Int
arr_i, [Term]
terms0) <-
Int
-> Int
-> [Type]
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
go Int
ptr_i Int
arr_i ([Type] -> [Type]
dropRuntimeRepArgs [Type]
elem_tys)
(Int
ptr_i, Int
arr_i, [Term]
terms1) <- Int
-> Int
-> [Type]
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
go Int
ptr_i Int
arr_i [Type]
tys
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ptr_i, Int
arr_i, Type -> [Term] -> Term
unboxedTupleTerm Type
ty [Term]
terms0 forall a. a -> [a] -> [a]
: [Term]
terms1)
| Bool
otherwise
= case HasDebugCallStack => Type -> [PrimRep]
typePrimRepArgs Type
ty of
[PrimRep
rep_ty] -> do
(Int
ptr_i, Int
arr_i, Term
term0) <- Int
-> Int
-> Type
-> PrimRep
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, Term)
go_rep Int
ptr_i Int
arr_i Type
ty PrimRep
rep_ty
(Int
ptr_i, Int
arr_i, [Term]
terms1) <- Int
-> Int
-> [Type]
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
go Int
ptr_i Int
arr_i [Type]
tys
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ptr_i, Int
arr_i, Term
term0 forall a. a -> [a] -> [a]
: [Term]
terms1)
[PrimRep]
rep_tys -> do
(Int
ptr_i, Int
arr_i, [Term]
terms0) <- Int
-> Int
-> [PrimRep]
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
go_unary_types Int
ptr_i Int
arr_i [PrimRep]
rep_tys
(Int
ptr_i, Int
arr_i, [Term]
terms1) <- Int
-> Int
-> [Type]
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
go Int
ptr_i Int
arr_i [Type]
tys
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ptr_i, Int
arr_i, Type -> [Term] -> Term
unboxedTupleTerm Type
ty [Term]
terms0 forall a. a -> [a] -> [a]
: [Term]
terms1)
go_unary_types :: Int
-> Int
-> [PrimRep]
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
go_unary_types Int
ptr_i Int
arr_i [] = forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ptr_i, Int
arr_i, [])
go_unary_types Int
ptr_i Int
arr_i (PrimRep
rep_ty:[PrimRep]
rep_tys) = do
Type
tv <- Type -> TR Type
newVar Type
liftedTypeKind
(Int
ptr_i, Int
arr_i, Term
term0) <- Int
-> Int
-> Type
-> PrimRep
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, Term)
go_rep Int
ptr_i Int
arr_i Type
tv PrimRep
rep_ty
(Int
ptr_i, Int
arr_i, [Term]
terms1) <- Int
-> Int
-> [PrimRep]
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
go_unary_types Int
ptr_i Int
arr_i [PrimRep]
rep_tys
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ptr_i, Int
arr_i, Term
term0 forall a. a -> [a] -> [a]
: [Term]
terms1)
go_rep :: Int
-> Int
-> Type
-> PrimRep
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, Term)
go_rep Int
ptr_i Int
arr_i Type
ty PrimRep
rep
| PrimRep -> Bool
isGcPtrRep PrimRep
rep = do
Term
t <- Type -> ForeignHValue -> TR Term
recurse Type
ty forall a b. (a -> b) -> a -> b
$ (forall b. GenClosure b -> [b]
ptrArgs GenClosure ForeignHValue
clos)forall a. [a] -> Int -> a
!!Int
ptr_i
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ptr_i forall a. Num a => a -> a -> a
+ Int
1, Int
arr_i, Term
t)
| Bool
otherwise = do
Platform
platform <- TcM Platform
getPlatform
let word_size :: Int
word_size = Platform -> Int
platformWordSizeInBytes Platform
platform
endian :: ByteOrder
endian = Platform -> ByteOrder
platformByteOrder Platform
platform
size_b :: Int
size_b = Platform -> PrimRep -> Int
primRepSizeB Platform
platform PrimRep
rep
!aligned_idx :: Int
aligned_idx = Int -> Int -> Int
roundUpTo Int
arr_i (forall a. Ord a => a -> a -> a
min Int
word_size Int
size_b)
!new_arr_i :: Int
new_arr_i = Int
aligned_idx forall a. Num a => a -> a -> a
+ Int
size_b
ws :: [Word]
ws | Int
size_b forall a. Ord a => a -> a -> Bool
< Int
word_size =
[Int -> Int -> Int -> ByteOrder -> Word
index Int
size_b Int
aligned_idx Int
word_size ByteOrder
endian]
| Bool
otherwise =
let (Int
q, Int
r) = Int
size_b forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
word_size
in ASSERT( r == 0 )
[ [Word]
arrayforall a. [a] -> Int -> a
!!Int
i
| Int
o <- [Int
0.. Int
q forall a. Num a => a -> a -> a
- Int
1]
, let i :: Int
i = (Int
aligned_idx forall a. Integral a => a -> a -> a
`quot` Int
word_size) forall a. Num a => a -> a -> a
+ Int
o
]
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ptr_i, Int
new_arr_i, Type -> [Word] -> Term
Prim Type
ty [Word]
ws)
unboxedTupleTerm :: Type -> [Term] -> Term
unboxedTupleTerm Type
ty [Term]
terms
= TermProcessor Term Term
Term Type
ty (forall a b. b -> Either a b
Right (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Term]
terms)))
(forall a. HasCallStack => String -> a
error String
"unboxedTupleTerm: no HValue for unboxed tuple") [Term]
terms
index :: Int -> Int -> Int -> ByteOrder -> Word
index Int
size_b Int
aligned_idx Int
word_size ByteOrder
endian = case ByteOrder
endian of
ByteOrder
BigEndian -> (Word
word forall a. Bits a => a -> Int -> a
`shiftL` Int
moveBits) forall a. Bits a => a -> Int -> a
`shiftR` Int
zeroOutBits forall a. Bits a => a -> Int -> a
`shiftL` Int
zeroOutBits
ByteOrder
LittleEndian -> (Word
word forall a. Bits a => a -> Int -> a
`shiftR` Int
moveBits) forall a. Bits a => a -> Int -> a
`shiftL` Int
zeroOutBits forall a. Bits a => a -> Int -> a
`shiftR` Int
zeroOutBits
where
(Int
q, Int
r) = Int
aligned_idx forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
word_size
word :: Word
word = [Word]
arrayforall a. [a] -> Int -> a
!!Int
q
moveBits :: Int
moveBits = Int
r forall a. Num a => a -> a -> a
* Int
8
zeroOutBits :: Int
zeroOutBits = (Int
word_size forall a. Num a => a -> a -> a
- Int
size_b) forall a. Num a => a -> a -> a
* Int
8
cvReconstructType
:: HscEnv
-> Int
-> GhciType
-> ForeignHValue
-> IO (Maybe Type)
cvReconstructType :: HscEnv -> Int -> Type -> ForeignHValue -> IO (Maybe Type)
cvReconstructType HscEnv
hsc_env Int
max_depth Type
old_ty ForeignHValue
hval = forall a. HscEnv -> TR a -> IO (Maybe a)
runTR_maybe HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ do
SDoc -> TR ()
traceTR (String -> SDoc
text String
"RTTI started with initial type " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Type
old_ty)
let sigma_old_ty :: QuantifiedType
sigma_old_ty@([TyVar]
old_tvs, Type
_) = Type -> QuantifiedType
quantifyType Type
old_ty
Type
new_ty <-
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVar]
old_tvs
then forall (m :: * -> *) a. Monad m => a -> m a
return Type
old_ty
else do
(Type
old_ty', RttiInstantiation
rev_subst) <- QuantifiedType -> TR (Type, RttiInstantiation)
instScheme QuantifiedType
sigma_old_ty
Type
my_ty <- TR Type
newOpenVar
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (QuantifiedType -> Bool
check1 QuantifiedType
sigma_old_ty) (SDoc -> TR ()
traceTR (String -> SDoc
text String
"check1 passed") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
Type -> Type -> TR ()
addConstraint Type
my_ty Type
old_ty')
IOEnv (Env TcGblEnv TcLclEnv) Bool
-> ((Type, ForeignHValue)
-> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)])
-> Seq (Type, ForeignHValue)
-> Int
-> TR ()
search (Type -> Bool
isMonomorphic forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Type -> TR Type
zonkTcType Type
my_ty)
(\(Type
ty,ForeignHValue
a) -> Type
-> ForeignHValue
-> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
go Type
ty ForeignHValue
a)
(forall a. a -> Seq a
Seq.singleton (Type
my_ty, ForeignHValue
hval))
Int
max_depth
Type
new_ty <- Type -> TR Type
zonkTcType Type
my_ty
if Type -> Bool
isMonomorphic Type
new_ty Bool -> Bool -> Bool
|| QuantifiedType -> QuantifiedType -> Bool
check2 (Type -> QuantifiedType
quantifyType Type
new_ty) QuantifiedType
sigma_old_ty
then do
SDoc -> TR ()
traceTR (String -> SDoc
text String
"check2 passed" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Type
old_ty SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr Type
new_ty)
Type -> Type -> TR ()
addConstraint Type
my_ty Type
old_ty'
RttiInstantiation -> TR ()
applyRevSubst RttiInstantiation
rev_subst
Type -> TR Type
zonkRttiType Type
new_ty
else SDoc -> TR ()
traceTR (String -> SDoc
text String
"check2 failed" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (forall a. Outputable a => a -> SDoc
ppr Type
new_ty)) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
forall (m :: * -> *) a. Monad m => a -> m a
return Type
old_ty
SDoc -> TR ()
traceTR (String -> SDoc
text String
"RTTI completed. Type obtained:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Type
new_ty)
forall (m :: * -> *) a. Monad m => a -> m a
return Type
new_ty
where
interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
search :: IOEnv (Env TcGblEnv TcLclEnv) Bool
-> ((Type, ForeignHValue)
-> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)])
-> Seq (Type, ForeignHValue)
-> Int
-> TR ()
search IOEnv (Env TcGblEnv TcLclEnv) Bool
_ (Type, ForeignHValue)
-> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
_ Seq (Type, ForeignHValue)
_ Int
0 = SDoc -> TR ()
traceTR (String -> SDoc
text String
"Failed to reconstruct a type after " SDoc -> SDoc -> SDoc
<>
Int -> SDoc
int Int
max_depth SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" steps")
search IOEnv (Env TcGblEnv TcLclEnv) Bool
stop (Type, ForeignHValue)
-> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
expand Seq (Type, ForeignHValue)
l Int
d =
case forall a. Seq a -> ViewL a
viewl Seq (Type, ForeignHValue)
l of
ViewL (Type, ForeignHValue)
EmptyL -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Type, ForeignHValue)
x :< Seq (Type, ForeignHValue)
xx -> forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM IOEnv (Env TcGblEnv TcLclEnv) Bool
stop forall a b. (a -> b) -> a -> b
$ do
[(Type, ForeignHValue)]
new <- (Type, ForeignHValue)
-> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
expand (Type, ForeignHValue)
x
IOEnv (Env TcGblEnv TcLclEnv) Bool
-> ((Type, ForeignHValue)
-> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)])
-> Seq (Type, ForeignHValue)
-> Int
-> TR ()
search IOEnv (Env TcGblEnv TcLclEnv) Bool
stop (Type, ForeignHValue)
-> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
expand (Seq (Type, ForeignHValue)
xx forall a. Monoid a => a -> a -> a
`mappend` forall a. [a] -> Seq a
Seq.fromList [(Type, ForeignHValue)]
new) forall a b. (a -> b) -> a -> b
$! (forall a. Enum a => a -> a
pred Int
d)
go :: Type -> ForeignHValue -> TR [(Type, ForeignHValue)]
go :: Type
-> ForeignHValue
-> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
go Type
my_ty ForeignHValue
a = do
SDoc -> TR ()
traceTR (String -> SDoc
text String
"go" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Type
my_ty)
GenClosure ForeignHValue
clos <- forall a. IO a -> TR a
trIO forall a b. (a -> b) -> a -> b
$ Interp -> ForeignHValue -> IO (GenClosure ForeignHValue)
GHCi.getClosure Interp
interp ForeignHValue
a
case GenClosure ForeignHValue
clos of
BlackholeClosure{indirectee :: forall b. GenClosure b -> b
indirectee=ForeignHValue
ind} -> Type
-> ForeignHValue
-> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
go Type
my_ty ForeignHValue
ind
IndClosure{indirectee :: forall b. GenClosure b -> b
indirectee=ForeignHValue
ind} -> Type
-> ForeignHValue
-> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
go Type
my_ty ForeignHValue
ind
MutVarClosure{var :: forall b. GenClosure b -> b
var=ForeignHValue
contents} -> do
Type
tv' <- Type -> TR Type
newVar Type
liftedTypeKind
Type
world <- Type -> TR Type
newVar Type
liftedTypeKind
Type -> Type -> TR ()
addConstraint Type
my_ty (TyCon -> [Type] -> Type
mkTyConApp TyCon
mutVarPrimTyCon [Type
world,Type
tv'])
forall (m :: * -> *) a. Monad m => a -> m a
return [(Type
tv', ForeignHValue
contents)]
ConstrClosure{ptrArgs :: forall b. GenClosure b -> [b]
ptrArgs=[ForeignHValue]
pArgs} -> do
Right Name
dcname <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. HscEnv -> GenClosure a -> IO (Either String Name)
constrClosToName HscEnv
hsc_env GenClosure ForeignHValue
clos
SDoc -> TR ()
traceTR (String -> SDoc
text String
"Constr1" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Name
dcname)
(Maybe DataCon
mb_dc, Messages DecoratedSDoc
_) <- forall a. TcRn a -> TcRn (Maybe a, Messages DecoratedSDoc)
tryTc (Name -> TcM DataCon
tcLookupDataCon Name
dcname)
case Maybe DataCon
mb_dc of
Maybe DataCon
Nothing->
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ForeignHValue]
pArgs forall a b. (a -> b) -> a -> b
$ \ForeignHValue
x -> do
Type
tv <- Type -> TR Type
newVar Type
liftedTypeKind
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
tv, ForeignHValue
x)
Just DataCon
dc -> do
[Type]
arg_tys <- DataCon -> Type -> TR [Type]
getDataConArgTys DataCon
dc Type
my_ty
(Int
_, [(Int, Type)]
itys) <- Int -> [Type] -> TR (Int, [(Int, Type)])
findPtrTyss Int
0 [Type]
arg_tys
SDoc -> TR ()
traceTR (String -> SDoc
text String
"Constr2" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Name
dcname SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Type]
arg_tys)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Int
_,Type
ty) ForeignHValue
x -> (Type
ty, ForeignHValue
x)) [(Int, Type)]
itys [ForeignHValue]
pArgs
GenClosure ForeignHValue
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return []
findPtrTys :: Int
-> Type
-> TR (Int, [(Int, Type)])
findPtrTys :: Int -> Type -> TR (Int, [(Int, Type)])
findPtrTys Int
i Type
ty
| Just (TyCon
tc, [Type]
elem_tys) <- HasCallStack => Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty
, TyCon -> Bool
isUnboxedTupleTyCon TyCon
tc
= Int -> [Type] -> TR (Int, [(Int, Type)])
findPtrTyss Int
i [Type]
elem_tys
| Bool
otherwise
= case HasDebugCallStack => Type -> [PrimRep]
typePrimRep Type
ty of
[PrimRep
rep] | PrimRep -> Bool
isGcPtrRep PrimRep
rep -> forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i forall a. Num a => a -> a -> a
+ Int
1, [(Int
i, Type
ty)])
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, [])
[PrimRep]
prim_reps ->
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\(Int
i, [(Int, Type)]
extras) PrimRep
prim_rep ->
if PrimRep -> Bool
isGcPtrRep PrimRep
prim_rep
then Type -> TR Type
newVar Type
liftedTypeKind forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type
tv -> forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i forall a. Num a => a -> a -> a
+ Int
1, [(Int, Type)]
extras forall a. [a] -> [a] -> [a]
++ [(Int
i, Type
tv)])
else forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, [(Int, Type)]
extras))
(Int
i, []) [PrimRep]
prim_reps
findPtrTyss :: Int
-> [Type]
-> TR (Int, [(Int, Type)])
findPtrTyss :: Int -> [Type] -> TR (Int, [(Int, Type)])
findPtrTyss Int
i [Type]
tys = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Int, [(Int, Type)]) -> Type -> TR (Int, [(Int, Type)])
step (Int
i, []) [Type]
tys
where step :: (Int, [(Int, Type)]) -> Type -> TR (Int, [(Int, Type)])
step (Int
i, [(Int, Type)]
discovered) Type
elem_ty = do
(Int
i, [(Int, Type)]
extras) <- Int -> Type -> TR (Int, [(Int, Type)])
findPtrTys Int
i Type
elem_ty
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, [(Int, Type)]
discovered forall a. [a] -> [a] -> [a]
++ [(Int, Type)]
extras)
improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TCvSubst
improveRTTIType :: HscEnv -> Type -> Type -> Maybe TCvSubst
improveRTTIType HscEnv
_ Type
base_ty Type
new_ty = Type -> Type -> Maybe TCvSubst
U.tcUnifyTyKi Type
base_ty Type
new_ty
getDataConArgTys :: DataCon -> Type -> TR [Type]
getDataConArgTys :: DataCon -> Type -> TR [Type]
getDataConArgTys DataCon
dc Type
con_app_ty
= do { let rep_con_app_ty :: Type
rep_con_app_ty = Type -> Type
unwrapType Type
con_app_ty
; SDoc -> TR ()
traceTR (String -> SDoc
text String
"getDataConArgTys 1" SDoc -> SDoc -> SDoc
<+> (forall a. Outputable a => a -> SDoc
ppr Type
con_app_ty SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr Type
rep_con_app_ty
SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr (HasCallStack => Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
rep_con_app_ty)))
; ASSERT( all isTyVar ex_tvs ) return ()
; (TCvSubst
subst, [TyVar]
_) <- [TyVar] -> TR (TCvSubst, [TyVar])
instTyVars ([TyVar]
univ_tvs forall a. [a] -> [a] -> [a]
++ [TyVar]
ex_tvs)
; Type -> Type -> TR ()
addConstraint Type
rep_con_app_ty (HasCallStack => TCvSubst -> Type -> Type
substTy TCvSubst
subst (DataCon -> Type
dataConOrigResTy DataCon
dc))
; let con_arg_tys :: [Type]
con_arg_tys = HasCallStack => TCvSubst -> [Type] -> [Type]
substTys TCvSubst
subst (forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
scaledThing forall a b. (a -> b) -> a -> b
$ DataCon -> [Scaled Type]
dataConRepArgTys DataCon
dc)
; SDoc -> TR ()
traceTR (String -> SDoc
text String
"getDataConArgTys 2" SDoc -> SDoc -> SDoc
<+> (forall a. Outputable a => a -> SDoc
ppr Type
rep_con_app_ty SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [Type]
con_arg_tys SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr TCvSubst
subst))
; forall (m :: * -> *) a. Monad m => a -> m a
return [Type]
con_arg_tys }
where
univ_tvs :: [TyVar]
univ_tvs = DataCon -> [TyVar]
dataConUnivTyVars DataCon
dc
ex_tvs :: [TyVar]
ex_tvs = DataCon -> [TyVar]
dataConExTyCoVars DataCon
dc
check1 :: QuantifiedType -> Bool
check1 :: QuantifiedType -> Bool
check1 ([TyVar]
tvs, Type
_) = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Type -> Bool
isHigherKind (forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Type
tyVarKind [TyVar]
tvs)
where
isHigherKind :: Type -> Bool
isHigherKind = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ([TyCoBinder], Type)
splitPiTys
check2 :: QuantifiedType -> QuantifiedType -> Bool
check2 :: QuantifiedType -> QuantifiedType -> Bool
check2 ([TyVar]
_, Type
rtti_ty) ([TyVar]
_, Type
old_ty)
| Just (TyCon
_, [Type]
rttis) <- HasCallStack => Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
rtti_ty
= case () of
()
_ | Just (TyCon
_,[Type]
olds) <- HasCallStack => Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
old_ty
-> forall (t :: * -> *). Foldable t => t Bool -> Bool
andforall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith QuantifiedType -> QuantifiedType -> Bool
check2 (forall a b. (a -> b) -> [a] -> [b]
map Type -> QuantifiedType
quantifyType [Type]
rttis) (forall a b. (a -> b) -> [a] -> [b]
map Type -> QuantifiedType
quantifyType [Type]
olds)
()
_ | Just (Type, Type)
_ <- Type -> Maybe (Type, Type)
splitAppTy_maybe Type
old_ty
-> Type -> Bool
isMonomorphicOnNonPhantomArgs Type
rtti_ty
()
_ -> Bool
True
| Bool
otherwise = Bool
True
congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
congruenceNewtypes :: Type -> Type -> TR (Type, Type)
congruenceNewtypes Type
lhs Type
rhs = Type -> Type -> TR Type
go Type
lhs Type
rhs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type
rhs' -> forall (m :: * -> *) a. Monad m => a -> m a
return (Type
lhs,Type
rhs')
where
go :: Type -> Type -> TR Type
go Type
l Type
r
| Just TyVar
tv <- Type -> Maybe TyVar
getTyVar_maybe Type
l
, TyVar -> Bool
isTcTyVar TyVar
tv
, TyVar -> Bool
isMetaTyVar TyVar
tv
= forall a. TR a -> TR a -> TR a
recoverTR (forall (m :: * -> *) a. Monad m => a -> m a
return Type
r) forall a b. (a -> b) -> a -> b
$ do
Indirect Type
ty_v <- TyVar -> TcM MetaDetails
readMetaTyVar TyVar
tv
SDoc -> TR ()
traceTR forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
fsep [String -> SDoc
text String
"(congruence) Following indirect tyvar:",
forall a. Outputable a => a -> SDoc
ppr TyVar
tv, SDoc
equals, forall a. Outputable a => a -> SDoc
ppr Type
ty_v]
Type -> Type -> TR Type
go Type
ty_v Type
r
| Just (Type
w1,Type
l1,Type
l2) <- Type -> Maybe (Type, Type, Type)
splitFunTy_maybe Type
l
, Just (Type
w2,Type
r1,Type
r2) <- Type -> Maybe (Type, Type, Type)
splitFunTy_maybe Type
r
, Type
w1 Type -> Type -> Bool
`eqType` Type
w2
= do Type
r2' <- Type -> Type -> TR Type
go Type
l2 Type
r2
Type
r1' <- Type -> Type -> TR Type
go Type
l1 Type
r1
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type -> Type -> Type
mkVisFunTy Type
w1 Type
r1' Type
r2')
| Just (TyCon
tycon_l, [Type]
_) <- HasCallStack => Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
lhs
, Just (TyCon
tycon_r, [Type]
_) <- HasCallStack => Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
rhs
, TyCon
tycon_l forall a. Eq a => a -> a -> Bool
/= TyCon
tycon_r
= TyCon -> Type -> TR Type
upgrade TyCon
tycon_l Type
r
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return Type
r
where upgrade :: TyCon -> Type -> TR Type
upgrade :: TyCon -> Type -> TR Type
upgrade TyCon
new_tycon Type
ty
| Bool -> Bool
not (TyCon -> Bool
isNewTyCon TyCon
new_tycon) = do
SDoc -> TR ()
traceTR (String -> SDoc
text String
"(Upgrade) Not matching newtype evidence: " SDoc -> SDoc -> SDoc
<>
forall a. Outputable a => a -> SDoc
ppr TyCon
new_tycon SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" for " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Type
ty)
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty
| Bool
otherwise = do
SDoc -> TR ()
traceTR (String -> SDoc
text String
"(Upgrade) upgraded " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
<>
String -> SDoc
text String
" in presence of newtype evidence " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr TyCon
new_tycon)
(TCvSubst
_, [TyVar]
vars) <- [TyVar] -> TR (TCvSubst, [TyVar])
instTyVars (TyCon -> [TyVar]
tyConTyVars TyCon
new_tycon)
let ty' :: Type
ty' = TyCon -> [Type] -> Type
mkTyConApp TyCon
new_tycon ([TyVar] -> [Type]
mkTyVarTys [TyVar]
vars)
rep_ty :: Type
rep_ty = Type -> Type
unwrapType Type
ty'
TcCoercionN
_ <- forall a. TcM a -> TcM a
liftTcM (Maybe SDoc -> Type -> Type -> TcM TcCoercionN
unifyType forall a. Maybe a
Nothing Type
ty Type
rep_ty)
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty'
zonkTerm :: Term -> TcM Term
zonkTerm :: Term -> TR Term
zonkTerm = forall (m :: * -> *) a. Monad m => TermFoldM m a -> Term -> m a
foldTermM (TermFoldM
{ fTermM :: TermProcessor Term (TR Term)
fTermM = \Type
ty Either String DataCon
dc ForeignHValue
v [Term]
tt -> Type -> TR Type
zonkRttiType Type
ty forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type
ty' ->
forall (m :: * -> *) a. Monad m => a -> m a
return (TermProcessor Term Term
Term Type
ty' Either String DataCon
dc ForeignHValue
v [Term]
tt)
, fSuspensionM :: ClosureType -> Type -> ForeignHValue -> Maybe Name -> TR Term
fSuspensionM = \ClosureType
ct Type
ty ForeignHValue
v Maybe Name
b -> Type -> TR Type
zonkRttiType Type
ty forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type
ty ->
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
Suspension ClosureType
ct Type
ty ForeignHValue
v Maybe Name
b)
, fNewtypeWrapM :: Type -> Either String DataCon -> Term -> TR Term
fNewtypeWrapM = \Type
ty Either String DataCon
dc Term
t -> Type -> TR Type
zonkRttiType Type
ty forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type
ty' ->
forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ Type -> Either String DataCon -> Term -> Term
NewtypeWrap Type
ty' Either String DataCon
dc Term
t
, fRefWrapM :: Type -> Term -> TR Term
fRefWrapM = \Type
ty Term
t -> forall (m :: * -> *) a. Monad m => a -> m a
return Type -> Term -> Term
RefWrap forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap`
Type -> TR Type
zonkRttiType Type
ty forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` forall (m :: * -> *) a. Monad m => a -> m a
return Term
t
, fPrimM :: Type -> [Word] -> TR Term
fPrimM = (forall (m :: * -> *) a. Monad m => a -> m a
returnforall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> [Word] -> Term
Prim })
zonkRttiType :: TcType -> TcM Type
zonkRttiType :: Type -> TR Type
zonkRttiType Type
ty= do { ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
RuntimeUnkFlexi
; ZonkEnv -> Type -> TR Type
zonkTcTypeToTypeX ZonkEnv
ze Type
ty }
dictsView :: Type -> Type
dictsView :: Type -> Type
dictsView Type
ty = Type
ty
isMonomorphic :: RttiType -> Bool
isMonomorphic :: Type -> Bool
isMonomorphic Type
ty = Bool
noExistentials Bool -> Bool -> Bool
&& Bool
noUniversals
where ([TyVar]
tvs, [Type]
_, Type
ty') = Type -> ([TyVar], [Type], Type)
tcSplitSigmaTy Type
ty
noExistentials :: Bool
noExistentials = Type -> Bool
noFreeVarsOfType Type
ty'
noUniversals :: Bool
noUniversals = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVar]
tvs
isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
isMonomorphicOnNonPhantomArgs :: Type -> Bool
isMonomorphicOnNonPhantomArgs Type
ty
| Just (TyCon
tc, [Type]
all_args) <- HasCallStack => Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe (Type -> Type
unwrapType Type
ty)
, [TyVar]
phantom_vars <- TyCon -> [TyVar]
tyConPhantomTyVars TyCon
tc
, [Type]
concrete_args <- [ Type
arg | (TyVar
tyv,Type
arg) <- TyCon -> [TyVar]
tyConTyVars TyCon
tc forall a b. [a] -> [b] -> [(a, b)]
`zip` [Type]
all_args
, TyVar
tyv forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [TyVar]
phantom_vars]
= forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isMonomorphicOnNonPhantomArgs [Type]
concrete_args
| Just (Type
_, Type
ty1, Type
ty2) <- Type -> Maybe (Type, Type, Type)
splitFunTy_maybe Type
ty
= forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isMonomorphicOnNonPhantomArgs [Type
ty1,Type
ty2]
| Bool
otherwise = Type -> Bool
isMonomorphic Type
ty
tyConPhantomTyVars :: TyCon -> [TyVar]
tyConPhantomTyVars :: TyCon -> [TyVar]
tyConPhantomTyVars TyCon
tc
| TyCon -> Bool
isAlgTyCon TyCon
tc
, Just [DataCon]
dcs <- TyCon -> Maybe [DataCon]
tyConDataCons_maybe TyCon
tc
, [TyVar]
dc_vars <- forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DataCon -> [TyVar]
dataConUnivTyVars [DataCon]
dcs
= TyCon -> [TyVar]
tyConTyVars TyCon
tc forall a. Eq a => [a] -> [a] -> [a]
\\ [TyVar]
dc_vars
tyConPhantomTyVars TyCon
_ = []
type QuantifiedType = ([TyVar], Type)
quantifyType :: Type -> QuantifiedType
quantifyType :: Type -> QuantifiedType
quantifyType Type
ty = ( forall a. (a -> Bool) -> [a] -> [a]
filter TyVar -> Bool
isTyVar forall a b. (a -> b) -> a -> b
$
Type -> [TyVar]
tyCoVarsOfTypeWellScoped Type
rho
, Type
rho)
where
([TyVar]
_tvs, Type
rho) = Type -> QuantifiedType
tcSplitForAllInvisTyVars Type
ty