{-# LANGUAGE BangPatterns, ScopedTypeVariables, MagicHash #-}
module GHC.Runtime.Heap.Inspect(
cvObtainTerm,
cvReconstructType,
improveRTTIType,
Term(..),
isFullyEvaluatedTerm,
termType, mapTermType, termTyCoVars,
foldTerm, TermFold(..),
cPprTerm, cPprTermBase,
constrClosToName
) where
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.Utils.Panic.Plain
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} = (Term -> Bool) -> [Term] -> Bool
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 <- CustomTermPrinter Maybe -> Term -> Maybe SDoc
forall (m :: * -> *).
Monad m =>
CustomTermPrinter m -> Term -> m SDoc
cPprTerm CustomTermPrinter Maybe
forall (m :: * -> *). Monad m => CustomTermPrinter m
cPprTermBase Term
t = SDoc
doc
| Bool
otherwise = String -> SDoc
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 = Unit -> ModuleName -> GenModule Unit
forall u. u -> ModuleName -> GenModule u
mkModule (String -> Unit
stringToUnit String
pkg) (String -> ModuleName
mkModuleName String
mod)
Name -> Either String Name
forall a b. b -> Either a b
Right (Name -> Either String Name) -> IO Name -> IO (Either String Name)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` NameCache -> GenModule Unit -> OccName -> IO Name
lookupNameCache (HscEnv -> NameCache
hsc_NC HscEnv
hsc_env) GenModule Unit
modName OccName
occName
constrClosToName HscEnv
_hsc_env GenClosure a
clos =
Either String Name -> IO (Either String Name)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String Name
forall a b. a -> Either a b
Left (String
"conClosToName: Expected ConstrClosure, got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ GenClosure () -> String
forall a. Show a => a -> String
show ((a -> ()) -> GenClosure a -> GenClosure ()
forall a b. (a -> b) -> GenClosure a -> GenClosure b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> a -> ()
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) = TermFold a -> TermProcessor a a
forall a. TermFold a -> TermProcessor a a
fTerm TermFold a
tf Type
ty Either String DataCon
dc ForeignHValue
v ((Term -> a) -> [Term] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (TermFold a -> Term -> a
forall a. TermFold a -> Term -> a
foldTerm TermFold a
tf) [Term]
tt)
foldTerm TermFold a
tf (Prim Type
ty [Word]
v ) = TermFold a -> Type -> [Word] -> a
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) = TermFold a
-> ClosureType -> Type -> ForeignHValue -> Maybe Name -> a
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) = TermFold a -> Type -> Either String DataCon -> a -> a
forall a. TermFold a -> Type -> Either String DataCon -> a -> a
fNewtypeWrap TermFold a
tf Type
ty Either String DataCon
dc (TermFold a -> Term -> a
forall a. TermFold a -> Term -> a
foldTerm TermFold a
tf Term
t)
foldTerm TermFold a
tf (RefWrap Type
ty Term
t) = TermFold a -> Type -> a -> a
forall a. TermFold a -> Type -> a -> a
fRefWrap TermFold a
tf Type
ty (TermFold a -> Term -> a
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) = (Term -> m a) -> [Term] -> m [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TermFoldM m a -> Term -> m a
forall (m :: * -> *) a. Monad m => TermFoldM m a -> Term -> m a
foldTermM TermFoldM m a
tf) [Term]
tt m [a] -> ([a] -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermFoldM m a -> TermProcessor a (m a)
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 ) = TermFoldM m a -> Type -> [Word] -> m a
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) = TermFoldM m a
-> ClosureType -> Type -> ForeignHValue -> Maybe Name -> m a
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) = TermFoldM m a -> Term -> m a
forall (m :: * -> *) a. Monad m => TermFoldM m a -> Term -> m a
foldTermM TermFoldM m a
tf Term
t m a -> (a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermFoldM m a -> Type -> Either String DataCon -> a -> m a
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) = TermFoldM m a -> Term -> m a
forall (m :: * -> *) a. Monad m => TermFoldM m a -> Term -> m a
foldTermM TermFoldM m a
tf Term
t m a -> (a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermFoldM m a -> Type -> a -> m a
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 = TermFold Term -> Term -> Term
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 = TermFoldM m Term -> Term -> m Term
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 m Type -> (Type -> m Term) -> m Term
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type
ty' -> Term -> m Term
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> m Term) -> Term -> m Term
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 = (Term -> m Term
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return(Term -> m Term) -> ([Word] -> Term) -> [Word] -> m Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (([Word] -> Term) -> [Word] -> m Term)
-> (Type -> [Word] -> Term) -> Type -> [Word] -> m Term
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 m Type -> (Type -> m Term) -> m Term
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type
ty' -> Term -> m Term
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> m Term) -> Term -> m Term
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 m Type -> (Type -> m Term) -> m Term
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type
ty' -> Term -> m Term
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> m Term) -> Term -> m Term
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 m Type -> (Type -> m Term) -> m Term
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type
ty' -> Term -> m Term
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> m Term) -> Term -> m Term
forall a b. (a -> b) -> a -> b
$ Type -> Term -> Term
RefWrap Type
ty' Term
t}
termTyCoVars :: Term -> TyCoVarSet
termTyCoVars :: Term -> TyCoVarSet
termTyCoVars = TermFold TyCoVarSet -> Term -> TyCoVarSet
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 = (TyCoVarSet -> TyCoVarSet -> TyCoVarSet)
-> TyCoVarSet -> [TyCoVarSet] -> TyCoVarSet
forall a b. (a -> b -> b) -> b -> [a] -> b
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 (SDoc -> SDoc) -> m SDoc -> m SDoc
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` TermPrinterM m -> TermPrinterM m
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 <- (Term -> m SDoc) -> [Term] -> m [SDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TermPrinterM m
y Int
app_prec) [Term]
tt
SDoc -> m SDoc
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ Bool -> SDoc -> SDoc
cparen (Bool -> Bool
not ([Term] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Term]
tt) Bool -> Bool -> Bool
&& Int
p Int -> Int -> Bool
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' <- (Term -> m SDoc) -> [Term] -> m [SDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TermPrinterM m
y Int
app_prec) [Term]
tt
; SDoc -> m SDoc
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc -> SDoc
ifPprDebug ([SDoc] -> SDoc
show_tm [SDoc]
tt_docs')
([SDoc] -> SDoc
show_tm ([Type] -> [SDoc] -> [SDoc]
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
| [SDoc] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SDoc]
tt_docs = DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dc
| Bool
otherwise = Bool -> SDoc -> SDoc
cparen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
app_prec) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
sep [DataCon -> SDoc
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{} = TermPrinterM m -> TermPrinterM m
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
SDoc -> m SDoc
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return(SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ Bool -> SDoc -> SDoc
cparen (Int
p Int -> Int -> Bool
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 = Term -> m SDoc
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} =
SDoc -> m SDoc
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ TyCon -> [Word] -> SDoc
repPrim ((() :: Constraint) => Type -> TyCon
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} =
SDoc -> m SDoc
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> SDoc
char Char
'_' SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
whenPprDebug (SDoc
dcolon SDoc -> SDoc -> SDoc
<> Type -> SDoc
pprSigmaType Type
ty))
ppr_termM1 Suspension{ty :: Term -> Type
ty=Type
ty, bound_to :: Term -> Maybe Name
bound_to=Just Name
n}
| Bool
otherwise = SDoc -> m SDoc
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return(SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc
parens(SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n SDoc -> SDoc -> SDoc
<> SDoc
dcolon SDoc -> SDoc -> SDoc
<> Type -> SDoc
pprSigmaType Type
ty
ppr_termM1 Term{} = String -> m SDoc
forall a. String -> a
panic String
"ppr_termM1 - Term"
ppr_termM1 RefWrap{} = String -> m SDoc
forall a. String -> a
panic String
"ppr_termM1 - RefWrap"
ppr_termM1 NewtypeWrap{} = String -> m SDoc
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])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty
, Bool -> Bool -> Bool
forall a. HasCallStack => Bool -> a -> a
assert (TyCon -> Bool
isNewTyCon TyCon
tc) Bool
True
, Just DataCon
new_dc <- TyCon -> Maybe DataCon
tyConSingleDataCon_maybe TyCon
tc = do
SDoc
real_term <- TermPrinterM m
y Int
max_prec Term
t
SDoc -> m SDoc
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ Bool -> SDoc -> SDoc
cparen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
app_prec) (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
new_dc SDoc -> SDoc -> SDoc
<+> SDoc
real_term)
pprNewtypeWrap TermPrinterM m
_ Int
_ Term
_ = String -> m SDoc
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_ = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> m SDoc -> m (Maybe SDoc)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` TermPrinterM m -> TermPrinterM m
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] [m (Maybe SDoc)] -> [m (Maybe SDoc)] -> [m (Maybe SDoc)]
forall a. [a] -> [a] -> [a]
++ [m (Maybe SDoc)
default_]
Maybe SDoc
mdoc <- [m (Maybe SDoc)] -> m (Maybe SDoc)
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 -> String -> m SDoc
forall a. String -> a
panic String
"cPprTerm"
Just SDoc
doc -> SDoc -> m SDoc
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ Bool -> SDoc -> SDoc
cparen (Int
precInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
app_precInt -> Int -> Int
forall 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 m (Maybe a) -> (Maybe a -> m (Maybe a)) -> m (Maybe a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (Maybe a) -> (a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([m (Maybe a)] -> m (Maybe a)
firstJustM [m (Maybe a)]
mbs) (Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> m (Maybe a)) -> (a -> Maybe a) -> a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just)
firstJustM [] = Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
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
isTupleTy(Type -> Bool) -> (Term -> Type) -> Term -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Term -> Type
ty) (\Int
_p -> ([SDoc] -> SDoc) -> m [SDoc] -> m SDoc
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (SDoc -> SDoc
parens (SDoc -> SDoc) -> ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
hcat ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma)
(m [SDoc] -> m SDoc) -> (Term -> m [SDoc]) -> Term -> m SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term -> m SDoc) -> [Term] -> m [SDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TermPrinterM m
y (-Int
1))
([Term] -> m [SDoc]) -> (Term -> [Term]) -> Term -> m [SDoc]
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 [Term] -> Int -> Bool
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 (Type -> Bool) -> (Term -> Type) -> Term -> Bool
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 (Type -> Bool) -> (Term -> Type) -> Term -> Bool
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 (Type -> Bool) -> (Term -> Type) -> Term -> Bool
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 (Type -> Bool) -> (Term -> Type) -> Term -> Bool
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 (Type -> Bool) -> (Term -> Type) -> Term -> Bool
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 (Type -> Bool) -> (Term -> Type) -> Term -> Bool
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 -> SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> m SDoc -> m (Maybe SDoc)
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
_ = Maybe SDoc -> m (Maybe SDoc)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SDoc
forall a. Maybe a
Nothing
isTupleTy :: Type -> Bool
isTupleTy Type
ty = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
(TyCon
tc,[Type]
_) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty
Bool -> Maybe Bool
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> Bool
isBoxedTupleTyCon TyCon
tc)
isTyCon :: TyCon -> Type -> Bool
isTyCon TyCon
a_tc Type
ty = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
(TyCon
tc,[Type]
_) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty
Bool -> Maybe Bool
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon
a_tc TyCon -> TyCon -> Bool
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]}]} =
Maybe SDoc -> m (Maybe SDoc)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Int -> SDoc
Ppr.int (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w)))
ppr_int Int
_ Term
_ = Maybe SDoc -> m (Maybe SDoc)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SDoc
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]}]} =
Maybe SDoc -> m (Maybe SDoc)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Char -> SDoc
Ppr.pprHsChar (Int -> Char
chr (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w))))
ppr_char Int
_ Term
_ = Maybe SDoc -> m (Maybe SDoc)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SDoc
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 = IO Float -> Float
forall a. IO a -> a
unsafeDupablePerformIO (IO Float -> Float) -> IO Float -> Float
forall a b. (a -> b) -> a -> b
$
(Ptr Word -> IO Float) -> IO Float
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Word -> IO Float) -> IO Float)
-> (Ptr Word -> IO Float) -> IO Float
forall a b. (a -> b) -> a -> b
$ \Ptr Word
p -> Ptr Word -> Word -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word
p Word
w IO () -> IO Float -> IO Float
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr Float -> IO Float
forall a. Storable a => Ptr a -> IO a
peek (Ptr Word -> Ptr Float
forall a b. Ptr a -> Ptr b
castPtr Ptr Word
p)
Maybe SDoc -> m (Maybe SDoc)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Float -> SDoc
Ppr.float Float
f))
ppr_float Int
_ Term
_ = Maybe SDoc -> m (Maybe SDoc)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SDoc
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 = IO Double -> Double
forall a. IO a -> a
unsafeDupablePerformIO (IO Double -> Double) -> IO Double -> Double
forall a b. (a -> b) -> a -> b
$
(Ptr Word -> IO Double) -> IO Double
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Word -> IO Double) -> IO Double)
-> (Ptr Word -> IO Double) -> IO Double
forall a b. (a -> b) -> a -> b
$ \Ptr Word
p -> Ptr Word -> Word -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word
p Word
w IO () -> IO Double -> IO Double
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr Double -> IO Double
forall a. Storable a => Ptr a -> IO a
peek (Ptr Word -> Ptr Double
forall a b. Ptr a -> Ptr b
castPtr Ptr Word
p)
Maybe SDoc -> m (Maybe SDoc)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> Maybe SDoc
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 = IO Double -> Double
forall a. IO a -> a
unsafeDupablePerformIO (IO Double -> Double) -> IO Double -> Double
forall a b. (a -> b) -> a -> b
$
(Ptr Word32 -> IO Double) -> IO Double
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Word32 -> IO Double) -> IO Double)
-> (Ptr Word32 -> IO Double) -> IO Double
forall a b. (a -> b) -> a -> b
$ \Ptr Word32
p -> do
Ptr Word32 -> Word32 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word32
p (Word -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w1 :: Word32)
Ptr Word32 -> Word32 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word32
p Ptr Word32 -> Int -> Ptr Word32
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
4) (Word -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w2 :: Word32)
Ptr Double -> IO Double
forall a. Storable a => Ptr a -> IO a
peek (Ptr Word32 -> Ptr Double
forall a b. Ptr a -> Ptr b
castPtr Ptr Word32
p)
Maybe SDoc -> m (Maybe SDoc)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Double -> SDoc
Ppr.double Double
f))
ppr_double Int
_ Term
_ = Maybe SDoc -> m (Maybe SDoc)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SDoc
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 = Word -> Int
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 t -> t -> t
forall a. Num a => a -> a -> a
+ (a -> t
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x t -> Int -> t
forall a. Bits a => a -> Int -> a
`shiftL` Int
s)) (Int
s Int -> Int -> Int
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
Maybe SDoc -> m (Maybe SDoc)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SDoc -> m (Maybe SDoc)) -> Maybe SDoc -> m (Maybe SDoc)
forall a b. (a -> b) -> a -> b
$ SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ Integer -> SDoc
Ppr.integer (Integer -> SDoc) -> Integer -> SDoc
forall a b. (a -> b) -> a -> b
$ Integer
signf Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (Integer -> Int -> [Word] -> Integer
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 DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
integerISDataCon
, [W# Word#
w] <- [Word]
ws
= Maybe SDoc -> m (Maybe SDoc)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Integer -> SDoc
Ppr.integer (Int -> 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 DataCon -> DataCon -> Bool
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 DataCon -> DataCon -> Bool
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 = String -> m (Maybe SDoc)
forall a. String -> a
panic String
"Unexpected Integer constructor"
ppr_integer Int
_ Term
_ = Maybe SDoc -> m (Maybe SDoc)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SDoc
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 DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
naturalNSDataCon
, [Word
w] <- [Word]
ws
= Maybe SDoc -> m (Maybe SDoc)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Integer -> SDoc
Ppr.integer (Word -> 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 DataCon -> DataCon -> Bool
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 = String -> m (Maybe SDoc)
forall a. String -> a
panic String
"Unexpected Natural constructor"
ppr_natural Int
_ Term
_ = Maybe SDoc -> m (Maybe SDoc)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SDoc
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 Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
: Term -> [Term]
getListTerms Term
t
isConsLast :: Bool
isConsLast = Bool -> Bool
not (Term -> Type
termType ([Term] -> Term
forall a. HasCallStack => [a] -> a
last [Term]
elems) Type -> Type -> Bool
`eqType` Term -> Type
termType Term
h)
is_string :: Bool
is_string = (Term -> Bool) -> [Term] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Type -> Bool
isCharTy (Type -> Bool) -> (Term -> Type) -> Term -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Type
ty) [Term]
elems
chars :: String
chars = [ Int -> Char
chr (Word -> Int
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 <- (Term -> m SDoc) -> [Term] -> m [SDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TermPrinterM m
y Int
cons_prec) [Term]
elems
if Bool
is_string
then SDoc -> m SDoc
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> SDoc
Ppr.doubleQuotes (String -> SDoc
Ppr.text String
chars))
else if Bool
isConsLast
then SDoc -> m SDoc
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ Bool -> SDoc -> SDoc
cparen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
cons_prec)
(SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ ([SDoc] -> SDoc) -> [SDoc] -> SDoc
pprDeeperList [SDoc] -> SDoc
fsep
([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate (SDoc
spaceSDoc -> SDoc -> SDoc
<>SDoc
colon) [SDoc]
print_elems
else SDoc -> m SDoc
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc
brackets
(SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ ([SDoc] -> SDoc) -> [SDoc] -> SDoc
pprDeeperList [SDoc] -> SDoc
fcat
([SDoc] -> SDoc) -> [SDoc] -> SDoc
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 Term -> [Term] -> [Term]
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 = String -> SDoc -> [Term]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getListTerms" (Term -> SDoc
forall a. Outputable a => a -> SDoc
ppr Term
t)
ppr_list Int
_ Term
_ = String -> m SDoc
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 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
charPrimTyCon = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Char -> String
forall a. Show a => a -> String
show (Int -> Char
chr ([Word] -> Int
forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Int))
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
intPrimTyCon = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show ([Word] -> Int
forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Int)
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
wordPrimTyCon = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Word -> String
forall a. Show a => a -> String
show ([Word] -> Word
forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Word)
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
floatPrimTyCon = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Float -> String
forall a. Show a => a -> String
show ([Word] -> Float
forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Float)
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
doublePrimTyCon = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Double -> String
forall a. Show a => a -> String
show ([Word] -> Double
forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Double)
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
int8PrimTyCon = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Int8 -> String
forall a. Show a => a -> String
show ([Word] -> Int8
forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Int8)
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
word8PrimTyCon = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Word8 -> String
forall a. Show a => a -> String
show ([Word] -> Word8
forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Word8)
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
int16PrimTyCon = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Int16 -> String
forall a. Show a => a -> String
show ([Word] -> Int16
forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Int16)
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
word16PrimTyCon = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Word16 -> String
forall a. Show a => a -> String
show ([Word] -> Word16
forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Word16)
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
int32PrimTyCon = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Int32 -> String
forall a. Show a => a -> String
show ([Word] -> Int32
forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Int32)
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
word32PrimTyCon = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Word32 -> String
forall a. Show a => a -> String
show ([Word] -> Word32
forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Word32)
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
int64PrimTyCon = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Int64 -> String
forall a. Show a => a -> String
show ([Word] -> Int64
forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Int64)
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
word64PrimTyCon = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Word64 -> String
forall a. Show a => a -> String
show ([Word] -> Word64
forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x :: Word64)
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
addrPrimTyCon = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Ptr Any -> String
forall a. Show a => a -> String
show (Ptr Any
forall a. Ptr a
nullPtr Ptr Any -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` [Word] -> Int
forall {a} {a}. (Storable a, Storable a) => [a] -> a
build [Word]
x)
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
stablePtrPrimTyCon = String -> SDoc
text String
"<stablePtr>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
stableNamePrimTyCon = String -> SDoc
text String
"<stableName>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
statePrimTyCon = String -> SDoc
text String
"<statethread>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
proxyPrimTyCon = String -> SDoc
text String
"<proxy>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
realWorldTyCon = String -> SDoc
text String
"<realworld>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
threadIdPrimTyCon = String -> SDoc
text String
"<ThreadId>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
weakPrimTyCon = String -> SDoc
text String
"<Weak>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
arrayPrimTyCon = String -> SDoc
text String
"<array>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
smallArrayPrimTyCon = String -> SDoc
text String
"<smallArray>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
byteArrayPrimTyCon = String -> SDoc
text String
"<bytearray>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutableArrayPrimTyCon = String -> SDoc
text String
"<mutableArray>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
smallMutableArrayPrimTyCon = String -> SDoc
text String
"<smallMutableArray>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutableByteArrayPrimTyCon = String -> SDoc
text String
"<mutableByteArray>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutVarPrimTyCon = String -> SDoc
text String
"<mutVar>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mVarPrimTyCon = String -> SDoc
text String
"<mVar>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tVarPrimTyCon = String -> SDoc
text String
"<tVar>"
| Bool
otherwise = Char -> SDoc
char Char
'<' SDoc -> SDoc -> SDoc
<> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
t SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'>'
where build :: [a] -> a
build [a]
ww = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ [a] -> (Ptr a -> IO a) -> IO a
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [a]
ww (Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek (Ptr a -> IO a) -> (Ptr a -> Ptr a) -> Ptr a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr a -> Ptr a
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 <- HscEnv -> TR a -> IO (Maybe a)
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 -> String -> IO a
forall a. HasCallStack => String -> a
error String
"unable to :print the term"
Just a
x -> a -> IO a
forall a. a -> IO a
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 TcRnMessage
_errs, Maybe a
res) <- HscEnv -> TR a -> IO (Messages TcRnMessage, Maybe a)
forall a. HscEnv -> TcM a -> IO (Messages TcRnMessage, Maybe a)
initTcInteractive HscEnv
hsc_env TR a
thing_inside
; Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
res }
traceTR :: SDoc -> TR ()
traceTR :: SDoc -> TR ()
traceTR = TR () -> TR ()
forall a. TcM a -> TcM a
liftTcM (TR () -> TR ()) -> (SDoc -> TR ()) -> SDoc -> TR ()
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 = TcM a -> TcM a -> TcM a
forall a. TR a -> TR a -> TR a
tryTcDiscardingErrs
trIO :: IO a -> TR a
trIO :: forall a. IO a -> TR a
trIO = TcM a -> TcM a
forall a. TcM a -> TcM a
liftTcM (TcM a -> TcM a) -> (IO a -> TcM a) -> IO a -> TcM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> TcM a
forall a. IO a -> TR a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
liftTcM :: TcM a -> TR a
liftTcM :: forall a. TcM a -> TcM a
liftTcM = TcM a -> TcM a
forall a. a -> a
id
newVar :: Kind -> TR TcType
newVar :: Type -> TR Type
newVar Type
kind = TR Type -> TR Type
forall a. TcM a -> TcM a
liftTcM (do { TyVar
tv <- MetaInfo -> Type -> TcM TyVar
newAnonMetaTyVar MetaInfo
RuntimeUnkTv Type
kind
; Type -> TR Type
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> Type
mkTyVarTy TyVar
tv) })
newOpenVar :: TR TcType
newOpenVar :: TR Type
newOpenVar = TR Type -> TR Type
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
= TR (TCvSubst, [TyVar]) -> TR (TCvSubst, [TyVar])
forall a. TcM a -> TcM a
liftTcM (TR (TCvSubst, [TyVar]) -> TR (TCvSubst, [TyVar]))
-> TR (TCvSubst, [TyVar]) -> TR (TCvSubst, [TyVar])
forall a b. (a -> b) -> a -> b
$ ((TCvSubst, [TyVar]), WantedConstraints) -> (TCvSubst, [TyVar])
forall a b. (a, b) -> a
fst (((TCvSubst, [TyVar]), WantedConstraints) -> (TCvSubst, [TyVar]))
-> IOEnv
(Env TcGblEnv TcLclEnv) ((TCvSubst, [TyVar]), WantedConstraints)
-> TR (TCvSubst, [TyVar])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TR (TCvSubst, [TyVar])
-> IOEnv
(Env TcGblEnv TcLclEnv) ((TCvSubst, [TyVar]), WantedConstraints)
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' [TyVar] -> [TyVar] -> RttiInstantiation
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TyVar]
tvs]
; SDoc -> TR ()
traceTR (String -> SDoc
text String
"instScheme" SDoc -> SDoc -> SDoc
<+> ([TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
$$ [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs'))
; (Type, RttiInstantiation) -> TR (Type, RttiInstantiation)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((() :: Constraint) => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
ty, RttiInstantiation
rtti_inst) }
applyRevSubst :: RttiInstantiation -> TR ()
applyRevSubst :: RttiInstantiation -> TR ()
applyRevSubst RttiInstantiation
pairs = TR () -> TR ()
forall a. TcM a -> TcM a
liftTcM (((TyVar, TyVar) -> TR ()) -> RttiInstantiation -> TR ()
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 -> (() :: Constraint) => TyVar -> Type -> TR ()
TyVar -> Type -> TR ()
writeMetaTyVar TyVar
tv (TyVar -> Type
mkTyVarTy TyVar
rtti_tv)
Maybe TyVar
_ -> () -> TR ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 [Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
actual, SDoc
equals, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
expected])
TR () -> TR () -> TR ()
forall a. TR a -> TR a -> TR a
recoverTR (SDoc -> TR ()
traceTR (SDoc -> TR ()) -> SDoc -> TR ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
fsep [String -> SDoc
text String
"Failed to unify", Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
actual,
String -> SDoc
text String
"with", Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
expected]) (TR () -> TR ()) -> TR () -> TR ()
forall a b. (a -> b) -> a -> b
$
TcM (TcCoercionN, WantedConstraints) -> TR ()
forall a. TcM a -> TR ()
discardResult (TcM (TcCoercionN, WantedConstraints) -> TR ())
-> TcM (TcCoercionN, WantedConstraints) -> TR ()
forall a b. (a -> b) -> a -> b
$
TcM TcCoercionN -> TcM (TcCoercionN, WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints (TcM TcCoercionN -> TcM (TcCoercionN, WantedConstraints))
-> TcM TcCoercionN -> TcM (TcCoercionN, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
do { (Type
ty1, Type
ty2) <- Type -> Type -> TR (Type, Type)
congruenceNewtypes Type
actual Type
expected
; Maybe TypedThing -> Type -> Type -> TcM TcCoercionN
unifyType Maybe TypedThing
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 = HscEnv -> TR Term -> IO Term
forall a. HscEnv -> TR a -> IO a
runTR HscEnv
hsc_env (TR Term -> IO Term) -> TR Term -> IO Term
forall a b. (a -> b) -> a -> b
$ do
let quant_old_ty :: QuantifiedType
quant_old_ty@([TyVar]
old_tvs, Type
_) = Type -> QuantifiedType
quantifyType Type
old_ty
SDoc -> TR ()
traceTR (String -> SDoc
text String
"Term reconstruction started with initial type " SDoc -> SDoc -> SDoc
<> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
old_ty)
Term
term <-
if [TyVar] -> Bool
forall a. [a] -> Bool
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
old_ty Type
old_ty ForeignHValue
hval
Term
term' <- Term -> TR Term
zonkTerm Term
term
Term -> TR Term
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> TR Term) -> Term -> TR Term
forall a b. (a -> b) -> a -> b
$ Term -> Term
fixFunDictionaries (Term -> Term) -> Term -> Term
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
Bool -> TR () -> TR ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([TyVar] -> Bool
check1 [TyVar]
old_tvs) (SDoc -> TR ()
traceTR (String -> SDoc
text String
"check1 passed") TR () -> TR () -> TR ()
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
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
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
|| Type -> Type -> Bool
check2 Type
new_ty Type
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
Term -> TR Term
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Term -> Term
fixFunDictionaries (Term -> Term) -> (Term -> Term) -> Term -> Term
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
(Term -> SDoc
forall a. Outputable a => a -> SDoc
ppr Term
term SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"::" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
new_ty))
Term
zterm' <- (Type -> TR Type) -> Term -> TR Term
forall (m :: * -> *). Monad m => (Type -> m Type) -> Term -> m Term
mapTermTypeM
(\Type
ty -> case HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty of
Just (TyCon
tc, Type
_:[Type]
_) | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
/= TyCon
funTyCon
-> TR Type
newOpenVar
Maybe (TyCon, [Type])
_ -> Type -> TR Type
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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
<> Term -> SDoc
forall a. Outputable a => a -> SDoc
ppr Term
term SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"Type obtained: " SDoc -> SDoc -> SDoc
<> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Term -> Type
termType Term
term))
Term -> TR Term
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
term
where
interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
unit_env :: UnitEnv
unit_env = HscEnv -> UnitEnv
hsc_unit_env 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 <- IO (GenClosure ForeignHValue) -> TR (GenClosure ForeignHValue)
forall a. IO a -> TR a
trIO (IO (GenClosure ForeignHValue) -> TR (GenClosure ForeignHValue))
-> IO (GenClosure ForeignHValue) -> TR (GenClosure ForeignHValue)
forall a b. (a -> b) -> a -> b
$ Interp -> ForeignHValue -> IO (GenClosure ForeignHValue)
GHCi.getClosure Interp
interp ForeignHValue
a
Term -> TR Term
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
Suspension (StgInfoTable -> ClosureType
tipe (GenClosure ForeignHValue -> StgInfoTable
forall b. GenClosure b -> StgInfoTable
info GenClosure ForeignHValue
clos)) Type
my_ty ForeignHValue
a Maybe Name
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 <- IO (GenClosure ForeignHValue) -> TR (GenClosure ForeignHValue)
forall a. IO a -> TR a
trIO (IO (GenClosure ForeignHValue) -> TR (GenClosure ForeignHValue))
-> IO (GenClosure ForeignHValue) -> TR (GenClosure ForeignHValue)
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 | GenClosure ForeignHValue -> Bool
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 (GenClosure () -> String
forall a. Show a => a -> String
show ((ForeignHValue -> ()) -> GenClosure ForeignHValue -> GenClosure ()
forall a b. (a -> b) -> GenClosure a -> GenClosure b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> ForeignHValue -> ()
forall a b. a -> b -> a
const ()) GenClosure ForeignHValue
t)))
EvalResult ()
evalRslt <- IO (EvalResult ()) -> IOEnv (Env TcGblEnv TcLclEnv) (EvalResult ())
forall a. IO a -> TR a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (EvalResult ())
-> IOEnv (Env TcGblEnv TcLclEnv) (EvalResult ()))
-> IO (EvalResult ())
-> IOEnv (Env TcGblEnv TcLclEnv) (EvalResult ())
forall a b. (a -> b) -> a -> b
$ Interp -> UnitEnv -> ForeignHValue -> IO (EvalResult ())
GHCi.seqHValue Interp
interp UnitEnv
unit_env ForeignHValue
a
case EvalResult ()
evalRslt of
EvalSuccess ()
_ -> Int -> Type -> Type -> ForeignHValue -> TR Term
go (Int -> Int
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 (SDoc -> TR ()) -> SDoc -> TR ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Exception occured:" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (SerializableException -> String
forall a. Show a => a -> String
show SerializableException
ex)
IO Term -> TR Term
forall a. IO a -> TR a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Term -> TR Term) -> IO Term -> TR Term
forall a b. (a -> b) -> a -> b
$ SomeException -> IO Term
forall e a. Exception e => e -> IO a
throwIO (SomeException -> IO Term) -> SomeException -> IO Term
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 <- IO (GenClosure ForeignHValue) -> TR (GenClosure ForeignHValue)
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 = Term -> TR Term
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
Suspension ClosureType
BLACKHOLE Type
my_ty ForeignHValue
a Maybe Name
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 ClosureType -> ClosureType -> Bool
forall a. Eq a => a -> a -> Bool
== ClosureType
TSO -> TR Term
return_bh_value
UnsupportedClosure StgInfoTable
info
| StgInfoTable -> ClosureType
tipe StgInfoTable
info ClosureType -> ClosureType -> Bool
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
lev,Type
world,Type
contents_ty]) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
old_ty
-> do
Bool -> TR ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutVarPrimTyCon)
Bool -> TR ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert ((() :: Constraint) => Type -> Bool
Type -> Bool
isUnliftedType Type
my_ty)
SDoc -> TR ()
traceTR (String -> SDoc
text String
"Following a MutVar")
let contents_kind :: Type
contents_kind = Type -> Type
mkTYPEapp (TyCon -> [Type] -> Type
mkTyConApp TyCon
boxedRepDataConTyCon [Type
lev])
Type
contents_tv <- Type -> TR Type
newVar Type
contents_kind
(Type
mutvar_ty,RttiInstantiation
_) <- QuantifiedType -> TR (Type, RttiInstantiation)
instScheme (QuantifiedType -> TR (Type, RttiInstantiation))
-> QuantifiedType -> TR (Type, RttiInstantiation)
forall a b. (a -> b) -> a -> b
$ Type -> QuantifiedType
quantifyType (Type -> QuantifiedType) -> Type -> QuantifiedType
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
mkVisFunTyMany
Type
contents_ty (TyCon -> [Type] -> Type
mkTyConApp TyCon
tycon [Type
lev, 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 (Int -> Int
forall a. Enum a => a -> a
pred Int
max_depth) Type
contents_tv Type
contents_ty ForeignHValue
contents
Term -> TR Term
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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
<> [Word] -> 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
<> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
my_ty)
else SDoc
Ppr.empty)
Right Name
dcname <- IO (Either String Name)
-> IOEnv (Env TcGblEnv TcLclEnv) (Either String Name)
forall a. IO a -> TR a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String Name)
-> IOEnv (Env TcGblEnv TcLclEnv) (Either String Name))
-> IO (Either String Name)
-> IOEnv (Env TcGblEnv TcLclEnv) (Either String Name)
forall a b. (a -> b) -> a -> b
$ HscEnv -> GenClosure ForeignHValue -> IO (Either String Name)
forall a. HscEnv -> GenClosure a -> IO (Either String Name)
constrClosToName HscEnv
hsc_env GenClosure ForeignHValue
clos
(Maybe DataCon
mb_dc, Messages TcRnMessage
_) <- TcRn DataCon -> TcRn (Maybe DataCon, Messages TcRnMessage)
forall a. TcRn a -> TcRn (Maybe a, Messages TcRnMessage)
tryTc (Name -> TcRn 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
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
dcname)
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
tag :: String
tag = DynFlags -> Name -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags Name
dcname
[Type]
vars <- (ForeignHValue -> TR Type)
-> [ForeignHValue] -> IOEnv (Env TcGblEnv TcLclEnv) [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TR Type -> ForeignHValue -> TR Type
forall a b. a -> b -> a
const (Type -> TR Type
newVar Type
liftedTypeKind)) [ForeignHValue]
pArgs
[Term]
subTerms <- [TR Term] -> IOEnv (Env TcGblEnv TcLclEnv) [Term]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([TR Term] -> IOEnv (Env TcGblEnv TcLclEnv) [Term])
-> [TR Term] -> IOEnv (Env TcGblEnv TcLclEnv) [Term]
forall a b. (a -> b) -> a -> b
$ (ForeignHValue -> Type -> TR Term)
-> [ForeignHValue] -> [Type] -> [TR Term]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ForeignHValue
x Type
tv ->
Int -> Type -> Type -> ForeignHValue -> TR Term
go (Int -> Int
forall a. Enum a => a -> a
pred Int
max_depth) Type
tv Type
tv ForeignHValue
x) [ForeignHValue]
pArgs [Type]
vars
Term -> TR Term
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TermProcessor Term Term
Term Type
my_ty (String -> Either String DataCon
forall a b. a -> Either a b
Left (Char
'<' Char -> String -> String
forall a. a -> [a] -> [a]
: String
tag String -> String -> String
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
<+> (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dc SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
my_ty))
[Type]
subTtypes <- DataCon -> Type -> IOEnv (Env TcGblEnv TcLclEnv) [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 (Int -> Int
forall a. Enum a => a -> a
pred Int
max_depth) Type
ty Type
ty) GenClosure ForeignHValue
clos [Type]
subTtypes
Term -> TR Term
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TermProcessor Term Term
Term Type
my_ty (DataCon -> Either String DataCon
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
<> Word -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word
b)
Term -> TR Term
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TermProcessor Term Term
Term Type
my_ty (String -> Either String DataCon
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 (GenClosure () -> String
forall a. Show a => a -> String
show ((ForeignHValue -> ()) -> GenClosure ForeignHValue -> GenClosure ()
forall a b. (a -> b) -> GenClosure a -> GenClosure b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> ForeignHValue -> ()
forall a b. a -> b -> a
const ()) GenClosure ForeignHValue
clos)))
Term -> TR Term
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
Suspension (StgInfoTable -> ClosureType
tipe (GenClosure ForeignHValue -> StgInfoTable
forall b. GenClosure b -> StgInfoTable
info GenClosure ForeignHValue
clos)) Type
my_ty ForeignHValue
a Maybe Name
forall a. Maybe a
Nothing)
expandNewtypes :: Term -> Term
expandNewtypes = TermFold Term -> Term -> Term
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])
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 (DataCon -> Either String DataCon
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 = TermFold Term -> Term -> Term
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 = ((Int, Int, [Term]) -> [Term])
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
-> IOEnv (Env TcGblEnv TcLclEnv) [Term]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int, Int, [Term]) -> [Term]
forall a b c. (a, b, c) -> c
thdOf3 (IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
-> IOEnv (Env TcGblEnv TcLclEnv) [Term])
-> ([Type] -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term]))
-> [Type]
-> IOEnv (Env TcGblEnv TcLclEnv) [Term]
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 = GenClosure ForeignHValue -> [Word]
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 [] = (Int, Int, [Term])
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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])
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
(Int, Int, [Term])
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ptr_i, Int
arr_i, Type -> [Term] -> Term
unboxedTupleTerm Type
ty [Term]
terms0 Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
: [Term]
terms1)
| Bool
otherwise
= case (() :: Constraint) => Type -> [PrimRep]
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
(Int, Int, [Term])
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ptr_i, Int
arr_i, Term
term0 Term -> [Term] -> [Term]
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
(Int, Int, [Term])
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ptr_i, Int
arr_i, Type -> [Term] -> Term
unboxedTupleTerm Type
ty [Term]
terms0 Term -> [Term] -> [Term]
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 [] = (Int, Int, [Term])
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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
(Int, Int, [Term])
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ptr_i, Int
arr_i, Term
term0 Term -> [Term] -> [Term]
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 (ForeignHValue -> TR Term) -> ForeignHValue -> TR Term
forall a b. (a -> b) -> a -> b
$ (GenClosure ForeignHValue -> [ForeignHValue]
forall b. GenClosure b -> [b]
ptrArgs GenClosure ForeignHValue
clos)[ForeignHValue] -> Int -> ForeignHValue
forall a. HasCallStack => [a] -> Int -> a
!!Int
ptr_i
(Int, Int, Term) -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, Term)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ptr_i Int -> Int -> Int
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 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
word_size Int
size_b)
!new_arr_i :: Int
new_arr_i = Int
aligned_idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size_b
ws :: [Word]
ws | Int
size_b Int -> Int -> Bool
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 Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
word_size
in Bool -> [Word] -> [Word]
forall a. HasCallStack => Bool -> a -> a
assert (Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 )
[ [Word]
array[Word] -> Int -> Word
forall a. HasCallStack => [a] -> Int -> a
!!Int
i
| Int
o <- [Int
0.. Int
q Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
, let i :: Int
i = (Int
aligned_idx Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` Int
word_size) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
o
]
(Int, Int, Term) -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, Term)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 (DataCon -> Either String DataCon
forall a b. b -> Either a b
Right (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed ([Term] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Term]
terms)))
(String -> ForeignHValue
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 Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftL` Int
moveBits) Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
zeroOutBits Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftL` Int
zeroOutBits
ByteOrder
LittleEndian -> (Word
word Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
moveBits) Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftL` Int
zeroOutBits Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
zeroOutBits
where
(Int
q, Int
r) = Int
aligned_idx Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
word_size
word :: Word
word = [Word]
array[Word] -> Int -> Word
forall a. HasCallStack => [a] -> Int -> a
!!Int
q
moveBits :: Int
moveBits = Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8
zeroOutBits :: Int
zeroOutBits = (Int
word_size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
size_b) Int -> Int -> Int
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 = HscEnv -> TR Type -> IO (Maybe Type)
forall a. HscEnv -> TR a -> IO (Maybe a)
runTR_maybe HscEnv
hsc_env (TR Type -> IO (Maybe Type)) -> TR Type -> IO (Maybe Type)
forall a b. (a -> b) -> a -> b
$ do
SDoc -> TR ()
traceTR (String -> SDoc
text String
"RTTI started with initial type " SDoc -> SDoc -> SDoc
<> Type -> 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 [TyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVar]
old_tvs
then Type -> TR Type
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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
Bool -> TR () -> TR ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([TyVar] -> Bool
check1 [TyVar]
old_tvs) (SDoc -> TR ()
traceTR (String -> SDoc
text String
"check1 passed") TR () -> TR () -> TR ()
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
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 (Type -> Bool) -> TR Type -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
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)
((Type, ForeignHValue) -> Seq (Type, ForeignHValue)
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
|| Type -> Type -> Bool
check2 Type
new_ty Type
old_ty
then do
SDoc -> TR ()
traceTR (String -> SDoc
text String
"check2 passed" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
old_ty SDoc -> SDoc -> SDoc
$$ Type -> 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 (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
new_ty)) TR () -> TR Type -> TR Type
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
Type -> TR Type
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
new_ty)
Type -> TR Type
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 Seq (Type, ForeignHValue) -> ViewL (Type, ForeignHValue)
forall a. Seq a -> ViewL a
viewl Seq (Type, ForeignHValue)
l of
ViewL (Type, ForeignHValue)
EmptyL -> () -> TR ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Type, ForeignHValue)
x :< Seq (Type, ForeignHValue)
xx -> IOEnv (Env TcGblEnv TcLclEnv) Bool -> TR () -> TR ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM IOEnv (Env TcGblEnv TcLclEnv) Bool
stop (TR () -> TR ()) -> TR () -> TR ()
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 Seq (Type, ForeignHValue)
-> Seq (Type, ForeignHValue) -> Seq (Type, ForeignHValue)
forall a. Monoid a => a -> a -> a
`mappend` [(Type, ForeignHValue)] -> Seq (Type, ForeignHValue)
forall a. [a] -> Seq a
Seq.fromList [(Type, ForeignHValue)]
new) (Int -> TR ()) -> Int -> TR ()
forall a b. (a -> b) -> a -> b
$! (Int -> Int
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
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
my_ty)
GenClosure ForeignHValue
clos <- IO (GenClosure ForeignHValue) -> TR (GenClosure ForeignHValue)
forall a. IO a -> TR a
trIO (IO (GenClosure ForeignHValue) -> TR (GenClosure ForeignHValue))
-> IO (GenClosure ForeignHValue) -> TR (GenClosure ForeignHValue)
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}
| Just (TyCon
_tycon,[Type
lev,Type
_world,Type
_contents_ty]) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
my_ty
-> do
Bool -> TR ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (TyCon
_tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutVarPrimTyCon)
Type
tv' <- Type -> TR Type
newVar (Type -> TR Type) -> Type -> TR Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
mkTYPEapp (TyCon -> [Type] -> Type
mkTyConApp TyCon
boxedRepDataConTyCon [Type
lev])
Type
world <- Type -> TR Type
newVar Type
liftedTypeKind
Type -> Type -> TR ()
addConstraint Type
my_ty (Type -> TR ()) -> Type -> TR ()
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
mkMutVarPrimTy Type
world Type
tv'
[(Type, ForeignHValue)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Type
tv', ForeignHValue
contents)]
APClosure {payload :: forall b. GenClosure b -> [b]
payload=[ForeignHValue]
pLoad} -> do
(ForeignHValue
-> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)])
-> [ForeignHValue] -> TR ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Type
-> ForeignHValue
-> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
go Type
my_ty) [ForeignHValue]
pLoad
[(Type, ForeignHValue)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
ConstrClosure{ptrArgs :: forall b. GenClosure b -> [b]
ptrArgs=[ForeignHValue]
pArgs} -> do
Right Name
dcname <- IO (Either String Name)
-> IOEnv (Env TcGblEnv TcLclEnv) (Either String Name)
forall a. IO a -> TR a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String Name)
-> IOEnv (Env TcGblEnv TcLclEnv) (Either String Name))
-> IO (Either String Name)
-> IOEnv (Env TcGblEnv TcLclEnv) (Either String Name)
forall a b. (a -> b) -> a -> b
$ HscEnv -> GenClosure ForeignHValue -> IO (Either String Name)
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
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
dcname)
(Maybe DataCon
mb_dc, Messages TcRnMessage
_) <- TcRn DataCon -> TcRn (Maybe DataCon, Messages TcRnMessage)
forall a. TcRn a -> TcRn (Maybe a, Messages TcRnMessage)
tryTc (Name -> TcRn DataCon
tcLookupDataCon Name
dcname)
case Maybe DataCon
mb_dc of
Maybe DataCon
Nothing->
[ForeignHValue]
-> (ForeignHValue
-> IOEnv (Env TcGblEnv TcLclEnv) (Type, ForeignHValue))
-> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ForeignHValue]
pArgs ((ForeignHValue
-> IOEnv (Env TcGblEnv TcLclEnv) (Type, ForeignHValue))
-> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)])
-> (ForeignHValue
-> IOEnv (Env TcGblEnv TcLclEnv) (Type, ForeignHValue))
-> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
forall a b. (a -> b) -> a -> b
$ \ForeignHValue
x -> do
Type
tv <- Type -> TR Type
newVar Type
liftedTypeKind
(Type, ForeignHValue)
-> IOEnv (Env TcGblEnv TcLclEnv) (Type, ForeignHValue)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
tv, ForeignHValue
x)
Just DataCon
dc -> do
[Type]
arg_tys <- DataCon -> Type -> IOEnv (Env TcGblEnv TcLclEnv) [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
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
dcname SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
arg_tys)
[(Type, ForeignHValue)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Type, ForeignHValue)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)])
-> [(Type, ForeignHValue)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
forall a b. (a -> b) -> a -> b
$ ((Int, Type) -> ForeignHValue -> (Type, ForeignHValue))
-> [(Int, Type)] -> [ForeignHValue] -> [(Type, ForeignHValue)]
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
_ -> [(Type, ForeignHValue)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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])
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 (() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
ty of
[PrimRep
rep] | PrimRep -> Bool
isGcPtrRep PrimRep
rep -> (Int, [(Int, Type)]) -> TR (Int, [(Int, Type)])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, [(Int
i, Type
ty)])
| Bool
otherwise -> (Int, [(Int, Type)]) -> TR (Int, [(Int, Type)])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, [])
[PrimRep]
prim_reps ->
((Int, [(Int, Type)]) -> PrimRep -> TR (Int, [(Int, Type)]))
-> (Int, [(Int, Type)]) -> [PrimRep] -> TR (Int, [(Int, Type)])
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 TR Type
-> (Type -> TR (Int, [(Int, Type)])) -> TR (Int, [(Int, Type)])
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> (a -> IOEnv (Env TcGblEnv TcLclEnv) b)
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type
tv -> (Int, [(Int, Type)]) -> TR (Int, [(Int, Type)])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, [(Int, Type)]
extras [(Int, Type)] -> [(Int, Type)] -> [(Int, Type)]
forall a. [a] -> [a] -> [a]
++ [(Int
i, Type
tv)])
else (Int, [(Int, Type)]) -> TR (Int, [(Int, Type)])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 = ((Int, [(Int, Type)]) -> Type -> TR (Int, [(Int, Type)]))
-> (Int, [(Int, Type)]) -> [Type] -> TR (Int, [(Int, Type)])
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
(Int, [(Int, Type)]) -> TR (Int, [(Int, Type)])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, [(Int, Type)]
discovered [(Int, Type)] -> [(Int, Type)] -> [(Int, Type)]
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 -> IOEnv (Env TcGblEnv TcLclEnv) [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
<+> (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
con_app_ty SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rep_con_app_ty
SDoc -> SDoc -> SDoc
$$ Maybe (TyCon, [Type]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
rep_con_app_ty)))
; Bool -> (() -> TR ()) -> () -> TR ()
forall a. HasCallStack => Bool -> a -> a
assert ((TyVar -> Bool) -> [TyVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TyVar -> Bool
isTyVar [TyVar]
ex_tvs ) () -> TR ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; (TCvSubst
subst, [TyVar]
_) <- [TyVar] -> TR (TCvSubst, [TyVar])
instTyVars ([TyVar]
univ_tvs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
ex_tvs)
; Type -> Type -> TR ()
addConstraint Type
rep_con_app_ty ((() :: Constraint) => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst (DataCon -> Type
dataConOrigResTy DataCon
dc))
; let con_arg_tys :: [Type]
con_arg_tys = (() :: Constraint) => TCvSubst -> [Type] -> [Type]
TCvSubst -> [Type] -> [Type]
substTys TCvSubst
subst ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing ([Scaled Type] -> [Type]) -> [Scaled Type] -> [Type]
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
<+> (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rep_con_app_ty SDoc -> SDoc -> SDoc
$$ [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
con_arg_tys SDoc -> SDoc -> SDoc
$$ TCvSubst -> SDoc
forall a. Outputable a => a -> SDoc
ppr TCvSubst
subst))
; [Type] -> IOEnv (Env TcGblEnv TcLclEnv) [Type]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 :: [TyVar] -> Bool
check1 :: [TyVar] -> Bool
check1 [TyVar]
tvs = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Type -> Bool
isHigherKind ((TyVar -> Type) -> [TyVar] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Type
tyVarKind [TyVar]
tvs)
where
isHigherKind :: Type -> Bool
isHigherKind = Bool -> Bool
not (Bool -> Bool) -> (Type -> Bool) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TyCoBinder] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TyCoBinder] -> Bool) -> (Type -> [TyCoBinder]) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TyCoBinder], Type) -> [TyCoBinder]
forall a b. (a, b) -> a
fst (([TyCoBinder], Type) -> [TyCoBinder])
-> (Type -> ([TyCoBinder], Type)) -> Type -> [TyCoBinder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ([TyCoBinder], Type)
splitPiTys
check2 :: Type -> Type -> Bool
check2 :: Type -> Type -> Bool
check2 Type
rtti_ty Type
old_ty = Type -> Type -> Bool
check2' (Type -> Type
tauPart Type
rtti_ty) (Type -> Type
tauPart Type
old_ty)
where
check2' :: Type -> Type -> Bool
check2' Type
rtti_ty Type
old_ty
| Just (TyCon
_, [Type]
rttis) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
rtti_ty
= case () of
()
_ | Just (TyCon
_,[Type]
olds) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
old_ty
-> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Bool) -> [Type] -> [Type] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> Type -> Bool
check2 [Type]
rttis [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
tauPart :: Type -> Type
tauPart Type
ty = Type
tau
where
([TyVar]
_, [Type]
_, Type
tau) = Type -> ([TyVar], [Type], Type)
tcSplitNestedSigmaTys Type
ty
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 TR Type -> (Type -> TR (Type, Type)) -> TR (Type, Type)
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> (a -> IOEnv (Env TcGblEnv TcLclEnv) b)
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type
rhs' -> (Type, Type) -> TR (Type, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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
= TR Type -> TR Type -> TR Type
forall a. TR a -> TR a -> TR a
recoverTR (Type -> TR Type
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
r) (TR Type -> TR Type) -> TR Type -> TR Type
forall a b. (a -> b) -> a -> b
$ do
Indirect Type
ty_v <- TyVar -> TcM MetaDetails
readMetaTyVar TyVar
tv
SDoc -> TR ()
traceTR (SDoc -> TR ()) -> SDoc -> TR ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
fsep [String -> SDoc
text String
"(congruence) Following indirect tyvar:",
TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
tv, SDoc
equals, Type -> SDoc
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
Type -> TR Type
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
lhs
, Just (TyCon
tycon_r, [Type]
_) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
rhs
, TyCon
tycon_l TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
/= TyCon
tycon_r
= TyCon -> Type -> TR Type
upgrade TyCon
tycon_l Type
r
| Bool
otherwise = Type -> TR Type
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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
<>
TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
new_tycon SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" for " SDoc -> SDoc -> SDoc
<> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
Type -> TR Type
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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
<> Type -> 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
<> TyCon -> 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
_ <- TcM TcCoercionN -> TcM TcCoercionN
forall a. TcM a -> TcM a
liftTcM (Maybe TypedThing -> Type -> Type -> TcM TcCoercionN
unifyType Maybe TypedThing
forall a. Maybe a
Nothing Type
ty Type
rep_ty)
Type -> TR Type
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty'
zonkTerm :: Term -> TcM Term
zonkTerm :: Term -> TR Term
zonkTerm = TermFoldM (IOEnv (Env TcGblEnv TcLclEnv)) Term -> Term -> TR Term
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 TR Type -> (Type -> TR Term) -> TR Term
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> (a -> IOEnv (Env TcGblEnv TcLclEnv) b)
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type
ty' ->
Term -> TR Term
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 TR Type -> (Type -> TR Term) -> TR Term
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> (a -> IOEnv (Env TcGblEnv TcLclEnv) b)
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type
ty ->
Term -> TR Term
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 TR Type -> (Type -> TR Term) -> TR Term
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> (a -> IOEnv (Env TcGblEnv TcLclEnv) b)
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type
ty' ->
Term -> TR Term
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return(Term -> TR Term) -> Term -> TR Term
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 -> TR Term
fRefWrapM = \Type
ty Term
t -> (Type -> Term -> Term)
-> IOEnv (Env TcGblEnv TcLclEnv) (Type -> Term -> Term)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Type -> Term -> Term
RefWrap IOEnv (Env TcGblEnv TcLclEnv) (Type -> Term -> Term)
-> TR Type -> IOEnv (Env TcGblEnv TcLclEnv) (Term -> Term)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap`
Type -> TR Type
zonkRttiType Type
ty IOEnv (Env TcGblEnv TcLclEnv) (Term -> Term) -> TR Term -> TR Term
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` Term -> TR Term
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
t
, fPrimM :: Type -> [Word] -> TR Term
fPrimM = (Term -> TR Term
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return(Term -> TR Term) -> ([Word] -> Term) -> [Word] -> TR Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (([Word] -> Term) -> [Word] -> TR Term)
-> (Type -> [Word] -> Term) -> Type -> [Word] -> TR Term
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 = [TyVar] -> Bool
forall a. [a] -> Bool
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])
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 [TyVar] -> [Type] -> [(TyVar, Type)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Type]
all_args
, TyVar
tyv TyVar -> [TyVar] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [TyVar]
phantom_vars]
= (Type -> Bool) -> [Type] -> Bool
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
= (Type -> Bool) -> [Type] -> Bool
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 <- (DataCon -> [TyVar]) -> [DataCon] -> [TyVar]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DataCon -> [TyVar]
dataConUnivTyVars [DataCon]
dcs
= TyCon -> [TyVar]
tyConTyVars TyCon
tc [TyVar] -> [TyVar] -> [TyVar]
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 = ( (TyVar -> Bool) -> [TyVar] -> [TyVar]
forall a. (a -> Bool) -> [a] -> [a]
filter TyVar -> Bool
isTyVar ([TyVar] -> [TyVar]) -> [TyVar] -> [TyVar]
forall a b. (a -> b) -> a -> b
$
Type -> [TyVar]
tyCoVarsOfTypeWellScoped Type
rho
, Type
ty)
where
([TyVar]
_tvs, [Type]
_, Type
rho) = Type -> ([TyVar], [Type], Type)
tcSplitNestedSigmaTys Type
ty