{-# 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 hiding (head, init, last, tail)
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.Core.TyCon
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.Types.Var
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 Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
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. HasCallStack => 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 = \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
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
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
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
forall doc. IsLine doc => String -> doc
text String
dc_tag SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ([SDoc] -> SDoc) -> [SDoc] -> SDoc
pprDeeperList [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
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
forall doc. IsOutput doc => doc -> doc -> doc
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
forall doc. IsLine doc => [doc] -> doc
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
forall doc. IsLine doc => [doc] -> doc
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
forall doc. IsLine doc => String -> doc
text String
"GHC.Prim.MutVar#" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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
forall doc. IsLine doc => Char -> doc
char Char
'_' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsOutput doc => doc -> doc
whenPprDebug (SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> 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
forall doc. IsLine doc => doc -> doc
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
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Type -> SDoc
pprSigmaType Type
ty
ppr_termM1 Term{} = String -> m SDoc
forall a. HasCallStack => String -> a
panic String
"ppr_termM1 - Term"
ppr_termM1 RefWrap{} = String -> m SDoc
forall a. HasCallStack => String -> a
panic String
"ppr_termM1 - RefWrap"
ppr_termM1 NewtypeWrap{} = String -> m SDoc
forall a. HasCallStack => 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
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
real_term)
pprNewtypeWrap TermPrinterM m
_ Int
_ Term
_ = String -> m SDoc
forall a. HasCallStack => 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. HasCallStack => 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
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc) -> ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
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
forall doc. IsLine doc => Int -> doc
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
forall doc. IsLine doc => Float -> doc
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
forall doc. IsLine doc => Double -> doc
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
forall doc. IsLine doc => Double -> doc
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
forall doc. IsLine doc => Integer -> doc
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
forall doc. IsLine doc => Integer -> doc
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. HasCallStack => 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
forall doc. IsLine doc => Integer -> doc
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. HasCallStack => 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 :: NonEmpty Term
elems = Term
h Term -> [Term] -> NonEmpty Term
forall a. a -> [a] -> NonEmpty a
:| Term -> [Term]
getListTerms Term
t
elemList :: [Item (NonEmpty Term)]
elemList = NonEmpty Term -> [Item (NonEmpty Term)]
forall l. IsList l => l -> [Item l]
toList NonEmpty Term
elems
isConsLast :: Bool
isConsLast = Bool -> Bool
not (Term -> Type
termType (NonEmpty Term -> Term
forall a. NonEmpty a -> a
NE.last NonEmpty Term
elems) Type -> Type -> Bool
`eqType` Term -> Type
termType Term
h)
is_string :: Bool
is_string = (Term -> Bool) -> NonEmpty 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) NonEmpty 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]}]} <- [Item (NonEmpty Term)]
[Term]
elemList ]
[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) [Item (NonEmpty Term)]
[Term]
elemList
if Bool
is_string
then SDoc -> m SDoc
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
Ppr.doubleQuotes (String -> SDoc
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => [doc] -> doc
fsep
([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate (SDoc
forall doc. IsLine doc => doc
spaceSDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>SDoc
forall doc. IsLine doc => doc
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
forall doc. IsLine doc => doc -> doc
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]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
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. HasCallStack => 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
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
text String
"<stablePtr>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
stableNamePrimTyCon = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<stableName>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
statePrimTyCon = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<statethread>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
proxyPrimTyCon = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<proxy>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
realWorldTyCon = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<realworld>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
threadIdPrimTyCon = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<ThreadId>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
weakPrimTyCon = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<Weak>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
arrayPrimTyCon = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<array>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
smallArrayPrimTyCon = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<smallArray>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
byteArrayPrimTyCon = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<bytearray>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutableArrayPrimTyCon = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<mutableArray>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
smallMutableArrayPrimTyCon = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<smallMutableArray>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutableByteArrayPrimTyCon = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<mutableByteArray>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutVarPrimTyCon = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<mutVar>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mVarPrimTyCon = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<mVar>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tVarPrimTyCon = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<tVar>"
| Bool
otherwise = Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'<' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
t SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
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 (Subst, [TcTyVar])
instTyVars :: [TyVar] -> TR (Subst, [TyVar])
instTyVars [TyVar]
tvs
= TR (Subst, [TyVar]) -> TR (Subst, [TyVar])
forall a. TcM a -> TcM a
liftTcM (TR (Subst, [TyVar]) -> TR (Subst, [TyVar]))
-> TR (Subst, [TyVar]) -> TR (Subst, [TyVar])
forall a b. (a -> b) -> a -> b
$ ((Subst, [TyVar]), WantedConstraints) -> (Subst, [TyVar])
forall a b. (a, b) -> a
fst (((Subst, [TyVar]), WantedConstraints) -> (Subst, [TyVar]))
-> IOEnv
(Env TcGblEnv TcLclEnv) ((Subst, [TyVar]), WantedConstraints)
-> TR (Subst, [TyVar])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TR (Subst, [TyVar])
-> IOEnv
(Env TcGblEnv TcLclEnv) ((Subst, [TyVar]), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints ([TyVar] -> TR (Subst, [TyVar])
newMetaTyVars [TyVar]
tvs)
type RttiInstantiation = [(TcTyVar, TyVar)]
instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation)
instScheme :: QuantifiedType -> TR (Type, RttiInstantiation)
instScheme ([TyVar]
tvs, Type
ty)
= do { (Subst
subst, [TyVar]
tvs') <- [TyVar] -> TR (Subst, [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
forall doc. IsLine doc => String -> doc
text String
"instScheme" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ([TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [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) => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
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
getTyVar_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
forall doc. IsLine doc => String -> doc
text String
"add constraint:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
fsep [Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
actual, SDoc
forall doc. IsLine doc => doc
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
forall doc. IsLine doc => [doc] -> doc
fsep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Failed to unify", Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
actual,
String -> SDoc
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
text String
"Term reconstruction started with initial type " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> 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
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
text String
"check2 failed" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens
(Term -> SDoc
forall a. Outputable a => a -> SDoc
ppr Term
term SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"::" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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 (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty of
Just (TyCon
_tc, Type
_ : [Type]
_) | Bool -> Bool
not (Type -> Bool
isFunTy Type
ty)
-> 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
forall doc. IsLine doc => String -> doc
text String
"Term reconstruction completed." SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Term obtained: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Term -> SDoc
forall a. Outputable a => a -> SDoc
ppr Term
term SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Type obtained: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> 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
forall doc. IsLine doc => String -> doc
text String
"Gave up reconstructing a term after" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
max_depth SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
text String
"Forcing a " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
text String
"Exception occurred:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
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
$ (() :: Constraint) => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany
Type
contents_ty (TyCon -> [Type] -> Type
mkTyConApp TyCon
tycon [Type
lev, Type
world,Type
contents_ty])
Type -> Type -> TR ()
addConstraint ((() :: Constraint) => Type -> Type -> Type
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
forall doc. IsLine doc => String -> doc
text String
"entering a constructor " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Word] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Word]
dArgs SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
if Bool
monomorphic
then SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"already monomorphic: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
my_ty)
else SDoc
forall doc. IsOutput doc => doc
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
forall doc. IsLine doc => String -> doc
text String
"Not constructor" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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
forall doc. IsLine doc => String -> doc
text String
"Is constructor" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dc SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ 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
forall doc. IsLine doc => String -> doc
text String
"ByteArray# closure, size " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> 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
forall doc. IsLine doc => String -> doc
text String
"Unknown closure:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
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 = 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 = 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 <- TcRnIf TcGblEnv TcLclEnv Platform
forall a b. TcRnIf a b 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
forall doc. IsLine doc => String -> doc
text String
"RTTI started with initial type " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> 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
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
text String
"check2 passed" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
old_ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ 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
forall doc. IsLine doc => String -> doc
text String
"check2 failed" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
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
forall doc. IsLine doc => String -> doc
text String
"RTTI completed. Type obtained:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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
forall doc. IsLine doc => String -> doc
text String
"Failed to reconstruct a type after " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
max_depth SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
text String
"go" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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
forall doc. IsLine doc => String -> doc
text String
"Constr1" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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
forall doc. IsLine doc => String -> doc
text String
"Constr2" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
dcname SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [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 Subst
improveRTTIType :: HscEnv -> Type -> Type -> Maybe Subst
improveRTTIType HscEnv
_ Type
base_ty Type
new_ty = Type -> Type -> Maybe Subst
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
forall doc. IsLine doc => String -> doc
text String
"getDataConArgTys 1" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
con_app_ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rep_con_app_ty
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ 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 ()
; (Subst
subst, [TyVar]
_) <- [TyVar] -> TR (Subst, [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) => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst (DataCon -> Type
dataConOrigResTy DataCon
dc))
; let con_arg_tys :: [Type]
con_arg_tys = (() :: Constraint) => Subst -> [Type] -> [Type]
Subst -> [Type] -> [Type]
substTys Subst
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
forall doc. IsLine doc => String -> doc
text String
"getDataConArgTys 2" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rep_con_app_ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
con_arg_tys SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Subst -> SDoc
forall a. Outputable a => a -> SDoc
ppr Subst
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
. [PiTyBinder] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([PiTyBinder] -> Bool) -> (Type -> [PiTyBinder]) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([PiTyBinder], Type) -> [PiTyBinder]
forall a b. (a, b) -> a
fst (([PiTyBinder], Type) -> [PiTyBinder])
-> (Type -> ([PiTyBinder], Type)) -> Type -> [PiTyBinder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ([PiTyBinder], 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
forall doc. IsLine doc => [doc] -> doc
fsep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(congruence) Following indirect tyvar:",
TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
tv, SDoc
forall doc. IsLine doc => doc
equals, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty_v]
Type -> Type -> TR Type
go Type
ty_v Type
r
| Just (FunTyFlag
af1,Type
w1,Type
l1,Type
l2) <- Type -> Maybe (FunTyFlag, Type, Type, Type)
splitFunTy_maybe Type
l
, Just (FunTyFlag
af2,Type
w2,Type
r1,Type
r2) <- Type -> Maybe (FunTyFlag, Type, Type, Type)
splitFunTy_maybe Type
r
, FunTyFlag
af1FunTyFlag -> FunTyFlag -> Bool
forall a. Eq a => a -> a -> Bool
==FunTyFlag
af2
, 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 ((() :: Constraint) => FunTyFlag -> Type -> Type -> Type -> Type
FunTyFlag -> Type -> Type -> Type -> Type
mkFunTy FunTyFlag
af1 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
forall doc. IsLine doc => String -> doc
text String
"(Upgrade) Not matching newtype evidence: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
new_tycon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" for " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> 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
forall doc. IsLine doc => String -> doc
text String
"(Upgrade) upgraded " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" in presence of newtype evidence " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
new_tycon)
(Subst
_, [TyVar]
vars) <- [TyVar] -> TR (Subst, [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 (FunTyFlag
_, Type
_, Type
ty1, Type
ty2) <- Type -> Maybe (FunTyFlag, 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