{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, MagicHash #-}
module RtClosureInspect(
cvObtainTerm,
cvReconstructType,
improveRTTIType,
Term(..),
isFullyEvaluatedTerm,
termType, mapTermType, termTyCoVars,
foldTerm, TermFold(..),
cPprTerm, cPprTermBase,
constrClosToName
) where
#include "HsVersions.h"
import GhcPrelude
import GHCi
import GHCi.RemoteTypes
import HscTypes
import DataCon
import Type
import RepType
import qualified Unify as U
import Var
import TcRnMonad
import TcType
import TcMType
import TcHsSyn ( zonkTcTypeToTypeX, mkEmptyZonkEnv, ZonkFlexi( RuntimeUnkFlexi ) )
import TcUnify
import TcEnv
import TyCon
import Name
import OccName
import Module
import IfaceEnv
import Util
import VarSet
import BasicTypes ( Boxity(..) )
import TysPrim
import PrelNames
import TysWiredIn
import DynFlags
import Outputable as Ppr
import GHC.Char
import GHC.Exts.Heap
import SMRep ( roundUpTo )
import Control.Monad
import Data.Maybe
import Data.List
#if defined(INTEGER_GMP)
import GHC.Exts
import Data.Array.Base
import GHC.Integer.GMP.Internals
#elif defined(INTEGER_SIMPLE)
import GHC.Exts
import GHC.Integer.Simple.Internals
#endif
import qualified Data.Sequence as Seq
import Data.Sequence (viewl, ViewL(..))
import Foreign
import System.IO.Unsafe
data Term = Term { Term -> RttiType
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 -> RttiType
termType t :: Term
t = Term -> RttiType
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 _ = Bool
False
instance Outputable (Term) where
ppr :: Term -> SDoc
ppr t :: Term
t | Just doc :: SDoc
doc <- CustomTermPrinter Maybe -> Term -> Maybe SDoc
forall (m :: * -> *).
Monad m =>
CustomTermPrinter m -> Term -> m SDoc
cPprTerm CustomTermPrinter Maybe
forall (m :: * -> *). Monad m => CustomTermPrinter m
cPprTermBase Term
t = SDoc
doc
| Bool
otherwise = String -> SDoc
forall a. String -> a
panic "Outputable Term instance"
isThunk :: GenClosure a -> Bool
isThunk :: GenClosure a -> Bool
isThunk ThunkClosure{} = Bool
True
isThunk APClosure{} = Bool
True
isThunk APStackClosure{} = Bool
True
isThunk _ = Bool
False
constrClosToName :: HscEnv -> GenClosure a -> IO (Either String Name)
constrClosToName :: HscEnv -> GenClosure a -> IO (Either String Name)
constrClosToName hsc_env :: 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 :: Module
modName = UnitId -> ModuleName -> Module
mkModule (String -> UnitId
stringToUnitId 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` HscEnv -> Module -> OccName -> IO Name
lookupOrigIO HscEnv
hsc_env Module
modName OccName
occName
constrClosToName _hsc_env :: HscEnv
_hsc_env clos :: GenClosure a
clos =
Either String Name -> IO (Either String Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String Name
forall a b. a -> Either a b
Left ("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 (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 { TermFold a -> TermProcessor a a
fTerm :: TermProcessor a a
, TermFold a -> RttiType -> [Word] -> a
fPrim :: RttiType -> [Word] -> a
, TermFold a
-> ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> a
fSuspension :: ClosureType -> RttiType -> ForeignHValue
-> Maybe Name -> a
, TermFold a -> RttiType -> Either String DataCon -> a -> a
fNewtypeWrap :: RttiType -> Either String DataCon
-> a -> a
, TermFold a -> RttiType -> a -> a
fRefWrap :: RttiType -> a -> a
}
data TermFoldM m a =
TermFoldM {TermFoldM m a -> TermProcessor a (m a)
fTermM :: TermProcessor a (m a)
, TermFoldM m a -> RttiType -> [Word] -> m a
fPrimM :: RttiType -> [Word] -> m a
, TermFoldM m a
-> ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> m a
fSuspensionM :: ClosureType -> RttiType -> ForeignHValue
-> Maybe Name -> m a
, TermFoldM m a -> RttiType -> Either String DataCon -> a -> m a
fNewtypeWrapM :: RttiType -> Either String DataCon
-> a -> m a
, TermFoldM m a -> RttiType -> a -> m a
fRefWrapM :: RttiType -> a -> m a
}
foldTerm :: TermFold a -> Term -> a
foldTerm :: TermFold a -> Term -> a
foldTerm tf :: TermFold a
tf (Term ty :: RttiType
ty dc :: Either String DataCon
dc v :: ForeignHValue
v tt :: [Term]
tt) = TermFold a -> TermProcessor a a
forall a. TermFold a -> TermProcessor a a
fTerm TermFold a
tf RttiType
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 tf :: TermFold a
tf (Prim ty :: RttiType
ty v :: [Word]
v ) = TermFold a -> RttiType -> [Word] -> a
forall a. TermFold a -> RttiType -> [Word] -> a
fPrim TermFold a
tf RttiType
ty [Word]
v
foldTerm tf :: TermFold a
tf (Suspension ct :: ClosureType
ct ty :: RttiType
ty v :: ForeignHValue
v b :: Maybe Name
b) = TermFold a
-> ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> a
forall a.
TermFold a
-> ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> a
fSuspension TermFold a
tf ClosureType
ct RttiType
ty ForeignHValue
v Maybe Name
b
foldTerm tf :: TermFold a
tf (NewtypeWrap ty :: RttiType
ty dc :: Either String DataCon
dc t :: Term
t) = TermFold a -> RttiType -> Either String DataCon -> a -> a
forall a. TermFold a -> RttiType -> Either String DataCon -> a -> a
fNewtypeWrap TermFold a
tf RttiType
ty Either String DataCon
dc (TermFold a -> Term -> a
forall a. TermFold a -> Term -> a
foldTerm TermFold a
tf Term
t)
foldTerm tf :: TermFold a
tf (RefWrap ty :: RttiType
ty t :: Term
t) = TermFold a -> RttiType -> a -> a
forall a. TermFold a -> RttiType -> a -> a
fRefWrap TermFold a
tf RttiType
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 :: TermFoldM m a -> Term -> m a
foldTermM tf :: TermFoldM m a
tf (Term ty :: RttiType
ty dc :: Either String DataCon
dc v :: ForeignHValue
v tt :: [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)
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 (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 RttiType
ty Either String DataCon
dc ForeignHValue
v
foldTermM tf :: TermFoldM m a
tf (Prim ty :: RttiType
ty v :: [Word]
v ) = TermFoldM m a -> RttiType -> [Word] -> m a
forall (m :: * -> *) a. TermFoldM m a -> RttiType -> [Word] -> m a
fPrimM TermFoldM m a
tf RttiType
ty [Word]
v
foldTermM tf :: TermFoldM m a
tf (Suspension ct :: ClosureType
ct ty :: RttiType
ty v :: ForeignHValue
v b :: Maybe Name
b) = TermFoldM m a
-> ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> m a
forall (m :: * -> *) a.
TermFoldM m a
-> ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> m a
fSuspensionM TermFoldM m a
tf ClosureType
ct RttiType
ty ForeignHValue
v Maybe Name
b
foldTermM tf :: TermFoldM m a
tf (NewtypeWrap ty :: RttiType
ty dc :: Either String DataCon
dc t :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermFoldM m a -> RttiType -> Either String DataCon -> a -> m a
forall (m :: * -> *) a.
TermFoldM m a -> RttiType -> Either String DataCon -> a -> m a
fNewtypeWrapM TermFoldM m a
tf RttiType
ty Either String DataCon
dc
foldTermM tf :: TermFoldM m a
tf (RefWrap ty :: RttiType
ty t :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermFoldM m a -> RttiType -> a -> m a
forall (m :: * -> *) a. TermFoldM m a -> RttiType -> a -> m a
fRefWrapM TermFoldM m a
tf RttiType
ty
idTermFold :: TermFold Term
idTermFold :: TermFold Term
idTermFold = TermFold :: forall a.
TermProcessor a a
-> (RttiType -> [Word] -> a)
-> (ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> a)
-> (RttiType -> Either String DataCon -> a -> a)
-> (RttiType -> a -> a)
-> TermFold a
TermFold {
fTerm :: TermProcessor Term Term
fTerm = TermProcessor Term Term
Term,
fPrim :: RttiType -> [Word] -> Term
fPrim = RttiType -> [Word] -> Term
Prim,
fSuspension :: ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> Term
fSuspension = ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> Term
Suspension,
fNewtypeWrap :: RttiType -> Either String DataCon -> Term -> Term
fNewtypeWrap = RttiType -> Either String DataCon -> Term -> Term
NewtypeWrap,
fRefWrap :: RttiType -> Term -> Term
fRefWrap = RttiType -> Term -> Term
RefWrap
}
mapTermType :: (RttiType -> Type) -> Term -> Term
mapTermType :: (RttiType -> RttiType) -> Term -> Term
mapTermType f :: RttiType -> RttiType
f = TermFold Term -> Term -> Term
forall a. TermFold a -> Term -> a
foldTerm TermFold Term
idTermFold {
fTerm :: TermProcessor Term Term
fTerm = \ty :: RttiType
ty dc :: Either String DataCon
dc hval :: ForeignHValue
hval tt :: [Term]
tt -> TermProcessor Term Term
Term (RttiType -> RttiType
f RttiType
ty) Either String DataCon
dc ForeignHValue
hval [Term]
tt,
fSuspension :: ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> Term
fSuspension = \ct :: ClosureType
ct ty :: RttiType
ty hval :: ForeignHValue
hval n :: Maybe Name
n ->
ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> Term
Suspension ClosureType
ct (RttiType -> RttiType
f RttiType
ty) ForeignHValue
hval Maybe Name
n,
fNewtypeWrap :: RttiType -> Either String DataCon -> Term -> Term
fNewtypeWrap= \ty :: RttiType
ty dc :: Either String DataCon
dc t :: Term
t -> RttiType -> Either String DataCon -> Term -> Term
NewtypeWrap (RttiType -> RttiType
f RttiType
ty) Either String DataCon
dc Term
t,
fRefWrap :: RttiType -> Term -> Term
fRefWrap = \ty :: RttiType
ty t :: Term
t -> RttiType -> Term -> Term
RefWrap (RttiType -> RttiType
f RttiType
ty) Term
t}
mapTermTypeM :: Monad m => (RttiType -> m Type) -> Term -> m Term
mapTermTypeM :: (RttiType -> m RttiType) -> Term -> m Term
mapTermTypeM f :: RttiType -> m RttiType
f = TermFoldM m Term -> Term -> m Term
forall (m :: * -> *) a. Monad m => TermFoldM m a -> Term -> m a
foldTermM TermFoldM :: forall (m :: * -> *) a.
TermProcessor a (m a)
-> (RttiType -> [Word] -> m a)
-> (ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> m a)
-> (RttiType -> Either String DataCon -> a -> m a)
-> (RttiType -> a -> m a)
-> TermFoldM m a
TermFoldM {
fTermM :: TermProcessor Term (m Term)
fTermM = \ty :: RttiType
ty dc :: Either String DataCon
dc hval :: ForeignHValue
hval tt :: [Term]
tt -> RttiType -> m RttiType
f RttiType
ty m RttiType -> (RttiType -> m Term) -> m Term
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ty' :: RttiType
ty' -> Term -> m Term
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 RttiType
ty' Either String DataCon
dc ForeignHValue
hval [Term]
tt,
fPrimM :: RttiType -> [Word] -> m Term
fPrimM = (Term -> m Term
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)
-> (RttiType -> [Word] -> Term) -> RttiType -> [Word] -> m Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RttiType -> [Word] -> Term
Prim,
fSuspensionM :: ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> m Term
fSuspensionM = \ct :: ClosureType
ct ty :: RttiType
ty hval :: ForeignHValue
hval n :: Maybe Name
n ->
RttiType -> m RttiType
f RttiType
ty m RttiType -> (RttiType -> m Term) -> m Term
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ty' :: RttiType
ty' -> Term -> m Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> m Term) -> Term -> m Term
forall a b. (a -> b) -> a -> b
$ ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> Term
Suspension ClosureType
ct RttiType
ty' ForeignHValue
hval Maybe Name
n,
fNewtypeWrapM :: RttiType -> Either String DataCon -> Term -> m Term
fNewtypeWrapM= \ty :: RttiType
ty dc :: Either String DataCon
dc t :: Term
t -> RttiType -> m RttiType
f RttiType
ty m RttiType -> (RttiType -> m Term) -> m Term
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ty' :: RttiType
ty' -> Term -> m Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> m Term) -> Term -> m Term
forall a b. (a -> b) -> a -> b
$ RttiType -> Either String DataCon -> Term -> Term
NewtypeWrap RttiType
ty' Either String DataCon
dc Term
t,
fRefWrapM :: RttiType -> Term -> m Term
fRefWrapM = \ty :: RttiType
ty t :: Term
t -> RttiType -> m RttiType
f RttiType
ty m RttiType -> (RttiType -> m Term) -> m Term
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ty' :: RttiType
ty' -> Term -> m Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> m Term) -> Term -> m Term
forall a b. (a -> b) -> a -> b
$ RttiType -> Term -> Term
RefWrap RttiType
ty' Term
t}
termTyCoVars :: Term -> TyCoVarSet
termTyCoVars :: Term -> TyCoVarSet
termTyCoVars = TermFold TyCoVarSet -> Term -> TyCoVarSet
forall a. TermFold a -> Term -> a
foldTerm TermFold :: forall a.
TermProcessor a a
-> (RttiType -> [Word] -> a)
-> (ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> a)
-> (RttiType -> Either String DataCon -> a -> a)
-> (RttiType -> a -> a)
-> TermFold a
TermFold {
fTerm :: TermProcessor TyCoVarSet TyCoVarSet
fTerm = \ty :: RttiType
ty _ _ tt :: [TyCoVarSet]
tt ->
RttiType -> TyCoVarSet
tyCoVarsOfType RttiType
ty TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` [TyCoVarSet] -> TyCoVarSet
concatVarEnv [TyCoVarSet]
tt,
fSuspension :: ClosureType
-> RttiType -> ForeignHValue -> Maybe Name -> TyCoVarSet
fSuspension = \_ ty :: RttiType
ty _ _ -> RttiType -> TyCoVarSet
tyCoVarsOfType RttiType
ty,
fPrim :: RttiType -> [Word] -> TyCoVarSet
fPrim = \ _ _ -> TyCoVarSet
emptyVarSet,
fNewtypeWrap :: RttiType -> Either String DataCon -> TyCoVarSet -> TyCoVarSet
fNewtypeWrap= \ty :: RttiType
ty _ t :: TyCoVarSet
t -> RttiType -> TyCoVarSet
tyCoVarsOfType RttiType
ty TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` TyCoVarSet
t,
fRefWrap :: RttiType -> TyCoVarSet -> TyCoVarSet
fRefWrap = \ty :: RttiType
ty t :: TyCoVarSet
t -> RttiType -> TyCoVarSet
tyCoVarsOfType RttiType
ty TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` TyCoVarSet
t}
where concatVarEnv :: [TyCoVarSet] -> TyCoVarSet
concatVarEnv = (TyCoVarSet -> TyCoVarSet -> TyCoVarSet)
-> TyCoVarSet -> [TyCoVarSet] -> TyCoVarSet
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 = 10
app_prec :: Int
app_prec = Int
max_prec
cons_prec :: Int
cons_prec = 5
pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
pprTermM :: TermPrinterM m -> TermPrinterM m
pprTermM y :: TermPrinterM m
y p :: Int
p t :: 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 :: TermPrinterM m -> TermPrinterM m
ppr_termM y :: TermPrinterM m
y p :: Int
p Term{dc :: Term -> Either String DataCon
dc=Left dc_tag :: 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)
mapM (TermPrinterM m
y Int
app_prec) [Term]
tt
SDoc -> m SDoc
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 (t :: * -> *) a. Foldable t => t a -> Bool
null [Term]
tt) Bool -> Bool -> Bool
&& Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
app_prec)
(String -> SDoc
text String
dc_tag SDoc -> SDoc -> SDoc
<+> ([SDoc] -> SDoc) -> [SDoc] -> SDoc
pprDeeperList [SDoc] -> SDoc
fsep [SDoc]
tt_docs)
ppr_termM y :: TermPrinterM m
y p :: Int
p Term{dc :: Term -> Either String DataCon
dc=Right dc :: 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)
mapM (TermPrinterM m
y Int
app_prec) [Term]
tt
; SDoc -> m SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc -> SDoc
ifPprDebug ([SDoc] -> SDoc
show_tm [SDoc]
tt_docs')
([SDoc] -> SDoc
show_tm ([RttiType] -> [SDoc] -> [SDoc]
forall b a. [b] -> [a] -> [a]
dropList (DataCon -> [RttiType]
dataConTheta DataCon
dc) [SDoc]
tt_docs'))
}
where
show_tm :: [SDoc] -> SDoc
show_tm tt_docs :: [SDoc]
tt_docs
| [SDoc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SDoc]
tt_docs = DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dc
| Bool
otherwise = Bool -> SDoc -> SDoc
cparen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
app_prec) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
sep [DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dc, Int -> SDoc -> SDoc
nest 2 (([SDoc] -> SDoc) -> [SDoc] -> SDoc
pprDeeperList [SDoc] -> SDoc
fsep [SDoc]
tt_docs)]
ppr_termM y :: TermPrinterM m
y p :: 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 y :: TermPrinterM m
y p :: 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 (m :: * -> *) a. Monad m => a -> m a
return(SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ Bool -> SDoc -> SDoc
cparen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
app_prec) (String -> SDoc
text "GHC.Prim.MutVar#" SDoc -> SDoc -> SDoc
<+> SDoc
contents)
ppr_termM _ _ t :: 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 :: Term -> m SDoc
ppr_termM1 Prim{valRaw :: Term -> [Word]
valRaw=[Word]
words, ty :: Term -> RttiType
ty=RttiType
ty} =
SDoc -> m SDoc
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 (RttiType -> TyCon
tyConAppTyCon RttiType
ty) [Word]
words
ppr_termM1 Suspension{ty :: Term -> RttiType
ty=RttiType
ty, bound_to :: Term -> Maybe Name
bound_to=Maybe Name
Nothing} =
SDoc -> m SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> SDoc
char '_' SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
whenPprDebug (String -> SDoc
text "::" SDoc -> SDoc -> SDoc
<> RttiType -> SDoc
forall a. Outputable a => a -> SDoc
ppr RttiType
ty))
ppr_termM1 Suspension{ty :: Term -> RttiType
ty=RttiType
ty, bound_to :: Term -> Maybe Name
bound_to=Just n :: Name
n}
| Bool
otherwise = SDoc -> m SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return(SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc
parens(SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n SDoc -> SDoc -> SDoc
<> String -> SDoc
text "::" SDoc -> SDoc -> SDoc
<> RttiType -> SDoc
forall a. Outputable a => a -> SDoc
ppr RttiType
ty
ppr_termM1 Term{} = String -> m SDoc
forall a. String -> a
panic "ppr_termM1 - Term"
ppr_termM1 RefWrap{} = String -> m SDoc
forall a. String -> a
panic "ppr_termM1 - RefWrap"
ppr_termM1 NewtypeWrap{} = String -> m SDoc
forall a. String -> a
panic "ppr_termM1 - NewtypeWrap"
pprNewtypeWrap :: TermPrinterM m -> TermPrinterM m
pprNewtypeWrap y :: TermPrinterM m
y p :: Int
p NewtypeWrap{ty :: Term -> RttiType
ty=RttiType
ty, wrapped_term :: Term -> Term
wrapped_term=Term
t}
| Just (tc :: TyCon
tc,_) <- HasCallStack => RttiType -> Maybe (TyCon, [RttiType])
RttiType -> Maybe (TyCon, [RttiType])
tcSplitTyConApp_maybe RttiType
ty
, ASSERT(isNewTyCon tc) True
, Just new_dc :: 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 (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ Bool -> SDoc -> SDoc
cparen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
app_prec) (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
new_dc SDoc -> SDoc -> SDoc
<+> SDoc
real_term)
pprNewtypeWrap _ _ _ = String -> m SDoc
forall a. String -> a
panic "pprNewtypeWrap"
type CustomTermPrinter m = TermPrinterM m
-> [Precedence -> Term -> (m (Maybe SDoc))]
cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
cPprTerm :: CustomTermPrinter m -> Term -> m SDoc
cPprTerm printers_ :: CustomTermPrinter m
printers_ = TermPrinterM m
go 0 where
printers :: [Int -> Term -> m (Maybe SDoc)]
printers = CustomTermPrinter m
printers_ TermPrinterM m
go
go :: TermPrinterM m
go prec :: Int
prec t :: 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
Nothing -> String -> m SDoc
forall a. String -> a
panic "cPprTerm"
Just doc :: SDoc
doc -> SDoc -> m SDoc
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
+1) SDoc
doc
firstJustM :: [m (Maybe a)] -> m (Maybe a)
firstJustM (mb :: m (Maybe a)
mb:mbs :: [m (Maybe a)]
mbs) = m (Maybe a)
mb m (Maybe a) -> (Maybe a -> m (Maybe a)) -> m (Maybe a)
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 (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 (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
cPprTermBase :: forall m. Monad m => CustomTermPrinter m
cPprTermBase :: CustomTermPrinter m
cPprTermBase y :: TermPrinterM m
y =
[ (Term -> Bool) -> TermPrinterM m -> Int -> Term -> m (Maybe SDoc)
ifTerm (RttiType -> Bool
isTupleTy(RttiType -> Bool) -> (Term -> RttiType) -> Term -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Term -> RttiType
ty) (\_p :: Int
_p -> ([SDoc] -> SDoc) -> m [SDoc] -> m SDoc
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (SDoc -> SDoc
parens (SDoc -> SDoc) -> ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
hcat ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma)
(m [SDoc] -> m SDoc) -> (Term -> m [SDoc]) -> Term -> m SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term -> m SDoc) -> [Term] -> m [SDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TermPrinterM m
y (-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 (\t :: Term
t -> TyCon -> RttiType -> Bool
isTyCon TyCon
listTyCon (Term -> RttiType
ty Term
t) Bool -> Bool -> Bool
&& Term -> [Term]
subTerms Term
t [Term] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` 2)
TermPrinterM m
ppr_list
, (Term -> Bool)
-> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
ifTerm' (TyCon -> RttiType -> Bool
isTyCon TyCon
intTyCon (RttiType -> Bool) -> (Term -> RttiType) -> Term -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> RttiType
ty) Int -> Term -> m (Maybe SDoc)
ppr_int
, (Term -> Bool)
-> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
ifTerm' (TyCon -> RttiType -> Bool
isTyCon TyCon
charTyCon (RttiType -> Bool) -> (Term -> RttiType) -> Term -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> RttiType
ty) Int -> Term -> m (Maybe SDoc)
ppr_char
, (Term -> Bool)
-> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
ifTerm' (TyCon -> RttiType -> Bool
isTyCon TyCon
floatTyCon (RttiType -> Bool) -> (Term -> RttiType) -> Term -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> RttiType
ty) Int -> Term -> m (Maybe SDoc)
ppr_float
, (Term -> Bool)
-> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
ifTerm' (TyCon -> RttiType -> Bool
isTyCon TyCon
doubleTyCon (RttiType -> Bool) -> (Term -> RttiType) -> Term -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> RttiType
ty) Int -> Term -> m (Maybe SDoc)
ppr_double
, (Term -> Bool)
-> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
ifTerm' (RttiType -> Bool
isIntegerTy (RttiType -> Bool) -> (Term -> RttiType) -> Term -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> RttiType
ty) Int -> Term -> m (Maybe SDoc)
ppr_integer
]
where
ifTerm :: (Term -> Bool)
-> (Precedence -> Term -> m SDoc)
-> Precedence -> Term -> m (Maybe SDoc)
ifTerm :: (Term -> Bool) -> TermPrinterM m -> Int -> Term -> m (Maybe SDoc)
ifTerm pred :: Term -> Bool
pred f :: TermPrinterM m
f = (Term -> Bool)
-> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
ifTerm' Term -> Bool
pred (\prec :: Int
prec t :: 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' pred :: Term -> Bool
pred f :: Int -> Term -> m (Maybe SDoc)
f prec :: Int
prec t :: Term
t@Term{}
| Term -> Bool
pred Term
t = Int -> Term -> m (Maybe SDoc)
f Int
prec Term
t
ifTerm' _ _ _ _ = Maybe SDoc -> m (Maybe SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SDoc
forall a. Maybe a
Nothing
isTupleTy :: RttiType -> Bool
isTupleTy ty :: RttiType
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
(tc :: TyCon
tc,_) <- HasCallStack => RttiType -> Maybe (TyCon, [RttiType])
RttiType -> Maybe (TyCon, [RttiType])
tcSplitTyConApp_maybe RttiType
ty
Bool -> Maybe Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> Bool
isBoxedTupleTyCon TyCon
tc)
isTyCon :: TyCon -> RttiType -> Bool
isTyCon a_tc :: TyCon
a_tc ty :: RttiType
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
(tc :: TyCon
tc,_) <- HasCallStack => RttiType -> Maybe (TyCon, [RttiType])
RttiType -> Maybe (TyCon, [RttiType])
tcSplitTyConApp_maybe RttiType
ty
Bool -> Maybe Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon
a_tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc)
isIntegerTy :: RttiType -> Bool
isIntegerTy ty :: RttiType
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
(tc :: TyCon
tc,_) <- HasCallStack => RttiType -> Maybe (TyCon, [RttiType])
RttiType -> Maybe (TyCon, [RttiType])
tcSplitTyConApp_maybe RttiType
ty
Bool -> Maybe Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> Name
tyConName TyCon
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
integerTyConName)
ppr_int, ppr_char, ppr_float, ppr_double
:: Precedence -> Term -> m (Maybe SDoc)
ppr_int :: Int -> Term -> m (Maybe SDoc)
ppr_int _ Term{subTerms :: Term -> [Term]
subTerms=[Prim{valRaw :: Term -> [Word]
valRaw=[w :: Word
w]}]} =
Maybe SDoc -> m (Maybe SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Int -> SDoc
Ppr.int (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w)))
ppr_int _ _ = Maybe SDoc -> m (Maybe SDoc)
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 _ Term{subTerms :: Term -> [Term]
subTerms=[Prim{valRaw :: Term -> [Word]
valRaw=[w :: Word
w]}]} =
Maybe SDoc -> m (Maybe SDoc)
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 _ _ = Maybe SDoc -> m (Maybe SDoc)
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 _ Term{subTerms :: Term -> [Term]
subTerms=[Prim{valRaw :: Term -> [Word]
valRaw=[w :: 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
$ \p :: 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 (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 (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Float -> SDoc
Ppr.float Float
f))
ppr_float _ _ = Maybe SDoc -> m (Maybe SDoc)
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 _ Term{subTerms :: Term -> [Term]
subTerms=[Prim{valRaw :: Term -> [Word]
valRaw=[w :: 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
$ \p :: 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 (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 (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Double -> SDoc
Ppr.double Double
f))
ppr_double _ Term{subTerms :: Term -> [Term]
subTerms=[Prim{valRaw :: Term -> [Word]
valRaw=[w1 :: Word
w1,w2 :: 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
$ \p :: 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` 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 (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Double -> SDoc
Ppr.double Double
f))
ppr_double _ _ = Maybe SDoc -> m (Maybe SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SDoc
forall a. Maybe a
Nothing
ppr_integer :: Precedence -> Term -> m (Maybe SDoc)
#if defined(INTEGER_GMP)
ppr_integer _ Term{subTerms=[Prim{valRaw=[W# w]}]} =
return (Just (Ppr.integer (S# (word2Int# w))))
ppr_integer _ Term{dc=Right con,
subTerms=[Term{subTerms=[Prim{valRaw=ws}]}]} = do
let
!(UArray _ _ _ arr#) = listArray (0,length ws-1) ws
constr
| "Jp#" <- getOccString (dataConName con) = Jp#
| otherwise = Jn#
return (Just (Ppr.integer (constr (BN# arr#))))
#elif defined(INTEGER_SIMPLE)
ppr_integer _ Term{subTerms=[]} =
return (Just (Ppr.integer Naught))
ppr_integer _ Term{dc=Right con, subTerms=[digitTerm]}
| Just digits <- get_digits digitTerm
= return (Just (Ppr.integer (constr digits)))
where
get_digits :: Term -> Maybe Digits
get_digits Term{subTerms=[]} = Just None
get_digits Term{subTerms=[Prim{valRaw=[W# w]},t]}
= Some w <$> get_digits t
get_digits _ = Nothing
constr
| "Positive" <- getOccString (dataConName con) = Positive
| otherwise = Negative
#endif
ppr_integer :: Int -> Term -> m (Maybe SDoc)
ppr_integer _ _ = Maybe SDoc -> m (Maybe SDoc)
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 p :: Int
p (Term{subTerms :: Term -> [Term]
subTerms=[h :: Term
h,t :: Term
t]}) = do
let elems :: [Term]
elems = Term
h Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
: Term -> [Term]
getListTerms Term
t
isConsLast :: Bool
isConsLast = Bool -> Bool
not (Term -> RttiType
termType ([Term] -> Term
forall a. [a] -> a
last [Term]
elems) RttiType -> RttiType -> Bool
`eqType` Term -> RttiType
termType Term
h)
is_string :: Bool
is_string = (Term -> Bool) -> [Term] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (RttiType -> Bool
isCharTy (RttiType -> Bool) -> (Term -> RttiType) -> Term -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> RttiType
ty) [Term]
elems
chars :: String
chars = [ Int -> Char
chr (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w)
| Term{subTerms :: Term -> [Term]
subTerms=[Prim{valRaw :: Term -> [Word]
valRaw=[w :: Word
w]}]} <- [Term]
elems ]
[SDoc]
print_elems <- (Term -> m SDoc) -> [Term] -> m [SDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TermPrinterM m
y Int
cons_prec) [Term]
elems
if Bool
is_string
then SDoc -> m SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> SDoc
Ppr.doubleQuotes (String -> SDoc
Ppr.text String
chars))
else if Bool
isConsLast
then SDoc -> m SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ Bool -> SDoc -> SDoc
cparen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
cons_prec)
(SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ ([SDoc] -> SDoc) -> [SDoc] -> SDoc
pprDeeperList [SDoc] -> SDoc
fsep
([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate (SDoc
spaceSDoc -> SDoc -> SDoc
<>SDoc
colon) [SDoc]
print_elems
else SDoc -> m SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc
brackets
(SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ ([SDoc] -> SDoc) -> [SDoc] -> SDoc
pprDeeperList [SDoc] -> SDoc
fcat
([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma [SDoc]
print_elems
where getListTerms :: Term -> [Term]
getListTerms Term{subTerms :: Term -> [Term]
subTerms=[h :: Term
h,t :: 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 t :: Term
t = String -> SDoc -> [Term]
forall a. HasCallStack => String -> SDoc -> a
pprPanic "getListTerms" (Term -> SDoc
forall a. Outputable a => a -> SDoc
ppr Term
t)
ppr_list _ _ = String -> m SDoc
forall a. String -> a
panic "doList"
repPrim :: TyCon -> [Word] -> SDoc
repPrim :: TyCon -> [Word] -> SDoc
repPrim t :: TyCon
t = [Word] -> SDoc
forall a. Storable a => [a] -> SDoc
rep where
rep :: [a] -> SDoc
rep x :: [a]
x
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
charPrimTyCon = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Char -> String
forall a. Show a => a -> String
show (Int -> Char
chr ([a] -> Int
forall a a. (Storable a, Storable a) => [a] -> a
build [a]
x :: Int))
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
intPrimTyCon = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show ([a] -> Int
forall a a. (Storable a, Storable a) => [a] -> a
build [a]
x :: Int)
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
wordPrimTyCon = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Word -> String
forall a. Show a => a -> String
show ([a] -> Word
forall a a. (Storable a, Storable a) => [a] -> a
build [a]
x :: Word)
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
floatPrimTyCon = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Float -> String
forall a. Show a => a -> String
show ([a] -> Float
forall a a. (Storable a, Storable a) => [a] -> a
build [a]
x :: Float)
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
doublePrimTyCon = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Double -> String
forall a. Show a => a -> String
show ([a] -> Double
forall a a. (Storable a, Storable a) => [a] -> a
build [a]
x :: Double)
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
int32PrimTyCon = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Int32 -> String
forall a. Show a => a -> String
show ([a] -> Int32
forall a a. (Storable a, Storable a) => [a] -> a
build [a]
x :: Int32)
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
word32PrimTyCon = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Word32 -> String
forall a. Show a => a -> String
show ([a] -> Word32
forall a a. (Storable a, Storable a) => [a] -> a
build [a]
x :: Word32)
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
int64PrimTyCon = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Int64 -> String
forall a. Show a => a -> String
show ([a] -> Int64
forall a a. (Storable a, Storable a) => [a] -> a
build [a]
x :: Int64)
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
word64PrimTyCon = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Word64 -> String
forall a. Show a => a -> String
show ([a] -> Word64
forall a a. (Storable a, Storable a) => [a] -> a
build [a]
x :: Word64)
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
addrPrimTyCon = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Ptr Any -> String
forall a. Show a => a -> String
show (Ptr Any
forall a. Ptr a
nullPtr Ptr Any -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` [a] -> Int
forall a a. (Storable a, Storable a) => [a] -> a
build [a]
x)
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
stablePtrPrimTyCon = String -> SDoc
text "<stablePtr>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
stableNamePrimTyCon = String -> SDoc
text "<stableName>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
statePrimTyCon = String -> SDoc
text "<statethread>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
proxyPrimTyCon = String -> SDoc
text "<proxy>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
realWorldTyCon = String -> SDoc
text "<realworld>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
threadIdPrimTyCon = String -> SDoc
text "<ThreadId>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
weakPrimTyCon = String -> SDoc
text "<Weak>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
arrayPrimTyCon = String -> SDoc
text "<array>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
smallArrayPrimTyCon = String -> SDoc
text "<smallArray>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
byteArrayPrimTyCon = String -> SDoc
text "<bytearray>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutableArrayPrimTyCon = String -> SDoc
text "<mutableArray>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
smallMutableArrayPrimTyCon = String -> SDoc
text "<smallMutableArray>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutableByteArrayPrimTyCon = String -> SDoc
text "<mutableByteArray>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutVarPrimTyCon = String -> SDoc
text "<mutVar>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mVarPrimTyCon = String -> SDoc
text "<mVar>"
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tVarPrimTyCon = String -> SDoc
text "<tVar>"
| Bool
otherwise = Char -> SDoc
char '<' SDoc -> SDoc -> SDoc
<> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
t SDoc -> SDoc -> SDoc
<> Char -> SDoc
char '>'
where build :: [a] -> a
build ww :: [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 :: HscEnv -> TR a -> IO a
runTR hsc_env :: HscEnv
hsc_env thing :: 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
Nothing -> String -> IO a
forall a. HasCallStack => String -> a
error "unable to :print the term"
Just x :: a
x -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
runTR_maybe hsc_env :: HscEnv
hsc_env thing_inside :: TR a
thing_inside
= do { (_errs :: Messages
_errs, res :: Maybe a
res) <- HscEnv -> TR a -> IO (Messages, Maybe a)
forall a. HscEnv -> TcM a -> IO (Messages, Maybe a)
initTcInteractive HscEnv
hsc_env TR a
thing_inside
; Maybe a -> IO (Maybe 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 :: TR a -> TR a -> TR a
recoverTR = TR a -> TR a -> TR a
forall r. TcM r -> TcM r -> TcM r
tryTcDiscardingErrs
trIO :: IO a -> TR a
trIO :: IO a -> TR a
trIO = TR a -> TR a
forall a. TcM a -> TcM a
liftTcM (TR a -> TR a) -> (IO a -> TR a) -> IO a -> TR a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> TR a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
liftTcM :: TcM a -> TR a
liftTcM :: TcM a -> TcM a
liftTcM = TcM a -> TcM a
forall a. a -> a
id
newVar :: Kind -> TR TcType
newVar :: RttiType -> TR RttiType
newVar = TR RttiType -> TR RttiType
forall a. TcM a -> TcM a
liftTcM (TR RttiType -> TR RttiType)
-> (RttiType -> TR RttiType) -> RttiType -> TR RttiType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RttiType -> TR RttiType
newFlexiTyVarTy
newOpenVar :: TR TcType
newOpenVar :: TR RttiType
newOpenVar = TR RttiType -> TR RttiType
forall a. TcM a -> TcM a
liftTcM TR RttiType
newOpenFlexiTyVarTy
instTyVars :: [TyVar] -> TR (TCvSubst, [TcTyVar])
instTyVars :: [TyVar] -> TR (TCvSubst, [TyVar])
instTyVars tvs :: [TyVar]
tvs
= TR (TCvSubst, [TyVar]) -> TR (TCvSubst, [TyVar])
forall a. TcM a -> TcM a
liftTcM (TR (TCvSubst, [TyVar]) -> TR (TCvSubst, [TyVar]))
-> TR (TCvSubst, [TyVar]) -> TR (TCvSubst, [TyVar])
forall a b. (a -> b) -> a -> b
$ ((TCvSubst, [TyVar]), WantedConstraints) -> (TCvSubst, [TyVar])
forall a b. (a, b) -> a
fst (((TCvSubst, [TyVar]), WantedConstraints) -> (TCvSubst, [TyVar]))
-> IOEnv
(Env TcGblEnv TcLclEnv) ((TCvSubst, [TyVar]), WantedConstraints)
-> TR (TCvSubst, [TyVar])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TR (TCvSubst, [TyVar])
-> IOEnv
(Env TcGblEnv TcLclEnv) ((TCvSubst, [TyVar]), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints ([TyVar] -> TR (TCvSubst, [TyVar])
newMetaTyVars [TyVar]
tvs)
type RttiInstantiation = [(TcTyVar, TyVar)]
instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation)
instScheme :: QuantifiedType -> TR (RttiType, RttiInstantiation)
instScheme (tvs :: [TyVar]
tvs, ty :: RttiType
ty)
= do { (subst :: TCvSubst
subst, tvs' :: [TyVar]
tvs') <- [TyVar] -> TR (TCvSubst, [TyVar])
instTyVars [TyVar]
tvs
; let rtti_inst :: RttiInstantiation
rtti_inst = [(TyVar
tv',TyVar
tv) | (tv' :: TyVar
tv',tv :: TyVar
tv) <- [TyVar]
tvs' [TyVar] -> [TyVar] -> RttiInstantiation
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TyVar]
tvs]
; (RttiType, RttiInstantiation) -> TR (RttiType, RttiInstantiation)
forall (m :: * -> *) a. Monad m => a -> m a
return (HasCallStack => TCvSubst -> RttiType -> RttiType
TCvSubst -> RttiType -> RttiType
substTy TCvSubst
subst RttiType
ty, RttiInstantiation
rtti_inst) }
applyRevSubst :: RttiInstantiation -> TR ()
applyRevSubst :: RttiInstantiation -> TR ()
applyRevSubst pairs :: 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 (tc_tv :: TyVar
tc_tv, rtti_tv :: TyVar
rtti_tv)
= do { RttiType
tc_ty <- TyVar -> TR RttiType
zonkTcTyVar TyVar
tc_tv
; case RttiType -> Maybe TyVar
tcGetTyVar_maybe RttiType
tc_ty of
Just tv :: TyVar
tv | TyVar -> Bool
isMetaTyVar TyVar
tv -> TyVar -> RttiType -> TR ()
writeMetaTyVar TyVar
tv (TyVar -> RttiType
mkTyVarTy TyVar
rtti_tv)
_ -> () -> TR ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
addConstraint :: TcType -> TcType -> TR ()
addConstraint :: RttiType -> RttiType -> TR ()
addConstraint actual :: RttiType
actual expected :: RttiType
expected = do
SDoc -> TR ()
traceTR (String -> SDoc
text "add constraint:" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
fsep [RttiType -> SDoc
forall a. Outputable a => a -> SDoc
ppr RttiType
actual, SDoc
equals, RttiType -> SDoc
forall a. Outputable a => a -> SDoc
ppr RttiType
expected])
TR () -> TR () -> TR ()
forall r. TcM r -> TcM r -> TcM r
recoverTR (SDoc -> TR ()
traceTR (SDoc -> TR ()) -> SDoc -> TR ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
fsep [String -> SDoc
text "Failed to unify", RttiType -> SDoc
forall a. Outputable a => a -> SDoc
ppr RttiType
actual,
String -> SDoc
text "with", RttiType -> SDoc
forall a. Outputable a => a -> SDoc
ppr RttiType
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 { (ty1 :: RttiType
ty1, ty2 :: RttiType
ty2) <- RttiType -> RttiType -> TR (RttiType, RttiType)
congruenceNewtypes RttiType
actual RttiType
expected
; Maybe (HsExpr GhcRn) -> RttiType -> RttiType -> TcM TcCoercionN
unifyType Maybe (HsExpr GhcRn)
forall a. Maybe a
Nothing RttiType
ty1 RttiType
ty2 }
cvObtainTerm
:: HscEnv
-> Int
-> Bool
-> RttiType
-> ForeignHValue
-> IO Term
cvObtainTerm :: HscEnv -> Int -> Bool -> RttiType -> ForeignHValue -> IO Term
cvObtainTerm hsc_env :: HscEnv
hsc_env max_depth :: Int
max_depth force :: Bool
force old_ty :: RttiType
old_ty hval :: 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@(old_tvs :: [TyVar]
old_tvs, old_tau :: RttiType
old_tau) = RttiType -> QuantifiedType
quantifyType RttiType
old_ty
sigma_old_ty :: RttiType
sigma_old_ty = [TyVar] -> RttiType -> RttiType
mkInvForAllTys [TyVar]
old_tvs RttiType
old_tau
SDoc -> TR ()
traceTR (String -> SDoc
text "Term reconstruction started with initial type " SDoc -> SDoc -> SDoc
<> RttiType -> SDoc
forall a. Outputable a => a -> SDoc
ppr RttiType
old_ty)
Term
term <-
if [TyVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVar]
old_tvs
then do
Term
term <- Int -> RttiType -> RttiType -> ForeignHValue -> TR Term
go Int
max_depth RttiType
sigma_old_ty RttiType
sigma_old_ty ForeignHValue
hval
Term
term' <- Term -> TR Term
zonkTerm Term
term
Term -> TR Term
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
(old_ty' :: RttiType
old_ty', rev_subst :: RttiInstantiation
rev_subst) <- QuantifiedType -> TR (RttiType, RttiInstantiation)
instScheme QuantifiedType
quant_old_ty
RttiType
my_ty <- TR RttiType
newOpenVar
Bool -> TR () -> TR ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (QuantifiedType -> Bool
check1 QuantifiedType
quant_old_ty) (SDoc -> TR ()
traceTR (String -> SDoc
text "check1 passed") TR () -> TR () -> TR ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
RttiType -> RttiType -> TR ()
addConstraint RttiType
my_ty RttiType
old_ty')
Term
term <- Int -> RttiType -> RttiType -> ForeignHValue -> TR Term
go Int
max_depth RttiType
my_ty RttiType
sigma_old_ty ForeignHValue
hval
RttiType
new_ty <- RttiType -> TR RttiType
zonkTcType (Term -> RttiType
termType Term
term)
if RttiType -> Bool
isMonomorphic RttiType
new_ty Bool -> Bool -> Bool
|| QuantifiedType -> QuantifiedType -> Bool
check2 (RttiType -> QuantifiedType
quantifyType RttiType
new_ty) QuantifiedType
quant_old_ty
then do
SDoc -> TR ()
traceTR (String -> SDoc
text "check2 passed")
RttiType -> RttiType -> TR ()
addConstraint RttiType
new_ty RttiType
old_ty'
RttiInstantiation -> TR ()
applyRevSubst RttiInstantiation
rev_subst
Term
zterm' <- Term -> TR Term
zonkTerm Term
term
Term -> TR Term
forall (m :: * -> *) a. Monad m => a -> m a
return ((Term -> Term
fixFunDictionaries (Term -> Term) -> (Term -> Term) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Term
expandNewtypes) Term
zterm')
else do
SDoc -> TR ()
traceTR (String -> SDoc
text "check2 failed" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens
(Term -> SDoc
forall a. Outputable a => a -> SDoc
ppr Term
term SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "::" SDoc -> SDoc -> SDoc
<+> RttiType -> SDoc
forall a. Outputable a => a -> SDoc
ppr RttiType
new_ty))
Term
zterm' <- (RttiType -> TR RttiType) -> Term -> TR Term
forall (m :: * -> *).
Monad m =>
(RttiType -> m RttiType) -> Term -> m Term
mapTermTypeM
(\ty :: RttiType
ty -> case HasCallStack => RttiType -> Maybe (TyCon, [RttiType])
RttiType -> Maybe (TyCon, [RttiType])
tcSplitTyConApp_maybe RttiType
ty of
Just (tc :: TyCon
tc, _:_) | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
/= TyCon
funTyCon
-> TR RttiType
newOpenVar
_ -> RttiType -> TR RttiType
forall (m :: * -> *) a. Monad m => a -> m a
return RttiType
ty)
Term
term
Term -> TR Term
zonkTerm Term
zterm'
SDoc -> TR ()
traceTR (String -> SDoc
text "Term reconstruction completed." SDoc -> SDoc -> SDoc
$$
String -> SDoc
text "Term obtained: " SDoc -> SDoc -> SDoc
<> Term -> SDoc
forall a. Outputable a => a -> SDoc
ppr Term
term SDoc -> SDoc -> SDoc
$$
String -> SDoc
text "Type obtained: " SDoc -> SDoc -> SDoc
<> RttiType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Term -> RttiType
termType Term
term))
Term -> TR Term
forall (m :: * -> *) a. Monad m => a -> m a
return Term
term
where
go :: Int -> Type -> Type -> ForeignHValue -> TcM Term
go :: Int -> RttiType -> RttiType -> ForeignHValue -> TR Term
go 0 my_ty :: RttiType
my_ty _old_ty :: RttiType
_old_ty a :: ForeignHValue
a = do
SDoc -> TR ()
traceTR (String -> SDoc
text "Gave up reconstructing a term after" SDoc -> SDoc -> SDoc
<>
Int -> SDoc
int Int
max_depth SDoc -> SDoc -> SDoc
<> String -> SDoc
text " 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
$ HscEnv -> ForeignHValue -> IO (GenClosure ForeignHValue)
GHCi.getClosure HscEnv
hsc_env ForeignHValue
a
Term -> TR Term
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> Term
Suspension (StgInfoTable -> ClosureType
tipe (GenClosure ForeignHValue -> StgInfoTable
forall b. GenClosure b -> StgInfoTable
info GenClosure ForeignHValue
clos)) RttiType
my_ty ForeignHValue
a Maybe Name
forall a. Maybe a
Nothing)
go !Int
max_depth my_ty :: RttiType
my_ty old_ty :: RttiType
old_ty a :: ForeignHValue
a = do
let monomorphic :: Bool
monomorphic = Bool -> Bool
not(RttiType -> Bool
isTyVarTy RttiType
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
$ HscEnv -> ForeignHValue -> IO (GenClosure ForeignHValue)
GHCi.getClosure HscEnv
hsc_env ForeignHValue
a
case GenClosure ForeignHValue
clos of
t :: GenClosure ForeignHValue
t | GenClosure ForeignHValue -> Bool
forall a. GenClosure a -> Bool
isThunk GenClosure ForeignHValue
t Bool -> Bool -> Bool
&& Bool
force -> do
SDoc -> TR ()
traceTR (String -> SDoc
text "Forcing a " SDoc -> SDoc -> SDoc
<> String -> SDoc
text (GenClosure () -> String
forall a. Show a => a -> String
show ((ForeignHValue -> ()) -> GenClosure ForeignHValue -> GenClosure ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> ForeignHValue -> ()
forall a b. a -> b -> a
const ()) GenClosure ForeignHValue
t)))
IO () -> TR ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TR ()) -> IO () -> TR ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> ForeignHValue -> IO ()
GHCi.seqHValue HscEnv
hsc_env ForeignHValue
a
Int -> RttiType -> RttiType -> ForeignHValue -> TR Term
go (Int -> Int
forall a. Enum a => a -> a
pred Int
max_depth) RttiType
my_ty RttiType
old_ty ForeignHValue
a
BlackholeClosure{indirectee :: forall b. GenClosure b -> b
indirectee=ForeignHValue
ind} -> do
SDoc -> TR ()
traceTR (String -> SDoc
text "Following a BLACKHOLE")
GenClosure ForeignHValue
ind_clos <- IO (GenClosure ForeignHValue) -> TR (GenClosure ForeignHValue)
forall a. IO a -> TR a
trIO (HscEnv -> ForeignHValue -> IO (GenClosure ForeignHValue)
GHCi.getClosure HscEnv
hsc_env ForeignHValue
ind)
let return_bh_value :: TR Term
return_bh_value = Term -> TR Term
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> Term
Suspension ClosureType
BLACKHOLE RttiType
my_ty ForeignHValue
a Maybe Name
forall a. Maybe a
Nothing)
case GenClosure ForeignHValue
ind_clos of
BlockingQueueClosure{} -> TR Term
return_bh_value
OtherClosure info :: StgInfoTable
info _ _
| StgInfoTable -> ClosureType
tipe StgInfoTable
info ClosureType -> ClosureType -> Bool
forall a. Eq a => a -> a -> Bool
== ClosureType
TSO -> TR Term
return_bh_value
UnsupportedClosure info :: StgInfoTable
info
| StgInfoTable -> ClosureType
tipe StgInfoTable
info ClosureType -> ClosureType -> Bool
forall a. Eq a => a -> a -> Bool
== ClosureType
TSO -> TR Term
return_bh_value
_ -> Int -> RttiType -> RttiType -> ForeignHValue -> TR Term
go Int
max_depth RttiType
my_ty RttiType
old_ty ForeignHValue
ind
IndClosure{indirectee :: forall b. GenClosure b -> b
indirectee=ForeignHValue
ind} -> do
SDoc -> TR ()
traceTR (String -> SDoc
text "Following an indirection" )
Int -> RttiType -> RttiType -> ForeignHValue -> TR Term
go Int
max_depth RttiType
my_ty RttiType
old_ty ForeignHValue
ind
MutVarClosure{var :: forall b. GenClosure b -> b
var=ForeignHValue
contents}
| Just (tycon :: TyCon
tycon,[world :: RttiType
world,contents_ty :: RttiType
contents_ty]) <- HasCallStack => RttiType -> Maybe (TyCon, [RttiType])
RttiType -> Maybe (TyCon, [RttiType])
tcSplitTyConApp_maybe RttiType
old_ty
-> do
SDoc -> TR ()
traceTR (String -> SDoc
text "Following a MutVar")
RttiType
contents_tv <- RttiType -> TR RttiType
newVar RttiType
liftedTypeKind
MASSERT(isUnliftedType my_ty)
(mutvar_ty :: RttiType
mutvar_ty,_) <- QuantifiedType -> TR (RttiType, RttiInstantiation)
instScheme (QuantifiedType -> TR (RttiType, RttiInstantiation))
-> QuantifiedType -> TR (RttiType, RttiInstantiation)
forall a b. (a -> b) -> a -> b
$ RttiType -> QuantifiedType
quantifyType (RttiType -> QuantifiedType) -> RttiType -> QuantifiedType
forall a b. (a -> b) -> a -> b
$ RttiType -> RttiType -> RttiType
mkFunTy
RttiType
contents_ty (TyCon -> [RttiType] -> RttiType
mkTyConApp TyCon
tycon [RttiType
world,RttiType
contents_ty])
RttiType -> RttiType -> TR ()
addConstraint (RttiType -> RttiType -> RttiType
mkFunTy RttiType
contents_tv RttiType
my_ty) RttiType
mutvar_ty
Term
x <- Int -> RttiType -> RttiType -> ForeignHValue -> TR Term
go (Int -> Int
forall a. Enum a => a -> a
pred Int
max_depth) RttiType
contents_tv RttiType
contents_ty ForeignHValue
contents
Term -> TR Term
forall (m :: * -> *) a. Monad m => a -> m a
return (RttiType -> Term -> Term
RefWrap RttiType
my_ty Term
x)
ConstrClosure{ptrArgs :: forall b. GenClosure b -> [b]
ptrArgs=[ForeignHValue]
pArgs,dataArgs :: forall b. GenClosure b -> [Word]
dataArgs=[Word]
dArgs} -> do
SDoc -> TR ()
traceTR (String -> SDoc
text "entering a constructor " SDoc -> SDoc -> SDoc
<> [Word] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Word]
dArgs SDoc -> SDoc -> SDoc
<+>
if Bool
monomorphic
then SDoc -> SDoc
parens (String -> SDoc
text "already monomorphic: " SDoc -> SDoc -> SDoc
<> RttiType -> SDoc
forall a. Outputable a => a -> SDoc
ppr RttiType
my_ty)
else SDoc
Ppr.empty)
Right dcname :: Name
dcname <- IO (Either String Name)
-> IOEnv (Env TcGblEnv TcLclEnv) (Either String Name)
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
(mb_dc :: Maybe DataCon
mb_dc, _) <- TcRn DataCon -> TcRn (Maybe DataCon, Messages)
forall a. TcRn a -> TcRn (Maybe a, Messages)
tryTc (Name -> TcRn DataCon
tcLookupDataCon Name
dcname)
case Maybe DataCon
mb_dc of
Nothing -> do
SDoc -> TR ()
traceTR (String -> SDoc
text "Not constructor" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
dcname)
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
tag :: String
tag = DynFlags -> Name -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags Name
dcname
[RttiType]
vars <- Int -> TR RttiType -> IOEnv (Env TcGblEnv TcLclEnv) [RttiType]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([ForeignHValue] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ForeignHValue]
pArgs)
(RttiType -> TR RttiType
newVar RttiType
liftedTypeKind)
[Term]
subTerms <- [TR Term] -> IOEnv (Env TcGblEnv TcLclEnv) [Term]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([TR Term] -> IOEnv (Env TcGblEnv TcLclEnv) [Term])
-> [TR Term] -> IOEnv (Env TcGblEnv TcLclEnv) [Term]
forall a b. (a -> b) -> a -> b
$ (ForeignHValue -> RttiType -> TR Term)
-> [ForeignHValue] -> [RttiType] -> [TR Term]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\x :: ForeignHValue
x tv :: RttiType
tv ->
Int -> RttiType -> RttiType -> ForeignHValue -> TR Term
go (Int -> Int
forall a. Enum a => a -> a
pred Int
max_depth) RttiType
tv RttiType
tv ForeignHValue
x) [ForeignHValue]
pArgs [RttiType]
vars
Term -> TR Term
forall (m :: * -> *) a. Monad m => a -> m a
return (TermProcessor Term Term
Term RttiType
my_ty (String -> Either String DataCon
forall a b. a -> Either a b
Left ('<' Char -> String -> String
forall a. a -> [a] -> [a]
: String
tag String -> String -> String
forall a. [a] -> [a] -> [a]
++ ">")) ForeignHValue
a [Term]
subTerms)
Just dc :: DataCon
dc -> do
SDoc -> TR ()
traceTR (String -> SDoc
text "Is constructor" SDoc -> SDoc -> SDoc
<+> (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dc SDoc -> SDoc -> SDoc
$$ RttiType -> SDoc
forall a. Outputable a => a -> SDoc
ppr RttiType
my_ty))
[RttiType]
subTtypes <- DataCon -> RttiType -> IOEnv (Env TcGblEnv TcLclEnv) [RttiType]
getDataConArgTys DataCon
dc RttiType
my_ty
[Term]
subTerms <- (RttiType -> ForeignHValue -> TR Term)
-> GenClosure ForeignHValue
-> [RttiType]
-> IOEnv (Env TcGblEnv TcLclEnv) [Term]
extractSubTerms (\ty :: RttiType
ty -> Int -> RttiType -> RttiType -> ForeignHValue -> TR Term
go (Int -> Int
forall a. Enum a => a -> a
pred Int
max_depth) RttiType
ty RttiType
ty) GenClosure ForeignHValue
clos [RttiType]
subTtypes
Term -> TR Term
forall (m :: * -> *) a. Monad m => a -> m a
return (TermProcessor Term Term
Term RttiType
my_ty (DataCon -> Either String DataCon
forall a b. b -> Either a b
Right DataCon
dc) ForeignHValue
a [Term]
subTerms)
ArrWordsClosure{bytes :: forall b. GenClosure b -> Word
bytes=Word
b, arrWords :: forall b. GenClosure b -> [Word]
arrWords=[Word]
ws} -> do
SDoc -> TR ()
traceTR (String -> SDoc
text "ByteArray# closure, size " SDoc -> SDoc -> SDoc
<> Word -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word
b)
Term -> TR Term
forall (m :: * -> *) a. Monad m => a -> m a
return (TermProcessor Term Term
Term RttiType
my_ty (String -> Either String DataCon
forall a b. a -> Either a b
Left "ByteArray#") ForeignHValue
a [RttiType -> [Word] -> Term
Prim RttiType
my_ty [Word]
ws])
_ -> do
SDoc -> TR ()
traceTR (String -> SDoc
text "Unknown closure:" SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text (GenClosure () -> String
forall a. Show a => a -> String
show ((ForeignHValue -> ()) -> GenClosure ForeignHValue -> GenClosure ()
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 (m :: * -> *) a. Monad m => a -> m a
return (ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> Term
Suspension (StgInfoTable -> ClosureType
tipe (GenClosure ForeignHValue -> StgInfoTable
forall b. GenClosure b -> StgInfoTable
info GenClosure ForeignHValue
clos)) RttiType
my_ty ForeignHValue
a Maybe Name
forall a. Maybe a
Nothing)
expandNewtypes :: Term -> Term
expandNewtypes = TermFold Term -> Term -> Term
forall a. TermFold a -> Term -> a
foldTerm TermFold Term
idTermFold { fTerm :: TermProcessor Term Term
fTerm = TermProcessor Term Term
worker } where
worker :: TermProcessor Term Term
worker ty :: RttiType
ty dc :: Either String DataCon
dc hval :: ForeignHValue
hval tt :: [Term]
tt
| Just (tc :: TyCon
tc, args :: [RttiType]
args) <- HasCallStack => RttiType -> Maybe (TyCon, [RttiType])
RttiType -> Maybe (TyCon, [RttiType])
tcSplitTyConApp_maybe RttiType
ty
, TyCon -> Bool
isNewTyCon TyCon
tc
, RttiType
wrapped_type <- TyCon -> [RttiType] -> RttiType
newTyConInstRhs TyCon
tc [RttiType]
args
, Just dc' :: DataCon
dc' <- TyCon -> Maybe DataCon
tyConSingleDataCon_maybe TyCon
tc
, Term
t' <- TermProcessor Term Term
worker RttiType
wrapped_type Either String DataCon
dc ForeignHValue
hval [Term]
tt
= RttiType -> Either String DataCon -> Term -> Term
NewtypeWrap RttiType
ty (DataCon -> Either String DataCon
forall a b. b -> Either a b
Right DataCon
dc') Term
t'
| Bool
otherwise = TermProcessor Term Term
Term RttiType
ty Either String DataCon
dc ForeignHValue
hval [Term]
tt
fixFunDictionaries :: Term -> Term
fixFunDictionaries = TermFold Term -> Term -> Term
forall a. TermFold a -> Term -> a
foldTerm TermFold Term
idTermFold {fSuspension :: ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> Term
fSuspension = ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> Term
worker} where
worker :: ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> Term
worker ct :: ClosureType
ct ty :: RttiType
ty hval :: ForeignHValue
hval n :: Maybe Name
n | RttiType -> Bool
isFunTy RttiType
ty = ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> Term
Suspension ClosureType
ct (RttiType -> RttiType
dictsView RttiType
ty) ForeignHValue
hval Maybe Name
n
| Bool
otherwise = ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> Term
Suspension ClosureType
ct RttiType
ty ForeignHValue
hval Maybe Name
n
extractSubTerms :: (Type -> ForeignHValue -> TcM Term)
-> GenClosure ForeignHValue -> [Type] -> TcM [Term]
recurse :: RttiType -> ForeignHValue -> TR Term
recurse clos :: 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])
-> ([RttiType] -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term]))
-> [RttiType]
-> IOEnv (Env TcGblEnv TcLclEnv) [Term]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> Int
-> [RttiType]
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
go 0 0
where
array :: [Word]
array = GenClosure ForeignHValue -> [Word]
forall b. GenClosure b -> [Word]
dataArgs GenClosure ForeignHValue
clos
go :: Int
-> Int
-> [RttiType]
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
go ptr_i :: Int
ptr_i arr_i :: Int
arr_i [] = (Int, Int, [Term])
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ptr_i, Int
arr_i, [])
go ptr_i :: Int
ptr_i arr_i :: Int
arr_i (ty :: RttiType
ty:tys :: [RttiType]
tys)
| Just (tc :: TyCon
tc, elem_tys :: [RttiType]
elem_tys) <- HasCallStack => RttiType -> Maybe (TyCon, [RttiType])
RttiType -> Maybe (TyCon, [RttiType])
tcSplitTyConApp_maybe RttiType
ty
, TyCon -> Bool
isUnboxedTupleTyCon TyCon
tc
= do (ptr_i :: Int
ptr_i, arr_i :: Int
arr_i, terms0 :: [Term]
terms0) <-
Int
-> Int
-> [RttiType]
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
go Int
ptr_i Int
arr_i ([RttiType] -> [RttiType]
dropRuntimeRepArgs [RttiType]
elem_tys)
(ptr_i :: Int
ptr_i, arr_i :: Int
arr_i, terms1 :: [Term]
terms1) <- Int
-> Int
-> [RttiType]
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
go Int
ptr_i Int
arr_i [RttiType]
tys
(Int, Int, [Term])
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ptr_i, Int
arr_i, RttiType -> [Term] -> Term
unboxedTupleTerm RttiType
ty [Term]
terms0 Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
: [Term]
terms1)
| Bool
otherwise
= case HasDebugCallStack => RttiType -> [PrimRep]
RttiType -> [PrimRep]
typePrimRepArgs RttiType
ty of
[rep_ty :: PrimRep
rep_ty] -> do
(ptr_i :: Int
ptr_i, arr_i :: Int
arr_i, term0 :: Term
term0) <- Int
-> Int
-> RttiType
-> PrimRep
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, Term)
go_rep Int
ptr_i Int
arr_i RttiType
ty PrimRep
rep_ty
(ptr_i :: Int
ptr_i, arr_i :: Int
arr_i, terms1 :: [Term]
terms1) <- Int
-> Int
-> [RttiType]
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
go Int
ptr_i Int
arr_i [RttiType]
tys
(Int, Int, [Term])
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
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)
rep_tys :: [PrimRep]
rep_tys -> do
(ptr_i :: Int
ptr_i, arr_i :: Int
arr_i, terms0 :: [Term]
terms0) <- Int
-> Int
-> [PrimRep]
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
go_unary_types Int
ptr_i Int
arr_i [PrimRep]
rep_tys
(ptr_i :: Int
ptr_i, arr_i :: Int
arr_i, terms1 :: [Term]
terms1) <- Int
-> Int
-> [RttiType]
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
go Int
ptr_i Int
arr_i [RttiType]
tys
(Int, Int, [Term])
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ptr_i, Int
arr_i, RttiType -> [Term] -> Term
unboxedTupleTerm RttiType
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 ptr_i :: Int
ptr_i arr_i :: Int
arr_i [] = (Int, Int, [Term])
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ptr_i, Int
arr_i, [])
go_unary_types ptr_i :: Int
ptr_i arr_i :: Int
arr_i (rep_ty :: PrimRep
rep_ty:rep_tys :: [PrimRep]
rep_tys) = do
RttiType
tv <- RttiType -> TR RttiType
newVar RttiType
liftedTypeKind
(ptr_i :: Int
ptr_i, arr_i :: Int
arr_i, term0 :: Term
term0) <- Int
-> Int
-> RttiType
-> PrimRep
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, Term)
go_rep Int
ptr_i Int
arr_i RttiType
tv PrimRep
rep_ty
(ptr_i :: Int
ptr_i, arr_i :: Int
arr_i, terms1 :: [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 (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
-> RttiType
-> PrimRep
-> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, Term)
go_rep ptr_i :: Int
ptr_i arr_i :: Int
arr_i ty :: RttiType
ty rep :: PrimRep
rep
| PrimRep -> Bool
isGcPtrRep PrimRep
rep = do
Term
t <- RttiType -> ForeignHValue -> TR Term
recurse RttiType
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. [a] -> Int -> a
!!Int
ptr_i
(Int, Int, Term) -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, Term)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ptr_i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Int
arr_i, Term
t)
| Bool
otherwise = do
DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let word_size :: Int
word_size = DynFlags -> Int
wORD_SIZE DynFlags
dflags
big_endian :: Bool
big_endian = DynFlags -> Bool
wORDS_BIGENDIAN DynFlags
dflags
size_b :: Int
size_b = DynFlags -> PrimRep -> Int
primRepSizeB DynFlags
dflags 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 -> Bool -> Word
index Int
size_b Int
aligned_idx Int
word_size Bool
big_endian]
| Bool
otherwise =
let (q :: Int
q, r :: Int
r) = Int
size_b Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
word_size
in ASSERT( r == 0 )
[ [Word]
array[Word] -> Int -> Word
forall a. [a] -> Int -> a
!!Int
i
| Int
o <- [0.. Int
q Int -> Int -> Int
forall a. Num a => a -> a -> a
- 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 (m :: * -> *) a. Monad m => a -> m a
return (Int
ptr_i, Int
new_arr_i, RttiType -> [Word] -> Term
Prim RttiType
ty [Word]
ws)
unboxedTupleTerm :: RttiType -> [Term] -> Term
unboxedTupleTerm ty :: RttiType
ty terms :: [Term]
terms
= TermProcessor Term Term
Term RttiType
ty (DataCon -> Either String DataCon
forall a b. b -> Either a b
Right (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed ([Term] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Term]
terms)))
(String -> ForeignHValue
forall a. HasCallStack => String -> a
error "unboxedTupleTerm: no HValue for unboxed tuple") [Term]
terms
index :: Int -> Int -> Int -> Bool -> Word
index item_size_b :: Int
item_size_b index_b :: Int
index_b word_size :: Int
word_size big_endian :: Bool
big_endian =
(Word
word Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. (Word
mask Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftL` Int
moveBytes)) Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
moveBytes
where
mask :: Word
mask :: Word
mask = case Int
item_size_b of
1 -> 0xFF
2 -> 0xFFFF
4 -> 0xFFFFFFFF
_ -> String -> Word
forall a. String -> a
panic ("Weird byte-index: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
index_b)
(q :: Int
q,r :: Int
r) = Int
index_b 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. [a] -> Int -> a
!!Int
q
moveBytes :: Int
moveBytes = if Bool
big_endian
then Int
word_size Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
item_size_b) Int -> Int -> Int
forall a. Num a => a -> a -> a
* 8
else Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
* 8
cvReconstructType
:: HscEnv
-> Int
-> GhciType
-> ForeignHValue
-> IO (Maybe Type)
cvReconstructType :: HscEnv -> Int -> RttiType -> ForeignHValue -> IO (Maybe RttiType)
cvReconstructType hsc_env :: HscEnv
hsc_env max_depth :: Int
max_depth old_ty :: RttiType
old_ty hval :: ForeignHValue
hval = HscEnv -> TR RttiType -> IO (Maybe RttiType)
forall a. HscEnv -> TR a -> IO (Maybe a)
runTR_maybe HscEnv
hsc_env (TR RttiType -> IO (Maybe RttiType))
-> TR RttiType -> IO (Maybe RttiType)
forall a b. (a -> b) -> a -> b
$ do
SDoc -> TR ()
traceTR (String -> SDoc
text "RTTI started with initial type " SDoc -> SDoc -> SDoc
<> RttiType -> SDoc
forall a. Outputable a => a -> SDoc
ppr RttiType
old_ty)
let sigma_old_ty :: QuantifiedType
sigma_old_ty@(old_tvs :: [TyVar]
old_tvs, _) = RttiType -> QuantifiedType
quantifyType RttiType
old_ty
RttiType
new_ty <-
if [TyVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVar]
old_tvs
then RttiType -> TR RttiType
forall (m :: * -> *) a. Monad m => a -> m a
return RttiType
old_ty
else do
(old_ty' :: RttiType
old_ty', rev_subst :: RttiInstantiation
rev_subst) <- QuantifiedType -> TR (RttiType, RttiInstantiation)
instScheme QuantifiedType
sigma_old_ty
RttiType
my_ty <- TR RttiType
newOpenVar
Bool -> TR () -> TR ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (QuantifiedType -> Bool
check1 QuantifiedType
sigma_old_ty) (SDoc -> TR ()
traceTR (String -> SDoc
text "check1 passed") TR () -> TR () -> TR ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
RttiType -> RttiType -> TR ()
addConstraint RttiType
my_ty RttiType
old_ty')
IOEnv (Env TcGblEnv TcLclEnv) Bool
-> ((RttiType, ForeignHValue)
-> IOEnv (Env TcGblEnv TcLclEnv) [(RttiType, ForeignHValue)])
-> Seq (RttiType, ForeignHValue)
-> Int
-> TR ()
forall a t.
(Eq a, Num a, Enum a) =>
IOEnv (Env TcGblEnv TcLclEnv) Bool
-> (t -> IOEnv (Env TcGblEnv TcLclEnv) [t]) -> Seq t -> a -> TR ()
search (RttiType -> Bool
isMonomorphic (RttiType -> Bool)
-> TR RttiType -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RttiType -> TR RttiType
zonkTcType RttiType
my_ty)
(\(ty :: RttiType
ty,a :: ForeignHValue
a) -> RttiType
-> ForeignHValue
-> IOEnv (Env TcGblEnv TcLclEnv) [(RttiType, ForeignHValue)]
go RttiType
ty ForeignHValue
a)
((RttiType, ForeignHValue) -> Seq (RttiType, ForeignHValue)
forall a. a -> Seq a
Seq.singleton (RttiType
my_ty, ForeignHValue
hval))
Int
max_depth
RttiType
new_ty <- RttiType -> TR RttiType
zonkTcType RttiType
my_ty
if RttiType -> Bool
isMonomorphic RttiType
new_ty Bool -> Bool -> Bool
|| QuantifiedType -> QuantifiedType -> Bool
check2 (RttiType -> QuantifiedType
quantifyType RttiType
new_ty) QuantifiedType
sigma_old_ty
then do
SDoc -> TR ()
traceTR (String -> SDoc
text "check2 passed" SDoc -> SDoc -> SDoc
<+> RttiType -> SDoc
forall a. Outputable a => a -> SDoc
ppr RttiType
old_ty SDoc -> SDoc -> SDoc
$$ RttiType -> SDoc
forall a. Outputable a => a -> SDoc
ppr RttiType
new_ty)
RttiType -> RttiType -> TR ()
addConstraint RttiType
my_ty RttiType
old_ty'
RttiInstantiation -> TR ()
applyRevSubst RttiInstantiation
rev_subst
RttiType -> TR RttiType
zonkRttiType RttiType
new_ty
else SDoc -> TR ()
traceTR (String -> SDoc
text "check2 failed" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (RttiType -> SDoc
forall a. Outputable a => a -> SDoc
ppr RttiType
new_ty)) TR () -> TR RttiType -> TR RttiType
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
RttiType -> TR RttiType
forall (m :: * -> *) a. Monad m => a -> m a
return RttiType
old_ty
SDoc -> TR ()
traceTR (String -> SDoc
text "RTTI completed. Type obtained:" SDoc -> SDoc -> SDoc
<+> RttiType -> SDoc
forall a. Outputable a => a -> SDoc
ppr RttiType
new_ty)
RttiType -> TR RttiType
forall (m :: * -> *) a. Monad m => a -> m a
return RttiType
new_ty
where
search :: IOEnv (Env TcGblEnv TcLclEnv) Bool
-> (t -> IOEnv (Env TcGblEnv TcLclEnv) [t]) -> Seq t -> a -> TR ()
search _ _ _ 0 = SDoc -> TR ()
traceTR (String -> SDoc
text "Failed to reconstruct a type after " SDoc -> SDoc -> SDoc
<>
Int -> SDoc
int Int
max_depth SDoc -> SDoc -> SDoc
<> String -> SDoc
text " steps")
search stop :: IOEnv (Env TcGblEnv TcLclEnv) Bool
stop expand :: t -> IOEnv (Env TcGblEnv TcLclEnv) [t]
expand l :: Seq t
l d :: a
d =
case Seq t -> ViewL t
forall a. Seq a -> ViewL a
viewl Seq t
l of
EmptyL -> () -> TR ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
x :: t
x :< xx :: Seq t
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
[t]
new <- t -> IOEnv (Env TcGblEnv TcLclEnv) [t]
expand t
x
IOEnv (Env TcGblEnv TcLclEnv) Bool
-> (t -> IOEnv (Env TcGblEnv TcLclEnv) [t]) -> Seq t -> a -> TR ()
search IOEnv (Env TcGblEnv TcLclEnv) Bool
stop t -> IOEnv (Env TcGblEnv TcLclEnv) [t]
expand (Seq t
xx Seq t -> Seq t -> Seq t
forall a. Monoid a => a -> a -> a
`mappend` [t] -> Seq t
forall a. [a] -> Seq a
Seq.fromList [t]
new) (a -> TR ()) -> a -> TR ()
forall a b. (a -> b) -> a -> b
$! (a -> a
forall a. Enum a => a -> a
pred a
d)
go :: Type -> ForeignHValue -> TR [(Type, ForeignHValue)]
go :: RttiType
-> ForeignHValue
-> IOEnv (Env TcGblEnv TcLclEnv) [(RttiType, ForeignHValue)]
go my_ty :: RttiType
my_ty a :: ForeignHValue
a = do
SDoc -> TR ()
traceTR (String -> SDoc
text "go" SDoc -> SDoc -> SDoc
<+> RttiType -> SDoc
forall a. Outputable a => a -> SDoc
ppr RttiType
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
$ HscEnv -> ForeignHValue -> IO (GenClosure ForeignHValue)
GHCi.getClosure HscEnv
hsc_env ForeignHValue
a
case GenClosure ForeignHValue
clos of
BlackholeClosure{indirectee :: forall b. GenClosure b -> b
indirectee=ForeignHValue
ind} -> RttiType
-> ForeignHValue
-> IOEnv (Env TcGblEnv TcLclEnv) [(RttiType, ForeignHValue)]
go RttiType
my_ty ForeignHValue
ind
IndClosure{indirectee :: forall b. GenClosure b -> b
indirectee=ForeignHValue
ind} -> RttiType
-> ForeignHValue
-> IOEnv (Env TcGblEnv TcLclEnv) [(RttiType, ForeignHValue)]
go RttiType
my_ty ForeignHValue
ind
MutVarClosure{var :: forall b. GenClosure b -> b
var=ForeignHValue
contents} -> do
RttiType
tv' <- RttiType -> TR RttiType
newVar RttiType
liftedTypeKind
RttiType
world <- RttiType -> TR RttiType
newVar RttiType
liftedTypeKind
RttiType -> RttiType -> TR ()
addConstraint RttiType
my_ty (TyCon -> [RttiType] -> RttiType
mkTyConApp TyCon
mutVarPrimTyCon [RttiType
world,RttiType
tv'])
[(RttiType, ForeignHValue)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(RttiType, ForeignHValue)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(RttiType
tv', ForeignHValue
contents)]
ConstrClosure{ptrArgs :: forall b. GenClosure b -> [b]
ptrArgs=[ForeignHValue]
pArgs} -> do
Right dcname :: Name
dcname <- IO (Either String Name)
-> IOEnv (Env TcGblEnv TcLclEnv) (Either String Name)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String Name)
-> IOEnv (Env TcGblEnv TcLclEnv) (Either String Name))
-> IO (Either String Name)
-> IOEnv (Env TcGblEnv TcLclEnv) (Either String Name)
forall a b. (a -> b) -> a -> b
$ HscEnv -> GenClosure ForeignHValue -> IO (Either String Name)
forall a. HscEnv -> GenClosure a -> IO (Either String Name)
constrClosToName HscEnv
hsc_env GenClosure ForeignHValue
clos
SDoc -> TR ()
traceTR (String -> SDoc
text "Constr1" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
dcname)
(mb_dc :: Maybe DataCon
mb_dc, _) <- TcRn DataCon -> TcRn (Maybe DataCon, Messages)
forall a. TcRn a -> TcRn (Maybe a, Messages)
tryTc (Name -> TcRn DataCon
tcLookupDataCon Name
dcname)
case Maybe DataCon
mb_dc of
Nothing-> do
[ForeignHValue]
-> (ForeignHValue
-> IOEnv (Env TcGblEnv TcLclEnv) (RttiType, ForeignHValue))
-> IOEnv (Env TcGblEnv TcLclEnv) [(RttiType, 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) (RttiType, ForeignHValue))
-> IOEnv (Env TcGblEnv TcLclEnv) [(RttiType, ForeignHValue)])
-> (ForeignHValue
-> IOEnv (Env TcGblEnv TcLclEnv) (RttiType, ForeignHValue))
-> IOEnv (Env TcGblEnv TcLclEnv) [(RttiType, ForeignHValue)]
forall a b. (a -> b) -> a -> b
$ \x :: ForeignHValue
x -> do
RttiType
tv <- RttiType -> TR RttiType
newVar RttiType
liftedTypeKind
(RttiType, ForeignHValue)
-> IOEnv (Env TcGblEnv TcLclEnv) (RttiType, ForeignHValue)
forall (m :: * -> *) a. Monad m => a -> m a
return (RttiType
tv, ForeignHValue
x)
Just dc :: DataCon
dc -> do
[RttiType]
arg_tys <- DataCon -> RttiType -> IOEnv (Env TcGblEnv TcLclEnv) [RttiType]
getDataConArgTys DataCon
dc RttiType
my_ty
(_, itys :: [(Int, RttiType)]
itys) <- Int -> [RttiType] -> TR (Int, [(Int, RttiType)])
findPtrTyss 0 [RttiType]
arg_tys
SDoc -> TR ()
traceTR (String -> SDoc
text "Constr2" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
dcname SDoc -> SDoc -> SDoc
<+> [RttiType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [RttiType]
arg_tys)
[(RttiType, ForeignHValue)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(RttiType, ForeignHValue)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(RttiType, ForeignHValue)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(RttiType, ForeignHValue)])
-> [(RttiType, ForeignHValue)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(RttiType, ForeignHValue)]
forall a b. (a -> b) -> a -> b
$ ((Int, RttiType) -> ForeignHValue -> (RttiType, ForeignHValue))
-> [(Int, RttiType)]
-> [ForeignHValue]
-> [(RttiType, ForeignHValue)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(_,ty :: RttiType
ty) x :: ForeignHValue
x -> (RttiType
ty, ForeignHValue
x)) [(Int, RttiType)]
itys [ForeignHValue]
pArgs
_ -> [(RttiType, ForeignHValue)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(RttiType, ForeignHValue)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
findPtrTys :: Int
-> Type
-> TR (Int, [(Int, Type)])
findPtrTys :: Int -> RttiType -> TR (Int, [(Int, RttiType)])
findPtrTys i :: Int
i ty :: RttiType
ty
| Just (tc :: TyCon
tc, elem_tys :: [RttiType]
elem_tys) <- HasCallStack => RttiType -> Maybe (TyCon, [RttiType])
RttiType -> Maybe (TyCon, [RttiType])
tcSplitTyConApp_maybe RttiType
ty
, TyCon -> Bool
isUnboxedTupleTyCon TyCon
tc
= Int -> [RttiType] -> TR (Int, [(Int, RttiType)])
findPtrTyss Int
i [RttiType]
elem_tys
| Bool
otherwise
= case HasDebugCallStack => RttiType -> [PrimRep]
RttiType -> [PrimRep]
typePrimRep RttiType
ty of
[rep :: PrimRep
rep] | PrimRep -> Bool
isGcPtrRep PrimRep
rep -> (Int, [(Int, RttiType)]) -> TR (Int, [(Int, RttiType)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, [(Int
i, RttiType
ty)])
| Bool
otherwise -> (Int, [(Int, RttiType)]) -> TR (Int, [(Int, RttiType)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, [])
prim_reps :: [PrimRep]
prim_reps ->
((Int, [(Int, RttiType)])
-> PrimRep -> TR (Int, [(Int, RttiType)]))
-> (Int, [(Int, RttiType)])
-> [PrimRep]
-> TR (Int, [(Int, RttiType)])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\(i :: Int
i, extras :: [(Int, RttiType)]
extras) prim_rep :: PrimRep
prim_rep ->
if PrimRep -> Bool
isGcPtrRep PrimRep
prim_rep
then RttiType -> TR RttiType
newVar RttiType
liftedTypeKind TR RttiType
-> (RttiType -> TR (Int, [(Int, RttiType)]))
-> TR (Int, [(Int, RttiType)])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \tv :: RttiType
tv -> (Int, [(Int, RttiType)]) -> TR (Int, [(Int, RttiType)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, [(Int, RttiType)]
extras [(Int, RttiType)] -> [(Int, RttiType)] -> [(Int, RttiType)]
forall a. [a] -> [a] -> [a]
++ [(Int
i, RttiType
tv)])
else (Int, [(Int, RttiType)]) -> TR (Int, [(Int, RttiType)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, [(Int, RttiType)]
extras))
(Int
i, []) [PrimRep]
prim_reps
findPtrTyss :: Int
-> [Type]
-> TR (Int, [(Int, Type)])
findPtrTyss :: Int -> [RttiType] -> TR (Int, [(Int, RttiType)])
findPtrTyss i :: Int
i tys :: [RttiType]
tys = ((Int, [(Int, RttiType)])
-> RttiType -> TR (Int, [(Int, RttiType)]))
-> (Int, [(Int, RttiType)])
-> [RttiType]
-> TR (Int, [(Int, RttiType)])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Int, [(Int, RttiType)]) -> RttiType -> TR (Int, [(Int, RttiType)])
step (Int
i, []) [RttiType]
tys
where step :: (Int, [(Int, RttiType)]) -> RttiType -> TR (Int, [(Int, RttiType)])
step (i :: Int
i, discovered :: [(Int, RttiType)]
discovered) elem_ty :: RttiType
elem_ty = do
(i :: Int
i, extras :: [(Int, RttiType)]
extras) <- Int -> RttiType -> TR (Int, [(Int, RttiType)])
findPtrTys Int
i RttiType
elem_ty
(Int, [(Int, RttiType)]) -> TR (Int, [(Int, RttiType)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, [(Int, RttiType)]
discovered [(Int, RttiType)] -> [(Int, RttiType)] -> [(Int, RttiType)]
forall a. [a] -> [a] -> [a]
++ [(Int, RttiType)]
extras)
improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TCvSubst
improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TCvSubst
improveRTTIType _ base_ty :: RttiType
base_ty new_ty :: RttiType
new_ty = RttiType -> RttiType -> Maybe TCvSubst
U.tcUnifyTyKi RttiType
base_ty RttiType
new_ty
getDataConArgTys :: DataCon -> Type -> TR [Type]
getDataConArgTys :: DataCon -> RttiType -> IOEnv (Env TcGblEnv TcLclEnv) [RttiType]
getDataConArgTys dc :: DataCon
dc con_app_ty :: RttiType
con_app_ty
= do { let rep_con_app_ty :: RttiType
rep_con_app_ty = RttiType -> RttiType
unwrapType RttiType
con_app_ty
; SDoc -> TR ()
traceTR (String -> SDoc
text "getDataConArgTys 1" SDoc -> SDoc -> SDoc
<+> (RttiType -> SDoc
forall a. Outputable a => a -> SDoc
ppr RttiType
con_app_ty SDoc -> SDoc -> SDoc
$$ RttiType -> SDoc
forall a. Outputable a => a -> SDoc
ppr RttiType
rep_con_app_ty
SDoc -> SDoc -> SDoc
$$ Maybe (TyCon, [RttiType]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasCallStack => RttiType -> Maybe (TyCon, [RttiType])
RttiType -> Maybe (TyCon, [RttiType])
tcSplitTyConApp_maybe RttiType
rep_con_app_ty)))
; ASSERT( all isTyVar ex_tvs ) return ()
; (subst :: TCvSubst
subst, _) <- [TyVar] -> TR (TCvSubst, [TyVar])
instTyVars ([TyVar]
univ_tvs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
ex_tvs)
; RttiType -> RttiType -> TR ()
addConstraint RttiType
rep_con_app_ty (HasCallStack => TCvSubst -> RttiType -> RttiType
TCvSubst -> RttiType -> RttiType
substTy TCvSubst
subst (DataCon -> RttiType
dataConOrigResTy DataCon
dc))
; let con_arg_tys :: [RttiType]
con_arg_tys = HasCallStack => TCvSubst -> [RttiType] -> [RttiType]
TCvSubst -> [RttiType] -> [RttiType]
substTys TCvSubst
subst (DataCon -> [RttiType]
dataConRepArgTys DataCon
dc)
; SDoc -> TR ()
traceTR (String -> SDoc
text "getDataConArgTys 2" SDoc -> SDoc -> SDoc
<+> (RttiType -> SDoc
forall a. Outputable a => a -> SDoc
ppr RttiType
rep_con_app_ty SDoc -> SDoc -> SDoc
$$ [RttiType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [RttiType]
con_arg_tys SDoc -> SDoc -> SDoc
$$ TCvSubst -> SDoc
forall a. Outputable a => a -> SDoc
ppr TCvSubst
subst))
; [RttiType] -> IOEnv (Env TcGblEnv TcLclEnv) [RttiType]
forall (m :: * -> *) a. Monad m => a -> m a
return [RttiType]
con_arg_tys }
where
univ_tvs :: [TyVar]
univ_tvs = DataCon -> [TyVar]
dataConUnivTyVars DataCon
dc
ex_tvs :: [TyVar]
ex_tvs = DataCon -> [TyVar]
dataConExTyCoVars DataCon
dc
check1 :: QuantifiedType -> Bool
check1 :: QuantifiedType -> Bool
check1 (tvs :: [TyVar]
tvs, _) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (RttiType -> Bool) -> [RttiType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any RttiType -> Bool
isHigherKind ((TyVar -> RttiType) -> [TyVar] -> [RttiType]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> RttiType
tyVarKind [TyVar]
tvs)
where
isHigherKind :: RttiType -> Bool
isHigherKind = Bool -> Bool
not (Bool -> Bool) -> (RttiType -> Bool) -> RttiType -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TyCoBinder] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TyCoBinder] -> Bool)
-> (RttiType -> [TyCoBinder]) -> RttiType -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TyCoBinder], RttiType) -> [TyCoBinder]
forall a b. (a, b) -> a
fst (([TyCoBinder], RttiType) -> [TyCoBinder])
-> (RttiType -> ([TyCoBinder], RttiType))
-> RttiType
-> [TyCoBinder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RttiType -> ([TyCoBinder], RttiType)
splitPiTys
check2 :: QuantifiedType -> QuantifiedType -> Bool
check2 :: QuantifiedType -> QuantifiedType -> Bool
check2 (_, rtti_ty :: RttiType
rtti_ty) (_, old_ty :: RttiType
old_ty)
| Just (_, rttis :: [RttiType]
rttis) <- HasCallStack => RttiType -> Maybe (TyCon, [RttiType])
RttiType -> Maybe (TyCon, [RttiType])
tcSplitTyConApp_maybe RttiType
rtti_ty
= case () of
_ | Just (_,olds :: [RttiType]
olds) <- HasCallStack => RttiType -> Maybe (TyCon, [RttiType])
RttiType -> Maybe (TyCon, [RttiType])
tcSplitTyConApp_maybe RttiType
old_ty
-> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (QuantifiedType -> QuantifiedType -> Bool)
-> [QuantifiedType] -> [QuantifiedType] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith QuantifiedType -> QuantifiedType -> Bool
check2 ((RttiType -> QuantifiedType) -> [RttiType] -> [QuantifiedType]
forall a b. (a -> b) -> [a] -> [b]
map RttiType -> QuantifiedType
quantifyType [RttiType]
rttis) ((RttiType -> QuantifiedType) -> [RttiType] -> [QuantifiedType]
forall a b. (a -> b) -> [a] -> [b]
map RttiType -> QuantifiedType
quantifyType [RttiType]
olds)
_ | Just _ <- RttiType -> Maybe (RttiType, RttiType)
splitAppTy_maybe RttiType
old_ty
-> RttiType -> Bool
isMonomorphicOnNonPhantomArgs RttiType
rtti_ty
_ -> Bool
True
| Bool
otherwise = Bool
True
congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
congruenceNewtypes :: RttiType -> RttiType -> TR (RttiType, RttiType)
congruenceNewtypes lhs :: RttiType
lhs rhs :: RttiType
rhs = RttiType -> RttiType -> TR RttiType
go RttiType
lhs RttiType
rhs TR RttiType
-> (RttiType -> TR (RttiType, RttiType)) -> TR (RttiType, RttiType)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \rhs' :: RttiType
rhs' -> (RttiType, RttiType) -> TR (RttiType, RttiType)
forall (m :: * -> *) a. Monad m => a -> m a
return (RttiType
lhs,RttiType
rhs')
where
go :: RttiType -> RttiType -> TR RttiType
go l :: RttiType
l r :: RttiType
r
| Just tv :: TyVar
tv <- RttiType -> Maybe TyVar
getTyVar_maybe RttiType
l
, TyVar -> Bool
isTcTyVar TyVar
tv
, TyVar -> Bool
isMetaTyVar TyVar
tv
= TR RttiType -> TR RttiType -> TR RttiType
forall r. TcM r -> TcM r -> TcM r
recoverTR (RttiType -> TR RttiType
forall (m :: * -> *) a. Monad m => a -> m a
return RttiType
r) (TR RttiType -> TR RttiType) -> TR RttiType -> TR RttiType
forall a b. (a -> b) -> a -> b
$ do
Indirect ty_v :: RttiType
ty_v <- TyVar -> TcM MetaDetails
readMetaTyVar TyVar
tv
SDoc -> TR ()
traceTR (SDoc -> TR ()) -> SDoc -> TR ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
fsep [String -> SDoc
text "(congruence) Following indirect tyvar:",
TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
tv, SDoc
equals, RttiType -> SDoc
forall a. Outputable a => a -> SDoc
ppr RttiType
ty_v]
RttiType -> RttiType -> TR RttiType
go RttiType
ty_v RttiType
r
| Just (l1 :: RttiType
l1,l2 :: RttiType
l2) <- RttiType -> Maybe (RttiType, RttiType)
splitFunTy_maybe RttiType
l
, Just (r1 :: RttiType
r1,r2 :: RttiType
r2) <- RttiType -> Maybe (RttiType, RttiType)
splitFunTy_maybe RttiType
r
= do RttiType
r2' <- RttiType -> RttiType -> TR RttiType
go RttiType
l2 RttiType
r2
RttiType
r1' <- RttiType -> RttiType -> TR RttiType
go RttiType
l1 RttiType
r1
RttiType -> TR RttiType
forall (m :: * -> *) a. Monad m => a -> m a
return (RttiType -> RttiType -> RttiType
mkFunTy RttiType
r1' RttiType
r2')
| Just (tycon_l :: TyCon
tycon_l, _) <- HasCallStack => RttiType -> Maybe (TyCon, [RttiType])
RttiType -> Maybe (TyCon, [RttiType])
tcSplitTyConApp_maybe RttiType
lhs
, Just (tycon_r :: TyCon
tycon_r, _) <- HasCallStack => RttiType -> Maybe (TyCon, [RttiType])
RttiType -> Maybe (TyCon, [RttiType])
tcSplitTyConApp_maybe RttiType
rhs
, TyCon
tycon_l TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
/= TyCon
tycon_r
= TyCon -> RttiType -> TR RttiType
upgrade TyCon
tycon_l RttiType
r
| Bool
otherwise = RttiType -> TR RttiType
forall (m :: * -> *) a. Monad m => a -> m a
return RttiType
r
where upgrade :: TyCon -> Type -> TR Type
upgrade :: TyCon -> RttiType -> TR RttiType
upgrade new_tycon :: TyCon
new_tycon ty :: RttiType
ty
| Bool -> Bool
not (TyCon -> Bool
isNewTyCon TyCon
new_tycon) = do
SDoc -> TR ()
traceTR (String -> SDoc
text "(Upgrade) Not matching newtype evidence: " SDoc -> SDoc -> SDoc
<>
TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
new_tycon SDoc -> SDoc -> SDoc
<> String -> SDoc
text " for " SDoc -> SDoc -> SDoc
<> RttiType -> SDoc
forall a. Outputable a => a -> SDoc
ppr RttiType
ty)
RttiType -> TR RttiType
forall (m :: * -> *) a. Monad m => a -> m a
return RttiType
ty
| Bool
otherwise = do
SDoc -> TR ()
traceTR (String -> SDoc
text "(Upgrade) upgraded " SDoc -> SDoc -> SDoc
<> RttiType -> SDoc
forall a. Outputable a => a -> SDoc
ppr RttiType
ty SDoc -> SDoc -> SDoc
<>
String -> SDoc
text " in presence of newtype evidence " SDoc -> SDoc -> SDoc
<> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
new_tycon)
(_, vars :: [TyVar]
vars) <- [TyVar] -> TR (TCvSubst, [TyVar])
instTyVars (TyCon -> [TyVar]
tyConTyVars TyCon
new_tycon)
let ty' :: RttiType
ty' = TyCon -> [RttiType] -> RttiType
mkTyConApp TyCon
new_tycon ([TyVar] -> [RttiType]
mkTyVarTys [TyVar]
vars)
rep_ty :: RttiType
rep_ty = RttiType -> RttiType
unwrapType RttiType
ty'
TcCoercionN
_ <- TcM TcCoercionN -> TcM TcCoercionN
forall a. TcM a -> TcM a
liftTcM (Maybe (HsExpr GhcRn) -> RttiType -> RttiType -> TcM TcCoercionN
unifyType Maybe (HsExpr GhcRn)
forall a. Maybe a
Nothing RttiType
ty RttiType
rep_ty)
RttiType -> TR RttiType
forall (m :: * -> *) a. Monad m => a -> m a
return RttiType
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 :: forall (m :: * -> *) a.
TermProcessor a (m a)
-> (RttiType -> [Word] -> m a)
-> (ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> m a)
-> (RttiType -> Either String DataCon -> a -> m a)
-> (RttiType -> a -> m a)
-> TermFoldM m a
TermFoldM
{ fTermM :: TermProcessor Term (TR Term)
fTermM = \ty :: RttiType
ty dc :: Either String DataCon
dc v :: ForeignHValue
v tt :: [Term]
tt -> RttiType -> TR RttiType
zonkRttiType RttiType
ty TR RttiType -> (RttiType -> TR Term) -> TR Term
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ty' :: RttiType
ty' ->
Term -> TR Term
forall (m :: * -> *) a. Monad m => a -> m a
return (TermProcessor Term Term
Term RttiType
ty' Either String DataCon
dc ForeignHValue
v [Term]
tt)
, fSuspensionM :: ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> TR Term
fSuspensionM = \ct :: ClosureType
ct ty :: RttiType
ty v :: ForeignHValue
v b :: Maybe Name
b -> RttiType -> TR RttiType
zonkRttiType RttiType
ty TR RttiType -> (RttiType -> TR Term) -> TR Term
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ty :: RttiType
ty ->
Term -> TR Term
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosureType -> RttiType -> ForeignHValue -> Maybe Name -> Term
Suspension ClosureType
ct RttiType
ty ForeignHValue
v Maybe Name
b)
, fNewtypeWrapM :: RttiType -> Either String DataCon -> Term -> TR Term
fNewtypeWrapM = \ty :: RttiType
ty dc :: Either String DataCon
dc t :: Term
t -> RttiType -> TR RttiType
zonkRttiType RttiType
ty TR RttiType -> (RttiType -> TR Term) -> TR Term
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ty' :: RttiType
ty' ->
Term -> TR Term
forall (m :: * -> *) a. Monad m => a -> m a
return(Term -> TR Term) -> Term -> TR Term
forall a b. (a -> b) -> a -> b
$ RttiType -> Either String DataCon -> Term -> Term
NewtypeWrap RttiType
ty' Either String DataCon
dc Term
t
, fRefWrapM :: RttiType -> Term -> TR Term
fRefWrapM = \ty :: RttiType
ty t :: Term
t -> (RttiType -> Term -> Term)
-> IOEnv (Env TcGblEnv TcLclEnv) (RttiType -> Term -> Term)
forall (m :: * -> *) a. Monad m => a -> m a
return RttiType -> Term -> Term
RefWrap IOEnv (Env TcGblEnv TcLclEnv) (RttiType -> Term -> Term)
-> TR RttiType -> IOEnv (Env TcGblEnv TcLclEnv) (Term -> Term)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap`
RttiType -> TR RttiType
zonkRttiType RttiType
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 (m :: * -> *) a. Monad m => a -> m a
return Term
t
, fPrimM :: RttiType -> [Word] -> TR Term
fPrimM = (Term -> TR Term
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)
-> (RttiType -> [Word] -> Term) -> RttiType -> [Word] -> TR Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RttiType -> [Word] -> Term
Prim })
zonkRttiType :: TcType -> TcM Type
zonkRttiType :: RttiType -> TR RttiType
zonkRttiType ty :: RttiType
ty= do { ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
RuntimeUnkFlexi
; ZonkEnv -> RttiType -> TR RttiType
zonkTcTypeToTypeX ZonkEnv
ze RttiType
ty }
dictsView :: Type -> Type
dictsView :: RttiType -> RttiType
dictsView ty :: RttiType
ty = RttiType
ty
isMonomorphic :: RttiType -> Bool
isMonomorphic :: RttiType -> Bool
isMonomorphic ty :: RttiType
ty = Bool
noExistentials Bool -> Bool -> Bool
&& Bool
noUniversals
where (tvs :: [TyVar]
tvs, _, ty' :: RttiType
ty') = RttiType -> ([TyVar], [RttiType], RttiType)
tcSplitSigmaTy RttiType
ty
noExistentials :: Bool
noExistentials = RttiType -> Bool
noFreeVarsOfType RttiType
ty'
noUniversals :: Bool
noUniversals = [TyVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVar]
tvs
isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
isMonomorphicOnNonPhantomArgs ty :: RttiType
ty
| Just (tc :: TyCon
tc, all_args :: [RttiType]
all_args) <- HasCallStack => RttiType -> Maybe (TyCon, [RttiType])
RttiType -> Maybe (TyCon, [RttiType])
tcSplitTyConApp_maybe (RttiType -> RttiType
unwrapType RttiType
ty)
, [TyVar]
phantom_vars <- TyCon -> [TyVar]
tyConPhantomTyVars TyCon
tc
, [RttiType]
concrete_args <- [ RttiType
arg | (tyv :: TyVar
tyv,arg :: RttiType
arg) <- TyCon -> [TyVar]
tyConTyVars TyCon
tc [TyVar] -> [RttiType] -> [(TyVar, RttiType)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [RttiType]
all_args
, TyVar
tyv TyVar -> [TyVar] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [TyVar]
phantom_vars]
= (RttiType -> Bool) -> [RttiType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all RttiType -> Bool
isMonomorphicOnNonPhantomArgs [RttiType]
concrete_args
| Just (ty1 :: RttiType
ty1, ty2 :: RttiType
ty2) <- RttiType -> Maybe (RttiType, RttiType)
splitFunTy_maybe RttiType
ty
= (RttiType -> Bool) -> [RttiType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all RttiType -> Bool
isMonomorphicOnNonPhantomArgs [RttiType
ty1,RttiType
ty2]
| Bool
otherwise = RttiType -> Bool
isMonomorphic RttiType
ty
tyConPhantomTyVars :: TyCon -> [TyVar]
tyConPhantomTyVars :: TyCon -> [TyVar]
tyConPhantomTyVars tc :: TyCon
tc
| TyCon -> Bool
isAlgTyCon TyCon
tc
, Just dcs :: [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 _ = []
type QuantifiedType = ([TyVar], Type)
quantifyType :: Type -> QuantifiedType
quantifyType :: RttiType -> QuantifiedType
quantifyType ty :: RttiType
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
$
RttiType -> [TyVar]
tyCoVarsOfTypeWellScoped RttiType
rho
, RttiType
rho)
where
(_tvs :: [TyVar]
_tvs, rho :: RttiType
rho) = RttiType -> QuantifiedType
tcSplitForAllTys RttiType
ty