    {-# LANGUAGE BangPatterns, ScopedTypeVariables, MagicHash #-}

    -----------------------------------------------------------------------------
    --
    -- GHC Interactive support for inspecting arbitrary closures at runtime
    --
    -- Pepe Iborra (supported by Google SoC) 2006
    --
    -----------------------------------------------------------------------------
    module GHC.Runtime.Heap.Inspect(
         -- * Entry points and types
         cvObtainTerm,
         cvReconstructType,
         improveRTTIType,
         Term(..),

         -- * Utils
         isFullyEvaluatedTerm,
         termType, mapTermType, termTyCoVars,
         foldTerm, TermFold(..),
         cPprTerm, cPprTermBase,

         constrClosToName -- exported to use in test T4891
     ) where

    import GHC.Prelude
    import GHC.Platform

    import GHC.Runtime.Interpreter as GHCi
    import GHCi.RemoteTypes
    import GHC.Driver.Env
    import GHCi.Message ( fromSerializableException )

    import GHC.Core.DataCon
    import GHC.Core.Type
    import GHC.Types.RepType
    import GHC.Core.Multiplicity
    import qualified GHC.Core.Unify as U
    import GHC.Types.Var
    import GHC.Tc.Utils.Monad
    import GHC.Tc.Utils.TcType
    import GHC.Tc.Utils.TcMType
    import GHC.Tc.Utils.Zonk ( zonkTcTypeToTypeX, mkEmptyZonkEnv, ZonkFlexi( RuntimeUnkFlexi ) )
    import GHC.Tc.Utils.Unify
    import GHC.Tc.Utils.Env

    import GHC.Core.TyCon
    import GHC.Types.Name
    import GHC.Types.Name.Occurrence as OccName
    import GHC.Unit.Module
    import GHC.Iface.Env
    import GHC.Utils.Misc
    import GHC.Types.Var.Set
    import GHC.Types.Basic ( Boxity(..) )
    import GHC.Builtin.Types.Prim
    import GHC.Builtin.Types
    import GHC.Driver.Session
    import GHC.Driver.Ppr
    import GHC.Utils.Outputable as Ppr
    import GHC.Utils.Panic
    import GHC.Utils.Panic.Plain
    import GHC.Char
    import GHC.Exts.Heap
    import GHC.Runtime.Heap.Layout ( roundUpTo )
    import GHC.IO (throwIO)

    import Control.Monad
    import Data.Maybe
    import Data.List ((\\))
    import GHC.Exts
    import qualified Data.Sequence as Seq
    import Data.Sequence (viewl, ViewL(..))
    import Foreign hiding (shiftL, shiftR)
    import System.IO.Unsafe

    ---------------------------------------------
    -- * A representation of semi evaluated Terms
    ---------------------------------------------

    data Term = Term { Term -> Type
    ty        :: RttiType
                     , Term -> Either String DataCon
    dc        :: Either String DataCon
                                   -- Carries a text representation if the datacon is
                                   -- not exported by the .hi file, which is the case
                                   -- for private constructors in -O0 compiled libraries
                     , 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   -- Useful for printing
                           }
              | NewtypeWrap{       -- At runtime there are no newtypes, and hence no
                                   -- newtype constructors. A NewtypeWrap is just a
                                   -- made-up tag saying "heads up, there used to be
                                   -- a newtype constructor here".
                             ty           :: RttiType
                           , dc           :: Either String DataCon
                           , Term -> Term
    wrapped_term :: Term }
              | RefWrap    {       -- The contents of a reference
                             ty           :: RttiType
                           , wrapped_term :: Term }

    termType :: Term -> RttiType
    termType :: Term -> Type
    termType Term
    t = Term -> Type
    ty Term
    t

    isFullyEvaluatedTerm :: Term -> Bool
    isFullyEvaluatedTerm :: Term -> Bool
    isFullyEvaluatedTerm Term {subTerms :: Term -> [Term]
    subTerms=[Term]
    tt} = (Term -> Bool) -> [Term] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Term -> Bool
    isFullyEvaluatedTerm [Term]
    tt
    isFullyEvaluatedTerm Prim {}            = Bool
    True
    isFullyEvaluatedTerm NewtypeWrap{wrapped_term :: Term -> Term
    wrapped_term=Term
    t} = Term -> Bool
    isFullyEvaluatedTerm Term
    t
    isFullyEvaluatedTerm RefWrap{wrapped_term :: Term -> Term
    wrapped_term=Term
    t}     = Term -> Bool
    isFullyEvaluatedTerm Term
    t
    isFullyEvaluatedTerm Term
    _                  = Bool
    False

    instance Outputable (Term) where
     ppr :: Term -> SDoc
    ppr Term
    t | Just SDoc
    doc <- CustomTermPrinter Maybe -> Term -> Maybe SDoc
    forall (m :: * -> *).
    Monad m =>
    CustomTermPrinter m -> Term -> m SDoc
    cPprTerm CustomTermPrinter Maybe
    forall (m :: * -> *). Monad m => CustomTermPrinter m
    cPprTermBase Term
    t = SDoc
    doc
           | Bool
    otherwise = String -> SDoc
    forall a. String -> a
    panic String
    "Outputable Term instance"

    ----------------------------------------
    -- Runtime Closure information functions
    ----------------------------------------

    isThunk :: GenClosure a -> Bool
    isThunk :: forall a. GenClosure a -> Bool
    isThunk ThunkClosure{} = Bool
    True
    isThunk APClosure{} = Bool
    True
    isThunk APStackClosure{} = Bool
    True
    isThunk GenClosure a
    _             = Bool
    False

    -- Lookup the name in a constructor closure
    constrClosToName :: HscEnv -> GenClosure a -> IO (Either String Name)
    constrClosToName :: forall a. HscEnv -> GenClosure a -> IO (Either String Name)
    constrClosToName HscEnv
    hsc_env ConstrClosure{pkg :: forall b. GenClosure b -> String
    pkg=String
    pkg,modl :: forall b. GenClosure b -> String
    modl=String
    mod,name :: forall b. GenClosure b -> String
    name=String
    occ} = do
       let occName :: OccName
    occName = NameSpace -> String -> OccName
    mkOccName NameSpace
    OccName.dataName String
    occ
           modName :: GenModule Unit
    modName = Unit -> ModuleName -> GenModule Unit
    forall u. u -> ModuleName -> GenModule u
    mkModule (String -> Unit
    stringToUnit String
    pkg) (String -> ModuleName
    mkModuleName String
    mod)
       Name -> Either String Name
    forall a b. b -> Either a b
    Right (Name -> Either String Name) -> IO Name -> IO (Either String Name)
    forall a b. (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` HscEnv -> GenModule Unit -> OccName -> IO Name
    lookupOrigIO HscEnv
    hsc_env GenModule Unit
    modName OccName
    occName
    constrClosToName HscEnv
    _hsc_env GenClosure a
    clos =
       Either String Name -> IO (Either String Name)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> Either String Name
    forall a b. a -> Either a b
    Left (String
    "conClosToName: Expected ConstrClosure, got " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ GenClosure () -> String
    forall a. Show a => a -> String
    show ((a -> ()) -> GenClosure a -> GenClosure ()
    forall a b. (a -> b) -> GenClosure a -> GenClosure b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (() -> a -> ()
    forall a b. a -> b -> a
    const ()) GenClosure a
    clos)))

    -----------------------------------
    -- * Traversals for Terms
    -----------------------------------
    type TermProcessor a b = RttiType -> Either String DataCon -> ForeignHValue -> [a] -> b

    data TermFold a = TermFold { forall a. TermFold a -> TermProcessor a a
    fTerm        :: TermProcessor a a
                               , forall a. TermFold a -> Type -> [Word] -> a
    fPrim        :: RttiType -> [Word] -> a
                               , forall a.
    TermFold a
    -> ClosureType -> Type -> ForeignHValue -> Maybe Name -> a
    fSuspension  :: ClosureType -> RttiType -> ForeignHValue
                                                -> Maybe Name -> a
                               , forall a. TermFold a -> Type -> Either String DataCon -> a -> a
    fNewtypeWrap :: RttiType -> Either String DataCon
                                                -> a -> a
                               , forall a. TermFold a -> Type -> a -> a
    fRefWrap     :: RttiType -> a -> a
                               }

    data TermFoldM m a =
                       TermFoldM {forall (m :: * -> *) a. TermFoldM m a -> TermProcessor a (m a)
    fTermM        :: TermProcessor a (m a)
                                , forall (m :: * -> *) a. TermFoldM m a -> Type -> [Word] -> m a
    fPrimM        :: RttiType -> [Word] -> m a
                                , forall (m :: * -> *) a.
    TermFoldM m a
    -> ClosureType -> Type -> ForeignHValue -> Maybe Name -> m a
    fSuspensionM  :: ClosureType -> RttiType -> ForeignHValue
                                                 -> Maybe Name -> m a
                                , forall (m :: * -> *) a.
    TermFoldM m a -> Type -> Either String DataCon -> a -> m a
    fNewtypeWrapM :: RttiType -> Either String DataCon
                                                -> a -> m a
                                , forall (m :: * -> *) a. TermFoldM m a -> Type -> a -> m a
    fRefWrapM     :: RttiType -> a -> m a
                               }

    foldTerm :: TermFold a -> Term -> a
    foldTerm :: forall a. TermFold a -> Term -> a
    foldTerm TermFold a
    tf (Term Type
    ty Either String DataCon
    dc ForeignHValue
    v [Term]
    tt) = TermFold a -> TermProcessor a a
    forall a. TermFold a -> TermProcessor a a
    fTerm TermFold a
    tf Type
    ty Either String DataCon
    dc ForeignHValue
    v ((Term -> a) -> [Term] -> [a]
    forall a b. (a -> b) -> [a] -> [b]
    map (TermFold a -> Term -> a
    forall a. TermFold a -> Term -> a
    foldTerm TermFold a
    tf) [Term]
    tt)
    foldTerm TermFold a
    tf (Prim Type
    ty    [Word]
    v   ) = TermFold a -> Type -> [Word] -> a
    forall a. TermFold a -> Type -> [Word] -> a
    fPrim TermFold a
    tf Type
    ty [Word]
    v
    foldTerm TermFold a
    tf (Suspension ClosureType
    ct Type
    ty ForeignHValue
    v Maybe Name
    b) = TermFold a
    -> ClosureType -> Type -> ForeignHValue -> Maybe Name -> a
    forall a.
    TermFold a
    -> ClosureType -> Type -> ForeignHValue -> Maybe Name -> a
    fSuspension TermFold a
    tf ClosureType
    ct Type
    ty ForeignHValue
    v Maybe Name
    b
    foldTerm TermFold a
    tf (NewtypeWrap Type
    ty Either String DataCon
    dc Term
    t)  = TermFold a -> Type -> Either String DataCon -> a -> a
    forall a. TermFold a -> Type -> Either String DataCon -> a -> a
    fNewtypeWrap TermFold a
    tf Type
    ty Either String DataCon
    dc (TermFold a -> Term -> a
    forall a. TermFold a -> Term -> a
    foldTerm TermFold a
    tf Term
    t)
    foldTerm TermFold a
    tf (RefWrap Type
    ty Term
    t)         = TermFold a -> Type -> a -> a
    forall a. TermFold a -> Type -> a -> a
    fRefWrap TermFold a
    tf Type
    ty (TermFold a -> Term -> a
    forall a. TermFold a -> Term -> a
    foldTerm TermFold a
    tf Term
    t)

    foldTermM :: Monad m => TermFoldM m a -> Term -> m a
    foldTermM :: forall (m :: * -> *) a. Monad m => TermFoldM m a -> Term -> m a
    foldTermM TermFoldM m a
    tf (Term Type
    ty Either String DataCon
    dc ForeignHValue
    v [Term]
    tt) = (Term -> m a) -> [Term] -> m [a]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (TermFoldM m a -> Term -> m a
    forall (m :: * -> *) a. Monad m => TermFoldM m a -> Term -> m a
    foldTermM TermFoldM m a
    tf) [Term]
    tt m [a] -> ([a] -> m a) -> m a
    forall a b. m a -> (a -> m b) -> m b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= TermFoldM m a -> TermProcessor a (m a)
    forall (m :: * -> *) a. TermFoldM m a -> TermProcessor a (m a)
    fTermM TermFoldM m a
    tf Type
    ty Either String DataCon
    dc ForeignHValue
    v
    foldTermM TermFoldM m a
    tf (Prim Type
    ty    [Word]
    v   ) = TermFoldM m a -> Type -> [Word] -> m a
    forall (m :: * -> *) a. TermFoldM m a -> Type -> [Word] -> m a
    fPrimM TermFoldM m a
    tf Type
    ty [Word]
    v
    foldTermM TermFoldM m a
    tf (Suspension ClosureType
    ct Type
    ty ForeignHValue
    v Maybe Name
    b) = TermFoldM m a
    -> ClosureType -> Type -> ForeignHValue -> Maybe Name -> m a
    forall (m :: * -> *) a.
    TermFoldM m a
    -> ClosureType -> Type -> ForeignHValue -> Maybe Name -> m a
    fSuspensionM TermFoldM m a
    tf ClosureType
    ct Type
    ty ForeignHValue
    v Maybe Name
    b
    foldTermM TermFoldM m a
    tf (NewtypeWrap Type
    ty Either String DataCon
    dc Term
    t)  = TermFoldM m a -> Term -> m a
    forall (m :: * -> *) a. Monad m => TermFoldM m a -> Term -> m a
    foldTermM TermFoldM m a
    tf Term
    t m a -> (a -> m a) -> m a
    forall a b. m a -> (a -> m b) -> m b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>=  TermFoldM m a -> Type -> Either String DataCon -> a -> m a
    forall (m :: * -> *) a.
    TermFoldM m a -> Type -> Either String DataCon -> a -> m a
    fNewtypeWrapM TermFoldM m a
    tf Type
    ty Either String DataCon
    dc
    foldTermM TermFoldM m a
    tf (RefWrap Type
    ty Term
    t)         = TermFoldM m a -> Term -> m a
    forall (m :: * -> *) a. Monad m => TermFoldM m a -> Term -> m a
    foldTermM TermFoldM m a
    tf Term
    t m a -> (a -> m a) -> m a
    forall a b. m a -> (a -> m b) -> m b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= TermFoldM m a -> Type -> a -> m a
    forall (m :: * -> *) a. TermFoldM m a -> Type -> a -> m a
    fRefWrapM TermFoldM m a
    tf Type
    ty

    idTermFold :: TermFold Term
    idTermFold :: TermFold Term
    idTermFold = TermFold {
                  fTerm :: TermProcessor Term Term
    fTerm = TermProcessor Term Term
    Term,
                  fPrim :: Type -> [Word] -> Term
    fPrim = Type -> [Word] -> Term
    Prim,
                  fSuspension :: ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
    fSuspension  = ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
    Suspension,
                  fNewtypeWrap :: Type -> Either String DataCon -> Term -> Term
    fNewtypeWrap = Type -> Either String DataCon -> Term -> Term
    NewtypeWrap,
                  fRefWrap :: Type -> Term -> Term
    fRefWrap = Type -> Term -> Term
    RefWrap
                          }

    mapTermType :: (RttiType -> Type) -> Term -> Term
    mapTermType :: (Type -> Type) -> Term -> Term
    mapTermType Type -> Type
    f = TermFold Term -> Term -> Term
    forall a. TermFold a -> Term -> a
    foldTerm TermFold Term
    idTermFold {
              fTerm :: TermProcessor Term Term
    fTerm       = \Type
    ty Either String DataCon
    dc ForeignHValue
    hval [Term]
    tt -> TermProcessor Term Term
    Term (Type -> Type
    f Type
    ty) Either String DataCon
    dc ForeignHValue
    hval [Term]
    tt,
              fSuspension :: ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
    fSuspension = \ClosureType
    ct Type
    ty ForeignHValue
    hval Maybe Name
    n ->
                              ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
    Suspension ClosureType
    ct (Type -> Type
    f Type
    ty) ForeignHValue
    hval Maybe Name
    n,
              fNewtypeWrap :: Type -> Either String DataCon -> Term -> Term
    fNewtypeWrap= \Type
    ty Either String DataCon
    dc Term
    t -> Type -> Either String DataCon -> Term -> Term
    NewtypeWrap (Type -> Type
    f Type
    ty) Either String DataCon
    dc Term
    t,
              fRefWrap :: Type -> Term -> Term
    fRefWrap    = \Type
    ty Term
    t -> Type -> Term -> Term
    RefWrap (Type -> Type
    f Type
    ty) Term
    t}

    mapTermTypeM :: Monad m =>  (RttiType -> m Type) -> Term -> m Term
    mapTermTypeM :: forall (m :: * -> *). Monad m => (Type -> m Type) -> Term -> m Term
    mapTermTypeM Type -> m Type
    f = TermFoldM m Term -> Term -> m Term
    forall (m :: * -> *) a. Monad m => TermFoldM m a -> Term -> m a
    foldTermM TermFoldM {
              fTermM :: TermProcessor Term (m Term)
    fTermM       = \Type
    ty Either String DataCon
    dc ForeignHValue
    hval [Term]
    tt -> Type -> m Type
    f Type
    ty m Type -> (Type -> m Term) -> m Term
    forall a b. m a -> (a -> m b) -> m b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \Type
    ty' -> Term -> m Term
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Term -> m Term) -> Term -> m Term
    forall a b. (a -> b) -> a -> b
    $ TermProcessor Term Term
    Term Type
    ty'  Either String DataCon
    dc ForeignHValue
    hval [Term]
    tt,
              fPrimM :: Type -> [Word] -> m Term
    fPrimM       = (Term -> m Term
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return(Term -> m Term) -> ([Word] -> Term) -> [Word] -> m Term
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .) (([Word] -> Term) -> [Word] -> m Term)
    -> (Type -> [Word] -> Term) -> Type -> [Word] -> m Term
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Type -> [Word] -> Term
    Prim,
              fSuspensionM :: ClosureType -> Type -> ForeignHValue -> Maybe Name -> m Term
    fSuspensionM = \ClosureType
    ct Type
    ty ForeignHValue
    hval Maybe Name
    n ->
                              Type -> m Type
    f Type
    ty m Type -> (Type -> m Term) -> m Term
    forall a b. m a -> (a -> m b) -> m b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \Type
    ty' -> Term -> m Term
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Term -> m Term) -> Term -> m Term
    forall a b. (a -> b) -> a -> b
    $ ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
    Suspension ClosureType
    ct Type
    ty' ForeignHValue
    hval Maybe Name
    n,
              fNewtypeWrapM :: Type -> Either String DataCon -> Term -> m Term
    fNewtypeWrapM= \Type
    ty Either String DataCon
    dc Term
    t -> Type -> m Type
    f Type
    ty m Type -> (Type -> m Term) -> m Term
    forall a b. m a -> (a -> m b) -> m b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \Type
    ty' -> Term -> m Term
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Term -> m Term) -> Term -> m Term
    forall a b. (a -> b) -> a -> b
    $ Type -> Either String DataCon -> Term -> Term
    NewtypeWrap Type
    ty' Either String DataCon
    dc Term
    t,
              fRefWrapM :: Type -> Term -> m Term
    fRefWrapM    = \Type
    ty Term
    t -> Type -> m Type
    f Type
    ty m Type -> (Type -> m Term) -> m Term
    forall a b. m a -> (a -> m b) -> m b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \Type
    ty' -> Term -> m Term
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Term -> m Term) -> Term -> m Term
    forall a b. (a -> b) -> a -> b
    $ Type -> Term -> Term
    RefWrap Type
    ty' Term
    t}

    termTyCoVars :: Term -> TyCoVarSet
    termTyCoVars :: Term -> TyCoVarSet
    termTyCoVars = TermFold TyCoVarSet -> Term -> TyCoVarSet
    forall a. TermFold a -> Term -> a
    foldTerm TermFold {
                fTerm :: TermProcessor TyCoVarSet TyCoVarSet
    fTerm       = \Type
    ty Either String DataCon
    _ ForeignHValue
    _ [TyCoVarSet]
    tt   ->
                              Type -> TyCoVarSet
    tyCoVarsOfType Type
    ty TyCoVarSet -> TyCoVarSet -> TyCoVarSet
    `unionVarSet` [TyCoVarSet] -> TyCoVarSet
    concatVarEnv [TyCoVarSet]
    tt,
                fSuspension :: ClosureType -> Type -> ForeignHValue -> Maybe Name -> TyCoVarSet
    fSuspension = \ClosureType
    _ Type
    ty ForeignHValue
    _ Maybe Name
    _ -> Type -> TyCoVarSet
    tyCoVarsOfType Type
    ty,
                fPrim :: Type -> [Word] -> TyCoVarSet
    fPrim       = \ Type
    _ [Word]
    _ -> TyCoVarSet
    emptyVarSet,
                fNewtypeWrap :: Type -> Either String DataCon -> TyCoVarSet -> TyCoVarSet
    fNewtypeWrap= \Type
    ty Either String DataCon
    _ TyCoVarSet
    t -> Type -> TyCoVarSet
    tyCoVarsOfType Type
    ty TyCoVarSet -> TyCoVarSet -> TyCoVarSet
    `unionVarSet` TyCoVarSet
    t,
                fRefWrap :: Type -> TyCoVarSet -> TyCoVarSet
    fRefWrap    = \Type
    ty TyCoVarSet
    t -> Type -> TyCoVarSet
    tyCoVarsOfType Type
    ty TyCoVarSet -> TyCoVarSet -> TyCoVarSet
    `unionVarSet` TyCoVarSet
    t}
        where concatVarEnv :: [TyCoVarSet] -> TyCoVarSet
    concatVarEnv = (TyCoVarSet -> TyCoVarSet -> TyCoVarSet)
    -> TyCoVarSet -> [TyCoVarSet] -> TyCoVarSet
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr TyCoVarSet -> TyCoVarSet -> TyCoVarSet
    unionVarSet TyCoVarSet
    emptyVarSet

    ----------------------------------
    -- Pretty printing of terms
    ----------------------------------

    type Precedence        = Int
    type TermPrinterM m    = Precedence -> Term -> m SDoc

    app_prec,cons_prec, max_prec ::Int
    max_prec :: Int
    max_prec  = Int
    10
    app_prec :: Int
    app_prec  = Int
    max_prec
    cons_prec :: Int
    cons_prec = Int
    5 -- TODO Extract this info from GHC itself

    pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
    pprTermM :: forall (m :: * -> *). Monad m => TermPrinterM m -> TermPrinterM m
    pprTermM TermPrinterM m
    y Int
    p Term
    t = SDoc -> SDoc
    pprDeeper (SDoc -> SDoc) -> m SDoc -> m SDoc
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    `liftM` TermPrinterM m -> TermPrinterM m
    forall (m :: * -> *). Monad m => TermPrinterM m -> TermPrinterM m
    ppr_termM TermPrinterM m
    y Int
    p Term
    t

    ppr_termM :: forall (m :: * -> *). Monad m => TermPrinterM m -> TermPrinterM m
    ppr_termM TermPrinterM m
    y Int
    p Term{dc :: Term -> Either String DataCon
    dc=Left String
    dc_tag, subTerms :: Term -> [Term]
    subTerms=[Term]
    tt} = do
      [SDoc]
    tt_docs <- (Term -> m SDoc) -> [Term] -> m [SDoc]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (TermPrinterM m
    y Int
    app_prec) [Term]
    tt
      SDoc -> m SDoc
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (SDoc -> m SDoc) -> SDoc -> m SDoc
    forall a b. (a -> b) -> a -> b
    $ Bool -> SDoc -> SDoc
    cparen (Bool -> Bool
    not ([Term] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Term]
    tt) Bool -> Bool -> Bool
    && Int
    p Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    app_prec)
                      (String -> SDoc
    text String
    dc_tag SDoc -> SDoc -> SDoc
    <+> ([SDoc] -> SDoc) -> [SDoc] -> SDoc
    pprDeeperList [SDoc] -> SDoc
    fsep [SDoc]
    tt_docs)

    ppr_termM TermPrinterM m
    y Int
    p Term{dc :: Term -> Either String DataCon
    dc=Right DataCon
    dc, subTerms :: Term -> [Term]
    subTerms=[Term]
    tt}
    {-  | dataConIsInfix dc, (t1:t2:tt') <- tt  --TODO fixity
      = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
        <+> hsep (map (ppr_term1 True) tt)
    -} -- TODO Printing infix constructors properly
      = do { [SDoc]
    tt_docs' <- (Term -> m SDoc) -> [Term] -> m [SDoc]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (TermPrinterM m
    y Int
    app_prec) [Term]
    tt
           ; SDoc -> m SDoc
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (SDoc -> m SDoc) -> SDoc -> m SDoc
    forall a b. (a -> b) -> a -> b
    $ SDoc -> SDoc -> SDoc
    ifPprDebug ([SDoc] -> SDoc
    show_tm [SDoc]
    tt_docs')
                                 ([SDoc] -> SDoc
    show_tm ([Type] -> [SDoc] -> [SDoc]
    forall b a. [b] -> [a] -> [a]
    dropList (DataCon -> [Type]
    dataConTheta DataCon
    dc) [SDoc]
    tt_docs'))
                      -- Don't show the dictionary arguments to
                      -- constructors unless -dppr-debug is on
           }
      where
        show_tm :: [SDoc] -> SDoc
    show_tm [SDoc]
    tt_docs
          | [SDoc] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [SDoc]
    tt_docs = DataCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr DataCon
    dc
          | Bool
    otherwise    = Bool -> SDoc -> SDoc
    cparen (Int
    p Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    app_prec) (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $
                           [SDoc] -> SDoc
    sep [DataCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr DataCon
    dc, Int -> SDoc -> SDoc
    nest Int
    2 (([SDoc] -> SDoc) -> [SDoc] -> SDoc
    pprDeeperList [SDoc] -> SDoc
    fsep [SDoc]
    tt_docs)]

    ppr_termM TermPrinterM m
    y Int
    p t :: Term
    t@NewtypeWrap{} = TermPrinterM m -> TermPrinterM m
    forall (m :: * -> *). Monad m => TermPrinterM m -> TermPrinterM m
    pprNewtypeWrap TermPrinterM m
    y Int
    p Term
    t
    ppr_termM TermPrinterM m
    y Int
    p RefWrap{wrapped_term :: Term -> Term
    wrapped_term=Term
    t}  = do
      SDoc
    contents <- TermPrinterM m
    y Int
    app_prec Term
    t
      SDoc -> m SDoc
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return(SDoc -> m SDoc) -> SDoc -> m SDoc
    forall a b. (a -> b) -> a -> b
    $ Bool -> SDoc -> SDoc
    cparen (Int
    p Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    app_prec) (String -> SDoc
    text String
    "GHC.Prim.MutVar#" SDoc -> SDoc -> SDoc
    <+> SDoc
    contents)
      -- The constructor name is wired in here ^^^ for the sake of simplicity.
      -- I don't think mutvars are going to change in a near future.
      -- In any case this is solely a presentation matter: MutVar# is
      -- a datatype with no constructors, implemented by the RTS
      -- (hence there is no way to obtain a datacon and print it).
    ppr_termM TermPrinterM m
    _ Int
    _ Term
    t = Term -> m SDoc
    forall (m :: * -> *). Monad m => Term -> m SDoc
    ppr_termM1 Term
    t

    ppr_termM1 :: Monad m => Term -> m SDoc
    ppr_termM1 :: forall (m :: * -> *). Monad m => Term -> m SDoc
    ppr_termM1 Prim{valRaw :: Term -> [Word]
    valRaw=[Word]
    words, ty :: Term -> Type
    ty=Type
    ty} =
        SDoc -> m SDoc
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (SDoc -> m SDoc) -> SDoc -> m SDoc
    forall a b. (a -> b) -> a -> b
    $ TyCon -> [Word] -> SDoc
    repPrim ((() :: Constraint) => Type -> TyCon
    Type -> TyCon
    tyConAppTyCon Type
    ty) [Word]
    words
    ppr_termM1 Suspension{ty :: Term -> Type
    ty=Type
    ty, bound_to :: Term -> Maybe Name
    bound_to=Maybe Name
    Nothing} =
        SDoc -> m SDoc
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Char -> SDoc
    char Char
    '_' SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    whenPprDebug (SDoc
    dcolon SDoc -> SDoc -> SDoc
    <> Type -> SDoc
    pprSigmaType Type
    ty))
    ppr_termM1 Suspension{ty :: Term -> Type
    ty=Type
    ty, bound_to :: Term -> Maybe Name
    bound_to=Just Name
    n}
      | Bool
    otherwise = SDoc -> m SDoc
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return(SDoc -> m SDoc) -> SDoc -> m SDoc
    forall a b. (a -> b) -> a -> b
    $ SDoc -> SDoc
    parens(SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $ Name -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Name
    n SDoc -> SDoc -> SDoc
    <> SDoc
    dcolon SDoc -> SDoc -> SDoc
    <> Type -> SDoc
    pprSigmaType Type
    ty
    ppr_termM1 Term{}        = String -> m SDoc
    forall a. String -> a
    panic String
    "ppr_termM1 - Term"
    ppr_termM1 RefWrap{}     = String -> m SDoc
    forall a. String -> a
    panic String
    "ppr_termM1 - RefWrap"
    ppr_termM1 NewtypeWrap{} = String -> m SDoc
    forall a. String -> a
    panic String
    "ppr_termM1 - NewtypeWrap"

    pprNewtypeWrap :: forall (m :: * -> *). Monad m => TermPrinterM m -> TermPrinterM m
    pprNewtypeWrap TermPrinterM m
    y Int
    p NewtypeWrap{ty :: Term -> Type
    ty=Type
    ty, wrapped_term :: Term -> Term
    wrapped_term=Term
    t}
      | Just (TyCon
    tc,[Type]
    _) <- HasCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    tcSplitTyConApp_maybe Type
    ty
      , Bool -> Bool -> Bool
    forall a. HasCallStack => Bool -> a -> a
    assert (TyCon -> Bool
    isNewTyCon TyCon
    tc) Bool
    True
      , Just DataCon
    new_dc <- TyCon -> Maybe DataCon
    tyConSingleDataCon_maybe TyCon
    tc = do
                 SDoc
    real_term <- TermPrinterM m
    y Int
    max_prec Term
    t
                 SDoc -> m SDoc
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (SDoc -> m SDoc) -> SDoc -> m SDoc
    forall a b. (a -> b) -> a -> b
    $ Bool -> SDoc -> SDoc
    cparen (Int
    p Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    app_prec) (DataCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr DataCon
    new_dc SDoc -> SDoc -> SDoc
    <+> SDoc
    real_term)
    pprNewtypeWrap TermPrinterM m
    _ Int
    _ Term
    _ = String -> m SDoc
    forall a. String -> a
    panic String
    "pprNewtypeWrap"

    -------------------------------------------------------
    -- Custom Term Pretty Printers
    -------------------------------------------------------

    -- We can want to customize the representation of a
    --  term depending on its type.
    -- However, note that custom printers have to work with
    --  type representations, instead of directly with types.
    -- We cannot use type classes here, unless we employ some
    --  typerep trickery (e.g. Weirich's RepLib tricks),
    --  which I didn't. Therefore, this code replicates a lot
    --  of what type classes provide for free.

    type CustomTermPrinter m = TermPrinterM m
                             -> [Precedence -> Term -> (m (Maybe SDoc))]

    -- | Takes a list of custom printers with a explicit recursion knot and a term,
    -- and returns the output of the first successful printer, or the default printer
    cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
    cPprTerm :: forall (m :: * -> *).
    Monad m =>
    CustomTermPrinter m -> Term -> m SDoc
    cPprTerm CustomTermPrinter m
    printers_ = TermPrinterM m
    go Int
    0 where
      printers :: [Int -> Term -> m (Maybe SDoc)]
    printers = CustomTermPrinter m
    printers_ TermPrinterM m
    go
      go :: TermPrinterM m
    go Int
    prec Term
    t = do
        let default_ :: m (Maybe SDoc)
    default_ = SDoc -> Maybe SDoc
    forall a. a -> Maybe a
    Just (SDoc -> Maybe SDoc) -> m SDoc -> m (Maybe SDoc)
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    `liftM` TermPrinterM m -> TermPrinterM m
    forall (m :: * -> *). Monad m => TermPrinterM m -> TermPrinterM m
    pprTermM TermPrinterM m
    go Int
    prec Term
    t
            mb_customDocs :: [m (Maybe SDoc)]
    mb_customDocs = [Int -> Term -> m (Maybe SDoc)
    pp Int
    prec Term
    t | Int -> Term -> m (Maybe SDoc)
    pp <- [Int -> Term -> m (Maybe SDoc)]
    printers] [m (Maybe SDoc)] -> [m (Maybe SDoc)] -> [m (Maybe SDoc)]
    forall a. [a] -> [a] -> [a]
    ++ [m (Maybe SDoc)
    default_]
        Maybe SDoc
    mdoc <- [m (Maybe SDoc)] -> m (Maybe SDoc)
    forall {m :: * -> *} {a}. Monad m => [m (Maybe a)] -> m (Maybe a)
    firstJustM [m (Maybe SDoc)]
    mb_customDocs
        case Maybe SDoc
    mdoc of
          Maybe SDoc
    Nothing -> String -> m SDoc
    forall a. String -> a
    panic String
    "cPprTerm"
          Just SDoc
    doc -> SDoc -> m SDoc
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (SDoc -> m SDoc) -> SDoc -> m SDoc
    forall a b. (a -> b) -> a -> b
    $ Bool -> SDoc -> SDoc
    cparen (Int
    precInt -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >Int
    app_precInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1) SDoc
    doc

      firstJustM :: [m (Maybe a)] -> m (Maybe a)
    firstJustM (m (Maybe a)
    mb:[m (Maybe a)]
    mbs) = m (Maybe a)
    mb m (Maybe a) -> (Maybe a -> m (Maybe a)) -> m (Maybe a)
    forall a b. m a -> (a -> m b) -> m b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= m (Maybe a) -> (a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe ([m (Maybe a)] -> m (Maybe a)
    firstJustM [m (Maybe a)]
    mbs) (Maybe a -> m (Maybe a)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe a -> m (Maybe a)) -> (a -> Maybe a) -> a -> m (Maybe a)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> Maybe a
    forall a. a -> Maybe a
    Just)
      firstJustM [] = Maybe a -> m (Maybe a)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe a
    forall a. Maybe a
    Nothing

    -- Default set of custom printers. Note that the recursion knot is explicit
    cPprTermBase :: forall m. Monad m => CustomTermPrinter m
    cPprTermBase :: forall (m :: * -> *). Monad m => CustomTermPrinter m
    cPprTermBase TermPrinterM m
    y =
      [ (Term -> Bool) -> TermPrinterM m -> Int -> Term -> m (Maybe SDoc)
    ifTerm (Type -> Bool
    isTupleTy(Type -> Bool) -> (Term -> Type) -> Term -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .Term -> Type
    ty) (\Int
    _p -> ([SDoc] -> SDoc) -> m [SDoc] -> m SDoc
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM (SDoc -> SDoc
    parens (SDoc -> SDoc) -> ([SDoc] -> SDoc) -> [SDoc] -> SDoc
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [SDoc] -> SDoc
    hcat ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . SDoc -> [SDoc] -> [SDoc]
    punctuate SDoc
    comma)
                                          (m [SDoc] -> m SDoc) -> (Term -> m [SDoc]) -> Term -> m SDoc
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Term -> m SDoc) -> [Term] -> m [SDoc]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (TermPrinterM m
    y (-Int
    1))
                                          ([Term] -> m [SDoc]) -> (Term -> [Term]) -> Term -> m [SDoc]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Term -> [Term]
    subTerms)
      , (Term -> Bool) -> TermPrinterM m -> Int -> Term -> m (Maybe SDoc)
    ifTerm (\Term
    t -> TyCon -> Type -> Bool
    isTyCon TyCon
    listTyCon (Term -> Type
    ty Term
    t) Bool -> Bool -> Bool
    && Term -> [Term]
    subTerms Term
    t [Term] -> Int -> Bool
    forall a. [a] -> Int -> Bool
    `lengthIs` Int
    2)
               TermPrinterM m
    ppr_list
      , (Term -> Bool)
    -> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
    ifTerm' (TyCon -> Type -> Bool
    isTyCon TyCon
    intTyCon     (Type -> Bool) -> (Term -> Type) -> Term -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Term -> Type
    ty) Int -> Term -> m (Maybe SDoc)
    ppr_int
      , (Term -> Bool)
    -> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
    ifTerm' (TyCon -> Type -> Bool
    isTyCon TyCon
    charTyCon    (Type -> Bool) -> (Term -> Type) -> Term -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Term -> Type
    ty) Int -> Term -> m (Maybe SDoc)
    ppr_char
      , (Term -> Bool)
    -> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
    ifTerm' (TyCon -> Type -> Bool
    isTyCon TyCon
    floatTyCon   (Type -> Bool) -> (Term -> Type) -> Term -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Term -> Type
    ty) Int -> Term -> m (Maybe SDoc)
    ppr_float
      , (Term -> Bool)
    -> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
    ifTerm' (TyCon -> Type -> Bool
    isTyCon TyCon
    doubleTyCon  (Type -> Bool) -> (Term -> Type) -> Term -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Term -> Type
    ty) Int -> Term -> m (Maybe SDoc)
    ppr_double
      , (Term -> Bool)
    -> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
    ifTerm' (TyCon -> Type -> Bool
    isTyCon TyCon
    integerTyCon (Type -> Bool) -> (Term -> Type) -> Term -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Term -> Type
    ty) Int -> Term -> m (Maybe SDoc)
    ppr_integer
      , (Term -> Bool)
    -> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
    ifTerm' (TyCon -> Type -> Bool
    isTyCon TyCon
    naturalTyCon (Type -> Bool) -> (Term -> Type) -> Term -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Term -> Type
    ty) Int -> Term -> m (Maybe SDoc)
    ppr_natural
      ]
     where
       ifTerm :: (Term -> Bool)
              -> (Precedence -> Term -> m SDoc)
              -> Precedence -> Term -> m (Maybe SDoc)
       ifTerm :: (Term -> Bool) -> TermPrinterM m -> Int -> Term -> m (Maybe SDoc)
    ifTerm Term -> Bool
    pred TermPrinterM m
    f = (Term -> Bool)
    -> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
    ifTerm' Term -> Bool
    pred (\Int
    prec Term
    t -> SDoc -> Maybe SDoc
    forall a. a -> Maybe a
    Just (SDoc -> Maybe SDoc) -> m SDoc -> m (Maybe SDoc)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> TermPrinterM m
    f Int
    prec Term
    t)

       ifTerm' :: (Term -> Bool)
              -> (Precedence -> Term -> m (Maybe SDoc))
              -> Precedence -> Term -> m (Maybe SDoc)
       ifTerm' :: (Term -> Bool)
    -> (Int -> Term -> m (Maybe SDoc)) -> Int -> Term -> m (Maybe SDoc)
    ifTerm' Term -> Bool
    pred Int -> Term -> m (Maybe SDoc)
    f Int
    prec t :: Term
    t@Term{}
           | Term -> Bool
    pred Term
    t    = Int -> Term -> m (Maybe SDoc)
    f Int
    prec Term
    t
       ifTerm' Term -> Bool
    _ Int -> Term -> m (Maybe SDoc)
    _ Int
    _ Term
    _  = Maybe SDoc -> m (Maybe SDoc)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe SDoc
    forall a. Maybe a
    Nothing

       isTupleTy :: Type -> Bool
    isTupleTy Type
    ty    = Bool -> Maybe Bool -> Bool
    forall a. a -> Maybe a -> a
    fromMaybe Bool
    False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $ do
         (TyCon
    tc,[Type]
    _) <- HasCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    tcSplitTyConApp_maybe Type
    ty
         Bool -> Maybe Bool
    forall a. a -> Maybe a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TyCon -> Bool
    isBoxedTupleTyCon TyCon
    tc)

       isTyCon :: TyCon -> Type -> Bool
    isTyCon TyCon
    a_tc Type
    ty = Bool -> Maybe Bool -> Bool
    forall a. a -> Maybe a -> a
    fromMaybe Bool
    False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $ do
         (TyCon
    tc,[Type]
    _) <- HasCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    tcSplitTyConApp_maybe Type
    ty
         Bool -> Maybe Bool
    forall a. a -> Maybe a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TyCon
    a_tc TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    tc)

       ppr_int, ppr_char, ppr_float, ppr_double
          :: Precedence -> Term -> m (Maybe SDoc)
       ppr_int :: Int -> Term -> m (Maybe SDoc)
    ppr_int Int
    _ Term{subTerms :: Term -> [Term]
    subTerms=[Prim{valRaw :: Term -> [Word]
    valRaw=[Word
    w]}]} =
          Maybe SDoc -> m (Maybe SDoc)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (SDoc -> Maybe SDoc
    forall a. a -> Maybe a
    Just (Int -> SDoc
    Ppr.int (Word -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word
    w)))
       ppr_int Int
    _ Term
    _ = Maybe SDoc -> m (Maybe SDoc)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe SDoc
    forall a. Maybe a
    Nothing

       ppr_char :: Int -> Term -> m (Maybe SDoc)
    ppr_char Int
    _ Term{subTerms :: Term -> [Term]
    subTerms=[Prim{valRaw :: Term -> [Word]
    valRaw=[Word
    w]}]} =
          Maybe SDoc -> m (Maybe SDoc)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (SDoc -> Maybe SDoc
    forall a. a -> Maybe a
    Just (Char -> SDoc
    Ppr.pprHsChar (Int -> Char
    chr (Word -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word
    w))))
       ppr_char Int
    _ Term
    _ = Maybe SDoc -> m (Maybe SDoc)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe SDoc
    forall a. Maybe a
    Nothing

       ppr_float :: Int -> Term -> m (Maybe SDoc)
    ppr_float   Int
    _ Term{subTerms :: Term -> [Term]
    subTerms=[Prim{valRaw :: Term -> [Word]
    valRaw=[Word
    w]}]} = do
          let f :: Float
    f = IO Float -> Float
    forall a. IO a -> a
    unsafeDupablePerformIO (IO Float -> Float) -> IO Float -> Float
    forall a b. (a -> b) -> a -> b
    $
                    (Ptr Word -> IO Float) -> IO Float
    forall a b. Storable a => (Ptr a -> IO b) -> IO b
    alloca ((Ptr Word -> IO Float) -> IO Float)
    -> (Ptr Word -> IO Float) -> IO Float
    forall a b. (a -> b) -> a -> b
    $ \Ptr Word
    p -> Ptr Word -> Word -> IO ()
    forall a. Storable a => Ptr a -> a -> IO ()
    poke Ptr Word
    p Word
    w IO () -> IO Float -> IO Float
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Ptr Float -> IO Float
    forall a. Storable a => Ptr a -> IO a
    peek (Ptr Word -> Ptr Float
    forall a b. Ptr a -> Ptr b
    castPtr Ptr Word
    p)
          Maybe SDoc -> m (Maybe SDoc)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (SDoc -> Maybe SDoc
    forall a. a -> Maybe a
    Just (Float -> SDoc
    Ppr.float Float
    f))
       ppr_float Int
    _ Term
    _ = Maybe SDoc -> m (Maybe SDoc)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe SDoc
    forall a. Maybe a
    Nothing

       ppr_double :: Int -> Term -> m (Maybe SDoc)
    ppr_double  Int
    _ Term{subTerms :: Term -> [Term]
    subTerms=[Prim{valRaw :: Term -> [Word]
    valRaw=[Word
    w]}]} = do
          let f :: Double
    f = IO Double -> Double
    forall a. IO a -> a
    unsafeDupablePerformIO (IO Double -> Double) -> IO Double -> Double
    forall a b. (a -> b) -> a -> b
    $
                    (Ptr Word -> IO Double) -> IO Double
    forall a b. Storable a => (Ptr a -> IO b) -> IO b
    alloca ((Ptr Word -> IO Double) -> IO Double)
    -> (Ptr Word -> IO Double) -> IO Double
    forall a b. (a -> b) -> a -> b
    $ \Ptr Word
    p -> Ptr Word -> Word -> IO ()
    forall a. Storable a => Ptr a -> a -> IO ()
    poke Ptr Word
    p Word
    w IO () -> IO Double -> IO Double
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Ptr Double -> IO Double
    forall a. Storable a => Ptr a -> IO a
    peek (Ptr Word -> Ptr Double
    forall a b. Ptr a -> Ptr b
    castPtr Ptr Word
    p)
          Maybe SDoc -> m (Maybe SDoc)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (SDoc -> Maybe SDoc
    forall a. a -> Maybe a
    Just (Double -> SDoc
    Ppr.double Double
    f))
       -- let's assume that if we get two words, we're on a 32-bit
       -- machine. There's no good way to get a Platform to check the word
       -- size here.
       ppr_double  Int
    _ Term{subTerms :: Term -> [Term]
    subTerms=[Prim{valRaw :: Term -> [Word]
    valRaw=[Word
    w1,Word
    w2]}]} = do
          let f :: Double
    f = IO Double -> Double
    forall a. IO a -> a
    unsafeDupablePerformIO (IO Double -> Double) -> IO Double -> Double
    forall a b. (a -> b) -> a -> b
    $
                    (Ptr Word32 -> IO Double) -> IO Double
    forall a b. Storable a => (Ptr a -> IO b) -> IO b
    alloca ((Ptr Word32 -> IO Double) -> IO Double)
    -> (Ptr Word32 -> IO Double) -> IO Double
    forall a b. (a -> b) -> a -> b
    $ \Ptr Word32
    p -> do
                      Ptr Word32 -> Word32 -> IO ()
    forall a. Storable a => Ptr a -> a -> IO ()
    poke Ptr Word32
    p (Word -> Word32
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word
    w1 :: Word32)
                      Ptr Word32 -> Word32 -> IO ()
    forall a. Storable a => Ptr a -> a -> IO ()
    poke (Ptr Word32
    p Ptr Word32 -> Int -> Ptr Word32
    forall a b. Ptr a -> Int -> Ptr b
    `plusPtr` Int
    4) (Word -> Word32
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word
    w2 :: Word32)
                      Ptr Double -> IO Double
    forall a. Storable a => Ptr a -> IO a
    peek (Ptr Word32 -> Ptr Double
    forall a b. Ptr a -> Ptr b
    castPtr Ptr Word32
    p)
          Maybe SDoc -> m (Maybe SDoc)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (SDoc -> Maybe SDoc
    forall a. a -> Maybe a
    Just (Double -> SDoc
    Ppr.double Double
    f))
       ppr_double Int
    _ Term
    _ = Maybe SDoc -> m (Maybe SDoc)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe SDoc
    forall a. Maybe a
    Nothing

       ppr_bignat :: Bool -> Precedence -> [Word] -> m (Maybe SDoc)
       ppr_bignat :: Bool -> Int -> [Word] -> m (Maybe SDoc)
    ppr_bignat Bool
    sign Int
    _ [Word]
    ws = do
          let
             wordSize :: Int
    wordSize = Word -> Int
    forall b. FiniteBits b => b -> Int
    finiteBitSize (Word
    0 :: Word) -- does the word size depend on the target?
             makeInteger :: t -> Int -> [a] -> t
    makeInteger t
    n Int
    _ []     = t
    n
             makeInteger t
    n Int
    s (a
    x:[a]
    xs) = t -> Int -> [a] -> t
    makeInteger (t
    n t -> t -> t
    forall a. Num a => a -> a -> a
    + (a -> t
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral a
    x t -> Int -> t
    forall a. Bits a => a -> Int -> a
    `shiftL` Int
    s)) (Int
    s Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    wordSize) [a]
    xs
             signf :: Integer
    signf = case Bool
    sign of
                      Bool
    False -> Integer
    1
                      Bool
    True  -> -Integer
    1
          Maybe SDoc -> m (Maybe SDoc)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe SDoc -> m (Maybe SDoc)) -> Maybe SDoc -> m (Maybe SDoc)
    forall a b. (a -> b) -> a -> b
    $ SDoc -> Maybe SDoc
    forall a. a -> Maybe a
    Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
    forall a b. (a -> b) -> a -> b
    $ Integer -> SDoc
    Ppr.integer (Integer -> SDoc) -> Integer -> SDoc
    forall a b. (a -> b) -> a -> b
    $ Integer
    signf Integer -> Integer -> Integer
    forall a. Num a => a -> a -> a
    * (Integer -> Int -> [Word] -> Integer
    forall {t} {a}. (Bits t, Integral a, Num t) => t -> Int -> [a] -> t
    makeInteger Integer
    0 Int
    0 [Word]
    ws)

       -- Reconstructing Bignums is a bit of a pain. This depends deeply on their
       -- representation, so it'll break if that changes (but there are several
       -- tests in tests/ghci.debugger/scripts that will tell us if this is wrong).
       --
       --   data Integer
       --     = IS !Int#
       --     | IP !BigNat
       --     | IN !BigNat
       --
       --   data Natural
       --     = NS !Word#
       --     | NB !BigNat
       --
       --   type BigNat = ByteArray#

       ppr_integer :: Precedence -> Term -> m (Maybe SDoc)
       ppr_integer :: Int -> Term -> m (Maybe SDoc)
    ppr_integer Int
    _ Term{dc :: Term -> Either String DataCon
    dc=Right DataCon
    con, subTerms :: Term -> [Term]
    subTerms=[Prim{valRaw :: Term -> [Word]
    valRaw=[Word]
    ws}]}
          | DataCon
    con DataCon -> DataCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == DataCon
    integerISDataCon
          , [W# Word#
    w] <- [Word]
    ws
          = Maybe SDoc -> m (Maybe SDoc)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (SDoc -> Maybe SDoc
    forall a. a -> Maybe a
    Just (Integer -> SDoc
    Ppr.integer (Int -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Int# -> Int
    I# (Word# -> Int#
    word2Int# Word#
    w)))))
       ppr_integer Int
    p Term{dc :: Term -> Either String DataCon
    dc=Right DataCon
    con, subTerms :: Term -> [Term]
    subTerms=[Term{subTerms :: Term -> [Term]
    subTerms=[Prim{valRaw :: Term -> [Word]
    valRaw=[Word]
    ws}]}]}
          | DataCon
    con DataCon -> DataCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == DataCon
    integerIPDataCon = Bool -> Int -> [Word] -> m (Maybe SDoc)
    ppr_bignat Bool
    False Int
    p [Word]
    ws
          | DataCon
    con DataCon -> DataCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == DataCon
    integerINDataCon = Bool -> Int -> [Word] -> m (Maybe SDoc)
    ppr_bignat Bool
    True  Int
    p [Word]
    ws
          | Bool
    otherwise = String -> m (Maybe SDoc)
    forall a. String -> a
    panic String
    "Unexpected Integer constructor"
       ppr_integer Int
    _ Term
    _ = Maybe SDoc -> m (Maybe SDoc)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe SDoc
    forall a. Maybe a
    Nothing

       ppr_natural :: Precedence -> Term -> m (Maybe SDoc)
       ppr_natural :: Int -> Term -> m (Maybe SDoc)
    ppr_natural Int
    _ Term{dc :: Term -> Either String DataCon
    dc=Right DataCon
    con, subTerms :: Term -> [Term]
    subTerms=[Prim{valRaw :: Term -> [Word]
    valRaw=[Word]
    ws}]}
          | DataCon
    con DataCon -> DataCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == DataCon
    naturalNSDataCon
          , [Word
    w] <- [Word]
    ws
          = Maybe SDoc -> m (Maybe SDoc)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (SDoc -> Maybe SDoc
    forall a. a -> Maybe a
    Just (Integer -> SDoc
    Ppr.integer (Word -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word
    w)))
       ppr_natural Int
    p Term{dc :: Term -> Either String DataCon
    dc=Right DataCon
    con, subTerms :: Term -> [Term]
    subTerms=[Term{subTerms :: Term -> [Term]
    subTerms=[Prim{valRaw :: Term -> [Word]
    valRaw=[Word]
    ws}]}]}
          | DataCon
    con DataCon -> DataCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == DataCon
    naturalNBDataCon = Bool -> Int -> [Word] -> m (Maybe SDoc)
    ppr_bignat Bool
    False Int
    p [Word]
    ws
          | Bool
    otherwise = String -> m (Maybe SDoc)
    forall a. String -> a
    panic String
    "Unexpected Natural constructor"
       ppr_natural Int
    _ Term
    _ = Maybe SDoc -> m (Maybe SDoc)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe SDoc
    forall a. Maybe a
    Nothing

       --Note pprinting of list terms is not lazy
       ppr_list :: Precedence -> Term -> m SDoc
       ppr_list :: TermPrinterM m
    ppr_list Int
    p (Term{subTerms :: Term -> [Term]
    subTerms=[Term
    h,Term
    t]}) = do
           let elems :: [Term]
    elems      = Term
    h Term -> [Term] -> [Term]
    forall a. a -> [a] -> [a]
    : Term -> [Term]
    getListTerms Term
    t
               isConsLast :: Bool
    isConsLast = Bool -> Bool
    not (Term -> Type
    termType ([Term] -> Term
    forall a. HasCallStack => [a] -> a
    last [Term]
    elems) Type -> Type -> Bool
    `eqType` Term -> Type
    termType Term
    h)
               is_string :: Bool
    is_string  = (Term -> Bool) -> [Term] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (Type -> Bool
    isCharTy (Type -> Bool) -> (Term -> Type) -> Term -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Term -> Type
    ty) [Term]
    elems
               chars :: String
    chars = [ Int -> Char
    chr (Word -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word
    w)
                       | Term{subTerms :: Term -> [Term]
    subTerms=[Prim{valRaw :: Term -> [Word]
    valRaw=[Word
    w]}]} <- [Term]
    elems ]

           [SDoc]
    print_elems <- (Term -> m SDoc) -> [Term] -> m [SDoc]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (TermPrinterM m
    y Int
    cons_prec) [Term]
    elems
           if Bool
    is_string
            then SDoc -> m SDoc
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (SDoc -> SDoc
    Ppr.doubleQuotes (String -> SDoc
    Ppr.text String
    chars))
            else if Bool
    isConsLast
            then SDoc -> m SDoc
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (SDoc -> m SDoc) -> SDoc -> m SDoc
    forall a b. (a -> b) -> a -> b
    $ Bool -> SDoc -> SDoc
    cparen (Int
    p Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    cons_prec)
                        (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $ ([SDoc] -> SDoc) -> [SDoc] -> SDoc
    pprDeeperList [SDoc] -> SDoc
    fsep
                        ([SDoc] -> SDoc) -> [SDoc] -> SDoc
    forall a b. (a -> b) -> a -> b
    $ SDoc -> [SDoc] -> [SDoc]
    punctuate (SDoc
    spaceSDoc -> SDoc -> SDoc
    <>SDoc
    colon) [SDoc]
    print_elems
            else SDoc -> m SDoc
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (SDoc -> m SDoc) -> SDoc -> m SDoc
    forall a b. (a -> b) -> a -> b
    $ SDoc -> SDoc
    brackets
                        (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $ ([SDoc] -> SDoc) -> [SDoc] -> SDoc
    pprDeeperList [SDoc] -> SDoc
    fcat
                        ([SDoc] -> SDoc) -> [SDoc] -> SDoc
    forall a b. (a -> b) -> a -> b
    $ SDoc -> [SDoc] -> [SDoc]
    punctuate SDoc
    comma [SDoc]
    print_elems

            where getListTerms :: Term -> [Term]
    getListTerms Term{subTerms :: Term -> [Term]
    subTerms=[Term
    h,Term
    t]} = Term
    h Term -> [Term] -> [Term]
    forall a. a -> [a] -> [a]
    : Term -> [Term]
    getListTerms Term
    t
                  getListTerms Term{subTerms :: Term -> [Term]
    subTerms=[]}    = []
                  getListTerms t :: Term
    t@Suspension{}       = [Term
    t]
                  getListTerms Term
    t = String -> SDoc -> [Term]
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "getListTerms" (Term -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Term
    t)
       ppr_list Int
    _ Term
    _ = String -> m SDoc
    forall a. String -> a
    panic String
    "doList"

    repPrim :: TyCon -> [Word] -> SDoc
    repPrim :: TyCon -> [Word] -> SDoc
    repPrim TyCon
    t = [Word] -> SDoc
    rep where
       rep :: [Word] -> SDoc
    rep [Word]
    x
        -- Char# uses native machine words, whereas Char's Storable instance uses
        -- Int32, so we have to read it as an Int.
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    charPrimTyCon             = String -> SDoc
    text (String -> SDoc) -> String -> SDoc
    forall a b. (a -> b) -> a -> b
    $ Char -> String
    forall a. Show a => a -> String
    show (Int -> Char
    chr ([Word] -> Int
    forall {a} {a}. (Storable a, Storable a) => [a] -> a
    build [Word]
    x :: Int))
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    intPrimTyCon              = String -> SDoc
    text (String -> SDoc) -> String -> SDoc
    forall a b. (a -> b) -> a -> b
    $ Int -> String
    forall a. Show a => a -> String
    show ([Word] -> Int
    forall {a} {a}. (Storable a, Storable a) => [a] -> a
    build [Word]
    x :: Int)
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    wordPrimTyCon             = String -> SDoc
    text (String -> SDoc) -> String -> SDoc
    forall a b. (a -> b) -> a -> b
    $ Word -> String
    forall a. Show a => a -> String
    show ([Word] -> Word
    forall {a} {a}. (Storable a, Storable a) => [a] -> a
    build [Word]
    x :: Word)
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    floatPrimTyCon            = String -> SDoc
    text (String -> SDoc) -> String -> SDoc
    forall a b. (a -> b) -> a -> b
    $ Float -> String
    forall a. Show a => a -> String
    show ([Word] -> Float
    forall {a} {a}. (Storable a, Storable a) => [a] -> a
    build [Word]
    x :: Float)
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    doublePrimTyCon           = String -> SDoc
    text (String -> SDoc) -> String -> SDoc
    forall a b. (a -> b) -> a -> b
    $ Double -> String
    forall a. Show a => a -> String
    show ([Word] -> Double
    forall {a} {a}. (Storable a, Storable a) => [a] -> a
    build [Word]
    x :: Double)
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    int8PrimTyCon             = String -> SDoc
    text (String -> SDoc) -> String -> SDoc
    forall a b. (a -> b) -> a -> b
    $ Int8 -> String
    forall a. Show a => a -> String
    show ([Word] -> Int8
    forall {a} {a}. (Storable a, Storable a) => [a] -> a
    build [Word]
    x :: Int8)
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    word8PrimTyCon            = String -> SDoc
    text (String -> SDoc) -> String -> SDoc
    forall a b. (a -> b) -> a -> b
    $ Word8 -> String
    forall a. Show a => a -> String
    show ([Word] -> Word8
    forall {a} {a}. (Storable a, Storable a) => [a] -> a
    build [Word]
    x :: Word8)
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    int16PrimTyCon            = String -> SDoc
    text (String -> SDoc) -> String -> SDoc
    forall a b. (a -> b) -> a -> b
    $ Int16 -> String
    forall a. Show a => a -> String
    show ([Word] -> Int16
    forall {a} {a}. (Storable a, Storable a) => [a] -> a
    build [Word]
    x :: Int16)
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    word16PrimTyCon           = String -> SDoc
    text (String -> SDoc) -> String -> SDoc
    forall a b. (a -> b) -> a -> b
    $ Word16 -> String
    forall a. Show a => a -> String
    show ([Word] -> Word16
    forall {a} {a}. (Storable a, Storable a) => [a] -> a
    build [Word]
    x :: Word16)
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    int32PrimTyCon            = String -> SDoc
    text (String -> SDoc) -> String -> SDoc
    forall a b. (a -> b) -> a -> b
    $ Int32 -> String
    forall a. Show a => a -> String
    show ([Word] -> Int32
    forall {a} {a}. (Storable a, Storable a) => [a] -> a
    build [Word]
    x :: Int32)
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    word32PrimTyCon           = String -> SDoc
    text (String -> SDoc) -> String -> SDoc
    forall a b. (a -> b) -> a -> b
    $ Word32 -> String
    forall a. Show a => a -> String
    show ([Word] -> Word32
    forall {a} {a}. (Storable a, Storable a) => [a] -> a
    build [Word]
    x :: Word32)
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    int64PrimTyCon            = String -> SDoc
    text (String -> SDoc) -> String -> SDoc
    forall a b. (a -> b) -> a -> b
    $ Int64 -> String
    forall a. Show a => a -> String
    show ([Word] -> Int64
    forall {a} {a}. (Storable a, Storable a) => [a] -> a
    build [Word]
    x :: Int64)
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    word64PrimTyCon           = String -> SDoc
    text (String -> SDoc) -> String -> SDoc
    forall a b. (a -> b) -> a -> b
    $ Word64 -> String
    forall a. Show a => a -> String
    show ([Word] -> Word64
    forall {a} {a}. (Storable a, Storable a) => [a] -> a
    build [Word]
    x :: Word64)
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    addrPrimTyCon             = String -> SDoc
    text (String -> SDoc) -> String -> SDoc
    forall a b. (a -> b) -> a -> b
    $ Ptr Any -> String
    forall a. Show a => a -> String
    show (Ptr Any
    forall a. Ptr a
    nullPtr Ptr Any -> Int -> Ptr Any
    forall a b. Ptr a -> Int -> Ptr b
    `plusPtr` [Word] -> Int
    forall {a} {a}. (Storable a, Storable a) => [a] -> a
    build [Word]
    x)
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    stablePtrPrimTyCon        = String -> SDoc
    text String
    "<stablePtr>"
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    stableNamePrimTyCon       = String -> SDoc
    text String
    "<stableName>"
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    statePrimTyCon            = String -> SDoc
    text String
    "<statethread>"
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    proxyPrimTyCon            = String -> SDoc
    text String
    "<proxy>"
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    realWorldTyCon            = String -> SDoc
    text String
    "<realworld>"
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    threadIdPrimTyCon         = String -> SDoc
    text String
    "<ThreadId>"
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    weakPrimTyCon             = String -> SDoc
    text String
    "<Weak>"
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    arrayPrimTyCon            = String -> SDoc
    text String
    "<array>"
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    smallArrayPrimTyCon       = String -> SDoc
    text String
    "<smallArray>"
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    byteArrayPrimTyCon        = String -> SDoc
    text String
    "<bytearray>"
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    mutableArrayPrimTyCon     = String -> SDoc
    text String
    "<mutableArray>"
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    smallMutableArrayPrimTyCon = String -> SDoc
    text String
    "<smallMutableArray>"
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    mutableByteArrayPrimTyCon = String -> SDoc
    text String
    "<mutableByteArray>"
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    mutVarPrimTyCon           = String -> SDoc
    text String
    "<mutVar>"
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    mVarPrimTyCon             = String -> SDoc
    text String
    "<mVar>"
        | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    tVarPrimTyCon             = String -> SDoc
    text String
    "<tVar>"
        | Bool
    otherwise                      = Char -> SDoc
    char Char
    '<' SDoc -> SDoc -> SDoc
    <> TyCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TyCon
    t SDoc -> SDoc -> SDoc
    <> Char -> SDoc
    char Char
    '>'
        where build :: [a] -> a
    build [a]
    ww = IO a -> a
    forall a. IO a -> a
    unsafePerformIO (IO a -> a) -> IO a -> a
    forall a b. (a -> b) -> a -> b
    $ [a] -> (Ptr a -> IO a) -> IO a
    forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
    withArray [a]
    ww (Ptr a -> IO a
    forall a. Storable a => Ptr a -> IO a
    peek (Ptr a -> IO a) -> (Ptr a -> Ptr a) -> Ptr a -> IO a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Ptr a -> Ptr a
    forall a b. Ptr a -> Ptr b
    castPtr)
    --   This ^^^ relies on the representation of Haskell heap values being
    --   the same as in a C array.

    -----------------------------------
    -- Type Reconstruction
    -----------------------------------
    {-
    Type Reconstruction is type inference done on heap closures.
    The algorithm walks the heap generating a set of equations, which
    are solved with syntactic unification.
    A type reconstruction equation looks like:

      <datacon reptype>  =  <actual heap contents>

    The full equation set is generated by traversing all the subterms, starting
    from a given term.

    The only difficult part is that newtypes are only found in the lhs of equations.
    Right hand sides are missing them. We can either (a) drop them from the lhs, or
    (b) reconstruct them in the rhs when possible.

    The function congruenceNewtypes takes a shot at (b)
    -}

    -- See Note [RttiType]
    type RttiType = Type

    -- An incomplete type as stored in GHCi:
    --  no polymorphism: no quantifiers & all tyvars are skolem.
    type GhciType = Type

    -- The Type Reconstruction monad
    --------------------------------
    type TR a = TcM a

    runTR :: HscEnv -> TR a -> IO a
    runTR :: forall a. HscEnv -> TR a -> IO a
    runTR HscEnv
    hsc_env TR a
    thing = do
      Maybe a
    mb_val <- HscEnv -> TR a -> IO (Maybe a)
    forall a. HscEnv -> TR a -> IO (Maybe a)
    runTR_maybe HscEnv
    hsc_env TR a
    thing
      case Maybe a
    mb_val of
        Maybe a
    Nothing -> String -> IO a
    forall a. HasCallStack => String -> a
    error String
    "unable to :print the term"
        Just a
    x  -> a -> IO a
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return a
    x

    runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
    runTR_maybe :: forall a. HscEnv -> TR a -> IO (Maybe a)
    runTR_maybe HscEnv
    hsc_env TR a
    thing_inside
      = do { (Messages TcRnMessage
    _errs, Maybe a
    res) <- HscEnv -> TR a -> IO (Messages TcRnMessage, Maybe a)
    forall a. HscEnv -> TcM a -> IO (Messages TcRnMessage, Maybe a)
    initTcInteractive HscEnv
    hsc_env TR a
    thing_inside
           ; Maybe a -> IO (Maybe a)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe a
    res }

    -- | Term Reconstruction trace
    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

    -- Semantically different to recoverM in GHC.Tc.Utils.Monad
    -- recoverM retains the errors in the first action,
    --  whereas recoverTc here does not
    recoverTR :: TR a -> TR a -> TR a
    recoverTR :: forall a. TR a -> TR a -> TR a
    recoverTR = TcM a -> TcM a -> TcM a
    forall a. TR a -> TR a -> TR a
    tryTcDiscardingErrs

    trIO :: IO a -> TR a
    trIO :: forall a. IO a -> TR a
    trIO = TcM a -> TcM a
    forall a. TcM a -> TcM a
    liftTcM (TcM a -> TcM a) -> (IO a -> TcM a) -> IO a -> TcM a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . IO a -> TcM a
    forall a. IO a -> TR a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO

    liftTcM :: TcM a -> TR a
    liftTcM :: forall a. TcM a -> TcM a
    liftTcM = TcM a -> TcM a
    forall a. a -> a
    id

    -- When we make new unification variables in the GHCi debugger,
    -- we use RuntimeUnkTvs.   See Note [RuntimeUnkTv].
    newVar :: Kind -> TR TcType
    newVar :: Type -> TR Type
    newVar Type
    kind = TR Type -> TR Type
    forall a. TcM a -> TcM a
    liftTcM (do { TyVar
    tv <- MetaInfo -> Type -> TcM TyVar
    newAnonMetaTyVar MetaInfo
    RuntimeUnkTv Type
    kind
                              ; Type -> TR Type
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TyVar -> Type
    mkTyVarTy TyVar
    tv) })

    newOpenVar :: TR TcType
    newOpenVar :: TR Type
    newOpenVar = TR Type -> TR Type
    forall a. TcM a -> TcM a
    liftTcM (do { Type
    kind <- TR Type
    newOpenTypeKind
                             ; Type -> TR Type
    newVar Type
    kind })

    {- Note [RttiType]
    ~~~~~~~~~~~~~~~~~~
    The type synonym `type RttiType = Type` is the type synonym used
    by the debugger for the types of the data type `Term`.

    For a long time the `RttiType` carried the following comment:

    >     A (non-mutable) tau type containing
    >     existentially quantified tyvars.
    >          (since GHC type language currently does not support
    >          existentials, we leave these variables unquantified)

    The tau type part is only correct for terms representing the results
    of fully saturated functions that return non-function (data) values
    and not functions.

    For non-function values, the GHC runtime always works with concrete
    types eg `[Maybe Int]`, but never with polymorphic types like eg
    `(Traversable t, Monad m) => t (m a)`. The concrete types, don't
    need a quantification. They are always tau types.

    The debugger binds the terms of :print commands and of the free
    variables at a breakpoint to names. These newly bound names can
    be used in new GHCi expressions. If these names represent functions,
    then the type checker expects that the types of these functions are
    fully-fledged. They must contain the necessary `forall`s and type
    constraints. Hence the types of terms that represent functions must
    be sigmas and not taus.
    (See #12449)
    -}

    {- Note [RuntimeUnkTv]
    ~~~~~~~~~~~~~~~~~~~~~~
    In the GHCi debugger we use unification variables whose MetaInfo is
    RuntimeUnkTv.  The special property of a RuntimeUnkTv is that it can
    unify with a polytype (see GHC.Tc.Utils.Unify.checkTypeEq).
    If we don't do this `:print <term>` will fail if the type of <term>
    has nested `forall`s or `=>`s.

    This is because the GHCi debugger's internals will attempt to unify a
    metavariable with the type of <term> and then display the result, but
    if the type has nested `forall`s or `=>`s, then unification will fail
    unless we do something special.  As a result, `:print` will bail out
    and the unhelpful result will be `<term> = (_t1::t1)` (where `t1` is a
    metavariable).

    Beware: <term> can have nested `forall`s even if its definition doesn't use
    RankNTypes! Here is an example from #14828:

      class Functor f where
        fmap :: (a -> b) -> f a -> f b

    Somewhat surprisingly, `:print fmap` considers the type of fmap to have
    nested foralls. This is because the GHCi debugger sees the type
    `fmap :: forall f. Functor f => forall a b. (a -> b) -> f a -> f b`.
    We could envision deeply instantiating this type to get the type
    `forall f a b. Functor f => (a -> b) -> f a -> f b`,
    but this trick wouldn't work for higher-rank types.

    Instead, we adopt a simpler fix: allow RuntimeUnkTv to unify with a
    polytype (specifically, see ghci_tv in GHC.Tc.Utils.Unify.preCheck).
    This allows metavariables to unify with types that have
    nested (or higher-rank) `forall`s/`=>`s, which makes `:print fmap`
    display as
    `fmap = (_t1::forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b)`,
    as expected.
    -}

    instTyVars :: [TyVar] -> TR (TCvSubst, [TcTyVar])
    -- Instantiate fresh mutable type variables from some TyVars
    -- This function preserves the print-name, which helps error messages
    instTyVars :: [TyVar] -> TR (TCvSubst, [TyVar])
    instTyVars [TyVar]
    tvs
      = TR (TCvSubst, [TyVar]) -> TR (TCvSubst, [TyVar])
    forall a. TcM a -> TcM a
    liftTcM (TR (TCvSubst, [TyVar]) -> TR (TCvSubst, [TyVar]))
    -> TR (TCvSubst, [TyVar]) -> TR (TCvSubst, [TyVar])
    forall a b. (a -> b) -> a -> b
    $ ((TCvSubst, [TyVar]), WantedConstraints) -> (TCvSubst, [TyVar])
    forall a b. (a, b) -> a
    fst (((TCvSubst, [TyVar]), WantedConstraints) -> (TCvSubst, [TyVar]))
    -> IOEnv
         (Env TcGblEnv TcLclEnv) ((TCvSubst, [TyVar]), WantedConstraints)
    -> TR (TCvSubst, [TyVar])
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> TR (TCvSubst, [TyVar])
    -> IOEnv
         (Env TcGblEnv TcLclEnv) ((TCvSubst, [TyVar]), WantedConstraints)
    forall a. TcM a -> TcM (a, WantedConstraints)
    captureConstraints ([TyVar] -> TR (TCvSubst, [TyVar])
    newMetaTyVars [TyVar]
    tvs)

    type RttiInstantiation = [(TcTyVar, TyVar)]
       -- Associates the typechecker-world meta type variables
       -- (which are mutable and may be refined), to their
       -- debugger-world RuntimeUnk counterparts.
       -- If the TcTyVar has not been refined by the runtime type
       -- elaboration, then we want to turn it back into the
       -- original RuntimeUnk
       --
       -- July 20: I'm not convinced that the little dance from
       -- RuntimeUnkTv unification variables to RuntimeUnk skolems
       -- is buying us anything.  ToDo: get rid of it.

    -- | Returns the instantiated type scheme ty', and the
    --   mapping from new (instantiated) -to- old (skolem) type variables
    instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation)
    instScheme :: QuantifiedType -> TR (Type, RttiInstantiation)
    instScheme ([TyVar]
    tvs, Type
    ty)
      = do { (TCvSubst
    subst, [TyVar]
    tvs') <- [TyVar] -> TR (TCvSubst, [TyVar])
    instTyVars [TyVar]
    tvs
           ; let rtti_inst :: RttiInstantiation
    rtti_inst = [(TyVar
    tv',TyVar
    tv) | (TyVar
    tv',TyVar
    tv) <- [TyVar]
    tvs' [TyVar] -> [TyVar] -> RttiInstantiation
    forall a b. [a] -> [b] -> [(a, b)]
    `zip` [TyVar]
    tvs]
           ; SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "instScheme" SDoc -> SDoc -> SDoc
    <+> ([TyVar] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [TyVar]
    tvs SDoc -> SDoc -> SDoc
    $$ Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    ty SDoc -> SDoc -> SDoc
    $$ [TyVar] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [TyVar]
    tvs'))
           ; (Type, RttiInstantiation) -> TR (Type, RttiInstantiation)
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ((() :: Constraint) => TCvSubst -> Type -> Type
    TCvSubst -> Type -> Type
    substTy TCvSubst
    subst Type
    ty, RttiInstantiation
    rtti_inst) }

    applyRevSubst :: RttiInstantiation -> TR ()
    -- Apply the *reverse* substitution in-place to any un-filled-in
    -- meta tyvars.  This recovers the original debugger-world variable
    -- unless it has been refined by new information from the heap
    applyRevSubst :: RttiInstantiation -> TR ()
    applyRevSubst RttiInstantiation
    pairs = TR () -> TR ()
    forall a. TcM a -> TcM a
    liftTcM (((TyVar, TyVar) -> TR ()) -> RttiInstantiation -> TR ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (TyVar, TyVar) -> TR ()
    do_pair RttiInstantiation
    pairs)
      where
        do_pair :: (TyVar, TyVar) -> TR ()
    do_pair (TyVar
    tc_tv, TyVar
    rtti_tv)
          = do { Type
    tc_ty <- TyVar -> TR Type
    zonkTcTyVar TyVar
    tc_tv
               ; case Type -> Maybe TyVar
    tcGetTyVar_maybe Type
    tc_ty of
                   Just TyVar
    tv | TyVar -> Bool
    isMetaTyVar TyVar
    tv -> TyVar -> Type -> TR ()
    writeMetaTyVar TyVar
    tv (TyVar -> Type
    mkTyVarTy TyVar
    rtti_tv)
                   Maybe TyVar
    _                        -> () -> TR ()
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return () }

    -- Adds a constraint of the form t1 == t2
    -- t1 is expected to come from walking the heap
    -- t2 is expected to come from a datacon signature
    -- Before unification, congruenceNewtypes needs to
    -- do its magic.
    addConstraint :: TcType -> TcType -> TR ()
    addConstraint :: Type -> Type -> TR ()
    addConstraint Type
    actual Type
    expected = do
        SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "add constraint:" SDoc -> SDoc -> SDoc
    <+> [SDoc] -> SDoc
    fsep [Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    actual, SDoc
    equals, Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    expected])
        TR () -> TR () -> TR ()
    forall a. TR a -> TR a -> TR a
    recoverTR (SDoc -> TR ()
    traceTR (SDoc -> TR ()) -> SDoc -> TR ()
    forall a b. (a -> b) -> a -> b
    $ [SDoc] -> SDoc
    fsep [String -> SDoc
    text String
    "Failed to unify", Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    actual,
                                        String -> SDoc
    text String
    "with", Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    expected]) (TR () -> TR ()) -> TR () -> TR ()
    forall a b. (a -> b) -> a -> b
    $
          TcM (TcCoercionN, WantedConstraints) -> TR ()
    forall a. TcM a -> TR ()
    discardResult (TcM (TcCoercionN, WantedConstraints) -> TR ())
    -> TcM (TcCoercionN, WantedConstraints) -> TR ()
    forall a b. (a -> b) -> a -> b
    $
          TcM TcCoercionN -> TcM (TcCoercionN, WantedConstraints)
    forall a. TcM a -> TcM (a, WantedConstraints)
    captureConstraints (TcM TcCoercionN -> TcM (TcCoercionN, WantedConstraints))
    -> TcM TcCoercionN -> TcM (TcCoercionN, WantedConstraints)
    forall a b. (a -> b) -> a -> b
    $
          do { (Type
    ty1, Type
    ty2) <- Type -> Type -> TR (Type, Type)
    congruenceNewtypes Type
    actual Type
    expected
             ; Maybe TypedThing -> Type -> Type -> TcM TcCoercionN
    unifyType Maybe TypedThing
    forall a. Maybe a
    Nothing Type
    ty1 Type
    ty2 }
         -- TOMDO: what about the coercion?
         -- we should consider family instances

    -- | Term reconstruction
    --
    -- Given a pointer to a heap object (`HValue`) and its type, build a `Term`
    -- representation of the object. Subterms (objects in the payload) are also
    -- built up to the given `max_depth`. After `max_depth` any subterms will appear
    -- as `Suspension`s. Any thunks found while traversing the object will be forced
    -- based on `force` parameter.
    --
    -- Types of terms will be refined based on constructors we find during term
    -- reconstruction. See `cvReconstructType` for an overview of how type
    -- reconstruction works.
    --
    cvObtainTerm
        :: HscEnv
        -> Int      -- ^ How many times to recurse for subterms
        -> Bool     -- ^ Force thunks
        -> RttiType -- ^ Type of the object to reconstruct
        -> ForeignHValue   -- ^ Object to reconstruct
        -> IO Term
    cvObtainTerm :: HscEnv -> Int -> Bool -> Type -> ForeignHValue -> IO Term
    cvObtainTerm HscEnv
    hsc_env Int
    max_depth Bool
    force Type
    old_ty ForeignHValue
    hval = HscEnv -> TR Term -> IO Term
    forall a. HscEnv -> TR a -> IO a
    runTR HscEnv
    hsc_env (TR Term -> IO Term) -> TR Term -> IO Term
    forall a b. (a -> b) -> a -> b
    $ do
      -- we quantify existential tyvars as universal,
      -- as this is needed to be able to manipulate
      -- them properly
       let quant_old_ty :: QuantifiedType
    quant_old_ty@([TyVar]
    old_tvs, Type
    _) = Type -> QuantifiedType
    quantifyType Type
    old_ty
       SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "Term reconstruction started with initial type " SDoc -> SDoc -> SDoc
    <> Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    old_ty)
       Term
    term <-
         if [TyVar] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [TyVar]
    old_tvs
          then do
            Term
    term  <- Int -> Type -> Type -> ForeignHValue -> TR Term
    go Int
    max_depth Type
    old_ty Type
    old_ty ForeignHValue
    hval
            Term
    term' <- Term -> TR Term
    zonkTerm Term
    term
            Term -> TR Term
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Term -> TR Term) -> Term -> TR Term
    forall a b. (a -> b) -> a -> b
    $ Term -> Term
    fixFunDictionaries (Term -> Term) -> Term -> Term
    forall a b. (a -> b) -> a -> b
    $ Term -> Term
    expandNewtypes Term
    term'
          else do
                  (Type
    old_ty', RttiInstantiation
    rev_subst) <- QuantifiedType -> TR (Type, RttiInstantiation)
    instScheme QuantifiedType
    quant_old_ty
                  Type
    my_ty <- TR Type
    newOpenVar
                  Bool -> TR () -> TR ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when ([TyVar] -> Bool
    check1 [TyVar]
    old_tvs) (SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "check1 passed") TR () -> TR () -> TR ()
    forall a b.
    IOEnv (Env TcGblEnv TcLclEnv) a
    -> IOEnv (Env TcGblEnv TcLclEnv) b
    -> IOEnv (Env TcGblEnv TcLclEnv) b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >>
                                              Type -> Type -> TR ()
    addConstraint Type
    my_ty Type
    old_ty')
                  Term
    term  <- Int -> Type -> Type -> ForeignHValue -> TR Term
    go Int
    max_depth Type
    my_ty Type
    old_ty ForeignHValue
    hval
                  Type
    new_ty <- Type -> TR Type
    zonkTcType (Term -> Type
    termType Term
    term)
                  if Type -> Bool
    isMonomorphic Type
    new_ty Bool -> Bool -> Bool
    || Type -> Type -> Bool
    check2 Type
    new_ty Type
    old_ty
                     then do
                          SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "check2 passed")
                          Type -> Type -> TR ()
    addConstraint Type
    new_ty Type
    old_ty'
                          RttiInstantiation -> TR ()
    applyRevSubst RttiInstantiation
    rev_subst
                          Term
    zterm' <- Term -> TR Term
    zonkTerm Term
    term
                          Term -> TR Term
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ((Term -> Term
    fixFunDictionaries (Term -> Term) -> (Term -> Term) -> Term -> Term
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Term -> Term
    expandNewtypes) Term
    zterm')
                     else do
                          SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "check2 failed" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    parens
                                           (Term -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Term
    term SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "::" SDoc -> SDoc -> SDoc
    <+> Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    new_ty))
                          -- we have unsound types. Replace constructor types in
                          -- subterms with tyvars
                          Term
    zterm' <- (Type -> TR Type) -> Term -> TR Term
    forall (m :: * -> *). Monad m => (Type -> m Type) -> Term -> m Term
    mapTermTypeM
                                     (\Type
    ty -> case HasCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    tcSplitTyConApp_maybe Type
    ty of
                                               Just (TyCon
    tc, Type
    _:[Type]
    _) | TyCon
    tc TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    /= TyCon
    funTyCon
                                                   -> TR Type
    newOpenVar
                                               Maybe (TyCon, [Type])
    _   -> Type -> TR Type
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    ty)
                                     Term
    term
                          Term -> TR Term
    zonkTerm Term
    zterm'
       SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "Term reconstruction completed." SDoc -> SDoc -> SDoc
    $$
                String -> SDoc
    text String
    "Term obtained: " SDoc -> SDoc -> SDoc
    <> Term -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Term
    term SDoc -> SDoc -> SDoc
    $$
                String -> SDoc
    text String
    "Type obtained: " SDoc -> SDoc -> SDoc
    <> Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Term -> Type
    termType Term
    term))
       Term -> TR Term
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Term
    term
        where
      interp :: Interp
    interp = HscEnv -> Interp
    hscInterp HscEnv
    hsc_env
      unit_env :: UnitEnv
    unit_env = HscEnv -> UnitEnv
    hsc_unit_env HscEnv
    hsc_env

      go :: Int -> Type -> Type -> ForeignHValue -> TcM Term
       -- [SPJ May 11] I don't understand the difference between my_ty and old_ty

      go :: Int -> Type -> Type -> ForeignHValue -> TR Term
    go Int
    0 Type
    my_ty Type
    _old_ty ForeignHValue
    a = do
        SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "Gave up reconstructing a term after" SDoc -> SDoc -> SDoc
    <>
                      Int -> SDoc
    int Int
    max_depth SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text String
    " steps")
        GenClosure ForeignHValue
    clos <- IO (GenClosure ForeignHValue) -> TR (GenClosure ForeignHValue)
    forall a. IO a -> TR a
    trIO (IO (GenClosure ForeignHValue) -> TR (GenClosure ForeignHValue))
    -> IO (GenClosure ForeignHValue) -> TR (GenClosure ForeignHValue)
    forall a b. (a -> b) -> a -> b
    $ Interp -> ForeignHValue -> IO (GenClosure ForeignHValue)
    GHCi.getClosure Interp
    interp ForeignHValue
    a
        Term -> TR Term
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
    Suspension (StgInfoTable -> ClosureType
    tipe (GenClosure ForeignHValue -> StgInfoTable
    forall b. GenClosure b -> StgInfoTable
    info GenClosure ForeignHValue
    clos)) Type
    my_ty ForeignHValue
    a Maybe Name
    forall a. Maybe a
    Nothing)
      go !Int
    max_depth Type
    my_ty Type
    old_ty ForeignHValue
    a = do
        let monomorphic :: Bool
    monomorphic = Bool -> Bool
    not(Type -> Bool
    isTyVarTy Type
    my_ty)
        -- This ^^^ is a convention. The ancestor tests for
        -- monomorphism and passes a type instead of a tv
        GenClosure ForeignHValue
    clos <- IO (GenClosure ForeignHValue) -> TR (GenClosure ForeignHValue)
    forall a. IO a -> TR a
    trIO (IO (GenClosure ForeignHValue) -> TR (GenClosure ForeignHValue))
    -> IO (GenClosure ForeignHValue) -> TR (GenClosure ForeignHValue)
    forall a b. (a -> b) -> a -> b
    $ Interp -> ForeignHValue -> IO (GenClosure ForeignHValue)
    GHCi.getClosure Interp
    interp ForeignHValue
    a
        case GenClosure ForeignHValue
    clos of
    -- Thunks we may want to force
          GenClosure ForeignHValue
    t | GenClosure ForeignHValue -> Bool
    forall a. GenClosure a -> Bool
    isThunk GenClosure ForeignHValue
    t Bool -> Bool -> Bool
    && Bool
    force -> do
             SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "Forcing a " SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text (GenClosure () -> String
    forall a. Show a => a -> String
    show ((ForeignHValue -> ()) -> GenClosure ForeignHValue -> GenClosure ()
    forall a b. (a -> b) -> GenClosure a -> GenClosure b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (() -> ForeignHValue -> ()
    forall a b. a -> b -> a
    const ()) GenClosure ForeignHValue
    t)))
             EvalResult ()
    evalRslt <- IO (EvalResult ()) -> IOEnv (Env TcGblEnv TcLclEnv) (EvalResult ())
    forall a. IO a -> TR a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO (EvalResult ())
     -> IOEnv (Env TcGblEnv TcLclEnv) (EvalResult ()))
    -> IO (EvalResult ())
    -> IOEnv (Env TcGblEnv TcLclEnv) (EvalResult ())
    forall a b. (a -> b) -> a -> b
    $ Interp -> UnitEnv -> ForeignHValue -> IO (EvalResult ())
    GHCi.seqHValue Interp
    interp UnitEnv
    unit_env ForeignHValue
    a
             case EvalResult ()
    evalRslt of                                            -- #2950
               EvalSuccess ()
    _ -> Int -> Type -> Type -> ForeignHValue -> TR Term
    go (Int -> Int
    forall a. Enum a => a -> a
    pred Int
    max_depth) Type
    my_ty Type
    old_ty ForeignHValue
    a
               EvalException SerializableException
    ex -> do
                  -- Report the exception to the UI
                  SDoc -> TR ()
    traceTR (SDoc -> TR ()) -> SDoc -> TR ()
    forall a b. (a -> b) -> a -> b
    $ String -> SDoc
    text String
    "Exception occured:" SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text (SerializableException -> String
    forall a. Show a => a -> String
    show SerializableException
    ex)
                  IO Term -> TR Term
    forall a. IO a -> TR a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO Term -> TR Term) -> IO Term -> TR Term
    forall a b. (a -> b) -> a -> b
    $ SomeException -> IO Term
    forall e a. Exception e => e -> IO a
    throwIO (SomeException -> IO Term) -> SomeException -> IO Term
    forall a b. (a -> b) -> a -> b
    $ SerializableException -> SomeException
    fromSerializableException SerializableException
    ex
    -- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE. If
    -- the indirection is a TSO or BLOCKING_QUEUE, we return the BLACKHOLE itself as
    -- the suspension so that entering it in GHCi will enter the BLACKHOLE instead
    -- of entering the TSO or BLOCKING_QUEUE (which leads to runtime panic).
          BlackholeClosure{indirectee :: forall b. GenClosure b -> b
    indirectee=ForeignHValue
    ind} -> do
             SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "Following a BLACKHOLE")
             GenClosure ForeignHValue
    ind_clos <- IO (GenClosure ForeignHValue) -> TR (GenClosure ForeignHValue)
    forall a. IO a -> TR a
    trIO (Interp -> ForeignHValue -> IO (GenClosure ForeignHValue)
    GHCi.getClosure Interp
    interp ForeignHValue
    ind)
             let return_bh_value :: TR Term
    return_bh_value = Term -> TR Term
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
    Suspension ClosureType
    BLACKHOLE Type
    my_ty ForeignHValue
    a Maybe Name
    forall a. Maybe a
    Nothing)
             case GenClosure ForeignHValue
    ind_clos of
               -- TSO and BLOCKING_QUEUE cases
               BlockingQueueClosure{} -> TR Term
    return_bh_value
               OtherClosure StgInfoTable
    info [ForeignHValue]
    _ [Word]
    _
                 | StgInfoTable -> ClosureType
    tipe StgInfoTable
    info ClosureType -> ClosureType -> Bool
    forall a. Eq a => a -> a -> Bool
    == ClosureType
    TSO -> TR Term
    return_bh_value
               UnsupportedClosure StgInfoTable
    info
                 | StgInfoTable -> ClosureType
    tipe StgInfoTable
    info ClosureType -> ClosureType -> Bool
    forall a. Eq a => a -> a -> Bool
    == ClosureType
    TSO -> TR Term
    return_bh_value
               -- Otherwise follow the indirectee
               -- (NOTE: This code will break if we support TSO in ghc-heap one day)
               GenClosure ForeignHValue
    _ -> Int -> Type -> Type -> ForeignHValue -> TR Term
    go Int
    max_depth Type
    my_ty Type
    old_ty ForeignHValue
    ind
    -- We always follow indirections
          IndClosure{indirectee :: forall b. GenClosure b -> b
    indirectee=ForeignHValue
    ind} -> do
             SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "Following an indirection" )
             Int -> Type -> Type -> ForeignHValue -> TR Term
    go Int
    max_depth Type
    my_ty Type
    old_ty ForeignHValue
    ind
    -- We also follow references
          MutVarClosure{var :: forall b. GenClosure b -> b
    var=ForeignHValue
    contents}
             | Just (TyCon
    tycon,[Type
    lev,Type
    world,Type
    contents_ty]) <- HasCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    tcSplitTyConApp_maybe Type
    old_ty
                 -> do
                      -- Deal with the MutVar# primitive
                      -- It does not have a constructor at all,
                      -- so we simulate the following one
                      -- MutVar# :: contents_ty -> MutVar# s contents_ty
             Bool -> TR ()
    forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
    massert (TyCon
    tycon TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    mutVarPrimTyCon)
             Bool -> TR ()
    forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
    massert ((() :: Constraint) => Type -> Bool
    Type -> Bool
    isUnliftedType Type
    my_ty)
             SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "Following a MutVar")
             let contents_kind :: Type
    contents_kind = Type -> Type
    mkTYPEapp (TyCon -> [Type] -> Type
    mkTyConApp TyCon
    boxedRepDataConTyCon [Type
    lev])
             Type
    contents_tv <- Type -> TR Type
    newVar Type
    contents_kind
             (Type
    mutvar_ty,RttiInstantiation
    _) <- QuantifiedType -> TR (Type, RttiInstantiation)
    instScheme (QuantifiedType -> TR (Type, RttiInstantiation))
    -> QuantifiedType -> TR (Type, RttiInstantiation)
    forall a b. (a -> b) -> a -> b
    $ Type -> QuantifiedType
    quantifyType (Type -> QuantifiedType) -> Type -> QuantifiedType
    forall a b. (a -> b) -> a -> b
    $ Type -> Type -> Type
    mkVisFunTyMany
                                Type
    contents_ty (TyCon -> [Type] -> Type
    mkTyConApp TyCon
    tycon [Type
    lev, Type
    world,Type
    contents_ty])
             Type -> Type -> TR ()
    addConstraint (Type -> Type -> Type
    mkVisFunTyMany Type
    contents_tv Type
    my_ty) Type
    mutvar_ty
             Term
    x <- Int -> Type -> Type -> ForeignHValue -> TR Term
    go (Int -> Int
    forall a. Enum a => a -> a
    pred Int
    max_depth) Type
    contents_tv Type
    contents_ty ForeignHValue
    contents
             Term -> TR Term
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Type -> Term -> Term
    RefWrap Type
    my_ty Term
    x)

     -- The interesting case
          ConstrClosure{ptrArgs :: forall b. GenClosure b -> [b]
    ptrArgs=[ForeignHValue]
    pArgs,dataArgs :: forall b. GenClosure b -> [Word]
    dataArgs=[Word]
    dArgs} -> do
            SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "entering a constructor " SDoc -> SDoc -> SDoc
    <> [Word] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Word]
    dArgs SDoc -> SDoc -> SDoc
    <+>
                          if Bool
    monomorphic
                            then SDoc -> SDoc
    parens (String -> SDoc
    text String
    "already monomorphic: " SDoc -> SDoc -> SDoc
    <> Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    my_ty)
                            else SDoc
    Ppr.empty)
            Right Name
    dcname <- IO (Either String Name)
    -> IOEnv (Env TcGblEnv TcLclEnv) (Either String Name)
    forall a. IO a -> TR a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO (Either String Name)
     -> IOEnv (Env TcGblEnv TcLclEnv) (Either String Name))
    -> IO (Either String Name)
    -> IOEnv (Env TcGblEnv TcLclEnv) (Either String Name)
    forall a b. (a -> b) -> a -> b
    $ HscEnv -> GenClosure ForeignHValue -> IO (Either String Name)
    forall a. HscEnv -> GenClosure a -> IO (Either String Name)
    constrClosToName HscEnv
    hsc_env GenClosure ForeignHValue
    clos
            (Maybe DataCon
    mb_dc, Messages TcRnMessage
    _)   <- TcRn DataCon -> TcRn (Maybe DataCon, Messages TcRnMessage)
    forall a. TcRn a -> TcRn (Maybe a, Messages TcRnMessage)
    tryTc (Name -> TcRn DataCon
    tcLookupDataCon Name
    dcname)
            case Maybe DataCon
    mb_dc of
              Maybe DataCon
    Nothing -> do -- This can happen for private constructors compiled -O0
                            -- where the .hi descriptor does not export them
                            -- In such case, we return a best approximation:
                            --  ignore the unpointed args, and recover the pointeds
                            -- This preserves laziness, and should be safe.
                           SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "Not constructor" SDoc -> SDoc -> SDoc
    <+> Name -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Name
    dcname)
                           let dflags :: DynFlags
    dflags = HscEnv -> DynFlags
    hsc_dflags HscEnv
    hsc_env
                               tag :: String
    tag = DynFlags -> Name -> String
    forall a. Outputable a => DynFlags -> a -> String
    showPpr DynFlags
    dflags Name
    dcname
                           [Type]
    vars     <- (ForeignHValue -> TR Type)
    -> [ForeignHValue] -> IOEnv (Env TcGblEnv TcLclEnv) [Type]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (TR Type -> ForeignHValue -> TR Type
    forall a b. a -> b -> a
    const (Type -> TR Type
    newVar Type
    liftedTypeKind)) [ForeignHValue]
    pArgs
                           [Term]
    subTerms <- [TR Term] -> IOEnv (Env TcGblEnv TcLclEnv) [Term]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    forall (m :: * -> *) a. Monad m => [m a] -> m [a]
    sequence ([TR Term] -> IOEnv (Env TcGblEnv TcLclEnv) [Term])
    -> [TR Term] -> IOEnv (Env TcGblEnv TcLclEnv) [Term]
    forall a b. (a -> b) -> a -> b
    $ (ForeignHValue -> Type -> TR Term)
    -> [ForeignHValue] -> [Type] -> [TR Term]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (\ForeignHValue
    x Type
    tv ->
                               Int -> Type -> Type -> ForeignHValue -> TR Term
    go (Int -> Int
    forall a. Enum a => a -> a
    pred Int
    max_depth) Type
    tv Type
    tv ForeignHValue
    x) [ForeignHValue]
    pArgs [Type]
    vars
                           Term -> TR Term
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TermProcessor Term Term
    Term Type
    my_ty (String -> Either String DataCon
    forall a b. a -> Either a b
    Left (Char
    '<' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    tag String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ">")) ForeignHValue
    a [Term]
    subTerms)
              Just DataCon
    dc -> do
                SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "Is constructor" SDoc -> SDoc -> SDoc
    <+> (DataCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr DataCon
    dc SDoc -> SDoc -> SDoc
    $$ Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    my_ty))
                [Type]
    subTtypes <- DataCon -> Type -> IOEnv (Env TcGblEnv TcLclEnv) [Type]
    getDataConArgTys DataCon
    dc Type
    my_ty
                [Term]
    subTerms <- (Type -> ForeignHValue -> TR Term)
    -> GenClosure ForeignHValue
    -> [Type]
    -> IOEnv (Env TcGblEnv TcLclEnv) [Term]
    extractSubTerms (\Type
    ty -> Int -> Type -> Type -> ForeignHValue -> TR Term
    go (Int -> Int
    forall a. Enum a => a -> a
    pred Int
    max_depth) Type
    ty Type
    ty) GenClosure ForeignHValue
    clos [Type]
    subTtypes
                Term -> TR Term
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TermProcessor Term Term
    Term Type
    my_ty (DataCon -> Either String DataCon
    forall a b. b -> Either a b
    Right DataCon
    dc) ForeignHValue
    a [Term]
    subTerms)

          -- This is to support printing of Integers. It's not a general
          -- mechanism by any means; in particular we lose the size in
          -- bytes of the array.
          ArrWordsClosure{bytes :: forall b. GenClosure b -> Word
    bytes=Word
    b, arrWords :: forall b. GenClosure b -> [Word]
    arrWords=[Word]
    ws} -> do
             SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "ByteArray# closure, size " SDoc -> SDoc -> SDoc
    <> Word -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Word
    b)
             Term -> TR Term
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TermProcessor Term Term
    Term Type
    my_ty (String -> Either String DataCon
    forall a b. a -> Either a b
    Left String
    "ByteArray#") ForeignHValue
    a [Type -> [Word] -> Term
    Prim Type
    my_ty [Word]
    ws])

    -- The otherwise case: can be a Thunk,AP,PAP,etc.
          GenClosure ForeignHValue
    _ -> do
             SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "Unknown closure:" SDoc -> SDoc -> SDoc
    <+>
                      String -> SDoc
    text (GenClosure () -> String
    forall a. Show a => a -> String
    show ((ForeignHValue -> ()) -> GenClosure ForeignHValue -> GenClosure ()
    forall a b. (a -> b) -> GenClosure a -> GenClosure b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (() -> ForeignHValue -> ()
    forall a b. a -> b -> a
    const ()) GenClosure ForeignHValue
    clos)))
             Term -> TR Term
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
    Suspension (StgInfoTable -> ClosureType
    tipe (GenClosure ForeignHValue -> StgInfoTable
    forall b. GenClosure b -> StgInfoTable
    info GenClosure ForeignHValue
    clos)) Type
    my_ty ForeignHValue
    a Maybe Name
    forall a. Maybe a
    Nothing)

      -- insert NewtypeWraps around newtypes
      expandNewtypes :: Term -> Term
    expandNewtypes = TermFold Term -> Term -> Term
    forall a. TermFold a -> Term -> a
    foldTerm TermFold Term
    idTermFold { fTerm :: TermProcessor Term Term
    fTerm = TermProcessor Term Term
    worker } where
       worker :: TermProcessor Term Term
    worker Type
    ty Either String DataCon
    dc ForeignHValue
    hval [Term]
    tt
         | Just (TyCon
    tc, [Type]
    args) <- HasCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    tcSplitTyConApp_maybe Type
    ty
         , TyCon -> Bool
    isNewTyCon TyCon
    tc
         , Type
    wrapped_type    <- TyCon -> [Type] -> Type
    newTyConInstRhs TyCon
    tc [Type]
    args
         , Just DataCon
    dc'        <- TyCon -> Maybe DataCon
    tyConSingleDataCon_maybe TyCon
    tc
         , Term
    t'              <- TermProcessor Term Term
    worker Type
    wrapped_type Either String DataCon
    dc ForeignHValue
    hval [Term]
    tt
         = Type -> Either String DataCon -> Term -> Term
    NewtypeWrap Type
    ty (DataCon -> Either String DataCon
    forall a b. b -> Either a b
    Right DataCon
    dc') Term
    t'
         | Bool
    otherwise = TermProcessor Term Term
    Term Type
    ty Either String DataCon
    dc ForeignHValue
    hval [Term]
    tt

       -- Avoid returning types where predicates have been expanded to dictionaries.
      fixFunDictionaries :: Term -> Term
    fixFunDictionaries = TermFold Term -> Term -> Term
    forall a. TermFold a -> Term -> a
    foldTerm TermFold Term
    idTermFold {fSuspension :: ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
    fSuspension = ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
    worker} where
          worker :: ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
    worker ClosureType
    ct Type
    ty ForeignHValue
    hval Maybe Name
    n | Type -> Bool
    isFunTy Type
    ty = ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
    Suspension ClosureType
    ct (Type -> Type
    dictsView Type
    ty) ForeignHValue
    hval Maybe Name
    n
                              | Bool
    otherwise  = ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
    Suspension ClosureType
    ct Type
    ty ForeignHValue
    hval Maybe Name
    n

    extractSubTerms :: (Type -> ForeignHValue -> TcM Term)
                    -> GenClosure ForeignHValue -> [Type] -> TcM [Term]
    extractSubTerms :: (Type -> ForeignHValue -> TR Term)
    -> GenClosure ForeignHValue
    -> [Type]
    -> IOEnv (Env TcGblEnv TcLclEnv) [Term]
    extractSubTerms Type -> ForeignHValue -> TR Term
    recurse GenClosure ForeignHValue
    clos = ((Int, Int, [Term]) -> [Term])
    -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
    -> IOEnv (Env TcGblEnv TcLclEnv) [Term]
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM (Int, Int, [Term]) -> [Term]
    forall a b c. (a, b, c) -> c
    thdOf3 (IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
     -> IOEnv (Env TcGblEnv TcLclEnv) [Term])
    -> ([Type] -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term]))
    -> [Type]
    -> IOEnv (Env TcGblEnv TcLclEnv) [Term]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int
    -> Int
    -> [Type]
    -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
    go Int
    0 Int
    0
      where
        array :: [Word]
    array = GenClosure ForeignHValue -> [Word]
    forall b. GenClosure b -> [Word]
    dataArgs GenClosure ForeignHValue
    clos

        go :: Int
    -> Int
    -> [Type]
    -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
    go Int
    ptr_i Int
    arr_i [] = (Int, Int, [Term])
    -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Int
    ptr_i, Int
    arr_i, [])
        go Int
    ptr_i Int
    arr_i (Type
    ty:[Type]
    tys)
          | Just (TyCon
    tc, [Type]
    elem_tys) <- HasCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    tcSplitTyConApp_maybe Type
    ty
          , TyCon -> Bool
    isUnboxedTupleTyCon TyCon
    tc
                    -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
          = do (Int
    ptr_i, Int
    arr_i, [Term]
    terms0) <-
                   Int
    -> Int
    -> [Type]
    -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
    go Int
    ptr_i Int
    arr_i ([Type] -> [Type]
    dropRuntimeRepArgs [Type]
    elem_tys)
               (Int
    ptr_i, Int
    arr_i, [Term]
    terms1) <- Int
    -> Int
    -> [Type]
    -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
    go Int
    ptr_i Int
    arr_i [Type]
    tys
               (Int, Int, [Term])
    -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Int
    ptr_i, Int
    arr_i, Type -> [Term] -> Term
    unboxedTupleTerm Type
    ty [Term]
    terms0 Term -> [Term] -> [Term]
    forall a. a -> [a] -> [a]
    : [Term]
    terms1)
          | Bool
    otherwise
          = case (() :: Constraint) => Type -> [PrimRep]
    Type -> [PrimRep]
    typePrimRepArgs Type
    ty of
              [PrimRep
    rep_ty] ->  do
                (Int
    ptr_i, Int
    arr_i, Term
    term0)  <- Int
    -> Int
    -> Type
    -> PrimRep
    -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, Term)
    go_rep Int
    ptr_i Int
    arr_i Type
    ty PrimRep
    rep_ty
                (Int
    ptr_i, Int
    arr_i, [Term]
    terms1) <- Int
    -> Int
    -> [Type]
    -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
    go Int
    ptr_i Int
    arr_i [Type]
    tys
                (Int, Int, [Term])
    -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Int
    ptr_i, Int
    arr_i, Term
    term0 Term -> [Term] -> [Term]
    forall a. a -> [a] -> [a]
    : [Term]
    terms1)
              [PrimRep]
    rep_tys -> do
               (Int
    ptr_i, Int
    arr_i, [Term]
    terms0) <- Int
    -> Int
    -> [PrimRep]
    -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
    go_unary_types Int
    ptr_i Int
    arr_i [PrimRep]
    rep_tys
               (Int
    ptr_i, Int
    arr_i, [Term]
    terms1) <- Int
    -> Int
    -> [Type]
    -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
    go Int
    ptr_i Int
    arr_i [Type]
    tys
               (Int, Int, [Term])
    -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Int
    ptr_i, Int
    arr_i, Type -> [Term] -> Term
    unboxedTupleTerm Type
    ty [Term]
    terms0 Term -> [Term] -> [Term]
    forall a. a -> [a] -> [a]
    : [Term]
    terms1)

        go_unary_types :: Int
    -> Int
    -> [PrimRep]
    -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
    go_unary_types Int
    ptr_i Int
    arr_i [] = (Int, Int, [Term])
    -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Int
    ptr_i, Int
    arr_i, [])
        go_unary_types Int
    ptr_i Int
    arr_i (PrimRep
    rep_ty:[PrimRep]
    rep_tys) = do
          Type
    tv <- Type -> TR Type
    newVar Type
    liftedTypeKind
          (Int
    ptr_i, Int
    arr_i, Term
    term0)  <- Int
    -> Int
    -> Type
    -> PrimRep
    -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, Term)
    go_rep Int
    ptr_i Int
    arr_i Type
    tv PrimRep
    rep_ty
          (Int
    ptr_i, Int
    arr_i, [Term]
    terms1) <- Int
    -> Int
    -> [PrimRep]
    -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
    go_unary_types Int
    ptr_i Int
    arr_i [PrimRep]
    rep_tys
          (Int, Int, [Term])
    -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, [Term])
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Int
    ptr_i, Int
    arr_i, Term
    term0 Term -> [Term] -> [Term]
    forall a. a -> [a] -> [a]
    : [Term]
    terms1)

        go_rep :: Int
    -> Int
    -> Type
    -> PrimRep
    -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, Term)
    go_rep Int
    ptr_i Int
    arr_i Type
    ty PrimRep
    rep
          | PrimRep -> Bool
    isGcPtrRep PrimRep
    rep = do
              Term
    t <- Type -> ForeignHValue -> TR Term
    recurse Type
    ty (ForeignHValue -> TR Term) -> ForeignHValue -> TR Term
    forall a b. (a -> b) -> a -> b
    $ (GenClosure ForeignHValue -> [ForeignHValue]
    forall b. GenClosure b -> [b]
    ptrArgs GenClosure ForeignHValue
    clos)[ForeignHValue] -> Int -> ForeignHValue
    forall a. HasCallStack => [a] -> Int -> a
    !!Int
    ptr_i
              (Int, Int, Term) -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, Term)
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Int
    ptr_i Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1, Int
    arr_i, Term
    t)
          | Bool
    otherwise = do
              -- This is a bit involved since we allow packing multiple fields
              -- within a single word. See also
              -- GHC.StgToCmm.Layout.mkVirtHeapOffsetsWithPadding
              Platform
    platform <- TcM Platform
    getPlatform
              let word_size :: Int
    word_size = Platform -> Int
    platformWordSizeInBytes Platform
    platform
                  endian :: ByteOrder
    endian = Platform -> ByteOrder
    platformByteOrder Platform
    platform
                  size_b :: Int
    size_b = Platform -> PrimRep -> Int
    primRepSizeB Platform
    platform PrimRep
    rep
                  -- Align the start offset (eg, 2-byte value should be 2-byte
                  -- aligned). But not more than to a word. The offset calculation
                  -- should be the same with the offset calculation in
                  -- GHC.StgToCmm.Layout.mkVirtHeapOffsetsWithPadding.
                  !aligned_idx :: Int
    aligned_idx = Int -> Int -> Int
    roundUpTo Int
    arr_i (Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    min Int
    word_size Int
    size_b)
                  !new_arr_i :: Int
    new_arr_i = Int
    aligned_idx Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    size_b
                  ws :: [Word]
    ws | Int
    size_b Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    word_size =
                         [Int -> Int -> Int -> ByteOrder -> Word
    index Int
    size_b Int
    aligned_idx Int
    word_size ByteOrder
    endian]
                     | Bool
    otherwise =
                         let (Int
    q, Int
    r) = Int
    size_b Int -> Int -> (Int, Int)
    forall a. Integral a => a -> a -> (a, a)
    `quotRem` Int
    word_size
                         in Bool -> [Word] -> [Word]
    forall a. HasCallStack => Bool -> a -> a
    assert (Int
    r Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0 )
                            [ [Word]
    array[Word] -> Int -> Word
    forall a. HasCallStack => [a] -> Int -> a
    !!Int
    i
                            | Int
    o <- [Int
    0.. Int
    q Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1]
                            , let i :: Int
    i = (Int
    aligned_idx Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `quot` Int
    word_size) Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    o
                            ]
              (Int, Int, Term) -> IOEnv (Env TcGblEnv TcLclEnv) (Int, Int, Term)
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Int
    ptr_i, Int
    new_arr_i, Type -> [Word] -> Term
    Prim Type
    ty [Word]
    ws)

        unboxedTupleTerm :: Type -> [Term] -> Term
    unboxedTupleTerm Type
    ty [Term]
    terms
          = TermProcessor Term Term
    Term Type
    ty (DataCon -> Either String DataCon
    forall a b. b -> Either a b
    Right (Boxity -> Int -> DataCon
    tupleDataCon Boxity
    Unboxed ([Term] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Term]
    terms)))
                    (String -> ForeignHValue
    forall a. HasCallStack => String -> a
    error String
    "unboxedTupleTerm: no HValue for unboxed tuple") [Term]
    terms

        -- Extract a sub-word sized field from a word
        -- A sub word is aligned to the left-most part of a word on big-endian
        -- platforms, and to the right-most part of a word on little-endian
        -- platforms.  This allows to write and read it back from memory
        -- independent of endianness.  Bits not belonging to a sub word are zeroed
        -- out, although, this is strictly speaking not necessary since a sub word
        -- is read back from memory by appropriately casted pointers (see e.g.
        -- ppr_float of cPprTermBase).
        index :: Int -> Int -> Int -> ByteOrder -> Word
    index Int
    size_b Int
    aligned_idx Int
    word_size ByteOrder
    endian = case ByteOrder
    endian of
          ByteOrder
    BigEndian    -> (Word
    word Word -> Int -> Word
    forall a. Bits a => a -> Int -> a
    `shiftL` Int
    moveBits) Word -> Int -> Word
    forall a. Bits a => a -> Int -> a
    `shiftR` Int
    zeroOutBits Word -> Int -> Word
    forall a. Bits a => a -> Int -> a
    `shiftL` Int
    zeroOutBits
          ByteOrder
    LittleEndian -> (Word
    word Word -> Int -> Word
    forall a. Bits a => a -> Int -> a
    `shiftR` Int
    moveBits) Word -> Int -> Word
    forall a. Bits a => a -> Int -> a
    `shiftL` Int
    zeroOutBits Word -> Int -> Word
    forall a. Bits a => a -> Int -> a
    `shiftR` Int
    zeroOutBits
         where
          (Int
    q, Int
    r) = Int
    aligned_idx Int -> Int -> (Int, Int)
    forall a. Integral a => a -> a -> (a, a)
    `quotRem` Int
    word_size
          word :: Word
    word = [Word]
    array[Word] -> Int -> Word
    forall a. HasCallStack => [a] -> Int -> a
    !!Int
    q
          moveBits :: Int
    moveBits = Int
    r Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    8
          zeroOutBits :: Int
    zeroOutBits = (Int
    word_size Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    size_b) Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    8

    -- | Fast, breadth-first Type reconstruction
    --
    -- Given a heap object (`HValue`) and its (possibly polymorphic) type (usually
    -- obtained in GHCi), try to reconstruct a more monomorphic type of the object.
    -- This is used for improving type information in debugger. For example, if we
    -- have a polymorphic function:
    --
    --     sumNumList :: Num a => [a] -> a
    --     sumNumList [] = 0
    --     sumNumList (x : xs) = x + sumList xs
    --
    -- and add a breakpoint to it:
    --
    --     ghci> break sumNumList
    --     ghci> sumNumList ([0 .. 9] :: [Int])
    --
    -- ghci shows us more precise types than just `a`s:
    --
    --     Stopped in Main.sumNumList, debugger.hs:3:23-39
    --     _result :: Int = _
    --     x :: Int = 0
    --     xs :: [Int] = _
    --
    cvReconstructType
        :: HscEnv
        -> Int       -- ^ How many times to recurse for subterms
        -> GhciType  -- ^ Type to refine
        -> ForeignHValue  -- ^ Refine the type using this value
        -> IO (Maybe Type)
    cvReconstructType :: HscEnv -> Int -> Type -> ForeignHValue -> IO (Maybe Type)
    cvReconstructType HscEnv
    hsc_env Int
    max_depth Type
    old_ty ForeignHValue
    hval = HscEnv -> TR Type -> IO (Maybe Type)
    forall a. HscEnv -> TR a -> IO (Maybe a)
    runTR_maybe HscEnv
    hsc_env (TR Type -> IO (Maybe Type)) -> TR Type -> IO (Maybe Type)
    forall a b. (a -> b) -> a -> b
    $ do
       SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "RTTI started with initial type " SDoc -> SDoc -> SDoc
    <> Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    old_ty)
       let sigma_old_ty :: QuantifiedType
    sigma_old_ty@([TyVar]
    old_tvs, Type
    _) = Type -> QuantifiedType
    quantifyType Type
    old_ty
       Type
    new_ty <-
           if [TyVar] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [TyVar]
    old_tvs
            then Type -> TR Type
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    old_ty
            else do
              (Type
    old_ty', RttiInstantiation
    rev_subst) <- QuantifiedType -> TR (Type, RttiInstantiation)
    instScheme QuantifiedType
    sigma_old_ty
              Type
    my_ty <- TR Type
    newOpenVar
              Bool -> TR () -> TR ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when ([TyVar] -> Bool
    check1 [TyVar]
    old_tvs) (SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "check1 passed") TR () -> TR () -> TR ()
    forall a b.
    IOEnv (Env TcGblEnv TcLclEnv) a
    -> IOEnv (Env TcGblEnv TcLclEnv) b
    -> IOEnv (Env TcGblEnv TcLclEnv) b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >>
                                          Type -> Type -> TR ()
    addConstraint Type
    my_ty Type
    old_ty')
              IOEnv (Env TcGblEnv TcLclEnv) Bool
    -> ((Type, ForeignHValue)
        -> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)])
    -> Seq (Type, ForeignHValue)
    -> Int
    -> TR ()
    search (Type -> Bool
    isMonomorphic (Type -> Bool) -> TR Type -> IOEnv (Env TcGblEnv TcLclEnv) Bool
    forall a b.
    (a -> b)
    -> IOEnv (Env TcGblEnv TcLclEnv) a
    -> IOEnv (Env TcGblEnv TcLclEnv) b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` Type -> TR Type
    zonkTcType Type
    my_ty)
                     (\(Type
    ty,ForeignHValue
    a) -> Type
    -> ForeignHValue
    -> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
    go Type
    ty ForeignHValue
    a)
                     ((Type, ForeignHValue) -> Seq (Type, ForeignHValue)
    forall a. a -> Seq a
    Seq.singleton (Type
    my_ty, ForeignHValue
    hval))
                     Int
    max_depth
              Type
    new_ty <- Type -> TR Type
    zonkTcType Type
    my_ty
              if Type -> Bool
    isMonomorphic Type
    new_ty Bool -> Bool -> Bool
    || Type -> Type -> Bool
    check2 Type
    new_ty Type
    old_ty
                then do
                     SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "check2 passed" SDoc -> SDoc -> SDoc
    <+> Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    old_ty SDoc -> SDoc -> SDoc
    $$ Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    new_ty)
                     Type -> Type -> TR ()
    addConstraint Type
    my_ty Type
    old_ty'
                     RttiInstantiation -> TR ()
    applyRevSubst RttiInstantiation
    rev_subst
                     Type -> TR Type
    zonkRttiType Type
    new_ty
                else SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "check2 failed" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    parens (Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    new_ty)) TR () -> TR Type -> TR Type
    forall a b.
    IOEnv (Env TcGblEnv TcLclEnv) a
    -> IOEnv (Env TcGblEnv TcLclEnv) b
    -> IOEnv (Env TcGblEnv TcLclEnv) b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >>
                     Type -> TR Type
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    old_ty
       SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "RTTI completed. Type obtained:" SDoc -> SDoc -> SDoc
    <+> Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    new_ty)
       Type -> TR Type
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    new_ty
        where
      interp :: Interp
    interp = HscEnv -> Interp
    hscInterp HscEnv
    hsc_env

    --  search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
      search :: IOEnv (Env TcGblEnv TcLclEnv) Bool
    -> ((Type, ForeignHValue)
        -> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)])
    -> Seq (Type, ForeignHValue)
    -> Int
    -> TR ()
    search IOEnv (Env TcGblEnv TcLclEnv) Bool
    _ (Type, ForeignHValue)
    -> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
    _ Seq (Type, ForeignHValue)
    _ Int
    0 = SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "Failed to reconstruct a type after " SDoc -> SDoc -> SDoc
    <>
                                    Int -> SDoc
    int Int
    max_depth SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text String
    " steps")
      search IOEnv (Env TcGblEnv TcLclEnv) Bool
    stop (Type, ForeignHValue)
    -> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
    expand Seq (Type, ForeignHValue)
    l Int
    d =
        case Seq (Type, ForeignHValue) -> ViewL (Type, ForeignHValue)
    forall a. Seq a -> ViewL a
    viewl Seq (Type, ForeignHValue)
    l of
          ViewL (Type, ForeignHValue)
    EmptyL  -> () -> TR ()
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
          (Type, ForeignHValue)
    x :< Seq (Type, ForeignHValue)
    xx -> IOEnv (Env TcGblEnv TcLclEnv) Bool -> TR () -> TR ()
    forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
    unlessM IOEnv (Env TcGblEnv TcLclEnv) Bool
    stop (TR () -> TR ()) -> TR () -> TR ()
    forall a b. (a -> b) -> a -> b
    $ do
                      [(Type, ForeignHValue)]
    new <- (Type, ForeignHValue)
    -> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
    expand (Type, ForeignHValue)
    x
                      IOEnv (Env TcGblEnv TcLclEnv) Bool
    -> ((Type, ForeignHValue)
        -> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)])
    -> Seq (Type, ForeignHValue)
    -> Int
    -> TR ()
    search IOEnv (Env TcGblEnv TcLclEnv) Bool
    stop (Type, ForeignHValue)
    -> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
    expand (Seq (Type, ForeignHValue)
    xx Seq (Type, ForeignHValue)
    -> Seq (Type, ForeignHValue) -> Seq (Type, ForeignHValue)
    forall a. Monoid a => a -> a -> a
    `mappend` [(Type, ForeignHValue)] -> Seq (Type, ForeignHValue)
    forall a. [a] -> Seq a
    Seq.fromList [(Type, ForeignHValue)]
    new) (Int -> TR ()) -> Int -> TR ()
    forall a b. (a -> b) -> a -> b
    $! (Int -> Int
    forall a. Enum a => a -> a
    pred Int
    d)

       -- returns unification tasks,since we are going to want a breadth-first search
      go :: Type -> ForeignHValue -> TR [(Type, ForeignHValue)]
      go :: Type
    -> ForeignHValue
    -> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
    go Type
    my_ty ForeignHValue
    a = do
        SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "go" SDoc -> SDoc -> SDoc
    <+> Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    my_ty)
        GenClosure ForeignHValue
    clos <- IO (GenClosure ForeignHValue) -> TR (GenClosure ForeignHValue)
    forall a. IO a -> TR a
    trIO (IO (GenClosure ForeignHValue) -> TR (GenClosure ForeignHValue))
    -> IO (GenClosure ForeignHValue) -> TR (GenClosure ForeignHValue)
    forall a b. (a -> b) -> a -> b
    $ Interp -> ForeignHValue -> IO (GenClosure ForeignHValue)
    GHCi.getClosure Interp
    interp ForeignHValue
    a
        case GenClosure ForeignHValue
    clos of
          BlackholeClosure{indirectee :: forall b. GenClosure b -> b
    indirectee=ForeignHValue
    ind} -> Type
    -> ForeignHValue
    -> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
    go Type
    my_ty ForeignHValue
    ind
          IndClosure{indirectee :: forall b. GenClosure b -> b
    indirectee=ForeignHValue
    ind} -> Type
    -> ForeignHValue
    -> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
    go Type
    my_ty ForeignHValue
    ind
          MutVarClosure{var :: forall b. GenClosure b -> b
    var=ForeignHValue
    contents}
            | Just (TyCon
    _tycon,[Type
    lev,Type
    _world,Type
    _contents_ty]) <- HasCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    tcSplitTyConApp_maybe Type
    my_ty
            -> do
            Bool -> TR ()
    forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
    massert (TyCon
    _tycon TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    mutVarPrimTyCon)
            Type
    tv'   <- Type -> TR Type
    newVar (Type -> TR Type) -> Type -> TR Type
    forall a b. (a -> b) -> a -> b
    $ Type -> Type
    mkTYPEapp (TyCon -> [Type] -> Type
    mkTyConApp TyCon
    boxedRepDataConTyCon [Type
    lev])
            Type
    world <- Type -> TR Type
    newVar Type
    liftedTypeKind
            Type -> Type -> TR ()
    addConstraint Type
    my_ty (Type -> TR ()) -> Type -> TR ()
    forall a b. (a -> b) -> a -> b
    $ Type -> Type -> Type
    mkMutVarPrimTy Type
    world Type
    tv'
            [(Type, ForeignHValue)]
    -> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [(Type
    tv', ForeignHValue
    contents)]
          APClosure {payload :: forall b. GenClosure b -> [b]
    payload=[ForeignHValue]
    pLoad} -> do                -- #19559 (incr)
            (ForeignHValue
     -> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)])
    -> [ForeignHValue] -> TR ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (Type
    -> ForeignHValue
    -> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
    go Type
    my_ty) [ForeignHValue]
    pLoad
            [(Type, ForeignHValue)]
    -> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
          ConstrClosure{ptrArgs :: forall b. GenClosure b -> [b]
    ptrArgs=[ForeignHValue]
    pArgs} -> do
            Right Name
    dcname <- IO (Either String Name)
    -> IOEnv (Env TcGblEnv TcLclEnv) (Either String Name)
    forall a. IO a -> TR a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO (Either String Name)
     -> IOEnv (Env TcGblEnv TcLclEnv) (Either String Name))
    -> IO (Either String Name)
    -> IOEnv (Env TcGblEnv TcLclEnv) (Either String Name)
    forall a b. (a -> b) -> a -> b
    $ HscEnv -> GenClosure ForeignHValue -> IO (Either String Name)
    forall a. HscEnv -> GenClosure a -> IO (Either String Name)
    constrClosToName HscEnv
    hsc_env GenClosure ForeignHValue
    clos
            SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "Constr1" SDoc -> SDoc -> SDoc
    <+> Name -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Name
    dcname)
            (Maybe DataCon
    mb_dc, Messages TcRnMessage
    _) <- TcRn DataCon -> TcRn (Maybe DataCon, Messages TcRnMessage)
    forall a. TcRn a -> TcRn (Maybe a, Messages TcRnMessage)
    tryTc (Name -> TcRn DataCon
    tcLookupDataCon Name
    dcname)
            case Maybe DataCon
    mb_dc of
              Maybe DataCon
    Nothing->
                [ForeignHValue]
    -> (ForeignHValue
        -> IOEnv (Env TcGblEnv TcLclEnv) (Type, ForeignHValue))
    -> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    t a -> (a -> m b) -> m (t b)
    forM [ForeignHValue]
    pArgs ((ForeignHValue
      -> IOEnv (Env TcGblEnv TcLclEnv) (Type, ForeignHValue))
     -> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)])
    -> (ForeignHValue
        -> IOEnv (Env TcGblEnv TcLclEnv) (Type, ForeignHValue))
    -> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
    forall a b. (a -> b) -> a -> b
    $ \ForeignHValue
    x -> do
                  Type
    tv <- Type -> TR Type
    newVar Type
    liftedTypeKind
                  (Type, ForeignHValue)
    -> IOEnv (Env TcGblEnv TcLclEnv) (Type, ForeignHValue)
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Type
    tv, ForeignHValue
    x)

              Just DataCon
    dc -> do
                [Type]
    arg_tys <- DataCon -> Type -> IOEnv (Env TcGblEnv TcLclEnv) [Type]
    getDataConArgTys DataCon
    dc Type
    my_ty
                (Int
    _, [(Int, Type)]
    itys) <- Int -> [Type] -> TR (Int, [(Int, Type)])
    findPtrTyss Int
    0 [Type]
    arg_tys
                SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "Constr2" SDoc -> SDoc -> SDoc
    <+> Name -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Name
    dcname SDoc -> SDoc -> SDoc
    <+> [Type] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Type]
    arg_tys)
                [(Type, ForeignHValue)]
    -> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([(Type, ForeignHValue)]
     -> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)])
    -> [(Type, ForeignHValue)]
    -> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
    forall a b. (a -> b) -> a -> b
    $ ((Int, Type) -> ForeignHValue -> (Type, ForeignHValue))
    -> [(Int, Type)] -> [ForeignHValue] -> [(Type, ForeignHValue)]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (\(Int
    _,Type
    ty) ForeignHValue
    x -> (Type
    ty, ForeignHValue
    x)) [(Int, Type)]
    itys [ForeignHValue]
    pArgs
          GenClosure ForeignHValue
    _ -> [(Type, ForeignHValue)]
    -> IOEnv (Env TcGblEnv TcLclEnv) [(Type, ForeignHValue)]
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []

    findPtrTys :: Int  -- Current pointer index
               -> Type -- Type
               -> TR (Int, [(Int, Type)])
    findPtrTys :: Int -> Type -> TR (Int, [(Int, Type)])
    findPtrTys Int
    i Type
    ty
      | Just (TyCon
    tc, [Type]
    elem_tys) <- HasCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    tcSplitTyConApp_maybe Type
    ty
      , TyCon -> Bool
    isUnboxedTupleTyCon TyCon
    tc
      = Int -> [Type] -> TR (Int, [(Int, Type)])
    findPtrTyss Int
    i [Type]
    elem_tys

      | Bool
    otherwise
      = case (() :: Constraint) => Type -> [PrimRep]
    Type -> [PrimRep]
    typePrimRep Type
    ty of
          [PrimRep
    rep] | PrimRep -> Bool
    isGcPtrRep PrimRep
    rep -> (Int, [(Int, Type)]) -> TR (Int, [(Int, Type)])
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Int
    i Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1, [(Int
    i, Type
    ty)])
                | Bool
    otherwise      -> (Int, [(Int, Type)]) -> TR (Int, [(Int, Type)])
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Int
    i,     [])
          [PrimRep]
    prim_reps              ->
            ((Int, [(Int, Type)]) -> PrimRep -> TR (Int, [(Int, Type)]))
    -> (Int, [(Int, Type)]) -> [PrimRep] -> TR (Int, [(Int, Type)])
    forall (t :: * -> *) (m :: * -> *) b a.
    (Foldable t, Monad m) =>
    (b -> a -> m b) -> b -> t a -> m b
    foldM (\(Int
    i, [(Int, Type)]
    extras) PrimRep
    prim_rep ->
                    if PrimRep -> Bool
    isGcPtrRep PrimRep
    prim_rep
                      then Type -> TR Type
    newVar Type
    liftedTypeKind TR Type
    -> (Type -> TR (Int, [(Int, Type)])) -> TR (Int, [(Int, Type)])
    forall a b.
    IOEnv (Env TcGblEnv TcLclEnv) a
    -> (a -> IOEnv (Env TcGblEnv TcLclEnv) b)
    -> IOEnv (Env TcGblEnv TcLclEnv) b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \Type
    tv -> (Int, [(Int, Type)]) -> TR (Int, [(Int, Type)])
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Int
    i Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1, [(Int, Type)]
    extras [(Int, Type)] -> [(Int, Type)] -> [(Int, Type)]
    forall a. [a] -> [a] -> [a]
    ++ [(Int
    i, Type
    tv)])
                      else (Int, [(Int, Type)]) -> TR (Int, [(Int, Type)])
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Int
    i, [(Int, Type)]
    extras))
                  (Int
    i, []) [PrimRep]
    prim_reps

    findPtrTyss :: Int
                -> [Type]
                -> TR (Int, [(Int, Type)])
    findPtrTyss :: Int -> [Type] -> TR (Int, [(Int, Type)])
    findPtrTyss Int
    i [Type]
    tys = ((Int, [(Int, Type)]) -> Type -> TR (Int, [(Int, Type)]))
    -> (Int, [(Int, Type)]) -> [Type] -> TR (Int, [(Int, Type)])
    forall (t :: * -> *) (m :: * -> *) b a.
    (Foldable t, Monad m) =>
    (b -> a -> m b) -> b -> t a -> m b
    foldM (Int, [(Int, Type)]) -> Type -> TR (Int, [(Int, Type)])
    step (Int
    i, []) [Type]
    tys
      where step :: (Int, [(Int, Type)]) -> Type -> TR (Int, [(Int, Type)])
    step (Int
    i, [(Int, Type)]
    discovered) Type
    elem_ty = do
              (Int
    i, [(Int, Type)]
    extras) <- Int -> Type -> TR (Int, [(Int, Type)])
    findPtrTys Int
    i Type
    elem_ty
              (Int, [(Int, Type)]) -> TR (Int, [(Int, Type)])
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Int
    i, [(Int, Type)]
    discovered [(Int, Type)] -> [(Int, Type)] -> [(Int, Type)]
    forall a. [a] -> [a] -> [a]
    ++ [(Int, Type)]
    extras)

    -- Compute the difference between a base type and the type found by RTTI
    -- improveType <base_type> <rtti_type>
    -- The types can contain skolem type variables, which need to be treated as normal vars.
    -- In particular, we want them to unify with things.
    improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TCvSubst
    improveRTTIType :: HscEnv -> Type -> Type -> Maybe TCvSubst
    improveRTTIType HscEnv
    _ Type
    base_ty Type
    new_ty = Type -> Type -> Maybe TCvSubst
    U.tcUnifyTyKi Type
    base_ty Type
    new_ty

    getDataConArgTys :: DataCon -> Type -> TR [Type]
    -- Given the result type ty of a constructor application (D a b c :: ty)
    -- return the types of the arguments.  This is RTTI-land, so 'ty' might
    -- not be fully known.  Moreover, the arg types might involve existentials;
    -- if so, make up fresh RTTI type variables for them
    getDataConArgTys :: DataCon -> Type -> IOEnv (Env TcGblEnv TcLclEnv) [Type]
    getDataConArgTys DataCon
    dc Type
    con_app_ty
      = do { let rep_con_app_ty :: Type
    rep_con_app_ty = Type -> Type
    unwrapType Type
    con_app_ty
           ; SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "getDataConArgTys 1" SDoc -> SDoc -> SDoc
    <+> (Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    con_app_ty SDoc -> SDoc -> SDoc
    $$ Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    rep_con_app_ty
                       SDoc -> SDoc -> SDoc
    $$ Maybe (TyCon, [Type]) -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (HasCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    tcSplitTyConApp_maybe Type
    rep_con_app_ty)))
           ; Bool -> (() -> TR ()) -> () -> TR ()
    forall a. HasCallStack => Bool -> a -> a
    assert ((TyVar -> Bool) -> [TyVar] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all TyVar -> Bool
    isTyVar [TyVar]
    ex_tvs ) () -> TR ()
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                     -- ex_tvs can only be tyvars as data types in source
                     -- Haskell cannot mention covar yet (Aug 2018)
           ; (TCvSubst
    subst, [TyVar]
    _) <- [TyVar] -> TR (TCvSubst, [TyVar])
    instTyVars ([TyVar]
    univ_tvs [TyVar] -> [TyVar] -> [TyVar]
    forall a. [a] -> [a] -> [a]
    ++ [TyVar]
    ex_tvs)
           ; Type -> Type -> TR ()
    addConstraint Type
    rep_con_app_ty ((() :: Constraint) => TCvSubst -> Type -> Type
    TCvSubst -> Type -> Type
    substTy TCvSubst
    subst (DataCon -> Type
    dataConOrigResTy DataCon
    dc))
                  -- See Note [Constructor arg types]
           ; let con_arg_tys :: [Type]
    con_arg_tys = (() :: Constraint) => TCvSubst -> [Type] -> [Type]
    TCvSubst -> [Type] -> [Type]
    substTys TCvSubst
    subst ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Scaled Type -> Type
    forall a. Scaled a -> a
    scaledThing ([Scaled Type] -> [Type]) -> [Scaled Type] -> [Type]
    forall a b. (a -> b) -> a -> b
    $ DataCon -> [Scaled Type]
    dataConRepArgTys DataCon
    dc)
           ; SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "getDataConArgTys 2" SDoc -> SDoc -> SDoc
    <+> (Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    rep_con_app_ty SDoc -> SDoc -> SDoc
    $$ [Type] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Type]
    con_arg_tys SDoc -> SDoc -> SDoc
    $$ TCvSubst -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TCvSubst
    subst))
           ; [Type] -> IOEnv (Env TcGblEnv TcLclEnv) [Type]
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Type]
    con_arg_tys }
      where
        univ_tvs :: [TyVar]
    univ_tvs = DataCon -> [TyVar]
    dataConUnivTyVars DataCon
    dc
        ex_tvs :: [TyVar]
    ex_tvs   = DataCon -> [TyVar]
    dataConExTyCoVars DataCon
    dc

    {- Note [Constructor arg types]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider a GADT (cf #7386)
       data family D a b
       data instance D [a] a where
         MkT :: a -> D [a] (Maybe a)
         ...

    In getDataConArgTys
    * con_app_ty is the known type (from outside) of the constructor application,
      say D [Int] Int

    * The data constructor MkT has a (representation) dataConTyCon = DList,
      say where
        data DList a where
          MkT :: a -> DList a (Maybe a)
          ...

    So the dataConTyCon of the data constructor, DList, differs from
    the "outside" type, D. So we can't straightforwardly decompose the
    "outside" type, and we end up in the "_" branch of the case.

    Then we match the dataConOrigResTy of the data constructor against the
    outside type, hoping to get a substitution that tells how to instantiate
    the *representation* type constructor.   This looks a bit delicate to
    me, but it seems to work.
    -}

    -- Soundness checks
    --------------------
    {-
    This is not formalized anywhere, so hold to your seats!
    RTTI in the presence of newtypes can be a tricky and unsound business.

    Example:
    ~~~~~~~~~
    Suppose we are doing RTTI for a partially evaluated
    closure t, the real type of which is t :: MkT Int, for

       newtype MkT a = MkT [Maybe a]

    The table below shows the results of RTTI and the improvement
    calculated for different combinations of evaluatedness and :type t.
    Regard the two first columns as input and the next two as output.

      # |     t     |  :type t  | rtti(t)  | improv.    | result
        ------------------------------------------------------------
      1 |     _     |    t b    |    a     | none       | OK
      2 |     _     |   MkT b   |    a     | none       | OK
      3 |     _     |   t Int   |    a     | none       | OK

      If t is not evaluated at *all*, we are safe.

      4 |  (_ : _)  |    t b    |   [a]    | t = []     | UNSOUND
      5 |  (_ : _)  |   MkT b   |  MkT a   | none       | OK (compensating for the missing newtype)
      6 |  (_ : _)  |   t Int   |  [Int]   | t = []     | UNSOUND

      If a is a minimal whnf, we run into trouble. Note that
      row 5 above does newtype enrichment on the ty_rtty parameter.

      7 | (Just _:_)|    t b    |[Maybe a] | t = [],    | UNSOUND
        |                       |          | b = Maybe a|

      8 | (Just _:_)|   MkT b   |  MkT a   |  none      | OK
      9 | (Just _:_)|   t Int   |   FAIL   |  none      | OK

      And if t is any more evaluated than whnf, we are still in trouble.
      Because constraints are solved in top-down order, when we reach the
      Maybe subterm what we got is already unsound. This explains why the
      row 9 fails to complete.

      10 | (Just _:_)|  t Int  | [Maybe a]   |  FAIL    | OK
      11 | (Just 1:_)|  t Int  | [Maybe Int] |  FAIL    | OK

      We can undo the failure in row 9 by leaving out the constraint
      coming from the type signature of t (i.e., the 2nd column).
      Note that this type information is still used
      to calculate the improvement. But we fail
      when trying to calculate the improvement, as there is no unifier for
      t Int = [Maybe a] or t Int = [Maybe Int].

      Another set of examples with t :: [MkT (Maybe Int)]  \equiv  [[Maybe (Maybe Int)]]

      # |     t     |    :type t    |  rtti(t)    | improvement | result
        ---------------------------------------------------------------------
      1 |(Just _:_) | [t (Maybe a)] | [[Maybe b]] | t = []      |
        |           |               |             | b = Maybe a |

    The checks:
    ~~~~~~~~~~~
    Consider a function obtainType that takes a value and a type and produces
    the Term representation and a substitution (the improvement).
    Assume an auxiliar rtti' function which does the actual job if recovering
    the type, but which may produce a false type.

    In pseudocode:

      rtti' :: a -> IO Type  -- Does not use the static type information

      obtainType :: a -> Type -> IO (Maybe (Term, Improvement))
      obtainType v old_ty = do
           rtti_ty <- rtti' v
           if monomorphic rtti_ty || (check rtti_ty old_ty)
            then ...
             else return Nothing
      where check rtti_ty old_ty = check1 rtti_ty &&
                                  check2 rtti_ty old_ty

      check1 :: Type -> Bool
      check2 :: Type -> Type -> Bool

    Now, if rtti' returns a monomorphic type, we are safe.
    If that is not the case, then we consider two conditions.

    1. To prevent the class of unsoundness displayed by
       rows 4 and 7 in the example: no higher kind tyvars
       accepted.

      check1 (t a)   = NO
      check1 (t Int) = NO
      check1 ([] a)  = YES

    2. To prevent the class of unsoundness shown by row 6,
       the rtti type should be structurally more
       defined than the old type we are comparing it to.
      check2 :: NewType -> OldType -> Bool
      check2 a  _        = True
      check2 [a] a       = True
      check2 [a] (t Int) = False
      check2 [a] (t a)   = False  -- By check1 we never reach this equation
      check2 [Int] a     = True
      check2 [Int] (t Int) = True
      check2 [Maybe a]   (t Int) = False
      check2 [Maybe Int] (t Int) = True
      check2 (Maybe [a])   (m [Int]) = False
      check2 (Maybe [Int]) (m [Int]) = True

    -}

    check1 :: [TyVar] -> Bool
    check1 :: [TyVar] -> Bool
    check1 [TyVar]
    tvs = Bool -> Bool
    not (Bool -> Bool) -> Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $ (Type -> Bool) -> [Type] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any Type -> Bool
    isHigherKind ((TyVar -> Type) -> [TyVar] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVar -> Type
    tyVarKind [TyVar]
    tvs)
     where
       isHigherKind :: Type -> Bool
    isHigherKind = Bool -> Bool
    not (Bool -> Bool) -> (Type -> Bool) -> Type -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [TyCoBinder] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null ([TyCoBinder] -> Bool) -> (Type -> [TyCoBinder]) -> Type -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ([TyCoBinder], Type) -> [TyCoBinder]
    forall a b. (a, b) -> a
    fst (([TyCoBinder], Type) -> [TyCoBinder])
    -> (Type -> ([TyCoBinder], Type)) -> Type -> [TyCoBinder]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Type -> ([TyCoBinder], Type)
    splitPiTys

    check2 :: Type -> Type -> Bool
    check2 :: Type -> Type -> Bool
    check2 Type
    rtti_ty Type
    old_ty = Type -> Type -> Bool
    check2' (Type -> Type
    tauPart Type
    rtti_ty) (Type -> Type
    tauPart Type
    old_ty)
      -- The function `tcSplitTyConApp_maybe` doesn't split foralls or types
      -- headed with (=>). Hence here we need only the tau part of a type.
      -- See Note [Missing test case].
      where
        check2' :: Type -> Type -> Bool
    check2' Type
    rtti_ty Type
    old_ty
          | Just (TyCon
    _, [Type]
    rttis) <- HasCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    tcSplitTyConApp_maybe Type
    rtti_ty
          = case () of
              ()
    _ | Just (TyCon
    _,[Type]
    olds) <- HasCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    tcSplitTyConApp_maybe Type
    old_ty
                -> [Bool] -> Bool
    forall (t :: * -> *). Foldable t => t Bool -> Bool
    and([Bool] -> Bool) -> [Bool] -> Bool
    forall a b. (a -> b) -> a -> b
    $ (Type -> Type -> Bool) -> [Type] -> [Type] -> [Bool]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith Type -> Type -> Bool
    check2 [Type]
    rttis [Type]
    olds
              ()
    _ | Just (Type, Type)
    _ <- Type -> Maybe (Type, Type)
    splitAppTy_maybe Type
    old_ty
                -> Type -> Bool
    isMonomorphicOnNonPhantomArgs Type
    rtti_ty
              ()
    _ -> Bool
    True
          | Bool
    otherwise = Bool
    True
        tauPart :: Type -> Type
    tauPart Type
    ty = Type
    tau
          where
            ([TyVar]
    _, [Type]
    _, Type
    tau) = Type -> ([TyVar], [Type], Type)
    tcSplitNestedSigmaTys Type
    ty
    {-
    Note [Missing test case]
    ~~~~~~~~~~~~~~~~~~~~~~~~
    Her we miss a test case. It should be a term, with a function `f`
    with a non-empty sigma part and an unsound type. The result of
    `check2 f` should be different if we omit or do the calls to `tauPart`.
    I (R.Senn) was unable to find such a term, and I'm in doubt, whether it exists.
    -}

    -- Dealing with newtypes
    --------------------------
    {-
     congruenceNewtypes does a parallel fold over two Type values,
     compensating for missing newtypes on both sides.
     This is necessary because newtypes are not present
     in runtime, but sometimes there is evidence available.
       Evidence can come from DataCon signatures or
     from compile-time type inference.
     What we are doing here is an approximation
     of unification modulo a set of equations derived
     from newtype definitions. These equations should be the
     same as the equality coercions generated for newtypes
     in System Fc. The idea is to perform a sort of rewriting,
     taking those equations as rules, before launching unification.

     The caller must ensure the following.
     The 1st type (lhs) comes from the heap structure of ptrs,nptrs.
     The 2nd type (rhs) comes from a DataCon type signature.
     Rewriting (i.e. adding/removing a newtype wrapper) can happen
     in both types, but in the rhs it is restricted to the result type.

       Note that it is very tricky to make this 'rewriting'
     work with the unification implemented by TcM, where
     substitutions are operationally inlined. The order in which
     constraints are unified is vital as we cannot modify
     anything that has been touched by a previous unification step.
    Therefore, congruenceNewtypes is sound only if the types
    recovered by the RTTI mechanism are unified Top-Down.
    -}
    congruenceNewtypes ::  TcType -> TcType -> TR (TcType,TcType)
    congruenceNewtypes :: Type -> Type -> TR (Type, Type)
    congruenceNewtypes Type
    lhs Type
    rhs = Type -> Type -> TR Type
    go Type
    lhs Type
    rhs TR Type -> (Type -> TR (Type, Type)) -> TR (Type, Type)
    forall a b.
    IOEnv (Env TcGblEnv TcLclEnv) a
    -> (a -> IOEnv (Env TcGblEnv TcLclEnv) b)
    -> IOEnv (Env TcGblEnv TcLclEnv) b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \Type
    rhs' -> (Type, Type) -> TR (Type, Type)
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Type
    lhs,Type
    rhs')
     where
       go :: Type -> Type -> TR Type
    go Type
    l Type
    r
     -- TyVar lhs inductive case
        | Just TyVar
    tv <- Type -> Maybe TyVar
    getTyVar_maybe Type
    l
        , TyVar -> Bool
    isTcTyVar TyVar
    tv
        , TyVar -> Bool
    isMetaTyVar TyVar
    tv
        = TR Type -> TR Type -> TR Type
    forall a. TR a -> TR a -> TR a
    recoverTR (Type -> TR Type
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    r) (TR Type -> TR Type) -> TR Type -> TR Type
    forall a b. (a -> b) -> a -> b
    $ do
             Indirect Type
    ty_v <- TyVar -> TcM MetaDetails
    readMetaTyVar TyVar
    tv
             SDoc -> TR ()
    traceTR (SDoc -> TR ()) -> SDoc -> TR ()
    forall a b. (a -> b) -> a -> b
    $ [SDoc] -> SDoc
    fsep [String -> SDoc
    text String
    "(congruence) Following indirect tyvar:",
                              TyVar -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TyVar
    tv, SDoc
    equals, Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    ty_v]
             Type -> Type -> TR Type
    go Type
    ty_v Type
    r
    -- FunTy inductive case
        | Just (Type
    w1,Type
    l1,Type
    l2) <- Type -> Maybe (Type, Type, Type)
    splitFunTy_maybe Type
    l
        , Just (Type
    w2,Type
    r1,Type
    r2) <- Type -> Maybe (Type, Type, Type)
    splitFunTy_maybe Type
    r
        , Type
    w1 Type -> Type -> Bool
    `eqType` Type
    w2
        = do Type
    r2' <- Type -> Type -> TR Type
    go Type
    l2 Type
    r2
             Type
    r1' <- Type -> Type -> TR Type
    go Type
    l1 Type
    r1
             Type -> TR Type
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Type -> Type -> Type -> Type
    mkVisFunTy Type
    w1 Type
    r1' Type
    r2')
    -- TyconApp Inductive case; this is the interesting bit.
        | Just (TyCon
    tycon_l, [Type]
    _) <- HasCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    tcSplitTyConApp_maybe Type
    lhs
        , Just (TyCon
    tycon_r, [Type]
    _) <- HasCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    tcSplitTyConApp_maybe Type
    rhs
        , TyCon
    tycon_l TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    /= TyCon
    tycon_r
        = TyCon -> Type -> TR Type
    upgrade TyCon
    tycon_l Type
    r

        | Bool
    otherwise = Type -> TR Type
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    r

        where upgrade :: TyCon -> Type -> TR Type
              upgrade :: TyCon -> Type -> TR Type
    upgrade TyCon
    new_tycon Type
    ty
                | Bool -> Bool
    not (TyCon -> Bool
    isNewTyCon TyCon
    new_tycon) = do
                  SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "(Upgrade) Not matching newtype evidence: " SDoc -> SDoc -> SDoc
    <>
                           TyCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TyCon
    new_tycon SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text String
    " for " SDoc -> SDoc -> SDoc
    <> Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    ty)
                  Type -> TR Type
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    ty
                | Bool
    otherwise = do
                   SDoc -> TR ()
    traceTR (String -> SDoc
    text String
    "(Upgrade) upgraded " SDoc -> SDoc -> SDoc
    <> Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    ty SDoc -> SDoc -> SDoc
    <>
                            String -> SDoc
    text String
    " in presence of newtype evidence " SDoc -> SDoc -> SDoc
    <> TyCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TyCon
    new_tycon)
                   (TCvSubst
    _, [TyVar]
    vars) <- [TyVar] -> TR (TCvSubst, [TyVar])
    instTyVars (TyCon -> [TyVar]
    tyConTyVars TyCon
    new_tycon)
                   let ty' :: Type
    ty' = TyCon -> [Type] -> Type
    mkTyConApp TyCon
    new_tycon ([TyVar] -> [Type]
    mkTyVarTys [TyVar]
    vars)
                       rep_ty :: Type
    rep_ty = Type -> Type
    unwrapType Type
    ty'
                   TcCoercionN
    _ <- TcM TcCoercionN -> TcM TcCoercionN
    forall a. TcM a -> TcM a
    liftTcM (Maybe TypedThing -> Type -> Type -> TcM TcCoercionN
    unifyType Maybe TypedThing
    forall a. Maybe a
    Nothing Type
    ty Type
    rep_ty)
            -- assumes that reptype doesn't ^^^^ touch tyconApp args
                   Type -> TR Type
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    ty'

    zonkTerm :: Term -> TcM Term
    zonkTerm :: Term -> TR Term
    zonkTerm = TermFoldM (IOEnv (Env TcGblEnv TcLclEnv)) Term -> Term -> TR Term
    forall (m :: * -> *) a. Monad m => TermFoldM m a -> Term -> m a
    foldTermM (TermFoldM
                 { fTermM :: TermProcessor Term (TR Term)
    fTermM = \Type
    ty Either String DataCon
    dc ForeignHValue
    v [Term]
    tt -> Type -> TR Type
    zonkRttiType Type
    ty    TR Type -> (Type -> TR Term) -> TR Term
    forall a b.
    IOEnv (Env TcGblEnv TcLclEnv) a
    -> (a -> IOEnv (Env TcGblEnv TcLclEnv) b)
    -> IOEnv (Env TcGblEnv TcLclEnv) b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \Type
    ty' ->
                                           Term -> TR Term
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TermProcessor Term Term
    Term Type
    ty' Either String DataCon
    dc ForeignHValue
    v [Term]
    tt)
                 , fSuspensionM :: ClosureType -> Type -> ForeignHValue -> Maybe Name -> TR Term
    fSuspensionM  = \ClosureType
    ct Type
    ty ForeignHValue
    v Maybe Name
    b -> Type -> TR Type
    zonkRttiType Type
    ty TR Type -> (Type -> TR Term) -> TR Term
    forall a b.
    IOEnv (Env TcGblEnv TcLclEnv) a
    -> (a -> IOEnv (Env TcGblEnv TcLclEnv) b)
    -> IOEnv (Env TcGblEnv TcLclEnv) b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \Type
    ty ->
                                                 Term -> TR Term
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ClosureType -> Type -> ForeignHValue -> Maybe Name -> Term
    Suspension ClosureType
    ct Type
    ty ForeignHValue
    v Maybe Name
    b)
                 , fNewtypeWrapM :: Type -> Either String DataCon -> Term -> TR Term
    fNewtypeWrapM = \Type
    ty Either String DataCon
    dc Term
    t -> Type -> TR Type
    zonkRttiType Type
    ty TR Type -> (Type -> TR Term) -> TR Term
    forall a b.
    IOEnv (Env TcGblEnv TcLclEnv) a
    -> (a -> IOEnv (Env TcGblEnv TcLclEnv) b)
    -> IOEnv (Env TcGblEnv TcLclEnv) b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \Type
    ty' ->
                                               Term -> TR Term
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return(Term -> TR Term) -> Term -> TR Term
    forall a b. (a -> b) -> a -> b
    $ Type -> Either String DataCon -> Term -> Term
    NewtypeWrap Type
    ty' Either String DataCon
    dc Term
    t
                 , fRefWrapM :: Type -> Term -> TR Term
    fRefWrapM     = \Type
    ty Term
    t -> (Type -> Term -> Term)
    -> IOEnv (Env TcGblEnv TcLclEnv) (Type -> Term -> Term)
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type -> Term -> Term
    RefWrap  IOEnv (Env TcGblEnv TcLclEnv) (Type -> Term -> Term)
    -> TR Type -> IOEnv (Env TcGblEnv TcLclEnv) (Term -> Term)
    forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
    `ap`
                                            Type -> TR Type
    zonkRttiType Type
    ty IOEnv (Env TcGblEnv TcLclEnv) (Term -> Term) -> TR Term -> TR Term
    forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
    `ap` Term -> TR Term
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Term
    t
                 , fPrimM :: Type -> [Word] -> TR Term
    fPrimM        = (Term -> TR Term
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return(Term -> TR Term) -> ([Word] -> Term) -> [Word] -> TR Term
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .) (([Word] -> Term) -> [Word] -> TR Term)
    -> (Type -> [Word] -> Term) -> Type -> [Word] -> TR Term
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Type -> [Word] -> Term
    Prim })

    zonkRttiType :: TcType -> TcM Type
    -- Zonk the type, replacing any unbound Meta tyvars
    -- by RuntimeUnk skolems, safely out of Meta-tyvar-land
    zonkRttiType :: Type -> TR Type
    zonkRttiType Type
    ty= do { ZonkEnv
    ze <- ZonkFlexi -> TcM ZonkEnv
    mkEmptyZonkEnv ZonkFlexi
    RuntimeUnkFlexi
                        ; ZonkEnv -> Type -> TR Type
    zonkTcTypeToTypeX ZonkEnv
    ze Type
    ty }

    --------------------------------------------------------------------------------
    -- Restore Class predicates out of a representation type
    dictsView :: Type -> Type
    dictsView :: Type -> Type
    dictsView Type
    ty = Type
    ty

    -- Use only for RTTI types
    isMonomorphic :: RttiType -> Bool
    isMonomorphic :: Type -> Bool
    isMonomorphic Type
    ty = Bool
    noExistentials Bool -> Bool -> Bool
    && Bool
    noUniversals
     where ([TyVar]
    tvs, [Type]
    _, Type
    ty')  = Type -> ([TyVar], [Type], Type)
    tcSplitSigmaTy Type
    ty
           noExistentials :: Bool
    noExistentials = Type -> Bool
    noFreeVarsOfType Type
    ty'
           noUniversals :: Bool
    noUniversals   = [TyVar] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [TyVar]
    tvs

    -- Use only for RTTI types
    isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
    isMonomorphicOnNonPhantomArgs :: Type -> Bool
    isMonomorphicOnNonPhantomArgs Type
    ty
      | Just (TyCon
    tc, [Type]
    all_args) <- HasCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    tcSplitTyConApp_maybe (Type -> Type
    unwrapType Type
    ty)
      , [TyVar]
    phantom_vars  <- TyCon -> [TyVar]
    tyConPhantomTyVars TyCon
    tc
      , [Type]
    concrete_args <- [ Type
    arg | (TyVar
    tyv,Type
    arg) <- TyCon -> [TyVar]
    tyConTyVars TyCon
    tc [TyVar] -> [Type] -> [(TyVar, Type)]
    forall a b. [a] -> [b] -> [(a, b)]
    `zip` [Type]
    all_args
                               , TyVar
    tyv TyVar -> [TyVar] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` [TyVar]
    phantom_vars]
      = (Type -> Bool) -> [Type] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Type -> Bool
    isMonomorphicOnNonPhantomArgs [Type]
    concrete_args
      | Just (Type
    _, Type
    ty1, Type
    ty2) <- Type -> Maybe (Type, Type, Type)
    splitFunTy_maybe Type
    ty
      = (Type -> Bool) -> [Type] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Type -> Bool
    isMonomorphicOnNonPhantomArgs [Type
    ty1,Type
    ty2]
      | Bool
    otherwise = Type -> Bool
    isMonomorphic Type
    ty

    tyConPhantomTyVars :: TyCon -> [TyVar]
    tyConPhantomTyVars :: TyCon -> [TyVar]
    tyConPhantomTyVars TyCon
    tc
      | TyCon -> Bool
    isAlgTyCon TyCon
    tc
      , Just [DataCon]
    dcs <- TyCon -> Maybe [DataCon]
    tyConDataCons_maybe TyCon
    tc
      , [TyVar]
    dc_vars  <- (DataCon -> [TyVar]) -> [DataCon] -> [TyVar]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap DataCon -> [TyVar]
    dataConUnivTyVars [DataCon]
    dcs
      = TyCon -> [TyVar]
    tyConTyVars TyCon
    tc [TyVar] -> [TyVar] -> [TyVar]
    forall a. Eq a => [a] -> [a] -> [a]
    \\ [TyVar]
    dc_vars
    tyConPhantomTyVars TyCon
    _ = []

    type QuantifiedType = ([TyVar], Type)
       -- Make the free type variables explicit

    quantifyType :: Type -> QuantifiedType
    -- Find all free and forall'd tyvars and return them
    -- together with the unmodified input type.
    quantifyType :: Type -> QuantifiedType
    quantifyType Type
    ty = ( (TyVar -> Bool) -> [TyVar] -> [TyVar]
    forall a. (a -> Bool) -> [a] -> [a]
    filter TyVar -> Bool
    isTyVar ([TyVar] -> [TyVar]) -> [TyVar] -> [TyVar]
    forall a b. (a -> b) -> a -> b
    $
                        Type -> [TyVar]
    tyCoVarsOfTypeWellScoped Type
    rho
                      , Type
    ty)
      where
        ([TyVar]
    _tvs, [Type]
    _, Type
    rho) = Type -> ([TyVar], [Type], Type)
    tcSplitNestedSigmaTys Type
    ty